X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1-translators.lisp;h=c8eb5e933f0d1303d78d9d8883b93404ab47aea4;hb=4e3b57699314dbd3883470d9b196287b178f3e6d;hp=971550f40e457b2d28c0e40b45fbfdc47a5bf6f7;hpb=b0b168c08b31a748150f404398af754f26fd4813;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 971550f..c8eb5e9 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") -;;;; control special forms +;;;; special forms for control (def-ir1-translator progn ((&rest forms) start cont) #!+sb-doc @@ -84,7 +84,6 @@ (push env-entry (continuation-lexenv-uses cont)) (ir1-convert-progn-body dummy cont forms)))) - (def-ir1-translator return-from ((name &optional value) start cont) #!+sb-doc "Return-From Block-Name Value-Form @@ -356,39 +355,32 @@ ;;; VOP or %VOP.. -- WHN 2001-06-11 ;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((name &rest args) start cont) - (unless (symbolp name) - (compiler-error "internal error: Primitive name ~S is not a symbol." name)) + (declare (type symbol name)) (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "internal error: Primitive name ~A is not defined." - name))) + (bug "undefined primitive ~A" 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 "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) + (bug "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) (unless (= nargs min) - (compiler-error "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) + (bug "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.")) + (bug "%PRIMITIVE was used with a conditional template.")) (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) + (bug "%PRIMITIVE was used with an unknown values template.")) (ir1-convert start cont @@ -441,36 +433,39 @@ ;;; except that the value of NAME is passed to the compiler for use in ;;; creation of debug information for the resulting function. ;;; -;;; Eventually we might use this for NAME values other than legal -;;; function names, e.g. +;;; NAME can be a legal function name or some arbitrary other thing. +;;; +;;; If NAME is a legal function name, then the caller should be +;;; planning to set (FDEFINITION NAME) to the created function. +;;; (Otherwise the debug names will be inconsistent and thus +;;; unnecessarily confusing.) +;;; +;;; Arbitrary other things are appropriate for naming things which are +;;; not the FDEFINITION of NAME. E.g. ;;; NAME = (:FLET FOO BAR) ;;; for the FLET function in ;;; (DEFUN BAR (X) ;;; (FLET ((FOO (Y) (+ X Y))) ;;; FOO)) ;;; or -;;; NAME = (:METHOD PRINT-OBJECT (STARSHIP T)) +;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) ;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...). -;;; However, as of this writing (while defining/implementing it in -;;; sbcl-0.pre7.108) NAME is always a legal function name. -;;; -;;; If NAME is a legal function name, then the caller should be -;;; planning to set (FDEFINITION NAME) to the created function. -;;; (Otherwise the debug names will be inconsistent and thus -;;; unnecessarily confusing.) +;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). (def-ir1-translator named-lambda ((name &rest rest) start cont) (reference-leaf start cont - (ir1-convert-lambda `(lambda ,@rest) - :source-name name))) + (if (legal-fun-name-p name) + (ir1-convert-lambda `(lambda ,@rest) + :source-name name) + (ir1-convert-lambda `(lambda ,@rest) + :debug-name name)))) ;;;; FUNCALL ;;; FUNCALL is implemented on %FUNCALL, which can only call functions ;;; (not symbols). %FUNCALL is used directly in some places where the ;;; call should always be open-coded even if FUNCALL is :NOTINLINE. -(deftransform funcall ((function &rest args) * * :when :both) +(deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) (%funcall ,(if (csubtypep (continuation-type function) @@ -495,7 +490,6 @@ (values nil t))) (deftransform %coerce-callable-to-fun ((thing) (function) * - :when :both :important t) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -506,14 +500,14 @@ ;;;; any pervasive declarations also affect the evaluation of the ;;;; arguments.) -;;; Given a list of binding specifiers in the style of Let, return: +;;; Given a list of binding specifiers in the style of LET, return: ;;; 1. The list of var structures for the variables bound. ;;; 2. The initial value form for each variable. ;;; ;;; The variable names are checked for legality and globally special ;;; variables are marked as such. Context is the name of the form, for ;;; error reporting purposes. -(declaim (ftype (function (list symbol) (values list list list)) +(declaim (ftype (function (list symbol) (values list list)) extract-let-vars)) (defun extract-let-vars (bindings context) (collect ((vars) @@ -528,7 +522,7 @@ (cond ((atom spec) (let ((var (get-var spec))) (vars var) - (names (cons spec var)) + (names spec) (vals nil))) (t (unless (proper-list-of-length-p spec 1 2) @@ -541,7 +535,7 @@ (names name) (vals (second spec))))))) - (values (vars) (vals) (names)))) + (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start cont) @@ -552,12 +546,13 @@ evaluated." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body - forms vars :debug-name (debug-namify "LET ~S" bindings)))) - (reference-leaf start fun-cont fun) - (ir1-convert-combination-args fun-cont cont values))))) + (let ((fun-cont (make-continuation))) + (let* ((*lexenv* (process-decls decls vars nil cont)) + (fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" bindings)))) + (reference-leaf start fun-cont fun)) + (ir1-convert-combination-args fun-cont cont values))))) (def-ir1-translator let* ((bindings &body body) start cont) @@ -720,7 +715,7 @@ ;;; We make this work by getting USE-CONTINUATION to do the unioning ;;; across COND branches. We can't do it here, since we don't know how ;;; many branches there are going to be. -(defun do-the-stuff (type cont lexenv name) +(defun ir1ize-the-or-values (type cont lexenv name) (declare (type continuation cont) (type lexenv lexenv)) (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) @@ -749,7 +744,7 @@ ;;; 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) - (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) + (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the))) (ir1-convert start cont value))) ;;; This is like the THE special form, except that it believes