Changeset 8501


Ignore:
Timestamp:
02/07/05 17:48:02 (16 years ago)
Author:
piso
Message:

Section 5.1.3.

File:
1 edited

Legend:

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

    r3819 r8501  
    11;;; remf.lisp
    22;;;
    3 ;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: remf.lisp,v 1.1 2003-09-16 16:47:49 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: remf.lisp,v 1.2 2005-02-07 17:48:02 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 ;;; REMF (from OpenMCL)
     20;;; Adapted from SBCL.
     21
    2122(defmacro remf (place indicator &environment env)
    2223  "Place may be any place expression acceptable to SETF, and is expected
    23    to hold a property list or ().  This list is destructively altered to
    24    remove the property specified by the indicator.  Returns T if such a
     24   to hold a property list or (). This list is destructively altered to
     25   remove the property specified by the indicator. Returns T if such a
    2526   property was present, NIL if not."
    2627  (multiple-value-bind (dummies vals newval setter getter)
    27     (get-setf-expansion place env)
     28      (get-setf-expansion place env)
    2829    (do* ((d dummies (cdr d))
    29           (v vals (cdr v))
    30           (let-list nil)
    31           (ind-temp (gensym))
    32           (local1 (gensym))
    33           (local2 (gensym)))
    34          ((null d)
    35           (push (list (car newval) getter) let-list)
    36           (push (list ind-temp indicator) let-list)
    37           `(let* ,(nreverse let-list)
    38              (do ((,local1 ,(car newval) (cddr ,local1))
    39                   (,local2 nil ,local1))
    40                  ((atom ,local1) nil)
    41                (cond ((atom (cdr ,local1))
    42                       (error "odd-length property list in REMF"))
    43                      ((eq (car ,local1) ,ind-temp)
    44                       (cond (,local2
    45                              (rplacd (cdr ,local2) (cddr ,local1))
    46                              (return t))
    47                             (t (setq ,(car newval) (cddr ,(car newval)))
    48                                ,setter
    49                                (return t))))))))
     30    (v vals (cdr v))
     31    (let-list nil)
     32    (ind-temp (gensym))
     33    (local1 (gensym))
     34    (local2 (gensym)))
     35   ((null d)
     36          ;; See ANSI 5.1.3 for why we do out-of-order evaluation
     37    (push (list ind-temp indicator) let-list)
     38    (push (list (car newval) getter) let-list)
     39    `(let* ,(nreverse let-list)
     40       (do ((,local1 ,(car newval) (cddr ,local1))
     41      (,local2 nil ,local1))
     42     ((atom ,local1) nil)
     43         (cond ((atom (cdr ,local1))
     44          (error "Odd-length property list in REMF."))
     45         ((eq (car ,local1) ,ind-temp)
     46          (cond (,local2
     47           (rplacd (cdr ,local2) (cddr ,local1))
     48           (return t))
     49          (t (setq ,(car newval) (cddr ,(car newval)))
     50             ,setter
     51             (return t))))))))
    5052      (push (list (car d) (car v)) let-list))))
Note: See TracChangeset for help on using the changeset viewer.