Changeset 3700


Ignore:
Timestamp:
09/11/03 15:54:26 (19 years ago)
Author:
piso
Message:

REMF

File:
1 edited

Legend:

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

    r3688 r3700  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: boot.lisp,v 1.106 2003-09-10 18:46:29 piso Exp $
     4;;; $Id: boot.lisp,v 1.107 2003-09-11 15:54:26 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    409409
    410410;;; MULTIPLE-VALUE-BIND (from CLISP)
    411 
    412411(defmacro multiple-value-bind (varlist form &body body)
    413412  (let ((g (gensym))
     
    416415    `(let* ((,g (multiple-value-list ,form)) ,@(nreverse poplist))
    417416           ,@body)))
     417
     418
     419;;; REMF (from OpenMCL)
     420(defmacro remf (place indicator &environment env)
     421  "Place may be any place expression acceptable to SETF, and is expected
     422   to hold a property list or ().  This list is destructively altered to
     423   remove the property specified by the indicator.  Returns T if such a
     424   property was present, NIL if not."
     425  (multiple-value-bind (dummies vals newval setter getter)
     426    (get-setf-expansion place env)
     427    (do* ((d dummies (cdr d))
     428          (v vals (cdr v))
     429          (let-list nil)
     430          (ind-temp (gensym))
     431          (local1 (gensym))
     432          (local2 (gensym)))
     433         ((null d)
     434          (push (list (car newval) getter) let-list)
     435          (push (list ind-temp indicator) let-list)
     436          `(let* ,(nreverse let-list)
     437             (do ((,local1 ,(car newval) (cddr ,local1))
     438                  (,local2 nil ,local1))
     439                 ((atom ,local1) nil)
     440               (cond ((atom (cdr ,local1))
     441                      (error "Odd-length property list in REMF."))
     442                     ((eq (car ,local1) ,ind-temp)
     443                      (cond (,local2
     444                             (rplacd (cdr ,local2) (cddr ,local1))
     445                             (return t))
     446                            (t (setq ,(car newval) (cddr ,(car newval)))
     447                               ,setter
     448                               (return t))))))))
     449      (push (list (car d) (car v)) let-list))))
Note: See TracChangeset for help on using the changeset viewer.