Changeset 5219


Ignore:
Timestamp:
12/20/03 14:13:04 (18 years ago)
Author:
piso
Message:

Added SETF expander for GETF.

File:
1 edited

Legend:

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

    r4554 r5219  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: late-setf.lisp,v 1.1 2003-10-28 02:28:04 piso Exp $
     4;;; $Id: late-setf.lisp,v 1.2 2003-12-20 14:13:04 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    5151    (values all-dummies all-vals newvals
    5252            `(values ,@(reverse setters)) `(values ,@(reverse getters)))))
     53
     54(defun %putf (place property new-value)
     55  (do ((plist place (cddr plist)))
     56      ((endp plist) (list* property new-value place))
     57    (when (eq (car plist) property)
     58      (setf (cadr plist) new-value)
     59      (return place))))
     60
     61(define-setf-expander getf (place prop &optional default &environment env)
     62  (multiple-value-bind (temps values stores set get)
     63    (get-setf-expansion place env)
     64    (let ((newval (gensym))
     65          (ptemp (gensym))
     66          (def-temp (if default (gensym))))
     67      (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
     68              `(,@values ,prop ,@(if default `(,default)))
     69              `(,newval)
     70              `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
     71                 ,set
     72                 ,newval)
     73              `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
Note: See TracChangeset for help on using the changeset viewer.