;-*-LISP-*-    Write out the output of CONSLP.

(DECLARE (COND ((STATUS FEATURE LISPM))   ;DO NOTHING ON LISP MACHINE. HA HA
	       ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
		(BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
	       ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
		(LOAD '(MACROS > DSK LISPM))
		(LOAD '(DEFMAC FASL DSK LISPM2))
		(LOAD '(LMMAC > DSK LISPM2))
		(MACROS T))))	;SEND OVER THE REST OF THE MACROS IN THIS FILE

;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).

(DEFUN OUT-MCR MACRO (X)  ;SIMILAR TO OUT, BUT SHIFTS DATA WRITTEN 4 PLACES.
  (LIST 'OUT (CADR X) (LIST 'LSH (CADDR X) 4)))

(DEFUN IN-MCR MACRO (X)
  (LIST 'LSH (LIST 'IN (CADR X)) -4))

(DECLARE (SPECIAL MICRO-CODE-SYMBOL-AREA-BLOCK-NO-FILEPOS
		  CONSLP-OUTPUT CONS-DISP-PARITY-BIT))

(DECLARE (SPECIAL ASSEMBLER-SAVED-STATE))

(DECLARE (FIXNUM (LOGDPB-INTO-FIXNUM FIXNUM FIXNUM FIXNUM)
		 (LOGLDB FIXNUM NOTYPE))
	 (NOTYPE (LOGDPB FIXNUM NOTYPE)))

