;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(DEFCONST DATA-TYPES '(
  %DTP-TRAP
  %DTP-NULL
  %DTP-UNRECONCILED
  %DTP-SYMBOL
  %DTP-SYMBOL-HEADER
  %DTP-FIX
  %DTP-EXTENDED-NUMBER
  %DTP-HEADER 
  %DTP-GC-FORWARD
  %DTP-EXTERNAL-VALUE-CELL-POINTER
  %DTP-ONE-Q-FORWARD
  %DTP-HEADER-FORWARD
  %DTP-BODY-FORWARD
  %DTP-LOCATIVE
  %DTP-LIST 
  %DTP-U-ENTRY 
  %DTP-FEF-POINTER
  %DTP-ARRAY-POINTER
  %DTP-ARRAY-HEADER 
  %DTP-STACK-GROUP
  %DTP-CLOSURE
  %DTP-INDEXED-FORWARD
  %DTP-SELECT-METHOD 
  %DTP-INSTANCE
  %DTP-INSTANCE-HEADER
  %DTP-ENTITY
  %DTP-STACK-CLOSURE
  %DTP-SELF-REF-POINTER
  %DTP-CHARACTER
  %DTP-RPLACD-FORWARD
  %DTP-SPARE
  %DTP-SMALL-FLONUM
  %dtp-unboxed-pointer
  ))

(si:assign-values data-types)

(defconst %%data-type (byte 6 26.))
(defconst %%pointer (byte 26. 0))
(defconst %pointer-mask (1- (ash 1 26.)))

(defvar *dont-cons* nil)

(defflavor typed-pointer
	 (pointer type)
	 ())

(defmethod (pointer :print-self) (stream ignore ignore)
  (si:printing-random-object (self stream :no-pointer :type)
    (format stream "~a ~o" (nth type data-types) pointer)))

(defmethod (pointer :pointer-value) ()
  pointer)

(defmethod (pointer :make-pointer-offset) (new-data-type offset)
  (make-instance 'pointer
		 :type new-data-type
		 :pointer (logand %pointer-mask (+ pointer offset))))

(defun >make-pointer-offset (data-type pointer offset)
  (send pointer :make-pointer-offset data-type offset))

