;;; FIXME: This could and probably should be converted to use
;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings,
;;; so I'm not motivated. Patches will be accepted...
-(defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals)
+(defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals
+ post-binding-lexenv)
(declare (type ctran start next) (type (or lvar null) result)
(list body aux-vars aux-vals))
(if (null aux-vars)
- (ir1-convert-progn-body start next result body)
+ (let ((*lexenv* (make-lexenv :vars (copy-list post-binding-lexenv))))
+ (ir1-convert-progn-body start next result body))
(let ((ctran (make-ctran))
(fun-lvar (make-lvar))
(fun (ir1-convert-lambda-body body
(list (first aux-vars))
:aux-vars (rest aux-vars)
:aux-vals (rest aux-vals)
+ :post-binding-lexenv post-binding-lexenv
:debug-name (debug-name
'&aux-bindings
aux-vars))))
;;; to start a block outside of this cleanup, causing cleanup code to
;;; be emitted when the scope is exited.
(defun ir1-convert-special-bindings
- (start next result body aux-vars aux-vals svars)
+ (start next result body aux-vars aux-vals svars post-binding-lexenv)
(declare (type ctran start next) (type (or lvar null) result)
(list body aux-vars aux-vals svars))
(cond
((null svars)
- (ir1-convert-aux-bindings start next result body aux-vars aux-vals))
+ (ir1-convert-aux-bindings start next result body aux-vars aux-vals
+ post-binding-lexenv))
(t
(ctran-starts-block next)
(let ((cleanup (make-cleanup :kind :special-bind))
(ir1-convert bind-ctran cleanup-ctran nil '(%cleanup-point))
(ir1-convert-special-bindings cleanup-ctran next result
body aux-vars aux-vals
- (rest svars))))))
+ (rest svars)
+ post-binding-lexenv)))))
(values))
;;; Create a lambda node out of some code, returning the result. The
aux-vals
(source-name '.anonymous.)
debug-name
- (note-lexical-bindings t))
+ (note-lexical-bindings t)
+ post-binding-lexenv)
(declare (list body vars aux-vars aux-vals))
;; We're about to try to put new blocks into *CURRENT-COMPONENT*.
(use-ctran bind postbind-ctran)
(ir1-convert-special-bindings postbind-ctran result-ctran
result-lvar body
- aux-vars aux-vals (svars))))))
+ aux-vars aux-vals (svars)
+ post-binding-lexenv)))))
(link-blocks (component-head *current-component*) (node-block bind))
(push lambda (component-new-functionals *current-component*))
vars supplied-p-p body
aux-vars aux-vals
source-name debug-name
- force)
+ force post-binding-lexenv)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals))
(list* t arg-name entry-vals)
(rest vars) t body aux-vars aux-vals
source-name debug-name
- force)
+ force post-binding-lexenv)
(ir1-convert-hairy-args
res
(cons arg default-vars)
(cons arg-name entry-vals)
(rest vars) supplied-p-p body aux-vars aux-vals
source-name debug-name
- force))))
+ force post-binding-lexenv))))
;; We want to delay converting the entry, but there exist
;; problems: hidden references should not be established to
(convert-optional-entry (force ep)
default-vars default-vals
defaults
- name)
+ name)
res))))))
;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
(defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
rest more-context more-count keys supplied-p-p
body aux-vars aux-vals
- source-name debug-name)
+ source-name debug-name post-binding-lexenv)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals keys body
aux-vars aux-vals))
body (main-vars)
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
+ :post-binding-lexenv post-binding-lexenv
:debug-name (debug-name 'varargs-entry name)))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) () name)))
vars supplied-p-p body aux-vars
aux-vals
source-name debug-name
- force)
+ force post-binding-lexenv)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals))
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil nil nil vars supplied-p-p body aux-vars
- aux-vals source-name debug-name)
+ aux-vals source-name debug-name
+ post-binding-lexenv)
(let* ((name (or debug-name source-name))
(fun (ir1-convert-lambda-body
body (reverse default-vars)
:aux-vars aux-vars
:aux-vals aux-vals
+ :post-binding-lexenv post-binding-lexenv
:debug-name (debug-name 'hairy-arg-processor name))))
(setf (optional-dispatch-main-entry res) fun)
(ir1-convert-hairy-args res nvars nvals nvars nvals
(rest vars) nil body aux-vars aux-vals
source-name debug-name
- nil)))
+ nil post-binding-lexenv)))
(t
(let* ((arg (first vars))
(info (lambda-var-arg-info arg))
entry-vars entry-vals vars supplied-p-p body
aux-vars aux-vals
source-name debug-name
- force)))
+ force post-binding-lexenv)))
;; See GENERATE-OPTIONAL-DEFAULT-ENTRY.
(push (if (lambda-p ep)
(register-entry-point
entry-vars entry-vals
arg nil nil (rest vars) supplied-p-p body
aux-vars aux-vals
- source-name debug-name))
+ source-name debug-name
+ post-binding-lexenv))
(:more-context
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil arg (second vars) (cddr vars) supplied-p-p
body aux-vars aux-vals
- source-name debug-name))
+ source-name debug-name
+ post-binding-lexenv))
(:keyword
(ir1-convert-more res default-vars default-vals
entry-vars entry-vals
nil nil nil vars supplied-p-p body aux-vars
- aux-vals source-name debug-name)))))))
+ aux-vals source-name debug-name
+ post-binding-lexenv)))))))
;;; This function deals with the case where we have to make an
;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and
;;; figure out the MIN-ARGS and MAX-ARGS.
(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals
&key
+ post-binding-lexenv
(source-name '.anonymous.)
(debug-name
(debug-name '&optional-dispatch vars)))
(aver-live-component *current-component*)
(push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
- source-name debug-name nil)
+ source-name debug-name nil post-binding-lexenv)
(setf (optional-dispatch-min-args res) min)
(setf (optional-dispatch-max-args res)
(+ (1- (length (optional-dispatch-entry-points res))) min))
(multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
(make-lambda-vars (cadr form))
(multiple-value-bind (forms decls) (parse-body (cddr form))
- (binding* (((*lexenv* result-type)
- (process-decls decls (append aux-vars vars) nil))
+ (binding* (((*lexenv* result-type post-binding-lexenv)
+ (process-decls decls (append aux-vars vars) nil
+ :binding-form-p t))
(forms (if (and *allow-instrumenting*
(policy *lexenv* (>= insert-debug-catch 2)))
`((catch (locally
(ir1-convert-hairy-lambda forms vars keyp
allow-other-keys
aux-vars aux-vals
+ :post-binding-lexenv post-binding-lexenv
:source-name source-name
:debug-name debug-name)
(ir1-convert-lambda-body forms vars
:aux-vars aux-vars
:aux-vals aux-vals
+ :post-binding-lexenv post-binding-lexenv
:source-name source-name
:debug-name debug-name))))
(setf (functional-inline-expansion res) form)
`(() () () . ,(cdr fun)))
(let ((*lexenv* (make-lexenv
:default (process-decls decls nil nil
- (make-null-lexenv))
+ :lexenv (make-null-lexenv))
:vars (copy-list symbol-macros)
:funs (mapcar (lambda (x)
`(,(car x) .
the efficiency of stable code.")
(defvar *fun-names-in-this-file* nil)
+
+(defvar *post-binding-variable-lexenv* nil)
\f
;;;; namespace management utilities
;;; Process a special declaration, returning a new LEXENV. A non-bound
;;; special declaration is instantiated by throwing a special variable
-;;; into the variables.
-(defun process-special-decl (spec res vars)
+;;; into the variables if BINDING-FORM-P is NIL, or otherwise into
+;;; *POST-BINDING-VARIABLE-LEXENV*.
+(defun process-special-decl (spec res vars binding-form-p)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
(setf (lambda-var-specvar var)
(specvar-for-binding name)))
(null
- (unless (assoc name (new-venv) :test #'eq)
+ (unless (or (assoc name (new-venv) :test #'eq))
(new-venv (cons name (specvar-for-binding name))))))))
- (if (new-venv)
- (make-lexenv :default res :vars (new-venv))
- res)))
+ (cond (binding-form-p
+ (setf *post-binding-variable-lexenv*
+ (append (new-venv) *post-binding-variable-lexenv*))
+ res)
+ ((new-venv)
+ (make-lexenv :default res :vars (new-venv)))
+ (t
+ res))))
;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
;;; (and TYPE if notinline), plus type-restrictions from the lexenv.
;;; Process a single declaration spec, augmenting the specified LEXENV
;;; RES. Return RES and result type. VARS and FVARS are as described
;;; PROCESS-DECLS.
-(defun process-1-decl (raw-spec res vars fvars)
+(defun process-1-decl (raw-spec res vars fvars binding-form-p)
(declare (type list raw-spec vars fvars))
(declare (type lexenv res))
(let ((spec (canonized-decl-spec raw-spec))
(result-type *wild-type*))
(values
(case (first spec)
- (special (process-special-decl spec res vars))
+ (special (process-special-decl spec res vars binding-form-p))
(ftype
(unless (cdr spec)
(compiler-error "no type specified in FTYPE declaration: ~S" spec))
;;; filling in slots in the leaf structures, we return a new LEXENV,
;;; which reflects pervasive special and function type declarations,
;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of
-;;; VALUES declarations.
+;;; VALUES declarations. If BINDING-FORM-P is true, the third return
+;;; value is a list of VARs that should not apply to the lexenv of the
+;;; initialization forms for the bindings, but should apply to the body.
;;;
;;; This is also called in main.lisp when PROCESS-FORM handles a use
;;; of LOCALLY.
-(defun process-decls (decls vars fvars &optional (env *lexenv*))
+(defun process-decls (decls vars fvars &key (lexenv *lexenv*)
+ (binding-form-p nil))
(declare (list decls vars fvars))
- (let ((result-type *wild-type*))
+ (let ((result-type *wild-type*)
+ (*post-binding-variable-lexenv* nil))
(dolist (decl decls)
(dolist (spec (rest decl))
(unless (consp spec)
(compiler-error "malformed declaration specifier ~S in ~S" spec decl))
(multiple-value-bind (new-env new-result-type)
- (process-1-decl spec env vars fvars)
- (setq env new-env)
+ (process-1-decl spec lexenv vars fvars binding-form-p)
+ (setq lexenv new-env)
(unless (eq new-result-type *wild-type*)
(setq result-type
(values-type-intersection result-type new-result-type))))))
- (values env result-type)))
+ (values lexenv result-type *post-binding-variable-lexenv*)))
-(defun %processing-decls (decls vars fvars ctran lvar fun)
- (multiple-value-bind (*lexenv* result-type)
- (process-decls decls vars fvars)
+(defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)
+ (multiple-value-bind (*lexenv* result-type post-binding-lexenv)
+ (process-decls decls vars fvars :binding-form-p binding-form-p)
(cond ((eq result-type *wild-type*)
- (funcall fun ctran lvar))
+ (funcall fun ctran lvar post-binding-lexenv))
(t
(let ((value-ctran (make-ctran))
(value-lvar (make-lvar)))
(multiple-value-prog1
- (funcall fun value-ctran value-lvar)
+ (funcall fun value-ctran value-lvar post-binding-lexenv)
(let ((cast (make-cast value-lvar result-type
(lexenv-policy *lexenv*))))
(link-node-to-previous-ctran cast value-ctran)
(setf (lvar-dest value-lvar) cast)
(use-continuation cast ctran lvar))))))))
-(defmacro processing-decls ((decls vars fvars ctran lvar) &body forms)
+(defmacro processing-decls ((decls vars fvars ctran lvar
+ &optional post-binding-lexenv)
+ &body forms)
(check-type ctran symbol)
(check-type lvar symbol)
- `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
- (lambda (,ctran ,lvar) ,@forms)))
+ (let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
+ (post-binding-lexenv (or post-binding-lexenv (gensym))))
+ `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
+ ,post-binding-lexenv-p
+ (lambda (,ctran ,lvar ,post-binding-lexenv)
+ (declare (ignorable ,post-binding-lexenv))
+ ,@forms))))
;;; Return the SPECVAR for NAME to use when we see a local SPECIAL
;;; declaration. If there is a global variable of that name, then
projects / sbcl.git / commitdiff