;;; this is in an inconsistent state right now! -*- LISP -*-


(SETQ BASE 8 IBASE 8)		;BARF!

(SETQ MEMORY-SIZE 100000)
(SETQ MEMORY (ARRAY NIL FIXNUM MEMORY-SIZE))

;State registers:	GCSTATE	 EVSTATE
;Control arrays:	GCCONTROL[GCSTATE] EVCONTROL[EVSTATE]

;GC Busses: GCCDR, GCATOM, GCDATA
;EV Busses: EVPTR, EVTYPE

(SETQ GCREGS '(???))					;GC registers
(SETQ EVREGS '(EXP ENV VAL EVLIS PDL LC))		;EV registers

;Each element of the control array is a set of commands in the form of a property list.
;EV Commands:
;In EV processor, the ATOM bit is considered part of the PTR
;	READPTR reg	;gates reg onto PTR bus
;	READTYPE reg
;	WRITEPTR reg	;store into reg from PTR bus
;	WRITETYPE reg
;	NEXT state	;the new state
;	DISPATCH bits
;		bits:	TYPE	TYPE bus
;			ATOM	ATOM bit bus
;			EQ	EQ comparator ???
;			LFCZ	Lookup Frame Counter Zero
;			LSCZ	Lookup Slot Counter Zero
;			SYNC	1 IFF other processor is also doing DISPATCH SYNC
;				If so, busses are connected together for this cycle
;			INTERRUPT  Bit from outside world
;	REQUEST bits	Bits to be dispatched on by GC

;GC Commands:
;In GC processor, the TYPE and PTR fields of EV (but not ATOM) are together called DATA
;	READDATA reg
;	READCDR reg
;	READATOM reg
;	WRITEDATA reg
;	WRITECDR reg
;	WRITEATOM reg
;	NEXT state	;the new state
;	DISPATCH bits
;		bits:	TYPE	TYPE bus
;			ATOM	ATOM bit bus
;			CDR	CDR bus
;			SYNC	1 IFF other processor is also doing DISPATCH SYNC
;				If so, busses are connected together for this cycle
;			REQUEST	Bits from state of EV
;	MEMORY ADDRESS	;push GCPTR bus out to memory
;	MEMORY READ	;read GCPTR/GCTYPE/GCCDR from memory
;	MEMORY WRITE	;write to memory from GC busses
;for now we ignore other memory handshaking problems

;EV registers: EXP, ENV, EVLIS, VAL, PDL, LC
;GC registers: ??

(SETQ INTERRUPT 0)

(DEFUN CHIP (GCSTATE EVSTATE)
       (DO ()
	   (NIL)					;FOREVER
	   (OR (SETQ GCCMDS (CDR (ASSQ GCSTATE GCCONTROL)))
	       (ERROR '|Missing GC State| GCSTATE 'FAIL-ACT))
	   (OR (SETQ EVCMDS (CDR (ASSQ EVSTATE EVCONTROL)))
	       (ERROR '|Missing EV State| EVSTATE 'FAIL-ACT))
	   (SETQ GCCONNECT (EQ (GETCMD GCCMDS 'DISPATCH) 'SYNC))
	   (SETQ EVCONNECT (EQ (GETCMD EVCMDS 'DISPATCH) 'SYNC))
	   (SETQ CONNECTEDP (AND GCCONNECT EVCONNECT))
	   ;;Get sources onto PTR busses
	   (SETQ GCPTR-READ-REG (GETCMD GCCMDS 'READPTR))
	   (SETQ MEMREADP (AND (EQ (GETCMD GCCMDS 'MEMORY) 'READ) '(MEMORY READ)))
	   (AND MEMREADP (SETQ MEMORY-READ-DATA (READ-MEMORY)))
	   (SETQ EVPTR-READ-REG (GETCMD EVCMDS 'READPTR))
	   (AND (OR (AND CONNECTEDP
			 GCPTR-READ-REG
			 EVPTR-READ-REG)
		    (AND GCPTR-READ-REG
			 MEMREADP))
		(ERROR '|PTR Bus Sources Conflict|
		       (DELQ 'NIL (LIST GCPTR-READ-REG MEMREADP EVPTR-READ-REG))
		       'FAIL-ACT))
	   (COND (GCPTR-READ-REG
		  (SETQ GCPTR (SYMEVAL GCPTR-READ-REG))
		  (AND CONNECTEDP (SETQ EVPTR GCPTR))))
	   (COND (MEMREADP
		  (SETQ GCPTR (GET-PTR MEMORY-READ-DATA)
		  (AND CONNECTP (SETQ EVPTR GCPTR))))
	   (COND (EVPTR-READ-REG
		  (SETQ EVPTR (SYMEVAL EVPTR-READ-REG))
		  (AND CONNECTEDP (SETQ GCPTR EVPTR))))
	   ;;Get sources onto TYPE busses
	   (SETQ GCTYPE-READ-REG (GETCMD GCCMDS 'READTYPE))
	   (SETQ EVTYPE-READ-REG (GETCMD EVCMDS 'READTYPE))
	   (SETQ EV-TYPE-CONSTANT (GETCMD EVCMDS 'TYPE))
	   (AND (OR (AND CONNECTEDP
			 (OR GCTYPE-READ-REG MEMREADP)
			 (OR EVTYPE-READ-REG EV-TYPE-CONSTANT))
		    (AND EVTYPE-READ-REG
			 EV-TYPE-CONSTANT)
		    (AND GCTYPE-READ-REG
			 MEMREADP))
		(ERROR '|TYPE Bus Sources Conflict|
		       (DELQ 'NIL (LIST GCTYPE-READ-REG MEMREADP EVTYPE-READ-REG EV-TYPE-CONSTANT))
		       'FAIL-ACT))
	   (COND (GCTYPE-READ-REG
		  (SETQ GCTYPE (SYMEVAL GCTYPE-READ-REG))
		  (AND CONNECTEDP (SETQ EVTYPE GCTYPE))))
	   (COND (MEMREADP
		  (SETQ GCTYPE (GET-TYPE MEMORY-READ-DATA))
		  (AND CONNECTP (SETQ EVTYPE GCTYPE))))
	   (COND (EVTYPE-READ-REG
		  (SETQ EVTYPE (SYMEVAL EVTYPE-READ-REG))
		  (AND CONNECTEDP (SETQ GCTYPE EVTYPE))))
	   (COND (EV-TYPE-CONSTANT
		  (SETQ EVTYPE (SYMEVAL EV-TYPE-CONSTANT))
		  (AND CONNECTEDP (SETQ GCTYPE EVTYPE))))
	   ;;Get source onto GCCDR bus
	   (SETQ GCCDR-READ-REG (GETCMD GCCMDS 'READCDR))
	   (AND GCCDR-READ-REG
		MEMREADP
		(ERROR '|CDR Bus Sources Conflict|
		       (LIST GCCDR-READ-REG MEMREADP)
		       'FAIL-ACT))
	   (COND (GCCDR-READ-REG
		  (SETQ GCCDR (SYMEVAL GCCDR-READ-REG))))
	   (COND (MEMREADP
		  (SETQ GCCDR (GET-CDR MEMORY-READ-DATA))))
	   ;;Write destinations from PTR busses
	   (SETQ GCPTR-WRITE-REG (GETCMD GCCMDS 'WRITEPTR))
	   (SETQ MEMWRITEP (AND (EQ (GETCMD GCCMDS 'MEMORY) 'WRITE) '(MEMORY WRITE)))
	   (SETQ EVPTR-WRITE-REG (GETCMD EVCMDS 'WRITEPTR))
	   (AND (OR (AND CONNECTEDP
			 GCPTR-WRITE-REG
			 EVPTR-WRITE-REG)
		    (AND GCPTR-WRITE-REG
			 MEMWRITEP))
		(ERROR '|PTR Bus Destinations Conflict|
		       (DELQ 'NIL (LIST GCPTR-WRITE-REG MEMWRITEP EVPTR-WRITE-REG))
		       'FAIL-ACT))
	   (AND (EQ GCPTR-WRITE-REG GCPTR-READ-REG)
		GCPTR-WRITE-REG
		(ERROR '|Read/write from Same PTR Register| GCPTR-WRITE-REG 'FAIL-ACT))
	   (AND (EQ EVPTR-WRITE-REG EVPTR-READ-REG)
		EVPTR-WRITE-REG
		(ERROR '|Read/write from Same PTR Register| EVPTR-WRITE-REG 'FAIL-ACT))
	   (COND (GCPTR-WRITE-REG
		  (SET GCPTR-WRITE-REG GCPTR)))
	   (COND (EVPTR-WRITE-REG
		  (SET EVPTR-WRITE-REG EVPTR)))
	   ;;Write destinations from TYPE busses
	   (SETQ GCTYPE-WRITE-REG (GETCMD GCCMDS 'WRITETYPE))
	   (SETQ EVTYPE-WRITE-REG (GETCMD EVCMDS 'WRITETYPE))
	   (AND (OR (AND CONNECTEDP
			 GCTYPE-WRITE-REG
			 EVTYPE-WRITE-REG)
		    (AND GCTYPE-WRITE-REG
			 MEMWRITEP))
		(ERROR '|TYPE Bus Destinations Conflict|
		       (DELQ 'NIL (LIST GCTYPE-WRITE-REG MEMWRITEP EVTYPE-WRITE-REG))
		       'FAIL-ACT))
	   (AND (EQ GCTYPE-WRITE-REG GCTYPE-READ-REG)
		GCTYPE-WRITE-REG
		(ERROR '|Read/write from Same TYPE Register| GCTYPE-WRITE-REG 'FAIL-ACT))
	   (AND (EQ EVTYPE-WRITE-REG EVTYPE-READ-REG)
		EVTYPE-WRITE-REG
		(ERROR '|Read/write from Same TYPE Register| EVTYPE-WRITE-REG 'FAIL-ACT))
	   (COND (GCTYPE-WRITE-REG
		  (SET GCTYPE-WRITE-REG GCTYPE)))
	   (COND (EVTYPE-WRITE-REG
		  (SET EVTYPE-WRITE-REG EVTYPE)))
	   ;;Write destinations from CDR busses
	   (SETQ GCCDR-WRITE-REG (GETCMD GCCMDS 'WRITECDR))
	   (AND GCCDR-WRITE-REG
		MEMWRITEP
		(ERROR '|CDR Bus Destinations Conflict|
		       (LIST GCCDR-WRITE-REG MEMWRITEP)
		       'FAIL-ACT))
	   (AND (EQ GCCDR-WRITE-REG GCCDR-READ-REG)
		GCCDR-WRITE-REG
		(ERROR '|Read/write from Same CDR Register| GCCDR-WRITE-REG 'FAIL-ACT))
	   (COND (GCCDR-WRITE-REG
		  (SET GCCDR-WRITE-REG GCCDR)))
	   ;;Write to memory if appropriate
	   (COND (MEMWRITEP
		  (WRITE-MEMORY (PUT-WORD GCCDR GCTYPE GCPTR)))
		 ((EQ (GETCMD GCCMDS 'MEMORY) 'ADDRESS)
		  (SETQ MEMORY-ADDRESS GCPTR)))
	   ;;Check for DECREMENT hack
	   (SETQ DECREMENT (GETCMD EVCMDS 'DECREMENT))
	   (AND DECREMENT
		(COND ((EQ DECREMENT 'LFC)
		       (DECREMENT-LFC))
		      ((EQ DECREMENT 'LSC)
		       (DECREMENT-LSC))
		      (T (ERROR '|Bad DECREMENT Register| DECREMENT 'FAIL-ACT))))
	   ;;Hack DISPATCH quantities
	   (SETQ EQ-BIT (COND ((= EVLIS VAL) 1) (T 0)))
	   (SETQ LFCZ-BIT (COND ((LFC-ZEROP) 1) (T 0)))
	   (SETQ LSCZ-BIT (COND ((LSC-ZEROP) 1) (T 0)))
	   (SETQ GCSYNC (COND (EVCONNECT 1) (T 0)))
	   (SETQ EVSYNC (COND (GCCONNECT 1) (T 0)))
	   (SETQ REQUEST (OR (SYMEVAL (GETCMD EVCMDS 'REQUEST)) 0))
	   ;;Perform state transitions
	   (SETQ GCDISP (GETCMD GCCMDS 'DISPATCH))
	   (SETQ EVDISP (GETCMD EVCMDS 'DISPATCH))
	   (SETQ GCSTATE
		 (MUNCH-STATE 'GC
			      GCCMDS
			      (GETCMD GCCMDS 'NEXT)
			      (AND GCDISP
				   (COND ((EQ GCDISP 'TYPE) GCTYPE)
					 ((EQ GCDISP 'CDR) GCCDR)
					 ((EQ GCDISP 'SYNC) GCSYNC)
					 ((EQ GCDISP 'REQUEST) REQUEST)
					 (T (ERROR '|Invalid GC DISPATCH Type|
						   GCDISP
						   'FAIL-ACT))))))
	   (SETQ EVSTATE
		 (MUNCH-STATE 'EV
			      EVCMDS
			      (GETCMD EVCMDS 'NEXT)
			      (AND EVDISP
				   (COND ((EQ EVDISP 'TYPE) EVTYPE)
					 ((EQ EVDISP 'EQ) EQ-BIT)
					 ((EQ EVDISP 'SYNC) EVSYNC)
					 ((EQ EVDISP 'LFCZ) LFCZ-BIT)
					 ((EQ EVDISP 'LSCZ) LSCZ-BIT)
					 ((EQ EVDISP 'INTERRUPT) INTERRUPT)
					 (T (ERROR '|Invalid EV DISPATCH Type|
						   EVDISP
						   'FAIL-ACT))))))
	   ))	;END OF DO AND DEFUN

(DEFUN MUNCH-STATE (WHO CMDS NEXT DISP)
       (COND ((NULL NEXT)
	      (ERROR '|Missing NEXT Component| (LIST WHO CMDS) 'FAIL-ACT))
	     ((NULL DISP) NEXT)
	     (T (IMPLODE (NCONC (EXPLODEN NEXT)
				(LIST '-)
				(EXPLODEN DISP))))))

(DEFUN GETCMD (CMDS WHICH)
       (CADR (ASSQ WHICH CMDS)))

;;; Here are assumptions about the word format for the simulation:
;;;	total word: 36. bits
;;;	cdr:	     3. bits
;;;	type:	     6. bits
;;;	ptr:	    27. bits
;;;		each lookup counter has 12. bits

(DEFUN DECREMENT-LFC ()
       (SETQ LC (+ (BOOLE 2 77770000 LC)
		   (BOOLE 1 77770000 (- LC 10000)))))

(DEFUN DECREMENT-LSC ()
       (SETQ LC (+ (BOOLE 2 7777 LC)
		   (BOOLE 1 7777 (- LC 1)))))

(DEFUN LFC-ZEROP ()
       (ZEROP (BOOLE 1 77770000 LC)))

(DEFUN LSC-ZEROP ()
       (ZEROP (BOOLE 1 7777 LC)))

(DEFUN PUT-WORD (XCDR TYPE PTR)
       (+ (LSH (BOOLE 1 7 XCDR) 41)
	  (LSH (BOOLE 1 77 TYPE) 33)
	  (BOOLE 1 777777777 PTR)))

(DEFUN GET-CDR (WORD)
       (LSH WORD -41))

(DEFUN GET-TYPE (WORD)
       (BOOLE 1 77 (LSH WORD -33)))

(DEFUN GET-PTR (WORD)
       (BOOLE 1 777777777 WORD))

;;; Memory interface

(DEFUN READ-MEMORY ()
       (AND (OR (< MEMORY-ADDRESS 0)
		(NOT (< MEMORY-ADDRESS MEMORY-SIZE)))
	    (ERROR '|Illegal Memory Address| MEMORY-ADDRESS 'FAIL-ACT))
       (ARRAYCALL FIXNUM MEMORY MEMORY-ADDRESS))

(DEFUN WRITE-MEMORY (WORD)
       (AND (OR (< MEMORY-ADDRESS 0)
		(NOT (< MEMORY-ADDRESS MEMORY-SIZE)))
	    (ERROR '|Illegal Memory Address| MEMORY-ADDRESS 'FAIL-ACT))
       (STORE (ARRAYCALL FIXNUM MEMORY MEMORY-ADDRESS) WORD))

;;; Preprocessor for Control Programs

(DEFUN PREPROCESS (CONTROL)
       (MAPCAR '(LAMBDA (CMDS)
			(OR (ATOM (CAR CMDS))
			    (RPLACA CMDS (MUNCH-STATE (CAAR CMDS) (SYMEVAL (CADAR CMDS))))))
	       CONTROL))

(DEFUN ENUMERATE (X)
       (DO ((L X (CDR L))
	    (N 0 (+ N 1)))
	   ((NULL L))
	   (SET (CAR L) N)))

;;; Microcode for SCHEME Machine

(ENUMERATE '(SELFEVAL LOCALVAR GLOBALVAR CODE IFEXP CALL CLOSURE))
(ENUMERATE '(CAR? CDR? CONSA? CONSD? RPLACA? RPLACD? RPLAC?))


(SETQ EVCONTROL
      (PREPROCESS '(
(START (READTYPE EXP) (DISPATCH TYPE) (NEXT START1))
((START1 SELFEVAL) (READPTR EXP) (READTYPE EXP) (WRITEPTR VAL) (WRITETYPE VAL) (NEXT POPJ))
((START1 GLOBALVAR) (READPTR EXP) (REQUEST CAR?) (HANG) (NEXT GLOBALVAR1))
  (GLOBALVAR1 (WRITEPTR VAL) (WRITETYPE VAL) (HANG) (NEXT POPJ))
((START1 CODE) (READPTR EXP) (READTYPE EXP) (REQUEST CONSA?) (HANG) (NEXT CODE1))
  (CODE1 (READPTR ENV) (READTYPE ENV) (REQUEST CONSD?) (HANG) (NEXT CODE2))
  (CODE2 (WRITEPTR VAL) (WRITETYPE VAL) (TYPE CLOSURE) (HANG) (NEXT POPJ))
((START1 IFEXP) (READPTR EXP) (READTYPE EXP) (REQUEST CONSA?) (HANG) (NEXT IFEXP1))
  (IFEXP1 (READPTR ENV) (READTYPE ENV) (REQUEST CONSA?) (HANG) (NEXT IFEXP2))
  (IFEXP2 (READPTR PDL) (READTYPE PDL) (REQUEST CONSD?) (HANG) (NEXT IFEXP3))
  (IFEXP3 (WRITEPTR PDL) (WRITETYPE PDL) (TYPE PDL-IF1) (HANG) (NEXT IFEXP4))
  (IFEXP4 (READPTR EXP) (READTYPE EXP) (REQUEST CAR?) (HANG) (NEXT IFEXP5))
  (IFEXP5 (WRITEPTR EXP) (WRITETYPE EXP) (HANG) (DISPATCH TYPE) (NEXT START1))

((START1 LOCALVAR) ...)




)))

(SETQ GCCONTROL
      (PREPROCESS '(
)))