(in-package "SB!C")
\f
-;;;; control special forms
+;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-continuation entry start)
(use-continuation entry dummy)
-
+
(let* ((env-entry (list entry cont))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
:cleanup cleanup)))
(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
(starts dummy)
(dolist (segment (rest segments))
(let* ((tag-cont (make-continuation))
- (tag (list (car segment) entry tag-cont)))
+ (tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
;;; 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.
+;;; 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*
(compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
- (funcall fun)))
+ (funcall fun definitionize-keyword processed-definitions)))
;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
;;; call FUN (with no arguments).
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
(compiler-error "The local macro name ~S is not a symbol." name))
+ (unless (listp arglist)
+ (compiler-error "The local macro argument list ~S is not a list." arglist))
(let ((whole (gensym "WHOLE"))
(environment (gensym "ENVIRONMENT")))
(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))))))))
+ ,(compile-in-lexenv
+ nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ (block ,name ,body))
+ (make-restricted-lexenv *lexenv*)))))))
:funs
definitions
fun))
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."
- (funcall-in-macrolet-lexenv definitions
- (lambda ()
- (ir1-translate-locally body start cont))))
+ (funcall-in-macrolet-lexenv
+ definitions
+ (lambda (&key funs)
+ (declare (ignore funs))
+ (ir1-translate-locally body start cont))))
(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
(%funcall-in-foomacrolet-lexenv
(compiler-error
"The local symbol macro name ~S is not a symbol."
name))
+ (let ((kind (info :variable :kind name)))
+ (when (member kind '(:special :constant))
+ (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name)))
`(,name . (MACRO . ,expansion))))
:vars
definitions
fun))
-
+
(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
#!+sb-doc
"SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
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))))
+ (lambda (&key vars)
+ (ir1-translate-locally body start cont :vars vars))))
;;; not really a special form, but..
(def-ir1-translator declare ((&rest stuff) start cont)
;;; for the function used to implement
;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
(def-ir1-translator named-lambda ((name &rest rest) start cont)
- (reference-leaf start
- cont
- (if (legal-fun-name-p name)
- (ir1-convert-lambda `(lambda ,@rest)
- :source-name name)
- (ir1-convert-lambda `(lambda ,@rest)
- :debug-name name))))
+ (let* ((fun (if (legal-fun-name-p name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :source-name name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :debug-name name)))
+ (leaf (reference-leaf start cont fun)))
+ (when (legal-fun-name-p name)
+ (assert-global-function-definition-type name fun))
+ leaf))
\f
;;;; 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)
(values nil t)))
(deftransform %coerce-callable-to-fun ((thing) (function) *
- :when :both
:important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
During evaluation of the Forms, bind the Vars to the result of evaluating the
Value forms. The variables are bound in parallel after all of the Values are
evaluated."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let)
(let ((fun-cont (make-continuation)))
(let* ((*lexenv* (process-decls decls vars nil cont))
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
form to reference any of the previous Vars."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
(let ((*lexenv* (process-decls decls vars nil cont)))
(ir1-convert-aux-bindings start cont forms vars values)))))
;;; but we don't need to worry about that within an IR1 translator,
;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
;;; forms before we hit the IR1 transform level.
-(defun ir1-translate-locally (body start cont)
+(defun ir1-translate-locally (body start cont &key vars funs)
(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)))
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (let ((*lexenv* (process-decls decls vars funs cont)))
(ir1-convert-aux-bindings start cont forms nil nil))))
(def-ir1-translator locally ((&body body) start cont)
(let ((name (first def)))
(check-fun-name name)
(names name)
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+ (multiple-value-bind (forms decls) (parse-body (cddr def))
(defs `(lambda ,(second def)
,@decls
(block ,(fun-name-block-name name)
Evaluate the Body-Forms with some local function definitions. The bindings
do not enclose the definitions; any use of Name in the Forms will refer to
the lexically apparent function definition in the enclosing environment."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'flet)
(let* ((fvars (mapcar (lambda (n d)
Evaluate the Body-Forms with some local function definitions. The bindings
enclose the new definitions, so the defined functions can call themselves or
each other."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'labels)
(let* (;; dummy LABELS functions, to be used as placeholders
;;; 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 ir1ize-the-or-values (type cont lexenv name)
+(defun ir1ize-the-or-values (type cont lexenv place)
(declare (type continuation cont) (type lexenv lexenv))
- (let* ((ctype (values-specifier-type type))
+ (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
(old-type (or (lexenv-find cont type-restrictions)
*wild-type*))
(intersects (values-types-equal-or-intersect old-type ctype))
- (int (values-type-intersection old-type ctype))
- (new (if intersects int old-type)))
+ (new (values-type-intersection old-type ctype)))
(when (null (find-uses cont))
(setf (continuation-asserted-type cont) new))
(when (and (not intersects)
+ ;; FIXME: Is it really right to look at *LEXENV* here,
+ ;; instead of looking at the LEXENV argument? Why?
(not (policy *lexenv*
(= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
(compiler-warn
- "The type ~S in ~S declaration conflicts with an ~
- enclosing assertion:~% ~S"
+ "The type ~S ~A conflicts with an enclosing assertion:~% ~S"
(type-specifier ctype)
- name
+ place
(type-specifier old-type)))
(make-lexenv :type-restrictions `((,cont . ,new))
:default lexenv)))
;;; 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* (ir1ize-the-or-values type cont *lexenv* 'the)))
+ (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
+ "in THE declaration")
(ir1-convert start cont value)))
;;; This is like the THE special form, except that it believes
(def-ir1-translator truly-the ((type value) start cont)
#!+sb-doc
(declare (inline member))
- (let ((type (values-specifier-type type))
+ (let ((type (compiler-values-specifier-type type))
(old (find-uses cont)))
(ir1-convert start cont value)
(do-uses (use cont)
(continuation-starts-block dummy-start)
(ir1-convert start dummy-start result)
- (substitute-continuation-uses cont dummy-start)
+ (with-continuation-type-assertion
+ (cont (continuation-asserted-type dummy-start)
+ "of the first form")
+ (substitute-continuation-uses cont dummy-start))
(continuation-starts-block dummy-result)
(ir1-convert-progn-body dummy-start dummy-result forms)
(eq first 'original-source-start))
(return path)))))
-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
- :kind :function)
- (let (;; QNAME is typically a quoted name. I think the idea is to
- ;; let %DEFMACRO work as an ordinary function when
- ;; interpreting. Whatever the reason the quote is there, we
- ;; don't want it any more. -- WHN 19990603
- (name (eval qname))
- ;; 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
- (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))
-
- (ecase (info :function :kind name)
- ((nil))
- (:function
- (remhash name *free-funs*)
- (undefine-fun-name name)
- (compiler-warn
- "~S is being redefined as a macro when it was ~
- previously ~(~A~) to be a function."
- name
- (info :function :where-from name)))
- (:macro)
- (:special-form
- (compiler-error "The special form ~S can't be redefined as a macro."
- name)))
-
- (setf (info :function :kind name) :macro
- (info :function :where-from name) :defined
- (info :function :macro-function name) (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'defmacro))
- (fun (ir1-convert-lambda def
- :debug-name (debug-namify "DEFMACRO ~S"
- name))))
- (setf (functional-arg-documentation fun) (eval lambda-list))
-
- (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
- (when sb!xc:*compile-print*
- ;; FIXME: It would be nice to convert this, and the other places
- ;; which create compiler diagnostic output prefixed by
- ;; semicolons, to use some common utility which automatically
- ;; prefixes all its output with semicolons. (The addition of
- ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
- ;; "MNA compiler message patch", and implemented by modifying a
- ;; bunch of output statements on a case-by-case basis, which
- ;; seems unnecessarily error-prone and unclear, scattering
- ;; implicit information about output style throughout the
- ;; system.) Starting by rewriting COMPILER-MUMBLE to add
- ;; semicolon prefixes would be a good start, and perhaps also:
- ;; * Add semicolon prefixes for "FOO assembled" messages emitted
- ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed.
- ;; * At least some debugger output messages deserve semicolon
- ;; prefixes too:
- ;; ** restarts table
- ;; ** "Within the debugger, you can type HELP for help."
- (compiler-mumble "~&; converted ~S~%" name))))
-
(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
start cont
:kind :function)
(coerce def 'function))
(let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (fun (ir1-convert-lambda def
+ (fun (ir1-convert-lambda def
:debug-name (debug-namify
"DEFINE-COMPILER-MACRO ~S"
name))))
projects / sbcl.git / blobdiff