(defmethod (pointer :nil) ()
  (make-instance 'pointer :type 0 :pointer 0))

(defmethod (pointer :null?) ()
  (and (eq data-type 0) (eq pointer 0)))

(defmethod (pointer :whole-q) ()
  (dpb data-type %%data-type (logand %pointer-mask pointer)))

(defun >whole-q (ptr)
  (send ptr :whole-q))

(defun >p-ldb-offset (byte-spec pointer offset)
  (lam:ldb-big byte-spec (send (send pointer :follow-structure-forwarding) :read-offset offset)))

(defun >p-ldb (byte-spec pointer)
  (>p-ldb-offset byte-spec pointer 0))

(defun >p-dpb-offset (value byte-spec pointer offset)
  (let ((p (send pointer :follow-structure-forwarding)))
    (let ((old (send p :read-offset offset)))
      (send p :write-offset offset (lam:dpb-big (if (typep value 'pointer)
						    (send value :pointer-value)
						  value) byte-spec old)))))

(defun >p-dpb (value byte-spec pointer)
  (>p-dpb-offset value byte-spec pointer 0))

(defsetf >p-ldb-offset (byte-spec pointer offset) (val)
  `(>p-dpb-offset ,val ,byte-spec ,pointer ,offset))

(defsetf >p-ldb (byte-spec pointer) (val)
  `(>p-dpb ,val ,byte-spec ,pointer))

(defun >p-mask-field-offset (byte-spec pointer offset)
  (lam:dpb-big (>p-ldb-offset byte-spec pointer offset) byte-spec 0))

(defmacro >p-mask-field (byte-spec pointer)
  `(>p-mask-field-offset ,byte-spec ,pointer 0))

(defmacro >p-data-type-offset (pointer offset)
  `(>p-ldb-offset %%data-type ,pointer ,offset))

(defmacro >p-data-type (pointer)
  `(>p-data-type-offset ,pointer 0))

(defun >p-pointer-offset (pointer offset)
  (>p-ldb-offset %%pointer pointer offset))

(defsetf >p-pointer-offset (pointer offset) (val)
  `(>p-dpb-offset ,val %%pointer ,pointer ,offset))

(defmacro >p-pointer (pointer)
  `(>p-pointer-offset ,pointer 0))

;;these are for writing brand new cells -- they will never transport
(defun >p-write-cell-offset (val adr offset)
  (send *proc* :write-main-memory (+ (>pointer-as-integer adr) offset) (>whole-q val)))

(defun >p-write-cell (val adr)
  (>p-write-cell-offset val adr 0))

;;these will someday do transport-header, etc 
;;therefore, they can't be used on uninitialized or unboxed storage
(defun >p-contents-offset (adr offset)
  (let ((q (send *proc* :read-main-memory (+ (>pointer-as-integer adr) offset))))
    (>make-pointer (ldb %%q-data-type q) (logand #.(1- (ash 1 25.)) q))))

(defun >p-store-contents-offset (value adr offset)
  (send *proc* :write-main-memory
	(+ (>pointer-as-integer adr) offset)
	(>whole-q value)))

(defun >p-store-contents-offset-setf (adr offset val)
  (send *proc* :write-main-memory
	(+ (>pointer-as-integer adr) offset)
	(>whole-q val)))
  
(defsetf >p-contents-offset >p-store-contents-offset-setf)

(defun >p-contents (adr)
  (>p-contents-offset adr 0))

(defun >p-store-contents (adr val)
  (>p-store-contents-offset val adr 0))

(defsetf >p-contents >p-store-contents)

(defun >pointer-plus (ptr &rest offsets)
  (>make-pointer dtp-trap (apply #'+ (>pointer-as-integer ptr) offsets)))


(defvar *NIL*)

(defun >cons (car cdr)
  (let ((new-cell (>allocate-cells 2 1)))
    (>p-write-cell car new-cell)
    (>p-write-cell-offset cdr new-cell 1)
    (>new-type dtp-list new-cell)))

(defun >eq (ptr1 ptr2)
  (and (= (>pointer-as-integer ptr1) (>pointer-as-integer ptr2))
       (= (>data-type ptr1) (>data-type ptr2))))

(defun >car (cons)
  (let ((dt (>data-type cons)))
    (cond ((= dt dtp-list)
	   (>p-contents cons))
	  ((and (= dt dtp-symbol)
		(>eq cons *NIL*))
	   *NIL*)
	  (t
	   (ferror nil "can't do car on ~s" cons)))))

(defun >cdr (cons)
  (let ((dt (>data-type cons)))
    (cond ((= dt dtp-list)
	   (>p-contents-offset cons 1))
	  ((and (= dt dtp-symbol)
		(>eq cons *NIL*))
	   *NIL*)
	  (t
	   (ferror nil "can't do cdr on ~s" cons)))))

(defun >print (ptr)
  (format t "~%")
  (>prin1 ptr))

(defun >prin1 (ptr)
  (select (>data-type ptr)
    (dtp-list (>print-list ptr))
    (dtp-symbol (>print-symbol ptr))
    (dtp-symbol-header (>print-symbol-header ptr))
    (dtp-array-pointer (>print-array ptr))
    (t
     (>print-random-object ptr)
     )))

(defun >print-random-object (ptr)
  (format t "#<~s ~s>" (nth (>data-type ptr) q-data-types) (>pointer-as-integer ptr)))

(defun >array-length (array)
  (when (not (= (>data-type array) dtp-array-pointer))
    (ferror nil "not an array"))
  (when (not (= (>p-data-type array) dtp-array-header))
    (ferror nil "doesn't point to a header"))
  (cond ((zerop (>p-ldb si:%%array-long-length-flag array))
	 (>p-ldb si:%%array-index-length-if-short array))
	(t
	 (>p-contents-offset array 1))))

(defun >print-array (array &optional just-the-bytes)
  (when (not (= (>p-data-type array) dtp-array-header))
    (ferror nil "first word of array is not header"))
  (cond ((or (not (= (>p-ldb si:%%array-number-dimensions array) 1))
	     (not (= (>p-ldb si:%%array-long-length-flag array) 0))
	     (not (= (>p-mask-field si:%%array-type-field array) art-string)))
	 (>print-random-object array))
	(t
	 (when (null just-the-bytes)
	   (format t "#<remote \""))
	 (dotimes (i (>array-length array))
	   (format t "~c" (>aref array i)))
	 (when (null just-the-bytes)
	   (format t "\">")))))

(defun >print-symbol-header (ptr)
  (when (not (= (>data-type ptr) dtp-symbol-header))
    (ferror nil "~s is not a symbol header" ptr))
  (let ((string (>new-type dtp-array-pointer (>pointer ptr))))
    (format t "#<DTP-SYMBOL-HEADER ")
    (>print-array string t)
    (format t " ~o>" (>pointer-as-integer ptr))))
  
  

(defun >print-symbol (ptr)
  (when (not (= (>data-type ptr) dtp-symbol))
    (ferror nil "~s is not a symbol" ptr))
  (when (not (= (>p-data-type ptr) dtp-symbol-header))
    (ferror nil "this symbol pointer does not point to a symbol header"))
  (let ((string (>new-type dtp-array-pointer (>p-pointer ptr))))
    (>print-array string t)))
    
(defun >null (ptr)
  (>eq ptr *NIL*))

(defun >consp (ptr)
  (= (>data-type ptr) dtp-list))

(defun >atom (ptr)
  (not (>consp ptr)))

(defun >print-list (ptr)
  (labels ((>print-list-1 (ptr)
	     (cond ((>null ptr))
		   ((>atom ptr)
		    (>prin1 ptr))
		   (t
		    (>print-list (>car ptr))
		    (cond ((>consp (>cdr ptr))
			   (format t " "))
			  ((not (>null (>cdr ptr)))
			   (format t " . ")))
		    (>print-list-1 (>cdr ptr))))))
    (cond ((>consp ptr)
	   (format t "(")
	   (>print-list-1 ptr)
	   (format t ")"))
	  (t
	   (>prin1 ptr)))))

(defun >aref (array &rest subscripts &aux element-number)
  (when (not (= (length subscripts) 1))
    (ferror nil "only one dimensional"))
  (setq element-number (car subscripts))
  (when (not (= (>data-type array) dtp-array-pointer))
    (ferror nil "~s is not an array-pointer" array))
  (when (not (= (>p-data-type array) dtp-array-header))
    (ferror nil "~s does not point to an array header"))
  (when (not (= (>p-ldb si:%%array-long-length-flag array) 0))
    (ferror nil "can't hack long arrays"))
  (when (or (< element-number 0)
	    (>= element-number (>p-ldb si:%%array-index-length-if-short array)))
    (ferror nil "out of bounds"))
  (let ((elements-per-word (select (>p-mask-field si:%%array-type-field array)
			     (art-string 4)
			     (t (ferror nil "can't hack this type of array"))))
	byte-spec)
    (setq byte-spec (byte (floor 32. elements-per-word) (* (floor 32. elements-per-word)
							   (remainder element-number 4))))
    (>p-ldb-offset byte-spec array (1+ (floor element-number elements-per-word)))))

(defun >aset (val array &rest subscripts &aux element-number)
  (when (not (= (length subscripts) 1))
    (ferror nil "only one dimensional"))
  (setq element-number (car subscripts))
  (when (not (= (>data-type array) dtp-array-pointer))
    (ferror nil "~s is not an array-pointer" array))
  (when (not (= (>p-data-type array) dtp-array-header))
    (ferror nil "~s does not point to an array header"))
  (when (not (= (>p-ldb si:%%array-long-length-flag array) 0))
    (ferror nil "can't hack long arrays"))
  (when (or (< element-number 0)
	    (>= element-number (>p-ldb si:%%array-index-length-if-short array)))
    (ferror nil "out of bounds"))
  (let ((elements-per-word (select (>p-mask-field si:%%array-type-field array)
			     (art-string 4)
			     (t (ferror nil "can't hack this type of array"))))
	byte-spec)
    (setq byte-spec (byte (floor 32. elements-per-word) (* (floor 32. elements-per-word)
							   (remainder element-number 4))))
    (>p-dpb-offset val byte-spec array (1+ (floor element-number elements-per-word)))))

(defsetf >aref (array index) (val)
  `(>aset ,val ,array  ,index))

(defun >make-string (length)
  (let ((words (ceiling length 4)))
    (when (> words si:%array-max-short-index-length)
      (ferror nil "can't hack long array"))
    (let ((array (>allocate-cells (1+ words))))
      (setf (>p-ldb %%q-data-type array) dtp-array-header)
      (setf (>p-ldb si:%%array-type-field array) (ldb si:%%array-type-field art-string))
      (setf (>p-ldb si:%%array-number-dimensions array) 1)
      (setf (>p-ldb si:%%array-index-length-if-short array) length)
      (>new-type dtp-array-pointer array))))

(defun copy-array-to-remote (from to)
  (dotimes (i (array-length from))
    (>aset (aref from i) to i)))
      
(defun make-remote-string (string)
  (let ((s (>make-string (string-length string))))
    (copy-array-to-remote string s)
    s))
      

(defvar *symbol-cache* 0)

(defpackage sim-sym
  :use nil)

(defun clear-symbol-cache ()
  (incf *symbol-cache*)
  (setq *NIL* (>intern "NIL"))
  (setf (>p-contents-offset *NIL* 1) *NIL*)
  )

(defun >make-symbol (pname &optional adr)
  (let ((symbol (if adr (>make-pointer dtp-trap adr) (>allocate-cells 5))))
    ;;pname
    (setf (>p-data-type symbol) dtp-symbol-header)
    (setf (>p-pointer symbol) (>pointer (make-remote-string pname)))
    ;;value
    (setf (>p-data-type-offset symbol 1) dtp-null)
    (setf (>p-pointer-offset symbol 1) (>pointer symbol))
    ;;function
    (setf (>p-data-type-offset symbol 2) dtp-null)
    (setf (>p-pointer-offset symbol 2) (>pointer symbol))
    ;;plist
    (setf (>p-contents-offset symbol 3) *NIL*)
    ;;package
    (setf (>p-contents-offset symbol 4) *NIL*)
    (>new-type dtp-symbol symbol)))

(defun >intern (string)
  (let ((local-symbol (intern string 'sim-sym)))
    (cond ((not (eq (get local-symbol 'sim-symbol-cache) *symbol-cache*))
	   (let ((remote-symbol (>make-symbol string
					      (cond ((string-equal string "NIL") 0)
						    (t nil)))))
	     (putprop local-symbol remote-symbol 'sim-remote-symbol)
	     (putprop local-symbol *symbol-cache* 'sim-symbol-cache)
	     remote-symbol))
	  (t
	   (get local-symbol 'sim-remote-symbol)))))

(defun (:property format:>S format:format-ctl-one-arg) (thing ignore)
  (>prin1 thing)
  )

(defun >length (list)
  (do ((len 0 (1+ len))
       (l list (>cdr l)))
      ((>atom l)
       (cond ((>null l) len)
	     (t (ferror nil "list ends in ~\\>s\\" l))))))