--- a/bones.asd Thu Mar 24 15:26:03 2016 +0000
+++ b/bones.asd Thu Mar 24 18:51:08 2016 +0000
@@ -19,6 +19,7 @@
(:file "package")
(:module "src"
:components ((:file "paip")
+ (:file "wam")
; (:file "paip-compiled")
(:file "bones")))))
--- a/package.lisp Thu Mar 24 15:26:03 2016 +0000
+++ b/package.lisp Thu Mar 24 18:51:08 2016 +0000
@@ -2,6 +2,10 @@
(:use #:cl)
(:export #:hello))
+(defpackage #:bones.wam
+ (:use #:cl #:defstar #:bones.utils #:optima)
+ (:import-from #:optima #:match))
+
(defpackage #:bones.paip
(:use #:cl #:defstar #:bones.utils)
(:documentation "Test?")
--- a/src/make-utilities.lisp Thu Mar 24 15:26:03 2016 +0000
+++ b/src/make-utilities.lisp Thu Mar 24 18:51:08 2016 +0000
@@ -3,5 +3,6 @@
(qtlc:save-utils-as "utils.lisp"
:utilities '(:define-constant
:set-equal
- :curry)
+ :curry
+ :switch)
:package "BONES.UTILS")
--- a/src/utils.lisp Thu Mar 24 15:26:03 2016 +0000
+++ b/src/utils.lisp Thu Mar 24 18:51:08 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH) :ensure-package T :package "BONES.UTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.UTILS")
@@ -15,7 +15,9 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY))))
+ :CURRY :STRING-DESIGNATOR
+ :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
+ :SWITCH))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -109,7 +111,101 @@
(lambda (&rest more)
(apply ,fun ,@curries more)))))
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(define-constant set-equal curry)))
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+ ) ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun extract-function-name (spec)
+ "Useful for macros that want to mimic the functional interface for functions
+like `#'eq` and `'eq`."
+ (if (and (consp spec)
+ (member (first spec) '(quote function)))
+ (second spec)
+ spec))
+ ) ; eval-when
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun generate-switch-body (whole object clauses test key &optional default)
+ (with-gensyms (value)
+ (setf test (extract-function-name test))
+ (setf key (extract-function-name key))
+ (when (and (consp default)
+ (member (first default) '(error cerror)))
+ (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+ ,value ',test)))
+ `(let ((,value (,key ,object)))
+ (cond ,@(mapcar (lambda (clause)
+ (if (member (first clause) '(t otherwise))
+ (progn
+ (when default
+ (error "Multiple default clauses or illegal use of a default clause in ~S."
+ whole))
+ (setf default `(progn ,@(rest clause)))
+ '(()))
+ (destructuring-bind (key-form &body forms) clause
+ `((,test ,value ,key-form)
+ ,@forms))))
+ clauses)
+ (t ,default))))))
+
+ (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of `default` if no keys match."
+ (generate-switch-body whole object clauses test key))
+
+ (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like `switch`, but signals an error if no key matches."
+ (generate-switch-body whole object clauses test key '(error)))
+
+ (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like `switch`, but signals a continuable error if no key matches."
+ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(define-constant set-equal curry switch eswitch cswitch)))
;;;; END OF utils.lisp ;;;;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wam.lisp Thu Mar 24 18:51:08 2016 +0000
@@ -0,0 +1,143 @@
+(in-package #:bones.wam)
+
+(declaim (optimize (safety 3) (debug 3)))
+
+;;;; Utilities
+(defun pb (b)
+ (format t "~B~%" b))
+
+
+;;;; Heap Cells
+(define-constant +cell-width+ 16
+ :documentation "Number of bits in each heap cell.")
+
+(define-constant +cell-tag-width+ 2
+ :documentation "Number of bits reserved for cell type tags.")
+
+(define-constant +cell-value-width+ (- +cell-width+ +cell-tag-width+)
+ :documentation "Number of bits reserved for cell values.")
+
+(define-constant +cell-tag-bitmask+ (1- (ash 1 +cell-tag-width+))
+ :documentation "Bitmask for masking the cell type tags.")
+
+(define-constant +tag-null+ #b00
+ :documentation "An empty cell.")
+
+(define-constant +tag-structure+ #b01
+ :documentation "A structure cell.")
+
+(define-constant +tag-reference+ #b10
+ :documentation "A pointer to a cell.")
+
+(define-constant +tag-symbol+ #b11
+ :documentation "A constant symbol.")
+
+
+(deftype heap-cell ()
+ `(unsigned-byte ,+cell-width+))
+
+(deftype heap-cell-tag ()
+ `(unsigned-byte ,+cell-tag-width+))
+
+(deftype heap-cell-value ()
+ `(unsigned-byte ,+cell-value-width+))
+
+
+(defun* cell-type ((cell heap-cell))
+ (:returns heap-cell-tag)
+ (logand cell +cell-tag-bitmask+))
+
+(defun* cell-value ((cell heap-cell))
+ (:returns heap-cell-value)
+ (ash cell (- +cell-tag-bit-length+)))
+
+
+(defun* cell-type-name ((cell heap-cell))
+ (:returns string)
+ (eswitch ((cell-type cell) :test #'=)
+ (+tag-null+ "NULL")
+ (+tag-structure+ "STRUCTURE")
+ (+tag-reference+ "REFERENCE")
+ (+tag-symbol+ "SYMBOL")))
+
+(defun* cell-type-short-name ((cell heap-cell))
+ (:returns string)
+ (eswitch ((cell-type cell) :test #'=)
+ (+tag-null+ "NUL")
+ (+tag-structure+ "STR")
+ (+tag-reference+ "REF")
+ (+tag-symbol+ "SYM")))
+
+
+(defun* make-cell ((tag heap-cell-tag) (value heap-cell-value))
+ (:returns heap-cell)
+ (logior (ash value +cell-tag-bit-length+)
+ tag))
+
+(defun* make-cell-null ()
+ (:returns heap-cell)
+ (make-cell +tag-null+ 0))
+
+(defun* make-cell-structure ((value heap-cell-value))
+ (:returns heap-cell)
+ (make-cell +tag-structure+ value))
+
+(defun* make-cell-reference ((value heap-cell-value))
+ (:returns heap-cell)
+ (make-cell +tag-reference+ value))
+
+(defun* make-cell-symbol ((value heap-cell-value))
+ (:returns heap-cell)
+ (make-cell +tag-symbol+ value))
+
+
+;;;; Heap
+(deftype heap-index ()
+ `(integer 0 ,array-total-size-limit))
+
+(defparameter *heap*
+ (make-array 16
+ :initial-element (make-cell-null)
+ :element-type 'heap-cell))
+
+(defun dump-heap (heap from to highlight)
+ (format t "~%Dumping heap...~%")
+ (format t "Heap size: ~A~%~%" (length heap))
+ (format t "+------+-----+--------------+~%")
+ (format t "| ADDR | TYP | VALUE |~%")
+ (format t "+------+-----+--------------+~%")
+ (flet ((print-cell
+ (i cell)
+ (format t "| ~4@A | ~A | ~12@A |~A~%"
+ i
+ (cell-type-short-name cell)
+ (cell-value cell)
+ (if (= i highlight) " <===" ""))))
+ (loop :for i :from from :below to
+ :do (print-cell i (aref heap i))))
+ (format t "+------+-----+--------------+~%")
+ (values))
+
+(defun dump-heap-full (heap)
+ (dump-heap heap 0 (length heap) -1))
+
+(defun dump-heap-around (heap addr width)
+ (dump-heap heap
+ (max 0 (- addr width))
+ (min (length heap) (+ addr width 1))
+ addr))
+
+
+(setf (aref *heap* 0) (make-cell-structure 12))
+(setf (aref *heap* 1) (make-cell-reference 42))
+(setf (aref *heap* 2) (make-cell-symbol 112))
+
+(dump-heap-full *heap*)
+
+
+;;;; Terms
+(defparameter p
+ '(p :z
+ (h :z :w)
+ (f :w)))
+