summaryrefslogtreecommitdiff
path: root/Sacla/symbol.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla/symbol.lisp')
-rw-r--r--Sacla/symbol.lisp102
1 files changed, 102 insertions, 0 deletions
diff --git a/Sacla/symbol.lisp b/Sacla/symbol.lisp
new file mode 100644
index 0000000..f508704
--- /dev/null
+++ b/Sacla/symbol.lisp
@@ -0,0 +1,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))
+