;;; -*- Mode:LISP; Package:DATATYPE-RAM; Readtable:CL; Base:10. -*-

;(in-package 'dt-ram)

(export '(
	  load-dt-ram-pattern
	  load-initial-datatype-ram
	  read-dt-ram
	  write-dt-ram
	  ))

(defafun write-dt-ram (lbox ldt rbox rdt dt-code value)
  (alu-field field-pass processor-control a5 processor-control (byte 1. 8.)) ;data bit
 left
  (alu-field extract-bit-right nop a0 a0 (byte 1. 0.))   ;left word
  (alu-field field-pass a6 a1 a1 (byte 6. 26.) unboxed br-zero)
  (branch right ())
  (alu-field field-pass a6 a1 a1 (byte 6. 26.) boxed)
 right
  (alu-field extract-bit-right nop a2 a2 (byte 1. 0.))   ;right word
  (alu-field field-pass a7 a3 a3 (byte 6. 26.) unboxed br-zero)
  (branch doit ())
  (alu-field field-pass a7 a3 a3 (byte 6. 26.) boxed)
 doit
  (alu-field field-extract-r a4 a4 a4 (byte 3. 0.) unboxed)
  (alu l+r a4 a4 a4 unboxed)
  (movea a8 write-dt-ram-dispatch)
  (alu l+r nop a8 a4)
  (nop)
  (nop next-pc-dispatch))


