movitz-cvs July 2004

movitz-cvs@common-lisp.net

2 participants
376 discussions

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

26 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2429 Modified Files: primitive-functions.lisp Log Message: fix class-of defstructs. Date: Mon Jul 26 14:02:25 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.34 movitz/losp/muerte/primitive-functions.lisp:1.35 --- movitz/losp/muerte/primitive-functions.lisp:1.34 Fri Jul 23 18:30:54 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jul 26 14:02:25 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.34 2004/07/24 01:30:54 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.35 2004/07/26 21:02:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -731,7 +731,7 @@ (function (find-class 'function)) (structure-object - (structure-object-name object)) + (structure-object-class object)) (character (find-class 'character)) (run-time-context

1 0

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

24 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27104 Modified Files: compiler.lisp Log Message: Minor edit. Date: Fri Jul 23 18:32:06 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.84 movitz/compiler.lisp:1.85 --- movitz/compiler.lisp:1.84 Fri Jul 23 09:42:38 2004 +++ movitz/compiler.lisp Fri Jul 23 18:32:06 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.84 2004/07/23 16:42:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.85 2004/07/24 01:32:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6161,7 +6161,7 @@ (let ((x (multiple-value-call #'encoded-integer-types-add (type-specifier-encode type0) (type-specifier-encode type1)))) - (warn "thunked: ~S ~S -> ~S" term0 term1) + ;; (warn "thunked: ~S ~S -> ~S" term0 term1 x) x)) (list term0 term1) ))))

1 0

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

24 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10113 Modified Files: primitive-functions.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:54 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.33 movitz/losp/muerte/primitive-functions.lisp:1.34 --- movitz/losp/muerte/primitive-functions.lisp:1.33 Tue Jul 20 16:51:19 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Jul 23 18:30:54 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.33 2004/07/20 23:51:19 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.34 2004/07/24 01:30:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -731,7 +731,7 @@ (function (find-class 'function)) (structure-object - (find-class (structure-object-name object))) + (structure-object-name object)) (character (find-class 'character)) (run-time-context

1 0

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

24 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9729 Modified Files: los-closette.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:49 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.16 movitz/losp/muerte/los-closette.lisp:1.17 --- movitz/losp/muerte/los-closette.lisp:1.16 Tue Jul 20 16:51:10 2004 +++ movitz/losp/muerte/los-closette.lisp Fri Jul 23 18:30:49 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.16 2004/07/20 23:51:10 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.17 2004/07/24 01:30:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1112,9 +1112,9 @@ (let* ((slots (class-slots class)) (num-slots (length slots)) (struct (malloc-pointer-words (+ 2 num-slots)))) - (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) + (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) 0 :lisp) - (class-name class)) + class) (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) 0 :unsigned-byte8) #.(movitz::tag :defstruct)) @@ -1728,7 +1728,7 @@ (let ((*never-use-print-object* t) (*print-length* 4) (*print-level* 2)) - (error "Recursive circle:~%:::~S~v{~&::~S~}" args nil *sml-context*)))) + (error "Recursive circle:~%:::~S~{~&::~S~}" args *bsml-context*)))) (let ((*bsml-context* (cons args *bsml-context*))) (apply 'do-bootstrap-slow-method-lookup args)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 24 Jul '04

24 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8377 Modified Files: defstruct.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:44 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.10 movitz/losp/muerte/defstruct.lisp:1.11 --- movitz/losp/muerte/defstruct.lisp:1.10 Tue Jul 20 01:54:09 2004 +++ movitz/losp/muerte/defstruct.lisp Fri Jul 23 18:30:44 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.10 2004/07/20 08:54:09 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,10 +21,10 @@ (defun structure-object-length (object) (check-type object structure-object) - (movitz-accessor-u16 object movitz-struct length)) + (memref object -4 0 :unsigned-byte14)) (defun copy-structure (object) - (check-type object structure-object) + ;; (check-type object structure-object) (let* ((length (structure-object-length object)) (copy (malloc-pointer-words (+ 2 length)))) (setf (memref copy -6 0 :lisp) @@ -46,8 +46,8 @@ (:jnz 'fail) (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+)) (:jne 'fail) - (:load-constant struct-name :ebx) - (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) + (:load-constant struct-class :ebx) + (:cmpl :ebx (:eax (:offset movitz-struct class))) fail)) (defun structure-ref (object slot-number) @@ -83,8 +83,7 @@ (:jne '(:sub-program (type-error) (:int 66))) (:cmpb ,(movitz:tag :defstruct) (:eax ,movitz:+other-type-offset+)) (:jne '(:sub-program (type-error) (:int 66))) - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx) - (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx) + (:movzxw (:eax (:offset movitz-struct length)) :ecx) (:testb ,movitz::+movitz-fixnum-zmask+ :bl) (:jnz '(:sub-program (not-fixnum) (:movl :ebx :eax) (:int 64))) (:cmpl :ecx :ebx) @@ -105,8 +104,8 @@ (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+)) (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ebx) - (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 66))) +;;; (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) +;;; (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) @@ -124,8 +123,8 @@ (:cmpb #.(movitz:tag :defstruct) (:ebx #.movitz:+other-type-offset+)) (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ecx) - (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 66))) +;;; (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) +;;; (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, write slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) @@ -227,20 +226,27 @@ '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) (defstruct (:translate-when :eval ,name-and-options :cl :muerte.cl) . (:translate-when :eval ,slot-names :cl :muerte.cl))) + (defclass ,struct-name (structure-object) () + (:metaclass structure-class) + (:slots ,(loop for (name) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :location location)))) ,@(loop for constructor in (getf options :constructor) if (and constructor (symbolp constructor)) collect `(defun ,constructor (&key ,@key-lambda) (let ((s (malloc-pointer-words ,(+ 2 (length slot-names))))) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) + (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) 0 :lisp) - ',struct-name) + (compile-time-find-class ,struct-name)) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) 0 :unsigned-byte8) #.(movitz::tag :defstruct)) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length) 0 :unsigned-byte16) - ,(length slot-names)) + ,(* movitz:+movitz-fixnum-factor+ (length slot-names))) ,@(loop for slot-name in slot-names as i upfrom 0 collecting `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0) @@ -254,15 +260,15 @@ (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) `(defun ,boa-constructor ,boa-lambda-list (let ((s (malloc-pointer-words ,(+ 2 (length slot-names))))) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) + (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) 0 :lisp) - ',struct-name) + (compile-time-find-class ,struct-name)) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) 0 :unsigned-byte8) #.(movitz::tag :defstruct)) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length) 0 :unsigned-byte16) - ,(length slot-names)) + ,(* movitz:+movitz-fixnum-factor+ (length slot-names))) ,@(loop for slot-name in slot-names as i upfrom 0 if (member slot-name boa-variables) collect @@ -280,7 +286,7 @@ do (error "Don't know how to make class-struct constructor: ~S" constructor)) ,(when predicate-name `(defun-by-proto ,predicate-name struct-predicate-prototype - (struct-name ,struct-name))) + (struct-class (:movitz-find-class ,struct-name)))) ,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) (movitz::symbol-package-fix-cl struct-name)) @@ -294,13 +300,6 @@ `(defun-by-proto ,accessor-name struct-accessor-prototype (struct-name ,struct-name) (slot-number ,slot-number))) - (defclass ,struct-name (structure-object) () - (:metaclass structure-class) - (:slots ,(loop for (name) in canonical-slot-descriptions - as location upfrom 0 - collect (movitz-make-instance 'structure-slot-definition - :name name - :location location)))) ',struct-name)) (list `(progn @@ -335,6 +334,6 @@ ',struct-name)) )))))) -(defun structure-object-name (x) - (movitz-accessor x movitz-struct name)) +;;;(defun structure-object-name (x) +;;; (movitz-accessor x movitz-struct name))

1 0

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

24 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6844 Modified Files: storage-types.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:40 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.31 movitz/storage-types.lisp:1.32 --- movitz/storage-types.lisp:1.31 Fri Jul 23 08:34:32 2004 +++ movitz/storage-types.lisp Fri Jul 23 18:30:40 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.31 2004/07/23 15:34:32 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.32 2004/07/24 01:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -975,15 +975,23 @@ :initform :defstruct) (pad :binary-lisp-type 1) (length - :binary-lisp-type lu16 + :binary-type lu16 :initarg :length - :accessor movitz-struct-length) - (name + :accessor movitz-bignum-length + :map-binary-write (lambda (x &optional type) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x 4)) + :map-binary-read (lambda (x &optional type) + (declare (ignore type)) + (assert (zerop (mod x 4))) + (truncate x 4))) + (class :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word - :reader movitz-struct-name - :initarg :name) + :reader movitz-struct-class + :initarg :class) (slot0 :binary-lisp-type :label) ; the slot values follows here. (slot-values :initform '() @@ -1017,7 +1025,7 @@ (defmethod print-object ((object movitz-struct) stream) (print-unreadable-object (object stream :type t) - (format stream "~S" (slot-value object 'name)))) + (format stream "~S" (slot-value object 'class)))) ;;; @@ -1072,7 +1080,7 @@ (svref bucket-data (1+ pos)) movitz-value))) (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data)) (lh (make-instance 'movitz-struct - :name (movitz-read 'muerte::hash-table) + :class (muerte::movitz-find-class 'muerte::hash-table) :length 3 :slot-values (list hash-test ; test-function bucket

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 24 Jul '04

24 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5994 Modified Files: special-operators.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:32 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.31 movitz/special-operators.lisp:1.32 --- movitz/special-operators.lisp:1.31 Tue Jul 20 05:40:07 2004 +++ movitz/special-operators.lisp Fri Jul 23 18:30:32 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.31 2004/07/20 12:40:07 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.32 2004/07/24 01:30:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -249,7 +249,12 @@ :form nil)) (list exit-label))))))))))))) - +(define-special-operator compile-time-find-class (&all all &form form) + (destructuring-bind (class-name) + (cdr form) + (compiler-call #'compile-form-unprotected + :form (muerte::movitz-find-class class-name) + :forward all))) (define-special-operator make-named-function (&form form &env env) (destructuring-bind (name formals declarations docstring body) @@ -296,7 +301,11 @@ The valid parameters are~{ ~S~}." parameter proto-name (mapcar #'movitz-print (movitz-funobj-const-list funobj-proto))) - do (setf (car (member parameter c)) (movitz-read value))) + (setf (car (member parameter c)) + (if (and (consp value) + (eq :movitz-find-class (car value))) + (muerte::movitz-find-class (cadr value)) + (movitz-read value)))) c)))) (setf (movitz-funobj-symbolic-name funobj) function-name) (setf (movitz-env-named-function function-name) funobj)

1 0

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

24 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4608 Modified Files: image.lisp Log Message: Changed the implementation of structs a bit: Keep the length encoded as a fixnum (in 16 bits), and name them by their class metaobject rather than the symbol name. Date: Fri Jul 23 18:30:27 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.50 movitz/image.lisp:1.51 --- movitz/image.lisp:1.50 Fri Jul 23 08:32:35 2004 +++ movitz/image.lisp Fri Jul 23 18:30:27 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.50 2004/07/23 15:32:35 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.51 2004/07/24 01:30:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1462,7 +1462,7 @@ (unless slot-descriptions (error "Don't know how to movitz-read struct: ~S" expr)) (let ((movitz-object (make-instance 'movitz-struct - :name (movitz-read (type-of expr)) + :class (muerte::movitz-find-class (type-of expr)) :length (length slot-descriptions)))) (setf (image-lisp-to-movitz-object *image* expr) movitz-object) (setf (slot-value movitz-object 'slot-values) @@ -1497,7 +1497,8 @@ (movitz-make-upload-form (movitz-symbol-value object))) (format nil "~:[~;'~]#:~A" quotep (movitz-print object)))) (t (check-type package movitz-struct) - (assert (eq (movitz-struct-name package) (movitz-read 'muerte::package-object))) + (assert (eq (movitz-struct-class package) + (muerte::movitz-find-class 'muerte::package-object))) (let ((package-name (intern (movitz-print (first (movitz-struct-slot-values package)))))) (case package-name (keyword (format nil ":~A" (movitz-print object))) @@ -1541,10 +1542,12 @@ (etypecase expr (integer expr) (symbol expr) + (array expr) (cons (mapcar #'movitz-print expr)) ((or movitz-nil movitz-constant-block) nil) (movitz-fixnum (movitz-fixnum-value expr)) + (movitz-std-instance expr) (movitz-heap-object (or (image-movitz-to-lisp-object *image* expr) (error "Unknown Movitz object: ~S" expr)))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 24 Jul '04

24 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv10918 Modified Files: debugger.lisp Log Message: Minor edit. Date: Fri Jul 23 18:29:06 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.18 movitz/losp/x86-pc/debugger.lisp:1.19 --- movitz/losp/x86-pc/debugger.lisp:1.18 Tue Jul 20 16:53:48 2004 +++ movitz/losp/x86-pc/debugger.lisp Fri Jul 23 18:29:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.18 2004/07/20 23:53:48 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.19 2004/07/24 01:29:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -429,6 +429,7 @@ (declare (dynamic-extent args)) (handler-case (apply #'print-stack-frame-arglist args) (serious-condition (conditon) + (declare (ignore conditon)) (write-string "#<error printing frame>")))) (defun backtrace (&key stack

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 24 Jul '04

24 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26461 Modified Files: memref.lisp Log Message: Added type :unsigned-byte14 for memref. Date: Fri Jul 23 18:28:28 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.21 movitz/losp/muerte/memref.lisp:1.22 --- movitz/losp/muerte/memref.lisp:1.21 Tue Jul 20 01:54:29 2004 +++ movitz/losp/muerte/memref.lisp Fri Jul 23 18:28:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.21 2004/07/20 08:54:29 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.22 2004/07/24 01:28:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,6 +112,39 @@ (:load-lexical (:lexical-binding ,object-var) :eax) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:movzxw (:eax :ecx ,(offset-by 2)) :ecx))))))) + (:unsigned-byte14 + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :ecx :type (unsigned-byte 14)) + (:compile-form (:result-mode :eax) ,object) + (:movzxw (:eax ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))) + ((eq 0 offset) + (let ((object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:eax :ecx) ,object-var ,index-var) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) + (:leal (:ecx (:ebx 2)) :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (:testb ,movitz:+movitz-fixnum-shift+ :cl) + (:jnz '(:sub-program () (:int 63))))))))) (:unsigned-byte29+3 ;; Two values: the 29 upper bits as unsigned integer, ;; and secondly the lower 3 bits as unsigned. @@ -256,6 +289,7 @@ (defun memref (object offset index type) (ecase type (:unsigned-byte8 (memref object offset index :unsigned-byte8)) + (:unsigned-byte14 (memref object offset index :unsigned-byte14)) (:unsigned-byte16 (memref object offset index :unsigned-byte16)) (:unsigned-byte32 (memref object offset index :unsigned-byte32)) (:character (memref object offset index :character))

1 0

← Newer
1
...
4
5
6
7
8
9
10
...
38
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs July 2004