X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=6d578ad370fdba82eb86666a30ed96b50123185d;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=fdb8a02940bb8231730dffdcb3c8b4fe3505a308;hpb=985c2d805428e1bbc479524fc955da5028d3e66e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fdb8a02..6d578ad 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,13 +48,6 @@ (defvar *converting-for-interpreter* nil) ;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*. -;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO -;;; definitions to be installed in the compilation environment as -;;; interpreted functions. We set this to false when compiling some -;;; parts of the system. -(defvar *compile-time-define-macros* t) -;;; FIXME: I think this can go away with the new system. - ;;; FIXME: This nastiness was one of my original motivations to start ;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should ;;; be made not the default, and perhaps should be controlled by @@ -204,7 +197,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)) @@ -807,7 +803,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) @@ -824,9 +820,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 nil (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -850,12 +846,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)) @@ -878,7 +874,7 @@ ;;; 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)) @@ -922,8 +918,8 @@ ;;; 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) - (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq))) +(defun process-inline-decl (spec res fvars) + (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) (let ((fvar (find name fvars :key #'leaf-name :test #'equal))) @@ -934,7 +930,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed brevity)) + (when (policy nil (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -959,7 +955,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))) @@ -992,87 +988,65 @@ #!+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)))) + (optimize-interface + (make-lexenv + :default res + :interface-policy (process-optimize-decl + spec + (lexenv-interface-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 nil (> 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) @@ -1081,10 +1055,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. @@ -1139,38 +1113,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") 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) @@ -1181,9 +1155,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)) @@ -1240,9 +1214,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)) @@ -1250,7 +1224,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) @@ -1258,14 +1232,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) @@ -1289,15 +1263,15 @@ (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. +;;; 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. ;;; -;;; 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. +;;; If INTERFACE is true, then we convert bindings with the interface +;;; policy. For real &AUX bindings, and for 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) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) @@ -1309,21 +1283,23 @@ (reference-leaf start fun-cont fun) (let ((*lexenv* (if interface (make-lexenv - :cookie (make-interface-cookie *lexenv*)) + :policy (make-interface-policy *lexenv*)) *lexenv*))) (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. +;;; 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) (declare (type continuation start cont) @@ -1347,24 +1323,24 @@ (values)) ;;; Create a lambda node out of some code, returning the result. The -;;; bindings are specified by the list of var structures Vars. We deal -;;; with adding the names to the Lexenv-Variables for the conversion. -;;; The result is added to the New-Functions in the -;;; *Current-Component* and linked to the component head and tail. +;;; bindings are specified by the list of VAR structures VARS. We deal +;;; with adding the names to the LEXENV-VARIABLES for the conversion. +;;; The result is added to the NEW-FUNCTIONS in the +;;; *CURRENT-COMPONENT* and linked to the component head and tail. ;;; -;;; We detect special bindings here, replacing the original Var in the +;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the -;;; special vars to IR1-Convert-Special-Bindings, which actually emits +;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits ;;; the special binding code. ;;; -;;; We ignore any Arg-Info in the Vars, trusting that someone else is +;;; We ignore any ARG-INFO in the VARS, trusting that someone else is ;;; dealing with &nonsense. ;;; -;;; 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.) +;;; 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) (declare (list body vars aux-vars aux-vals) @@ -1418,12 +1394,12 @@ 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. ;;; @@ -1440,7 +1416,7 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))) + (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))) (fun (ir1-convert-lambda-body `((%funcall ,fun ,@(reverse vals) ,@defaults)) @@ -1453,7 +1429,7 @@ ;;; 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. @@ -1490,28 +1466,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. +;;; 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 @@ -1533,7 +1511,7 @@ (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*)))) + (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))) (arg-vars context-temp count-temp) @@ -1559,7 +1537,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)) @@ -1567,13 +1545,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))))))) @@ -1586,7 +1562,7 @@ (body `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) + (%odd-key-arguments-error))) (body `(locally @@ -1601,7 +1577,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) @@ -1613,17 +1589,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 @@ -1732,8 +1708,8 @@ ;;; 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 @@ -1928,11 +1904,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)))) @@ -1960,7 +1934,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 @@ -1972,7 +1946,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)) @@ -2016,15 +1990,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)))) @@ -2063,7 +2035,7 @@ ;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1 ;;; conversion done by EVAL, or by conversion of the body for ;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do -;;; not* eval since some enclosing eval-when already did. +;;; not* EVAL since some enclosing EVAL-WHEN already did. ;;; ;;; We know we are EVAL'ing for LOAD since we wouldn't get called ;;; otherwise. If LOAD is a situation we call FUN on body. If we @@ -2086,7 +2058,31 @@ (not sb!eval::*already-evaled-this*))) (sb!eval::*already-evaled-this* t)) (when do-eval - (eval `(progn ,@body))) + + ;; This is the natural way to do it. + #-(and sb-xc-host (or sbcl cmu)) + (eval `(progn ,@body)) + + ;; This is a disgusting hack to work around bug IR1-3 when using + ;; SBCL (or CMU CL, for that matter) as a cross-compilation + ;; 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 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 + ;; suppressed. + ;; + ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if + ;; CMU CL doesn't fix the bug, then this hack can be made + ;; conditional on #+CMU.) + #+(and sb-xc-host (or sbcl cmu)) + (let (#+sbcl (sb-eval::*already-evaled-this* t) + #+cmu (common-lisp::*already-evaled-this* t)) + (eval `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@body)))) + (if (or (intersection '(:load-toplevel load) situations) (and *converting-for-interpreter* (intersection '(:execute eval) situations))) @@ -2098,11 +2094,37 @@ "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)))) -;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any + ;; It's difficult to handle EVAL-WHENs completely correctly in the + ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly + ;; language..) Since we, the system implementors, control not only + ;; the cross-compiler but also the code that it processes, we can + ;; handle this either by making the cross-compiler smarter about + ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult + ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs + ;; can be generated by many macro expansions, it's not always easy + ;; to detect problems by skimming the source code, so we'll try to + ;; add some code here to help out. + ;; + ;; Nested EVAL-WHENs are tricky. + #+sb-xc-host + (labels ((contains-toplevel-eval-when-p (body-part) + (and (consp body-part) + (or (eq (first body-part) 'eval-when) + (and (member (first body-part) + '(locally macrolet progn symbol-macrolet)) + (some #'contains-toplevel-eval-when-p + (rest body-part))))))) + (/show "testing for nested EVAL-WHENs" body) + (when (some #'contains-toplevel-eval-when-p body) + (compiler-style-warning "nested EVAL-WHENs in cross-compilation"))) + + (do-eval-when-stuff situations + body + (lambda (forms) + (ir1-convert-progn-body start cont forms)))) + +;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any ;;; arguments. (defun do-macrolet-stuff (definitions fun) (declare (list definitions) (type function fun)) @@ -2439,8 +2461,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 nil)))) ;;;; FLET and LABELS @@ -2521,9 +2542,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. ;;; @@ -2542,8 +2563,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 @@ -2564,7 +2585,7 @@ (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 nil (= 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) @@ -2573,26 +2594,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))) @@ -2607,11 +2628,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)) @@ -2645,8 +2661,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))) @@ -2673,11 +2689,11 @@ `(multiple-value-call #'%throw ,tag ,result))) ;;; This is a special special form used to instantiate a cleanup as -;;; the current cleanup within the body. Kind is a the kind of cleanup -;;; to make, and Mess-Up is a form that does the mess-up action. We -;;; make the MESS-UP be the USE of the Mess-Up form's continuation, +;;; the current cleanup within the body. KIND is a the kind of cleanup +;;; to make, and MESS-UP is a form that does the mess-up action. We +;;; make the MESS-UP be the USE of the MESS-UP form's continuation, ;;; and introduce the cleanup into the lexical environment. We -;;; back-patch the Entry-Cleanup for the current cleanup to be the new +;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new ;;; cleanup, since this inner cleanup is the interesting one. (def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont) (let ((dummy (make-continuation)) @@ -2694,13 +2710,13 @@ ;;; This is a special special form that makes an "escape function" ;;; which returns unknown values from named block. We convert the -;;; function, set its kind to :Escape, and then reference it. The +;;; function, set its kind to :ESCAPE, and then reference it. The ;;; :Escape kind indicates that this function's purpose is to ;;; represent a non-local control transfer, and that it might not ;;; actually have to be compiled. ;;; ;;; Note that environment analysis replaces references to escape -;;; functions with references to the corresponding NLX-Info structure. +;;; functions with references to the corresponding NLX-INFO structure. (def-ir1-translator %escape-function ((tag) start cont) (let ((fun (ir1-convert-lambda `(lambda () @@ -2709,7 +2725,7 @@ (reference-leaf start cont fun))) ;;; Yet another special special form. This one looks up a local -;;; function and smashes it to a :Cleanup function, as well as +;;; function and smashes it to a :CLEANUP function, as well as ;;; referencing it. (def-ir1-translator %cleanup-function ((name) start cont) (let ((fun (lexenv-find name functions))) @@ -2719,7 +2735,7 @@ ;;; We represent the possibility of the control transfer by making an ;;; "escape function" that does a lexical exit, and instantiate the -;;; cleanup using %within-cleanup. +;;; cleanup using %WITHIN-CLEANUP. (def-ir1-translator catch ((tag &body body) start cont) #!+sb-doc "Catch Tag Form* @@ -2739,8 +2755,8 @@ ;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the ;;; cleanup forms into a local function so that they can be referenced ;;; both in the case where we are unwound and in any local exits. We -;;; use %Cleanup-Function on this to indicate that reference by -;;; %Unwind-Protect isn't "real", and thus doesn't cause creation of +;;; use %CLEANUP-FUNCTION on this to indicate that reference by +;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of ;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) #!+sb-doc @@ -2775,12 +2791,12 @@ ;;;; multiple-value stuff ;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an -;;; MV-Combination. +;;; MV-COMBINATION. ;;; ;;; If there are no arguments, then we convert to a normal -;;; combination, ensuring that a MV-Combination always has at least +;;; combination, ensuring that a MV-COMBINATION always has at least ;;; one argument. This can be regarded as an optimization, but it is -;;; more important for simplifying compilation of MV-Combinations. +;;; more important for simplifying compilation of MV-COMBINATIONS. (def-ir1-translator multiple-value-call ((fun &rest args) start cont) #!+sb-doc "MULTIPLE-VALUE-CALL Function Values-Form* @@ -2808,16 +2824,16 @@ (use-continuation node cont) (setf (basic-combination-args node) (arg-conts)))))) -;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a +;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a ;;; the result code use result continuation (CONT), but transfer ;;; control to the evaluation of the body. In other words, the result -;;; continuation isn't Immediately-Used-P by the nodes that compute +;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute ;;; the result. ;;; ;;; In order to get the control flow right, we convert the result with ;;; a dummy result continuation, then convert all the uses of the -;;; dummy to be uses of CONT. If a use is an Exit, then we also -;;; substitute CONT for the dummy in the corresponding Entry node so +;;; dummy to be uses of CONT. If a use is an EXIT, then we also +;;; substitute CONT for the dummy in the corresponding ENTRY node so ;;; that they are consistent. Note that this doesn't amount to ;;; changing the exit target, since the control destination of an exit ;;; is determined by the block successor; we are just indicating the @@ -2830,7 +2846,7 @@ ;;; Note that we both exploit and maintain the invariant that the CONT ;;; to an IR1 convert method either has no block or starts the block ;;; that control should transfer to after completion for the form. -;;; Nested MV-Prog1's work because during conversion of the result +;;; Nested MV-PROG1's work because during conversion of the result ;;; form, we use dummy continuation whose block is the true control ;;; destination. (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) @@ -2859,13 +2875,18 @@ ;;;; interface to defining macros -;;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx -;;;; functions so that we get a chance to see what is going on. We -;;;; define IR1 translators for these functions which look at the -;;;; definition and then generate a call to the %%DEFxxx function. +;;;; FIXME: +;;;; classic CMU CL comment: +;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions +;;;; so that we get a chance to see what is going on. We define +;;;; IR1 translators for these functions which look at the +;;;; definition and then generate a call to the %%DEFxxx function. +;;;; Alas, this implementation doesn't do the right thing for +;;;; non-toplevel uses of these forms, so this should probably +;;;; be changed to use EVAL-WHEN instead. ;;; Return a new source path with any stuff intervening between the -;;; current path and the first form beginning with Name stripped off. +;;; current path and the first form beginning with NAME stripped off. ;;; This is used to hide the guts of DEFmumble macros to prevent ;;; annoying error messages. (defun revert-source-path (name) @@ -2912,12 +2933,9 @@ (compiler-error "The special form ~S can't be redefined as a macro." name))) - (setf (info :function :kind name) :macro) - (setf (info :function :where-from name) :defined) - - (when *compile-time-define-macros* - (setf (info :function :macro-function name) - (coerce def 'function))) + (setf (info :function :kind name) :macro + (info :function :where-from name) :defined + (info :function :macro-function name) (coerce def 'function)) (let* ((*current-path* (revert-source-path 'defmacro)) (fun (ir1-convert-lambda def name))) @@ -2928,22 +2946,37 @@ (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) (when sb!xc:*compile-print* - ;; MNA compiler message patch + ;; FIXME: It would be nice to convert this, and the other places + ;; which create compiler diagnostic output prefixed by + ;; semicolons, to use some common utility which automatically + ;; prefixes all its output with semicolons. (The addition of + ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the + ;; "MNA compiler message patch", and implemented by modifying a + ;; bunch of output statements on a case-by-case basis, which + ;; seems unnecessarily error-prone and unclear, scattering + ;; implicit information about output style throughout the + ;; system.) Starting by rewriting COMPILER-MUMBLE to add + ;; semicolon prefixes would be a good start, and perhaps also: + ;; * Add semicolon prefixes for "FOO assembled" messages emitted + ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed. + ;; * At least some debugger output messages deserve semicolon + ;; prefixes too: + ;; ** restarts table + ;; ** "Within the debugger, you can type HELP for help." (compiler-mumble "~&; converted ~S~%" name)))) (def-ir1-translator %define-compiler-macro ((name def lambda-list doc) start cont :kind :function) (let ((name (eval name)) - (def (second def))) ; Don't want to make a function just yet... + (def (second def))) ; We don't want to make a function just yet... (when (eq (info :function :kind name) :special-form) (compiler-error "attempt to define a compiler-macro for special form ~S" name)) - (when *compile-time-define-macros* - (setf (info :function :compiler-macro-function name) - (coerce def 'function))) + (setf (info :function :compiler-macro-function name) + (coerce def 'function)) (let* ((*current-path* (revert-source-path 'define-compiler-macro)) (fun (ir1-convert-lambda def name))) @@ -2955,82 +2988,7 @@ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name)))) - -;;; Update the global environment to correspond to the new definition. -(def-ir1-translator %defconstant ((name value doc) start cont - :kind :function) - (let ((name (eval name)) - (newval (eval value))) - (unless (symbolp name) - (compiler-error "constant name not a symbol: ~S" name)) - (when (eq name t) - (compiler-error "The value of T can't be changed.")) - (when (eq name nil) - (compiler-error "Nihil ex nihil. (can't change NIL)")) - (when (keywordp name) - (compiler-error "Keyword values can't be changed.")) - - (let ((kind (info :variable :kind name))) - (case kind - (:constant - ;; Note: This behavior (disparaging any non-EQL modification) - ;; is unpopular, but it is specified by ANSI (i.e. ANSI says - ;; a non-EQL change has undefined consequences). I think it's - ;; a bad idea to encourage nonconforming programming style - ;; even if it's convenient. If people really want things - ;; which are constant in some sense other than EQL, I suggest - ;; either just using DEFVAR (which is what I generally do), - ;; or defining something like this (untested) code: - ;; (DEFMACRO DEFCONSTANT-EQX (SYMBOL EXPR EQX &OPTIONAL DOC) - ;; "This macro is to be used instead of DEFCONSTANT for values - ;; which are appropriately compared using the function given by - ;; the EQX argument instead of EQL." - ;; (LET ((EXPR-TMP (GENSYM "EXPR-TMP-"))) - ;; `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - ;; (LET ((,EXPR-TMP ,EXPR)) - ;; (UNLESS (AND (BOUNDP ,SYMBOL) - ;; (CONSTANTP ,SYMBOL) - ;; (FUNCALL ,EQX - ;; (SYMBOL-VALUE ,SYMBOL) - ;; ,EXPR-TMP)) - ;; (DEFCONSTANT ,SYMBOL ,EXPR ,@(WHEN DOC `(,DOC)))))))) - ;; I prefer using DEFVAR, though, first because it's trivial, - ;; and second because using DEFCONSTANT lets the compiler - ;; optimize code by removing indirection, copying the current - ;; value of the constant directly into the code, and for - ;; consed data structures, this optimization can become a - ;; pessimization. (And consed data structures are exactly - ;; where you'd be tempted to use DEFCONSTANT-EQX.) Why is - ;; this a pessimization? It does remove a layer of - ;; indirection, but it makes it hard for the system's - ;; load/dump logic to see that all references to the consed - ;; data structure refer to the same (EQ) object. If you use - ;; something like DEFCONSTANT-EQX, you'll tend to get one - ;; copy of the data structure bound to the symbol, and one - ;; more copy for each file where code refers to the constant. - ;; If you're moderately clever with MAKE-LOAD-FORM, you might - ;; be able to make the copy bound to the symbol at load time - ;; be EQ to the references in code in the same file, but it - ;; seems to be rather tricky to force code in different files - ;; to refer the same copy without doing the DEFVAR thing of - ;; indirection through a symbol. -- WHN 2000-11-02 - (unless (eql newval - (info :variable :constant-value name)) - (compiler-warning "redefining constant ~S as:~% ~S" name newval))) - (:global) - (t - (compiler-warning "redefining ~(~A~) ~S to be a constant" - kind - name)))) - - (setf (info :variable :kind name) :constant) - (setf (info :variable :where-from name) :defined) - (setf (info :variable :constant-value name) newval) - (remhash name *free-variables*)) - - (ir1-convert start cont `(%%defconstant ,name ,value ,doc))) ;;;; defining global functions @@ -3053,8 +3011,8 @@ `(,(car x) . (macro . ,(coerce (cdr x) 'function)))) macros) - :cookie (lexenv-cookie *lexenv*) - :interface-cookie (lexenv-interface-cookie *lexenv*)))) + :policy (lexenv-policy *lexenv*) + :interface-policy (lexenv-interface-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3095,7 +3053,7 @@ (global-var (when (defined-function-p what) (push `(,(car (rassoc (defined-function-inlinep what) - inlinep-translations)) + *inlinep-translations*)) ,name) decls))) (t (return t)))))) @@ -3132,7 +3090,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 +, @@ -3143,8 +3101,18 @@ (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 + ;; + ;; FIXME: Actually, I think we could issue a full WARNING if the + ;; new definition contradicts a DECLAIM FTYPE. + :error-function #'compiler-style-warning + :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note) (t nil)) :really-assert @@ -3210,8 +3178,8 @@ (*current-path* (revert-source-path 'defun)) (expansion (unless (eq (info :function :inlinep name) :notinline) (inline-syntactic-closure-lambda lambda)))) - ;; If not in a simple environment or NOTINLINE, then discard any forward - ;; references to this function. + ;; If not in a simple environment or NOTINLINE, then discard any + ;; forward references to this function. (unless expansion (remhash name *free-functions*)) (let* ((var (get-defined-function name)) @@ -3220,8 +3188,8 @@ expansion))) (setf (defined-function-inline-expansion var) expansion) (setf (info :function :inline-expansion name) save-expansion) - ;; If there is a type from a previous definition, blast it, since it is - ;; obsolete. + ;; If there is a type from a previous definition, blast it, + ;; since it is obsolete. (when (eq (leaf-where-from var) :defined) (setf (leaf-type var) (specifier-type 'function))) @@ -3238,5 +3206,4 @@ ,@(when save-expansion `(',save-expansion))))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name))))))