Changeset 3483


Ignore:
Timestamp:
08/24/03 16:43:53 (19 years ago)
Author:
piso
Message:

GET-SETF-EXPANSION
ROTATEF

File:
1 edited

Legend:

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

    r3399 r3483  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: setf.lisp,v 1.19 2003-08-15 14:30:02 piso Exp $
     4;;; $Id: setf.lisp,v 1.20 2003-08-24 16:43:53 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
    20 (in-package "COMMON-LISP")
    21 
    22 (export '(setf incf decf fdefinition defsetf))
     20(in-package "SYSTEM")
     21
     22(defconstant *setf-expander* (make-symbol "SETF-EXPANDER"))
     23
     24(defun get-setf-expansion (form &optional environment)
     25  (cond ((symbolp form)
     26         (let ((new-var (gensym)))
     27           (values nil nil (list new-var)
     28                   `(setq ,form ,new-var) form)))
     29  ((get (car form) *setf-expander*)
     30   (let ((vars (mapcar #'(lambda (x) (gensym)) (cdr form)))
     31         (store (gensym)))
     32     (values vars
     33                   (cdr form)
     34                   (list store)
     35                   `(,(get (car form) *setf-expander*)
     36                      ,@vars ,store)
     37       (cons (car form) vars))))
     38        (t
     39         (error "no SETF expansion for ~S" form))))
     40
     41
     42;;; ROTATEF (from GCL)
     43(defmacro rotatef (&rest rest )
     44  (do ((r rest (cdr r))
     45       (pairs nil)
     46       (stores nil)
     47       (store-forms nil)
     48       (access-forms nil))
     49      ((endp r)
     50       (setq stores (nreverse stores))
     51       (setq store-forms (nreverse store-forms))
     52       (setq access-forms (nreverse access-forms))
     53       `(let* ,(nconc pairs
     54          (mapcar #'list stores (cdr access-forms))
     55          (list (list (car (last stores)) (car access-forms))))
     56          ,@store-forms
     57          nil))
     58    (multiple-value-bind (vars vals stores1 store-form access-form)
     59      (get-setf-expansion (car r))
     60      (setq pairs (nconc pairs (mapcar #'list vars vals)))
     61      (setq stores (cons (car stores1) stores))
     62      (setq store-forms (cons store-form store-forms))
     63      (setq access-forms (cons access-form access-forms)))))
     64
    2365
    2466(defmacro setf (&rest args)
     
    83125      (replace sequence v :start1 start :end1 end)
    84126      v)))
    85 
    86 (defconstant *setf-expander* (make-symbol "SETF-EXPANDER"))
    87127
    88128(defmacro defsetf (access-function update-function)
Note: See TracChangeset for help on using the changeset viewer.