X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=1d04deb2add348c6739045ccc922a7030a273492;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=c15321e1e8b4566a4de16303563c492c241c54d9;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c15321e..1d04deb 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -42,25 +42,12 @@ (declaim (list *current-path*)) (defvar *current-path* nil) -;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to -;;; be interpreted rather than compiled. This inhibits source -;;; tranformations and stuff. -(defvar *converting-for-interpreter* nil) -;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*. - -;;; 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 -;;; DECLAIM instead of a variable like this. And whether or not this -;;; kind of checking is on, declarations should be assertions to the -;;; extent practical, and code which can't be compiled efficiently -;;; while adhering to that principle should give warnings. -(defvar *derive-function-types* t - #!+sb-doc - "(Caution: Soon, this might change its semantics somewhat, or even go away.) - If true, argument and result type information derived from compilation of - DEFUNs is used when compiling calls to that function. If false, only - information from FTYPE proclamations will be used.") +(defvar *derive-function-types* nil + "Should the compiler assume that function types will never change, + so that it can use type information inferred from current definitions + to optimize code which uses those definitions? Setting this true + gives non-ANSI, early-CMU-CL behavior. It can be useful for improving + the efficiency of stable code.") ;;;; namespace management utilities @@ -72,7 +59,13 @@ (setf (info :function :where-from name) :assumed)) (let ((where (info :function :where-from name))) - (when (eq where :assumed) + (when (and (eq where :assumed) + ;; In the ordinary target Lisp, it's silly to report + ;; undefinedness when the function is defined in the + ;; running Lisp. But at cross-compile time, the current + ;; definedness of a function is irrelevant to the + ;; definedness at runtime, which is what matters. + #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function :name name @@ -93,7 +86,8 @@ (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor)) (type (dd-name info)) (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) + (unless slot + (error "can't find slot ~S" type)) (make-slot-accessor :name name :type (specifier-type @@ -155,7 +149,7 @@ (let ((var (lexenv-find name functions :test #'equal))) (cond (var (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro))) + (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t @@ -197,7 +191,10 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defconstant list-to-hash-table-threshold 32) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; below. -- AL 20010227 + (defconstant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) @@ -273,7 +270,7 @@ #!-sb-fluid (declaim (inline prev-link)) (defun prev-link (node cont) (declare (type node node) (type continuation cont)) - (assert (not (continuation-next cont))) + (aver (not (continuation-next cont))) (setf (continuation-next cont) node) (setf (node-prev node) cont)) @@ -304,15 +301,15 @@ (declare (type node node) (type continuation cont) (inline member)) (let ((block (continuation-block cont)) (node-block (continuation-block (node-prev node)))) - (assert (eq (continuation-kind cont) :block-start)) - (assert (not (block-last node-block)) () "~S has already ended." - node-block) + (aver (eq (continuation-kind cont) :block-start)) + (when (block-last node-block) + (error "~S has already ended." node-block)) (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) + (when (block-succ node-block) + (error "~S already has successors." node-block)) (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block) :test #'eq)) () - "~S is already a predecessor of ~S." node-block block) + (when (memq node-block (block-pred block)) + (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)) (add-continuation-use node cont) (unless (eq (continuation-asserted-type cont) *wild-type*) @@ -372,7 +369,7 @@ ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-Num is the top-level form number of the +;;; find the paths in, and TLF-NUM is the top-level form number of the ;;; truly top-level form. ;;; ;;; This gets a bit interesting when the source code is circular. This @@ -420,8 +417,8 @@ `(block ,skip (catch 'ir1-error-abort (let ((*compiler-error-bailout* - #'(lambda () - (throw 'ir1-error-abort nil)))) + (lambda () + (throw 'ir1-error-abort nil)))) ,@body (return-from ,skip nil))) (ir1-convert ,start ,cont ,proxy))))) @@ -462,8 +459,8 @@ (global-var (ir1-convert-srctran start cont lexical-def form)) (t - (assert (and (consp lexical-def) - (eq (car lexical-def) 'macro))) + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) (ir1-convert start cont (careful-expand-macro (cdr lexical-def) form)))))) @@ -477,7 +474,7 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl-file, make sure that + ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;; needs to be. (defun reference-constant (start cont value) @@ -538,7 +535,7 @@ (compiler-style-warning "reading an ignored variable: ~S" name)) (reference-leaf start cont var)) (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) @@ -552,8 +549,9 @@ (translator (info :function :ir1-convert fun)) (cmacro (info :function :compiler-macro-function fun))) (cond (translator (funcall translator start cont form)) - ((and cmacro (not *converting-for-interpreter*) - (not (eq (info :function :inlinep fun) :notinline))) + ((and cmacro + (not (eq (info :function :inlinep fun) + :notinline))) (let ((res (careful-expand-macro cmacro form))) (if (eq res form) (ir1-convert-global-functoid-no-cmacro start cont form fun) @@ -582,7 +580,8 @@ (muffle-warning) (error "internal error -- no MUFFLE-WARNING restart")) -;;; Trap errors during the macroexpansion. +;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping +;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) (handler-bind (;; When cross-compiling, we can get style warnings ;; about e.g. undefined functions. An unhandled @@ -698,32 +697,26 @@ ;;; Convert a call to a global function. If not :NOTINLINE, then we do ;;; source transforms and try out any inline expansion. If there is no -;;; expansion, but is :INLINE, then give an efficiency note (unless a known -;;; function which will quite possibly be open-coded.) Next, we go to -;;; ok-combination conversion. +;;; expansion, but is :INLINE, then give an efficiency note (unless a +;;; known function which will quite possibly be open-coded.) Next, we +;;; go to ok-combination conversion. (defun ir1-convert-srctran (start cont var form) (declare (type continuation start cont) (type global-var var)) (let ((inlinep (when (defined-function-p var) (defined-function-inlinep var)))) - (cond - ((eq inlinep :notinline) - (ir1-convert-combination start cont form var)) - (*converting-for-interpreter* - (ir1-convert-combination-checking-type start cont form var)) - (t - (let ((transform (info :function :source-transform (leaf-name var)))) - (cond - (transform - (multiple-value-bind (result pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start cont form var) - (ir1-convert start cont result)))) - (t - (ir1-convert-maybe-predicate start cont form var)))))))) - -;;; If the function has the Predicate attribute, and the CONT's DEST isn't -;;; an IF, then we convert (IF
T NIL), ensuring that a predicate always -;;; appears in a conditional context. + (if (eq inlinep :notinline) + (ir1-convert-combination start cont form var) + (let ((transform (info :function :source-transform (leaf-name var)))) + (if transform + (multiple-value-bind (result pass) (funcall transform form) + (if pass + (ir1-convert-maybe-predicate start cont form var) + (ir1-convert start cont result))) + (ir1-convert-maybe-predicate start cont form var)))))) + +;;; If the function has the PREDICATE attribute, and the CONT's DEST +;;; isn't an IF, then we convert (IF T NIL), ensuring that a +;;; predicate always appears in a conditional context. ;;; ;;; If the function isn't a predicate, then we call ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE. @@ -817,9 +810,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 (= inhibit-warnings 3)) + (unless (policy *lexenv* (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -829,7 +822,7 @@ (restr (cons var int)))))) (cons ;; FIXME: non-ANSI weirdness - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) ,(cdr var)))))) (heap-alien-info @@ -878,7 +871,7 @@ (let ((var (find-in-bindings vars name))) (etypecase var (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (compiler-error "~S is a symbol-macro and thus can't be declared special." name)) @@ -927,7 +920,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed inhibit-warnings)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -989,7 +982,9 @@ ;;; RES and returning it as a result. VARS and FVARS are as described in ;;; PROCESS-DECLS. (defun process-1-decl (raw-spec res vars fvars cont) - (declare (list spec vars fvars) (type lexenv res) (type continuation 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)) @@ -1006,12 +1001,6 @@ (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 @@ -1023,7 +1012,7 @@ `(values ,@types)) cont res 'values)))) (dynamic-extent - (when (policy nil (> speed inhibit-warnings)) + (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note "compiler limitation:~ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) @@ -1108,38 +1097,38 @@ (note-lexical-binding name) (make-lambda-var :name name))))) -;;; Make the keyword for a keyword arg, checking that the keyword -;;; isn't already used by one of the Vars. We also check that the -;;; keyword isn't the magical :allow-other-keys. +;;; Make the default keyword for a &KEY arg, checking that the keyword +;;; isn't already used by one of the VARS. We also check that the +;;; keyword isn't the magical :ALLOW-OTHER-KEYS. (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) - (intern (symbol-name symbol) "KEYWORD") + (keywordicate symbol) symbol))) (when (eq key :allow-other-keys) - (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS.")) + (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) (dolist (var vars) (let ((info (lambda-var-arg-info var))) (when (and info (eq (arg-info-kind info) :keyword) - (eq (arg-info-keyword info) key)) + (eq (arg-info-key info) key)) (compiler-error "The keyword ~S appears more than once in the lambda-list." key)))) key)) -;;; Parse a lambda-list into a list of Var structures, stripping off +;;; Parse a lambda-list into a list of VAR structures, stripping off ;;; any aux bindings. Each arg name is checked for legality, and ;;; duplicate names are checked for. If an arg is globally special, -;;; the var is marked as :special instead of :lexical. Keyword, -;;; optional and rest args are annotated with an arg-info structure +;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY, +;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure ;;; which contains the extra information. If we hit something losing, -;;; we bug out with Compiler-Error. These values are returned: -;;; 1. A list of the var structures for each top-level argument. -;;; 2. A flag indicating whether &key was specified. -;;; 3. A flag indicating whether other keyword args are allowed. -;;; 4. A list of the &aux variables. -;;; 5. A list of the &aux values. +;;; we bug out with COMPILER-ERROR. These values are returned: +;;; 1. a list of the var structures for each top-level argument; +;;; 2. a flag indicating whether &KEY was specified; +;;; 3. a flag indicating whether other &KEY args are allowed; +;;; 4. a list of the &AUX variables; and +;;; 5. a list of the &AUX values. (declaim (ftype (function (list) (values list boolean boolean list list)) find-lambda-vars)) (defun find-lambda-vars (list) @@ -1150,9 +1139,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)) @@ -1209,9 +1198,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)) @@ -1219,7 +1208,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) @@ -1227,14 +1216,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) @@ -1262,26 +1251,18 @@ ;;; 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 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) +(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) (ir1-convert-progn-body start cont body) (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body (list (first aux-vars)) - (rest aux-vars) (rest aux-vals) - interface))) + (fun (ir1-convert-lambda-body body + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals)))) (reference-leaf start fun-cont fun) - (let ((*lexenv* (if interface - (make-lexenv - :policy (make-interface-policy *lexenv*)) - *lexenv*))) - (ir1-convert-combination-args fun-cont cont - (list (first aux-vals)))))) + (ir1-convert-combination-args fun-cont cont + (list (first aux-vals))))) (values)) ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind @@ -1295,13 +1276,12 @@ ;;; 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) +(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars) (declare (type continuation start cont) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (ir1-convert-aux-bindings start cont body aux-vars aux-vals)) (t (continuation-starts-block cont) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -1314,7 +1294,7 @@ (let ((*lexenv* (make-lexenv :cleanup cleanup))) (ir1-convert next-cont nnext-cont '(%cleanup-point)) (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals - interface (rest svars)))))) + (rest svars)))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -1333,11 +1313,8 @@ ;;; ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated -;;; to get the initial value for the corresponding AUX-VAR. Interface -;;; is a flag as T when there are real aux values (see LET* and -;;; IR1-CONVERT-AUX-BINDINGS.) -(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals - interface result) +;;; to get the initial value for the corresponding AUX-VAR. +(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) (let* ((bind (make-bind)) @@ -1369,7 +1346,7 @@ (prev-link bind cont1) (use-continuation bind cont2) (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - interface (svars))) + (svars))) (let ((block (continuation-block result))) (when block @@ -1397,8 +1374,6 @@ ;;; then we mark the corresponding var as EVER-USED to inhibit ;;; "defined but not read" warnings for arguments that are only used ;;; by default forms. -;;; -;;; We bind *LEXENV* to change the policy to the interface policy. (defun convert-optional-entry (fun vars vals defaults) (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) @@ -1411,14 +1386,14 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))) (fun - (ir1-convert-lambda-body - `((%funcall ,fun ,@(reverse vals) ,@defaults)) - arg-vars))) - (mapc #'(lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) + (ir1-convert-lambda-body `((%funcall ,fun + ,@(reverse vals) + ,@defaults)) + arg-vars))) + (mapc (lambda (var arg-var) + (when (cdr (leaf-refs arg-var)) + (setf (leaf-ever-used var) t))) fvars arg-vars) fun)) @@ -1461,32 +1436,30 @@ (list (arg-info-default info) nil) (list (arg-info-default info)))))) -;;; Create the More-Entry function for the Optional-Dispatch Res. -;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var -;;; for any Rest arg. Keys is a list of the keyword arg vars. +;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES. +;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is +;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars. ;;; -;;; The most interesting thing that we do is parse keywords. We create a -;;; bunch of temporary variables to hold the result of the parse, and then loop -;;; over the supplied arguments, setting the appropriate temps for the supplied -;;; keyword. Note that it is significant that we iterate over the keywords in -;;; reverse order --- this implements the CL requirement that (when a keyword -;;; appears more than once) the first value is used. +;;; The most interesting thing that we do is parse keywords. We create +;;; a bunch of temporary variables to hold the result of the parse, +;;; and then loop over the supplied arguments, setting the appropriate +;;; temps for the supplied keyword. Note that it is significant that +;;; we iterate over the keywords in reverse order --- this implements +;;; the CL requirement that (when a keyword appears more than once) +;;; the first value is used. ;;; ;;; If there is no supplied-p var, then we initialize the temp to the -;;; default and just pass the temp into the main entry. Since non-constant -;;; keyword args are forcibly given a supplied-p var, we know that the default -;;; is constant, and thus safe to evaluate out of order. +;;; default and just pass the temp into the main entry. Since +;;; non-constant &KEY args are forcibly given a supplied-p var, we +;;; know that the default is constant, and thus safe to evaluate out +;;; of order. ;;; -;;; If there is a supplied-p var, then we create temps for both the value -;;; and the supplied-p, and pass them into the main entry, letting it worry -;;; about defaulting. +;;; If there is a supplied-p var, then we create temps for both the +;;; value and the supplied-p, and pass them into the main entry, +;;; letting it worry about defaulting. ;;; -;;; We deal with :allow-other-keys by delaying unknown keyword errors until -;;; we have scanned all the keywords. -;;; -;;; When converting the function, we bind *LEXENV* to change the -;;; compilation policy over to the interface policy, so that keyword -;;; args will be checked even when type checking isn't on in general. +;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors +;;; until we have scanned all the keywords. (defun convert-more-entry (res entry-vars entry-vals rest morep keys) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) @@ -1503,8 +1476,7 @@ (context-temp (make-lambda-var :name n-context)) (n-count (gensym "N-COUNT-")) (count-temp (make-lambda-var :name n-count - :type (specifier-type 'index))) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))) + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1521,7 +1493,7 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) + (policy *lexenv* (zerop safety))))) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -1530,7 +1502,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)) @@ -1555,7 +1527,7 @@ (body `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) + (%odd-key-arguments-error))) (body `(locally @@ -1570,7 +1542,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) @@ -1582,17 +1554,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 @@ -1656,11 +1628,11 @@ (main-vals (arg-info-default info)) (bind-vals n-val))))) - (let* ((main-entry (ir1-convert-lambda-body body (main-vars) - (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals) - t - cont)) + (let* ((main-entry (ir1-convert-lambda-body + body (main-vars) + :aux-vars (append (bind-vars) aux-vars) + :aux-vals (append (bind-vals) aux-vals) + :result cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1677,32 +1649,33 @@ ;;; arguments, analyzing the arglist on the way down and generating entry ;;; points on the way up. ;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. +;;; Default-Vars is a reversed list of all the argument vars processed +;;; so far, including supplied-p vars. Default-Vals is a list of the +;;; names of the Default-Vars. ;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. +;;; Entry-Vars is a reversed list of processed argument vars, +;;; excluding supplied-p vars. Entry-Vals is a list things that can be +;;; evaluated to get the values for all the vars from the Entry-Vars. +;;; It has the var name for each required or optional arg, and has T +;;; for each supplied-p arg. ;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. +;;; Vars is a list of the Lambda-Var structures for arguments that +;;; haven't been processed yet. Supplied-p-p is true if a supplied-p +;;; argument has already been processed; only in this case are the +;;; Default-XXX and Entry-XXX different. ;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. +;;; The result at each point is a lambda which should be called by the +;;; above level to default the remaining arguments and evaluate the +;;; body. We cause the body to be evaluated by converting it and +;;; returning it as the result when the recursion bottoms out. ;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. +;;; Each level in the recursion also adds its entry point function to +;;; the result Optional-Dispatch. For most arguments, the defaulting +;;; function and the entry point function will be the same, but when +;;; supplied-p args are present they may be different. ;;; -;;; When we run into a rest or keyword arg, we punt out to -;;; IR1-Convert-More, which finishes for us in this case. +;;; When we run into a &REST or &KEY arg, we punt out to +;;; IR1-CONVERT-MORE, which finishes for us in this case. (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars @@ -1719,7 +1692,9 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals t cont))) + :aux-vars aux-vars + :aux-vals aux-vals + :result cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1765,9 +1740,9 @@ aux-vals cont))))))) ;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; Optional-Dispatch to represent a lambda. We cons up the result and +;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we +;;; figure out the min-args and max-args. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars @@ -1792,7 +1767,7 @@ res)) -;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf. +;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. (defun ir1-convert-lambda (form &optional name) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" @@ -1819,8 +1794,10 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals cont) - (ir1-convert-lambda-body forms vars aux-vars aux-vals - t cont)))) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) (setf (leaf-name res) name) @@ -1927,7 +1904,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 @@ -1939,7 +1916,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)) @@ -1993,11 +1970,11 @@ (conts cont) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) - (mapc #'(lambda (segment start cont) - (ir1-convert-progn-body start cont (rest segment))) + (mapc (lambda (segment start cont) + (ir1-convert-progn-body start cont (rest segment))) segments (starts) (conts)))))) -;;; Emit an Exit node without any value. +;;; Emit an EXIT node without any value. (def-ir1-translator go ((tag) start cont) #!+sb-doc "Go Tag @@ -2014,137 +1991,64 @@ ;;;; translators for compiler-magic special forms -;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1 -;;; convert method so that it can be shared by the special-case -;;; top-level form processing code. We play with the dynamic -;;; environment and eval stuff, then call Fun with a list of forms to -;;; be processed at load time. -;;; -;;; Note: the EVAL situation is always ignored: this is conceptually a -;;; compile-only implementation. -;;; -;;; We have to interact with the interpreter to ensure that the forms -;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to -;;; 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. +;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in +;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM, +;;; so they're never seen at this level.) ;;; -;;; 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 -;;; aren't evaluating for LOAD, then we call FUN on NIL for the result -;;; of the EVAL-WHEN. -(defun do-eval-when-stuff (situations body fun) - - (when (or (not (listp situations)) - (set-difference situations - '(compile load eval - :compile-toplevel :load-toplevel :execute))) - (compiler-error "bad EVAL-WHEN situation list: ~S" situations)) - - (let ((deprecated-names (intersection situations '(compile load eval)))) - (when deprecated-names - (style-warn "using deprecated EVAL-WHEN situation names ~S" - deprecated-names))) - - (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations) - (not sb!eval::*already-evaled-this*))) - (sb!eval::*already-evaled-this* t)) - (when do-eval - - ;; 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))) - (funcall fun body) - (funcall fun '(nil))))) - -(def-ir1-translator eval-when ((situations &rest body) start cont) +;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing +;;; of non-top-level EVAL-WHENs is very simple: +;;; EVAL-WHEN forms cause compile-time evaluation only at top level. +;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications +;;; are ignored for non-top-level forms. For non-top-level forms, an +;;; eval-when specifying the :EXECUTE situation is treated as an +;;; implicit PROGN including the forms in the body of the EVAL-WHEN +;;; form; otherwise, the forms in the body are ignored. +(def-ir1-translator eval-when ((situations &rest forms) start cont) #!+sb-doc "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." - - ;; 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)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) - (collect ((new-fenv)) - (dolist (def definitions) - (let ((name (first def)) - (arglist (second def)) - (body (cddr def))) - (unless (symbolp name) - (compiler-error "The local macro name ~S is not a symbol." name)) - (when (< (length def) 2) - (compiler-error - "The list ~S is too short to be a legal local macro definition." - name)) - (multiple-value-bind (body local-decs) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - (new-fenv `(,(first def) macro . - ,(coerce `(lambda (,whole ,environment) - ,@local-decs (block ,name ,body)) - 'function)))))) - - (let ((*lexenv* (make-lexenv :functions (new-fenv)))) - (funcall fun)))) + Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL, + :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." + (multiple-value-bind (ct lt e) (parse-eval-when-situations situations) + (declare (ignore ct lt)) + (when e + (ir1-convert-progn-body start cont forms))) + (values)) +;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then +;;; call FUN (with no arguments). +;;; +;;; This is split off from the IR1 convert method so that it can be +;;; shared by the special-case top-level MACROLET processing code. +(defun funcall-in-macrolet-lexenv (definitions fun) + (declare (type list definitions) (type function fun)) + (let* ((whole (gensym "WHOLE")) + (environment (gensym "ENVIRONMENT")) + (processed-definitions + (mapcar (lambda (definition) + (unless (list-of-length-at-least-p definition 2) + (compiler-error + "The list ~S is too short to be a legal ~ + local macro definition." + definition)) + (destructuring-bind (name arglist &body body) definition + (unless (symbolp name) + (compiler-error + "The local macro name ~S is not a symbol." name)) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile nil + `(lambda (,whole ,environment) + ,@local-decls + (block ,name ,body))))))) + definitions)) + (*lexenv* (make-lexenv :functions processed-definitions))) + (unless (= (length definitions) + (length (remove-duplicates definitions :key #'first))) + (compiler-style-warning + "duplicate macro names in MACROLET ~S" definitions)) + (funcall fun)) (values)) (def-ir1-translator macrolet ((definitions &rest body) start cont) @@ -2154,9 +2058,46 @@ defined. Name is the local macro name, Lambda-List is the DEFMACRO style destructuring lambda list, and the Forms evaluate to the expansion. The Forms are evaluated in the null environment." - (do-macrolet-stuff definitions - #'(lambda () - (ir1-convert-progn-body start cont body)))) + (funcall-in-macrolet-lexenv definitions + (lambda () + (ir1-translate-locally body start cont)))) + +;;; Tweak *LEXENV* to include the MACROBINDINGS from a SYMBOL-MACROLET, +;;; then call FUN (with no arguments). +;;; +;;; This is split off from the IR1 convert method so that it can be +;;; shared by the special-case top-level SYMBOL-MACROLET processing code. +(defun funcall-in-symbol-macrolet-lexenv (macrobindings fun) + (declare (type list macrobindings) (type function fun)) + (let ((processed-macrobindings + (mapcar (lambda (macrobinding) + (unless (proper-list-of-length-p macrobinding 2) + (compiler-error "malformed symbol/expansion pair: ~S" + macrobinding)) + (destructuring-bind (name expansion) macrobinding + (unless (symbolp name) + (compiler-error + "The local symbol macro name ~S is not a symbol." + name)) + `(,name . (MACRO . ,expansion)))) + macrobindings))) + (unless (= (length macrobindings) + (length (remove-duplicates macrobindings :key #'first))) + (compiler-style-warning + "duplicate symbol macro names in SYMBOL-MACROLET ~S" macrobindings)) + (let ((*lexenv* (make-lexenv :variables processed-macrobindings))) + (funcall fun))) + (values)) + +(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont) + #!+sb-doc + "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* + Define the Names as symbol macros with the given Expansions. Within the + body, references to a Name will effectively be replaced with the Expansion." + (funcall-in-symbol-macrolet-lexenv + macrobindings + (lambda () + (ir1-translate-locally body start cont)))) ;;; not really a special form, but.. (def-ir1-translator declare ((&rest stuff) start cont) @@ -2180,9 +2121,6 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; a hashtable that translates from primitive names to translation functions -(defvar *primitive-translators* (make-hash-table :test 'eq)) - ;;; If there is a primitive translator, then we expand the call. ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first ;;; argument is the template, the second is a list of the results of @@ -2193,60 +2131,54 @@ ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for -;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be -;;; possible to reimplement BYTE-BLT (the only use of -;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive -;;; translators altogether, so that there would be no distinction -;;; between primitives and vops? Then we could call primitives vops, -;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to -;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906 -;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I -;;; think BYTE-BLT could probably just become an inline function. +;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU +;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call +;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename +;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to +;;; VOP or %VOP.. -- WHN 2001-06-11 +;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((&whole form name &rest args) start cont) (unless (symbolp name) (compiler-error "The primitive name ~S is not a symbol." name)) - (let* ((translator (gethash name *primitive-translators*))) - (if translator - (ir1-convert start cont (funcall translator (cdr form))) - (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "The primitive name ~A is not defined." - name))) - (required (length (template-arg-types template))) - (info (template-info-arg-count template)) - (min (+ required info)) - (nargs (length args))) - (if (template-more-args-type template) - (when (< nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) - (unless (= nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) - - (when (eq (template-result-types template) :conditional) - (compiler-error - "%PRIMITIVE was used with a conditional template.")) - - (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) - - (ir1-convert start - cont - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))))) + (let* ((template (or (gethash name *backend-template-names*) + (compiler-error + "The primitive name ~A is not defined." + name))) + (required (length (template-arg-types template))) + (info (template-info-arg-count template)) + (min (+ required info)) + (nargs (length args))) + (if (template-more-args-type template) + (when (< nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) + (unless (= nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants exactly ~R." + name + nargs + min))) + + (when (eq (template-result-types template) :conditional) + (compiler-error + "%PRIMITIVE was used with a conditional template.")) + + (when (template-more-results-type template) + (compiler-error + "%PRIMITIVE was used with an unknown values template.")) + + (ir1-convert start + cont + `(%%primitive ',template + ',(eval-info-args + (subseq args required min)) + ,@(subseq args 0 required) + ,@(subseq args min))))) ;;;; QUOTE and FUNCTION @@ -2314,32 +2246,6 @@ "optimize away possible call to FDEFINITION at runtime" 'thing) -;;;; symbol macros - -(def-ir1-translator symbol-macrolet ((specs &body body) start cont) - #!+sb-doc - "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* - Define the Names as symbol macros with the given Expansions. Within the - body, references to a Name will effectively be replaced with the Expansion." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (collect ((res)) - (dolist (spec specs) - (unless (proper-list-of-length-p spec 2) - (compiler-error "The symbol macro binding ~S is malformed." spec)) - (let ((name (first spec)) - (def (second spec))) - (unless (symbolp name) - (compiler-error "The symbol macro name ~S is not a symbol." name)) - (when (assoc name (res) :test #'eq) - (compiler-style-warning - "The name ~S occurs more than once in SYMBOL-MACROLET." - name)) - (res `(,name . (MACRO . ,def))))) - - (let* ((*lexenv* (make-lexenv :variables (res))) - (*lexenv* (process-decls decls (res) nil cont))) - (ir1-convert-progn-body start cont forms))))) - ;;; This is a frob that DEFSTRUCT expands into to establish the compiler ;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do ;;; most of the work, we just clear all of the functions out of @@ -2438,31 +2344,36 @@ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values nil))))) - -;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY -;;; has to preserves top-level-formness, but we don't need to worry -;;; about that here, because special logic in the compiler main loop -;;; grabs top-level LOCALLYs and takes care of them before this -;;; transform ever sees them. -(def-ir1-translator locally ((&body body) - start cont) + (ir1-convert-aux-bindings start cont forms vars values))))) + +;;; logic shared between IR1 translators for LOCALLY, MACROLET, +;;; and SYMBOL-MACROLET +;;; +;;; Note that all these things need to preserve top-level-formness, +;;; but we don't need to worry about that within an IR1 translator, +;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO +;;; forms before we hit the IR1 transform level. +(defun ir1-translate-locally (body start cont) + (declare (type list body) (type continuation start cont)) + (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (let ((*lexenv* (process-decls decls nil nil cont))) + (ir1-convert-aux-bindings start cont forms nil nil)))) + +(def-ir1-translator locally ((&body body) start cont) #!+sb-doc "LOCALLY Declaration* Form* Sequentially evaluate the Forms in a lexical environment where the the Declarations have effect. If LOCALLY is a top-level form, then 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))) - (ir1-convert-aux-bindings start cont forms nil nil nil)))) + (ir1-translate-locally body start cont)) ;;;; FLET and LABELS ;;; Given a list of local function specifications in the style of -;;; Flet, return lists of the function names and of the lambdas which +;;; FLET, return lists of the function names and of the lambdas which ;;; are their definitions. ;;; -;;; The function names are checked for legality. Context is the name +;;; The function names are checked for legality. CONTEXT is the name ;;; of the form, for error reporting. (declaim (ftype (function (list symbol) (values list list)) extract-flet-variables)) @@ -2572,13 +2483,14 @@ (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) - (intersects (values-types-intersect old-type ctype)) + (intersects (values-types-equal-or-intersect old-type ctype)) (int (values-type-intersection old-type ctype)) (new (if intersects int old-type))) (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) - (not (policy nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? + (not (policy *lexenv* + (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warning "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" (type-specifier ctype) @@ -2643,7 +2555,7 @@ name)) (set-variable start cont leaf (second things))) (cons - (assert (eq (car leaf) 'MACRO)) + (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info (ir1-convert start cont @@ -2722,7 +2634,7 @@ ;;; referencing it. (def-ir1-translator %cleanup-function ((name) start cont) (let ((fun (lexenv-find name functions))) - (assert (lambda-p fun)) + (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -2862,7 +2774,7 @@ (dolist (pred (block-pred end-block)) (unlink-blocks pred end-block) (link-blocks pred cont-block)) - (assert (not (continuation-dest dummy-result))) + (aver (not (continuation-dest dummy-result))) (delete-continuation dummy-result) (remove-from-dfo end-block)))) @@ -2905,10 +2817,12 @@ ;; QDEF should be a sharp-quoted definition. We don't want to make a ;; function of it just yet, so we just drop the sharp-quote. (def (progn - (assert (eq 'function (first qdef))) - (assert (proper-list-of-length-p qdef 2)) + (aver (eq 'function (first qdef))) + (aver (proper-list-of-length-p qdef 2)) (second qdef)))) + (/show "doing IR1 translator for %DEFMACRO" name) + (unless (symbolp name) (compiler-error "The macro name ~S is not a symbol." name)) @@ -2918,7 +2832,8 @@ (remhash name *free-functions*) (undefine-function-name name) (compiler-warning - "~S is being redefined as a macro when it was previously ~(~A~) to be a function." + "~S is being redefined as a macro when it was ~ + previously ~(~A~) to be a function." name (info :function :where-from name))) (:macro) @@ -3000,12 +2915,11 @@ (make-null-lexenv)) :variables (copy-list symbol-macros) :functions - (mapcar #'(lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) + (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) macros) - :policy (lexenv-policy *lexenv*) - :interface-policy (lexenv-interface-policy *lexenv*)))) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3027,10 +2941,10 @@ (when (eq x (assoc name variables :test #'eq)) (typecase what (cons - (assert (eq (car what) 'macro)) + (aver (eq (car what) 'macro)) (push x symmacs)) (global-var - (assert (eq (global-var-kind what) :special)) + (aver (eq (global-var-kind what) :special)) (push `(special ,name) decls)) (t (return t)))))) nil) @@ -3065,7 +2979,7 @@ (found (find-free-function name "Eh?"))) (note-name-defined name :function) (cond ((not (defined-function-p found)) - (assert (not (info :function :inlinep name))) + (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) (res (make-defined-function :name name @@ -3083,7 +2997,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 +, @@ -3094,8 +3008,15 @@ (info (info :function :info (leaf-name var)))) (assert-definition-type fun type - :error-function #'compiler-warning - :warning-function (cond (info #'compiler-warning) + ;; KLUDGE: Common Lisp is such a dynamic language that in general + ;; all we can do here in general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING in the special case of + ;; of type mismatches within a compilation unit (as in section + ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't + ;; keep track of whether the mismatched data came from the same + ;; compilation unit, so we can't do that. -- WHN 2001-02-11 + :error-function #'compiler-style-warning + :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note) (t nil)) :really-assert