X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=8c63c71cf3bcae368b0680e42cc160430d486da7;hb=a1a2c079c7654defb618baad0dddcf0eaf2ce64f;hp=06aa22b953ae050f44b04ee45b50596bd9ec8f6c;hpb=9266ac18b62c73bff89a0f45165cf740b3c87ca1;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 06aa22b..8c63c71 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -72,7 +72,13 @@ (setf (info :function :where-from name) :assumed)) (let ((where (info :function :where-from name))) - (when (eq where :assumed) + (when (and (eq where :assumed) + ;; In the ordinary target Lisp, it's silly to report + ;; undefinedness when the function is defined in the + ;; running Lisp. But at cross-compile time, the current + ;; definedness of a function is irrelevant to the + ;; definedness at runtime, which is what matters. + #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function :name name @@ -93,7 +99,8 @@ (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor)) (type (dd-name info)) (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) + (unless slot + (error "can't find slot ~S" type)) (make-slot-accessor :name name :type (specifier-type @@ -155,7 +162,7 @@ (let ((var (lexenv-find name functions :test #'equal))) (cond (var (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro))) + (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t @@ -197,7 +204,10 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defconstant list-to-hash-table-threshold 32) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; below. -- AL 20010227 + (defconstant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) @@ -273,7 +283,7 @@ #!-sb-fluid (declaim (inline prev-link)) (defun prev-link (node cont) (declare (type node node) (type continuation cont)) - (assert (not (continuation-next cont))) + (aver (not (continuation-next cont))) (setf (continuation-next cont) node) (setf (node-prev node) cont)) @@ -304,15 +314,15 @@ (declare (type node node) (type continuation cont) (inline member)) (let ((block (continuation-block cont)) (node-block (continuation-block (node-prev node)))) - (assert (eq (continuation-kind cont) :block-start)) - (assert (not (block-last node-block)) () "~S has already ended." - node-block) + (aver (eq (continuation-kind cont) :block-start)) + (when (block-last node-block) + (error "~S has already ended." node-block)) (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) + (when (block-succ node-block) + (error "~S already has successors." node-block)) (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block) :test #'eq)) () - "~S is already a predecessor of ~S." node-block block) + (when (memq node-block (block-pred block)) + (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)) (add-continuation-use node cont) (unless (eq (continuation-asserted-type cont) *wild-type*) @@ -372,7 +382,7 @@ ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-Num is the top-level form number of the +;;; find the paths in, and TLF-NUM is the top-level form number of the ;;; truly top-level form. ;;; ;;; This gets a bit interesting when the source code is circular. This @@ -462,8 +472,8 @@ (global-var (ir1-convert-srctran start cont lexical-def form)) (t - (assert (and (consp lexical-def) - (eq (car lexical-def) 'macro))) + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) (ir1-convert start cont (careful-expand-macro (cdr lexical-def) form)))))) @@ -477,7 +487,7 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl-file, make sure that + ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;; needs to be. (defun reference-constant (start cont value) @@ -538,7 +548,7 @@ (compiler-style-warning "reading an ignored variable: ~S" name)) (reference-leaf start cont var)) (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) @@ -800,7 +810,7 @@ ;;; If a lambda-var being bound, we intersect the type with the vars ;;; type, otherwise we add a type-restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-declaration (decl res vars) +(defun process-type-decl (decl res vars) (declare (list decl vars) (type lexenv res)) (let ((type (specifier-type (first decl)))) (collect ((restr nil cons) @@ -817,9 +827,9 @@ (int (if (or (function-type-p type) (function-type-p old-type)) type - (type-intersection old-type type)))) + (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= brevity 3)) + (unless (policy *lexenv* (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -829,7 +839,7 @@ (restr (cons var int)))))) (cons ;; FIXME: non-ANSI weirdness - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) ,(cdr var)))))) (heap-alien-info @@ -843,12 +853,12 @@ :variables (new-vars)) res)))) -;;; Somewhat similar to Process-Type-Declaration, but handles +;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles ;;; declarations for function variables. In addition to allowing ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-declaration (spec res names fvars) +(defun process-ftype-decl (spec res names fvars) (declare (list spec names fvars) (type lexenv res)) (let ((type (specifier-type spec))) (collect ((res nil cons)) @@ -871,14 +881,14 @@ ;;; Process a special declaration, returning a new LEXENV. A non-bound ;;; special declaration is instantiated by throwing a special variable ;;; into the variables. -(defun process-special-declaration (spec res vars) +(defun process-special-decl (spec res vars) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) (let ((var (find-in-bindings vars name))) (etypecase var (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (compiler-error "~S is a symbol-macro and thus can't be declared special." name)) @@ -915,7 +925,7 @@ ;;; Parse an inline/notinline declaration. If it's a local function we're ;;; defining, set its INLINEP. If a global function, add a new FENV entry. -(defun process-inline-declaration (spec res fvars) +(defun process-inline-decl (spec res fvars) (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) @@ -927,7 +937,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed brevity)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -952,7 +962,7 @@ ;;; Process an ignore/ignorable declaration, checking for various losing ;;; conditions. -(defun process-ignore-declaration (spec vars fvars) +(defun process-ignore-decl (spec vars fvars) (declare (list spec vars fvars)) (dolist (name (rest spec)) (let ((var (find-in-bindings-or-fbindings name vars fvars))) @@ -985,87 +995,59 @@ #!+sb-doc "If true, processing of the VALUES declaration is inhibited.") -;;; Process a single declaration spec, agumenting the specified LEXENV -;;; Res and returning it as a result. Vars and Fvars are as described in +;;; Process a single declaration spec, augmenting the specified LEXENV +;;; RES and returning it as a result. VARS and FVARS are as described in ;;; PROCESS-DECLS. -(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 - (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S." spec)) - (process-ftype-declaration (second spec) res (cddr spec) fvars)) - (function - ;; Handle old style FUNCTION declaration, which is an abbreviation for - ;; FTYPE. Args are name, arglist, result type. - (cond ((and (proper-list-of-length-p spec 3 4) - (listp (third spec))) - (process-ftype-declaration `(function ,@(cddr spec)) res - (list (second spec)) - fvars)) - (t - (process-type-declaration spec res vars)))) - ((inline notinline maybe-inline) - (process-inline-declaration spec res fvars)) - ((ignore ignorable) - (process-ignore-declaration spec vars fvars) - res) - (optimize - (make-lexenv - :default res - :cookie (process-optimize-declaration spec (lexenv-cookie res)))) - (optimize-interface - (make-lexenv - :default res - :interface-cookie (process-optimize-declaration - spec - (lexenv-interface-cookie res)))) - (type - (process-type-declaration (cdr spec) res vars)) - (sb!pcl::class - (process-type-declaration (list (third spec) (second spec)) res vars)) - (values - (if *suppress-values-declaration* - res - (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) - (dynamic-extent - (when (policy nil (> speed brevity)) - (compiler-note - "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) - res) - (t - (let ((what (first spec))) - (cond ((member what *standard-type-names*) - (process-type-declaration spec res vars)) - ((and (not (and (symbolp what) - (string= (symbol-name what) "CLASS"))) ; pcl hack - (or (info :type :kind what) - (and (consp what) (info :type :translator (car what))))) -;;; MNA - abbreviated declaration bug -;; (unless (policy nil (= brevity 3)) - ;; FIXME: Is it ANSI to warn about this? I think not. -;; (compiler-note "abbreviated type declaration: ~S." spec)) - (process-type-declaration spec res vars)) - ((info :declaration :recognized what) - res) - (t - (compiler-warning "unrecognized declaration ~S" spec) - res)))))) - -;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR and -;;; 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. CONT is the continuation affected by VALUES -;;; declarations. +(defun process-1-decl (raw-spec res vars fvars cont) + (declare (type list raw-spec vars fvars)) + (declare (type lexenv res)) + (declare (type continuation cont)) + (let ((spec (canonized-decl-spec raw-spec))) + (case (first spec) + (special (process-special-decl spec res vars)) + (ftype + (unless (cdr spec) + (compiler-error "No type specified in FTYPE declaration: ~S" spec)) + (process-ftype-decl (second spec) res (cddr spec) fvars)) + ((inline notinline maybe-inline) + (process-inline-decl spec res fvars)) + ((ignore ignorable) + (process-ignore-decl spec vars fvars) + res) + (optimize + (make-lexenv + :default res + :policy (process-optimize-decl spec (lexenv-policy res)))) + (type + (process-type-decl (cdr spec) res vars)) + (values + (if *suppress-values-declaration* + res + (let ((types (cdr spec))) + (do-the-stuff (if (eql (length types) 1) + (car types) + `(values ,@types)) + cont res 'values)))) + (dynamic-extent + (when (policy *lexenv* (> speed inhibit-warnings)) + (compiler-note + "compiler limitation:~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + res) + (t + (unless (info :declaration :recognized (first spec)) + (compiler-warning "unrecognized declaration ~S" raw-spec)) + res)))) + +;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR +;;; and 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. CONT is the +;;; continuation affected by VALUES declarations. ;;; -;;; This is also called in main.lisp when PROCESS-FORM handles a use of -;;; LOCALLY. +;;; This is also called in main.lisp when PROCESS-FORM handles a use +;;; of LOCALLY. (defun process-decls (decls vars fvars cont &optional (env *lexenv*)) (declare (list decls vars fvars) (type continuation cont)) (dolist (decl decls) @@ -1074,10 +1056,10 @@ (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (setq env (process-1-declaration spec env vars fvars cont)))) + (setq env (process-1-decl spec env vars fvars cont)))) env) -;;; Return the Specvar for Name to use when we see a local SPECIAL +;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then ;;; check that it isn't a constant and return it. Otherwise, create an ;;; anonymous GLOBAL-VAR. @@ -1132,38 +1114,38 @@ (note-lexical-binding name) (make-lambda-var :name name))))) -;;; Make the keyword for a keyword arg, checking that the keyword -;;; isn't already used by one of the Vars. We also check that the -;;; keyword isn't the magical :allow-other-keys. +;;; Make the default keyword for a &KEY arg, checking that the keyword +;;; isn't already used by one of the VARS. We also check that the +;;; keyword isn't the magical :ALLOW-OTHER-KEYS. (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) - (intern (symbol-name symbol) "KEYWORD") + (keywordicate symbol) symbol))) (when (eq key :allow-other-keys) - (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS.")) + (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) (dolist (var vars) (let ((info (lambda-var-arg-info var))) (when (and info (eq (arg-info-kind info) :keyword) - (eq (arg-info-keyword info) key)) + (eq (arg-info-key info) key)) (compiler-error "The keyword ~S appears more than once in the lambda-list." key)))) key)) -;;; Parse a lambda-list into a list of Var structures, stripping off +;;; Parse a lambda-list into a list of VAR structures, stripping off ;;; any aux bindings. Each arg name is checked for legality, and ;;; duplicate names are checked for. If an arg is globally special, -;;; the var is marked as :special instead of :lexical. Keyword, -;;; optional and rest args are annotated with an arg-info structure +;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY, +;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure ;;; which contains the extra information. If we hit something losing, -;;; we bug out with Compiler-Error. These values are returned: -;;; 1. A list of the var structures for each top-level argument. -;;; 2. A flag indicating whether &key was specified. -;;; 3. A flag indicating whether other keyword args are allowed. -;;; 4. A list of the &aux variables. -;;; 5. A list of the &aux values. +;;; we bug out with COMPILER-ERROR. These values are returned: +;;; 1. a list of the var structures for each top-level argument; +;;; 2. a flag indicating whether &KEY was specified; +;;; 3. a flag indicating whether other &KEY args are allowed; +;;; 4. a list of the &AUX variables; and +;;; 5. a list of the &AUX values. (declaim (ftype (function (list) (values list boolean boolean list list)) find-lambda-vars)) (defun find-lambda-vars (list) @@ -1174,9 +1156,9 @@ (names-so-far) (aux-vars) (aux-vals)) - ;; Parse-Default deals with defaults and supplied-p args for optionals - ;; and keywords args. - (flet ((parse-default (spec info) + (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args + ;; for optionals and keywords args. + (parse-default (spec info) (when (consp (cdr spec)) (setf (arg-info-default info) (second spec)) (when (consp (cddr spec)) @@ -1233,9 +1215,9 @@ (let ((var (varify-lambda-arg spec (names-so-far)))) (setf (lambda-var-arg-info var) (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg spec - (vars) - t))) + :key (make-keyword-for-arg spec + (vars) + t))) (vars var) (names-so-far spec))) ((atom (first spec)) @@ -1243,7 +1225,7 @@ (var (varify-lambda-arg name (names-so-far))) (info (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg name (vars) t)))) + :key (make-keyword-for-arg name (vars) t)))) (setf (lambda-var-arg-info var) info) (vars var) (names-so-far name) @@ -1251,14 +1233,14 @@ (t (let ((head (first spec))) (unless (proper-list-of-length-p head 2) - (error "malformed keyword arg specifier: ~S" spec)) + (error "malformed &KEY argument specifier: ~S" spec)) (let* ((name (second head)) (var (varify-lambda-arg name (names-so-far))) (info (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg (first head) - (vars) - nil)))) + :key (make-keyword-for-arg (first head) + (vars) + nil)))) (setf (lambda-var-arg-info var) info) (vars var) (names-so-far name) @@ -1282,48 +1264,41 @@ (values (vars) keyp allowp (aux-vars) (aux-vals)))))) -;;; Similar to IR1-Convert-Progn-Body except that we sequentially bind each -;;; Aux-Var to the corresponding Aux-Val before converting the body. If there -;;; are no bindings, just convert the body, otherwise do one binding and -;;; recurse on the rest. -;;; -;;; If Interface is true, then we convert bindings with the interface -;;; policy. For real &aux bindings, and implicit aux bindings introduced by -;;; keyword bindings, this is always true. It is only false when LET* directly -;;; calls this function. -(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface) +;;; This is similar to IR1-CONVERT-PROGN-BODY except that we +;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before +;;; converting the body. If there are no bindings, just convert the +;;; body, otherwise do one binding and recurse on the rest. +(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) (ir1-convert-progn-body start cont body) (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body (list (first aux-vars)) - (rest aux-vars) (rest aux-vals) - interface))) + (fun (ir1-convert-lambda-body body + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals)))) (reference-leaf start fun-cont fun) - (let ((*lexenv* (if interface - (make-lexenv - :cookie (make-interface-cookie *lexenv*)) - *lexenv*))) - (ir1-convert-combination-args fun-cont cont - (list (first aux-vals)))))) + (ir1-convert-combination-args fun-cont cont + (list (first aux-vals))))) (values)) -;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar -;;; for each Svar to the value of the variable is wrapped around the body. If -;;; there are no special bindings, we just convert the body, otherwise we do -;;; one special binding and recurse on the rest. +;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind +;;; the SPECVAR for each SVAR to the value of the variable is wrapped +;;; around the body. If there are no special bindings, we just convert +;;; the body, otherwise we do one special binding and recurse on the +;;; rest. ;;; -;;; We make a cleanup and introduce it into the lexical environment. If -;;; there are multiple special bindings, the cleanup for the blocks will end up -;;; being the innermost one. We force Cont to start a block outside of this -;;; cleanup, causing cleanup code to be emitted when the scope is exited. -(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals - interface svars) +;;; We make a cleanup and introduce it into the lexical environment. +;;; If there are multiple special bindings, the cleanup for the blocks +;;; will end up being the innermost one. We force CONT to start a +;;; block outside of this cleanup, causing cleanup code to be emitted +;;; when the scope is exited. +(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars) (declare (type continuation start cont) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (ir1-convert-aux-bindings start cont body aux-vars aux-vals)) (t (continuation-starts-block cont) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -1336,7 +1311,7 @@ (let ((*lexenv* (make-lexenv :cleanup cleanup))) (ir1-convert next-cont nnext-cont '(%cleanup-point)) (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals - interface (rest svars)))))) + (rest svars)))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -1355,11 +1330,8 @@ ;;; ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated -;;; to get the initial value for the corresponding AUX-VAR. Interface -;;; is a flag as T when there are real aux values (see LET* and -;;; IR1-CONVERT-AUX-BINDINGS.) -(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals - interface result) +;;; to get the initial value for the corresponding AUX-VAR. +(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) (let* ((bind (make-bind)) @@ -1391,7 +1363,7 @@ (prev-link bind cont1) (use-continuation bind cont2) (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - interface (svars))) + (svars))) (let ((block (continuation-block result))) (when block @@ -1411,16 +1383,14 @@ lambda)) ;;; Create the actual entry-point function for an optional entry -;;; point. The lambda binds copies of each of the Vars, then calls Fun -;;; with the argument Vals and the Defaults. Presumably the Vals refer -;;; to the Vars by name. The Vals are passed in in reverse order. +;;; point. The lambda binds copies of each of the VARS, then calls FUN +;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer +;;; to the VARS by name. The VALS are passed in in reverse order. ;;; ;;; If any of the copies of the vars are referenced more than once, -;;; then we mark the corresponding var as Ever-Used to inhibit +;;; then we mark the corresponding var as EVER-USED to inhibit ;;; "defined but not read" warnings for arguments that are only used ;;; by default forms. -;;; -;;; We bind *LEXENV* to change the policy to the interface policy. (defun convert-optional-entry (fun vars vals defaults) (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) @@ -1433,20 +1403,20 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))) (fun - (ir1-convert-lambda-body - `((%funcall ,fun ,@(reverse vals) ,@defaults)) - arg-vars))) - (mapc #'(lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) + (ir1-convert-lambda-body `((%funcall ,fun + ,@(reverse vals) + ,@defaults)) + arg-vars))) + (mapc (lambda (var arg-var) + (when (cdr (leaf-refs arg-var)) + (setf (leaf-ever-used var) t))) fvars arg-vars) fun)) ;;; This function deals with supplied-p vars in optional arguments. If ;;; the there is no supplied-p arg, then we just call -;;; IR1-Convert-Hairy-Args on the remaining arguments, and generate a +;;; IR1-CONVERT-HAIRY-ARGS on the remaining arguments, and generate a ;;; optional entry that calls the result. If there is a supplied-p ;;; var, then we add it into the default vars and throw a T into the ;;; entry values. The resulting entry point function is returned. @@ -1483,32 +1453,30 @@ (list (arg-info-default info) nil) (list (arg-info-default info)))))) -;;; Create the More-Entry function for the Optional-Dispatch Res. -;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var -;;; for any Rest arg. Keys is a list of the keyword arg vars. +;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES. +;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is +;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars. ;;; -;;; The most interesting thing that we do is parse keywords. We create a -;;; bunch of temporary variables to hold the result of the parse, and then loop -;;; over the supplied arguments, setting the appropriate temps for the supplied -;;; keyword. Note that it is significant that we iterate over the keywords in -;;; reverse order --- this implements the CL requirement that (when a keyword -;;; appears more than once) the first value is used. +;;; The most interesting thing that we do is parse keywords. We create +;;; a bunch of temporary variables to hold the result of the parse, +;;; and then loop over the supplied arguments, setting the appropriate +;;; temps for the supplied keyword. Note that it is significant that +;;; we iterate over the keywords in reverse order --- this implements +;;; the CL requirement that (when a keyword appears more than once) +;;; the first value is used. ;;; ;;; If there is no supplied-p var, then we initialize the temp to the -;;; default and just pass the temp into the main entry. Since non-constant -;;; keyword args are forcibly given a supplied-p var, we know that the default -;;; is constant, and thus safe to evaluate out of order. +;;; default and just pass the temp into the main entry. Since +;;; non-constant &KEY args are forcibly given a supplied-p var, we +;;; know that the default is constant, and thus safe to evaluate out +;;; of order. ;;; -;;; If there is a supplied-p var, then we create temps for both the value -;;; and the supplied-p, and pass them into the main entry, letting it worry -;;; about defaulting. +;;; If there is a supplied-p var, then we create temps for both the +;;; value and the supplied-p, and pass them into the main entry, +;;; letting it worry about defaulting. ;;; -;;; We deal with :allow-other-keys by delaying unknown keyword errors until -;;; we have scanned all the keywords. -;;; -;;; When converting the function, we bind *LEXENV* to change the -;;; compilation policy over to the interface policy, so that keyword -;;; args will be checked even when type checking isn't on in general. +;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors +;;; until we have scanned all the keywords. (defun convert-more-entry (res entry-vars entry-vals rest morep keys) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) @@ -1525,8 +1493,7 @@ (context-temp (make-lambda-var :name n-context)) (n-count (gensym "N-COUNT-")) (count-temp (make-lambda-var :name n-count - :type (specifier-type 'index))) - (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))) + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1543,7 +1510,7 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) + (policy *lexenv* (zerop safety))))) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -1552,7 +1519,7 @@ (dolist (key keys) (let* ((info (lambda-var-arg-info key)) (default (arg-info-default info)) - (keyword (arg-info-keyword info)) + (keyword (arg-info-key info)) (supplied-p (arg-info-supplied-p info)) (n-value (gensym "N-VALUE-"))) (temps `(,n-value ,default)) @@ -1560,13 +1527,11 @@ (let ((n-supplied (gensym "N-SUPPLIED-"))) (temps n-supplied) (arg-vals n-value n-supplied) - ;; MNA: non-self-eval-keyword patch (tests `((eq ,n-key ',keyword) (setq ,n-supplied t) (setq ,n-value ,n-value-temp))))) (t (arg-vals n-value) - ;; MNA: non-self-eval-keyword patch (tests `((eq ,n-key ',keyword) (setq ,n-value ,n-value-temp))))))) @@ -1579,7 +1544,7 @@ (body `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) + (%odd-key-arguments-error))) (body `(locally @@ -1594,7 +1559,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-keyword-argument-error ,n-losep))))))) + (%unknown-key-argument-error ,n-losep))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -1606,17 +1571,17 @@ (values)) -;;; Called by IR1-Convert-Hairy-Args when we run into a rest or -;;; keyword arg. The arguments are similar to that function, but we -;;; split off any rest arg and pass it in separately. Rest is the rest -;;; arg var, or NIL if there is no rest arg. Keys is a list of the -;;; keyword argument vars. +;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST +;;; or &KEY arg. The arguments are similar to that function, but we +;;; split off any &REST arg and pass it in separately. REST is the +;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of +;;; the &KEY argument vars. ;;; -;;; When there are keyword arguments, we introduce temporary gensym +;;; When there are &KEY arguments, we introduce temporary gensym ;;; variables to hold the values while keyword defaulting is in ;;; progress to get the required sequential binding semantics. ;;; -;;; This gets interesting mainly when there are keyword arguments with +;;; This gets interesting mainly when there are &KEY arguments with ;;; supplied-p vars or non-constant defaults. In either case, pass in ;;; a supplied-p var. If the default is non-constant, we introduce an ;;; IF in the main entry that tests the supplied-p var and decides @@ -1680,11 +1645,11 @@ (main-vals (arg-info-default info)) (bind-vals n-val))))) - (let* ((main-entry (ir1-convert-lambda-body body (main-vars) - (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals) - t - cont)) + (let* ((main-entry (ir1-convert-lambda-body + body (main-vars) + :aux-vars (append (bind-vars) aux-vars) + :aux-vals (append (bind-vals) aux-vals) + :result cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1701,32 +1666,33 @@ ;;; arguments, analyzing the arglist on the way down and generating entry ;;; points on the way up. ;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. +;;; Default-Vars is a reversed list of all the argument vars processed +;;; so far, including supplied-p vars. Default-Vals is a list of the +;;; names of the Default-Vars. ;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. +;;; Entry-Vars is a reversed list of processed argument vars, +;;; excluding supplied-p vars. Entry-Vals is a list things that can be +;;; evaluated to get the values for all the vars from the Entry-Vars. +;;; It has the var name for each required or optional arg, and has T +;;; for each supplied-p arg. ;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. +;;; Vars is a list of the Lambda-Var structures for arguments that +;;; haven't been processed yet. Supplied-p-p is true if a supplied-p +;;; argument has already been processed; only in this case are the +;;; Default-XXX and Entry-XXX different. ;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. +;;; The result at each point is a lambda which should be called by the +;;; above level to default the remaining arguments and evaluate the +;;; body. We cause the body to be evaluated by converting it and +;;; returning it as the result when the recursion bottoms out. ;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. +;;; Each level in the recursion also adds its entry point function to +;;; the result Optional-Dispatch. For most arguments, the defaulting +;;; function and the entry point function will be the same, but when +;;; supplied-p args are present they may be different. ;;; -;;; When we run into a rest or keyword arg, we punt out to -;;; IR1-Convert-More, which finishes for us in this case. +;;; When we run into a &REST or &KEY arg, we punt out to +;;; IR1-CONVERT-MORE, which finishes for us in this case. (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars @@ -1743,7 +1709,9 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals t cont))) + :aux-vars aux-vars + :aux-vals aux-vals + :result cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1789,9 +1757,9 @@ aux-vals cont))))))) ;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; Optional-Dispatch to represent a lambda. We cons up the result and +;;; call 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 cont) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars @@ -1843,8 +1811,10 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals cont) - (ir1-convert-lambda-body forms vars aux-vars aux-vals - t cont)))) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) (setf (leaf-name res) name) @@ -1921,11 +1891,9 @@ (prev-link entry start) (use-continuation entry dummy) - ;; MNA - Re: two obscure bugs in CMU CL (let* ((env-entry (list entry cont)) - (*lexenv* - (make-lexenv :blocks (list (cons name env-entry)) - :cleanup cleanup))) + (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) + :cleanup cleanup))) (push env-entry (continuation-lexenv-uses cont)) (ir1-convert-progn-body dummy cont forms)))) @@ -1953,7 +1921,7 @@ (prev-link exit value-cont) (use-continuation exit (second found)))) -;;; Return a list of the segments of a tagbody. Each segment looks +;;; Return a list of the segments of a TAGBODY. Each segment looks ;;; like (
* (go )). That is, we break up the ;;; tagbody into segments of non-tag statements, and explicitly ;;; represent the drop-through with a GO. The first segment has a @@ -1965,7 +1933,7 @@ (collect ((segments)) (let ((current (cons nil body))) (loop - (let ((tag-pos (position-if-not #'listp current :start 1))) + (let ((tag-pos (position-if (complement #'listp) current :start 1))) (unless tag-pos (segments `(,@current nil)) (return)) @@ -2009,15 +1977,13 @@ (conts)) (starts dummy) (dolist (segment (rest segments)) - ;; MNA - Re: two obscure bugs (let* ((tag-cont (make-continuation)) (tag (list (car segment) entry tag-cont))) (conts tag-cont) (starts tag-cont) (continuation-starts-block tag-cont) (tags tag) - (push (cdr tag) (continuation-lexenv-uses tag-cont)) - )) + (push (cdr tag) (continuation-lexenv-uses tag-cont)))) (conts cont) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) @@ -2089,7 +2055,7 @@ ;; host. When we go from the cross-compiler (where we bound ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL - ;; would go and executes nested EVAL-WHENs even when they're not + ;; would go and execute nested EVAL-WHENs even when they're not ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes ;; the cross-compilation host to bind its own ;; *ALREADY-EVALED-THIS* variable, so that the problem is @@ -2100,7 +2066,7 @@ ;; conditional on #+CMU.) #+(and sb-xc-host (or sbcl cmu)) (let (#+sbcl (sb-eval::*already-evaled-this* t) - #+cmu (stub:probably similar but has not been tested)) + #+cmu (common-lisp::*already-evaled-this* t)) (eval `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)))) @@ -2208,9 +2174,6 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; a hashtable that translates from primitive names to translation functions -(defvar *primitive-translators* (make-hash-table :test 'eq)) - ;;; If there is a primitive translator, then we expand the call. ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first ;;; argument is the template, the second is a list of the results of @@ -2221,60 +2184,54 @@ ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for -;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be -;;; possible to reimplement BYTE-BLT (the only use of -;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive -;;; translators altogether, so that there would be no distinction -;;; between primitives and vops? Then we could call primitives vops, -;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to -;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906 -;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I -;;; think BYTE-BLT could probably just become an inline function. +;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU +;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call +;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename +;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to +;;; VOP or %VOP.. -- WHN 2001-06-11 +;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((&whole form name &rest args) start cont) (unless (symbolp name) (compiler-error "The primitive name ~S is not a symbol." name)) - (let* ((translator (gethash name *primitive-translators*))) - (if translator - (ir1-convert start cont (funcall translator (cdr form))) - (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "The primitive name ~A is not defined." - name))) - (required (length (template-arg-types template))) - (info (template-info-arg-count template)) - (min (+ required info)) - (nargs (length args))) - (if (template-more-args-type template) - (when (< nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) - (unless (= nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) - - (when (eq (template-result-types template) :conditional) - (compiler-error - "%PRIMITIVE was used with a conditional template.")) - - (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) - - (ir1-convert start - cont - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))))) + (let* ((template (or (gethash name *backend-template-names*) + (compiler-error + "The primitive name ~A is not defined." + name))) + (required (length (template-arg-types template))) + (info (template-info-arg-count template)) + (min (+ required info)) + (nargs (length args))) + (if (template-more-args-type template) + (when (< nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) + (unless (= nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants exactly ~R." + name + nargs + min))) + + (when (eq (template-result-types template) :conditional) + (compiler-error + "%PRIMITIVE was used with a conditional template.")) + + (when (template-more-results-type template) + (compiler-error + "%PRIMITIVE was used with an unknown values template.")) + + (ir1-convert start + cont + `(%%primitive ',template + ',(eval-info-args + (subseq args required min)) + ,@(subseq args 0 required) + ,@(subseq args min))))) ;;;; QUOTE and FUNCTION @@ -2466,7 +2423,7 @@ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values nil))))) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY ;;; has to preserves top-level-formness, but we don't need to worry @@ -2482,8 +2439,7 @@ the Forms are also processed as top-level forms." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (let ((*lexenv* (process-decls decls nil nil cont))) - ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway! - (ir1-convert-progn-body start cont forms)))) + (ir1-convert-aux-bindings start cont forms nil nil)))) ;;;; FLET and LABELS @@ -2564,9 +2520,9 @@ ;;;; THE -;;; 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 +;;; 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. ;;; @@ -2585,8 +2541,8 @@ ;;; 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 +;;; 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 @@ -2601,13 +2557,14 @@ (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) - (intersects (values-types-intersect old-type ctype)) + (intersects (values-types-equal-or-intersect old-type ctype)) (int (values-type-intersection old-type ctype)) (new (if intersects int old-type))) (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) - (not (policy nil (= brevity 3)))) ;FIXME: really OK to suppress? + (not (policy *lexenv* + (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warning "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" (type-specifier ctype) @@ -2616,26 +2573,26 @@ (make-lexenv :type-restrictions `((,cont . ,new)) :default lexenv))) +;;; Assert that FORM evaluates to the specified type (which may be a +;;; VALUES type). +;;; ;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101, ;;; this didn't seem to expand into an assertion, at least for ALIEN ;;; values. Check that SBCL doesn't have this problem. (def-ir1-translator the ((type value) start cont) - #!+sb-doc - "THE Type Form - Assert that Form evaluates to the specified type (which may be a VALUES - type.)" (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) (ir1-convert start cont value))) +;;; This is like the THE special form, except that it believes +;;; whatever you tell it. It will never generate a type check, but +;;; will cause a warning if the compiler can prove the assertion is +;;; wrong. +;;; ;;; 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. (def-ir1-translator truly-the ((type value) start cont) #!+sb-doc - "Truly-The Type Value - Like the THE special form, except that it believes whatever you tell it. It - will never generate a type check, but will cause a warning if the compiler - can prove the assertion is wrong." (declare (inline member)) (let ((type (values-specifier-type type)) (old (find-uses cont))) @@ -2650,11 +2607,6 @@ ;;; otherwise look at the global information. If the name is for a ;;; constant, then error out. (def-ir1-translator setq ((&whole source &rest things) start cont) - #!+sb-doc - "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)) @@ -2677,7 +2629,7 @@ name)) (set-variable start cont leaf (second things))) (cons - (assert (eq (car leaf) 'MACRO)) + (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info (ir1-convert start cont @@ -2688,8 +2640,8 @@ (ir1-convert-progn-body start cont (sets))) (sets `(setq ,(first thing) ,(second thing)))))))) -;;; Kind of like Reference-Leaf, but we generate a Set node. This -;;; should only need to be called in Setq. +;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. +;;; This should only need to be called in SETQ. (defun set-variable (start cont var value) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) @@ -2756,7 +2708,7 @@ ;;; referencing it. (def-ir1-translator %cleanup-function ((name) start cont) (let ((fun (lexenv-find name functions))) - (assert (lambda-p fun)) + (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -2896,7 +2848,7 @@ (dolist (pred (block-pred end-block)) (unlink-blocks pred end-block) (link-blocks pred cont-block)) - (assert (not (continuation-dest dummy-result))) + (aver (not (continuation-dest dummy-result))) (delete-continuation dummy-result) (remove-from-dfo end-block)))) @@ -2939,8 +2891,8 @@ ;; QDEF should be a sharp-quoted definition. We don't want to make a ;; function of it just yet, so we just drop the sharp-quote. (def (progn - (assert (eq 'function (first qdef))) - (assert (proper-list-of-length-p qdef 2)) + (aver (eq 'function (first qdef))) + (aver (proper-list-of-length-p qdef 2)) (second qdef)))) (unless (symbolp name) @@ -3015,7 +2967,6 @@ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name)))) ;;;; defining global functions @@ -3039,8 +2990,7 @@ `(,(car x) . (macro . ,(coerce (cdr x) 'function)))) macros) - :cookie (lexenv-cookie *lexenv*) - :interface-cookie (lexenv-interface-cookie *lexenv*)))) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3062,10 +3012,10 @@ (when (eq x (assoc name variables :test #'eq)) (typecase what (cons - (assert (eq (car what) 'macro)) + (aver (eq (car what) 'macro)) (push x symmacs)) (global-var - (assert (eq (global-var-kind what) :special)) + (aver (eq (global-var-kind what) :special)) (push `(special ,name) decls)) (t (return t)))))) nil) @@ -3100,7 +3050,7 @@ (found (find-free-function name "Eh?"))) (note-name-defined name :function) (cond ((not (defined-function-p found)) - (assert (not (info :function :inlinep name))) + (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) (res (make-defined-function :name name @@ -3118,7 +3068,7 @@ ;;; Check a new global function definition for consistency with ;;; previous declaration or definition, and assert argument/result -;;; types if appropriate. This this assertion is suppressed by the +;;; types if appropriate. This assertion is suppressed by the ;;; EXPLICIT-CHECK attribute, which is specified on functions that ;;; check their argument types as a consequence of type dispatching. ;;; This avoids redundant checks such as NUMBERP on the args to +, @@ -3129,8 +3079,15 @@ (info (info :function :info (leaf-name var)))) (assert-definition-type fun type - :error-function #'compiler-warning - :warning-function (cond (info #'compiler-warning) + ;; KLUDGE: Common Lisp is such a dynamic language that in general + ;; all we can do here in general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING in the special case of + ;; of type mismatches within a compilation unit (as in section + ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't + ;; keep track of whether the mismatched data came from the same + ;; compilation unit, so we can't do that. -- WHN 2001-02-11 + :error-function #'compiler-style-warning + :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note) (t nil)) :really-assert @@ -3224,5 +3181,4 @@ ,@(when save-expansion `(',save-expansion))))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name))))))