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

Modified Files: image.lisp Log Message: These checkins more or less complete the migration to the new basic-vector data-structure. All traces of the old vector structure should be gone.

Date: Wed Jul 7 10:37:02 2004 Author: ffjeld

Index: movitz/image.lisp diff -u movitz/image.lisp:1.40 movitz/image.lisp:1.41 --- movitz/image.lisp:1.40 Tue Jun 29 16:16:43 2004 +++ movitz/image.lisp Wed Jul 7 10:37:01 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.40 2004/06/29 23:16:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.41 2004/07/07 17:37:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -624,7 +624,7 @@

(defun class-object-offset (name) (let ((name (translate-program name :cl :muerte.cl))) - (+ (bt:slot-offset 'movitz-vector 'data) + (+ (bt:slot-offset 'movitz-basic-vector 'data) (* 4 (1+ (or (position name (image-classes-map *image*)) (error "No class named ~S in class-map." name)))))))

@@ -678,17 +678,18 @@ (defmethod search-image ((image symbolic-image) address) (loop for a downfrom (logand address -8) by 8 until (gethash a (image-address-hash image)) - finally (progn - ;; (warn "Found at ~X: ~S" a (gethash a (image-address-hash image))) - (return (gethash a (image-address-hash image)))))) + finally (let ((object (gethash a (image-address-hash image)))) + (when (<= address (+ a (sizeof object))) + ;; (warn "Found at ~X: ~S" a (gethash a (image-address-hash image))) + (return object)))))

(defun search-image-funobj (address &optional (*image* *image*)) (search-image-funobj-by-image *image* address))

(defmethod search-image-funobj-by-image ((image symbolic-image) address) (let ((code-vector (search-image image (1- address)))) - (unless (and (typep code-vector 'movitz-vector) - (eq :u8 (movitz-vector-element-type code-vector))) + (unless (and (typep code-vector 'movitz-basic-vector) + (eq :code (movitz-vector-element-type code-vector))) (error "Not a code-vector at #x~8,'0X: ~S" address code-vector)) (let ((offset (- address (movitz-intern-code-vector code-vector)))) (assert (not (minusp offset))) @@ -710,7 +711,7 @@

(defun search-primitive-function (address &optional (*image* *image*)) (let ((code-vector (search-image *image* address))) - (unless (and (typep code-vector 'movitz-vector) + (unless (and (typep code-vector 'movitz-basic-vector) (eq :u8 (movitz-vector-element-type code-vector))) (error "Not a code-vector at #x~8,'0X: ~S" address code-vector)) (format t "~&;; Code vector: #x~X" (movitz-intern code-vector)) @@ -751,11 +752,11 @@ a cons is an offset (the car) from some other code-vector (the cdr)." (assert (member type '(code-vector-word code-pointer))) (etypecase object - ((or vector movitz-vector) + ((or vector movitz-basic-vector) (+ 2 (movitz-intern object))) ((or symbol movitz-symbol) (let ((primitive-code-vector (movitz-symbol-value (movitz-read object)))) - (check-type primitive-code-vector movitz-vector) + (check-type primitive-code-vector movitz-basic-vector) (movitz-intern-code-vector primitive-code-vector type))) (movitz-funobj (movitz-intern-code-vector (movitz-funobj-code-vector object) type)) @@ -811,7 +812,7 @@ (setf code-vector (setf (movitz-symbol-value (movitz-read name)) (movitz-read #())))) - (check-type code-vector movitz-vector) + (check-type code-vector movitz-basic-vector) code-vector))

(defun create-image (&key (init-file *default-image-init-file*) @@ -935,7 +936,7 @@ :if-does-not-exist :create) (assert (file-position stream 512) () ; leave room for bootblock. "Couldn't set file-position for ~W." (pathname stream)) - (let* ((stack-vector (make-instance 'movitz-vector + (let* ((stack-vector (make-instance 'movitz-basic-vector :num-elements #xffff :fill-pointer 0 :symbolic-data nil @@ -1053,15 +1054,14 @@ (write-size (write-binary-record obj stream))) (incf total-size write-size) (typecase obj - (movitz-vector + (movitz-basic-vector (case (movitz-vector-element-type obj) (:character (incf strings-numof) (incf strings-size write-size)) (:any-t (incf simple-vectors-numof) (incf simple-vectors-size write-size)) - (:u8 (when (member :code-vector-p (movitz-vector-flags obj)) - (incf code-vectors-numof) - (incf code-vectors-size write-size))))) + (:code (incf code-vectors-numof) + (incf code-vectors-size write-size)))) (movitz-funobj (incf funobjs-numof) (incf funobjs-size write-size)) (movitz-symbol (incf symbols-numof) @@ -1500,7 +1500,7 @@ (keyword (format nil ":~A" (movitz-print object))) (common-lisp (format nil "~:[~;'~]~A" quotep (movitz-print object))) (t (format nil "~:[~;'~]~A:~A" quotep package-name (movitz-print object))))))))) - (movitz-vector + (movitz-basic-vector (case (movitz-vector-element-type object) (:character (format nil ""~A"" (movitz-print object))) (t (movitz-print object))))