diff options
Diffstat (limited to 'Sacla/symbol.lisp')
| -rw-r--r-- | Sacla/symbol.lisp | 102 |
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)) + |