;;; -*- Mode:LISP; Package:COMPILER; Base:8; Readtable:ZL -*-

;;;    ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;;    ** (c) Copyright 1984 Lisp Machine Inc **
;;;    ** (c) Copyright 1987, GigaMOS Systems Inc. **

;k assembly code is sketched in ORSON:FLEABIT.GENERATE;ASSEM

;transplanted micro-compiler...

(DECLARE (SPECIAL FCTN-NAME CC-MODE
		  QCMP-OUTPUT   
		  CC-WORD-POINTER))

(DEFVAR CC-LAST-OUT NIL)       ;LOOK BEHIND BUFFER 
(DEFVAR CC-LAST-INST-NUMBER NIL)  ;INST NUMBER OF ABOVE
(DEFVAR CC-NEXT-TO-LAST-OUT NIL)
(DEFVAR CC-NEXT-TO-LAST-INST-NUMBER NIL)  ;INST NUMBER OF ABOVE

(defvar *cc-instructions* nil)		;in reversed order
(defvar *entry-points* nil)		;in form suitable for NC:ASSEMBLE-INSTRUCTION-LIST.
					; a list (<number args> . <entry-tag>).
;(defvar *entry-sequence-specbinds* nil)

(DEFVAR INST-NUMBER NIL)       ;# TIMES TO CC-OUT.  FOR DEBUGGING
(DEFVAR INST-STOP-NUMBER NIL)  ;If non-NIL, BKPT on NTH call to CC-OUT

;(defvar cc-label-pdl-slot-flag nil)  	;label next push as temporary variable.
;(defvar cc-temporary-variable-counter 0)

