(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
(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))
- (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-in-lexenv
- nil
- `(lambda (,whole ,environment)
- ,@local-decls
- (block ,name ,body))
- (make-restricted-lexenv *lexenv*)))))))
+ (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."
+ 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))
;;; 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
(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
;;; 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))
+ (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
(ir1-convert start dest value)
(let ((res (make-set :var var :value dest)))
(setf (continuation-dest dest) res)
`(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
(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))
projects / sbcl.git / blobdiff