the efficiency of stable code.")
(defvar *fun-names-in-this-file* nil)
-
-;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
-;;; insertion a (CATCH ...) around code to allow the debugger RETURN
-;;; command to function.
-(defvar *allow-debug-catch-tag* t)
\f
;;;; namespace management utilities
(declare (list path))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
+ (*current-component* component)
+ (*allow-instrumenting* t))
(setf (component-name component) "initial component")
(setf (component-kind component) :initial)
(let* ((forms (if for-value `(,form) `(,form nil)))
(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
- ;; out of the body and converts a proxy form instead.
- (ir1-error-bailout ((start next result
- form
- &optional
- (proxy ``(error 'simple-program-error
- :format-control "execution of a form compiled with errors:~% ~S"
- :format-arguments (list ',,form))))
- &body body)
- (with-unique-names (skip)
- `(block ,skip
- (catch 'ir1-error-abort
+ ;; out of the body and converts a condition signalling form
+ ;; instead. The source form is converted to a string since it
+ ;; may contain arbitrary non-externalizable objects.
+ (ir1-error-bailout ((start next result form) &body body)
+ (with-unique-names (skip condition)
+ `(block ,skip
+ (let ((,condition (catch 'ir1-error-abort
(let ((*compiler-error-bailout*
- (lambda ()
- (throw 'ir1-error-abort nil))))
+ (lambda (&optional e)
+ (throw 'ir1-error-abort e))))
,@body
- (return-from ,skip nil)))
- (ir1-convert ,start ,next ,result ,proxy)))))
+ (return-from ,skip nil)))))
+ (ir1-convert ,start ,next ,result
+ (make-compiler-error-form ,condition ,form)))))))
;; Translate FORM into IR1. The code is inserted as the NEXT of the
;; CTRAN START. RESULT is the LVAR which receives the value of the
(ir1-error-bailout (start next result form)
(let ((*current-path* (or (gethash form *source-paths*)
(cons form *current-path*))))
- (if (atom form)
- (cond ((and (symbolp form) (not (keywordp form)))
- (ir1-convert-var start next result form))
- ((leaf-p form)
- (reference-leaf start next result form))
- (t
- (reference-constant start next result form)))
- (let ((opname (car form)))
- (cond ((or (symbolp opname) (leaf-p opname))
- (let ((lexical-def (if (leaf-p opname)
- opname
- (lexenv-find opname funs))))
- (typecase lexical-def
- (null
- (ir1-convert-global-functoid start next result
- form))
- (functional
- (ir1-convert-local-combination start next result
- form
- lexical-def))
- (global-var
- (ir1-convert-srctran start next result
- lexical-def form))
- (t
- (aver (and (consp lexical-def)
- (eq (car lexical-def) 'macro)))
- (ir1-convert start next result
- (careful-expand-macro (cdr lexical-def)
- form))))))
- ((or (atom opname) (not (eq (car opname) 'lambda)))
- (compiler-error "illegal function call"))
- (t
- ;; implicitly (LAMBDA ..) because the LAMBDA
- ;; expression is the CAR of an executed form
- (ir1-convert-combination start next result
- form
- (ir1-convert-lambda
- opname
- :debug-name (debug-namify
- "LAMBDA CAR "
- opname)
- :allow-debug-catch-tag t))))))))
+ (cond ((step-form-p form)
+ (ir1-convert-step start next result form))
+ ((atom form)
+ (cond ((and (symbolp form) (not (keywordp form)))
+ (ir1-convert-var start next result form))
+ ((leaf-p form)
+ (reference-leaf start next result form))
+ (t
+ (reference-constant start next result form))))
+ (t
+ (let ((opname (car form)))
+ (cond ((or (symbolp opname) (leaf-p opname))
+ (let ((lexical-def (if (leaf-p opname)
+ opname
+ (lexenv-find opname funs))))
+ (typecase lexical-def
+ (null
+ (ir1-convert-global-functoid start next result
+ form))
+ (functional
+ (ir1-convert-local-combination start next result
+ form
+ lexical-def))
+ (global-var
+ (ir1-convert-srctran start next result
+ lexical-def form))
+ (t
+ (aver (and (consp lexical-def)
+ (eq (car lexical-def) 'macro)))
+ (ir1-convert start next result
+ (careful-expand-macro (cdr lexical-def)
+ form))))))
+ ((or (atom opname) (not (eq (car opname) 'lambda)))
+ (compiler-error "illegal function call"))
+ (t
+ ;; implicitly (LAMBDA ..) because the LAMBDA
+ ;; expression is the CAR of an executed form
+ (ir1-convert-combination start next result
+ form
+ (ir1-convert-lambda
+ opname
+ :debug-name (debug-namify
+ "LAMBDA CAR "
+ opname))))))))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
(declare (type ctran start next)
(type (or lvar null) result)
(inline find-constant))
- (ir1-error-bailout
- (start next result value '(error "attempt to reference undumpable constant"))
+ (ir1-error-bailout (start next result value)
(when (producing-fasl-file)
(maybe-emit-make-load-forms value))
(let* ((leaf (find-constant value))
;; there's no need for us to accept ANSI's lameness when
;; processing our own code, though.
#+sb-xc-host
- (compiler-warn "reading an ignored variable: ~S" name)))
+ (warn "reading an ignored variable: ~S" name)))
(reference-leaf start next result var))
(cons
(aver (eq (car var) 'MACRO))
(muffle-warning-or-die)))
#-(and cmu sb-xc-host)
(warning (lambda (c)
- (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
- (wherestring) hint c)
+ (warn "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
(muffle-warning-or-die)))
(error (lambda (c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
(collect ((restr nil cons)
(new-vars nil cons))
(dolist (var-name (rest decl))
+ (when (boundp var-name)
+ (compiler-assert-symbol-home-package-unlocked
+ var-name "declaring the type of ~A"))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
(lexenv-find var-name vars)
(find-free-var var-name))))
(etypecase var
(leaf
- (flet ((process-var (var bound-var)
- (let* ((old-type (or (lexenv-find var type-restrictions)
- (leaf-type var)))
- (int (if (or (fun-type-p type)
- (fun-type-p old-type))
- type
- (type-approx-intersection2 old-type type))))
- (cond ((eq int *empty-type*)
- (unless (policy *lexenv* (= inhibit-warnings 3))
- (compiler-warn
- "The type declarations ~S and ~S for ~S conflict."
- (type-specifier old-type) (type-specifier type)
- var-name)))
- (bound-var (setf (leaf-type bound-var) int))
- (t
- (restr (cons var int)))))))
+ (flet
+ ((process-var (var bound-var)
+ (let* ((old-type (or (lexenv-find var type-restrictions)
+ (leaf-type var)))
+ (int (if (or (fun-type-p type)
+ (fun-type-p old-type))
+ type
+ (type-approx-intersection2
+ old-type type))))
+ (cond ((eq int *empty-type*)
+ (unless (policy *lexenv* (= inhibit-warnings 3))
+ (warn
+ 'type-warning
+ :format-control
+ "The type declarations ~S and ~S for ~S conflict."
+ :format-arguments
+ (list
+ (type-specifier old-type)
+ (type-specifier type)
+ var-name))))
+ (bound-var (setf (leaf-type bound-var) int))
+ (t
+ (restr (cons var int)))))))
(process-var var bound-var)
(awhen (and (lambda-var-p var)
(lambda-var-specvar var))
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
+ (when (fboundp name)
+ (compiler-assert-symbol-home-package-unlocked name
+ "declaring the ftype of ~A"))
(let ((found (find name fvars
:key #'leaf-source-name
:test #'equal)))
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
+ (compiler-assert-symbol-home-package-unlocked name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
(functional
(when (policy *lexenv* (>= speed inhibit-warnings))
(compiler-notify "ignoring ~A declaration not at ~
- definition of local function:~% ~S"
+ definition of local function:~% ~S"
sense name)))
(global-var
(push (cons name (make-new-inlinep found sense))
(dynamic-extent
(process-dx-decl (cdr spec) vars)
res)
+ ((disable-package-locks enable-package-locks)
+ (make-lexenv
+ :default res
+ :disabled-package-locks (process-package-lock-decl
+ spec (lexenv-disabled-package-locks res))))
(t
(unless (info :declaration :recognized (first spec))
(compiler-warn "unrecognized declaration ~S" raw-spec))