cont
(ir1-convert-lambda thing
:debug-name (debug-namify
- "#'~S" thing))))
+ "#'~S" thing)
+ :allow-debug-catch-tag t)))
((setf)
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
((instance-lambda)
(let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
:debug-name (debug-namify "#'~S"
- thing))))
+ thing)
+ :allow-debug-catch-tag t)))
(setf (getf (functional-plist res) :fin-function) t)
(reference-leaf start cont res)))
(t
(def-ir1-translator named-lambda ((name &rest rest) start cont)
(let* ((fun (if (legal-fun-name-p name)
(ir1-convert-lambda `(lambda ,@rest)
- :source-name name)
+ :source-name name
+ :allow-debug-catch-tag t)
(ir1-convert-lambda `(lambda ,@rest)
- :debug-name name)))
+ :debug-name name
+ :allow-debug-catch-tag t)))
(leaf (reference-leaf start cont fun)))
(when (legal-fun-name-p name)
(assert-global-function-definition-type name fun))
(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
(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 (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)
`(%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))
\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