1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: symbol.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; * Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; * Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in
;; the documentation and/or other materials provided with the
;; distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defun keywordp (object)
"Return true if OBJECT is a keyword; otherwise, return false."
(and (symbolp object)
(symbol-package object)
(eq (symbol-package object)
(find-package "KEYWORD"))))
(defun copy-symbol (symbol &optional copy-properties)
"Returns a fresh, uninterned symbol whose name is string= to SYMBOL's."
(let ((copy (make-symbol (symbol-name symbol))))
(when copy-properties
(when (boundp symbol)
(setf (symbol-value copy) (symbol-value symbol)))
(when (fboundp symbol)
(setf (symbol-function copy) (symbol-function symbol)))
(setf (symbol-plist copy) (copy-list (symbol-plist symbol))))
copy))
(defun counter-to-str (x)
(flet ((digit-to-str (digit)
(string (char "0123456789" digit))))
(do* ((x x (floor x 10))
(digits (list (digit-to-str (mod x 10)))
(cons (digit-to-str (mod x 10)) digits)))
((zerop (floor x 10)) (apply #'concatenate
'string
digits)))))
;;(defvar *gensym-counter* 0
;; "Counter for generating unique GENSYM symbols.")
;;
;;(defun gensym (&optional (x "G"))
;; "Return a fresh, uninterned symbol whose name is determined using X."
;; (multiple-value-bind (prefix index)
;; (etypecase x
;; ((integer 0) (values "G" x))
;; ((string) (multiple-value-prog1
;; (values x *gensym-counter*)
;; (setq *gensym-counter* (1+ *gensym-counter*)))))
;; (make-symbol (concatenate 'string prefix (counter-to-str index)))))
(defvar *gentemp-counter* 0)
(defun gentemp (&optional (prefix "T") (package *package*))
"Return a fresh symbol, newly interned in PACKAGE."
(flet ((make-name (prefix)
(prog1
(concatenate 'string
prefix
(counter-to-str *gentemp-counter*))
(setq *gentemp-counter* (1+ *gentemp-counter*)))))
(do ((name (make-name prefix) (make-name prefix)))
(nil)
(multiple-value-bind (symbol status)
(find-symbol name package)
(declare (ignore symbol))
(when (eq status nil)
(return (intern name package)))))))
(defsetf symbol-value
set
"Change the contents of the value cell of symbol to the given value.")
(defun get (symbol indicator &optional default)
(getf (symbol-plist symbol) indicator default))
(defsetf get (symbol indicator &optional default) (value)
`(setf (getf (symbol-plist ,symbol) ,indicator ,default) ,value))
(defun remprop (symbol indicator)
(remf (symbol-plist symbol) indicator))
|
