diff options
Diffstat (limited to 'derrida.lisp')
-rw-r--r-- | derrida.lisp | 156 |
1 files changed, 85 insertions, 71 deletions
diff --git a/derrida.lisp b/derrida.lisp index b0a1cc0..6c4a3f7 100644 --- a/derrida.lisp +++ b/derrida.lisp @@ -1,8 +1,7 @@ ;;;; derrida.lisp -(in-package #:derrida) - +(in-package #:derrida) (defmacro with-alist ((&optional (accessor 'cdr)) (&rest bindings) alist &body body) "Bind variables to accessors into ALISTS. ACCESSOR, which should be @@ -64,7 +63,7 @@ EXAMPLE: (let ((pl (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum))) - (hq:with-plist (name (age :age) (job :|currentJob|)) pl + (with-plist (name (age :age) (job :|currentJob|)) pl (setf age (1+ age)) (format t \"~a the ~a had a birthday, and is now ~a years old~%\" name job age) @@ -88,77 +87,92 @@ And would return `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body)))) -(defmacro getf-path (place &rest indicators) +(defmacro define-deep-place-accessor (name nester &optional docstring) + "An internal helper macro. It defines a macro named NAME. NESTER +should be a function passed to REDUCE. Its purpose is to construct +nested access. See applications of DEFINE-DEEP-PLACE-ACCESSOR for examples." + `(defmacro ,name (place &rest indicators) + ,docstring + (if (null indicators) place + (reduce ,nester indicators :initial-value place)))) + +(defmacro define-with-deep-access (name accessor-macro &optional docstring) + "An internal helper macro for defining forms that behave like +WITH-SLOTS. NAME, a symbol, is the name of the macro being +defined. ACCESSOR-MACRO should be a symbol naming a macro defined with +DEFINE-DEEP-PLACE-ACCESSOR. See applications of this form for examples." + `(defmacro ,name (binding-paths place-form &body body) + ,docstring + (let ((tmp-place (gensym "place"))) + `(let ((,tmp-place ,place-form)) + (symbol-macrolet + ,(loop :for (var . path) :in binding-paths + :collect + (list var (list* ',accessor-macro tmp-place path))) + ,@body))))) + +(define-deep-place-accessor + gethash-path + (lambda (nested key) `(gethash ,key ,nested)) + "(GETHASH-PATH HASH K1 ... KN) expends into (GETHASH ( ... (GETHASH K1 PLACE) ...) KN).") + +(define-deep-place-accessor + slot-value-path + (lambda (nested slot) `(slot-value ,nested ,slot)) + "(SLOT-VALUE-PATH PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN). It gives you a SETFable in a nested tree of class instances.") + +(define-deep-place-accessor + getf-path + (lambda (nested key) `(getf ,nested ,key)) "(GETF-PATH PLACE K1 ... KN) expands to (GETF (... (GETF PLACE K1) ...) KN) E.g > (let ((pl '(:x (:a 10 :b 20) :y (:c 30)))) (incf (getf-path pl :x :b)) pl) - (:X (:A 10 :B 21) :Y (:C 30))" - (if - (null indicators) place - (reduce (lambda (nested key) `(getf ,nested ,key)) - indicators - :initial-value place))) - - -(defmacro with-keypaths (keypaths plist &body body) - "Bind SETFable places to locations in a nested PLIST and evaluate BODY. - -E.g. - > (defvar *pl* '(:x (:a 10 :b 20) :y (:c 30))) - *PL* - > (with-keypaths - ((b :x :b) - (c :y :c) - (d :y :d)) - (incf b) - (setf c (* c b)) - (setf d :HELLO)) - :HELLO - > *pl* - (:X (:A 10 :B 21) :Y (:D :HELLO :C 630)) -" - (let ((tmp-plist (gensym "plist"))) - `(let ((,tmp-plist ,plist)) - (symbol-macrolet - ,(loop :for (var . path) :in keypaths - :collect `(,var (getf-path ,tmp-plist ,@path))) - ,@body)))) - -(defmacro slot-path-value (place &rest slots) - "(SLOT-PATH-VALUE PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN). It gives you a SETFable in a nested tree of class instances." - (if (null slots) place - (reduce (lambda (nested slot) `(slot-value ,nested ,slot)) - slots - :initial-value place))) - -(defmacro with-slot-paths (slotpaths root &body body) -" Bind SETFable places to locations in a nested tree of CLOS instances and evaluate BODY. - - > (defclass moo () - ((x :initform 10))) - #<STANDARD-CLASS DERRIDA::MOO> - > (defclass zoo () - ((a-moo :initform (make-instance 'moo)))) - #<STANDARD-CLASS DERRIDA::ZOO> - > (defvar *z* (make-instance 'zoo)) - *Z* - > (with-slot-paths - ((x 'a-moo 'x)) *z* - (setf x (+ x 20))) - 30 - > (describe (slot-value *z* 'a-moo)) - #<MOO {100AEB1293}> - [standard-object] - - Slots with :INSTANCE allocation: - X = 30 -" - (let ((tmp-root (gensym "root"))) - `(let ((,tmp-root ,root)) - (symbol-macrolet - ,(loop :for (var . path) :in slotpaths - :collect `(,var (slot-path-value ,tmp-root ,@path))) - ,@body)))) + (:X (:A 10 :B 21) :Y (:C 30))") + +(define-with-deep-access with-keypaths getf-path + "PLACE should evaluate to a PLIST. WITH-KEPATHS evaluates BODY in the +context of context established by BINDING-PATHS. + +Example: + +> (defvar *pl* '(:x (:a 10) :y (:b 20)) +> (with-keypaths ((a :x :a) + (b :y :b) + (d :y :d)) *pl* + (incf a) + (setf d (* a b))) +220 +> *pl* +(:X (:A 11) :Y (:D 220 :B 20))") + +(define-with-deep-access with-slot-paths slot-value-path + "PLACE should evaluate to an instance of a CLOS class or a struct. WITH-SLOT-PATHS evaluates BODY in the context established by BINDING-PATHS. + +Example: + +> (defclass point () ((x :initform 0) (y :initform 0))) +#<STANDARD-CLASS DERRIDA::POINT> +> (defclass in-space () + ((location :initform (make-instance 'point)))) +#<STANDARD-CLASS DERRIDA::IN-SPACE> +> (defvar *thing* (make-instance 'in-space)) +*THING* +> (with-slot-paths + ((x 'location 'x) + (y 'location 'y)) *thing* + (setf x 10 + y -30)) + +-30 +> (describe (slot-value *thing* 'location)) +#<POINT {100781DB53}> + [standard-object] + +Slots with :INSTANCE allocation: + X = 10 + Y = -30") + +(define-with-deep-access with-hash-paths gethash-path) |