--- a/.lispwords Fri Jul 15 19:37:17 2016 +0000
+++ b/.lispwords Fri Jul 15 20:16:26 2016 +0000
@@ -2,7 +2,6 @@
(1 repeat)
(2 define-instruction define-instructions)
(1 with-database)
-(2 set-when-unbound)
(1 recursively)
(1 when-let)
(1 rule)
--- a/src/wam/compiler/1-parsing.lisp Fri Jul 15 19:37:17 2016 +0000
+++ b/src/wam/compiler/1-parsing.lisp Fri Jul 15 20:16:26 2016 +0000
@@ -7,86 +7,45 @@
;;;; ,|
;;;; `'
-(defclass node () ())
+; todo functor -> fname
+
+(defstruct node)
+
-(defclass top-level-node (node)
- ((functor :accessor node-functor
- :type symbol
- :initarg :functor)
- (arity :accessor node-arity
- :type arity
- :initarg :arity)
- (arguments :accessor node-arguments
- :type list
- :initarg :arguments)))
+(defstruct (top-level-node (:include node))
+ (functor nil :type symbol)
+ (arity 0 :type arity)
+ (arguments nil :type list))
-(defclass vanilla-node (node)
- ((register :accessor node-register
- :type register
- :documentation "The register allocated to store this node.")))
+(defstruct (vanilla-node (:include node)
+ (:conc-name node-))
+ ;; The register allocated to store this node.
+ (register nil :type (or null register)))
-(defclass structure-node (vanilla-node)
- ((functor :accessor node-functor
- :type symbol
- :initarg :functor)
- (arity :accessor node-arity
- :type arity
- :initarg :arity)
- (arguments :accessor node-arguments
- :type list
- :initarg :arguments)))
+(defstruct (structure-node (:include vanilla-node)
+ (:conc-name node-))
+ (functor nil :type symbol)
+ (arity 0 :type arity)
+ (arguments nil :type list))
-(defclass variable-node (vanilla-node)
- ((variable :accessor node-variable
- :type symbol
- :initarg :variable)))
-
-(defclass argument-variable-node (variable-node)
- ((secondary-register
- :accessor node-secondary-register
- :type register
- :documentation
- "The register that actually holds the variable (NOT the argument register).")))
-
-(defclass list-node (vanilla-node)
- ((head :accessor node-head :type node :initarg :head)
- (tail :accessor node-tail :type node :initarg :tail)))
-
-(defclass lisp-object-node (vanilla-node)
- ((object :accessor node-object :type t :initarg :object)))
-
+(defstruct (variable-node (:include vanilla-node)
+ (:conc-name node-))
+ (variable nil :type symbol))
-; todo functor -> fname
-(defun* make-top-level-node ((functor symbol) (arity arity) (arguments list))
- (:returns top-level-node)
- (values (make-instance 'top-level-node
- :functor functor
- :arity arity
- :arguments arguments)))
-
-(defun* make-structure-node ((functor symbol) (arity arity) (arguments list))
- (:returns structure-node)
- (values (make-instance 'structure-node
- :functor functor
- :arity arity
- :arguments arguments)))
+(defstruct (argument-variable-node (:include variable-node)
+ (:conc-name node-))
+ ;; The register that actually holds the variable (NOT the argument register).
+ (secondary-register nil :type (or null register)))
-(defun* make-variable-node ((variable symbol))
- (:returns variable-node)
- (values (make-instance 'variable-node :variable variable)))
-
-(defun* make-argument-variable-node ((variable symbol))
- (:returns variable-node)
- (values (make-instance 'argument-variable-node :variable variable)))
+(defstruct (list-node (:include vanilla-node)
+ (:conc-name node-))
+ (head (error "Head argument required") :type node)
+ (tail (error "Head argument required") :type node))
-(defun* make-list-node ((head node) (tail node))
- (:returns list-node)
- (values (make-instance 'list-node :head head :tail tail)))
-
-(defun* make-lisp-object-node ((object t))
- (:returns lisp-object-node)
- (values (make-instance 'lisp-object-node :object object)))
+(defstruct (lisp-object-node (:include vanilla-node)
+ (:conc-name node-))
+ (object nil :type t))
(defgeneric* node-children (node)
@@ -99,7 +58,7 @@
(list))
(defmethod node-children ((node top-level-node))
- (node-arguments node))
+ (top-level-node-arguments node))
(defmethod node-children ((node structure-node))
(node-arguments node))
@@ -175,12 +134,13 @@
(format t "~A>" (lisp-object-to-string (node-object node))))
(defmethod dump-node ((node top-level-node))
- (format t "#<~A/~D" (node-functor node) (node-arity node))
- (let ((*dump-node-indent* 4))
- (dolist (n (node-arguments node))
- (terpri)
- (dump-node n)))
- (format t ">"))
+ (with-slots (functor arity arguments) node
+ (format t "#<~A/~D" functor arity)
+ (let ((*dump-node-indent* 4))
+ (dolist (n arguments)
+ (terpri)
+ (dump-node n)))
+ (format t ">")))
(defmethod print-object ((node node) stream)
(let ((*standard-output* stream))
@@ -190,25 +150,27 @@
(defun* parse-list ((contents list))
(:returns node)
(if contents
- (make-list-node (parse (car contents))
- (parse-list (cdr contents)))
- (make-structure-node 'nil 0 ())))
+ (make-list-node :head (parse (car contents))
+ :tail (parse-list (cdr contents)))
+ (make-structure-node :functor nil
+ :arity 0
+ :arguments ())))
(defun* parse-list* ((contents list))
(:returns node)
(destructuring-bind (next . remaining) contents
(if (null remaining)
(parse next)
- (make-list-node (parse next)
- (parse-list* remaining)))))
+ (make-list-node :head (parse next)
+ :tail (parse-list* remaining)))))
(defun* parse (term &optional top-level-argument)
(:returns node)
(cond
((variablep term)
(if top-level-argument
- (make-argument-variable-node term)
- (make-variable-node term)))
+ (make-argument-variable-node :variable term)
+ (make-variable-node :variable term)))
((symbolp term)
(parse (list term))) ; c/0 -> (c/0)
((consp term)
@@ -220,11 +182,11 @@
(case functor
(list (parse-list arguments))
(list* (parse-list* arguments))
- (t (make-structure-node functor
- (length arguments)
- (mapcar #'parse arguments))))))
+ (t (make-structure-node :functor functor
+ :arity (length arguments)
+ :arguments (mapcar #'parse arguments))))))
((numberp term)
- (make-lisp-object-node term))
+ (make-lisp-object-node :object term))
(t (error "Cannot parse term ~S into a Prolog term." term))))
(defun* parse-top-level (term)
@@ -236,9 +198,10 @@
(error
"Cannot parse top-level term ~S because ~S is not a valid functor."
term functor))
- (make-top-level-node functor (length arguments)
- (mapcar (lambda (a) (parse a t))
- arguments))))
+ (make-top-level-node :functor functor
+ :arity (length arguments)
+ :arguments (mapcar (lambda (a) (parse a t))
+ arguments))))
(t (error "Cannot parse top-level term ~S into a Prolog term." term))))
--- a/src/wam/compiler/2-register-allocation.lisp Fri Jul 15 19:37:17 2016 +0000
+++ b/src/wam/compiler/2-register-allocation.lisp Fri Jul 15 20:16:26 2016 +0000
@@ -182,10 +182,10 @@
(store-variable state variable)))
-(defmacro set-when-unbound (instance slot value-form)
- (once-only (instance slot)
- `(when (not (slot-boundp ,instance ,slot))
- (setf (slot-value ,instance ,slot) ,value-form))))
+(defmacro set-when-nil ((accessor instance) value-form)
+ (once-only (instance)
+ `(when (not (,accessor ,instance))
+ (setf (,accessor ,instance) ,value-form))))
(defun* variable-anonymous-p ((state allocation-state) (variable symbol))
@@ -219,28 +219,28 @@
(values))
(defmethod allocate-register ((node variable-node) state)
- (set-when-unbound node 'register
- (allocate-variable-register state (node-variable node))))
+ (set-when-nil (node-register node)
+ (allocate-variable-register state (node-variable node))))
(defmethod allocate-register ((node argument-variable-node) state)
- (set-when-unbound node 'secondary-register
- (allocate-variable-register state (node-variable node))))
+ (set-when-nil (node-secondary-register node)
+ (allocate-variable-register state (node-variable node))))
(defmethod allocate-register ((node structure-node) state)
- (set-when-unbound node 'register
- (allocate-nonvariable-register state)))
+ (set-when-nil (node-register node)
+ (allocate-nonvariable-register state)))
(defmethod allocate-register ((node list-node) state)
- (set-when-unbound node 'register
- (allocate-nonvariable-register state)))
+ (set-when-nil (node-register node)
+ (allocate-nonvariable-register state)))
(defmethod allocate-register ((node lisp-object-node) state)
- (set-when-unbound node 'register
- (allocate-nonvariable-register state)))
+ (set-when-nil (node-register node)
+ (allocate-nonvariable-register state)))
(defun* allocate-argument-registers ((node top-level-node))
- (loop :for argument :in (node-arguments node)
+ (loop :for argument :in (top-level-node-arguments node)
:for i :from 0
:do (setf (node-register argument)
(make-register :argument i))))
@@ -250,7 +250,7 @@
&key nead)
;; JESUS TAKE THE WHEEL
(let*
- ((actual-arity (node-arity node))
+ ((actual-arity (top-level-node-arity node))
(reserved-arity (when nead
(clause-nead-arity clause-props)))
(reserved-variables (when nead
--- a/src/wam/compiler/4-tokenization.lisp Fri Jul 15 19:37:17 2016 +0000
+++ b/src/wam/compiler/4-tokenization.lisp Fri Jul 15 20:16:26 2016 +0000
@@ -146,9 +146,10 @@
flatten-query
tokenize-assignments
;; We need to shove a CALL/JUMP token onto the end.
- (append <> (list (make-instance (if is-tail 'jump-token 'call-token)
- :functor (node-functor tree)
- :arity (node-arity tree)))))))
+ (append <> (list (make-instance
+ (if is-tail 'jump-token 'call-token)
+ :functor (top-level-node-functor tree)
+ :arity (top-level-node-arity tree)))))))