[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-serv23880

Modified Files:
	symbols.lisp 
Log Message:
Re-arranged many details about *movitz-nil*, movitz-null, and how it
relates to the cons and symbol binary-classes etc. This should now be
slightly less messy, and slightly more efficient.

Date: Wed Jul 28 17:13:22 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.17 movitz/losp/muerte/symbols.lisp:1.18
--- movitz/losp/muerte/symbols.lisp:1.17	Thu Jul 15 14:07:32 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Jul 28 17:13:22 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.17 2004/07/15 21:07:32 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.18 2004/07/29 00:13:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,6 +21,23 @@
 
 (in-package muerte)
 
+(define-compiler-macro get-symbol-slot (object slot &optional (type t))
+  "Read a slot off a symbol (including NIL)."
+  `(with-inline-assembly (:returns :eax :type ,type)
+     (:compile-form (:result-mode :eax) ,object)
+     (:leal (:eax ,(- (movitz:tag :null))) :ecx)
+     (:andl 7 :ecx)
+     (:testb 5 :cl)
+     (:jnz '(:sub-program (not-a-symbol)
+	     (:compile-form (:result-mode :ignore)
+	      (error-not-symbol (assembly-register :eax)))))
+     (:xorl 2 :ecx)
+     (:movl (:eax :ecx (:offset movitz-symbol ,slot))
+	    :eax)))
+
+(defun error-not-symbol (x)
+  (error 'type-error :expected-type 'symbol :datum x))
+
 (defun symbol-value (symbol)
   "Returns the dynamic value of SYMBOL."
   (etypecase symbol
@@ -40,7 +57,7 @@
     (:movl (:eax) :eax)
     (:jmp 'done)
    no-local-binding
-    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)) :eax)
+    (:movl (:eax (:offset movitz-symbol value)) :eax)
    done))
 
 (defun (setf symbol-value) (value symbol)
@@ -70,12 +87,7 @@
   (setf (%symbol-global-value symbol) value))
 
 (defun symbol-function (symbol)
-  (let ((function-value
-	 (etypecase symbol
-	   (null
-	    (movitz-accessor symbol movitz-nil-symbol function-value))
-	   (symbol
-	    (movitz-accessor symbol movitz-symbol function-value)))))
+  (let ((function-value (get-symbol-slot symbol function-value)))
     (when (eq function-value (load-global-constant movitz::unbound-function))
       (error 'undefined-function :name symbol))
     function-value))
@@ -90,14 +102,9 @@
   (setf-movitz-accessor (symbol movitz-symbol function-value) value))
 
 (defun symbol-name (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol name))
-    (symbol 
-     (movitz-accessor symbol movitz-symbol name))))
+  (get-symbol-slot symbol name string))
 
 (defun (setf symbol-name) (value symbol)
-  (check-type value string)
   (etypecase symbol
     (null
      (error "Can't change the name of NIL."))
@@ -105,11 +112,7 @@
      (setf-movitz-accessor (symbol movitz-symbol name) value))))
 
 (defun symbol-plist (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol plist))
-    (symbol 
-     (movitz-accessor symbol movitz-symbol plist))))
+  (get-symbol-slot symbol plist))
 
 (defun (setf symbol-plist) (value symbol)
   (etypecase symbol
@@ -119,11 +122,7 @@
      (setf-movitz-accessor (symbol movitz-symbol plist) value))))
 
 (defun symbol-package (symbol)
-  (etypecase symbol
-    (null
-     (movitz-accessor symbol movitz-nil-symbol package))
-    (symbol
-     (movitz-accessor symbol movitz-symbol package))))
+  (get-symbol-slot symbol package))
 
 (defun boundp (symbol)
   (boundp symbol))
@@ -134,11 +133,8 @@
   symbol)
 
 (defun fboundp (symbol)
-  (etypecase symbol
-    (null nil)
-    (symbol
-     (not (eq (movitz-accessor symbol movitz-symbol function-value)
-	      (load-global-constant movitz::unbound-function))))))
+  (not (eq (get-symbol-slot symbol function-value)
+	   (load-global-constant movitz::unbound-function))))
 
 (defun %create-symbol (name &optional (package nil)
 				      (plist nil)