X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..6afec9101d5ea87e3df4bda2239ffd05f8154fa6:/src/codegen-proto.lisp

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index b8206fa..0d0bc22 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -49,24 +49,12 @@
 
 ;; Root class.
 
-(export 'temporary-name)
+(export '(temporary-name temp-tag))
 (defclass temporary-name ()
   ((tag :initarg :tag :reader temp-tag))
   (:documentation
    "Base class for temporary variable and argument names."))
 
-;; Important variables.
-
-(defparameter *temporary-index* 0
-  "Index for temporary name generation.
-
-   This is automatically reset to zero before the output functions are
-   invoked to write a file.  This way, we can ensure that the same output
-   file is always produced from the same input.")
-
-(define-clear-the-decks reset-codegen-index
-  (setf *temporary-index* 0))
-
 ;; Important temporary names.
 
 (export '(*sod-ap* *sod-master-ap*))
@@ -74,6 +62,17 @@
   (make-instance 'temporary-name :tag "sod__ap"))
 (defparameter *sod-master-ap*
   (make-instance 'temporary-name :tag "sod__master_ap"))
+(defparameter *sod-tmp-ap*
+  (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.
@@ -120,7 +119,7 @@
 ;; Instruction definition.
 
 (export 'definst)
-(defmacro definst (code (streamvar) args &body body)
+(defmacro definst (code (streamvar &key export) args &body body)
   "Define an instruction type and describe how to output it.
 
    An `inst' can represent any structured piece of output syntax: a
@@ -132,62 +131,115 @@
      * 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."
-
-  (let ((inst-var (gensym "INST"))
-	(class-name (symbolicate 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 ,(symbolicate 'make- code '-inst) (,@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)))
-	       (progn ,@body)))))))
-
-;; Important instruction classes.
-
-(export '(block-inst make-block-inst var-inst make-var-inst
-	  function-inst make-function-inst set-inst make-set-inst
-	  return-inst make-return-inst expr-inst make-expr-inst
-	  inst-decls inst-body inst-name inst-type inst-init inst-var
-	  inst-expr))
-
-(definst var (stream) (name type init)
-  (pprint-c-type type stream name)
-  (when init
-    (format stream " = ~A" init)))
-(definst set (stream) (var expr)
-  (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-(definst return (stream) (expr)
-  (format stream "return~@[ (~A)~];" expr))
-(definst expr (stream) (expr)
-  (format stream "~A;" expr))
-(definst block (stream) (decls body)
-  (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
-	  decls body))
-(definst function (stream) (name type body)
-  (pprint-logical-block (stream nil)
-    (princ "static " stream)
-    (pprint-c-type type stream name)
-    (format stream "~:@_~A~:@_~:@_" body)))
+       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."
+
+  (multiple-value-bind (bvl public private)
+      (let ((state :mandatory)
+	    (bvl (make-list-builder))
+	    (public (make-list-builder))
+	    (private (make-list-builder)))
+	(labels ((recurse-arg (arg path)
+		   (cond ((symbolp arg)
+			  (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)
+			  (error "Unexpected item ~S in lambda-list." arg))
+			 ((null path)
+			  (multiple-value-bind (public private)
+			      (if (cdr arg) (values (car arg) (cadr arg))
+				  (values (car arg) (car arg)))
+			    (values public public private)))
+			 (t
+			  (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)
+		   (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))))
+	(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)))))
+	(values (lbuild-list bvl)
+		(lbuild-list public)
+		(lbuild-list private)))
+    (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)))
+      `(progn
+	 (defclass ,class-name (inst)
+	   ,(mapcar (lambda (public-slot private-slot key)
+		      `(,private-slot :initarg ,key
+			      :reader ,(symbolicate 'inst- public-slot)))
+		    public private keys))
+	 (defun ,constructor-name (,@bvl)
+	   (make-instance ',class-name ,@(mappend #'list keys public)))
+	 (defmethod inst-metric ((,inst-var ,class-name))
+	   (with-slots (,@private) ,inst-var
+	     (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) private))))
+	 (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 stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
+			   ,@(mappend #'list keys public)))
+		 (block ,code ,@body))))
+	 ,@(and export `((export '(,class-name ,constructor-name
+				   ,@(mapcar (lambda (slot)
+					       (symbolicate 'inst- slot))
+					     public)))))
+	 ',code))))
 
 ;; Formatting utilities.
 
@@ -205,13 +257,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
@@ -224,6 +276,120 @@
   `(format-compound-statement* ,stream ,child ,morep
 			       (lambda (,stream) ,@body)))
 
+(export 'format-banner-comment)
+(defun format-banner-comment (stream control &rest args)
+  (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
+
+;; Important instruction classes.
+
+(definst var (stream :export t) (name %type &optional init)
+  (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)
+  (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)
+  (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) (%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) (%expr)
+  (format stream "return~@[ (~A)~];" expr))
+(definst break (stream :export t) ()
+  (format stream "break;"))
+(definst continue (stream :export t) ()
+  (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)
+  (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-inst codegen (apply #'make-banner-inst control args)))
+
+(definst block (stream :export t) (decls body)
+  (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)
+  (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)
+  (format-compound-statement (stream body)
+    (format stream "while (~A)" cond)))
+
+(definst do-while (stream :export t) (body %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)
+  (format-compound-statement (stream body)
+    (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
+	    init cond update)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Code generation.
 
@@ -254,6 +420,14 @@
   (:method (codegen insts)
     (dolist (inst insts) (emit-inst codegen inst))))
 
+(export '(emit-decl emit-decls))
+(defgeneric emit-decl (codegen inst)
+  (:documentation
+   "Add INST to the end of CODEGEN's list of declarations."))
+(defgeneric emit-decls (codegen insts)
+  (:documentation
+   "Add a list of INSTS to the end of CODEGEN's list of declarations."))
+
 (export 'codegen-push)
 (defgeneric codegen-push (codegen)
   (:documentation
@@ -288,13 +462,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)
@@ -306,15 +482,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)
@@ -322,10 +500,13 @@
 
    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
    available for re-use."
-  `(let ((,var (temporary-var ,codegen ,type)))
-     (unwind-protect
-	  (progn ,@body)
-       (setf (var-in-use-p ,var) nil))))
+  (multiple-value-bind (doc decls body) (parse-body body :docp nil)
+    (declare (ignore doc))
+    `(let ((,var (temporary-var ,codegen ,type)))
+       ,@decls
+       (unwind-protect
+	    (progn ,@body)
+	 (setf (var-in-use-p ,var) nil)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation idioms.
@@ -389,4 +570,9 @@
 		  (emit-inst codegen (make-return-inst nil)))
     (t (funcall func target))))
 
+(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 (apply #'make-call-inst func args)))
+
 ;;;----- That's all, folks --------------------------------------------------