X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=6d578ad370fdba82eb86666a30ed96b50123185d;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=c4029446bce4cee76adc6a70be225864b3fa8b10;hpb=f392742d2781f42b3bb15b637e5008e10fbbe092;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c402944..6d578ad 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -197,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)) @@ -800,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) @@ -817,7 +820,7 @@ (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 (= inhibit-warnings 3)) (compiler-warning @@ -843,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)) @@ -871,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)) @@ -915,7 +918,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)) @@ -952,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))) @@ -985,71 +988,55 @@ #!+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 - :policy (process-optimize-declaration spec (lexenv-policy res)))) - (optimize-interface - (make-lexenv - :default res - :interface-policy (process-optimize-declaration - spec - (lexenv-interface-policy res)))) - (type - (process-type-declaration (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 - "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))))) - (process-type-declaration spec res vars)) - ((info :declaration :recognized what) - res) - (t - (compiler-warning "unrecognized declaration ~S" spec) - res)))))) +(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 @@ -1068,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. @@ -1126,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) @@ -1168,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)) @@ -1227,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)) @@ -1237,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) @@ -1245,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) @@ -1282,7 +1269,7 @@ ;;; 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 +;;; 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) @@ -1479,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 @@ -1548,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)) @@ -1573,7 +1562,7 @@ (body `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) + (%odd-key-arguments-error))) (body `(locally @@ -1588,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) @@ -1600,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 @@ -1719,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 @@ -1945,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 @@ -1957,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)) @@ -3101,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 +, @@ -3112,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