April 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1444 Modified Files: storage-types.lisp Log Message: Re-worked a bit how hash-tables are translated to movitz. Increased their size quite a bit, so as to reduce the number of collisions. Date: Wed Apr 21 12:22:56 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.15 movitz/storage-types.lisp:1.16 --- movitz/storage-types.lisp:1.15 Mon Mar 29 09:35:17 2004 +++ movitz/storage-types.lisp Wed Apr 21 12:22:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.15 2004/03/29 14:35:17 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.16 2004/04/21 16:22:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1126,7 +1126,7 @@ (defun make-movitz-hash-table (lisp-hash) (let* ((undef (movitz-read +undefined-hash-key+)) - (hash-size (* 4 (max 8 (hash-table-count lisp-hash)))) + (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) (bucket-data (make-array hash-size :initial-element undef))) (multiple-value-bind (hash-test hash-sxhash) (ecase (hash-table-test lisp-hash) @@ -1139,8 +1139,8 @@ do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size) then (rem (+ 2 pos) hash-size) until (eq undef (svref bucket-data pos)) -;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" -;;; pos hash-size movitz-key (elt bucket-list pos)) +;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" +;;; pos hash-size movitz-key (elt bucket-data pos)) ;;; finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value) ;;; finally (when (equal "NIL" key) ;;; (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos)) @@ -1149,7 +1149,7 @@ (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data)) (lh (make-instance 'movitz-struct :name (movitz-read 'muerte::hash-table) - :length 2 + :length 3 :slot-values (list hash-test ; test-function bucket hash-sxhash)))) @@ -1160,7 +1160,7 @@ (assert (= 3 (length (movitz-struct-slot-values movitz-hash)))) (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) - (hash-size (* 2 (truncate (hash-table-count lisp-hash) 2/3))) + (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size) @@ -1178,12 +1178,14 @@ then (rem (+ 2 pos) hash-size) until (eq undef (svref bucket-data pos)) ;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" -;;; pos hash-size movitz-key (elt bucket-list pos)) +;;; pos hash-size movitz-key (elt bucket-data pos)) ;;; finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value) ;;; finally (when (equal "NIL" key) ;;; (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos)) - finally (setf (svref bucket-data pos) movitz-key - (svref bucket-data (1+ pos)) movitz-value))) + finally + (setf (svref bucket-data pos) movitz-key + (svref bucket-data (1+ pos)) movitz-value))) + (setf *foo* bucket-data) (setf (first (movitz-struct-slot-values movitz-hash)) hash-test (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data) (third (movitz-struct-slot-values movitz-hash)) hash-sxhash)

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14991 Modified Files: packages.lisp Log Message: More symbols. Date: Wed Apr 21 12:00:25 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.20 movitz/packages.lisp:1.21 --- movitz/packages.lisp:1.20 Mon Apr 19 11:04:32 2004 +++ movitz/packages.lisp Wed Apr 21 12:00:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.20 2004/04/19 15:04:32 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.21 2004/04/21 16:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1191,6 +1191,7 @@ #:vector-u32 #:pointer #:basic-restart + #:illegal-object #:run-time-context make-funobj

1 0

