[Bese-devel] (no subject)

Berki Lukacs Tamas blt at sch.bme.hu
Wed Dec 27 10:06:37 UTC 2006


Hi!


I have spent a little time on making the sharpl support more "correct" in
arnesi. Unfortunately, the patch is really intrusive since I had to modify
the code walker to make it work correctly -- basically, the code walker
called macro functions in the null lexical environment, and that made it
impossible for the #l reader to work in some more convoluted cases, so I
had to fix it. This should benefit call/cc too by making it work in more
cases.

There are a couple of functions that are implementation-dependent
(environment access, basically -- chapter 8.5 from CLtL2). I don't have
access to a Mac, so I have written and tested these for SBCL, CMUCL and
CLISP on Linux, and Allegro 8.0 and LispWorks Personal on Win32. Other
implementations should be no worse off than before...


Lukács
-------------- next part --------------

New patches:

[Evaluate macros in correct lexical environment in code walker, use code walking in sharpl-reader
Berki Lukacs Tamas <blt at sch.bme.hu>**20061226165103] {
hunk ./arnesi.asd 36
-                             (:file "lexenv" :depends-on ("packages"))
+                             (:file "lexenv" :depends-on ("packages" "one-liners"))
hunk ./arnesi.asd 73
+			     (:file "sharpl" :depends-on ("suite"))
hunk ./src/call-cc/interpreter.lisp 34
-    (dolist* ((type name &rest data) walk-env)
+    (dolist* ((type name &rest data) (car walk-env))
hunk ./src/lexenv.lisp 22
-(defmethod lexical-variables ((environment null))
+(defgeneric lexical-macros (environment)
+  (:documentation "Returns the lexical macro definitions in
+  ENVIRONMENT. The return value is a list of elements of form
+  (SYMBOL . MACRO-FUNCTION. MACRO-FUNCTION can be called like
+  functions returned by macro-function."))
+
+(defgeneric lexical-symbol-macros (environment)
+  (:documentation "Returns the lexical symbol macro definitions 
+  in ENVIRONMENT. The return value is a list of elements of form
+  (SYMBOL . EXPANSION)."))
+
+(defmethod lexical-variables ((environment t))
+  '())
+
+(defmethod lexical-functions ((environment t))
hunk ./src/lexenv.lisp 39
-(defmethod lexical-functions ((environment null))
+(defmethod lexical-macros ((environment t))
+  '())
+
+(defmethod lexical-symbol-macros ((environment t))
hunk ./src/lexenv.lisp 114
-  (mapcar #'first (sb-c::lexenv-funs environment)))
+  (loop
+   for fun-spec in (sb-c::lexenv-funs environment)
+   when (not (consp (cdr fun-spec)))
+   collect (car fun-spec)))
+
+#+sbcl
+(defmethod lexical-macros ((environment sb-kernel:lexenv))
+  (loop
+   for mac-spec in (sb-c::lexenv-funs environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'sb-sys::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+sbcl
+(defmethod lexical-symbol-macros ((environment sb-kernel:lexenv))
+  (loop
+   for mac-spec in (sb-c::lexenv-vars environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'sb-sys::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
hunk ./src/lexenv.lisp 174
+#+cmu
+(defmethod lexical-macros ((environment c::lexenv))
+  (loop
+   for mac-spec in (c::lexenv-functions environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'system::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+cmu
+(defmethod lexical-symbol-macros ((environment c::lexenv))
+  (loop
+   for mac-spec in (c::lexenv-variables environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'system::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
hunk ./src/lexenv.lisp 232
+#+clisp
+(defmethod lexical-macros ((environment vector))
+  (let ((macros '()))
+    (when (aref environment 1)
+      (walk-vector-tree 
+       (lambda (macro-name macro-spec)
+	 (if (system::macrop macro-spec)
+	     (push (cons macro-name 
+			 (macro-function macro-name environment))
+		   macros)))
+       (aref environment 1)))
+    macros))
+
+#+clisp
+(defmethod lexical-symbol-macros ((environment vector))
+  (let (symbol-macros '())
+    (when (aref environment 0)
+      (walk-vector-tree 
+       (lambda (macro-name macro-spec)
+	 (if (system::symbol-macro-p macro-spec)
+	     (push (cons macro-name
+			 (macroexpand-1 macro-name environment))
+		   symbol-macros)))
+       (aref environment 0)))
+    symbol-macros))
+      
hunk ./src/lexenv.lisp 308
+#+(and lispworks (or win32 linux))
+(defun lexical-runtime-p (value)
+  (and (symbolp value)
+       (eq (symbol-package value) nil)))
+
hunk ./src/lexenv.lisp 315
-  (mapcar #'car (slot-value environment 'lexical::variables)))
+  (loop for candidate in (slot-value environment 'lexical::variables)
+        if (lexical-runtime-p (cdr candidate))
+        collect (car candidate)))
hunk ./src/lexenv.lisp 321
-  (mapcar #'car (slot-value environment 'lexical::functions)))
+  (loop for candidate in (slot-value environment 'lexical::functions)
+        if (lexical-runtime-p (cdr candidate))
+        collect (car candidate)))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-symbol-macros ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::variables)
+        unless (lexical-runtime-p (cdr candidate))
+        collect candidate))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-macros ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::functions)
+        unless (lexical-runtime-p (cdr candidate))
+        collect candidate))
hunk ./src/lexenv.lisp 366
+#+(and allegro (version>= 7 0))
+(defmethod lexical-macros ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-functions
+     (lambda (name type rest)
+       (when (eq type :macro)
+         (push (cons name (car rest)) fns)))
+     env)
+    fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-symbol-macros ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-variables
+     (lambda (symbol type rest)
+       (when (eq type :symbol-macro)
+         (push (cons symbol (car rest)) fns)))
+     env)
+    fns))
+
+
+;; These functions are a half-assed implementation of section 8.5 in CLtL2
+;; (environment manipulation)
+;; I really don't feel like implementing THAT interface for every supported
+;; Lisp.
+
+(defgeneric augment-with-variable (env var))
+
+(defgeneric augment-with-function (env fun))
+
+(defgeneric augment-with-macro (env mac def))
+
+(defgeneric augment-with-symbol-macro (env symmac def))
+
+(defmethod augment-with-variable ((env t) var)
+  (declare (ignore var))
+  env)
+
+(defmethod augment-with-function ((env t) fun)
+  (declare (ignore fun))
+  env)
+
+(defmethod augment-with-macro ((env t) mac def)
+  (declare (ignore mac def))
+  env)
+
+(defmethod augment-with-symbol-macro ((env t) symmac def)
+  (declare (ignore symmac def))
+  env)
+
+#+sbcl
+(defmethod augment-with-variable ((env sb-kernel:lexenv) var)
+  (sb-c::make-lexenv :default env :vars (list (cons var t))))
+
+#+sbcl
+(defmethod augment-with-function ((env sb-kernel:lexenv) fun)
+  (sb-c::make-lexenv :default env :funs (list (cons fun t))))
+
+#+sbcl
+(defmethod augment-with-macro ((env sb-kernel:lexenv) mac def)
+  (sb-c::make-lexenv :default env :funs (list (list* mac 'sb-sys::macro def))))
+
+#+sbcl
+(defmethod augment-with-symbol-macro ((env sb-kernel:lexenv) symmac def)
+  (sb-c::make-lexenv :default env :vars (list (list* symmac 'sb-sys::macro def))))
+
+#+cmu
+(defmethod augment-with-variable ((env c::lexenv) var)
+  (c::make-lexenv :default env 
+		  :variables (list (cons var (c::make-lambda-var :name var)))))
+
+#+cmu
+(defmethod augment-with-function ((env c::lexenv) fun)
+  (c::make-lexenv :default env 
+		  :functions (list (cons fun (lambda () 42)))))
+
+#+cmu
+(defmethod augment-with-macro ((env c::lexenv) mac def)
+  (c::make-lexenv :default env 
+		  :functions (list (list* mac 'system::macro def))))
+
+#+cmu
+(defmethod augment-with-symbol-macro ((env c::lexenv) symmac def)
+  (c::make-lexenv :default env 
+		  :variables (list (list* symmac 'system::macro def))))
+
+
+#+clisp
+(defun augment-with-var-and-fun (env &key var fun)
+  (let* ((old-vars (aref env 0))
+	 (old-funs (aref env 1))
+	 (new-vars (if (eq var nil)
+		       (make-array '(1) :initial-contents (list old-vars))
+		       (make-array '(3) :initial-contents (list (car var) (cdr var) old-vars))))
+	 (new-funs (if (eq fun nil)
+		       (make-array '(1) :initial-contents (list old-funs))
+		       (make-array '(3) :initial-contents (list (car fun) (cdr fun) old-funs)))))
+    (make-array '(2) :initial-contents (list new-vars new-funs))))
+
+;; I don't know whether t is an acceptable value to store here,
+;; but CLISP does not complain.
+#+clisp
+(defmethod augment-with-variable ((env vector) var)
+  (augment-with-var-and-fun env :var (cons var t)))
+
+#+clisp
+(defmethod augment-with-function ((env vector) fun)
+  (augment-with-var-and-fun env :fun (cons fun t)))
+
+#+clisp
+(defmethod augment-with-macro ((env vector) mac def)
+  (augment-with-var-and-fun env :fun (cons mac (system::make-macro def))))
+
+#+clisp
+(defmethod augment-with-symbol-macro ((env vector) symmac def)
+  (augment-with-var-and-fun env :var
+			    (cons symmac 
+				  (system::make-symbol-macro def))))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-variable ((env lexical::environment) var)
+  (harlequin-common-lisp:augment-environment
+   env :variable (list var)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-function ((env lexical::environment) fun)
+  (harlequin-common-lisp:augment-environment
+   env :function (list fun)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-macro ((env lexical::environment) mac def)
+  (harlequin-common-lisp:augment-environment
+   env :macro (list (list mac def))))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-symbol-macro ((env lexical::environment) symmac def)
+  (harlequin-common-lisp:augment-environment
+   env :symbol-macro (list (list symmac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-variable ((env sys::augmentable-environment) var)
+  (system:augment-environment env :variable (list var)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-function ((env sys::augmentable-environment) fun)
+  (system:augment-environment env :function (list fun)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-macro ((env sys::augmentable-environment) mac def)
+  (system:augment-environment env :macro (list (list mac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-symbol-macro ((env sys::augmentable-environment) symmac def)
+  (system:augment-environment env :symbol-macro (list (list symmac def))))
+
+
+(defun macroexpand-all (form &optional env)
+  (unwalk-form (walk-form form nil (make-walk-env env))))
+
+;; Sort of parse-macro from CLtL2.
+
+(defun parse-macro-definition (name lambda-list body env)
+  (declare (ignore name))
+  (let* ((environment-var nil) 
+	 (lambda-list-without-environment
+	  (loop 
+	   for prev = nil then i
+	   for i in lambda-list
+	   if (not (or (eq '&environment i) (eq '&environment prev)))
+	   collect i
+	   if (eq '&environment prev)
+	   do (if (eq environment-var nil)
+		  (setq environment-var i)
+		  (error "Multiple &ENVIRONMENT clauses in macro lambda list: ~S" lambda-list))))
+	 (handler-env (if (eq environment-var nil) (gensym "ENV-") environment-var))
+	 whole-list lambda-list-without-whole)
+    (if (eq '&whole (car lambda-list-without-environment))
+	(setq whole-list (list '&whole (second lambda-list-without-environment))
+	      lambda-list-without-whole (cddr lambda-list-without-environment))
+	(setq whole-list '()
+	      lambda-list-without-whole lambda-list-without-environment))
+    (eval
+     (with-unique-names (handler-args form-name)
+       `(lambda (,handler-args ,handler-env)
+          ,@(if (eq environment-var nil) 
+              `((declare (ignore ,handler-env)))
+              nil)
+          (destructuring-bind (, at whole-list ,form-name , at lambda-list-without-whole)
+              ,handler-args
+            (declare (ignore ,form-name))
+            ,@(mapcar (lambda (form) (macroexpand-all form env)) body)))))))
hunk ./src/lexenv.lisp 559
+    
hunk ./src/sharpl-reader.lisp 12
+(defmacro sharpl-expander (body min-args &environment env)
+  (let* ((form body)
+         (lambda-args (loop
+                         for i upfrom 1 upto (max (or min-args 0)
+                                                  (highest-bang-var form env))
+                         collect (make-sharpl-arg i))))
+    `(lambda ,lambda-args
+       , (when lambda-args
+           `(declare (ignorable , at lambda-args)))
+       ,form)))
+
hunk ./src/sharpl-reader.lisp 29
-varibales named !1, !2, !3, !n etc. these are bound to the Nth
+variables named !1, !2, !3, !n etc. these are bound to the Nth
hunk ./src/sharpl-reader.lisp 50
-#2L(foo !1) ==> (lambda (!1 !2) (declare (ignore !2)) (foo !1))"
+#2L(foo !1) ==> (lambda (!1 !2) (declare (ignore !2)) (foo !1))
+
+When #l forms are nested, !X variables are bound to the innermost 
+form. Example:
+
+#l#l(+ !1 !2)
+
+returns a function that takes no arguments and returns a function
+that adds its two arguments."
hunk ./src/sharpl-reader.lisp 60
-  (let* ((form (read stream t nil t))
-         (lambda-args (loop
-                         for i upfrom 1 upto (max (or min-args 0)
-                                                  (highest-bang-var form))
-                         collect (make-sharpl-arg i))))
-    `(lambda ,lambda-args
-       , (when lambda-args
-           `(declare (ignorable , at lambda-args)))
-       ,form)))
+  (let ((body (read stream t nil t)))
+    `(sharpl-expander ,body ,min-args)))
hunk ./src/sharpl-reader.lisp 69
-(defun highest-bang-var (form)
-  (acond
-   ((consp form) (max (highest-bang-var (car form))
-                      (highest-bang-var (cdr form))))
-   ((bang-var-p form) it)
-   (t 0)))
+(defun find-var-references (input-form)
+  (typecase input-form
+    (cons 
+      (append (find-var-references (car input-form))
+	      (find-var-references (cdr input-form))))
+
+    (arnesi:free-variable-reference (list (slot-value input-form 'arnesi:name)))
+    (arnesi:local-lexical-variable-reference (list (slot-value input-form 'arnesi:name)))
+      
+    (arnesi:form
+     (loop for slot-name in (mapcar #'it.bese.arnesi.mopp:slot-definition-name 
+				    (it.bese.arnesi.mopp::class-slots (class-of input-form)))
+	   if (not (member slot-name '(parent target-progn enclosing-tagbody target-block)))
+	   append (find-var-references (slot-value input-form slot-name))))
+
+    (t nil)))
+
+(defun highest-bang-var (form env)
+  (let ((*warn-undefined* nil))
+    (declare (special *warn-undefined*))
+    (or
+     (loop for var in (find-var-references (walk-form form nil (make-walk-env env)))
+	   if (bang-var-p var)
+	   maximize (bang-var-p var))
+     0)))
hunk ./src/sharpl-reader.lisp 96
-  (and (symbolp form)
-       (char= #\! (aref (symbol-name form) 0))
+  (and (char= #\! (aref (symbol-name form) 0))
hunk ./src/walk.lisp 23
-	(extend walk-env :lexical-flet fun t)))
-    walk-env))
+	(extend walk-env :lexical-flet fun t))
+      (dolist (mac (lexical-macros lexical-env))
+	(extend walk-env :macrolet (car mac) (cdr mac)))
+      (dolist (symmac (lexical-symbol-macros lexical-env))
+	(extend walk-env :symbol-macrolet (car symmac) (cdr symmac))))
+    (cons walk-env lexical-env)))
+
+(defun register-walk-env (env type name datum &rest other-datum)
+  (let ((walk-env (register (car env) type name datum))
+	(lexenv (case type
+		  (:let (augment-with-variable (cdr env) name))
+		  (:macrolet (augment-with-macro (cdr env) name datum))
+		  (:flet (augment-with-function (cdr env) name))
+		  (:symbol-macrolet (augment-with-symbol-macro (cdr env) name datum))
+		  ;;TODO: :declare
+		  (t (cdr env)))))
+    (cons walk-env lexenv)))
+
+(defmacro extend-walk-env (env type name datum &rest other-datum)
+  `(setf ,env (register-walk-env ,env ,type ,name ,datum , at other-datum)))
+
+(defun lookup-walk-env (env type name &key (error-p nil) (default-value nil))
+  (lookup (car env) type name :error-p error-p :default-value default-value))
hunk ./src/walk.lisp 230
-                      (extend environment :declare , at datum))))
+                      (extend-walk-env environment :declare , at datum))))
hunk ./src/walk.lisp 318
-  lexical envorinment outside of the form passed to walk-form."))
+  lexical environment outside of the form passed to walk-form."))
hunk ./src/walk.lisp 329
-    ((lookup env :let form)
+    ((lookup-walk-env env :let form)
hunk ./src/walk.lisp 332
-    ((lookup env :lexical-let form)
+    ((lookup-walk-env env :lexical-let form)
hunk ./src/walk.lisp 335
-    ((lookup env :symbol-macrolet form)
-     (walk-form (lookup env :symbol-macrolet form) parent env))
+    ((lookup-walk-env env :symbol-macrolet form)
+     (walk-form (lookup-walk-env env :symbol-macrolet form) parent env))
hunk ./src/walk.lisp 377
-      (when (lookup env :macrolet op)
-        (return (walk-form (apply (lookup env :macrolet op) args) parent env)))
+      (when (lookup-walk-env env :macrolet op)
+        (return (walk-form (funcall (lookup-walk-env env :macrolet op) form (cdr env)) parent env)))
hunk ./src/walk.lisp 381
-	    (macroexpand-1 form nil)
+	    (macroexpand-1 form (cdr env))
hunk ./src/walk.lisp 384
-      (let ((app (if (lookup env :flet op)
-                     (make-instance 'local-application-form :code (lookup env :flet op))
-                     (if (lookup env :lexical-flet op)
+      (let ((app (if (lookup-walk-env env :flet op)
+                     (make-instance 'local-application-form :code (lookup-walk-env env :flet op))
+                     (if (lookup-walk-env env :lexical-flet op)
hunk ./src/walk.lisp 428
-      (make-instance (if (lookup env :flet (second form))
+      (make-instance (if (lookup-walk-env env :flet (second form))
hunk ./src/walk.lisp 430
-                         (if (lookup env :lexical-flet (second form))
+                         (if (lookup-walk-env env :lexical-flet (second form))
hunk ./src/walk.lisp 449
-(defun walk-lambda-list (lambda-list parent env &key allow-specializers)
+(defun walk-lambda-list (lambda-list parent env &key allow-specializers macro-p)
hunk ./src/walk.lisp 452
-             (extend env :let (name argument) argument))))
+             (extend-walk-env env :let (name argument) argument))))
hunk ./src/walk.lisp 580
-                                             (register env :block block-name block))))))
+                                             (register-walk-env env :block block-name block))))))
hunk ./src/walk.lisp 590
-    (if (lookup env :block block-name)
+    (if (lookup-walk-env env :block block-name)
hunk ./src/walk.lisp 592
-                           :target-block (lookup env :block block-name))
+                           :target-block (lookup-walk-env env :block block-name))
hunk ./src/walk.lisp 598
-            (walk-form form parent (register env :block block-name :unknown-block)))))))
+            (walk-form form parent (register-walk-env env :block block-name :unknown-block)))))))
hunk ./src/walk.lisp 675
-						  do (extend env :flet name lambda)
+						  do (extend-walk-env env :flet name lambda)
hunk ./src/walk.lisp 695
-         do (extend env :flet name lambda))
+         do (extend-walk-env env :flet name lambda))
hunk ./src/walk.lisp 731
-            (extend env :let var :dummy)))
+            (extend-walk-env env :let var :dummy)))
hunk ./src/walk.lisp 742
-      (extend env :let var :dummy))
+      (extend-walk-env env :let var :dummy))
hunk ./src/walk.lisp 776
-      (let ((handler (eval
-                      ;; NB: macrolet arguments are a
-                      ;; destructuring-bind list, not a lambda list
-                      (with-unique-names (handler-args)
-                        `(lambda (&rest ,handler-args)
-                           (destructuring-bind ,args
-                               ,handler-args
-                             , at body))))))
-        (extend env :macrolet name handler)
+      (let ((handler (parse-macro-definition name args body (cdr env))))
+        (extend-walk-env env :macrolet name handler)
hunk ./src/walk.lisp 847
-       if (lookup env :symbol-macrolet name)
-         do (push `(setf ,(lookup env :symbol-macrolet name) ,value) effective-code)
+       if (lookup-walk-env env :symbol-macrolet name)
+         do (push `(setf ,(lookup-walk-env env :symbol-macrolet name) ,value) effective-code)
hunk ./src/walk.lisp 873
-      (extend env :symbol-macrolet symbol expansion)
+      (extend-walk-env env :symbol-macrolet symbol expansion)
hunk ./src/walk.lisp 893
-    (extend env :tagbody 'enclosing-tagbody tagbody)
+    (extend-walk-env env :tagbody 'enclosing-tagbody tagbody)
hunk ./src/walk.lisp 902
-           do (extend env :tag (car part) (cdr part)))
+           do (extend-walk-env env :tag (car part) (cdr part)))
hunk ./src/walk.lisp 922
-                 :target-progn (lookup env :tag (second form))
-                 :enclosing-tagbody (lookup env :tagbody 'enclosing-tagbody)))
+                 :target-progn (lookup-walk-env env :tag (second form))
+                 :enclosing-tagbody (lookup-walk-env env :tagbody 'enclosing-tagbody)))
addfile ./t/sharpl.lisp
hunk ./t/sharpl.lisp 1
+(in-package :it.bese.arnesi.test)
+
+(def-suite :it.bese.arnesi.sharpl :in :it.bese.arnesi)
+
+(in-suite :it.bese.arnesi.sharpl)
+
+(eval-when (:compile-toplevel :execute)
+  (enable-sharp-l))
+
+(test sharpl-simple
+  (is (eql 42 (funcall (arnesi::sharpl-expander 42 0)))))
+
+(test sharpl-mb-example
+  (is (eql 6 (funcall (arnesi::sharpl-expander (block !2 (return-from !2 !1)) 0) 6))))
+
+(test sharpl-finds-variables
+  (is (eql 111 (funcall (arnesi::sharpl-expander (+ !1 !2) 0) 42 69))))
+
+(test sharpl-no-variable-in-quote
+  (is (eq (funcall (arnesi::sharpl-expander '!1 0)) '!1)))
+
+(test sharpl-not-captures-outer-bang
+  (let ((!1 42))
+    (declare (ignore !1))
+    (is (eql 69 (funcall (arnesi::sharpl-expander !1 0) 69)))))
+
+(test sharpl-nested-simple
+  (is (eql 1 (funcall (funcall (arnesi::sharpl-expander (arnesi::sharpl-expander 1 0) 0))))))
+
+(test sharpl-nested-arg
+  (is (eql 42 (funcall (funcall (arnesi::sharpl-expander (arnesi::sharpl-expander !1 0) 0)) 42))))
+
+(test sharpl-nested-complex
+  (is (eql 3 (funcall 
+	      (funcall (arnesi::sharpl-expander (let ((a !1)) 
+			   (arnesi::sharpl-expander (+ !1 a) 0)) 0)
+		       1)
+	      2))))
+
+(test sharpl-symbol-macrolet-1
+  (is (eql 3 (symbol-macrolet ((sym !1)) (funcall (arnesi::sharpl-expander sym 0) 3)))))
+
+(test sharpl-symbol-macrolet-2
+  (is (eql 3 (funcall (symbol-macrolet ((sym !1)) (arnesi::sharpl-expander sym 0)) 3 ))))
+
+(test sharpl-macrolet-1
+  (is (eql 15 (macrolet ((mac (arg) `(+ !1 ,arg))) (funcall (arnesi::sharpl-expander (mac 10) 0) 5)))))
+
+(test sharpl-macrolet-2
+  (is (eql 15 (funcall (macrolet ((mac (arg) `(+ !1 ,arg))) (arnesi::sharpl-expander (mac 10) 0)) 5))))
+
+(test sharpl-inner-macrolet
+  (is (eql 15 (funcall 
+	       (arnesi::sharpl-expander 
+		(macrolet ((!2 () '!1)) (!2))
+		0)
+	       15))))
+
+(test sharpl-inner-symbol-macrolet
+  (is (eql 15 (funcall 
+	       (arnesi::sharpl-expander 
+		(symbol-macrolet ((!2 !1)) (+ !2 10))
+		0)
+	       5))))
+
+(test sharpl-bang-binds-to-innermost
+  (is (eql 10 (funcall 
+	       (funcall (arnesi::sharpl-expander
+			 (let ((a !1))
+			   (arnesi::sharpl-expander (+ a !1) 0)) 0)
+			6)
+	       4))))
+
+(test sharpl-interposed-macrolet
+  (is (eql 6 (funcall
+              (funcall (arnesi::sharpl-expander
+                        (macrolet ((mac () '!1))
+                          (arnesi::sharpl-expander (mac) 0))
+                        0))
+              6))))
+
+(test sharpl-nested-macrolet
+  (is (eql 21 (funcall
+               (funcall
+                (arnesi::sharpl-expander
+                 (macrolet ((return-bang () ''!1))
+                   (macrolet ((multiply-first-bang (arg) `(* ,arg ,(return-bang))))
+                     (arnesi::sharpl-expander (+ (multiply-first-bang 2) 1) 0)))
+                 0))
+               10))))
+                          
+(test sharpl-interposed-symbol-macrolet
+  (is (eql 'result (funcall
+              (funcall (arnesi::sharpl-expander
+                        (symbol-macrolet ((mac !1))
+                          (arnesi::sharpl-expander mac 0))
+                        0))
+              'result))))
+  
}

Context:

[Specialize slime inspection of log categories, added [set level] action with predefined minibuffer history
attila.lendvai at gmail.com**20061225160657] 
[Added swank inspector dwim lookup hook for logger stuff (e.g. 'log or 'log.debug)
attila.lendvai at gmail.com**20061224130840] 
[Small fix for the slime-repl-log-appender
attila.lendvai at gmail.com**20061219171754] 
[Added slime-repl-log-appender that renders the args as inspectable presentations if :verbosity is > 1
attila.lendvai at gmail.com**20061219165118] 
[Added commented out eval based check for special-var-p
attila.lendvai at gmail.com**20061210193058
 
 This is the only way to check for a (defvar foo) where (boundp 'foo) is nil.
 Comment out for now, someone willing to take the responsibility should enable it... :)
] 
[Use eval-always in log.lisp
attila.lendvai at gmail.com**20061210193004] 
[Add inline annotations to %string-to-octets and friends, reorder definitions
attila.lendvai at gmail.com**20061210192956] 
[Clean up uri escaping to fix unicode text in ucw forms. Drop non-standard %u1234 unencoding.
attila.lendvai at gmail.com**20061210192813] 
[Added partial lispworks support for string encodings
attila.lendvai at gmail.com**20061206091936] 
[Bind *package* to the COMMON-LISP package instead of KEYWORD
attila.lendvai at gmail.com**20061105220327] 
[Set (FDEFINITION/CC NAME) on DEFGENERIC/CC; don't reDEFGENERIC/CC on DEFMETHOD/CC when GENERIC/CC already exists.
Maciek Pasternacki <maciekp at japhy.fnord.org>**20061204081042] 
[More detailed error reporting in unescape-as-uri
henrik at evahjelte.com**20061128101729
 Also a continue-as-is restart that allows parsing of invalid urls.
] 
[Do not export log.debug and friends
attila.lendvai at gmail.com**20061102143049
 
 to avoid mass confusion: two packages both using arnesi defining a logger called 'log.
] 
[Print debug messages with *package* = :keyword (to fully qualify every symbol printed)
attila.lendvai at gmail.com**20061102142939] 
[pushnew instead of push for *features*
attila.lendvai at gmail.com**20061018103629] 
[Added remove-keywords defun and implement remf-keywords as a define-modify-macro
attila.lendvai at gmail.com**20061017154226] 
[Missing pieces for my last two patches (damn)
attila.lendvai at gmail.com**20061017152503] 
[Added :at-redefinition to deflookup-table, default is :warn otherwise it can be nil or a code form
attila.lendvai at gmail.com**20061015131703] 
[Added a warning to deflogger at macroexpand time to warn when defining a logger whose name is from a foreign package
attila.lendvai at gmail.com**20061015131548] 
[src/posixenv.lisp: drop Time-stamp line
Luca Capello <luca at pca.it>**20060918120805] 
[Added with-logging-io to rebind some *io* vars while inside the logging code
attila.lendvai at gmail.com**20060911105133] 
[Various small patches by Chris Dean
attila.lendvai at gmail.com**20060909095845
 
 - A compatibility change to QUIT for LispWorks
 - A case-insensitive version of HTML-ENTITIES
 - A new function HTML-ENTITY->CHAR
 - A LispWorks fix for RADIX-VALUES
 - Small fix to HEAD
] 
[Drop accidental debug printf's
attila.lendvai at gmail.com**20060905132115] 
[Workaround for clisp adjust-array bug
attila.lendvai at gmail.com**20060905112932
 
 (adjust-array x 0) is legal according to CLHS, but clisp yells.
 so added an early-return for "" input.
] 
[Fix the reader test
attila.lendvai at gmail.com**20060902115131] 
[Optimized write-as-uri
attila.lendvai at gmail.com**20060831161612] 
[Fix unescape-as-uri and optimize it while we are at it
attila.lendvai at gmail.com**20060831153343] 
[Allegro environment walk fix.
Maciek Pasternacki <maciekp at japhy.fnord.org>**20060830093122] 
[TAG 2006-08-16
attila.lendvai at gmail.com**20060816211128] 
Patch bundle hash:
a2a575ad6e1b4837f993b34ba4e0e8239ca84d7c


More information about the bese-devel mailing list