Browse files

Merge pull request #2 from kisp/master

modf patches
  • Loading branch information...
2 parents 8765829 + 173b1cc commit 0095cf3abe33d7e43782e77964ec671c1ec4ff6d smithzvk committed Aug 8, 2011
Showing with 22 additions and 15 deletions.
  1. +21 −15 modf.lisp
  2. +1 −0 test-setup.lisp
@@ -76,10 +76,11 @@ functional analog of #'\(SETF SYM)."
(defmacro define-modf-function (name nth-arg (new-val &rest args) &body body)
"Define a new modf function. It inverts NAME forms by modifying the NTH-ARG
term of the arguments of the place form in the MODF macro."
- (setf (gethash name *modf-nth-arg*)
- nth-arg )
- `(defun ,(intern (modf-name name) :modf) (,new-val ,@args)
- ,@body ))
+ `(progn
+ (setf (gethash ',name *modf-nth-arg*)
+ ,nth-arg )
+ (defun ,(intern (modf-name name) :modf) (,new-val ,@args)
+ ,@body )))
;; <<>>=
(defmacro define-modf-method (name nth-arg (new-val &rest args) &body body)
@@ -88,10 +89,11 @@ term of the arguments of the place form in the MODF macro. This method can
specialize on any of ARGS."
;; Side effect in a macro, I know. How can you do this via EVAL-WHEN if the
;; rest of the macro-expansion depends on the side effect.
- (setf (gethash name *modf-nth-arg*)
- nth-arg )
- `(defmethod ,(intern (modf-name name) :modf) (,new-val ,@args)
- ,@body ))
+ `(progn
+ (setf (gethash ',name *modf-nth-arg*)
+ ,nth-arg )
+ (defmethod ,(intern (modf-name name) :modf) (,new-val ,@args)
+ ,@body )))
;; @\section{The {\em modf} macro}
@@ -227,7 +229,8 @@ functions ahead of time."
;; We use eval here because this setf form is hard to invert. We could,
;; in principle, using GET-SETF-EXPANSION.
(eval `(setf (,func ,new-struct) ',new-val))
- new-struct ))))
+ new-struct ))
+ (t (error "How shall I invert ~S?" func))))
(defun late-class-reader-inverter (func new-val obj)
@@ -275,14 +278,17 @@ functions ahead of time."
new-instance ))
;; <<>>=
-(defun modf-expand (new-val expr enclosed-obj-sym)
+(defun modf-expand (new-val expr enclosed-obj-sym env)
(cond ((or (atom expr) (eql (car expr) 'modf-eval))
`(let ((,enclosed-obj-sym ,expr))
,new-val ))
+ ((macro-function (car expr) env)
+ (modf-expand new-val (funcall (macro-function (car expr) env) expr env)
+ enclosed-obj-sym env))
;; First, try rewrite rules
((gethash (car expr) *modf-rewrites*)
(modf-expand new-val (funcall (gethash (car expr) *modf-rewrites*) expr)
- enclosed-obj-sym ))
+ enclosed-obj-sym env))
;; Okay, we are going to call modf-expand
(t (let* ((obj-sym (gensym))
(new-val (if enclosed-obj-sym
@@ -326,10 +332,10 @@ functions ahead of time."
(container-arg-n expr)
expr obj-sym ))))))
(nth (container-arg-n expr) expr)
- obj-sym )))))
+ obj-sym env)))))
;; <<>>=
-(defmacro modf (place value &rest more)
+(defmacro modf (place value &rest more &environment env)
"Make a new object \(which may use some of the old object) such that PLACE
evaluates to VALUE.
@@ -343,9 +349,9 @@ used in the subsequence MODF-PLACE NEW-VALUE pairs until the end of the MODF
(if more
(destructuring-bind (next-symbol next-place next-value &rest next-more) more
- `(let ((,next-symbol ,(modf-expand value place nil)))
+ `(let ((,next-symbol ,(modf-expand value place nil env)))
(modf ,next-place ,next-value ,@next-more) ))
- (modf-expand value place nil) ))
+ (modf-expand value place nil env) ))
(defun find-container (place)
(cond ((atom place)
@@ -6,5 +6,6 @@
(in-package :modf-test)
(defclass test-parent () ((a :accessor a-of :initarg :a)))
+#+sbcl(closer-mop:finalize-inheritance (find-class 'test-parent))
(modf-def:defclass test-class1 (test-parent) ((b :accessor b-of :initarg :b)))
(defclass test-class2 (test-parent) ((c :accessor c-of :initarg :c)))

0 comments on commit 0095cf3

Please sign in to comment.