X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwalk.lisp;h=c8401d43c31febb28f4e37b8dfc029aebc862e82;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=39beb2e3ce4fca980fff3bc6f746d2d4fbdbea9b;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index 39beb2e..c8401d4 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -153,6 +153,9 @@
   (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)))
@@ -236,14 +239,14 @@
 (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)))
@@ -355,13 +358,19 @@
   `(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))))
 
 ;;;; the actual templates
 
@@ -397,6 +406,9 @@
 
 ;;; SBCL-only special forms
 (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)
 
 (defvar *walk-form-expand-macros-p* nil)
 
@@ -446,7 +458,7 @@
 		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)
@@ -528,12 +540,8 @@
 (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)
@@ -542,7 +550,7 @@
 	 (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))
@@ -617,7 +625,7 @@
 		   (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)
 				     (sb-xc:macroexpand-1 form env))
@@ -703,21 +711,6 @@
     (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)
@@ -815,6 +808,20 @@
 	       walked-arglist
 	       walked-body))))
 
+(defun walk-named-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (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
+	       walked-arglist
+	       walked-body))))
+
 (defun walk-setq (form context env)
   (if (cdddr form)
       (let* ((expanded (let ((rforms nil)
@@ -845,7 +852,7 @@
 	 (body (cddr form)))
     (walker-environment-bind
 	(new-env old-env
-		 :lexical-variables
+		 :lexical-vars
 		 (append (mapcar (lambda (binding)
 				   `(,(car binding)
 				     sb!sys:macro . ,(cadr binding)))
@@ -965,4 +972,4 @@
 
 (defmacro with-rpush (&body body)
   `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
-|#
\ No newline at end of file
+|#