lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / codegen-proto.lisp

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 92569ae7f8a80eca899c401c5b99a92874870103..0c5040ca9be71af0cfa86d7a52445ccac3637a31 100644 (file)
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -155,26 +155,68 @@ (defmacro definst (code (streamvar &key export) args &body body)
    symbols."
 
   (multiple-value-bind (bvl public private)
    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)))
       (let ((state :mandatory)
            (bvl (make-list-builder))
            (public (make-list-builder))
            (private (make-list-builder)))

+

        (labels ((recurse-arg (arg path)
        (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)
                   (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))))
                          (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)
                         ((atom arg)

+                         ;; Any other kind of atom is obviously bogus.

                          (error "Unexpected item ~S in lambda-list." arg))
                          (error "Unexpected item ~S in lambda-list." arg))

+

                         ((null path)
                         ((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)))
                          (multiple-value-bind (public private)
                              (if (cdr arg) (values (car arg) (cadr arg))
                                  (values (car arg) (car arg)))
                            (values public public private)))

+

                         (t
                         (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)
                          (let* ((step (car path))
                                 (mine (nthcdr step arg)))
                            (multiple-value-bind (full public private)


@@ -184,62 +226,108 @@ (defmacro definst (code (streamvar &key export) args &body body)
                                              (cdr mine))
                                      public
                                      private))))))
                                              (cdr mine))
                                      public
                                      private))))))

+

                 (hack-arg (arg maxdp)
                 (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))))
                   (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)))))
+
+         ;; 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)))
        (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)))
     (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))))
+      (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.
 
 
 ;; Formatting utilities.
 


@@ -278,15 +366,20 @@ (defmacro format-compound-statement
 
 (export 'format-banner-comment)
 (defun format-banner-comment (stream control &rest args)
 
 (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.
 
   (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
 
 ;; 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)
 (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
   (pprint-logical-block (stream nil)
     (pprint-c-type type stream name)
     (when init


@@ -295,6 +388,16 @@ (definst var (stream :export t) (name %type &optional init)
 
 (definst function (stream :export t)
     (name %type body &optional %banner &rest banner-args)
 
 (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-logical-block (stream nil)
     (when banner
       (apply #'format-banner-comment stream banner banner-args)


@@ -305,24 +408,32 @@ (definst function (stream :export t)
 
 ;; Expression statements.
 (definst expr (stream :export t) (%expr)
 
 ;; Expression statements.
 (definst expr (stream :export t) (%expr)

+  "An expression statement: EXPR;"

   (format stream "~A;" expr))
 (definst set (stream :export t) (var %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)
   (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)
   (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)
   (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)
   (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) ()
   (format stream "return~@[ (~A)~];" expr))
 (definst break (stream :export t) ()

+  "A `break' statement: break;"

   (format stream "break;"))
 (definst continue (stream :export t) ()
   (format stream "break;"))
 (definst continue (stream :export t) ()

+  "A `continue' statement: continue;"

   (format stream "continue;"))
 
 ;; Compound statements.
   (format stream "continue;"))
 
 ;; Compound statements.


@@ -334,15 +445,31 @@ (defvar *first-statement-p* t
    they get the formatting right between them.")
 
 (definst banner (stream :export t) (control &rest args)
    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)
   (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)
   (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)
   (write-char #\{ stream)
   (pprint-newline :mandatory stream)
   (pprint-logical-block (stream nil)


@@ -367,6 +494,7 @@ (definst block (stream :export t) (decls body)
   (write-char #\} stream))
 
 (definst if (stream :export t) (%cond conseq &optional alt)
   (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))
   (let ((stmt "if"))
     (loop (format-compound-statement (stream conseq (if alt t nil))
            (format stream "~A (~A)" stmt cond))


@@ -381,15 +509,18 @@ (definst if (stream :export t) (%cond conseq &optional alt)
               (return))))))
 
 (definst while (stream :export t) (%cond body)
               (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)
   (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)
   (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)))
   (format-compound-statement (stream body)
     (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
            init cond update)))