Changeset 4440

Timestamp:

10/17/03 19:10:19 (18 years ago)

Author:

piso

Message:

GET-SETF-METHOD-INVERSE

File:

• trunk/j/src/org/armedbear/lisp/setf.lisp (modified) (8 diffs)

trunk/j/src/org/armedbear/lisp/setf.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: setf.lisp,v 1.34 2003-10-06 00:26:24 piso Exp $
+;;; $Id: setf.lisp,v 1.35 2003-10-17 19:10:19 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -22 +22 @@
 (defun get-setf-method-inverse (form inverse setf-function)
   (let ((new-var (gensym))
-  (vars nil)
-  (vals nil))
+        (vars nil)
+        (vals nil))
     (dolist (x (cdr form))
       (push (gensym) vars)
@@ -29 +29 @@
     (setq vals (nreverse vals))
     (values vars vals (list new-var)
-      (if setf-function
-    `(,@inverse ,new-var ,@vars)
-    `(,@inverse ,@vars ,new-var))
-      `(,(car form) ,@vars))))
+            (if setf-function
+                `(,@inverse ,new-var ,@vars)
+                (if (functionp (car inverse))
+                    `(funcall ,@inverse ,@vars ,new-var)
+                    `(,@inverse ,@vars ,new-var)))
+            `(,(car form) ,@vars))))
 
 ;;; If a macro, expand one level and try again.  If not, go for the
@@ -41 +43 @@
     (macroexpand-1 form environment)
     (if expanded
-  (get-setf-expansion expansion environment)
-  (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
-         t))))
+        (get-setf-expansion expansion environment)
+        (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
+                                 t))))
 
 (defun get-setf-expansion (form &optional environment)
@@ -51 +53 @@
              (values nil nil (list new-var)
                      `(setq ,form ,new-var) form)))
-    ((setq temp (get (car form) 'setf-inverse))
-     (get-setf-method-inverse form `(,temp) nil))
+          ((setq temp (get (car form) 'setf-inverse))
+           (get-setf-method-inverse form `(,temp) nil))
           ((setq temp (get (car form) 'setf-expander))
            (funcall temp form environment))
-    (t
-     (expand-or-get-setf-inverse form environment)))))
+          (t
+           (expand-or-get-setf-inverse form environment)))))
 
 ;;; ROTATEF (from GCL)
@@ -70 +72 @@
        (setq access-forms (nreverse access-forms))
        `(let* ,(nconc pairs
-          (mapcar #'list stores (cdr access-forms))
-          (list (list (car (last stores)) (car access-forms))))
+                      (mapcar #'list stores (cdr access-forms))
+                      (list (list (car (last stores)) (car access-forms))))
           ,@store-forms
           nil))
@@ -97 +99 @@
                         `(funcall ,inverse ,@(cdr place) ,value-form)
                         `(,inverse ,@(cdr place) ,value-form))
-        `(let* (,@(mapcar #'list dummies vals))
-           (multiple-value-bind ,newval ,value-form
-       ,setter))))))))
+                    `(let* (,@(mapcar #'list dummies vals))
+                       (multiple-value-bind ,newval ,value-form
+                         ,setter))))))))
      ((oddp count)
       (error "odd number of args to SETF"))
@@ -105 +107 @@
       (do ((a args (cddr a)) (l nil))
           ((null a) `(progn ,@(nreverse l)))
-  (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
+        (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
 
 ;;; Redefined in define-modify-macro.lisp.