X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e5573634ce3668f2a4eac74be125262d28a5cb8a..refs/heads/master:/src/codegen-proto.lisp diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 767f35b..0d0bc22 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -66,6 +66,10 @@ (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") @@ -135,45 +139,107 @@ otherwise. The BODY is expected to produce target code at this 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." - (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 (slot key) - `(,slot :initarg ,key - :reader ,(symbolicate 'inst- slot))) - slots keys)) - (defun ,constructor-name (,@args) - (make-instance ',class-name ,@(mappend #'list keys slots))) - (defmethod inst-metric ((,inst-var ,class-name)) - (with-slots (,@slots) ,inst-var - (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) slots)))) - (defmethod print-object ((,inst-var ,class-name) ,streamvar) - (with-slots (,@slots) ,inst-var - (if *print-escape* - (print-unreadable-object (,inst-var ,streamvar :type t) - (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" - ,@(mappend #'list keys slots))) - (block ,code ,@body)))) - ,@(and export `((export '(,class-name ,constructor-name - ,@(mapcar (lambda (slot) - (symbolicate 'inst- slot)) - slots))))) - ',code))) + (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. @@ -191,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 @@ -210,39 +276,46 @@ `(format-compound-statement* ,stream ,child ,morep (lambda (,stream) ,@body))) -;; Important instruction classes. +(export 'format-banner-comment) +(defun format-banner-comment (stream control &rest args) + (format stream "~@~_ */~:>" control args)) -;; 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. +;; Important instruction classes. -(definst var (stream :export t) (name #1=#:type &optional init) - (pprint-c-type #1# stream name) - (when init - (format stream " = ~A" init)) - (write-char #\; stream)) +(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 #1=#:type body) +(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 #1# stream name) + (pprint-c-type type stream name) (format stream "~:@_~A~:@_~:@_" body))) ;; Expression statements. -(definst expr (stream :export t) (#1=#:expr) - (format stream "~A;" #1#)) -(definst set (stream :export t) (var #1=#:expr) - (format stream "~@<~A = ~@_~2I~A;~:>" var #1#)) -(definst update (stream :export t) (var op #1=#:expr) - (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#)) +(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) (#1=#:func &rest args) - (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args)) +(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~@_~@~:>" cond conseq alt)) ;; Simple statements. -(definst return (stream :export t) (#1=#:expr) - (format stream "return~@[ (~A)~];" #1#)) +(definst return (stream :export t) (%expr) + (format stream "return~@[ (~A)~];" expr)) (definst break (stream :export t) () (format stream "break;")) (definst continue (stream :export t) () @@ -250,6 +323,21 @@ ;; 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) @@ -266,34 +354,41 @@ (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)) -(definst if (stream :export t) (#1=#:cond conseq &optional alt) +(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 #1#)) + (format stream "~A (~A)" stmt cond)) (typecase alt (null (return)) (if-inst (setf stmt "else if" - #1# (inst-cond alt) + 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) (#1=#:cond body) +(definst while (stream :export t) (%cond body) (format-compound-statement (stream body) - (format stream "while (~A)" #1#))) + (format stream "while (~A)" cond))) -(definst do-while (stream :export t) (body #1=#:cond) +(definst do-while (stream :export t) (body %cond) (format-compound-statement (stream body :space) (write-string "do" stream)) - (format stream "while (~A);" #1#)) + (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. @@ -367,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) @@ -385,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)