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(a)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