From 3994456543e7b7db0dc18b4d8ebf256303458736 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Wed, 26 May 2010 22:01:55 +0200 Subject: [PATCH] Implemented a type propagation phase --- src/cmp/cmpblock.lsp | 4 +- src/cmp/cmpform.lsp | 5 +- src/cmp/cmpglobals.lsp | 2 +- src/cmp/cmpif.lsp | 10 +- src/cmp/cmplet.lsp | 9 -- src/cmp/cmpprop.lsp | 279 +++++++++++++++++--------------------- src/cmp/cmptables.lsp | 9 ++ src/cmp/cmptop.lsp | 3 +- src/cmp/cmptype-arith.lsp | 6 +- src/cmp/cmptypes.lsp | 6 +- src/cmp/cmpvar.lsp | 2 +- 11 files changed, 155 insertions(+), 180 deletions(-) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index b56753b5f..95a2301ce 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -40,7 +40,7 @@ ;; either NIL or T), we lose a lot of information. (make-c1form* 'BLOCK :local-vars (list blk-var) - :type (type-or (blk-type blk) (c1form-type body)) + :type (values-type-or (blk-type blk) (c1form-type body)) :args blk body) body)))) @@ -97,7 +97,7 @@ (unw (setf type 'UNWIND-PROTECT var (blk-var blk)))) (incf (blk-ref blk)) - (setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val))) + (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val))) (let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val var))) (when var (add-to-read-nodes var output)) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 85ed44f2e..ccc64786e 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -54,7 +54,6 @@ (FMLA-AND * :pure) (FMLA-OR * :pure) (LAMBDA lambda-list doc body-c1form) - (LET vars-list var-init-c1form-list decl-body-c1form :pure) (LET* vars-list var-init-c1form-list decl-body-c1form :pure) (VALUES values-c1form-list :pure) (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) @@ -299,8 +298,8 @@ ;; Remaining flags are just copied (setf (c1form-name dest) (c1form-name new-fields) (c1form-local-vars dest) (c1form-local-vars new-fields) - (c1form-type dest) (type-and (c1form-type new-fields) - (c1form-type dest)) + (c1form-type dest) (values-type-and (c1form-type new-fields) + (c1form-type dest)) (c1form-sp-change dest) (c1form-sp-change new-fields) (c1form-side-effects dest) (c1form-side-effects new-fields) (c1form-volatile dest) (c1form-volatile new-fields) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 4c39f1cfc..e7acab7cc 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -215,7 +215,7 @@ slashes before special characters.") ;;; --cmptop.lsp-- ;;; -(defvar *do-type-propagation* nil +(defvar *do-type-propagation* t "Flag for switching on the type propagation phase. Use with care, experimental.") (defvar *compiler-phase* nil) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index c555f8e34..831500fbd 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -28,8 +28,8 @@ (let* ((true-branch (c1expr (second args))) (false-branch (c1expr (third args)))) (make-c1form* 'IF - :type (type-or (c1form-type true-branch) - (c1form-type false-branch)) + :type (values-type-or (c1form-type true-branch) + (c1form-type false-branch)) :args test true-branch false-branch)))) (defun c1not (args) @@ -55,7 +55,7 @@ ;; (AND x) => x (if butlast (make-c1form* 'FMLA-AND - :type (type-or 'null (c1form-type last)) + :type (type-or 'null (c1form-primary-type last)) :args butlast last) last)))) @@ -70,8 +70,8 @@ (if butlast (make-c1form* 'FMLA-OR :type (reduce #'type-or butlast - :key #'c1form-type - :initial-value (c1form-type last)) + :key #'c1form-primary-type + :initial-value (c1form-primary-type last)) :args butlast last) last)))) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index f9a6c9e68..a4fafd304 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -200,11 +200,6 @@ (member v (rest i))) (return t)))) -(defun c2let-update-variable-type (var form) - (unless (or (var-set-nodes var) - (unboxed var)) - (update-variable-type var (c1form-type form)))) - (defun env-grows (possibily) ;; if additional closure variables are introduced and this is not ;; last form, we must use a new env. @@ -237,10 +232,6 @@ (*inline-blocks* 0)) (declare (type boolean block-p)) - ;; FIXME! Until we switch on the type propagation phase we do - ;; this little optimization here - (mapc 'c2let-update-variable-type vars forms) - ;; Replace read-only variables when it is worth doing it. (loop for var in vars for rest-forms on (append forms (list body)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 36905a2e0..c8136a759 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -18,135 +18,83 @@ ;;; TYPE PROPAGATION LOOP ;;; -(defvar *type-propagation-messages* t) - (eval-when (eval compile) + (defvar *type-propagation-messages* nil) (defmacro prop-message (&rest args) - `(when *type-propagation-messages* - (format *standard-output* ,@args)))) + (when *type-propagation-messages* + `(format *standard-output* ,@args)))) (defun p1propagate (form assumptions) - (let* ((name (c1form-name form)) - (type (c1form-type form)) - propagator) - (cond ((eq name 'VAR) - (let* ((var (c1form-arg 0 form)) - (record (assoc var assumptions))) - (when record - (setf type (type-and (cdr record) (values-type-primary-type type)))) - (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type) - (values (setf (c1form-type form) type) assumptions))) - ((setf propagator (gethash name *p0-dispatch-table*)) + (let* ((*cmp-env* (c1form-env form)) + (name (c1form-name form)) + (propagator (gethash name *p1-dispatch-table*))) + (cond (propagator (prop-message "~&;;; Entering type propagation for ~A" name) - (multiple-value-bind (type assumptions) + (multiple-value-bind (new-type assumptions) (apply propagator form assumptions (c1form-args form)) - (prop-message "~&;;; Propagating ~A gives type ~A" name type) - (values (setf (c1form-type form) (values-type-and (c1form-type form) type)) - assumptions))) + (when assumptions + (baboon :format-control "Non-empty assumptions found in P1PROPAGATE")) + (prop-message "~&;;; Propagating ~A gives type ~A" name + new-type) + (values (setf (c1form-type form) + (values-type-and (c1form-type form) + new-type)) + assumptions))) (t - (prop-message "~&;;; Refusing to propagate ~A" name type) + (cmpnote "Refusing to propagate ~A" name) (values (c1form-type form) assumptions))))) +(defun p1location (form assumptions loc) + (values (c1form-type form) assumptions)) + +(defun p1var (form assumptions var) + (let ((record (assoc var assumptions)) + ;; Use the type of C1FORM because it might have been + ;; coerced by a THE form. + (type (c1form-primary-type form))) + (when record + (setf type (type-and (cdr record) (values-type-primary-type type))) + (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type)) + (values type assumptions))) + +(defun p1values (form assumptions values) + (loop for v in values + collect (multiple-value-bind (type new-assumptions) + (p1propagate v assumptions) + (setf assumptions new-assumptions) + (values-type-primary-type type)) + into all-values + finally (return (values `(values ,@all-values) assumptions)))) + (defun p1propagate-list (list assumptions) (loop with final-type = t for f in list do (multiple-value-setq (final-type assumptions) (p1propagate f assumptions)) finally (return (values final-type assumptions)))) -(defun print-assumptions (message assumptions &optional (always-p t)) - (when (and always-p (null assumptions)) - (prop-message "~&;;; ~A: NIL" message)) - (when assumptions - (prop-message "~&;;; ~A:" message)) - (dolist (record assumptions) - (prop-message "~&;;; ~A : ~A" (var-name (car record)) (cdr record)))) - (defun p1merge-branches (root chains) "ROOT is a list of assumptions, while CHAINS is list of extended versions of ROOT. This function takes all those extensions and makes a final list in which type assumptions have been merged, giving the variables the OR type of each of the occurrences in those lists." - ;; First the simple case in which we only have one list. - (when (null (rest chains)) - (setf root (first chains)) - (print-assumptions "Only one branch" root) - (return-from p1merge-branches root)) - ;; When we have to merge more than one list, we use a hash table in which - ;; we push all possible assumptions, merging the types with TYPE-OR. - (let* ((all-new-variables (make-hash-table)) - (scanned (make-hash-table))) - (print-assumptions "Root branch" root t) - (dolist (l chains) - (print-assumptions "Extra branch" (ldiff l root))) - ;; The first pass is filling the hash with unequal assumptions - ;; mergin the types - (loop for c in chains - do (clrhash scanned) - do (loop for list on c - for record = (first list) - until (eq list root) - do (let* ((var (car record)) - (type (cdr record))) - (unless (gethash var scanned) - (setf (gethash var scanned) type) - (let ((other-type (gethash var all-new-variables :missing))) - (unless (eq other-type :missing) - (setf type (type-or type other-type))) - (setf (gethash var all-new-variables) type)))))) - ;; While the last pass is extending the list of assumptions with - ;; the merged ones. - (loop with new-root = root - for var being the hash-key in all-new-variables - using (hash-value type) - do (setf new-root (acons var type new-root)) - finally (progn - (print-assumptions "Output branch" new-root) - (return new-root))))) + (unless (and (null root) + (every #'null chains)) + (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions"))) (defun revise-var-type (variable assumptions where-to-stop) - (unless (member (var-kind variable) - '(LEXICAL CLOSURE SPECIAL GLOBAL) :test #'eql) - (do* ((l assumptions (cdr l)) - (variable-type nil)) - ((or (null l) (eq l where-to-stop)) - (prop-message "~&;;; Changing type of variable ~A to ~A" - (var-name variable) variable-type) - (unless variable-type - (error "Variable ~A not found" (var-name variable))) - (setf (var-type variable) variable-type - (var-kind variable) (lisp-type->rep-type variable-type))) - (let ((record (first l))) - (print (list record (eql (car record) variable))) - (when (eql (car record) variable) - (let ((one-type (cdr record))) - (setf variable-type (if variable-type - (type-or variable-type one-type) - one-type)))))))) - -(defun p1expand-assumptions (var type assumptions) - (unless (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL)) - (prop-message "~&;;; Adding variable ~A with type ~A" (var-name var) type) - (unless (or (var-set-nodes var) (var-functions-setting var)) - (prop-message "~&;;; Changing type of read-only variable ~A" (var-name var)) - (setf (var-type var) type (var-kind var) (lisp-type->rep-type type))) - (setf assumptions (acons var type assumptions)))) - -(defun p1expand-many (var type assumptions) - (loop for v in var - for v-t in type - do (setf assumptions (p1expand-assumptions v v-t assumptions))) - assumptions) - -#+nil -(trace c::p1propagate c::p1progate-list c::p1expand-assumptions - c::p1call-global) + (unless (and (null assumptions) (null where-to-stop)) + (baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions"))) (defun p1block (c1form assumptions blk body) (multiple-value-bind (normal-type assumptions) (p1propagate body assumptions) - (values (type-or (blk-type blk) normal-type) + (values (values-type-or (blk-type blk) normal-type) assumptions))) +(defun p1return-from (c1form assumptions blk-var return-type value variable-or-nil) + (p1propagate value assumptions) + (values t assumptions)) + (defun p1call-global (c1form assumptions fname args &optional (return-type t)) (loop for v in args do (multiple-value-bind (arg-type local-ass) @@ -154,13 +102,20 @@ of the occurrences in those lists." (setf assumptions local-ass)) finally (let ((type (propagate-types fname args))) (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" - fname (mapcar #'c1form-type args) type (c1form-type c1form)) + fname (mapcar #'c1form-primary-type args) + type (c1form-type c1form)) (return (values type assumptions))))) (defun p1catch (c1form assumptions tag body) (multiple-value-bind (tag-type assumptions) (p1propagate tag assumptions) - (p1propagate-list body assumptions)) + (p1propagate body assumptions)) + (values t assumptions)) + +(defun p1throw (c1form assumptions catch-value output-value) + (multiple-value-bind (type new-assumptions) + (p1propagate catch-value assumptions) + (p1propagate output-value new-assumptions)) (values t assumptions)) (defun p1if (c1form assumptions fmla true-branch false-branch) @@ -170,43 +125,85 @@ of the occurrences in those lists." (p1propagate true-branch base-assumptions) (multiple-value-bind (t2 a2) (p1propagate false-branch base-assumptions) - (values (type-or t1 t2) (p1merge-branches base-assumptions (list a1 a2))))))) + (values (values-type-or t1 t2) + (p1merge-branches base-assumptions (list a1 a2))))))) + +(defun p1fmla-not (c1form assumptions form) + (multiple-value-bind (type assumptions) + (p1propagate form assumptions) + (values '(member t nil) assumptions))) + +(defun p1fmla-and (c1form orig-assumptions butlast last) + (loop with type = t + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + assumptions) + into assumptions-list + finally (return (values (type-or 'null (values-type-primary-type type)) + (p1merge-branches orig-assumptions + assumptions-list))))) + +(defun p1fmla-or (c1form orig-assumptions butlast last) + (loop with type + with output-type = t + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + (setf output-type (type-or (values-type-primary-type type) + output-type)) + assumptions) + into assumptions-list + finally (return (values output-type + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1lambda (c1form assumptions lambda-list doc body &rest not-used) (prop-message "~&;;;~&;;; Propagating function~&;;;") (let ((type (p1propagate body assumptions))) (values type assumptions))) +(defun p1propagate-function (fun assumptions) + (p1propagate (fun-lambda fun) assumptions)) + (defun p1let* (c1form base-assumptions vars forms body) (let ((assumptions base-assumptions)) - (loop for v in vars + (loop with type + for v in vars for f in forms - do (multiple-value-bind (type ass) - (p1propagate f assumptions) - (setf assumptions (p1expand-assumptions v type assumptions)))) + when (null (var-set-nodes v)) + do (progn + (multiple-value-setq (type assumptions) (p1propagate f assumptions)) + (setf (var-type v) (type-and (values-type-primary-type type) + (var-type v))))) (multiple-value-bind (type assumptions) (p1propagate body assumptions) (loop for v in vars do (revise-var-type v assumptions base-assumptions)) - (values (setf (c1form-type c1form) type) - assumptions)))) + (values type assumptions)))) (defun p1locals (c1form assumptions funs body labels) (loop for f in funs - do (p1propagate funs assumptions)) - (p1propagate-list body assumptions)) + do (p1propagate-function f assumptions)) + (p1propagate body assumptions)) (defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body) (multiple-value-bind (init-form-type assumptions) (p1propagate init-c1form assumptions) - (let ((new-types (values-type-to-n-types init-form-type (length vars-list)))) - (p1propagate body (p1expand-many vars-list new-types assumptions))))) + (loop for v in vars-list + for type in (values-type-to-n-types init-form-type (length vars-list)) + when (null (var-set-nodes v)) + do (setf (var-type v) (type-and (var-type v) type))) + (p1propagate body assumptions))) (defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) (multiple-value-bind (init-form-type assumptions) (p1propagate value-c1form assumptions) - (let ((new-types (values-type-to-n-types init-form-type (length vars-list)))) - (values init-form-type (p1expand-many vars-list new-types assumptions))))) + (values init-form-type assumptions))) (defun p1progn (c1form assumptions forms) (p1propagate-list forms assumptions)) @@ -214,25 +211,28 @@ of the occurrences in those lists." (defun p1setq (c1form assumptions var c1form) (multiple-value-bind (value-type assumptions) (p1propagate c1form assumptions) - (let ((type (type-and (var-type var) (values-type-primary-type value-type)))) - (values type (p1expand-assumptions var type assumptions))))) + (values (type-and (var-type var) (values-type-primary-type value-type)) + assumptions))) (defvar *tagbody-depth* -1 "If n > 0, limit the number of passes to converge tagbody forms. If -1, let the compiler do as many passes as it wishes. Complexity grows as 2^*tagbody-limit* in the worst cases.") -(defun p1tagbody (c1form assumptions tag-loc body) - (let ((*tagbody-depth* *tagbody-depth*)) - (cond ((zerop *tagbody-depth*) - (p1tagbody-simple c1form assumptions tag-loc body)) - (t - (setf *tagbody-depth* (1- *tagbody-depth*)) - (p1tagbody-many-passes c1form assumptions tag-loc body))))) +(defun p1go (c1form assumptions tag-var return-type) + (values t assumptions)) (defun filter-only-declarations (assumptions) + (when assumptions + (baboon :format-control "FILTER-ONLY-DECLARATIONS gets a non-empty assumption list")) nil) +(defun p1tagbody (c1form orig-assumptions tag-loc body) + (prop-message "~&;;; P1TAGBODY-SIMPLE pass") + (let* ((assumptions (filter-only-declarations orig-assumptions)) + (ass-list (p1tagbody-one-pass c1form assumptions tag-loc body))) + (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) + (defun p1tagbody-one-pass (c1form assumptions tag-loc body) (loop with local-ass = assumptions with ass-list = '() @@ -250,37 +250,10 @@ as 2^*tagbody-limit* in the worst cases.") (cons diff ass-list) ass-list))))) -(defun p1tagbody-simple (c1form orig-assumptions tag-loc body) - (prop-message "~&;;; P1TAGBODY-SIMPLE pass") - (print-assumptions "Orig assumptions:" orig-assumptions) - (let* ((assumptions (filter-only-declarations orig-assumptions)) - (ass-list (p1tagbody-one-pass c1form assumptions tag-loc body))) - (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) - -(defun p1tagbody-many-passes (c1form orig-assumptions tag-loc body) - (loop with orig-ass-list = '() - with assumptions = orig-assumptions - for i from 0 below 3 - for foo = (prop-message "~&;;; P1TAGBODY-MANY-PASSES pass ~D" i) - for ass-list = (p1tagbody-one-pass c1form assumptions tag-loc body) - for faa = (progn - (print-assumptions "Old tagbody assumptions" assumptions) - (pprint ass-list)) - for new-assumptions = (nconc (p1merge-branches nil ass-list) orig-assumptions) - for fee = (print-assumptions "New tagbody assumptions" new-assumptions) - for end = (equalp assumptions (setf assumptions new-assumptions)) - until end - finally (cond (end - (prop-message "~&;;; P1TAGBODY-MANY-PASSES exists at ~D" i) - (return (values 'null assumptions))) - (t - (prop-message "~&;;; P1TAGBODY-MANY-PASSES refuses at ~D" i) - (p1tagbody-simple c1form orig-assumptions tag-loc body))))) - (defun p1unwind-protect (c1form assumptions form body) (multiple-value-bind (output-type assumptions) (p1propagate form assumptions) - (p1propagate-list body assumptions) + (p1propagate body assumptions) (values output-type assumptions))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 6fd331d0d..335061b83 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -188,9 +188,14 @@ (defconstant +p1-dispatch-alist+ '((block . p1block) + (return-from . p1return-from) (call-global . p1call-global) (catch . p1catch) + (throw . p1throw) (if . p1if) + (fmla-not . p1fmla-not) + (fmla-and . p1fmla-and) + (fmla-or . p1fmla-or) (lambda . p1lambda) (let* . p1let*) (locals . p1locals) @@ -199,9 +204,13 @@ (progn . p1progn) (setq . p1setq) (tagbody . p1tagbody) + (go . p1go) (unwind-protect . p1unwind-protect) (ordinary . p1ordinary) (si::fset . p1fset) + (var . p1var) + (location . p1location) + (values . p1values) )) (defun make-dispatch-table (alist) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index c086b980a..ec42f8ede 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -182,7 +182,8 @@ (when *do-type-propagation* (setq *compiler-phase* 'p1propagate) (dolist (form *top-level-forms*) - (p1propagate form nil)) + (when form + (p1propagate form nil))) (dolist (fun *local-funs*) (p1propagate (fun-lambda fun) nil))) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 615b84084..018a4c93b 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -103,12 +103,12 @@ t1) ((null tag1) (setf c::*compiler-break-enable* t) - ;(error "foo") + ;(break) (cmpnote "Unknown type ~S. Assuming it is T." t1) t2) (t (setf c::*compiler-break-enable* t) - ;(error "foo") + ;(break) (cmpnote "Unknown type ~S. Assuming it is T." t2) t1)))) @@ -277,9 +277,11 @@ (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) T) ((null tag1) + ;(break) (cmpnote "Unknown type ~S" t1) T) (t + ;(break) (cmpnote "Unknown type ~S" t2) T)))) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 5a0b4d585..ac56c79c8 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -190,7 +190,7 @@ destination ;;; Where the value of the block to go. var ;;; Variable containing the block ID. #-new-cmp - (type 'NIL) ;;; Estimated type. + (type '(VALUES &REST T)) ;;; Estimated type. #+new-cmp env ;;; Block environment. ) @@ -213,8 +213,8 @@ (defstruct (info) (local-vars nil) ;;; List of var-objects created directly in the form. - #-new-cmp - (type t) ;;; Type of the form. + #-new-cmp + (type '(VALUES &REST T)) ;;; Type of the form. (sp-change nil) ;;; Whether execution of the form may change ;;; the value of a special variable. (volatile nil) ;;; whether there is a possible setjmp. Beppe diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 2911c1bad..b1e530241 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -67,7 +67,7 @@ (loop for form in (var-read-forms var) when (and (eq (c1form-name form) 'VAR) (eq var (c1form-arg 0 form))) - do (setf (c1form-type form) (type-and type (c1form-type form))) + do (setf (c1form-type form) (type-and type (c1form-primary-type form))) finally (setf (var-type var) type))))) (defun var-read-forms (var)