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
definst macro
deliver-call function
deliver-expr function
+ do-while-inst class
emit-decl generic
emit-decls generic
emit-inst generic
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
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
update-inst class
var-in-use-p generic setf
var-inst class
+ while-inst class
with-temporary-var macro
final.lisp
\thd{Class name} &
\thd{Arguments} &
\thd{Output format} \\ \hlx{vhv}
- @|var| & @<name> @<type> @<init> & @<type> @<name> @[= @<init>@];
+ @|var| & @<name> @<type> @|\&optional| @<init>
+ & @<type> @<name> @[= @<init>@];
\\ \hlx{v}
@|set| & @<var> @<expr> & @<var> = @<expr>; \\ \hlx{v}
@|update| & @<var> @<op> @<expr> & @<var> @<op>= @<expr>;
@|break| & --- & break; \\ \hlx{v}
@|continue| & --- & continue; \\ \hlx{v}
@|expr| & @<expr> & @<expr>; \\ \hlx{v}
- @|call| & @<func> @<args> & @<func>(@<arg>_1,
+ @|call| & @<func> @|\&rest| @<args>
+ & @<func>(@<arg>_1,
$\ldots$,
@<arg>_n) \\ \hlx{vhv}
@|block| & @<decls> @<body> & \{ @[@<decls>@] @<body> \}
\\ \hlx{v}
- @|if| & @<cond> @<conseq> @<alt> & if (@<cond>) @<conseq>
+ @|if| & @<cond> @<conseq> @|\&optional| @<alt>
+ & if (@<cond>) @<conseq>
@[else @<alt>@] \\ \hlx{v}
@|while| & @<cond> @<body> & while (@<cond>) @<body>
\\ \hlx{v}
@|do-while| & @<body> @<cond> & do @<body> while (@<cond>);
\\ \hlx{v}
@|function| & @<name> @<type> @<body> &
- @<type>_0 @<name>(@<type>_1 @<arg>_1, $\ldots$,
- @<type>_n @<arg>_n @[, \dots@])
- @<body> \\ \hlx*{vh}
+
\vtop{\hbox{\strut @<type>_0 @<name>(@<type>_1 @<arg>_1, $\ldots$,
+ @<type>_n @<arg>_n @[, \dots@])}
+ \hbox{\strut \quad @<body>}} \\ \hlx*{vh}
\end{tabular}
\caption{Instruction classes}
\label{tab:codegen.codegen.insts}
(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)
: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 --------------------------------------------------
* 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)
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.
;; 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))
(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.
(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
(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 --------------------------------------------------
(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
("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)
: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)
: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)
: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)
(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.
;; 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)))
(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)
~mdw / sod / commitdiff