Changeset 3821


Ignore:
Timestamp:
09/16/03 16:53:10 (19 years ago)
Author:
piso
Message:

Autoload REMF.

File:
1 edited

Legend:

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

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