[movitz-cvs] CVS update: movitz/movitz.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24597 Modified Files: movitz.lisp Log Message: Added syntax #{...} for arrays specialized to (unsigned-byte 8). Date: Wed Apr 21 11:09:25 2004 Author: ffjeld Index: movitz/movitz.lisp diff -u movitz/movitz.lisp:1.6 movitz/movitz.lisp:1.7 --- movitz/movitz.lisp:1.6 Wed Apr 14 08:37:23 2004 +++ movitz/movitz.lisp Wed Apr 21 11:09:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.6 2004/04/14 12:37:23 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.7 2004/04/21 15:09:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,6 +61,13 @@ (declare (ignore subchar arg)) (list 'muerte.common-lisp::function (read stream t nil t)))) + (set-dispatch-macro-character #\# #\{ + (lambda (stream subchar arg) + (declare (ignore subchar arg)) + (let ((data (read-delimited-list #\} stream))) + (make-movitz-vector (length data) + :element-type 'movitz-unboxed-integer-u8 + :initial-contents data)))) (set-macro-character #\` (lambda (stream char) (declare (ignore char)) (let ((*bq-level* (1+ *bq-level*)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16271 Modified Files: primitive-functions.lisp Log Message: Various minor fixes. Date: Wed Apr 21 11:08:36 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.15 movitz/losp/muerte/primitive-functions.lisp:1.16 --- movitz/losp/muerte/primitive-functions.lisp:1.15 Mon Apr 19 15:49:11 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Apr 21 11:08:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.15 2004/04/19 19:49:11 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.16 2004/04/21 15:08:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,33 +30,29 @@ "Call a function with 1 argument" (with-inline-assembly (:returns :nothing) (:movb 1 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-funcall%2op () "Call a function with 2 arguments" (with-inline-assembly (:returns :nothing) (:movb 2 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-funcall%3op () "Call a function with 3 arguments" (with-inline-assembly (:returns :nothing) -;;; (:xorl :ecx :ecx) -;;; (:movb 2 :cl) (:movb 3 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-cl-dispatch-1or2 () "Jump to the entry-point designated by :cl, which must be 1 or 2." (with-inline-assembly (:returns :nothing) - (:cmpb 1 :cl) - (:jne 'not-one) - (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) - not-one - (:cmpb 2 :cl) - (:jne 'not-two) - (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))) - not-two + (:subb 1 :cl) ; 1 or 2 => 0 or 1 + (:testb #xfe :cl) + (:jnz 'mismatch) + (:jmp (:esi (:ecx 4) #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) + mismatch + (:addb 1 :cl) (:int 100))) (define-primitive-function no-code-vector () @@ -246,10 +242,7 @@ (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) (:je 'success) -;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop -;;; (:cmpl :edx (:ecx 12)) -;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) ; compare name @@ -277,10 +270,7 @@ (:jecxz 'no-binding) (:cmpl :eax (:ecx)) (:je 'success) -;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop -;;; (:cmpl :edx (:ecx 12)) -;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-binding) (:cmpl :eax (:ecx)) ; compare name @@ -555,7 +545,8 @@ (define-primitive-function fast-class-of-tag3 () "Return the class of a tag3 object." (with-inline-assembly (:returns :multiple-values) - (:int 64) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'illegal-object)) :eax) (:ret))) (define-primitive-function fast-class-of-character () @@ -572,10 +563,14 @@ (define-primitive-function fast-class-of-null () "Return the class of a nil object." (with-inline-assembly (:returns :multiple-values) + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpl :edi :eax) - (:jne '(:sub-program () (:int 64))) - (:globally (:movl (:edi (:edi-offset classes)) :eax)) - (:movl (:eax #.(movitz::class-object-offset 'null)) :eax) + (:je 'null) + (:movl (:ebx #.(movitz::class-object-offset 'illegal-object)) :eax) + (:jmp 'not-null) + null + (:movl (:ebx #.(movitz::class-object-offset 'null)) :eax) + not-null (:ret))) (define-primitive-function fast-class-of-other () @@ -626,13 +621,7 @@ (find-class 'fixnum)) (basic-restart (find-class 'basic-restart)) - (tag6 - (error "Don't know the class of ~Z with other-type #x~X." - object (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :eax) object) - (:movzxb (:eax -2) :ecx)))) - (t (error "Don't know the class of the word ~Z!" object) - (find-class t)))) + (t (find-class 'illegal-object)))) (define-primitive-function push-current-values () "Push all current return-values on the stack. And, return number

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13349 Modified Files: print.lisp Log Message: Minor edits. Date: Wed Apr 21 11:07:48 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.7 movitz/losp/muerte/print.lisp:1.8 --- movitz/losp/muerte/print.lisp:1.7 Tue Apr 13 11:15:55 2004 +++ movitz/losp/muerte/print.lisp Wed Apr 21 11:07:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.7 2004/04/13 15:15:55 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.8 2004/04/21 15:07:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -202,8 +202,7 @@ (null (write-string (symbol-name nil) stream)) ((or cons tag5) - (let ((level *print-level*) - (length *print-length*)) + (let ((level *print-level*)) (cond ((and level (minusp level)) (write-char #\# stream)) @@ -227,7 +226,7 @@ (write (cdr c)) (write-char #\) stream))))))) (write-char #\( stream) - (write-cons object stream length)))))) + (write-cons object stream *print-length*)))))) (integer (write-integer object stream *print-base* *print-radix*)) (string

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12850 Modified Files: los-closette.lisp Log Message: Added class illegal-object. Date: Wed Apr 21 11:07:27 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.9 movitz/losp/muerte/los-closette.lisp:1.10 --- movitz/losp/muerte/los-closette.lisp:1.9 Mon Apr 19 18:38:27 2004 +++ movitz/losp/muerte/los-closette.lisp Wed Apr 21 11:07:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.9 2004/04/19 22:38:27 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.10 2004/04/21 15:07:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -227,44 +227,12 @@ (defun class-of (object) (class-of object)) ; compiler-macro -#+ignore -(defun class-of (object) - (typecase object - (std-instance - (movitz-accessor object movitz-std-instance class)) - (standard-gf-instance - (movitz-accessor object movitz-funobj-standard-gf standard-gf-class)) - (null - (find-class 'null)) - (cons - (find-class 'cons)) - (symbol - (find-class 'symbol)) - (fixnum - (find-class 'fixnum)) - (vector - (find-class 'vector)) - (compiled-function - (find-class 'function)) - (hash-table - (find-class 'hash-table)) - (package - (find-class 'package)) - (structure-object - (find-class 'structure-object)) - (t (warn "Don't know the class of ~Z!" object) - (find-class t)))) - (defun subclassp (c1 c2) (not (null (find c2 (class-precedence-list c1))))) ;;; -;;; -;;; -;;; -;;; -;;; ;;; Generic function stuff +;;; ;;; Several tedious functions for analyzing lambda lists @@ -1025,6 +993,8 @@ (defclass float (real) () (:metaclass built-in-class)) (defclass complex (number) () (:metaclass built-in-class)) +(defclass illegal-object (t) () (:metaclass built-in-class)) + (defclass run-time-context (t) () (:metaclass built-in-class) @@ -1144,7 +1114,7 @@ (declare (dynamic-extent init-args)) (let ((class (if (symbolp class) (find-class class nil) class))) (check-type class structure-class) - (let* ((slots (structure-slots class)) + (let* ((slots (class-slots class)) (num-slots (length slots)) (struct (malloc-words num-slots))) (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) @@ -1717,6 +1687,10 @@ (defmethod print-object ((x run-time-context) stream) (print-unreadable-object (x stream :type t :identity t) (format stream " ~S" (%run-time-context-slot 'name x))) + x) + +(defmethod print-object ((x illegal-object) stream) + (print-unreadable-object (x stream :type t :identity t)) x) ;;;

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11406 Modified Files: image.lisp Log Message: Minor edit. Date: Wed Apr 21 11:06:50 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.26 movitz/image.lisp:1.27 --- movitz/image.lisp:1.26 Mon Apr 19 11:06:21 2004 +++ movitz/image.lisp Wed Apr 21 11:06:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.26 2004/04/19 15:06:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.27 2004/04/21 15:06:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -549,7 +549,8 @@ muerte:run-time-context muerte.mop:standard-effective-slot-definition muerte.mop:funcallable-standard-class - muerte:basic-restart)) + muerte:basic-restart + muerte:illegal-object)) (defun class-object-offset (name) (+ (bt:slot-offset 'movitz-vector 'data)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10632 Modified Files: compiler.lisp Log Message: Removed bad check-type. Date: Wed Apr 21 11:06:16 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.57 movitz/compiler.lisp:1.58 --- movitz/compiler.lisp:1.57 Tue Apr 20 19:04:12 2004 +++ movitz/compiler.lisp Wed Apr 21 11:06:16 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.57 2004/04/20 23:04:12 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.58 2004/04/21 15:06:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5831,7 +5831,6 @@ (define-extended-code-expander :endp (instruction funobj frame-map) (destructuring-bind (cell result-mode) (cdr instruction) - (check-type cell lexical-binding) (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) (location (new-binding-location (binding-target binding) frame-map)) (binding-is-list-p (binding-store-subtypep binding 'list)) @@ -5844,11 +5843,6 @@ (member location '(:eax :ebx :ecx :edx))) (make-result-and-returns-glue result-mode :boolean-zf=1 `((:cmpl :edi ,location)))) -;;; ((and binding-is-list-p -;;; (eq (result-mode-type result-mode) -;;; :boolean-branch-on-false)) -;;; (cond -;;; ((member location '(:eax :ebx :ecx :edx)) ((eq :boolean-branch-on-true (result-mode-type result-mode)) (let ((tmp-register (or tmp-register :ecx))) (append (make-load-lexical binding

1 0

[movitz-cvs] CVS update: movitz/assembly-syntax.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8352 Modified Files: assembly-syntax.lisp Log Message: Make assembly-macroexpand not barf on non-proper lists. Date: Wed Apr 21 11:05:40 2004 Author: ffjeld Index: movitz/assembly-syntax.lisp diff -u movitz/assembly-syntax.lisp:1.2 movitz/assembly-syntax.lisp:1.3 --- movitz/assembly-syntax.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/assembly-syntax.lisp Wed Apr 21 11:05:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 17:34:37 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: assembly-syntax.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,29 +25,21 @@ (setf (gethash symbol (assembly-macro-environment-expanders amenv)) expander)) -;;;(defun assembly-macroexpand (prg amenv) -;;; (cond -;;; ((and (consp prg) (symbolp (car prg))) -;;; (let ((expander (assembly-macro-expander (car prg) amenv))) -;;; (if expander -;;; (assembly-macroexpand (funcall expander prg) amenv) -;;; #0=(cons (assembly-macroexpand (car prg) amenv) -;;; (assembly-macroexpand (cdr prg) amenv))))) -;;; ((consp prg) #0#) -;;; (t prg))) - (defun assembly-macroexpand (prg amenv) - (loop for p in prg - as expander = (and (consp p) - (symbolp (car p)) - (assembly-macro-expander (car p) amenv)) - if expander - append (funcall expander p) - else if (consp p) - append (list (assembly-macroexpand p amenv)) - else append (list p))) - -;;;(defmacro with-assembly-syntax (&body body) -;;; `(let ((*readtable* (copy-readtable nil))) -;;; (set-dispatch-macro-character + (let* ((fix-tail nil) + (new-prg + (loop for (p . tail) on prg + as expander = (and (consp p) + (symbolp (car p)) + (assembly-macro-expander (car p) amenv)) + if expander + append (funcall expander p) + else if (consp p) + append (list (assembly-macroexpand p amenv)) + else append (list p) + unless (listp tail) + do (setf fix-tail tail)))) + (when fix-tail + (setf (cdr (last new-prg)) fix-tail)) + new-prg))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp
by Frode Vatvedt Fjeld 21 Apr '04

21 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26391 Modified Files: symbols.lisp Log Message: Fixed a horrible bug in %create-symbol. Date: Wed Apr 21 10:00:16 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.11 movitz/losp/muerte/symbols.lisp:1.12 --- movitz/losp/muerte/symbols.lisp:1.11 Fri Apr 16 19:36:40 2004 +++ movitz/losp/muerte/symbols.lisp Wed Apr 21 10:00:15 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.11 2004/04/16 23:36:40 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.12 2004/04/21 14:00:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -149,7 +149,9 @@ (let ((symbol (%word-offset (malloc-clumps 3) 1))) (setf-movitz-accessor (symbol movitz-symbol package) package) (setf-movitz-accessor (symbol movitz-symbol name) name) - (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name)) + (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key) + 0 :unsigned-byte16) + (sxhash name)) (setf (symbol-flags symbol) flags (symbol-plist symbol) plist (symbol-function symbol) function

1 0