[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv14413

Modified Files:
	symbols.lisp 
Log Message:
Added functions copy-symbol, create-symbol, %unbounded-symbol-value,
and %unbounded-symbol-function, and rewrote make-symbol in terms of create-symbol.

Date: Sun Mar 28 12:33:46 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.4 movitz/losp/muerte/symbols.lisp:1.5
--- movitz/losp/muerte/symbols.lisp:1.4	Wed Mar 24 08:31:43 2004
+++ movitz/losp/muerte/symbols.lisp	Sun Mar 28 12:33:46 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.4 2004/03/24 13:31:43 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.5 2004/03/28 17:33:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,6 +30,19 @@
        (:compile-form (:result-mode :eax) symbol)
        (:call-global-constant dynamic-load)))))
 
+(defun %unbounded-symbol-value (symbol)
+  "Return the symbol's value without checking if it's bound or not."
+  (check-type symbol symbol)
+  (with-inline-assembly (:returns :eax)
+    (:compile-form (:result-mode :eax) symbol)
+    (:call-global-constant dynamic-find-binding)
+    (:jnc 'no-local-binding)
+    (:movl (:eax) :eax)
+    (:jmp 'done)
+   no-local-binding
+    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)) :eax)
+   done))
+
 (defun (setf symbol-value) (value symbol)
   (etypecase symbol
     (null
@@ -62,6 +75,10 @@
       (error 'undefined-function :name symbol))
     function-value))
 
+(defun %unbounded-symbol-function (symbol)
+  (check-type symbol symbol)
+  (movitz-accessor symbol movitz-symbol function-value))
+
 (defun (setf symbol-function) (value symbol)
   (check-type symbol symbol)
   (check-type value compiled-function)
@@ -120,17 +137,39 @@
      (not (eq (movitz-accessor symbol movitz-symbol function-value)
 	      (load-global-constant movitz::unbound-function))))))
 
-(defun make-symbol (name)
+(defun create-symbol (name &optional (package nil)
+				     (plist nil)
+				     (value (load-global-constant unbound-value))
+				     (function (load-global-constant movitz::unbound-function))
+				     (flags 0))
   (eval-when (:compile-toplevel)
     (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
   (let ((symbol (%word-offset (malloc-clumps 3) 1)))
-    (setf-movitz-accessor (symbol movitz-symbol package) nil)
+    (setf-movitz-accessor (symbol movitz-symbol package) package)
     (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name))
-    (setf (symbol-flags symbol) 0
-	  (symbol-function symbol) (load-global-constant movitz::unbound-function)
+    (setf (symbol-flags symbol) flags
+	  (symbol-plist symbol) plist
+	  (symbol-function symbol) function
 	  (symbol-name symbol) name
-	  (symbol-value symbol) (load-global-constant unbound-value))
+	  (symbol-value symbol) value)
     symbol))
+
+(defun make-symbol (name)
+  (create-symbol name))
+
+(defun copy-symbol (symbol &optional copy-properties) 
+  "copy-symbol returns a fresh, uninterned symbol, the name of which
+  is string= to and possibly the same as the name of the given
+  symbol."
+  (if (or (eq nil symbol)
+	  (not copy-properties))
+      (create-symbol (symbol-name symbol))
+    (create-symbol (symbol-name symbol)
+		   nil
+		   (symbol-plist symbol)
+		   (%unbounded-symbol-value symbol)
+		   (%unbounded-symbol-function symbol)
+		   (symbol-flags symbol))))
 
 (defun symbol-flags (symbol)
   (etypecase symbol