stream-image.lisp 4.14 KB
Newer Older
1 2
;;;;------------------------------------------------------------------
;;;; 
3
;;;;    Copyright (C) 2001-2005, 
4
;;;;    Department of Computer Science, University of Tromso, Norway.
5 6 7 8 9 10 11 12
;;;; 
;;;;    For distribution policy, see the accompanying file COPYING.
;;;; 
;;;; Filename:      stream-image.lisp
;;;; Description:   
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Mon Aug 27 14:46:50 2001
;;;;                
13
;;;; $Id: stream-image.lisp,v 1.12 2005/04/20 06:51:57 ffjeld Exp $
14 15 16 17 18 19 20
;;;;                
;;;;------------------------------------------------------------------


(in-package movitz)


21
(defclass stream-image (movitz-image)
22 23 24 25 26 27 28 29 30 31 32 33
  ((stream
    :reader image-stream
    :initarg :stream)
   (offset
    :initarg :offset
    :accessor image-stream-offset)
   (start-address
    :initarg :start-address
    :initform #x100000
    :reader image-start-address)
   (nil-word
    :initarg :nil-word
34 35 36 37 38
    :initform (if (boundp '*image*)
		  (image-nil-word *image*)
		(progn
		  (format *query-io* "~&Please enter the stream-images NIL value: ")
		  (read *query-io*)))
39 40 41 42
    :reader image-nil-word)
   (nil-object
    :initform (make-movitz-nil)
    :reader image-nil-object)))
43

44 45 46 47
(defmethod image-register32 ((image stream-image) register-name)
  (declare (ignorable image) (ignore register-name))
  (error "A stream-image has no CPU state."))

48 49 50 51 52 53 54 55 56
(defmethod (setf image-stream-position) (value (image stream-image) &optional physicalp)
  (check-type value (integer 0 *))
  (assert (file-position (image-stream image)
			 (+ (image-stream-offset image)
			    (if physicalp 0 (image-ds-segment-base image))
			    value))
      (value)
    "Unable to set memory-stream's file-position to #x~X." value))

57
(defmethod image-run-time-context ((image stream-image))
58 59 60 61 62 63 64 65 66 67 68 69
  (movitz-word (image-register32 image :edi)))

(defmethod movitz-word-by-image ((image stream-image) word)
  (let ((object (case (extract-tag word)
		  ((:even-fixnum :odd-fixnum)
		   (make-instance 'movitz-fixnum :value (ldb (byte 29 2) word)))
		  (:cons
		   (setf (image-stream-position image) (extract-pointer word))
		   (read-binary 'movitz-cons (image-stream image)))
		  (:character
		   (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word))))
		  (:null
70
		   (image-nil-object image))
71 72
		  (:symbol
		   ;; (warn "loading new symbol at ~S" word)
73 74 75 76 77 78
		   (if (= word #x7fffffff)
		       (make-instance 'movitz-unbound-value)
		     (progn
		       (setf (image-stream-position image)
			 (- word (tag :symbol)))
		       (read-binary 'movitz-symbol (image-stream image)))))
79 80
		  (:other
		   (setf (image-stream-position image)
81
		     (+ 0 (extract-pointer word)))
82 83
		   (let* ((type-code (read-binary 'u8 (image-stream image)))
			  (type-tag (enum-symbolic-value 'other-type-byte type-code)))
84 85 86 87 88
		     (setf (image-stream-position image)
		       (extract-pointer word))
		     (case type-tag
		       (:funobj
			(read-binary 'movitz-funobj (image-stream image)))
89 90
		       (:basic-vector
			(read-binary 'movitz-basic-vector (image-stream image)))
91 92 93 94
		       (:defstruct
			   (read-binary 'movitz-struct (image-stream image)))
		       (:std-instance
			(read-binary 'movitz-std-instance (image-stream image)))
95 96
		       (:bignum
			(read-binary 'movitz-bignum (image-stream image)))
97 98
		       (:run-time-context
			(read-binary 'movitz-run-time-context (image-stream image)))
99 100
		       (t (warn "unknown other object: #x~X: ~S code #x~X."
				word type-tag type-code)
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
			  (make-instance 'movitz-fixnum :value (truncate word 4))))))
		  (t (make-instance 'movitz-fixnum :value 0)))))
    (when (typep object 'movitz-heap-object)
      (setf (movitz-heap-object-word object) word))
    object))

(defmethod image-intern-object ((image stream-image) object &optional (size (sizeof object)))
  (declare (ignore size))
  (movitz-heap-object-word object))

(defmethod image-lisp-to-movitz-object ((image stream-image) lisp-object)
  (etypecase lisp-object
    (null
     (movitz-word-by-image image (image-nil-word image)))
    ((signed-byte 30)
     (make-movitz-fixnum lisp-object))))

(defmethod (setf image-lisp-to-movitz-object) (movitz-object (image stream-image) lisp-object)
  (declare (ignore lisp-object))
  movitz-object)