(defafun write-dt-ram-dispatch ()
  (alu setr datatype-ram-write-pulse a6 a7 dt-0)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-0))
  (alu setr datatype-ram-write-pulse a6 a7 dt-1)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-1))
  (alu setr datatype-ram-write-pulse a6 a7 dt-2)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-2))
  (alu setr datatype-ram-write-pulse a6 a7 dt-3)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-3))
  (alu setr datatype-ram-write-pulse a6 a7 dt-4)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-4))
  (alu setr datatype-ram-write-pulse a6 a7 dt-5)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-5))
  (alu setr datatype-ram-write-pulse a6 a7 dt-6)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-6))
  (alu setr datatype-ram-write-pulse a6 a7 dt-7)
  (unconditional-branch write-dt-ram-dispatch-exit (alu setr nop a6 a7 dt-7))
 write-dt-ram-dispatch-exit
  (movei a6 '0) ;these two moves kill the illegal stuff in a6 and a7
  (movei a7 '0)
  (return a5))


(defafun read-dt-ram (lbox ldt rbox rdt dt-code)
 left
  (alu-field extract-bit-right nop a0 a0 (byte 1. 0.))   ;left word
  (alu-field field-pass a6 a1 a1 (byte 6. 26.) unboxed br-zero)
  (branch right ())
  (alu-field field-pass a6 a1 a1 (byte 6. 26.) boxed)
 right
  (alu-field extract-bit-right nop a2 a2 (byte 1. 0.))   ;right word
  (alu-field field-pass a7 a3 a3 (byte 6. 26.) unboxed br-zero)
  (branch doit ())
  (alu-field field-pass a7 a3 a3 (byte 6. 26.) boxed)
 doit
  (alu-field field-extract-r a4 a4 a4 (byte 3. 0.) unboxed)
  (alu l+r a4 a4 a4 unboxed)
  (movea a8 read-dt-ram-dispatch)
  (alu l+r nop a8 a4)
  (nop)
  (nop next-pc-dispatch))


(defafun read-dt-ram-dispatch ()
  (alu setr nop a6 a7 dt-0)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-0))
  (alu setr nop a6 a7 dt-1)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-1))
  (alu setr nop a6 a7 dt-2)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-2))
  (alu setr nop a6 a7 dt-3)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-3))
  (alu setr nop a6 a7 dt-4)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-4))
  (alu setr nop a6 a7 dt-5)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-5))
  (alu setr nop a6 a7 dt-6)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-6))
  (alu setr nop a6 a7 dt-7)
  (unconditional-branch read-dt (alu setr nop a6 a7 dt-7))
 read-dt
  (alu-field extract-bit-right a8 r0 processor-status (byte 1. 13.) unboxed)
  (movei a6 '0) ;these two moves kill the illegal stuff in a6 and a7
  (movei a7 '0)
  (alu l+r return a8 gr::*zero* ch-return next-pc-return bw-24)
 )



; load-dt-ram-pattern takes its first 5 arguments as 16 bit numbers (the top doesn't matter)
;   The bottom 8 bits are the pattern to match, and the high 8 bits are the mask to
;   be and'ed with the current test pattern. Only locations that match will be written.
;
;  Example: to set all locations with a left boxed datatype of #x1e in code 3:
;            (dt-ram-load #x0101 #x3f1e 0 0 #x0703 1)
;
(defafun load-dt-ram-pattern (lbox ldt rbox rdt dt-code value)
  (movei a10 '1)
 lbox-loop
  (alu-field field-and a9 a0 a10 (byte 8. -8.) unboxed)
  (alu xor nop a0 a9 bw-8)
  (test br-not-equal)
  (branch lbox-next ())

  (movei a11 '63)
 ldt-loop
  (alu-field field-and a9 a1 a11 (byte 8. -8.) unboxed)
  (alu xor nop a1 a9 bw-8)
  (test br-not-equal)
  (branch ldt-next ())

  (movei a12 '1)
 rbox-loop
  (alu-field field-and a9 a2 a12 (byte 8. -8.) unboxed)
  (alu xor nop a2 a9 bw-8)
  (test br-not-equal)
  (branch rbox-next ())

  (movei a13 '63)
 rdt-loop
  (alu-field field-and a9 a3 a13 (byte 8. -8.) unboxed)
  (alu xor nop a3 a9 bw-8)
  (test br-not-equal)
  (branch rdt-next ())

  (movei a14 '7)
 dt-code-loop
  (alu-field field-and a9 a4 a14 (byte 8. -8.) unboxed)
  (alu xor nop a4 a9 bw-8)
  (test br-not-equal)
  (branch dt-code-next ())

  (move o5 a5 ch-open)
  (move o4 a14)
  (move o3 a13)
  (move o2 a12)
  (move o1 a11)
  (call (write-dt-ram 6) a6 (o0 a10))

 dt-code-next
  (alu r-1 a14 a14 a14 bw-24)
  (test br-not-negative)
  (branch dt-code-loop ())

 rdt-next
  (alu r-1 a13 a13 a13 bw-24)
  (test br-not-negative)
  (branch rdt-loop ())

 rbox-next
  (alu r-1 a12 a12 a12 bw-24)
  (test br-not-negative)
  (branch rbox-loop ())

 ldt-next
  (alu r-1 a11 a11 a11 bw-24)
  (test br-not-negative)
  (branch ldt-loop ())

 lbox-next
  (alu r-1 a10 a10 a10 bw-24)
  (test br-not-negative)
  (branch lbox-loop ())

  (return a6))


;;; This function sets up the initial datatype ram
;;;
(defun load-initial-datatype-ram ()

;;; Init the whole datatype ram to ones

  (load-dt-ram-pattern  ; set all the bits
    #x0000   ;all left boxes
    #x0000   ;all left datatypes
    #x0000   ;all right boxes
    #x0000   ;all right datatypes
    #x0000   ;all codes
    1)       

;;; Clear all the no-check code bits

  (load-dt-ram-pattern  ; clear the no-check bits
    #x0000   ;all left boxes
    #x0000   ;all left datatypes
    #x0000   ;all right boxes
    #x0000   ;all right datatypes
    (logior #x0700 vinc:$$dtc-none)	;only the no-check code
    0)

;;; set up the check for both fixnum
  
  (load-dt-ram-pattern  ; clear the fixnum-codes, left-fixnum & right-fixnum
    #x0101				;left-boxed
    (logior #x3f00 vinc:$$dtp-fixnum)	;left-fixnum
    #x0101				;right boxed
    (logior #x3f00 vinc:$$dtp-fixnum)	;right-fixnum
    (logior #x0700 vinc:$$dtc-both-fixnum) ;fixnum without overflow
    0)

  (load-dt-ram-pattern 
    #x0101				;left-boxed
    (logior #x3f00 vinc:$$dtp-fixnum)	;left-fixnum
    #x0101				;right boxed
    (logior #x3f00 vinc:$$dtp-fixnum)	;right-fixnum
    (logior #x0700 vinc:$$dtc-both-fixnum-with-overflow) ;fixnum with overflow
    0)

;;; set up check for list on right side
  
  (load-dt-ram-pattern  ; clear the list codes, left-any & right-list
    #x0000				;all left-box
    #x0000				;all left datatypes
    #x0101				;right-boxed
    (logior #x3f00 vinc:$$dtp-cons)		;right-list
    (logior #x0700 vinc:$$dtc-right-list)	;list code
    0)
  (load-dt-ram-pattern  ; clear the list codes, left-any & right-nil
    #x0000				;all left-box
    #x0000				;all left datatypes
    #x0101				;right-boxed
    (logior #x3f00 vinc:$$dtp-nil)		;right-nil
    (logior #x0700 vinc:$$dtc-right-list)	;list code
    0)

;;; set up check for array on right side and structure on left side

  (load-dt-ram-pattern  ; clear the list codes, left-structure & right-array
    #x0101                                 ;left-box
    (logior #x3f00 vinc:$$dtp-structure)   ;left-structure
    #x0101				   ;right-boxed
    (logior #x3f00 vinc:$$dtp-array)	   ;right-array
    (logior #x0700 vinc:$$dtc-right-array-and-left-structure) ;array code
    0)
  

;;; set up check for not both character

  (load-dt-ram-pattern  ; clear the character-codes, left-character & right-character
    #x0101				 ;left-boxed
    (logior #x3f00 vinc:$$dtp-character) ;left-character
    #x0101				 ;right boxed
    (logior #x3f00 vinc:$$dtp-character) ;right-character
    (logior #x0700 vinc:$$dtc-both-character) ;both character codes
    0)

;;; set up check for same type of hairy numbers (for EQL)

  (load-dt-ram-pattern  ; clear the entry
    #x0000   ;all left boxes
    #x0000   ;all left datatypes
    #x0000   ;all right boxes
    #x0000   ;all right datatypes
    (logior #x0700 vinc:$$dtc-hairy-number)	;only the no-check code
    0)

  (load-dt-ram-pattern  ;trap if left unboxed
    #x0100				 ;left-unboxed
    #x0000       			 ;left dt any
    #x0000				 ;right box any
    #x0000				 ;right dt any
    (logior #x0700 vinc:$$dtc-hairy-number) ;both fixnum codes
    1)

  (load-dt-ram-pattern  ;trap if right unboxed
    #x0000				 ;left box any
    #x0000       			 ;left dt any
    #x0100				 ;right unbox
    #x0000				 ;right dt any
    (logior #x0700 vinc:$$dtc-hairy-number) ;both fixnum codes
    1)

  (load-dt-ram-pattern  ; trap if both bignum
    #x0101				   ;left-boxed
    (logior #x3f00 vinc:$$dtp-bignum) ;left-short
    #x0101				   ;right boxed
    (logior #x3f00 vinc:$$dtp-bignum) ;right-short
    (logior #x0700 vinc:$$dtc-hairy-number) ;both short codes
    1)

  (load-dt-ram-pattern  ; trap if both rational
    #x0101				   ;left-boxed
    (logior #x3f00 vinc:$$dtp-rational) ;left-short
    #x0101				   ;right boxed
    (logior #x3f00 vinc:$$dtp-rational) ;right-short
    (logior #x0700 vinc:$$dtc-hairy-number) ;both short codes
    1)

  (load-dt-ram-pattern  ; trap if both short-float
    #x0101				   ;left-boxed
    (logior #x3f00 vinc:$$dtp-short-float) ;left-short
    #x0101				   ;right boxed
    (logior #x3f00 vinc:$$dtp-short-float) ;right-short
    (logior #x0700 vinc:$$dtc-hairy-number) ;both short codes
    1)

  (load-dt-ram-pattern  ; trap if both float
    #x0101				 ;left-boxed
    (logior #x3f00 vinc:$$dtp-single-float)     ;left-float
    #x0101				 ;right boxed
    (logior #x3f00 vinc:$$dtp-single-float)     ;right-float
    (logior #x0700 vinc:$$dtc-hairy-number) ;both float codes
    1)

  (load-dt-ram-pattern  ; trap if both double-float
    #x0101				 ;left-boxed
    (logior #x3f00 vinc:$$dtp-double-float) ;left-double
    #x0101				 ;right boxed
    (logior #x3f00 vinc:$$dtp-double-float) ;right-double
    (logior #x0700 vinc:$$dtc-hairy-number) ;both double codes
    1)

  (load-dt-ram-pattern  ; trap if both complex
    #x0101				   ;left-boxed
    (logior #x3f00 vinc:$$dtp-complex) ;left-short
    #x0101				   ;right boxed
    (logior #x3f00 vinc:$$dtp-complex) ;right-short
    (logior #x0700 vinc:$$dtc-hairy-number) ;both short codes
    1)

 )