Add Sacla to the repository.

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))
+