(IF-FOR-MACLISP
(DEFUN LOGXOR MACRO (X)
  (CONS 'BOOLE (CONS 6 (CDR X)))))

(DEFUN WRITE-MCR ()
  (LET ((FILE (OPEN (LIST '(DSK LISPM1) CONSLP-OUTPUT 'MCR) '(OUT FIXNUM BLOCK))))
    (WRITE-I-MEM (GET 'I-MEM 'ARRAY) 1 FILE)
    (WRITE-D-MEM (GET 'D-MEM 'ARRAY) 2 FILE)
    (WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 FILE)
    (WRITE-A-MEM (GET 'A-MEM 'ARRAY) 4 FILE)
    (WRITE-MICRO-CODE-SYMBOL-AREA-PART-2 FILE)
    (CLOSE FILE))
  (WRITE-SYMBOL-TABLE CONSLP-OUTPUT))

(DEFUN READ-MCR ()
  (LET ((FILE (OPEN (LIST '(DSK LISPM1) CONSLP-OUTPUT 'MCR) '(IN FIXNUM BLOCK))))
     (CONS-LAP-ALLOCATE-ARRAYS)
   (DO ((CODE (IN-MCR FILE) (IN-MCR FILE))
	(USYM-BLOCKS)
	(USYM-PAGNO))
       (NIL)
     (SELECTQ CODE 
        (0 (COND (USYM-PAGNO 
		  (FILEPOS FILE (* USYM-PAGNO 400))
		  (READ-MICRO-CODE-SYMBOL-AREA (GET 'MICRO-CODE-SYMBOL-IMAGE 'ARRAY)
					       FILE
					       USYM-BLOCKS)))
	   (RETURN T))
	(1 (READ-I-MEM (GET 'I-MEM 'ARRAY) FILE))
	(2 (READ-D-MEM (GET 'D-MEM 'ARRAY) FILE))
	(3 (SETQ USYM-BLOCKS (IN-MCR FILE) USYM-PAGNO (IN-MCR FILE)))
	(4 (READ-A-MEM (GET 'A-MEM 'ARRAY) FILE))))
   (READ-SYMBOL-TABLE CONSLP-OUTPUT)
))

(DEFUN WRITE-D-MEM (ARRAY CODE FILE)
    (OUT-MCR FILE CODE)		;Code for this kind of section.
    (OUT-MCR FILE 0)		;Start address.
    (LET ((SIZE (CADR (ARRAYDIMS ARRAY))))
      (DECLARE (FIXNUM SIZE))
      (OUT-MCR FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(DECLARE (FIXNUM I))
	(LET ((VAL (OR (ARRAYCALL T ARRAY I) 0)))
	  (DECLARE (FIXNUM VAL))
	  (OUT-MCR FILE (LOGDPB-INTO-FIXNUM (DO ((COUNT 17. (1- COUNT))
					     (X VAL (LOGXOR VAL (LSH X -1))))
					    ((= COUNT 0)
					     (LOGXOR 1 X))	;ODD PARITY
					  (DECLARE (FIXNUM COUNT X)))
					2101 ;CONS-DISP-PARITY-BIT
					VAL))))))

(DEFUN READ-D-MEM (ARRAY FILE)
   (DO ((ADR (IN-MCR FILE) (1+ ADR))
	(SIZE (IN-MCR FILE) (1- SIZE)))
       ((= SIZE 0))
     (DECLARE (FIXNUM ADR SIZE))
     (STORE (ARRAYCALL T ARRAY ADR) (LOGLDB 2000 (IN-MCR FILE)))))

(DEFUN WRITE-A-MEM (A-ARRAY CODE FILE)
    (OUT-MCR FILE CODE)		;Code for this kind of section.
    (OUT-MCR FILE 0)		;Start address.
    (LET ((SIZE (CADR (ARRAYDIMS A-ARRAY))))
      (DECLARE (FIXNUM SIZE))
      (OUT-MCR FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(DECLARE (FIXNUM I))
	(OUT-MCR FILE (OR (ARRAYCALL T A-ARRAY I) 0)))))

(DEFUN READ-A-MEM (A-ARRAY FILE)
    (DO ((ADR (IN-MCR FILE) (1+ ADR))
	 (COUNT (IN-MCR FILE) (1- COUNT)))
	((= COUNT 0))
      (DECLARE (FIXNUM ADR COUNT))
      (STORE (ARRAYCALL T A-ARRAY ADR) (IN-MCR FILE))))

(DEFUN WRITE-I-MEM (ARRAY CODE FILE)
    (OUT-MCR FILE CODE)		;Code for this kind of section.
    (OUT-MCR FILE 0)		;Start address.
    (LET ((SIZE (CADR (ARRAYDIMS ARRAY))) (TEM))
      (DECLARE (FIXNUM SIZE))
      (DO () ((NOT (NULL (ARRAYCALL T ARRAY (1- SIZE)))))
	(SETQ SIZE (1- SIZE)))
      (OUT-MCR FILE SIZE)
      (DO I 0 (1+ I) (= I SIZE)
	(DECLARE (FIXNUM I))
	(SETQ TEM (OR (ARRAYCALL T ARRAY I) 0))
	(OUT-MCR FILE (LOGLDB 4040 TEM)) ;A part
	(OUT-MCR FILE (LOGLDB 0040 TEM)) ;M part
	)))

(DEFUN READ-I-MEM (ARRAY FILE)
   (DO ((ADR (IN-MCR FILE) (1+ ADR))
	(COUNT (IN-MCR FILE) (1- COUNT)))
       ((= COUNT 0))
     (DECLARE (FIXNUM ADR COUNT))
     (STORE (ARRAYCALL T ARRAY ADR)
	    (LOGDPB (IN-MCR FILE) 4040 (IN-MCR FILE)))))

(DEFUN WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 (FILE)
  (OUT-MCR FILE 3)		;Code for main mem section.
  (OUT-MCR FILE (// (CADR (ARRAYDIMS (GET 'MICRO-CODE-SYMBOL-IMAGE 'ARRAY))) 400)) ;# of blocks
  (SETQ MICRO-CODE-SYMBOL-AREA-BLOCK-NO-FILEPOS (FILEPOS FILE))
  (OUT-MCR FILE -1)		;Block on disk, Filled in later
  (OUT-MCR 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)
  (DO N (\ (FILEPOS FILE) 400) (1+ N) (OR (ZEROP N) (= N 400))  ;Pad to page boundary
    (DECLARE (FIXNUM N))
    (OUT-MCR FILE 0))
  (LET ((FILEPOS (FILEPOS FILE)))
    (FILEPOS FILE MICRO-CODE-SYMBOL-AREA-BLOCK-NO-FILEPOS)
    (OUT-MCR FILE (// FILEPOS 400))
    (FILEPOS FILE FILEPOS))
  (LET ((ARRAY (GET 'MICRO-CODE-SYMBOL-IMAGE 'ARRAY)))
    (DO ((I 0 (1+ I))
	 (N (CADR (ARRAYDIMS ARRAY))))
	((NOT (< I N)))
      (DECLARE (FIXNUM I N))
      (OUT-MCR FILE (ARRAYCALL T ARRAY I)))))

(DEFUN READ-MICRO-CODE-SYMBOL-AREA (ARRAY FILE BLOCKS)
  (DO ((ADR 0 (1+ ADR))
       (SIZE (* BLOCKS 400) (1- SIZE)))
      ((= SIZE 0))
    (DECLARE (FIXNUM ADR SIZE))
    (STORE (ARRAYCALL T ARRAY ADR) (IN-MCR FILE))))

(COMMENT ;because it's in CDMP
(DEFUN CONS-DUMP-FIND-AREA-ORIGIN (AREA)
  (PROG (ADR LST TEM)
	(SETQ ADR 0)
	(SETQ LST AREA-LIST)
   L	(COND ((NULL LST)(BREAK 'CANT-FIND-AREA-ORIGIN T))
	      ((EQ (CAR LST) AREA) (RETURN ADR))
	      ((NULL (SETQ TEM (LIST-ASSQ (CAR LST) RM-AREA-SIZES)))
		(SETQ TEM 1)))
	(SETQ ADR (+ ADR (* (COND (FOR-CADR (// (1+ TEM) 2))  ;COMPUTE REAL CADR PAGES
				  (T TEM))
			    PAGE-SIZE)))
	(SETQ LST (CDR LST))
	(GO L)))
);comment

(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
; Warning: this function also exists in LCADR;QWMCR
(DEFUN WRITE-SYMBOL-TABLE (FILENAME)
  (LET ((OUT-FILE (OPEN (MERGEF '((DSK LISPM1)* USYM) FILENAME) '(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
    (CLOSE OUT-FILE)))

;DOESNT WIN ..  SYMBOL TABLE FORMAT WILL HAVE TO BE IMPROVED..
(DEFUN READ-SYMBOL-TABLE (FILENAME)
  (LET ((INFILE (OPEN (MERGEF '((DSK LISPM1) * USYM) FILENAME) '(IN BLOCK ASCII))))
   (PROG (CODE)
      L0 (SETQ CODE (READ INFILE))
      L  (SELECTQ CODE 
		  (-1 (RETURN T))
		  (-2 (SETQ CODE (READ-SYMBOL-TABLE-SYMBOLS))
		      (GO L))
		  (-4 (SETQ ASSEMBLER-SAVED-STATE (READ INFILE))
		      (GO L0)) ))))


(DEFUN READ-SYMBOL-TABLE-SYMBOLS NIL
  (PROG (SYM TYPE VAL)
    L	(COND ((NUMBERP (SETQ SYM (READ INFILE)))
	       (RETURN SYM)))
    	(SETQ TYPE (READ) VAL (READ))
	(COND ((EQ TYPE 'I-MEM)
	       (SETQ VAL `(I-MEM (FIELD JUMP-ADDRESS-MULTIPLIER ,VAL))))
	      ((EQ TYPE 'A-MEM)
	       (SETQ VAL `(A-MEM (FIELD DISPATCH-ADDRESS-MULTIPLIER ,VAL))))
	      ((EQ TYPE 'M-MEM)
	       (SETQ VAL `(M-MEM (FIELD M-SOURCE-MULTIPLIER ,VAL))))
	      ((EQ TYPE 'D-MEM)
	       (SETQ VAL `(D-MEM (FIELD DISPATCH-ADDRESS-MULTIPLIER ,VAL))))
	      ((EQ TYPE 'NUMBER))
	      (T (PRINT (LIST SYM TYPE VAL))
		 (BREAK BAD-SYMBOL-TYPE T)))
	(PUTPROP SYM VAL 'CONS-LAP-SYM)
	(GO L)))

(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