From ee750fd3be3e27e4fa035413ebb6051a525d27bc Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 11 Oct 1990 17:39:17 +0000 Subject: [PATCH] Many fixes and some enhancements. Added *DERIVE-FUNCTION-TYPES* switch which can inhibit inter-routine type interence. Fixed some broken FTYPE proclamations that have been noticed now that the declarations are applied to the definition. Added the VALUES declaration for conveniently declaring the return values from a function (or any other form that has declarations.) Made the gensym introduced to hold the value before defaulting for hairy keyword args have a comprehensible name so that type errors are somewhat more informative. Also, if the keyword default isn't hairy, give the value temp the right type so that the type check is forced back into the XEP. Made FIND-FREE-FUNCTION note if a setf function is also a setf macro. Made REFERENCE-CONSTANT error if the constant isn't dumpable. Fixed THE to be correct, which required adding information into the LEXENV and having USE-CONTINUATION cooperate. Added doc strings for all the special forms that didn't have any. Ripped out most of the code in the %COMPILER-DEFSTRUCT translator now that most everything is done by %%COMPILER-DEFSTRUCT. Frobbed DEFMACRO to clobber any old function info with UNDEFINE-FUNCTION-NAME. Tweaked %DEFUN translator quite a bit. NOTINLINE declarations are now respected as forcing named call. Changed to use ASSERT-DEFINITION-TYPE to apply any FTYPE proclamation to the definition. Also, call CHECK-FREE-FUNCTION now if we can't enter the functional into *FREE-FUNCTIONS* for some reason. Made %DEFCONSTANT warn about redefining constant or specials. Also, made DEFCONSTANT always eval the form at compile time, as this is now allowed --- compiler/ir1tran.lisp | 351 +++++++++++++++++++++++++++++------------- 1 file changed, 242 insertions(+), 109 deletions(-) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 5bdcc7517..6248dc730 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -17,7 +17,7 @@ (export '(*compile-time-define-macros* *converting-for-interpreter*)) (in-package 'ext) -(export '(ignorable truly-the maybe-inline)) +(export '(ignorable truly-the maybe-inline *derive-function-types*)) (in-package "LISP") (export '(symbol-macro-let)) @@ -551,7 +551,8 @@ ;;; 4] A list of the &aux variables. ;;; 5] A list of the &aux values. ;;; -(proclaim '(function find-lambda-vars (list) (values list boolean list list))) +(proclaim '(function find-lambda-vars (list) + (values list boolean boolean list list))) (defun find-lambda-vars (list) (multiple-value-bind (required optional restp rest keyp keys allowp aux) (parse-lambda-list list) @@ -672,7 +673,7 @@ ;;; of Name. The second value is the inlinep information which currently ;;; applies to the variable. ;;; -(proclaim '(function find-lexically-apparent-function (symbol string) +(proclaim '(function find-lexically-apparent-function (t string) (values leaf inlinep))) (defun find-lexically-apparent-function (name context) (let ((var (lexenv-find name functions :test #'equal))) @@ -844,8 +845,8 @@ ;;; Res and returning it as a result. Vars and Fvars are as described in ;;; PROCESS-DECLARATIONS. ;;; -(defun process-1-declaration (spec res vars fvars) - (declare (list spec vars fvars) (type lexenv res)) +(defun process-1-declaration (spec res vars fvars cont) + (declare (list spec vars fvars) (type lexenv res) (type continuation cont)) (case (first spec) (special (process-special-declaration spec res vars)) (ftype @@ -870,6 +871,12 @@ :cookie (process-optimize-declaration spec (lexenv-cookie res)))) (type (process-type-declaration (cdr spec) res vars)) + (values + (let ((types (cdr spec))) + (do-the-stuff (if (null (cdr types)) + (car types) + `(values ,@types)) + cont res 'values))) (t (let ((what (first spec))) (cond ((member what type-specifier-symbols) @@ -887,10 +894,11 @@ ;;; Functional structures which are being bound. In addition to filling in ;;; slots in the leaf structures, we return a new LEXENV which reflects ;;; pervasive special and function type declarations, (not)inline declarations -;;; and optimize declarations. +;;; and optimize declarations. Cont is the continuation affected by VALUES +;;; declarations. ;;; -(defun process-declarations (decls vars fvars) - (declare (list decls vars fvars)) +(defun process-declarations (decls vars fvars cont) + (declare (list decls vars fvars) (type continuation cont)) (let ((res *lexical-environment*)) (dolist (decl decls) (dolist (spec (rest decl)) @@ -898,7 +906,7 @@ (compiler-error "Malformed declaration specifier ~S in ~S." spec decl)) - (setq res (process-1-declaration spec res vars fvars)))) + (setq res (process-1-declaration spec res vars fvars cont)))) res)) @@ -995,11 +1003,12 @@ ;;; sequentially bound. Each Aux-Val is a form that is to be evaluated to get ;;; the initial value for the corresponding Aux-Var. ;;; -(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals) - (declare (list body vars aux-vars aux-vals)) +(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals result) + (declare (list body vars aux-vars aux-vals) + (type (or continuation null) result)) (let* ((bind (make-bind)) (lambda (make-lambda :vars vars :bind bind)) - (result (make-continuation))) + (result (or result (make-continuation)))) (setf (lambda-home lambda) lambda) (collect ((svars) (new-venv nil cons)) @@ -1090,10 +1099,11 @@ (defun generate-optional-default-entry (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals) + aux-vars aux-vals cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals)) + aux-vars aux-vals) + (type (or continuation null) cont)) (let* ((arg (first vars)) (arg-name (leaf-name arg)) (info (lambda-var-arg-info arg)) @@ -1105,14 +1115,14 @@ (list* (leaf-name supplied-p) arg-name default-vals) (cons arg entry-vars) (list* t arg-name entry-vals) - (rest vars) t body aux-vars aux-vals) + (rest vars) t body aux-vars aux-vals cont) (ir1-convert-hairy-args res (cons arg default-vars) (cons arg-name default-vals) (cons arg entry-vars) (cons arg-name entry-vals) - (rest vars) supplied-p-p body aux-vars aux-vals)))) + (rest vars) supplied-p-p body aux-vars aux-vals cont)))) (convert-optional-entry ep default-vars default-vals (if supplied-p @@ -1243,10 +1253,12 @@ ;;; rest arg. Keys is a list of the keyword argument vars. ;;; (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals - rest keys supplied-p-p body aux-vars aux-vals) + rest keys supplied-p-p body aux-vars aux-vals + cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body - aux-vars aux-vals)) + aux-vars aux-vals) + (type (or continuation null) cont)) (collect ((main-vars (reverse default-vars)) (main-vals default-vals cons) (bind-vars) @@ -1260,8 +1272,12 @@ (default (arg-info-default info)) (hairy-default (not (compiler-constantp default))) (supplied-p (arg-info-supplied-p info)) - (n-val (gensym)) - (val-temp (make-lambda-var :name n-val))) + (n-val (make-symbol (format nil "~A-DEFAULTING-TEMP" + (leaf-name key)))) + (val-temp (make-lambda-var :name n-val + :type (if hairy-default + *universal-type* + (leaf-type key))))) (main-vars val-temp) (bind-vars key) (cond ((or hairy-default supplied-p) @@ -1282,7 +1298,8 @@ (let* ((main-entry (ir1-convert-lambda-body body (main-vars) (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals))) + (append (bind-vals) aux-vals) + cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1332,13 +1349,14 @@ (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars - aux-vals) + aux-vals cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals)) + aux-vars aux-vals) + (type (or continuation null) cont)) (cond ((not vars) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals))) + aux-vars aux-vals cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1350,7 +1368,8 @@ (nvars (cons arg default-vars)) (nvals (cons (leaf-name arg) default-vals))) (ir1-convert-hairy-args res nvars nvals nvars nvals - (rest vars) nil body aux-vars aux-vals))) + (rest vars) nil body aux-vars aux-vals + cont))) (t (let* ((arg (first vars)) (info (lambda-var-arg-info arg)) @@ -1360,7 +1379,7 @@ (let ((ep (generate-optional-default-entry res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals))) + aux-vars aux-vals cont))) (push (if supplied-p-p (convert-optional-entry ep entry-vars entry-vals ()) ep) @@ -1370,12 +1389,12 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals arg (rest vars) supplied-p-p body - aux-vars aux-vals)) + aux-vars aux-vals cont)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil vars supplied-p-p body aux-vars - aux-vals))))))) + aux-vals cont))))))) ;;; IR1-Convert-Hairy-Lambda -- Internal @@ -1385,13 +1404,14 @@ ;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the ;;; min-args and max-args. ;;; -(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals) - (declare (list body vars aux-vars aux-vals)) +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) + (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp :keyp keyp)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-functions *current-component*)) - (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals) + (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals + cont) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) @@ -1421,13 +1441,15 @@ (multiple-value-bind (body decls) (system:parse-body (cddr form) *lexical-environment* t) - (let* ((*lexical-environment* - (process-declarations decls (append aux-vars vars) nil)) + (let* ((cont (make-continuation)) + (*lexical-environment* + (process-declarations decls (append aux-vars vars) nil cont)) (res (if (or (find-if #'lambda-var-arg-info vars) keyp) (ir1-convert-hairy-lambda body vars keyp allow-other-keys - aux-vars aux-vals) - (ir1-convert-lambda-body body vars aux-vars aux-vals)))) + aux-vars aux-vals cont) + (ir1-convert-lambda-body body vars aux-vars aux-vals + cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) res)))) @@ -1436,6 +1458,12 @@ ;;;; Variable hacking: +(defvar *derive-function-types* t + "If true, argument and result type information derived from compilation of + DEFUNs is used when compiling calls to that function. If false, only + information from FTYPE proclamations will be used.") + + ;;; Find-Free-Really-Function -- Internal ;;; ;;; Return a Global-Var structure usable for referencing the global function @@ -1445,13 +1473,17 @@ (unless (info function kind name) (setf (info function kind name) :function) (setf (info function where-from name) :assumed)) - + (when (eq (info function where-from name) :assumed) (note-undefined-reference name :function)) - - (make-global-var :kind :global-function :name name - :type (info function type name) - :where-from (info function where-from name))) + + (let ((where (info function where-from name))) + (make-global-var :kind :global-function :name name + :type (if (or *derive-function-types* + (eq where :declared)) + (info function type name) + (specifier-type 'function)) + :where-from where))) ;;; Find-Slot-Accessor -- Internal @@ -1498,6 +1530,7 @@ (compiler-error "Found special-form name ~S ~A." name context)) ((:function nil) (check-function-name name) + (note-if-setf-function-and-macro name) (let ((info (info function accessor-for name))) (values (setf (gethash name *free-functions*) (if info @@ -1566,6 +1599,8 @@ ;;; (defun reference-constant (start cont value) (declare (type continuation start cont)) + (unless (typep value '(or list number array symbol character structure)) + (compiler-error "~S constants not supported." (type-of value))) (let* ((leaf (find-constant value)) (res (make-ref (leaf-type leaf) leaf nil))) (push res (leaf-refs leaf)) @@ -1637,6 +1672,10 @@ ;;; derived-type for the continuation to that of the node, so that a little ;;; type propagation gets done. ;;; +;;; We also deal with a bit of THE's semantics here: we weaken the assertion +;;; on Cont to be no stronger than the assertion on Cont in our scope. See the +;;; THE IR1-CONVERT method. +;;; (proclaim '(function use-continuation (node continuation) void)) (defun use-continuation (node cont) (let ((block (continuation-block cont)) @@ -1658,7 +1697,12 @@ (assert (not (member node-block (block-pred block))) () "~S is already a predecessor of ~S." node-block block) (push node-block (block-pred block)) - (add-continuation-use node cont))))) + (add-continuation-use node cont) + (unless (eq (continuation-asserted-type cont) *wild-type*) + (setf (continuation-asserted-type cont) + (values-type-union (continuation-asserted-type cont) + (or (lexenv-find cont type-restrictions) + *wild-type*)))))))) ;;; Continuation-Starts-Block -- Internal @@ -2071,6 +2115,9 @@ (def-ir1-translator eval-when ((situations &rest body) start cont) + "EVAL-WHEN (Situation*) Form* + Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL. + This is conceptually a compile-only implementation, so EVAL is a no-op." (do-eval-when-stuff situations body #'(lambda (forms) (ir1-convert-progn-body start cont forms)))) @@ -2116,6 +2163,11 @@ (def-ir1-translator macrolet ((definitions &rest body) start cont) + "MACROLET ({(Name Lambda-List Form*)}*) Body-Form* + Evaluate the Body-Forms in an environment with the specified local macros + defined. Name is the local macro name, Lambda-List is the DEFMACRO style + destructuring lambda list, and the Forms evaluate to the expansion. The + Forms are evaluated in the null environment." (do-macrolet-stuff definitions #'(lambda () (ir1-convert-progn-body start cont body)))) @@ -2205,10 +2257,15 @@ ;;;; Quote and Function: (def-ir1-translator quote ((thing) start cont) + "QUOTE Value + Return Value without evaluating it." (reference-constant start cont thing)) (def-ir1-translator function ((thing) start cont) + "FUNCTION Name + Return the lexically apparent definition of the function Name. Name may also + be a lambda." (if (and (consp thing) (eq (car thing) 'lambda)) (reference-leaf start cont (ir1-convert-lambda thing) nil) (multiple-value-bind (var inlinep) @@ -2400,38 +2457,20 @@ ;;; %Compiler-Defstruct IR1 Convert -- Internal ;;; ;;; This is a frob that DEFMACRO expands into to establish the compiler -;;; semantics. This is similar to the translator for proclaim: its job is to -;;; keep the *free-functions* in sync. +;;; semantics. %%COMPILER-DEFSTRUCT does most of the work, we just clear all +;;; of the functions out of *FREE-FUNCTIONS* to keep things in synch. ;;; (def-ir1-translator %compiler-defstruct ((info) start cont :kind :function) - (let* ((info (eval info)) - (name (dd-name info)) - (copier (dd-copier info)) - (predicate (dd-predicate info))) - (setf (info type kind name) :structure) - (setf (info type structure-info name) info) + (let* ((info (eval info))) + (funcall #'%%compiler-defstruct info) (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor slot)) - (type (dsd-type slot))) - (process-1-ftype-proclamation - fun - (specifier-type `(function (,name) ,type))) + (let ((fun (dsd-accessor slot))) + (remhash fun *free-functions*) (unless (dsd-read-only slot) - (process-1-ftype-proclamation - `(setf ,fun) - (specifier-type `(function (,type ,name) ,type)))))) - - (collect ((forms)) - (when copier - (forms `(proclaim '(ftype (function (,name) ,name) ,copier)))) - - (when predicate - (forms `(proclaim '(ftype (function (t) boolean) ,predicate)))) - - (funcall #'%%compiler-defstruct info) - (ir1-convert start cont `(progn - ,@(forms) - (%%compiler-defstruct ',info)))))) + (remhash `(setf ,fun) *free-functions*)))) + (remhash (dd-predicate info) *free-functions*) + (remhash (dd-copier info) *free-functions*) + (ir1-convert start cont `(%%compiler-defstruct ',info)))) ;;;; Let and Let*: @@ -2449,7 +2488,8 @@ ;;; are marked as such. Context is the name of the form, for error reporting ;;; purposes. ;;; -(proclaim '(function extract-let-variables (list symbol) (values list list))) +(proclaim '(function extract-let-variables (list symbol) + (values list list list))) (defun extract-let-variables (bindings context) (collect ((vars) (vals) @@ -2474,9 +2514,13 @@ (def-ir1-translator let ((bindings &body (body decls)) start cont) + "LET ({(Var [Value]) | Var}*) Declaration* Form* + During evaluation of the Forms, Bind the Vars to the result of evaluating the + Value forms. The variables are bound in parallel after all of the Values are + evaluated." (multiple-value-bind (vars values) (extract-let-variables bindings 'let) - (let* ((*lexical-environment* (process-declarations decls vars nil)) + (let* ((*lexical-environment* (process-declarations decls vars nil cont)) (fun-cont (make-continuation)) (fun (ir1-convert-lambda-body body vars))) (reference-leaf start fun-cont fun nil) @@ -2485,9 +2529,12 @@ (def-ir1-translator let* ((bindings &body (body decls)) start cont) + "LET* ({(Var [Value]) | Var}*) Declaration* Form* + Similar to LET, but the variables are bound sequentially, allowing each Value + form to reference any of the previous Vars." (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) - (let ((*lexical-environment* (process-declarations decls vars nil))) + (let ((*lexical-environment* (process-declarations decls vars nil cont))) (ir1-convert-aux-bindings start cont body vars values)))) @@ -2524,6 +2571,10 @@ (def-ir1-translator flet ((definitions &body (body decls)) start cont) + "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* + Evaluate the Body-Forms with some local function definitions. The bindings + do not enclose the definitions; any use of Name in the Forms will refer to + the lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar #'(lambda (n d) @@ -2532,7 +2583,7 @@ res)) names defs)) (*lexical-environment* - (make-lexenv :default (process-declarations decls nil fvars) + (make-lexenv :default (process-declarations decls nil fvars cont) :functions (pairlis names fvars)))) (ir1-convert-progn-body start cont body)))) @@ -2548,6 +2599,10 @@ ;;; local functions.] ;;; (def-ir1-translator labels ((definitions &body (body decls)) start cont) + "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* + Evaluate the Body-Forms with some local function definitions. The bindings + enclose the new definitions, so the defined functions can call themselves or + each other." (multiple-value-bind (names defs) (extract-flet-variables definitions 'labels) (let* ((dummies (mapcar #'(lambda (x) @@ -2564,40 +2619,79 @@ (mapc #'substitute-leaf real-funs dummies) (let ((*lexical-environment* - (make-lexenv :default (process-declarations decls nil real-funs) - :functions (pairlis names real-funs)))) + (make-lexenv + :default (process-declarations decls nil real-funs cont) + :functions (pairlis names real-funs)))) (ir1-convert-progn-body start cont body))))) ;;;; THE + +;;; DO-THE-STUFF -- Internal +;;; +;;; Do stuff to recognize a THE or VALUES declaration. Cont is the +;;; continuation that the assertion applies to, Type is the type specifier and +;;; Lexenv is the current lexical environment. Name is the name of the +;;; declaration we are doing, for use in error messages. ;;; ;;; This is somewhat involved, since a type assertion may only be made on a -;;; continuation, not on a node. If the continuation has no uses before the -;;; form is converted, then we may make the type the assertion for the -;;; continuation. If there are other uses, then we accept some loss of -;;; information, but try to retain as much as possible. In this case, we make -;;; the type assertion the union of the pre-existing type assertion and the new -;;; type. - +;;; continuation, not on a node. We can't just set the continuation asserted +;;; type and let it go at that, since there may be paralell THE's for the same +;;; continuation, i.e.: +;;; (if ... +;;; (the foo ...) +;;; (the bar ...)) +;;; +;;; In this case, our representation can do no better than the union of these +;;; assertions. And if there is a branch with no assertion, we have nothing at +;;; all. We really need to recognize scoping, since we need to be able to +;;; discern between parallel assertions (which we union) and nested ones (which +;;; we intersect). +;;; +;;; We represent the scoping by throwing our innermost (intersected) assertion +;;; on Cont into the TYPE-RESTRICTIONS. As we go down, we intersect our +;;; assertions together. If Cont has no uses yet, we have not yet bottomed out +;;; on the first COND branch; in this case we optimistically assume that this +;;; type will be the one we end up with, and set the ASSERTED-TYPE to it. +;;; We can never get better than the type that we have the first time we bottom +;;; out. Later THE's (or the absence thereof) can only weaken this result. +;;; +;;; We make this work by getting USE-CONTINUATION to do the unioning across +;;; COND branches. We can't do it here, since we don't know how many branches +;;; there are going to be. +;;; +(defun do-the-stuff (type cont lexenv name) + (declare (type continuation cont) (type lexenv lexenv)) + (let* ((ctype (values-specifier-type type)) + (old-type (or (lexenv-find cont type-restrictions) + *wild-type*)) + (int (values-type-intersection old-type ctype)) + (new (if (eq int *empty-type*) old-type int))) + (when (null (find-uses cont)) + (setf (continuation-asserted-type cont) new)) + (when (and (eq int *empty-type*) + (not (policy nil (= brevity 3)))) + (compiler-warning + "Type ~S in ~S declaration conflicts with enclosing assertion:~% ~S" + (type-specifier ctype) name (type-specifier old-type))) + (make-lexenv :type-restrictions `((,cont . ,new)) + :default lexenv))) + + +;;; THE IR1 Convert -- Internal +;;; (def-ir1-translator the ((type value) start cont) - (let ((ctype (values-specifier-type type))) - (if (null (find-uses cont)) - (let* ((old-type (continuation-asserted-type cont)) - (int (values-type-intersection old-type ctype))) - (when (and (eq int *empty-type*) - (not (policy nil (= brevity 3)))) - (compiler-warning - "Type ~S in THE declaration conflicts with previous type ~S." - (type-specifier ctype) (type-specifier old-type))) - (setf (continuation-asserted-type cont) int)) - (setf (continuation-asserted-type cont) - (values-type-union ctype (continuation-asserted-type cont))))) - (ir1-convert start cont value)) + "THE Type Form + Assert that Form evaluates to the specified type (which may be a VALUES + type.)" + (let ((*lexical-environment* + (do-the-stuff type cont *lexical-environment* 'the))) + (ir1-convert start cont value))) ;;; Truly-The IR1 convert -- Internal ;;; -;;; Since the Continuation-Derive-Type is computed as the union of its +;;; Since the Continuation-Derived-Type is computed as the union of its ;;; uses's types, setting it won't work. Instead we must intersect the type ;;; with the uses's Derived-Type. ;;; @@ -2621,6 +2715,10 @@ ;;; out. (def-ir1-translator setq ((&rest things &whole source) start cont) + "SETQ {Var Value}* + Set the variables to the values. If more than one pair is supplied, the + assignments are done sequentially. If Var names a symbol macro, SETF the + expansion." (let ((len (length things))) (when (oddp len) (compiler-error "Odd number of args to SETQ: ~S." source)) @@ -2783,6 +2881,9 @@ ;;; compilation of MV-Combinations. ;;; (def-ir1-translator multiple-value-call ((fun &rest args) start cont) + "MULTIPLE-VALUE-CALL Function Values-Form* + Call Function, passing all the values of each Values-Form as arguments, + values from the first Values-Form making up the first argument, etc." (let* ((fun-cont (make-continuation)) (node (if args (make-mv-combination fun-cont) @@ -2829,6 +2930,9 @@ ;;; whose block is the true control destination. ;;; (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) + "MULTIPLE-VALUE-PROG1 Values-Form Form* + Evaluate Values-Form and then the Forms, but return all the values of + Values-Form." (continuation-starts-block cont) (let* ((dummy-result (make-continuation)) (dummy-start (make-continuation)) @@ -2888,11 +2992,11 @@ (unless (symbolp name) (compiler-error "Macro name is not a symbol: ~S." name)) - (force-output) (ecase (info function kind name) ((nil)) (:function (remhash name *free-functions*) + (undefine-function-name name) (compiler-warning "Defining ~S to be a macro when it was ~(~A~) to be a function." name (info function where-from name))) @@ -2919,11 +3023,12 @@ (compiler-mumble "Converted ~S.~%" name))) +;;; %DEFUN IR1 convert -- Internal ;;; ;;; Convert the definition and substitute for previous global uses. We only ;;; do the substitution if the function is in the null environment, ensuring ;;; that the function cannot be called outside of the correct environment. -;;; Emit top-level code to install the definition. +;;; Also, emit top-level code to install the definition. ;;; (def-ir1-translator %defun ((name def doc source) start cont :kind :function) @@ -2935,28 +3040,48 @@ (in-null-environment)) (cadr def) nil)) (*current-path* (revert-source-path 'defun))) - (setf (info function where-from name) :defined) (setf (info function inline-expansion name) expansion) ;; - ;; If there is a previous defun for the same name, disown the leaf for it. + ;; If function has type information from a previous DEFUN, blow it away. + (when (eq (info function where-from name) :defined) + (setf (info function type name) (specifier-type 'function)) + (remhash name *free-functions*)) + ;; + ;; If there is a previous defun for Name in the same compilation, disown + ;; the leaf for it. (let ((old (gethash name *free-functions*))) (when (functional-p old) (remhash name *free-functions*))) - + ;; + ;; Convert definition. If in the null environment and definitely not an + ;; interpreter stub, then substitute for any references that aren't + ;; :NOTINLINE. (let ((fun (ir1-convert-lambda (cadr def))) (new (gethash name *free-functions*)) (info (info function info name))) (setf (leaf-name fun) name) (cond ((and (in-null-environment t) - (not (eq (info function inlinep name) :notinline)) (or (not info) (and (null (function-info-transforms info)) (null (function-info-templates info)) (not (function-info-ir2-convert info))))) (setf (gethash name *free-functions*) fun) - (when new (substitute-leaf fun new))) + (when new + (substitute-leaf-if + #'(lambda (x) + (not (eq (ref-inlinep x) :notinline))) + fun new))) (t - (let ((var (find-free-function name "in a strange place"))) - (setf (leaf-where-from var) :defined)))) + ;; + ;; We call CHECK-FREE-FUNCTION now, since the functional never + ;; gets into *FREE-FUNCTIONS*. + ;; ### Not so good for inferring result types. + (setf (leaf-type fun) (definition-type fun)) + (check-free-function name fun))) + + (when (eq (info function where-from name) :declared) + (let ((type (info function type name))) + (when (function-type-p type) + (assert-definition-type fun type)))) (ir1-convert start cont `(%%defun ',name ,fun ,doc @@ -2971,15 +3096,23 @@ ;;; (def-ir1-translator %defconstant ((name value doc) start cont :kind :function) - (let ((name (eval name))) + (let ((name (eval name)) + (newval (eval value))) (unless (symbolp name) (compiler-error "Constant name is not a symbol: ~S." name)) + (ecase (info variable kind name) + (:constant + (unless (equalp newval (info variable constant-value name)) + (compiler-warning "Redefining constant ~S as:~% ~S" + name newval))) + (:special + (compiler-warning "Redefining special ~S to be a constant." name)) + (:global)) + (setf (info variable kind name) :constant) (setf (info variable where-from name) :defined) - - (when (and (constantp value) (not (symbolp value))) - (setf (info variable constant-value name) (eval value))) + (setf (info variable constant-value name) newval) (remhash name *free-variables*)) (ir1-convert start cont `(%%defconstant ,name ,value ,doc))) -- GitLab