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

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 831b23c..a3f3e51 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -66,6 +66,10 @@
   (make-instance 'temporary-name :tag "sod__tmp_ap"))
 (defparameter *sod-tmp-val*
   (make-instance 'temporary-name :tag "sod__t"))
+(defparameter *sod-keywords*
+  (make-instance 'temporary-name :tag "sod__kw"))
+(defparameter *sod-key-pointer*
+  (make-instance 'temporary-name :tag "sod__keys"))
 
 (export '*null-pointer*)
 (defparameter *null-pointer* "NULL")
@@ -135,45 +139,181 @@
        otherwise.  The BODY is expected to produce target code at this
        point.
 
+   The ARGS are an ordinary lambda-list, with the following quirks:
+
+     * Where an argument-name symbol is expected (as opposed to a list), a
+       list (ARG SLOT) may be written instead.  This allows the slots to be
+       named independently of the argument names, which is handy if they'd
+       otherwise conflict with exported symbol names.
+
+     * If an argument name begins with a `%' character, then the `%' is
+       stripped off, except when naming the actual slot.  Hence, `%FOO' is
+       equivalent to a list `(FOO %FOO)', except that a `%'-symbol can be
+       used even where the lambda-list syntax permits a list.
+
    If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
    symbols."
 
-  (let* ((inst-var (gensym "INST"))
-	 (class-name (symbolicate code '-inst))
-	 (constructor-name (symbolicate 'make- code '-inst))
-	 (slots (mapcan (lambda (arg)
-			  (if (listp arg) (list (car arg))
-			      (let ((name (symbol-name arg)))
-				(if (and (plusp (length name))
-					 (char/= (char name 0) #\&))
-				    (list arg)
-				    nil))))
-			args))
-	 (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
-		       slots)))
-    `(progn
-       (defclass ,class-name (inst)
-	 ,(mapcar (lambda (slot key)
-		    `(,slot :initarg ,key
-			    :reader ,(symbolicate 'inst- slot)))
-		  slots keys))
-       (defun ,constructor-name (,@args)
-	 (make-instance ',class-name ,@(mappend #'list keys slots)))
-       (defmethod inst-metric ((,inst-var ,class-name))
-	 (with-slots (,@slots) ,inst-var
-	   (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) slots))))
-       (defmethod print-object ((,inst-var ,class-name) ,streamvar)
-	 (with-slots (,@slots) ,inst-var
-	   (if *print-escape*
-	       (print-unreadable-object (,inst-var ,streamvar :type t)
-		 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
-			 ,@(mappend #'list keys slots)))
-	       (block ,code ,@body))))
-       ,@(and export `((export '(,class-name ,constructor-name
-				 ,@(mapcar (lambda (slot)
-					     (symbolicate 'inst- slot))
-					   slots)))))
-       ',code)))
+  (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))
+	    (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 ((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)
+			  ;; 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 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 public private)
+				(recurse-arg (car mine) (cdr path))
+			      (values (append (subseq arg 0 step)
+					      full
+					      (cdr mine))
+				      public
+				      private))))))
+
+		 (hack-arg (arg maxdp)
+		   ;; 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 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 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))
+			 public)))
+
+      ;; We have many jobs to do in the expansion.
+      `(progn
+
+	 ;; A class to hold the data.
+	 (defclass ,class-name (inst)
+	   ,(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 public)))
+
+	 ;; A method on `inst-metric', to feed into inlining heuristics.
+	 (defmethod inst-metric ((,inst-var ,class-name))
+	   (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 public private) ,inst-var
+	     (if *print-escape*
+		 (print-unreadable-object (,inst-var ,streamvar :type t)
+		   (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))
+					     public)))))
+
+	 ;; And try not to spam a REPL.
+	 ',code))))
 
 ;; Formatting utilities.
 
@@ -216,44 +356,40 @@
 
 ;; 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 #1=#:type &optional init)
+(definst var (stream :export t) (name %type &optional init)
   (pprint-logical-block (stream nil)
-    (pprint-c-type #1# stream name)
+    (pprint-c-type type stream name)
     (when init
       (format stream " = ~2I~_~A" init))
     (write-char #\; stream)))
 
 (definst function (stream :export t)
-    (name #1=#:type body &optional #2=#:banner &rest banner-args)
+    (name %type body &optional %banner &rest banner-args)
   (pprint-logical-block (stream nil)
-    (when #2#
-      (apply #'format-banner-comment stream #2# banner-args)
+    (when banner
+      (apply #'format-banner-comment stream banner banner-args)
       (pprint-newline :mandatory stream))
     (princ "static " stream)
-    (pprint-c-type #1# stream name)
+    (pprint-c-type type stream name)
     (format stream "~:@_~A~:@_~:@_" body)))
 
 ;; Expression statements.
-(definst expr (stream :export t) (#1=#:expr)
-  (format stream "~A;" #1#))
-(definst set (stream :export t) (var #1=#:expr)
-  (format stream "~@<~A = ~2I~_~A;~:>" var #1#))
-(definst update (stream :export t) (var op #1=#:expr)
-  (format stream "~@<~A ~A= ~2I~_~A;~:>" var op #1#))
+(definst expr (stream :export t) (%expr)
+  (format stream "~A;" expr))
+(definst set (stream :export t) (var %expr)
+  (format stream "~@<~A = ~2I~_~A;~:>" var expr))
+(definst update (stream :export t) (var op %expr)
+  (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr))
 
 ;; Special kinds of expressions.
-(definst call (stream :export t) (#1=#:func &rest args)
-  (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" #1# args))
-(definst cond (stream :export t) (#1=#:cond conseq alt)
-  (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" #1# conseq alt))
+(definst call (stream :export t) (%func &rest args)
+  (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args))
+(definst cond (stream :export t) (%cond conseq alt)
+  (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
 
 ;; Simple statements.
-(definst return (stream :export t) (#1=#:expr)
-  (format stream "return~@[ (~A)~];" #1#))
+(definst return (stream :export t) (%expr)
+  (format stream "return~@[ (~A)~];" expr))
 (definst break (stream :export t) ()
   (format stream "break;"))
 (definst continue (stream :export t) ()
@@ -300,33 +436,33 @@
   (pprint-newline :mandatory stream)
   (write-char #\} stream))
 
-(definst if (stream :export t) (#1=#:cond conseq &optional alt)
+(definst if (stream :export t) (%cond conseq &optional alt)
   (let ((stmt "if"))
     (loop (format-compound-statement (stream conseq (if alt t nil))
-	    (format stream "~A (~A)" stmt #1#))
+	    (format stream "~A (~A)" stmt cond))
 	  (typecase alt
 	    (null (return))
 	    (if-inst (setf stmt "else if"
-			   #1# (inst-cond alt)
+			   cond (inst-cond alt)
 			   conseq (inst-conseq alt)
 			   alt (inst-alt alt)))
 	    (t (format-compound-statement (stream alt)
 		 (format stream "else"))
 	       (return))))))
 
-(definst while (stream :export t) (#1=#:cond body)
+(definst while (stream :export t) (%cond body)
   (format-compound-statement (stream body)
-    (format stream "while (~A)" #1#)))
+    (format stream "while (~A)" cond)))
 
-(definst do-while (stream :export t) (body #1=#:cond)
+(definst do-while (stream :export t) (body %cond)
   (format-compound-statement (stream body :space)
     (write-string "do" stream))
-  (format stream "while (~A);" #1#))
+  (format stream "while (~A);" cond))
 
-(definst for (stream :export t) (init #1=#:cond update body)
+(definst for (stream :export t) (init %cond update body)
   (format-compound-statement (stream body)
     (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
-	    init #1# update)))
+	    init cond update)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation.