From 8db2259b25024c83cda8a1d0869b282d115983d7 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 4 Aug 2019 18:02:41 +0100 Subject: [PATCH] src/codegen-proto.lisp (definst): Overhaul argument-list processing. Previously I just used gensyms for the argument names. That breaks reloading the system, though: the classes get redefined with new slot names, but the old instances continue to linger, only they don't work properly any more. Instead, write a proper lambda-list parser which allows slot names to be specified independently of the user-facing argument names. Of course, this now changes the way the `list-exports' machinery parses `definst' forms. --- doc/list-exports.lisp | 31 ++++++-- src/codegen-proto.lisp | 188 ++++++++++++++++++++++++++++++++----------------- 2 files changed, 149 insertions(+), 70 deletions(-) diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp index 8ef80b8..c86156b 100755 --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -37,13 +37,30 @@ (and export (list* (symbolicate code '-inst) (symbolicate 'make- code '-inst) - (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))))) + (labels ((dig (tree path) + (if (or (atom tree) (null path)) tree + (dig (nth (car path) tree) (cdr path)))) + (cook (arg) + (if (consp arg) (car arg) + (let ((name (symbol-name arg))) + (if (char= (char name 0) #\%) + (intern (subseq name 1)) + arg)))) + (instify (arg) + (symbolicate 'inst- (cook arg)))) + (loop with state = :mandatory + for arg in args + if (and (symbolp arg) + (char= (char (symbol-name arg) 0) #\&)) + do (setf state arg) + else if (member state '(:mandatory &rest)) + collect (instify arg) + else if (member state '(&optional &aux)) + collect (instify (dig arg '(0))) + else if (eq state '&key) + collect (instify (dig arg '(0 1))) + else + do (error "Confused by ~S." arg))))))) (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail) (destructuring-bind (kind what) tail diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 856e44e..2dcd5ad 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -139,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 cooked raw) + (let ((state :mandatory) + (bvl (make-list-builder)) + (cooked (make-list-builder)) + (raw (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 ((cooked (intern (subseq name 1)))) + (values cooked cooked arg)) + (values arg arg arg)))) + ((atom arg) + (error "Unexpected item ~S in lambda-list." arg)) + ((null path) + (multiple-value-bind (cooked raw) + (if (cdr arg) (values (car arg) (cadr arg)) + (values (car arg) (car arg))) + (values cooked cooked raw))) + (t + (let* ((step (car path)) + (mine (nthcdr step arg))) + (multiple-value-bind (full cooked raw) + (recurse-arg (car mine) (cdr path)) + (values (append (subseq arg 0 step) + full + (cdr mine)) + cooked + raw)))))) + (hack-arg (arg maxdp) + (multiple-value-bind (full cooked-name raw-name) + (recurse-arg arg maxdp) + (lbuild-add bvl full) + (lbuild-add cooked cooked-name) + (lbuild-add raw raw-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 cooked) + (lbuild-list raw))) + (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)) + cooked))) + `(progn + (defclass ,class-name (inst) + ,(mapcar (lambda (cooked-slot raw-slot key) + `(,raw-slot :initarg ,key + :reader ,(symbolicate 'inst- cooked-slot))) + cooked raw keys)) + (defun ,constructor-name (,@bvl) + (make-instance ',class-name ,@(mappend #'list keys cooked))) + (defmethod inst-metric ((,inst-var ,class-name)) + (with-slots (,@raw) ,inst-var + (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) raw)))) + (defmethod print-object ((,inst-var ,class-name) ,streamvar) + (with-slots ,(mapcar #'list cooked raw) ,inst-var + (if *print-escape* + (print-unreadable-object (,inst-var ,streamvar :type t) + (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" + ,@(mappend #'list keys cooked))) + (block ,code ,@body)))) + ,@(and export `((export '(,class-name ,constructor-name + ,@(mapcar (lambda (slot) + (symbolicate 'inst- slot)) + cooked))))) + ',code)))) ;; Formatting utilities. @@ -224,40 +286,40 @@ ;; 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 &optional init) +(definst var (stream :export t) (name %type &optional init) (pprint-logical-block (stream nil) - (pprint-c-type #1# stream name) + (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 &optional #2=#:banner &rest banner-args) + (name %type body &optional %banner &rest banner-args) (pprint-logical-block (stream nil) - (when #2# - (apply #'format-banner-comment stream #2# banner-args) + (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~4I~_(~@<~{~A~^, ~_~}~:>)~:>" #1# args)) -(definst cond (stream :export t) (#1=#:cond conseq alt) - (format stream "~@<~A ~2I~@_~@~:>" #1# conseq alt)) +(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) () @@ -304,33 +366,33 @@ (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 #1=#:cond update body) +(definst for (stream :export t) (init %cond update body) (format-compound-statement (stream body) (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)" - init #1# update))) + init cond update))) ;;;-------------------------------------------------------------------------- ;;; Code generation. -- 2.11.0