Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Added macro FSETF which acts like SETF except that functionally modif…

…ies the

object and sets the symbol to the new value (thus leaving old instances intact).
  • Loading branch information...
commit 665d3b4bd5a5f8babe440a6ccbe082cd17c69f39 1 parent 29229d1
authored June 30, 2011
22  modf-test.lisp
@@ -3,9 +3,25 @@
3 3
 
4 4
 (in-root-suite)
5 5
 
  6
+(deftest run-tests ()
  7
+  (modf-eval-test)
  8
+  (fsetf-tests)
  9
+  (test-lists)
  10
+  (test-arrays)
  11
+  (test-structs)
  12
+  (test-classes) )
  13
+
6 14
 (deftest modf-eval-test ()
7 15
   (is (equal '(1 t 3 4) (modf (second (modf-eval '(1 2 3 4))) t))) )
8 16
 
  17
+(deftest fsetf-tests ()
  18
+  (let ((ima '((1 2 3) (4 5 6) (7 8 9))))
  19
+    (fsetf (second ima) 'second)
  20
+    (fsetf (second (first ima)) 'first-second
  21
+           (third ima) 'third )
  22
+    (is (equal '((1 first-second 3) second third)
  23
+               ima )) ))
  24
+
9 25
 (defsuite* lisp-types)
10 26
 
11 27
 (deftest test-lists ()
@@ -101,9 +117,3 @@
101 117
     (is (eql 2 (test-struct1-b (modf (test-struct1-b s1) 2))))
102 118
     (is (eql -1 (test-struct2-c (modf (test-struct2-c s2) -1)))) ))
103 119
 
104  
-(deftest run-tests ()
105  
-  (modf-eval-test)
106  
-  (test-lists)
107  
-  (test-arrays)
108  
-  (test-structs)
109  
-  (test-classes) )
25  modf.lisp
@@ -259,6 +259,31 @@ form."
259 259
            (modf ,next-place ,next-value ,@next-more) ))
260 260
       (modf-expand value place (gensym)) ))
261 261
 
  262
+(defun find-container (place)
  263
+  (cond ((atom place)
  264
+         place )
  265
+        ((gethash (car place) *modf-rewrites*)
  266
+         (find-container (funcall (gethash (car place) *modf-rewrites*) place)) )
  267
+        ((not (expandable? place))
  268
+         (error "You can only use FSETF if you are modfifying a container.  I don't have a place to set when given ~A." place) )
  269
+        (t (let ((nth-arg (container-arg-n place)))
  270
+             (unless nth-arg
  271
+               (error "I can't figure out which argument is the container in ~A." place) )
  272
+             (find-container (nth nth-arg place)) ))))
  273
+
  274
+;; <<>>=
  275
+(defmacro fsetf (place value &rest more)
  276
+  ;; First we need to find the "container" variable
  277
+  (let ((container (find-container place)))
  278
+    (with-gensyms (val-sym)
  279
+      (if more
  280
+          `(let ((,val-sym ,value))
  281
+             (setf ,container (modf ,place ,val-sym))
  282
+             (fsetf ,@more) )
  283
+          `(let ((,val-sym ,value))
  284
+             (setf ,container (modf ,place ,val-sym))
  285
+             ,val-sym )))))
  286
+
262 287
 ;; <<>>=
263 288
 (defmacro modf-eval (&rest args)
264 289
   `(progn ,@args) )
1  package.lisp
@@ -5,6 +5,7 @@
5 5
   (:export #:modf
6 6
            #:modf-eval
7 7
            #:modf-fn
  8
+           #:fsetf
8 9
            #:define-modf-rewrite
9 10
            #:define-modf-function
10 11
            #:define-modf-method

0 notes on commit 665d3b4

Please sign in to comment.
Something went wrong with that request. Please try again.