(node (make-if :test pred
:consequent then-block
:alternative else-block)))
+ ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
+ ;; order of the following two forms is important
(setf (continuation-dest pred) node)
(ir1-convert start pred test)
(link-node-to-previous-continuation node pred)
(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
+;;; 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.
+;;; shared by the special-case top level MACROLET processing code, and
+;;; further split so that the special-case MACROLET processing code in
+;;; EVAL can likewise make use of it.
+(defmacro macrolet-definitionize-fun (context lexenv)
+ (flet ((make-error-form (control &rest args)
+ (ecase context
+ (:compile `(compiler-error ,control ,@args))
+ (:eval `(error 'simple-program-error
+ :format-control ,control
+ :format-arguments (list ,@args))))))
+ `(lambda (definition)
+ (unless (list-of-length-at-least-p definition 2)
+ ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
+ (destructuring-bind (name arglist &body body) definition
+ (unless (symbolp name)
+ ,(make-error-form "The local macro name ~S is not a symbol." 'name))
+ (unless (listp arglist)
+ ,(make-error-form "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-in-lexenv
+ nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ (block ,name ,body))
+ ,lexenv))))))))
+
(defun funcall-in-macrolet-lexenv (definitions fun)
(%funcall-in-foomacrolet-lexenv
- (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))
- (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))))))))
+ (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))
:funs
definitions
fun))
"MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
Evaluate the Body-Forms in an environment with the specified local macros
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))))
+ destructuring lambda list, and the Forms evaluate to the expansion.."
+ (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
- (lambda (definition)
- (unless (proper-list-of-length-p definition 2)
- (compiler-error "malformed symbol/expansion pair: ~S" definition))
+(defmacro symbol-macrolet-definitionize-fun (context)
+ (flet ((make-error-form (control &rest args)
+ (ecase context
+ (:compile `(compiler-error ,control ,@args))
+ (:eval `(error 'simple-program-error
+ :format-control ,control
+ :format-arguments (list ,@args))))))
+ `(lambda (definition)
+ (unless (proper-list-of-length-p definition 2)
+ ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition))
(destructuring-bind (name expansion) definition
(unless (symbolp name)
- (compiler-error
- "The local symbol macro name ~S is not a symbol."
- name))
+ ,(make-error-form
+ "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))))
+ ,(make-error-form
+ "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+ 'kind 'name)))
+ `(,name . (MACRO . ,expansion))))))1
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+ (%funcall-in-foomacrolet-lexenv
+ (symbol-macrolet-definitionize-fun :compile)
:vars
definitions
fun))
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)
be a lambda expression."
(if (consp thing)
(case (car thing)
- ((lambda)
+ ((lambda named-lambda instance-lambda lambda-with-lexenv)
(reference-leaf start
cont
- (ir1-convert-lambda thing
- :debug-name (debug-namify
- "#'~S" thing))))
- ((setf)
+ (ir1-convert-lambdalike
+ thing
+ :debug-name (debug-namify "#'~S" thing)
+ :allow-debug-catch-tag t)))
+ ((setf sb!pcl::class-predicate)
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
- ((instance-lambda)
- (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
- :debug-name (debug-namify "#'~S"
- thing))))
- (setf (getf (functional-plist res) :fin-function) t)
- (reference-leaf start cont res)))
(t
(compiler-error "~S is not a legal function name." thing)))
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var))))
-
-;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
-;;; except that the value of NAME is passed to the compiler for use in
-;;; creation of debug information for the resulting function.
-;;;
-;;; 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 :AROUND (STARSHIP T))
-;;; 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))))
\f
;;;; FUNCALL
(def-ir1-translator %funcall ((function &rest args) start cont)
(let ((fun-cont (make-continuation)))
(ir1-convert start fun-cont function)
- (assert-continuation-type fun-cont (specifier-type 'function))
+ (assert-continuation-type fun-cont (specifier-type 'function)
+ (lexenv-policy *lexenv*))
(ir1-convert-combination-args fun-cont cont args)))
;;; This source transform exists to reduce the amount of work for the
;;; 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) (parse-body body nil)
- (let ((*lexenv* (process-decls decls nil nil cont)))
+ (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)
(ir1-convert-lambda d
:source-name n
:debug-name (debug-namify
- "FLET ~S" n)))
+ "FLET ~S" n)
+ :allow-debug-catch-tag t))
names defs))
(*lexenv* (make-lexenv
:default (process-decls decls nil fvars cont)
(ir1-convert-lambda def
:source-name name
:debug-name (debug-namify
- "LABELS ~S" name)))
+ "LABELS ~S" name)
+ :allow-debug-catch-tag t))
names defs))))
;; Modify all the references to the dummy function leaves so
;;; many branches there are going to be.
(defun ir1ize-the-or-values (type cont lexenv place)
(declare (type continuation cont) (type lexenv lexenv))
- (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))
- (new (values-type-intersection old-type ctype)))
+ (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
+ (old-atype (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (old-ctype (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (intersects (values-types-equal-or-intersect old-atype atype))
+ (new-atype (values-type-intersection old-atype atype))
+ (new-ctype (values-type-intersection
+ old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
(when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new))
+ (setf (continuation-asserted-type cont) new-atype)
+ (setf (continuation-type-to-check cont) new-ctype))
(when (and (not intersects)
;; FIXME: Is it really right to look at *LEXENV* here,
;; instead of looking at the LEXENV argument? Why?
(= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
(compiler-warn
"The type ~S ~A conflicts with an enclosing assertion:~% ~S"
- (type-specifier ctype)
+ (type-specifier atype)
place
- (type-specifier old-type)))
- (make-lexenv :type-restrictions `((,cont . ,new))
+ (type-specifier old-atype)))
+ (make-lexenv :type-restrictions `((,cont . ,new-atype))
+ :weakend-type-restrictions `((,cont . ,new-ctype))
:default lexenv)))
;;; Assert that FORM evaluates to the specified type (which may be a
(defun setq-var (start cont var value)
(declare (type continuation start cont) (type basic-var var))
(let ((dest (make-continuation)))
- (setf (continuation-asserted-type dest) (leaf-type var))
(ir1-convert start dest value)
+ (assert-continuation-type dest
+ (or (lexenv-find var type-restrictions)
+ (leaf-type var))
+ (lexenv-policy *lexenv*))
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
(setf (leaf-ever-used var) t)
\f
;;;; CATCH, THROW and UNWIND-PROTECT
-;;; We turn THROW into a multiple-value-call of a magical function,
+;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
;;; since as as far as IR1 is concerned, it has no interesting
;;; properties other than receiving multiple-values.
(def-ir1-translator throw ((tag result) start cont)
fun
`(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
- (assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(ir1-convert start dummy-start result)
(with-continuation-type-assertion
+ ;; FIXME: policy
(cont (continuation-asserted-type dummy-start)
"of the first form")
(substitute-continuation-uses cont dummy-start))
\f
;;;; interface to defining macros
-;;;; FIXME:
-;;;; classic CMU CL comment:
-;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;; so that we get a chance to see what is going on. We define
-;;;; IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
+;;; Old CMUCL comment:
+;;;
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with NAME stripped
+;;; off. This is used to hide the guts of DEFmumble macros to
+;;; prevent annoying error messages.
+;;;
+;;; Now that we have implementations of DEFmumble macros in terms of
+;;; EVAL-WHEN, this function is no longer used. However, it might be
+;;; worth figuring out why it was used, and maybe doing analogous
+;;; munging to the functions created in the expanders for the macros.
(defun revert-source-path (name)
(do ((path *current-path* (cdr path)))
((null path) *current-path*)
(when (or (eq first name)
(eq first 'original-source-start))
(return path)))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
- start cont
- :kind :function)
- (let ((name (eval name))
- (def (second def))) ; We don't want to make a function just yet...
-
- (when (eq (info :function :kind name) :special-form)
- (compiler-error "attempt to define a compiler-macro for special form ~S"
- name))
-
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (fun (ir1-convert-lambda def
- :debug-name (debug-namify
- "DEFINE-COMPILER-MACRO ~S"
- name))))
- (setf (functional-arg-documentation fun) (eval lambda-list))
-
- (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
- (when sb!xc:*compile-print*
- (compiler-mumble "~&; converted ~S~%" name))))
projects / sbcl.git / blobdiff