Changeset 4440


Ignore:
Timestamp:
10/17/03 19:10:19 (19 years ago)
Author:
piso
Message:

GET-SETF-METHOD-INVERSE

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/setf.lisp

    r4209 r4440  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: setf.lisp,v 1.34 2003-10-06 00:26:24 piso Exp $
     4;;; $Id: setf.lisp,v 1.35 2003-10-17 19:10:19 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2222(defun get-setf-method-inverse (form inverse setf-function)
    2323  (let ((new-var (gensym))
    24   (vars nil)
    25   (vals nil))
     24        (vars nil)
     25        (vals nil))
    2626    (dolist (x (cdr form))
    2727      (push (gensym) vars)
     
    2929    (setq vals (nreverse vals))
    3030    (values vars vals (list new-var)
    31       (if setf-function
    32     `(,@inverse ,new-var ,@vars)
    33     `(,@inverse ,@vars ,new-var))
    34       `(,(car form) ,@vars))))
     31            (if setf-function
     32                `(,@inverse ,new-var ,@vars)
     33                (if (functionp (car inverse))
     34                    `(funcall ,@inverse ,@vars ,new-var)
     35                    `(,@inverse ,@vars ,new-var)))
     36            `(,(car form) ,@vars))))
    3537
    3638;;; If a macro, expand one level and try again.  If not, go for the
     
    4143    (macroexpand-1 form environment)
    4244    (if expanded
    43   (get-setf-expansion expansion environment)
    44   (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
    45         t))))
     45        (get-setf-expansion expansion environment)
     46        (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
     47                                t))))
    4648
    4749(defun get-setf-expansion (form &optional environment)
     
    5153             (values nil nil (list new-var)
    5254                     `(setq ,form ,new-var) form)))
    53     ((setq temp (get (car form) 'setf-inverse))
    54      (get-setf-method-inverse form `(,temp) nil))
     55          ((setq temp (get (car form) 'setf-inverse))
     56           (get-setf-method-inverse form `(,temp) nil))
    5557          ((setq temp (get (car form) 'setf-expander))
    5658           (funcall temp form environment))
    57     (t
    58      (expand-or-get-setf-inverse form environment)))))
     59          (t
     60           (expand-or-get-setf-inverse form environment)))))
    5961
    6062;;; ROTATEF (from GCL)
     
    7072       (setq access-forms (nreverse access-forms))
    7173       `(let* ,(nconc pairs
    72           (mapcar #'list stores (cdr access-forms))
    73           (list (list (car (last stores)) (car access-forms))))
     74                      (mapcar #'list stores (cdr access-forms))
     75                      (list (list (car (last stores)) (car access-forms))))
    7476          ,@store-forms
    7577          nil))
     
    9799                        `(funcall ,inverse ,@(cdr place) ,value-form)
    98100                        `(,inverse ,@(cdr place) ,value-form))
    99         `(let* (,@(mapcar #'list dummies vals))
    100            (multiple-value-bind ,newval ,value-form
    101       ,setter))))))))
     101                    `(let* (,@(mapcar #'list dummies vals))
     102                       (multiple-value-bind ,newval ,value-form
     103                        ,setter))))))))
    102104     ((oddp count)
    103105      (error "odd number of args to SETF"))
     
    105107      (do ((a args (cddr a)) (l nil))
    106108          ((null a) `(progn ,@(nreverse l)))
    107   (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
     109        (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
    108110
    109111;;; Redefined in define-modify-macro.lisp.
Note: See TracChangeset for help on using the changeset viewer.