X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=70d4cecc07daeade47141f37119e2e0afff71900;hb=4fc9d21ae1d8a6a2f8ff70f589d5da103203de13;hp=67f5c45d0a95028979a9faf38b42d4af811fefe2;hpb=60011b86627fa68eeacffd49c49826e474c7fd82;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 67f5c45..70d4cec 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -800,7 +800,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) @@ -819,7 +819,7 @@ type (type-intersection 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) @@ -843,12 +843,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 +871,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 +915,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 +927,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))) @@ -952,7 +952,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,83 +985,63 @@ #!+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) +(defun process-1-decl (raw-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))))) - (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. + (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) @@ -1070,10 +1050,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. @@ -1284,7 +1264,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) @@ -1298,7 +1278,7 @@ (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)))))) @@ -1431,7 +1411,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)) @@ -1524,7 +1504,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) @@ -1947,7 +1927,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 @@ -1959,7 +1939,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)) @@ -2555,9 +2535,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. ;;; @@ -2576,8 +2556,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 @@ -2598,7 +2578,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) @@ -2607,26 +2587,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))) @@ -2641,11 +2621,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)) @@ -2679,8 +2654,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))) @@ -3029,8 +3004,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,