Subject: [clisp-list] Re: macrolet walker?

From: Bruno Haible <[email-masked]>
Date: Wed Dec 11 13:35:03 2002

Raymond Toy wrote:

> Is there a code walker in clisp that can be used to walk through
> macrolets?  Series has support for a macrolet walker in LW and
> CMUCL.  Support for Clisp would be nice.
> ...
> CMUCL uses the code-walker from PCL to do this.

Then why don't you use the port of PCL's code walker to clisp?

Here are the modifications I made to it back in 1993. The
*toplevel-environment* hack is probably not needed any more, as
clisp's macroexpand function now accepts NIL as denoting the toplevel
environment.

Bruno

*** pcl.orig/pcl/walk.lisp	Mon Dec 21 22:24:06 1992
--- pcl.clisp/sept92/pcl/walk.lsp	Mon Jun  7 02:14:35 1993
***************
*** 70,75 ****
--- 70,76 ----
  	  *variable-declarations*
  	  variable-declaration
  	  macroexpand-all
+ 	  *toplevel-environment*
  	  ))

***************
*** 622,627 ****
--- 623,686 ----
  );#+(or KCL IBCL)
  
  
+ ;;;
+ ;;; In CLISP Common Lisp, the macroexpansion environment has the form
+ ;;;   NIL  or  #(sym1 def1 ... symn defn next-env)
+ ;;; where next-env is an macroexpansion environment of the same form.
+ ;;; A def entry herein is a cons (SYS::MACRO . macroexpansion-function)
+ ;;; for macros, and a symbol (a gensym in compiler, or NIL during
+ ;;; interpretation of LABELS) or a function object for functions.
+ ;;;
+ ;;; From 5.6.1993 on, this description holds only for the function
+ ;;; and macro environment. The entire macroexpansion environment is a
+ ;;; simple-vector of length 2 whose second component obeys the description
+ ;;; above.
+ ;;;
+ 
+ #+CLISP
+ (progn
+   (defmacro with-augmented-environment
+             ((new-env old-env &key functions macros) &body body)
+     `(let ((,new-env (with-augmented-environment-internal
+                        ,old-env ,functions ,macros
+           ))         )
+        ,@body
+      )
+   )
+   (defun with-augmented-environment-internal (env functions macros)
+     (#-have-symbol-macrolet identity
+      #+have-symbol-macrolet (lambda (new-env) (vector (svref env 0) new-env))
+       (let* ((new-env (make-array (+ (* (+ (length functions) (length macros)) 2) 1)))
+              (i 0))
+         (dolist (f functions)
+           (setf (svref new-env i) f) (incf i)
+           (setf (svref new-env i) #'unbound-lexical-function) (incf i)
+         )
+         (dolist (m macros)
+           (setf (svref new-env i) (first m)) (incf i)
+           (setf (svref new-env i) (cons 'sys::macro (second m))) (incf i)
+         )
+         (setf (svref new-env i) #-have-symbol-macrolet env
+                                 #+have-symbol-macrolet (svref env 1)
+         )
+         new-env
+   ) ) )
+   (defun environment-function (env fn)
+     #+have-symbol-macrolet (setq env (svref env 1))
+     (let ((h (sys::fenv-assoc fn env)))
+       (or (eq h 'T) ; fenv-assoc didn't find anything
+           (sys::closurep h) (symbolp h)
+   ) ) )
+   (defun environment-macro (env macro)
+     #+have-symbol-macrolet (setq env (svref env 1))
+     (let ((h (sys::fenv-assoc macro env)))
+       (if (and (consp h) (eq (car h) 'sys::macro))
+         (cdr h) ; macroexpansion-function
+         nil ; anything
+   ) ) )
+ );#+CLISP
+ 
+ 
  ;;;   --- TI Explorer --
  
  ;;; An environment is a two element list, whose car we can ignore and
***************
*** 1125,1130 ****
--- 1184,1192 ----
  	     (get-implementation-dependent-walker-template x)))
  	((and (listp x) (eq (car x) 'lambda))
  	 '(lambda repeat (eval)))
+         #+(or cmu CLISP) ; #+setf is defined later, in macros.lsp
+         ((and (listp x) (eq (car x) 'setf))
+          nil)
  	(t
  	 (error "Can't get template for ~S" x))))
  
***************
*** 1214,1225 ****
  
  (defvar walk-form-expand-macros-p nil)
  
! (defun macroexpand-all (form &optional environment)
    (let ((walk-form-expand-macros-p t))
      (walk-form form environment)))
  
  (defun WALK-FORM (form
! 		  &optional environment
  			    (walk-function
  			      #'(lambda (subform context env)
  				  (declare (ignore context env))
--- 1276,1292 ----
  
  (defvar walk-form-expand-macros-p nil)
  
! (defconstant *toplevel-environment*
!   #+(and CLISP have-symbol-macrolet) (vector nil nil)
!   #-(and CLISP have-symbol-macrolet) nil
! )
! 
! (defun macroexpand-all (form &optional (environment *toplevel-environment*))
    (let ((walk-form-expand-macros-p t))
      (walk-form form environment)))
  
  (defun WALK-FORM (form
! 		  &optional (environment *toplevel-environment*)
  			    (walk-function
  			      #'(lambda (subform context env)
  				  (declare (ignore context env))
***************
*** 1248,1254 ****
  ;;;
  (defun NESTED-WALK-FORM (whole
  			 form
! 			 &optional environment
  				   (walk-function
  				     #'(lambda (subform context env)
  					 (declare (ignore context env))
--- 1315,1321 ----
  ;;;
  (defun NESTED-WALK-FORM (whole
  			 form
! 			 &optional (environment *toplevel-environment*)
  				   (walk-function
  				     #'(lambda (subform context env)
  					 (declare (ignore context env))
***************
*** 1842,1848 ****
  
  (defun walk-macrolet (form context old-env)
    (walker-environment-bind (macro-env
! 			    nil
  			    :walk-function (env-walk-function old-env))
      (labels ((walk-definitions (definitions)
  	       (and definitions
--- 1909,1915 ----
  
  (defun walk-macrolet (form context old-env)
    (walker-environment-bind (macro-env
! 			    *toplevel-environment*
  			    :walk-function (env-walk-function old-env))
      (labels ((walk-definitions (definitions)
  	       (and definitions
***************
*** 1971,1977 ****
    (terpri)
    (terpri)
    (let ((copy-of-form (copy-tree form))
! 	(result (walk-form form nil
  		  #'(lambda (x y env)
  		      (format t "~&Form: ~S ~3T Context: ~A" x y)
  		      (when (symbolp x)
--- 2038,2044 ----
    (terpri)
    (terpri)
    (let ((copy-of-form (copy-tree form))
! 	(result (walk-form form *toplevel-environment*
  		  #'(lambda (x y env)
  		      (format t "~&Form: ~S ~3T Context: ~A" x y)
  		      (when (symbolp x)
***************
*** 2165,2171 ****
  (let ((the-lexical-variables ()))
    (walk-form '(let ((a 1) (b 2))
  		#'(lambda (x) (list a b x y)))
! 	     ()
  	     #'(lambda (form context env)
  		 (when (and (symbolp form)
  			    (variable-lexical-p form env))
--- 2232,2238 ----
  (let ((the-lexical-variables ()))
    (walk-form '(let ((a 1) (b 2))
  		#'(lambda (x) (list a b x y)))
! 	     *toplevel-environment*
  	     #'(lambda (form context env)
  		 (when (and (symbolp form)
  			    (variable-lexical-p form env))

---

From: Raymond Toy <[email-masked]>
Date: Wed Dec 11 15:06:02 2002

>>>>> "Bruno" == Bruno Haible <[email-masked]> writes:

    >> CMUCL uses the code-walker from PCL to do this.

    Bruno> Then why don't you use the port of PCL's code walker to clisp?

I don't because, mostly, I don't want to maintain it as a part of
series.  CMUCL comes with PCL, so I don't have to maintain it.

Ray