source: trunk/j/src/org/armedbear/lisp/symbol.lisp @ 3784

Last change on this file since 3784 was 3784, checked in by piso, 19 years ago

GETF

File size: 2.4 KB
Line 
1;;; symbol.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: symbol.lisp,v 1.6 2003-09-14 18:01:12 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
22;;; From CMUCL.
23
24(defun remprop (symbol indicator)
25  (do ((pl (symbol-plist symbol) (cddr pl))
26       (prev nil pl))
27    ((atom pl) nil)
28    (cond ((atom (cdr pl))
29     (error "~S has an odd number of items in its property list" symbol))
30    ((eq (car pl) indicator)
31     (cond (prev (rplacd (cdr prev) (cddr pl)))
32     (t
33      (setf (symbol-plist symbol) (cddr pl))))
34     (return t)))))
35
36(defun getf (place indicator &optional (default ()))
37  (do ((plist place (cddr plist)))
38      ((null plist) default)
39    (cond ((atom (cdr plist))
40     (error 'type-error "malformed property list: ~S" place))
41    ((eq (car plist) indicator)
42     (return (cadr plist))))))
43
44(defun %putf (place property new-value)
45  (do ((plist place (cddr plist)))
46      ((endp plist) (list* property new-value place))
47    (when (eq (car plist) property)
48      (setf (cadr plist) new-value)
49      (return place))))
50
51(defsetf getf %putf)
52
53(defun get-properties (place indicator-list)
54  (do ((plist place (cddr plist)))
55      ((null plist) (values nil nil nil))
56    (cond ((atom (cdr plist))
57     (error 'type-error
58                  "malformed property list: ~S" (list place)))
59    ((memq (car plist) indicator-list)
60     (return (values (car plist) (cadr plist) plist))))))
61
62(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
63  (setq new-symbol (make-symbol (symbol-name symbol)))
64  (when copy-props
65    (when (boundp symbol)
66      (set new-symbol (symbol-value symbol)))
67    (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol)))
68    (when (fboundp symbol)
69      (setf (symbol-function new-symbol) (symbol-function symbol))))
70  new-symbol)
Note: See TracBrowser for help on using the repository browser.