X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8db2259b25024c83cda8a1d0869b282d115983d7..01868954eb076e618ed5b9f9425e428628e9fdbf:/src/codegen-proto.lisp

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 2dcd5ad..a3f3e51 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -154,91 +154,165 @@
    If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
    symbols."
 
-  (multiple-value-bind (bvl cooked raw)
+  (multiple-value-bind (bvl public private)
+      ;; The hard part of this is digging through the BVL to find the slot
+      ;; names.  Collect them into an actual BVL which will be acceptable to
+      ;; `defun', and (matching) lists of the PUBLIC and PRIVATE names of the
+      ;; slots.
+
       (let ((state :mandatory)
 	    (bvl (make-list-builder))
-	    (cooked (make-list-builder))
-	    (raw (make-list-builder)))
+	    (public (make-list-builder))
+	    (private (make-list-builder)))
+
 	(labels ((recurse-arg (arg path)
+		   ;; Figure out the argument name in ARG, which might be a
+		   ;; symbol or a list with the actual argument name buried
+		   ;; in it somewhere.  Once we've found it, return the
+		   ;; appropriate entries to add to the BVL, PUBLIC, and
+		   ;; PRIVATE lists.
+		   ;;
+		   ;; The PATH indicates a route to take through the tree to
+		   ;; find the actual argument name: it's a list of
+		   ;; nonnegative integers, one for each level of structure:
+		   ;; the integer indicates which element of the list at that
+		   ;; level to descend into to find the argument name
+		   ;; according to the usual BVL syntax.  It's always
+		   ;; acceptable for a level to actually be a symbol, which
+		   ;; is then the argument name we were after.  If we reach
+		   ;; the bottom and we still have a list, then it must be a
+		   ;; (PUBLIC PRIVATE) pair.
+
 		   (cond ((symbolp arg)
+			  ;; We've bottommed out at a symbol.  If it starts
+			  ;; with a `%' then that's the private name: strip
+			  ;; the `%' to find the public name.  Otherwise, the
+			  ;; symbol is all we have.
+
 			  (let ((name (symbol-name arg)))
 			    (if (and (plusp (length name))
 				     (char= (char name 0) #\%))
-				(let ((cooked (intern (subseq name 1))))
-				  (values cooked cooked arg))
+				(let ((public (intern (subseq name 1))))
+				  (values public public arg))
 				(values arg arg arg))))
+
 			 ((atom arg)
+			  ;; Any other kind of atom is obviously bogus.
 			  (error "Unexpected item ~S in lambda-list." arg))
+
 			 ((null path)
-			  (multiple-value-bind (cooked raw)
+			  ;; We've bottommed out of the path and still have a
+			  ;; list.  It must be (PUBLIC PRIVATE).
+
+			  (multiple-value-bind (public private)
 			      (if (cdr arg) (values (car arg) (cadr arg))
 				  (values (car arg) (car arg)))
-			    (values cooked cooked raw)))
+			    (values public public private)))
+
 			 (t
+			  ;; We have a list.  Take the first step in the
+			  ;; PATH, and recursively process corresponding list
+			  ;; element with the remainder of the PATH.  The
+			  ;; PUBLIC and PRIVATE slot names are fine, but we
+			  ;; must splice the given BVL entry into our list
+			  ;; structure.
+
 			  (let* ((step (car path))
 				 (mine (nthcdr step arg)))
-			    (multiple-value-bind (full cooked raw)
+			    (multiple-value-bind (full public private)
 				(recurse-arg (car mine) (cdr path))
 			      (values (append (subseq arg 0 step)
 					      full
 					      (cdr mine))
-				      cooked
-				      raw))))))
+				      public
+				      private))))))
+
 		 (hack-arg (arg maxdp)
-		   (multiple-value-bind (full cooked-name raw-name)
+		   ;; Find the actual argument name in a BVL entry, and add
+		   ;; the appropriate entries to the `bvl', `public', and
+		   ;; `private' lists.
+
+		   (multiple-value-bind (full public-name private-name)
 		       (recurse-arg arg maxdp)
 		     (lbuild-add bvl full)
-		     (lbuild-add cooked cooked-name)
-		     (lbuild-add raw raw-name))))
-	(dolist (arg args)
-	  (cond ((or (eq arg '&optional)
-		     (eq arg '&rest)
-		     (eq arg '&key)
-		     (eq arg '&aux))
-		 (setf state arg)
-		 (lbuild-add bvl arg))
-		((eq arg '&allow-other-keys)
-		 (lbuild-add bvl arg))
-		((or (eq state :mandatory)
-		     (eq state '&rest))
-		 (hack-arg arg '()))
-		((or (eq state '&optional)
-		     (eq state '&aux))
-		 (hack-arg arg '(0)))
-		((eq state '&key)
-		 (hack-arg arg '(0 1)))
-		(t
-		 (error "Confusion in ~S!" 'definst)))))
+		     (lbuild-add public public-name)
+		     (lbuild-add private private-name))))
+
+	  ;; Process the augmented BVL, extracting a standard BVL suitable
+	  ;; for `defun', and the public and private slot names into our
+	  ;; list.
+	  (dolist (arg args)
+	    (cond ((or (eq arg '&optional)
+		       (eq arg '&rest)
+		       (eq arg '&key)
+		       (eq arg '&aux))
+		   (setf state arg)
+		   (lbuild-add bvl arg))
+
+		  ((eq arg '&allow-other-keys)
+		   (lbuild-add bvl arg))
+
+		  ((or (eq state :mandatory)
+		       (eq state '&rest))
+		   (hack-arg arg '()))
+
+		  ((or (eq state '&optional)
+		       (eq state '&aux))
+		   (hack-arg arg '(0)))
+
+		  ((eq state '&key)
+		   (hack-arg arg '(0 1)))
+
+		  (t
+		   (error "Confusion in ~S!" 'definst)))))
+
+	;; Done!  That was something of a performance.
 	(values (lbuild-list bvl)
-		(lbuild-list cooked)
-		(lbuild-list raw)))
+		(lbuild-list public)
+		(lbuild-list private)))
+
+    ;; Now we can actually build the pieces of the code-generation machinery.
     (let* ((inst-var (gensym "INST"))
 	   (class-name (symbolicate code '-inst))
 	   (constructor-name (symbolicate 'make- code '-inst))
 	   (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
-			 cooked)))
+			 public)))
+
+      ;; We have many jobs to do in the expansion.
       `(progn
+
+	 ;; A class to hold the data.
 	 (defclass ,class-name (inst)
-	   ,(mapcar (lambda (cooked-slot raw-slot key)
-		      `(,raw-slot :initarg ,key
-			      :reader ,(symbolicate 'inst- cooked-slot)))
-		    cooked raw keys))
+	   ,(mapcar (lambda (public-slot private-slot key)
+		      `(,private-slot :initarg ,key
+			      :reader ,(symbolicate 'inst- public-slot)))
+		    public private keys))
+
+	 ;; A constructor to make an instance of the class.
 	 (defun ,constructor-name (,@bvl)
-	   (make-instance ',class-name ,@(mappend #'list keys cooked)))
+	   (make-instance ',class-name ,@(mappend #'list keys public)))
+
+	 ;; A method on `inst-metric', to feed into inlining heuristics.
 	 (defmethod inst-metric ((,inst-var ,class-name))
-	   (with-slots (,@raw) ,inst-var
-	     (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) raw))))
+	   (with-slots (,@private) ,inst-var
+	     (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) private))))
+
+	 ;; A method to actually produce the necessary output.
 	 (defmethod print-object ((,inst-var ,class-name) ,streamvar)
-	   (with-slots ,(mapcar #'list cooked raw) ,inst-var
+	   (with-slots ,(mapcar #'list public private) ,inst-var
 	     (if *print-escape*
 		 (print-unreadable-object (,inst-var ,streamvar :type t)
-		   (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
-			   ,@(mappend #'list keys cooked)))
+		   (format ,streamvar "~@<~@{~S ~@_~S~^ ~_~}~:>"
+			   ,@(mappend #'list keys public)))
 		 (block ,code ,@body))))
+
+	 ;; Maybe export all of this stuff.
 	 ,@(and export `((export '(,class-name ,constructor-name
 				   ,@(mapcar (lambda (slot)
 					       (symbolicate 'inst- slot))
-					     cooked)))))
+					     public)))))
+
+	 ;; And try not to spam a REPL.
 	 ',code))))
 
 ;; Formatting utilities.
@@ -282,10 +356,6 @@
 
 ;; Important instruction classes.
 
-;; HACK: Some of the slot names we'd like to use are external symbols in our
-;; package or the `common-lisp' package.  Use gensyms for these slot names to
-;; prevent them from leaking.
-
 (definst var (stream :export t) (name %type &optional init)
   (pprint-logical-block (stream nil)
     (pprint-c-type type stream name)