(DEFUN CROSS-COMPILE (FCTN CC-MODE)
 ;this function essentially does no work.  (finding the entry points hardly qualifies..)
  (PROG (FCTN-NAME CC-LAST-OUT CC-NEXT-TO-LAST-OUT 
	 CC-WORD-POINTER INST-NUMBER
	 *cc-instructions* *entry-points* *entry-sequence-specbinds*)
	(SETQ INST-NUMBER 0)
	(SETQ CC-WORD-POINTER FCTN)
   L1	(COND ((NULL CC-WORD-POINTER)  ;PROCESS UP TO BEG OF QUOTE-BASE
	       (FERROR NIL "~%Truncated input before QUOTE-BASE"))
	      ((EQ (CC-1 (CAR CC-WORD-POINTER)) 'ADVANCE) (GO L2)))
	(SETQ CC-WORD-POINTER (CDR CC-WORD-POINTER))
	(GO L1)
   L2	(SETQ CC-WORD-POINTER (CDR CC-WORD-POINTER))
	(COND ((NULL CC-WORD-POINTER)
	       (FERROR NIL "~%Truncated input in QUOTE list"))	;PROCESS QUOTE LIST
	      ((EQ (CC-2 (CAR CC-WORD-POINTER)) 'ADVANCE) (GO L3)))
	(GO L2)
   L3	(SETQ CC-WORD-POINTER (CDR CC-WORD-POINTER))	;FLUSH RANDOM ENDLIST
	(CC-PROCESS-CODE NIL)			;PROCESS CODE
	(CC-OUT NIL)				;UNBUFFER
	(CC-OUT NIL)
	(RETURN (values fctn-name *cc-instructions* *entry-points*))))

(DEFUN CC-PROCESS-CODE (END-TAG)	;PROCESS BODY OF CODE, BUT STOP IF REACH
  (DO-NAMED TOP () (())
    (PROG NIL 		;TAG END-TAG.  THIS FEATURE USEFUL WHEN COMPILING INITIALIZING
				;CODE FOR OPTIONAL ARGS.
       L  (COND ((NULL CC-WORD-POINTER) (RETURN-FROM TOP NIL)))
          (CC-3 (CAR CC-WORD-POINTER))
	  (COND ((AND END-TAG (EQ END-TAG (CAR CC-WORD-POINTER)))
		 (SETQ CC-WORD-POINTER (CDR CC-WORD-POINTER))
		 (RETURN-FROM TOP T)))
	  (SETQ CC-WORD-POINTER (CDR CC-WORD-POINTER))
	  (GO L))))

(DEFUN CC-1 (WD)
  (PROG ()
    L1	(COND ((ATOM WD) (GO E1))
	      ((EQ (CAR WD) 'QTAG)(GO QTAG-1))
	      ((EQ (CAR WD) 'PARAM)
	       (SET (CAR WD) (CADR WD))
	       (GO X1))
	      ((EQ (CAR WD) 'COMMENT) (GO X1))
	      ((EQ (CAR WD) 'ENDLIST) (GO X1))
	      ((EQ (CAR WD) 'MFEF) (GO MFEF1))
	      ((EQ (CAR WD) 'S-V-BLOCK) (GO X1))
	      ((EQ (CAR WD) 'A-D-L) (GO X1))
	      ((EQ (CAR WD) 'QUOTE)(GO X1))	;VAR NAME OR INITIALIZATION
	      ((eq (car wd) 'self-flavor) (go x1))
	      (T  (GO E1)))
  MFEF1 (SETQ FCTN-NAME (SECOND WD))
	;(SETQ BBLKP-EXIT-FLAG (THIRD WD))	;(T IF USED BIND OR SPECIALS)
	;(SETQ ALLVARS (FOURTH WD)
	;      FREEVARS (FIFTH WD))
  X1	(RETURN NIL)
  QTAG-1(COND ((NOT (EQ (CADR WD) 'QUOTE-BASE))(GO X1)))
	(RETURN 'ADVANCE)	;READY FOR QUOTE LIST
  E1	(FERROR NIL "~%Unknown word in CC-1: ~S" WD)
))

(DEFUN CC-2 (WD)		;PROCESS QUOTE-LIST 
  (PROG NIL 
	(COND ((ATOM WD) (GO E1))
	      ((EQ (CAR WD) 'ENDLIST) (RETURN 'ADVANCE)))
   E1	(FERROR NIL "~%Unknown word in CC-2: ~S" WD)
))

(DEFUN CC-3 (WD)		;TRANSLATE CODE
  (PROG ()
	(COND ((NULL WD)
	       (RETURN NIL))
	      ((ATOM WD)
	       (cc-out wd)
	       (return nil))
	      ((and (symbolp (car wd))
		    (or (memq (car wd) '(k:open))	;packages win again!
			(string-equal (si:package-primary-name (symbol-package (car wd)))
				      "K")))
	       (return (cc-out wd)))
	      ((EQ (CAR WD) 'DEBUG-INFO)
	       ;(CC-OUT `(UPARAM ,@ WD))
	       (RETURN NIL))
	      ((eq (car wd) 'entry)
	       (return
		 (let ((tag (gensym)))
		   (push `(,(cadr wd) . ,tag) *entry-points*)
		   (cc-out tag))))
	      ((EQ (CAR WD) 'NO-DROP-THROUGH)
	       (RETURN NIL))
	      ((EQ (CAR WD) 'PARAM) (SET (CAR WD) (CADR WD)) (RETURN NIL))
	      ((eq (car wd) 'variables-used-in-lexical-closures) (return nil))
	      ((eq (car wd) 'breakoffs) (return nil))
	      (t (fsignal "cc-3 ~s" wd))
	      ((EQ (CAR WD) 'RESTART-TAG) (GO RESTART-TAG))
	      ((EQ (CAR WD) 'COMMENT) (RETURN NIL))
	      )
  X1	(RETURN NIL)
))

;;see also K-DEST-FROM-LAP-ADDRESS in CROSS-P2.
;;use move or movei
;(defun k-compute-move (dest adr)
;  (cond ((eq (car adr) 'arg)
;	 (cc-out `(k:move ,dest ,(a-n (cadr adr)) k:boxed-right)))
;	((member adr '( (quote nil) (quote t) ))
;	 (cc-out
;	   `(k:move ,dest ,(make-register-list (cdr (assq (cadr adr)
;							  '( (nil . gr:*nil*)
;							    (t   . gr:*t*)))))
;		    k:boxed-right)))
;	((eq (car adr) 'quote)
;	 (cc-out `(k:movei ,dest ,adr k:boxed)))
;	((eq (car adr) 'special)
;	 (cc-out `(k:movei k:o0 (quote ,(cadr adr)) k:boxed k:ch-open))
;	 (cc-out `(k:call (symbol:%symbol-value 1) ,dest)))
;	((eq (car adr) 'quote-vector)
;	 (k-compute-move dest (cadr adr)))
;	(t (ferror nil "Cant compute move ~s ~s" dest adr))))

;(defun make-register-list (k-register-name)
;  (let ((prop (get k-register-name :register)))
;    `(k:register ,k-register-name ., (cdr prop))))


(DEFUN FIND-POSITION-IN-ASSOC-LIST (ITEM A-LIST)
  (PROG (C)
	(SETQ C 0)
     L	(COND ((NULL A-LIST) (RETURN NIL))
	      ((EQUAL ITEM (CAAR A-LIST)) (RETURN C)))
	(SETQ C (1+ C))
	(SETQ A-LIST (CDR A-LIST))
	(GO L)))

(DEFUN CC-FLUSH-LAST-OUT NIL 
  (PROG1 CC-LAST-OUT
	 (SETQ CC-LAST-OUT CC-NEXT-TO-LAST-OUT
	       CC-LAST-INST-NUMBER CC-NEXT-TO-LAST-INST-NUMBER)
	 (SETQ CC-NEXT-TO-LAST-OUT NIL
	       CC-NEXT-TO-LAST-INST-NUMBER NIL)))

(DEFUN CC-OUT (X) 
  (PROG NIL
	(COND ((EQ (SETQ INST-NUMBER (1+ INST-NUMBER))
		   INST-STOP-NUMBER)
	       (BREAK 'INST-STOP)))
 ;	(COND ((AND (NOT (ATOM X))		;FLUSH MOVE <X>,<X>
 ;		    (CC-NOOP-P X))		;THIS CAN GET GENERATED AS A RESULT
 ;	       (RETURN NIL)))			;OF A (GET-ADR-IN-T 'PDL-POP)
 ;	(SETQ INDICATORS-SET NIL)
	(COND (CC-NEXT-TO-LAST-OUT
		(CC-FINAL-OUT CC-NEXT-TO-LAST-OUT CC-NEXT-TO-LAST-INST-NUMBER)))
	(SETQ CC-NEXT-TO-LAST-OUT CC-LAST-OUT
	      CC-NEXT-TO-LAST-INST-NUMBER CC-LAST-INST-NUMBER)
	(SETQ CC-LAST-OUT X
	      CC-LAST-INST-NUMBER INST-NUMBER)))

;Debugging function
(DEFUN TC (&OPTIONAL (MODE 'PRINT))
  (COND ((EQ MODE 'INPUT)
	 (DOLIST (I (G-L-P QCMP-OUTPUT))
	   (PRINT I)))
	(T
	 (CROSS-COMPILE (G-L-P QCMP-OUTPUT) MODE))))

(DEFUN CC-FINAL-OUT (X INST-NUMBER)
	(COND ((EQ CC-MODE 'PRINT) (FORMAT T "~%~O:~S" INST-NUMBER X))
	      ((eq cc-mode 'store)
	       (push x *cc-instructions*))
	      (T
	       ;(MA-STORE-INST X)
	       )
	      ))

(DEFUN ASSQR (ITEM REVERSED-A-LIST)	;LIKE ASSQ, BUT KEY IN CDAR INSTEAD OF CAAR
   (PROG NIL 
   L	(COND ((NULL REVERSED-A-LIST) (RETURN NIL))
	      ((EQ ITEM (CDAR REVERSED-A-LIST))
	       (RETURN (CAR REVERSED-A-LIST))))
	(SETQ REVERSED-A-LIST (CDR REVERSED-A-LIST))
	(GO L)))