X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/357885be46389c70dc9e7c7859f47af68aeb58ae..refs/heads/mdw/progfmt:/src/codegen-proto.lisp

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 5364f72..0c5040c 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -66,6 +66,13 @@
   (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")
 
 ;;;--------------------------------------------------------------------------
 ;;; Instructions.
@@ -124,76 +131,203 @@
      * Instance slots named after the ARGS, with matching keyword initargs,
        and `inst-ARG' readers.
 
-     * A constructor `make-CODE-inst' which accepts the ARGS (in order, not
-       with keywords) as arguments and returns a fresh instance.
+     * A constructor `make-CODE-inst' which accepts the ARGS (as an ordinary
+       BVL) as arguments and returns a fresh instance.
 
      * A print method, which prints a diagnostic dump if `*print-escape*' is
        set, or invokes the BODY (with STREAMVAR bound to the output stream)
        otherwise.  The BODY is expected to produce target code at this
        point.
 
-   If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
-   symbols."
+   The ARGS are an ordinary lambda-list, with the following quirks:
 
-  (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))
-		      args)))
-    `(progn
-       (defclass ,class-name (inst)
-	 ,(mapcar (lambda (arg key)
-		    `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
-		  args keys))
-       (defun ,constructor-name (,@args)
-	 (make-instance ',class-name ,@(mappend #'list keys args)))
-       (defmethod inst-metric ((,inst-var ,class-name))
-	 (with-slots (,@args) ,inst-var
-	   (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args))))
-       (defmethod print-object ((,inst-var ,class-name) ,streamvar)
-	 (with-slots (,@args) ,inst-var
-	   (if *print-escape*
-	       (print-unreadable-object (,inst-var ,streamvar :type t)
-		 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
-			 ,@(mappend #'list keys args)))
-	       (block ,code ,@body))))
-       ,@(and export `((export '(,class-name ,constructor-name
-				 ,@(mapcar (lambda (arg)
-					     (symbolicate 'inst- arg))
-					   args)))))
-       ',code)))
+     * 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.
 
-;; Important instruction classes.
+     * 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.
 
-;; HACK: use a gensym for the `expr' and `type' slots to avoid leaking the
-;; slot names, since the symbol `expr' is exported from our package and
-;; `type' belongs to the `common-lisp' package.
-
-(definst var (stream :export t) (name #1=#:type init)
-  (pprint-c-type #1# stream name)
-  (when init
-    (format stream " = ~A" init))
-  (write-char #\; stream))
-(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 return (stream :export t) (#1=#:expr)
-  (format stream "return~@[ (~A)~];" #1#))
-(definst break (stream :export t) ()
-  (format stream "break;"))
-(definst continue (stream :export t) ()
-  (format stream "continue;"))
-(definst expr (stream :export t) (#1=#:expr)
-  (format stream "~A;" #1#))
-(definst block (stream :export t) (decls body)
-  (format stream "{~:@_~@<  ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
-	  decls body))
-(definst function (stream :export t) (name #1=#:type body)
-  (pprint-logical-block (stream nil)
-    (princ "static " stream)
-    (pprint-c-type #1# stream name)
-    (format stream "~:@_~A~:@_~:@_" body)))
+   If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
+   symbols."
+
+  (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)))
+      (multiple-value-bind (docs decls body) (parse-body body)
+
+	;; 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
+		     ,@(if (null decls) body
+			   `((locally ,@decls ,@body)))))))
+
+	   ;; Maybe export all of this stuff.
+	   ,@(and export `((export '(,class-name ,constructor-name
+				     ,@(mapcar (lambda (slot)
+						 (symbolicate 'inst- slot))
+					       public)))))
+
+	   ;; Remember the documentation.
+	   ,@(and docs `((setf (get ',class-name 'inst-documentation)
+				 ,@docs)))
+
+	   ;; And try not to spam a REPL.
+	   ',code)))))
+
+(defmethod documentation ((symbol symbol) (doc-type (eql 'inst)))
+  (get symbol 'inst-documentation))
+(defmethod (setf documentation) (doc (symbol symbol) (doc-type (eql 'inst)))
+  (setf (get symbol 'inst-documentation) doc))
 
 ;; Formatting utilities.
 
@@ -211,13 +345,13 @@
 	   (pprint-indent :block 2 stream)
 	   (pprint-newline :linear stream)
 	   (princ child stream)
-	   (pprint-indent :block 0 stream)
-	   (case morep
-	     (:space
-	      (write-char #\space stream)
-	      (pprint-newline :linear stream))
-	     ((t)
-	      (pprint-newline :mandatory stream)))))))
+	   (pprint-indent :block 0 stream))
+	 (case morep
+	   (:space
+	    (write-char #\space stream)
+	    (pprint-newline :linear stream))
+	   ((t)
+	    (pprint-newline :mandatory stream))))))
 
 (export 'format-compound-statement)
 (defmacro format-compound-statement
@@ -230,6 +364,167 @@
   `(format-compound-statement* ,stream ,child ,morep
 			       (lambda (,stream) ,@body)))
 
+(export 'format-banner-comment)
+(defun format-banner-comment (stream control &rest args)
+  "Format a comment, built from a `format' CONTROL string and ARGS.
+
+   The comment is wrapped in the usual `/* ... */' C comment delimiters, and
+   word-wrapped if necessary.  If multiple lines are needed, then a column of
+   `*'s is left down the left hand side, and the final `*/' ends up properly
+   aligned on a line by itself."
+  (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
+
+;; Important instruction classes.
+
+(definst var (stream :export t) (name %type &optional init)
+  "Declare a variable: TYPE NAME [= INIT].
+
+   This usually belongs in the DECLS of a `block'."
+  (pprint-logical-block (stream nil)
+    (pprint-c-type type stream name)
+    (when init
+      (format stream " = ~2I~_~A" init))
+    (write-char #\; stream)))
+
+(definst function (stream :export t)
+    (name %type body &optional %banner &rest banner-args)
+  "Define a function.
+
+   The TYPE must be a function type.  The BANNER and BANNER-ARGS are a
+   `format' control string and its argument list.  Output looks like:
+
+	/* BANNER */
+	TYPE NAME(ARGS-FROM-TYPE)
+	{
+	  BODY
+	}"
+  (pprint-logical-block (stream nil)
+    (when banner
+      (apply #'format-banner-comment stream banner banner-args)
+      (pprint-newline :mandatory stream))
+    (princ "static " stream)
+    (pprint-c-type type stream name)
+    (format stream "~:@_~A~:@_~:@_" body)))
+
+;; Expression statements.
+(definst expr (stream :export t) (%expr)
+  "An expression statement: EXPR;"
+  (format stream "~A;" expr))
+(definst set (stream :export t) (var %expr)
+  "An assignment statement: VAR = EXPR;"
+  (format stream "~@<~A = ~2I~_~A;~:>" var expr))
+(definst update (stream :export t) (var op %expr)
+  "An update statement: VAR OP= EXPR;"
+  (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr))
+
+;; Special kinds of expressions.
+(definst call (stream :export t) (%func &rest args)
+  "A function-call expression: FUNC(ARGS)"
+  (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args))
+(definst cond (stream :export t) (%cond conseq alt)
+  "A conditional expression: COND ? CONSEQ : ALT"
+  (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
+
+;; Simple statements.
+(definst return (stream :export t) (%expr)
+  "A `return' statement: return [(EXPR)];"
+  (format stream "return~@[ (~A)~];" expr))
+(definst break (stream :export t) ()
+  "A `break' statement: break;"
+  (format stream "break;"))
+(definst continue (stream :export t) ()
+  "A `continue' statement: continue;"
+  (format stream "continue;"))
+
+;; Compound statements.
+
+(defvar *first-statement-p* t
+  "True if this is the first statement in a block.
+
+   This is used to communicate between `block-inst' and `banner-inst' so that
+   they get the formatting right between them.")
+
+(definst banner (stream :export t) (control &rest args)
+  "A banner comment, built from a `format' CONTROL string and ARGS.
+
+   See `format-banner-comment' for more details."
+  (pprint-logical-block (stream nil)
+    (unless *first-statement-p* (pprint-newline :mandatory stream))
+    (apply #'format-banner-comment stream control args)))
+
+(export 'emit-banner)
+(defun emit-banner (codegen control &rest args)
+  "Emit a `banner-inst' to CODEGEN, with the given CONTROL and ARGS."
+  (emit-inst codegen (apply #'make-banner-inst control args)))
+
+(definst block (stream :export t) (decls body)
+  "A compound statement.
+
+   The output looks like
+
+	{
+	  DECLS
+
+	  BODY
+	}
+
+   If controlled by `if', `while', etc., then the leading brace ends up on
+   the same line, following K&R conventions."
+  (write-char #\{ stream)
+  (pprint-newline :mandatory stream)
+  (pprint-logical-block (stream nil)
+    (let ((newlinep nil))
+      (flet ((newline ()
+	       (if newlinep
+		   (pprint-newline :mandatory stream)
+		   (setf newlinep t))))
+	(pprint-indent :block 2 stream)
+	(write-string "  " stream)
+	(when decls
+	  (dolist (decl decls)
+	    (newline)
+	    (write decl :stream stream))
+	  (when body (newline)))
+	(let ((*first-statement-p* t))
+	  (dolist (inst body)
+	    (newline)
+	    (write inst :stream stream)
+	    (setf *first-statement-p* nil))))))
+  (pprint-newline :mandatory stream)
+  (write-char #\} stream))
+
+(definst if (stream :export t) (%cond conseq &optional alt)
+  "An `if' statement: if (COND) CONSEQ [else ALT]"
+  (let ((stmt "if"))
+    (loop (format-compound-statement (stream conseq (if alt t nil))
+	    (format stream "~A (~A)" stmt cond))
+	  (typecase alt
+	    (null (return))
+	    (if-inst (setf stmt "else if"
+			   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) (%cond body)
+  "A `while' statement: while (COND) BODY"
+  (format-compound-statement (stream body)
+    (format stream "while (~A)" cond)))
+
+(definst do-while (stream :export t) (body %cond)
+  "A `do'/`while' statement: do BODY while (COND);"
+  (format-compound-statement (stream body :space)
+    (write-string "do" stream))
+  (format stream "while (~A);" cond))
+
+(definst for (stream :export t) (init %cond update body)
+  "A `for' statement: for (INIT; COND; UPDATE) BODY"
+  (format-compound-statement (stream body)
+    (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
+	    init cond update)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Code generation.
 
@@ -302,13 +597,15 @@
    cleanup automatically."))
 
 (export 'codegen-build-function)
-(defun codegen-build-function (codegen name type vars insts)
+(defun codegen-build-function
+    (codegen name type vars insts &optional banner &rest banner-args)
   "Build a function and add it to CODEGEN's list.
 
    Returns the function's name."
   (codegen-add-function codegen
-			(make-function-inst name type
-					    (make-block-inst vars insts)))
+			(apply #'make-function-inst name type
+			       (make-block-inst vars insts)
+			       banner banner-args))
   name)
 
 (export 'codegen-pop-block)
@@ -320,15 +617,17 @@
       (make-block-inst vars insts))))
 
 (export 'codegen-pop-function)
-(defgeneric codegen-pop-function (codegen name type)
+(defgeneric codegen-pop-function
+    (codegen name type &optional banner &rest banner-args)
   (:documentation
    "Makes a function out of the completed code in CODEGEN.
 
    The NAME can be any object you like.  The TYPE should be a function type
    object which includes argument names.  The return value is the NAME.")
-  (:method (codegen name type)
+  (:method (codegen name type &optional banner &rest banner-args)
     (multiple-value-bind (vars insts) (codegen-pop codegen)
-      (codegen-build-function codegen name type vars insts))))
+      (apply #'codegen-build-function codegen name type vars insts
+	     banner banner-args))))
 
 (export 'with-temporary-var)
 (defmacro with-temporary-var ((codegen var type) &body body)
@@ -409,6 +708,6 @@
 (export 'deliver-call)
 (defun deliver-call (codegen target func &rest args)
   "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
-  (deliver-expr codegen target (make-call-inst func args)))
+  (deliver-expr codegen target (apply #'make-call-inst func args)))
 
 ;;;----- That's all, folks --------------------------------------------------