;;; -*- Mode:SCHEME; Package:SCHEME; Readtable:SCHEME; Base:10 -*-

(define (make-phys-mem size)
  (let ((phys-mem (make-vector size)))
    (vector-fill phys-mem 0)
    (object ()
	    ((phys-mem-read-unboxed self adr)
	     (ignore self)
	     (vref phys-mem adr))
	    ((phys-mem-write-unboxed self adr data)
	     (ignore self)
	     (set (vref phys-mem adr) data))
	    ((print self stream)
	     (ignore self)
	     (write-with-braces self stream "Phys-Mem"))
	    ((phys-mem-vector self)
	     (ignore self)
	     phys-mem)
	    )))

(define (non-phys-mem object)
  (error "~S is not a phys-mem." object))

(define-operation (phys-mem-read-unboxed phys-mem adr)
  (ignore adr)
  (non-phys-mem phys-mem))
(define-operation (phys-mem-write-unboxed phys-mem adr data)
  (ignore adr data)
  (non-phys-mem phys-mem))
(define-operation (phys-mem-vector phys-mem)
  (non-phys-mem phys-mem))
  
(set (setter phys-mem-read-unboxed) phys-mem-write-unboxed)

(define (create-pointer data-type address)
  (object ()
	  ((data-type self)
	   (ignore self)
	   data-type)
	  ((add-offset self offset)
	   (create-pointer data-type (+ address offset)))
	  ((print self stream)
	   (write-with-braces self stream "Pointer" data-type address))
	  ))



(define *phys-mem* (make-phys-mem 10000.))

(define ++q-pointer (byte 26. 0))
(define ++q-data-type (byte 6. 26.))
(define +q-pointer-mask (1- (ash 1 26.)))

(define (read-pointer adr)

  (logand (phys-mem-read-unboxed *phys-mem* adr)
	  +q-pointer-mask)



(define +free-pointer #o400)

(define (reset-memory)
  (set (phys-mem-read-unboxed +free-pointer) #o1000))

(define (allocate-words n)
  (let ((result (phys-mem-read-unboxed *phys-mem* +free-pointer)))
    (set (phys-mem-read-unboxed *phys-mem* +free-pointer)
	 (+ result n))
    result))