[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