stream-image.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      stream-image.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Mon Aug 27 14:46:50 2001
  12 ;;;;
  13 ;;;; $Id: stream-image.lisp,v 1.13 2005/05/03 20:12:42 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17
  18 (in-package movitz)
  19
  20
  21 (defclass stream-image (movitz-image)
  22   ((stream
  23     :reader image-stream
  24     :initarg :stream)
  25    (offset
  26     :initarg :offset
  27     :accessor image-stream-offset)
  28    (start-address
  29     :initarg :start-address
  30     :initform #x100000
  31     :reader image-start-address)
  32    (nil-word
  33     :initarg :nil-word
  34     :initform (if (boundp '*image*)
  35                   (image-nil-word *image*)
  36                 (progn
  37                   (format *query-io* "~&Please enter the stream-images NIL value: ")
  38                   (read *query-io*)))
  39     :reader image-nil-word)
  40    (nil-object
  41     :initform (make-movitz-nil)
  42     :reader image-nil-object)))
  43
  44 (defmethod image-register32 ((image stream-image) register-name)
  45   (declare (ignorable image) (ignore register-name))
  46   (error "A stream-image has no CPU state."))
  47
  48 (defmethod (setf image-stream-position) (value (image stream-image) &optional physicalp)
  49   (check-type value (integer 0 *))
  50   (assert (file-position (image-stream image)
  51                          (+ (image-stream-offset image)
  52                             (if physicalp 0 (image-ds-segment-base image))
  53                             value))
  54       (value)
  55     "Unable to set memory-stream's file-position to #x~X." value))
  56
  57 (defmethod image-run-time-context ((image stream-image))
  58   (movitz-word (image-register32 image :edi)))
  59
  60 (defmethod movitz-word-by-image ((image stream-image) word)
  61   (let ((object (case (extract-tag word)
  62                   ((:even-fixnum :odd-fixnum)
  63                    (make-instance 'movitz-fixnum :value (ldb (byte 29 2) word)))
  64                   (:cons
  65                    (setf (image-stream-position image) (extract-pointer word))
  66                    (read-binary 'movitz-cons (image-stream image)))
  67                   (:character
  68                    (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word))))
  69                   (:null
  70                    (image-nil-object image))
  71                   (:symbol
  72                    ;; (warn "loading new symbol at ~S" word)
  73                    (if (= word #x7fffffff)
  74                        (make-instance 'movitz-unbound-value)
  75                      (progn
  76                        (setf (image-stream-position image)
  77                          (- word (tag :symbol)))
  78                        (read-binary 'movitz-symbol (image-stream image)))))
  79                   (:other
  80                    (setf (image-stream-position image)
  81                      (+ 0 (extract-pointer word)))
  82                    (let* ((type-code (read-binary 'u8 (image-stream image)))
  83                           (type-tag (enum-symbolic-value 'other-type-byte type-code)))
  84                      (setf (image-stream-position image)
  85                        (extract-pointer word))
  86                      (case type-tag
  87                        (:funobj
  88                         (read-binary 'movitz-funobj (image-stream image)))
  89                        (:basic-vector
  90                         (read-binary 'movitz-basic-vector (image-stream image)))
  91                        (:defstruct
  92                            (read-binary 'movitz-struct (image-stream image)))
  93                        (:std-instance
  94                         (read-binary 'movitz-std-instance (image-stream image)))
  95                        (:bignum
  96                         (read-binary 'movitz-bignum (image-stream image)))
  97                        (:run-time-context
  98                         (read-binary 'movitz-run-time-context (image-stream image)))
  99                        (t (warn "unknown other object: #x~X: ~S code #x~X."
 100                                 word type-tag type-code)
 101                           (make-instance 'movitz-fixnum :value (truncate word 4))))))
 102                   (t (make-instance 'movitz-fixnum :value 0)))))
 103     (when (typep object 'movitz-heap-object)
 104       (setf (movitz-heap-object-word object) word))
 105     object))
 106
 107 (defmethod image-intern-object ((image stream-image) object &optional (size (sizeof object)))
 108   (declare (ignore size))
 109   (movitz-heap-object-word object))
 110
 111 (defmethod image-lisp-to-movitz-object ((image stream-image) lisp-object)
 112   (etypecase lisp-object
 113     (null
 114      (movitz-word-by-image image (image-nil-word image)))
 115     ((signed-byte 30)
 116      (make-movitz-fixnum lisp-object))))
 117
 118 (defmethod (setf image-lisp-to-movitz-object) (movitz-object (image stream-image) lisp-object)
 119   (declare (ignore lisp-object))
 120   movitz-object)
 121
 122
 123