-;;;; a simple code walker for PCL
+;;;; a simple code walker
;;;;
;;;; The code which implements the macroexpansion environment
;;;; manipulation mechanisms is in the first part of the file, the
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
-(in-package "SB-WALKER")
+(in-package "SB!WALKER")
+\f
+;;;; forward references
+
+(defvar *key-to-walker-environment*)
\f
;;;; environment hacking stuff, necessarily SBCL-specific
;;; In SBCL, as in CMU CL before it, the environment is represented
;;; with a structure that holds alists for the functional things,
-;;; variables, blocks, etc.
-;;; Except for SYMBOL-MACROLET, only the SB-C::LEXENV-FUNCTIONS slot
-;;; is relevant. It holds: Alist (Name . What), where What is either
-;;; a functional (a local function) or a list (MACRO . <function>) (a
-;;; local macro, with the specifier expander.) Note that Name may be a
-;;; (SETF <name>) function.
-;;; Accessors are defined below, eg (ENV-WALK-FUNCTION ENV).
+;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the
+;;; SB!C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What),
+;;; where What is either a functional (a local function) or a list
+;;; (MACRO . <function>) (a local macro, with the specifier expander.)
+;;; Note that Name may be a (SETF <name>) function. Accessors are
+;;; defined below, eg (ENV-WALK-FUNCTION ENV).
;;;
;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
;;; this code hides the WALKER version of an environment
-;;; inside the SB-C::LEXENV structure.
+;;; inside the SB!C::LEXENV structure.
;;;
;;; In CMUCL (and former SBCL), This used to be a list of lists of form
;;; (<gensym-name> MACRO . #<interpreted-function>) in the :functions slot
;;; a list, which was not really an interpreted function.
;;; Instead this list was COERCEd to a #<FUNCTION ...>!
;;;
-;;; Instead, we now use a special sort of "function"-type for that information,
-;;; because the functions slot in SB-C::LEXENV is supposed to have a list of
-;;; <Name MACRO . #<function> elements.
-;;; So, now we hide our bits of interest in the walker-info slot in our new
-;;; BOGO-FUNCTION.
+;;; Instead, we now use a special sort of "function"-type for that
+;;; information, because the functions slot in SB!C::LEXENV is
+;;; supposed to have a list of <Name MACRO . #<function> elements.
+;;; So, now we hide our bits of interest in the walker-info slot in
+;;; our new BOGO-FUN.
;;;
-;;; MACROEXPAND-1 is the only SBCL function that gets called with the
-;;; constructed environment argument.
+;;; MACROEXPAND-1 and SB!INT:EVAL-IN-LEXENV are the only SBCL
+;;; functions that get called with the constructed environment
+;;; argument.
+
+(/show "walk.lisp 108")
(defmacro with-augmented-environment
((new-env old-env &key functions macros) &body body)
,macros)))
,@body))
-(defstruct (bogo-function
- (:alternate-metaclass sb-kernel:funcallable-instance
- sb-kernel:funcallable-structure-class
- sb-kernel:make-funcallable-structure-class)
- (:type sb-kernel:funcallable-structure)
- (:copier nil))
- (walker-info (required-argument) :type list))
-
-(defun walker-info-to-bogo-function (x)
- (make-bogo-function :walker-info x))
-
-(defun bogo-function-to-walker-info (x)
- (bogo-function-walker-info x))
-
-(defun with-augmented-environment-internal (env functions macros)
+;;; a unique tag to show that we're the intended caller of BOGO-FUN
+(defvar *bogo-fun-magic-tag*
+ '(:bogo-fun-magic-tag))
+
+;;; The interface of BOGO-FUNs (previously implemented as
+;;; FUNCALLABLE-INSTANCEs) is just these two operations, so we can do
+;;; them with ordinary closures.
+;;;
+;;; KLUDGE: BOGO-FUNs are sorta weird, and MNA and I have both hacked
+;;; on this code without quite figuring out what they're for. (He
+;;; changed them to work after some changes in the IR1 interpreter
+;;; made functions not be built lazily, and I changed them so that
+;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff
+;;; can become less general.) There may be further simplifications or
+;;; clarifications which could be done. -- WHN 2001-10-19
+(defun walker-info-to-bogo-fun (walker-info)
+ (lambda (magic-tag &rest rest)
+ (aver (not rest)) ; else someone is using me in an unexpected way
+ (aver (eql magic-tag *bogo-fun-magic-tag*)) ; else ditto
+ walker-info))
+(defun bogo-fun-to-walker-info (bogo-fun)
+ (declare (type function bogo-fun))
+ (funcall bogo-fun *bogo-fun-magic-tag*))
+
+(defun with-augmented-environment-internal (env funs macros)
;; Note: In order to record the correct function definition, we
;; would have to create an interpreted closure, but the
;; WITH-NEW-DEFINITION macro down below makes no distinction between
;; environment. So we just blow it off, 'cause anything real we do
;; would be wrong. But we still have to make an entry so we can tell
;; functions from macros.
- (let ((lexenv (sb-kernel::coerce-to-lexenv env)))
- (sb-c::make-lexenv
- :default lexenv
- :functions
- (append (mapcar (lambda (f)
- (cons (car f) (sb-c::make-functional :lexenv lexenv)))
- functions)
- (mapcar (lambda (m)
- (list* (car m)
- 'sb-c::macro
- (if (eq (car m) *key-to-walker-environment*)
- (walker-info-to-bogo-function (cadr m))
- (coerce (cadr m) 'function))))
- macros)))))
+ (let ((lexenv (sb!kernel::coerce-to-lexenv env)))
+ (sb!c::make-lexenv
+ :default lexenv
+ :vars (when (eql (caar macros) *key-to-walker-environment*)
+ (copy-tree (remove :lexical-var (fourth (cadar macros))
+ :key #'cadr)))
+ :funs (append (mapcar (lambda (f)
+ (cons (car f)
+ (sb!c::make-functional :lexenv lexenv)))
+ funs)
+ (mapcar (lambda (m)
+ (list* (car m)
+ 'sb!c::macro
+ (if (eq (car m)
+ *key-to-walker-environment*)
+ (walker-info-to-bogo-fun (cadr m))
+ (coerce (cadr m) 'function))))
+ macros)))))
(defun environment-function (env fn)
(when env
- (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
+ (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal)))
(and entry
- (sb-c::functional-p (cdr entry))
+ (sb!c::functional-p (cdr entry))
(cdr entry)))))
(defun environment-macro (env macro)
(when env
- (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
+ (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq)))
(and entry
- (eq (cadr entry) 'sb-c::macro)
+ (eq (cadr entry) 'sb!c::macro)
(if (eq macro *key-to-walker-environment*)
- (values (bogo-function-to-walker-info (cddr entry)))
- (values (function-lambda-expression (cddr entry))))))))
+ (values (bogo-fun-to-walker-info (cddr entry)))
+ (values (function-lambda-expression (cddr entry))))))))
\f
;;;; other environment hacking, not so SBCL-specific as the
;;;; environment hacking in the previous section
(push (list (car mac)
(convert-macro-to-lambda (cadr mac)
(cddr mac)
+ ,old-env
(string (car mac))))
,macros))))
(with-augmented-environment
(,new-env ,old-env :functions ,functions :macros ,macros)
,@body))))
-(defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
+(defun convert-macro-to-lambda (llist body env &optional (name "dummy macro"))
(let ((gensym (make-symbol name)))
- (eval `(defmacro ,gensym ,llist ,@body))
+ (eval-in-lexenv `(defmacro ,gensym ,llist ,@body)
+ (sb!c::make-restricted-lexenv env))
(macro-function gensym)))
\f
;;;; the actual walker
(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
(walk-form nil wfop)
(declarations nil decp)
- (lexical-variables nil lexp))
- (let ((lock (environment-macro env *key-to-walker-environment*)))
+ (lexical-vars nil lexp))
+ (let ((lock (env-lock env)))
(list
(list *key-to-walker-environment*
- (list (if wfnp walk-function (car lock))
- (if wfop walk-form (cadr lock))
- (if decp declarations (caddr lock))
- (if lexp lexical-variables (cadddr lock)))))))
+ (list (if wfnp walk-function (car lock))
+ (if wfop walk-form (cadr lock))
+ (if decp declarations (caddr lock))
+ (if lexp lexical-vars (cadddr lock)))))))
(defun env-walk-function (env)
(car (env-lock env)))
(defun variable-symbol-macro-p (var env)
(let ((entry (member var (env-lexical-variables env) :key #'car)))
- (when (eq (cadar entry) :macro)
+ (when (eq (cadar entry) 'sb!sys:macro)
entry)))
(defvar *var-declarations* '(special))
;;; - Is a common lisp special form (not likely)
;;; - Is not a common lisp special form (on the 3600 IF --> COND).
;;;
-;;; * We can safe ourselves from this case (second subcase really)
+;;; * We can save ourselves from this case (second subcase really)
;;; by checking to see whether there is a template defined for
;;; something before we check to see whether we can macroexpand it.
;;;
`(eval-when (:load-toplevel :execute)
(setf (get-walker-template-internal ',name) ',template)))
-(defun get-walker-template (x)
+(defun get-walker-template (x context)
(cond ((symbolp x)
(get-walker-template-internal x))
((and (listp x) (eq (car x) 'lambda))
'(lambda repeat (eval)))
(t
- (error "can't get template for ~S" x))))
+ ;; FIXME: In an ideal world we would do something similar to
+ ;; COMPILER-ERROR here, replacing the form within the walker
+ ;; with an error-signalling form. This is slightly less
+ ;; pretty, but informative non the less. Best is the enemy of
+ ;; good, etc.
+ (error "Illegal function call in method body:~% ~S"
+ context))))
\f
;;;; the actual templates
(define-walker-template unwind-protect (nil return repeat (eval)))
;;; SBCL-only special forms
-(define-walker-template sb-ext:truly-the (nil quote eval))
+(define-walker-template sb!ext:truly-the (nil quote eval))
+;;; FIXME: maybe we don't need this one any more, given that
+;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))?
+(define-walker-template named-lambda walk-named-lambda)
\f
(defvar *walk-form-expand-macros-p* nil)
newform)))
(t
(let* ((fn (car newform))
- (template (get-walker-template fn)))
+ (template (get-walker-template fn newform)))
(if template
(if (symbolp template)
(funcall template newform context env)
(multiple-value-bind (newnewform macrop)
(walker-environment-bind
(new-env env :walk-form newform)
- (macroexpand-1 newform new-env))
+ (sb-xc:macroexpand-1 newform new-env))
(cond
(macrop
(let ((newnewnewform (walk-form-internal newnewform
;; maintained as part of SBCL, so it should know
;; about all the special forms that SBCL knows
;; about.
- (error "unexpected special form ~S" fn))
+ (bug "unexpected special form ~S" fn))
(t
;; Otherwise, walk the form as if it's just a
;; standard function call using a template for
(set
(walk-form-internal form :set env))
((lambda call)
- (cond ((or (symbolp form)
- (and (listp form)
- (= (length form) 2)
- (eq (car form) 'setf)))
+ (cond ((legal-fun-name-p form)
form)
(t (walk-form-internal form context env)))))
(case (car template)
(defun walk-template-handle-repeat (form template stop-form context env)
(if (eq form stop-form)
(walk-template form (cdr template) context env)
- (walk-template-handle-repeat-1 form
- template
- (car template)
- stop-form
- context
- env)))
+ (walk-template-handle-repeat-1
+ form template (car template) stop-form context env)))
(defun walk-template-handle-repeat-1 (form template repeat-template
stop-form context env)
(if (null repeat-template)
(walk-template stop-form (cdr template) context env)
(error "while handling code walker REPEAT:
- ~%ran into STOP while still in REPEAT template")))
+ ~%ran into STOP while still in REPEAT template")))
((null repeat-template)
(walk-template-handle-repeat-1
form template (car template) stop-form context env))
(cdr body) fn env doc-string-p declarations)))
((and form
(listp form)
- (null (get-walker-template (car form)))
+ (null (get-walker-template (car form) form))
(progn
(multiple-value-setq (new-form macrop)
- (macroexpand-1 form env))
+ (sb-xc:macroexpand-1 form env))
macrop))
;; This form was a call to a macro. Maybe it expanded
;; into a declare? Recurse to find out.
(defun walk-unexpected-declare (form context env)
(declare (ignore context env))
- (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
+ (warn "encountered ~S ~_in a place where a DECLARE was not expected"
form)
form)
(relist*
form locally walked-body)))
-(defun walk-let-if (form context env)
- (let ((test (cadr form))
- (bindings (caddr form))
- (body (cdddr form)))
- (walk-form-internal
- `(let ()
- (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
- bindings)))
- (flet ((.let-if-dummy. () ,@body))
- (if ,test
- (let ,bindings (.let-if-dummy.))
- (.let-if-dummy.))))
- context
- env)))
-
(defun walk-multiple-value-setq (form context env)
(let ((vars (cadr form)))
- (if (some #'(lambda (var)
- (variable-symbol-macro-p var env))
+ (if (some (lambda (var)
+ (variable-symbol-macro-p var env))
vars)
- (let* ((temps (mapcar #'(lambda (var)
- (declare (ignore var))
- (gensym))
+ (let* ((temps (mapcar (lambda (var)
+ (declare (ignore var))
+ (gensym))
vars))
- (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
+ (sets (mapcar (lambda (var temp) `(setq ,var ,temp))
vars
temps))
(expanded `(multiple-value-bind ,temps ,(caddr form)
(walked-body
(walk-declarations
body
- #'(lambda (real-body real-env)
- (setq walked-bindings
- (walk-bindings-1 bindings
- old-env
- new-env
- context
- nil))
- (walk-repeat-eval real-body real-env))
+ (lambda (real-body real-env)
+ (setq walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ nil))
+ (walk-repeat-eval real-body real-env))
new-env)))
(relist* form mvb walked-bindings mv-form walked-body))))
(defun walk-named-lambda (form context old-env)
(walker-environment-bind (new-env old-env)
- (let* ((name (cadr form))
- (arglist (caddr form))
+ (let* ((name (second form))
+ (arglist (third form))
(body (cdddr form))
(walked-arglist (walk-arglist arglist context new-env))
(walked-body
(walk-declarations body #'walk-repeat-eval new-env)))
(relist* form
(car form)
- name
+ name
walked-arglist
walked-body))))
(body (cddr form)))
(walker-environment-bind
(new-env old-env
- :lexical-variables
- (append (mapcar #'(lambda (binding)
- `(,(car binding)
- :macro . ,(cadr binding)))
+ :lexical-vars
+ (append (mapcar (lambda (binding)
+ `(,(car binding)
+ sb!sys:macro . ,(cadr binding)))
bindings)
(env-lexical-variables old-env)))
(relist* form 'symbol-macrolet bindings
(defmacro with-rpush (&body body)
`(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
-|#
\ No newline at end of file
+|#