*null-pointer* variable
*sod-ap* variable
*sod-master-ap* variable
+ banner-inst class
block-inst class
break-inst class
call-inst class
deliver-call function
deliver-expr function
do-while-inst class
+ emit-banner function
emit-decl generic
emit-decls generic
emit-inst generic
emit-insts generic
ensure-var generic
expr-inst class
+ format-banner-comment function
format-compound-statement macro
format-temporary-name generic
function-inst class
inst class
inst-alt generic
inst-args generic
+ inst-banner generic
+ inst-banner-args generic
inst-body generic
inst-cond generic
inst-conseq generic
+ inst-control generic
inst-decls generic
inst-expr generic
inst-func generic
inst-op generic
inst-type generic
inst-var generic
+ make-banner-inst function
make-block-inst function
make-break-inst function
make-call-inst function
ichain
ilayout
inst
+ banner-inst
block-inst
break-inst
call-inst
inst-alt
if-inst
inst-args
+ banner-inst
call-inst
+inst-banner
+ function-inst
+inst-banner-args
+ function-inst
inst-body
block-inst
do-while-inst
while-inst
inst-conseq
if-inst
+inst-control
+ banner-inst
inst-decls
block-inst
inst-expr
cl:list
cl:null
t
+ banner-inst
block-inst
break-inst
call-inst
t simple-c-type
t tagged-c-type
cl:print-object
+ banner-inst t
base-offset t
block-inst t
break-inst t
@<form>^*}
\end{describe}
+\begin{describe}{fun}
+ {format-banner-comment @<stream> @<control> \&rest @<args>}
+\end{describe}
+
\begin{table}
\begin{tabular}[C]{ll>{\codeface}l} \hlx*{hv}
\thd{Class name} &
@|call| & @<func> @|\&rest| @<args>
& @<func>(@<arg>_1,
$\ldots$,
- @<arg>_n) \\ \hlx{vhv}
+ @<arg>_n) \\ \hlx{v}
+ @|banner| & @<control> @|\&rest| @<args>
+ & /* @<banner> */ \\ \hlx{vhv}
@|block| & @<decls> @<body> & \{ @[@<decls>@] @<body> \}
\\ \hlx{v}
@|if| & @<cond> @<conseq> @|\&optional| @<alt>
\\ \hlx{v}
@|do-while| & @<body> @<cond> & do @<body> while (@<cond>);
\\ \hlx{v}
- @|function| & @<name> @<type> @<body> &
- \vtop{\hbox{\strut @<type>_0 @<name>(@<type>_1 @<arg>_1, $\ldots$,
+ @|function| &
+ \vtop{\hbox{\strut @<name> @<type> @<body>}
+ \hbox{\strut \quad @|\&optional @<banner>|}
+ \hbox{\strut \quad @|\&rest| @<banner-args>}} &
+ \vtop{\hbox{\strut @[/* @<banner> */@]}
+ \hbox{\strut @<type>_0 @<name>(@<type>_1 @<arg>_1, $\ldots$,
@<type>_n @<arg>_n @[, \dots@])}
\hbox{\strut \quad @<body>}} \\ \hlx*{vh}
\end{tabular}
\begin{describe}{gf}{emit-decls @<codegen> @<decls>}
\end{describe}
+\begin{describe}{fun}{emit-banner @<codegen> @<control> \&rest @<args>}
+\end{describe}
+
\begin{describe}{gf}{codegen-push @<codegen>}
\end{describe}
(format nil "~A__imprint" class)
(let ((ilayout (sod-class-ilayout class)))
(format stream "~&~:
-/* Imprint raw memory with instance structure. */
-static void *~A__imprint(void *p)
+/* Imprint raw memory with class `~A' instance structure. */
+static void *~:*~A__imprint(void *p)
{
struct ~A *sod__obj = p;
(defmethod hook-output progn
((method sod-method) (reason (eql :c)) sequencer)
- (with-slots ((class %class) body) method
+ (with-slots ((class %class) role body message) method
(unless body
(return-from hook-output))
(sequence-output (stream sequencer)
:constraint ((class :direct-methods :start)
+ (class :direct-method method :banner)
(class :direct-method method :start)
(class :direct-method method :body)
(class :direct-method method :end)
(class :direct-methods :end))
+ ((class :direct-method method :banner)
+ (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
+ on `~A.~A' ~:_defined by `~A'."
+ role
+ (sod-class-nickname
+ (sod-message-class message))
+ (sod-message-name message)
+ class)
+ (fresh-line stream))
((class :direct-method method :body)
(pprint-c-type (sod-method-function-type method)
stream
`(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.
;; HACK: Some of the slot names we'd like to use are external symbols in our
(format stream " = ~A" init))
(write-char #\; stream))
-(definst function (stream :export t) (name #1=#:type body)
+(definst function (stream :export t)
+ (name #1=#:type body &optional #2=#:banner &rest banner-args)
(pprint-logical-block (stream nil)
+ (when #2#
+ (apply #'format-banner-comment stream #2# banner-args)
+ (pprint-newline :mandatory stream))
(princ "static " stream)
(pprint-c-type #1# stream name)
(format stream "~:@_~A~:@_~:@_" body)))
;; 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)
(newline)
(write decl :stream stream))
(when body (newline)))
- (dolist (inst body)
- (newline)
- (write inst :stream stream)))))
+ (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))
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)
(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)
(type (c-type (fun (lisp return-type)
("me" (* (class tail)))
. entry-args))))
- (codegen-pop-function codegen name type)
+ (codegen-pop-function codegen name type
+ "~@(~@[~A ~]entry~) function ~:_~
+ for method `~A.~A' ~:_~
+ via chain headed by `~A' ~:_~
+ defined on `~A'."
+ (if parm-n "Indirect argument-tail" nil)
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ head class)
;; If this is a varargs method then we've made the
;; `:valist' role. Also make the `nil' role.
(deliver-expr codegen target call)
(deliver-call codegen :void "va_end"
*sod-ap*)))
- (codegen-pop-function codegen main main-type))))))
+ (codegen-pop-function codegen main main-type
+ "Variable-length argument list ~:_~
+ entry function ~:_~
+ for method `~A.~A' ~:_~
+ via chain headed by `~A' ~:_~
+ defined on `~A'."
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ head class))))))
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
;; function and call it a lot.
(codegen-build-function codegen emf-name emf-type vars
(nconc insts (and result
- (list (make-return-inst result)))))
+ (list (make-return-inst result))))
+ "Effective method function ~:_for `~A.~A' ~:_~
+ defined on `~A'."
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (effective-method-class method))
(let ((call (apply #'make-call-inst emf-name "sod__obj"
(mapcar #'argument-name emf-arg-tail))))
(let* ((message (codegen-message codegen))
(message-type (sod-message-type message))
+ (message-class (sod-message-class message))
+ (method (codegen-method codegen))
(return-type (c-type-subtype message-type))
(raw-args (sod-message-argument-tail message))
(arguments (if (varargs-message-p message)
(codegen-pop-function codegen (temporary-function)
(c-type (fun (lisp return-type)
("me" (* (class super)))
- . arguments)))))
+ . arguments))
+ "Delegation-chain trampoline ~:_~
+ for `~A.~A' ~:_on `~A'."
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (effective-method-class method))))
;;;--------------------------------------------------------------------------
;;; Method entry protocol.
~mdw / sod / commitdiff