From 167524b5890cdbf4a832b1766a328f6d8a1f8f04 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 10 Jan 2016 13:51:04 +0000 Subject: [PATCH] src/: Enhance `definst' to allow general BVL syntax. Allow the `alt' argument for `if' to be &optional, and omit it when it's not interesting. Allow the `init' argument for `var' to be &optional, and omit it when it's not interesting. Make the `args' argument for `call' be &rest. This isn't a win right now, but it will be later. --- doc/SYMBOLS | 27 ++++++++++++------------ doc/clang.tex | 15 ++++++++------ doc/list-exports.lisp | 8 +++++-- src/codegen-impl.lisp | 2 +- src/codegen-proto.lisp | 53 +++++++++++++++++++++++++++-------------------- src/codegen-test.lisp | 4 ++-- src/method-aggregate.lisp | 8 +++---- src/method-impl.lisp | 11 ++++------ 8 files changed, 70 insertions(+), 58 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 226ab38..5ee51b3 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -320,30 +320,17 @@ classes.lisp sod-slot-type generic codegen-impl.lisp - call-inst class codegen class - do-while-inst class - if-inst class - inst-alt generic - inst-args generic - inst-body generic - inst-cond generic - inst-conseq generic - inst-func generic - make-call-inst function - make-do-while-inst function - make-if-inst function - make-while-inst function temporary-argument class temporary-function function class temporary-variable class - while-inst class codegen-proto.lisp *sod-ap* variable *sod-master-ap* variable block-inst class break-inst class + call-inst class codegen-add-function generic codegen-build-function function codegen-functions generic setf @@ -356,6 +343,7 @@ codegen-proto.lisp definst macro deliver-call function deliver-expr function + do-while-inst class emit-decl generic emit-decls generic emit-inst generic @@ -365,10 +353,16 @@ codegen-proto.lisp format-compound-statement macro format-temporary-name generic function-inst class + if-inst class inst class + inst-alt generic + inst-args generic inst-body generic + inst-cond generic + inst-conseq generic inst-decls generic inst-expr generic + inst-func generic inst-init generic inst-metric generic inst-name generic @@ -377,13 +371,17 @@ codegen-proto.lisp inst-var generic make-block-inst function make-break-inst function + make-call-inst function make-continue-inst function + make-do-while-inst function make-expr-inst function make-function-inst function + make-if-inst function make-return-inst function make-set-inst function make-update-inst function make-var-inst function + make-while-inst function return-inst class set-inst class temp-tag generic @@ -392,6 +390,7 @@ codegen-proto.lisp update-inst class var-in-use-p generic setf var-inst class + while-inst class with-temporary-var macro final.lisp diff --git a/doc/clang.tex b/doc/clang.tex index 58b8cd2..f5b16a8 100644 --- a/doc/clang.tex +++ b/doc/clang.tex @@ -892,7 +892,8 @@ Temporary names are represented by objects which implement a simple protocol. \thd{Class name} & \thd{Arguments} & \thd{Output format} \\ \hlx{vhv} - @|var| & @ @ @ & @ @ @[= @@]; + @|var| & @ @ @|\&optional| @ + & @ @ @[= @@]; \\ \hlx{v} @|set| & @ @ & @ = @; \\ \hlx{v} @|update| & @ @ @ & @ @= @; @@ -902,21 +903,23 @@ Temporary names are represented by objects which implement a simple protocol. @|break| & --- & break; \\ \hlx{v} @|continue| & --- & continue; \\ \hlx{v} @|expr| & @ & @; \\ \hlx{v} - @|call| & @ @ & @(@_1, + @|call| & @ @|\&rest| @ + & @(@_1, $\ldots$, @_n) \\ \hlx{vhv} @|block| & @ @ & \{ @[@@] @ \} \\ \hlx{v} - @|if| & @ @ @ & if (@) @ + @|if| & @ @ @|\&optional| @ + & if (@) @ @[else @@] \\ \hlx{v} @|while| & @ @ & while (@) @ \\ \hlx{v} @|do-while| & @ @ & do @ while (@); \\ \hlx{v} @|function| & @ @ @ & - @_0 @(@_1 @_1, $\ldots$, - @_n @_n @[, \dots@]) - @ \\ \hlx*{vh} + \vtop{\hbox{\strut @_0 @(@_1 @_1, $\ldots$, + @_n @_n @[, \dots@])} + \hbox{\strut \quad @}} \\ \hlx*{vh} \end{tabular} \caption{Instruction classes} \label{tab:codegen.codegen.insts} diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp index 598d1c7..34b1497 100644 --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -28,8 +28,12 @@ (and export (list* (symbolicate code '-inst) (symbolicate 'make- code '-inst) - (mapcar (lambda (arg) - (symbolicate 'inst- arg)) + (mapcan (lambda (arg) + (let ((sym (if (listp arg) (car arg) arg))) + (cond ((char= (char (symbol-name sym) 0) #\&) + nil) + (t + (list (symbolicate 'inst- sym)))))) args))))) (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail) diff --git a/src/codegen-impl.lisp b/src/codegen-impl.lisp index 0dba2c1..84bdd18 100644 --- a/src/codegen-impl.lisp +++ b/src/codegen-impl.lisp @@ -161,7 +161,7 @@ :in-use-p t :tag (prog1 temp-index (incf temp-index))))) - (push (make-var-inst name type nil) vars) + (push (make-var-inst name type) vars) name)))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 264fd03..4bfaeca 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -124,8 +124,8 @@ * 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) @@ -135,32 +135,41 @@ 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)) - (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) - args))) + (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 (arg key) - `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg))) - args keys)) + ,(mapcar (lambda (slot key) + `(,slot :initarg ,key + :reader ,(symbolicate 'inst- slot))) + slots keys)) (defun ,constructor-name (,@args) - (make-instance ',class-name ,@(mappend #'list keys args))) + (make-instance ',class-name ,@(mappend #'list keys slots))) (defmethod inst-metric ((,inst-var ,class-name)) - (with-slots (,@args) ,inst-var - (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args)))) + (with-slots (,@slots) ,inst-var + (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) slots)))) (defmethod print-object ((,inst-var ,class-name) ,streamvar) - (with-slots (,@args) ,inst-var + (with-slots (,@slots) ,inst-var (if *print-escape* (print-unreadable-object (,inst-var ,streamvar :type t) (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" - ,@(mappend #'list keys args))) + ,@(mappend #'list keys slots))) (block ,code ,@body)))) ,@(and export `((export '(,class-name ,constructor-name - ,@(mapcar (lambda (arg) - (symbolicate 'inst- arg)) - args))))) + ,@(mapcar (lambda (slot) + (symbolicate 'inst- slot)) + slots))))) ',code))) ;; Formatting utilities. @@ -204,7 +213,7 @@ ;; 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 init) +(definst var (stream :export t) (name #1=#:type &optional init) (pprint-c-type #1# stream name) (when init (format stream " = ~A" init)) @@ -225,7 +234,7 @@ (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#)) ;; Special kinds of expressions. -(definst call (stream :export t) (#1=#:func args) +(definst call (stream :export t) (#1=#:func &rest args) (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args)) ;; Simple statements. @@ -242,7 +251,7 @@ (format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" decls body)) -(definst if (stream :export t) (#1=#:cond conseq alt) +(definst if (stream :export t) (#1=#:cond conseq &optional alt) (format-compound-statement (stream conseq alt) (format stream "if (~A)" #1#)) (when alt @@ -437,6 +446,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 -------------------------------------------------- diff --git a/src/codegen-test.lisp b/src/codegen-test.lisp index da3763b..6821059 100644 --- a/src/codegen-test.lisp +++ b/src/codegen-test.lisp @@ -50,7 +50,7 @@ (emit-insts codegen (list (make-set-inst "u" "v") (make-set-inst "v" r)))) (emit-inst codegen (make-while-inst "v" (codegen-pop-block codegen))) - (emit-inst codegen (make-if-inst "a" (make-set-inst "*a" "aa") nil)) + (emit-inst codegen (make-if-inst "a" (make-set-inst "*a" "aa"))) (deliver-expr codegen :return "u") (codegen-pop-function codegen "gcd" (c-type (fun int @@ -64,7 +64,7 @@ ("a")) do (ensure-var codegen name c-type-int init)) (ensure-var codegen "g" c-type-int - (make-call-inst "gcd" (list "u" "v" "&a"))) + (make-call-inst "gcd" "u" "v" "&a")) (deliver-call codegen :void "printf" "\"%d*%d == %d (mod %d)\\n\"" "a" "u" "g" "v") (deliver-expr codegen :return 0) diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp index c8791af..ec0a119 100644 --- a/src/method-aggregate.lisp +++ b/src/method-aggregate.lisp @@ -379,7 +379,7 @@ :methods (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val) - (make-set-inst acc val) nil)))) + (make-set-inst acc val))))) (define-aggregating-method-combination :max ((acc val) :codegen codegen) :first-method (lambda (invoke) @@ -388,7 +388,7 @@ :methods (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val) - (make-set-inst acc val) nil)))) + (make-set-inst acc val))))) (define-aggregating-method-combination :and ((ret) :codegen codegen) :around (lambda (body) @@ -399,7 +399,7 @@ :methods (lambda (invoke) (funcall invoke ret) (emit-inst codegen (make-if-inst (format nil "!~A" ret) - (make-break-inst) nil)))) + (make-break-inst))))) (define-aggregating-method-combination :or ((ret) :codegen codegen) :around (lambda (body) @@ -409,7 +409,7 @@ (make-do-while-inst (codegen-pop-block codegen) 0))) :methods (lambda (invoke) (funcall invoke ret) - (emit-inst codegen (make-if-inst ret (make-break-inst) nil)))) + (emit-inst codegen (make-if-inst ret (make-break-inst))))) ;;;-------------------------------------------------------------------------- ;;; A customizable aggregating method combination. diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 366d1dc..8501a02 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -443,10 +443,8 @@ ;; If this is a varargs method then we've made the ;; `:valist' role. Also make the `nil' role. (when parm-n - (let ((call (make-call-inst name - (cons "me" - (mapcar #'argument-name - entry-args)))) + (let ((call (apply #'make-call-inst name "me" + (mapcar #'argument-name entry-args))) (main (method-entry-function-name method head nil)) (main-type (c-type (fun (lisp return-type) ("me" (* (class tail))) @@ -496,9 +494,8 @@ (nconc insts (and result (list (make-return-inst result))))) - (let ((call (make-call-inst emf-name - (cons "sod__obj" (mapcar #'argument-name - emf-arg-tail))))) + (let ((call (apply #'make-call-inst emf-name "sod__obj" + (mapcar #'argument-name emf-arg-tail)))) (dolist (tail chain-tails) (setup-entry tail) (deliver-expr codegen entry-target call) -- 2.11.0