;-*- Mode:LISP; Package:MICRO-ASSEMBLER; Base:8 -*-
;Write out the output of CONSLP.
;This is the Lisp machine version of WMCR.  It's a different file
;because so much had to be changed.

;For now, the reading side is flushed.  It exists elsewhere anyway, doesn't it?

;An MCR file looks a lot like a microcode partition.  Each 36-bit word
;contains one 32-bit word, left-justified.  (Being left justified makes
;it a whole lot easier to gobble the file with the real machine).
;From the Lisp machine, we write this as 2 16-bit pieces

(DECLARE (SPECIAL CONSLP-OUTPUT-SYMBOL-PREDICTED-FILEPOS
		  CONSLP-OUTPUT-CURRENT-FILEPOS
		  CONSLP-OUTPUT VERSION-NUMBER CONS-DISP-PARITY-BIT
		  CONSLP-OUTPUT-PATHNAME))

(DECLARE (SPECIAL ASSEMBLER-SAVED-STATE))

(DEFUN OUT16 (FILE BYTE)
  (SETQ CONSLP-OUTPUT-CURRENT-FILEPOS (1+ CONSLP-OUTPUT-CURRENT-FILEPOS))
  (FUNCALL FILE ':TYO BYTE))

(DEFUN OUT32 (FILE WORD)
  (OUT16 FILE (LDB 2020 WORD))	;Note non-standard order of 16-bit bytes
  (OUT16 FILE (LDB 0020 WORD)))

;obsolete entry function
(DEFUN WRITE-MCR (BASE-VERSION-NUMBER)
  (WRITE-MCR-FILE (FUNCALL CONSLP-OUTPUT-PATHNAME ':NEW-TYPE-AND-VERSION
				   "MCR" VERSION-NUMBER)
		  BASE-VERSION-NUMBER))

(DEFUN WRITE-MCR-FILE (PATHNAME BASE-VERSION-NUMBER)
  (PKG-BIND "MICRO-ASSEMBLER"			;Try to reduces :s in symtab, etc.
    (WITH-OPEN-FILE (FILE PATHNAME
			  '(:OUT :FIXNUM))			
      (LET ((CONSLP-OUTPUT-CURRENT-FILEPOS 0))
	(COND (BASE-VERSION-NUMBER
	       (OUT32 FILE 3)	;a fake main memory block
	       (OUT32 FILE 0)	; blocks to xfer
	       (OUT32 FILE 0)	; normally relative disk block, 0 says base version follows
	       (OUT32 FILE BASE-VERSION-NUMBER)))
	(WRITE-I-MEM I-MEM 1 FILE)
	(WRITE-D-MEM D-MEM 2 FILE)
	(WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 FILE)
	(WRITE-A-MEM A-MEM 4 FILE)
	(WRITE-MICRO-CODE-SYMBOL-AREA-PART-2 FILE)))
    (WRITE-SYMBOL-TABLE-FILE (FUNCALL PATHNAME ':NEW-TYPE "SYM"))))

(DEFUN WRITE-D-MEM (ARRAY CODE FILE)
    (OUT32 FILE CODE)		;Code for this kind of section.
    (OUT32 FILE 0)		;Start address.
    (LET ((SIZE (ARRAY-LENGTH ARRAY)))
      (OUT32 FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(LET ((VAL (OR (AREF ARRAY I) 0)))
	  (OUT16 FILE	   ;High bit and parity bit
		 (DPB (DO ((COUNT 17. (1- COUNT))
			   (X VAL (LOGXOR VAL (LSH X -1))))
			  ((= COUNT 0)
			   (LOGXOR 1 X)))	;ODD PARITY
		      0101
		      (LDB 2001 VAL)))
	  (OUT16 FILE VAL) ;Low 16 bits
	  ))))

(DEFUN WRITE-A-MEM (A-ARRAY CODE FILE)
    (OUT32 FILE CODE)		;Code for this kind of section.
    (OUT32 FILE 0)		;Start address.
    (LET ((SIZE (ARRAY-LENGTH A-ARRAY)))
      (OUT32 FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(OUT32 FILE (OR (AREF A-ARRAY I) 0)))))

(DEFUN WRITE-I-MEM (ARRAY CODE FILE)
    (OUT32 FILE CODE)		;Code for this kind of section.
    (OUT32 FILE 0)		;Start address.
    (LET ((SIZE (ARRAY-LENGTH ARRAY)) (TEM))
      (DO () ((NOT (NULL (AREF ARRAY (1- SIZE)))))
	(SETQ SIZE (1- SIZE)))
      (OUT32 FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(SETQ TEM (OR (AREF ARRAY I) 0))
	(OUT16 FILE (LDB 6020 TEM))	;A high
	(OUT16 FILE (LDB 4020 TEM))	;A low
	(OUT16 FILE (LDB 2020 TEM))	;M high
	(OUT16 FILE (LDB 0020 TEM))	;M low
	)))

(DEFUN WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 (FILE)
  (OUT32 FILE 3)		;Code for main mem section.
  (OUT32 FILE (TRUNCATE (ARRAY-LENGTH MICRO-CODE-SYMBOL-IMAGE) 400)) ;# of blocks
  (SETQ CONSLP-OUTPUT-SYMBOL-PREDICTED-FILEPOS
	(+ CONSLP-OUTPUT-CURRENT-FILEPOS
	   4 ;rest of this block
	   6 ;A/M header
	   4000 ;A/M data
	   ))
  (OUT32 FILE (TRUNCATE (+ CONSLP-OUTPUT-SYMBOL-PREDICTED-FILEPOS 777) 1000)) ;Rel disk block #
  (OUT32 FILE (CONS-DUMP-FIND-AREA-ORIGIN 'MICRO-CODE-SYMBOL-AREA))) ;Phys mem address

;Call this after everything else, to put the micro code symbol area at the end
(DEFUN WRITE-MICRO-CODE-SYMBOL-AREA-PART-2 (FILE)
  (OR (= CONSLP-OUTPUT-CURRENT-FILEPOS CONSLP-OUTPUT-SYMBOL-PREDICTED-FILEPOS)
      (BREAK "LOSSAGE"))
  (DO N (\ CONSLP-OUTPUT-CURRENT-FILEPOS 1000)
        (1+ N) (OR (ZEROP N) (= N 1000))  ;Pad to page boundary
    (OUT16 FILE 0))
  (LET ((ARRAY MICRO-CODE-SYMBOL-IMAGE))
    (DO ((I 0 (1+ I))
	 (N (ARRAY-LENGTH ARRAY))
	 (FIXNUM-DATA-TYPE (DPB DTP-FIX %%Q-DATA-TYPE 0)))
	((NOT (< I N)))
      (OUT32 FILE (+ FIXNUM-DATA-TYPE (COND ((AREF ARRAY I)) (T 0)))))))

(DECLARE (SPECIAL I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC 
		  A-CONSTANT-LOC A-CONSTANT-BASE M-CONSTANT-LOC M-CONSTANT-BASE 
		  D-MEM-FREE-BLOCKS M-CONSTANT-LIST A-CONSTANT-LIST))

;This writes an ascii file containing the symbol table
(DEFUN WRITE-SYMBOL-TABLE-FILE (PATHNAME &AUX (BASE 8) (IBASE 8))
  (WITH-OPEN-FILE (OUT-FILE PATHNAME
			    '(:OUT :BLOCK :ASCII))
    (PRINT -4 OUT-FILE)	;ASSEMBLER STATE INFO
    (PRINT (MAKE-ASSEMBLER-STATE-LIST) OUT-FILE)
    (PRINT -2 OUT-FILE)
    (CONS-DUMP-SYMBOLS OUT-FILE)
    (PRINT -1 OUT-FILE)		;EOF
    ))

(DEFUN MAKE-CONSTANT-LIST (LST)   ;FLUSH USAGE COUNT, LAST LOCN REF'ED AT.
   (MAPCAR (FUNCTION (LAMBDA (X)
			 (LIST (CAR X) (CADR X))))
	   LST))

;CONS-DUMP-SYMBOLS IN CDMP