Changeset 4161


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

Work in progress.

File:
1 edited

Legend:

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

    r4159 r4161  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: setf.lisp,v 1.29 2003-10-01 14:29:36 piso Exp $
     4;;; $Id: setf.lisp,v 1.30 2003-10-01 17:45:35 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3434      `(,(car form) ,@vars))))
    3535
     36;;; If a macro, expand one level and try again.  If not, go for the
     37;;; SETF function.
     38(defun expand-or-get-setf-inverse (form environment)
     39  (multiple-value-bind
     40    (expansion expanded)
     41    (macroexpand-1 form environment)
     42    (if expanded
     43  (get-setf-expansion expansion environment)
     44  (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
     45         t))))
     46
    3647(defun get-setf-expansion (form &optional environment)
    3748  (let (temp)
     
    4657    (t
    4758     (expand-or-get-setf-inverse form environment)))))
    48 
    49 ;;; If a macro, expand one level and try again.  If not, go for the
    50 ;;; SETF function.
    51 (defun expand-or-get-setf-inverse (form environment)
    52   (multiple-value-bind
    53     (expansion expanded)
    54     (macroexpand-1 form environment)
    55     (if expanded
    56   (get-setf-expansion expansion environment)
    57   (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
    58          t))))
    59 
    60 (defun get-setf-method-inverse (form inverse setf-function)
    61   (let ((new-var (gensym))
    62   (vars nil)
    63   (vals nil))
    64     (dolist (x (cdr form))
    65       (push (gensym) vars)
    66       (push x vals))
    67     (setq vals (nreverse vals))
    68     (values vars vals (list new-var)
    69       (if setf-function
    70     `(,@inverse ,new-var ,@vars)
    71     `(,@inverse ,@vars ,new-var))
    72       `(,(car form) ,@vars))))
    7359
    7460;;; ROTATEF (from GCL)
Note: See TracChangeset for help on using the changeset viewer.