X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=6d077229a8f84ee4d618fde0114f16462d8cb8dd;hb=9a241987c408980164f71237f7d840265302bbc1;hp=0c83801eb4c6575f7460bd773fb4d0d1a3921938;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 0c83801..6d07722 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -53,7 +53,7 @@ ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. -(defun find-free-really-function (name) +(defun find-free-really-fun (name) (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) @@ -75,36 +75,13 @@ (specifier-type 'function)) :where-from where))) -;;; Return a SLOT-ACCESSOR structure usable for referencing the slot -;;; accessor NAME. CLASS is the structure class. -(defun find-structure-slot-accessor (class name) - (declare (type sb!xc:class class)) - (let* ((info (layout-info - (or (info :type :compiler-layout (sb!xc:class-name class)) - (class-layout class)))) - (accessor-name (if (listp name) (cadr name) name)) - (slot (find accessor-name (dd-slots info) - :key #'sb!kernel:dsd-accessor-name)) - (type (dd-name info)) - (slot-type (dsd-type slot))) - (unless slot - (error "can't find slot ~S" type)) - (make-slot-accessor - :%source-name name - :type (specifier-type - (if (listp name) - `(function (,slot-type ,type) ,slot-type) - `(function (,type) ,slot-type))) - :for class - :slot slot))) - -;;; Has the *FREE-FUNCTIONS* entry FREE-FUNCTION become invalid? +;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? ;;; ;;; In CMU CL, the answer was implicitly always true, so this ;;; predicate didn't exist. ;;; ;;; This predicate was added to fix bug 138 in SBCL. In some obscure -;;; circumstances, it was possible for a *FREE-FUNCTIONS* to contain a +;;; circumstances, it was possible for a *FREE-FUNS* to contain a ;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1 ;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka ;;; "dead") component. When this IR1 stuff was reused in a new @@ -113,12 +90,12 @@ ;;; *CURRENT-COMPONENT*. At that point things got all confused, since ;;; IR1 conversion was sending code to a component which had already ;;; been compiled and would never be compiled again. -(defun invalid-free-function-p (free-function) - ;; There might be other reasons that *FREE-FUNCTION* entries could +(defun invalid-free-fun-p (free-fun) + ;; There might be other reasons that *FREE-FUN* entries could ;; become invalid, but the only one we've been bitten by so far ;; (sbcl-0.pre7.118) is this one: - (and (defined-fun-p free-function) - (let ((functional (defined-fun-functional free-function))) + (and (defined-fun-p free-fun) + (let ((functional (defined-fun-functional free-fun))) (and (lambda-p functional) (or ;; (The main reason for this first test is to bail out @@ -138,18 +115,18 @@ ;; confusion. (eql (component-info (lambda-component functional)) :dead)))))) -;;; If NAME already has a valid entry in *FREE-FUNCTIONS*, then return +;;; If NAME already has a valid entry in *FREE-FUNS*, then return ;;; the value. Otherwise, make a new GLOBAL-VAR using information from -;;; the global environment and enter it in *FREE-FUNCTIONS*. If NAME +;;; the global environment and enter it in *FREE-FUNS*. If NAME ;;; names a macro or special form, then we error out using the ;;; supplied context which indicates what we were trying to do that ;;; demanded a function. -(defun find-free-function (name context) +(defun find-free-fun (name context) (declare (string context)) (declare (values global-var)) - (or (let ((old-free-function (gethash name *free-functions*))) - (and (not (invalid-free-function-p old-free-function)) - old-free-function)) + (or (let ((old-free-fun (gethash name *free-funs*))) + (and (not (invalid-free-fun-p old-free-fun)) + old-free-fun)) (ecase (info :function :kind name) ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. (:macro @@ -160,10 +137,10 @@ context)) ((:function nil) (check-fun-name name) - (note-if-setf-function-and-macro name) + (note-if-setf-fun-and-macro name) (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) - (setf (gethash name *free-functions*) + (setf (gethash name *free-funs*) (if (or expansion inlinep) (make-defined-fun :%source-name name @@ -171,38 +148,37 @@ :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (find-free-really-function name)))))))) + (find-free-really-fun name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. -(declaim (ftype (function (t string) leaf) find-lexically-apparent-function)) -(defun find-lexically-apparent-function (name context) - (let ((var (lexenv-find name functions :test #'equal))) +(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun)) +(defun find-lexically-apparent-fun (name context) + (let ((var (lexenv-find name funs :test #'equal))) (cond (var (unless (leaf-p var) (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t - (find-free-function name context))))) + (find-free-fun name context))))) ;;; Return the LEAF node for a global variable reference to NAME. If -;;; NAME is already entered in *FREE-VARIABLES*, then we just return -;;; the corresponding value. Otherwise, we make a new leaf using +;;; NAME is already entered in *FREE-VARS*, then we just return the +;;; corresponding value. Otherwise, we make a new leaf using ;;; information from the global environment and enter it in -;;; *FREE-VARIABLES*. If the variable is unknown, then we emit a -;;; warning. -(defun find-free-variable (name) +;;; *FREE-VARS*. If the variable is unknown, then we emit a warning. +(defun find-free-var (name) (declare (values (or leaf heap-alien-info))) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) - (or (gethash name *free-variables*) + (or (gethash name *free-vars*) (let ((kind (info :variable :kind name)) (type (info :variable :type name)) (where-from (info :variable :where-from name))) (when (and (eq where-from :assumed) (eq kind :global)) (note-undefined-reference name :variable)) - (setf (gethash name *free-variables*) + (setf (gethash name *free-vars*) (case kind (:alien (info :variable :alien-info name)) @@ -471,14 +447,14 @@ (cons form *current-path*)))) (if (atom form) (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-variable start cont form)) + (ir1-convert-var start cont form)) ((leaf-p form) (reference-leaf start cont form)) (t (reference-constant start cont form))) (let ((opname (car form))) (cond ((symbolp opname) - (let ((lexical-def (lexenv-find opname functions))) + (let ((lexical-def (lexenv-find opname funs))) (typecase lexical-def (null (ir1-convert-global-functoid start cont form)) (functional @@ -570,12 +546,12 @@ (use-continuation res cont))) ;;; Convert a reference to a symbolic constant or variable. If the -;;; symbol is entered in the LEXENV-VARIABLES we use that definition, +;;; symbol is entered in the LEXENV-VARS we use that definition, ;;; otherwise we find the current global definition. This is also ;;; where we pick off symbol macro and alien variable references. -(defun ir1-convert-variable (start cont name) +(defun ir1-convert-var (start cont name) (declare (type continuation start cont) (symbol name)) - (let ((var (or (lexenv-find name variables) (find-free-variable name)))) + (let ((var (or (lexenv-find name vars) (find-free-var name)))) (etypecase var (leaf (when (lambda-var-p var) @@ -585,7 +561,7 @@ (when (lambda-var-ignorep var) ;; (ANSI's specification for the IGNORE declaration requires ;; that this be a STYLE-WARNING, not a full WARNING.) - (compiler-style-warning "reading an ignored variable: ~S" name))) + (compiler-style-warn "reading an ignored variable: ~S" name))) (reference-leaf start cont var)) (cons (aver (eq (car var) 'MACRO)) @@ -629,8 +605,7 @@ ((nil :function) (ir1-convert-srctran start cont - (find-free-function fun - "shouldn't happen! (no-cmacro)") + (find-free-fun fun "shouldn't happen! (no-cmacro)") form)))) (defun muffle-warning-or-die () @@ -801,7 +776,7 @@ (declare (type continuation start cont) (list form) (type global-var var)) (let ((info (info :function :info (leaf-source-name var)))) (if (and info - (ir1-attributep (function-info-attributes info) predicate) + (ir1-attributep (fun-info-attributes info) predicate) (not (if-p (continuation-dest cont)))) (ir1-convert start cont `(if ,form t nil)) (ir1-convert-combination-checking-type start cont form var)))) @@ -877,8 +852,8 @@ (dolist (var-name (rest decl)) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var - (lexenv-find var-name variables) - (find-free-variable var-name)))) + (lexenv-find var-name vars) + (find-free-var var-name)))) (etypecase var (leaf (let* ((old-type (or (lexenv-find var type-restrictions) @@ -889,7 +864,7 @@ (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warning + (compiler-warn "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) var-name))) @@ -909,7 +884,7 @@ (if (or (restr) (new-vars)) (make-lexenv :default res :type-restrictions (restr) - :variables (new-vars)) + :vars (new-vars)) res)))) ;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles @@ -929,10 +904,10 @@ (found (setf (leaf-type found) type) (assert-definition-type found type - :warning-function #'compiler-note + :unwinnage-fun #'compiler-note :where "FTYPE declaration")) (t - (res (cons (find-lexically-apparent-function + (res (cons (find-lexically-apparent-fun name "in a function type declaration") type)))))) (if (res) @@ -957,7 +932,7 @@ (when (lambda-var-ignorep var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning + (compiler-style-warn "The ignored variable ~S is being declared special." name)) (setf (lambda-var-specvar var) @@ -966,7 +941,7 @@ (unless (assoc name (new-venv) :test #'eq) (new-venv (cons name (specvar-for-binding name)))))))) (if (new-venv) - (make-lexenv :default res :variables (new-venv)) + (make-lexenv :default res :vars (new-venv)) res))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP. @@ -996,7 +971,7 @@ (if fvar (setf (functional-inlinep fvar) sense) (let ((found - (find-lexically-apparent-function + (find-lexically-apparent-fun name "in an inline or notinline declaration"))) (etypecase found (functional @@ -1009,7 +984,7 @@ new-fenv))))))) (if new-fenv - (make-lexenv :default res :functions new-fenv) + (make-lexenv :default res :funs new-fenv) res))) ;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars. @@ -1033,8 +1008,8 @@ ((not var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring unknown variable ~S to be ignored" - name)) + (compiler-style-warn "declaring unknown variable ~S to be ignored" + name)) ;; FIXME: This special case looks like non-ANSI weirdness. ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro)) ;; Just ignore the IGNORE decl. @@ -1044,8 +1019,8 @@ ((lambda-var-specvar var) ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warning "declaring special variable ~S to be ignored" - name)) + (compiler-style-warn "declaring special variable ~S to be ignored" + name)) ((eq (first spec) 'ignorable) (setf (leaf-ever-used var) t)) (t @@ -1087,19 +1062,21 @@ (if *suppress-values-declaration* res (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) + (ir1ize-the-or-values (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).")) + "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)) + (compiler-warn "unrecognized declaration ~S" raw-spec)) res)))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR @@ -1128,7 +1105,7 @@ ;;; anonymous GLOBAL-VAR. (defun specvar-for-binding (name) (cond ((not (eq (info :variable :where-from name) :assumed)) - (let ((found (find-free-variable name))) + (let ((found (find-free-var name))) (when (heap-alien-info-p found) (compiler-error "~S is an alien variable and so can't be declared special." @@ -1167,7 +1144,7 @@ (compiler-error "The name of the lambda-variable ~S is a constant." name)) (cond ((eq kind :special) - (let ((specvar (find-free-variable name))) + (let ((specvar (find-free-var name))) (make-lambda-var :%source-name name :type (leaf-type specvar) :where-from (leaf-where-from specvar) @@ -1385,8 +1362,8 @@ ;;; 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-FUNS in the *CURRENT-COMPONENT* and +;;; with adding the names to the LEXENV-VARS for the conversion. The +;;; result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and ;;; linked to the component head and tail. ;;; ;;; We detect special bindings here, replacing the original VAR in the @@ -1446,7 +1423,7 @@ (note-lexical-binding (leaf-source-name var)) (new-venv (cons (leaf-source-name var) var)))))) - (let ((*lexenv* (make-lexenv :variables (new-venv) + (let ((*lexenv* (make-lexenv :vars (new-venv) :lambda lambda :cleanup nil))) (setf (bind-lambda bind) lambda) @@ -1643,7 +1620,7 @@ (body `(when (oddp ,n-count) - (%odd-key-arguments-error))) + (%odd-key-args-error))) (body `(locally @@ -1658,7 +1635,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-argument-error ,n-losep))))))) + (%unknown-key-arg-error ,n-losep))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -1964,12 +1941,11 @@ :default (process-decls decls nil nil (make-continuation) (make-null-lexenv)) - :variables (copy-list symbol-macros) - :functions - (mapcar (lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) - macros) + :vars (copy-list symbol-macros) + :funs (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) + macros) :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) :source-name source-name @@ -1980,7 +1956,7 @@ ;;; substitute for the previous references. (defun get-defined-fun (name) (proclaim-as-fun-name name) - (let ((found (find-free-function name "shouldn't happen! (defined-fun)"))) + (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) (cond ((not (defined-fun-p found)) (aver (not (info :function :inlinep name))) @@ -1991,11 +1967,11 @@ :declared :defined) :type (leaf-type found)))) (substitute-leaf res found) - (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition + (setf (gethash name *free-funs*) res))) + ;; If *FREE-FUNS* has a previously converted definition ;; for this name, then blow it away and try again. ((defined-fun-functional found) - (remhash name *free-functions*) + (remhash name *free-funs*) (get-defined-fun name)) (t found)))) @@ -2018,14 +1994,14 @@ ;; 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)) + :lossage-fun #'compiler-style-warn + :unwinnage-fun (cond (info #'compiler-style-warn) + (for-real #'compiler-note) + (t nil)) :really-assert (and for-real (not (and info - (ir1-attributep (function-info-attributes info) + (ir1-attributep (fun-info-attributes info) explicit-check)))) :where (if for-real "previous declaration" @@ -2048,7 +2024,7 @@ (setf (defined-fun-inline-expansion var) nil)) (let* ((name (leaf-source-name var)) (fun (funcall converter lambda :source-name name)) - (function-info (info :function :info name))) + (fun-info (info :function :info name))) (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) (setf (defined-fun-inline-expansion var) var-expansion) @@ -2056,10 +2032,10 @@ ;; old references. (unless (or (eq (defined-fun-inlinep var) :notinline) (not *block-compile*) - (and function-info - (or (function-info-transforms function-info) - (function-info-templates function-info) - (function-info-ir2-convert function-info)))) + (and fun-info + (or (fun-info-transforms fun-info) + (fun-info-templates fun-info) + (fun-info-ir2-convert fun-info)))) (substitute-leaf fun var) ;; If in a simple environment, then we can allow backward ;; references to this function from following top level forms. @@ -2077,7 +2053,7 @@ (when (boundp '*lexenv*) ; when in the compiler (when sb!xc:*compile-print* (compiler-mumble "~&; recognizing DEFUN ~S~%" name)) - (remhash name *free-functions*) + (remhash name *free-funs*) (setf defined-fun (get-defined-fun name))) (become-defined-fun-name name)