;;; -*- 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 ALLVARS FREEVARS CC-MODE
  MAX-ARGS MIN-ARGS SLOTLIST LOCAL-BLOCK-INDEX 
  NUMBER-PUSHED-ARGS PUSHED-CALLS-LIST
  MAX-IP-PDL-LEVEL SV-NAME-LIST 

  INDICATORS-SET SPECBIND-FLAG QCMP-OUTPUT   
  CC-TOP-PDL-LEVEL CC-DROPTHRU BBLKP-EXIT-FLAG 
  INHIBIT-OPTIMIZATION-FLAG 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)

(SETQ INHIBIT-OPTIMIZATION-FLAG NIL)	;AVOID ANY UNBOUND LOSSAGE

;The :DEPEND-ON-BEING-MICROCOMPILED property.  --flush

;When destination D-LAST is stored into, this is how we figure out what is happening.
(DEFSTRUCT (PUSHED-CALL-INFO :LIST)
   PC-TARGET-FUNCTION  ;If a symbol, function being called.  Otherwise list attempts
  		       ; to give some idea for debugging.
   PC-NUMBER-PUSHED-ARGS ;Saved value pertaining to previously nested call.
			 ; Currently active value lives in NUMBER-PUSHED-ARGS. 
   PC-DEST
   PC-N-VALS
   PC-RESTART-PC	;Only valid on MACRO-CALL
   PC-TAIL-CALL-SWITCH	;call to D-RETURN and no special variables to unwind.
  )

;Binding "timing" for SPECIAL variables (particularily as it relates to initializing
;code for optional arguments).  Microcompiled functions form the complete argument
;list on the PDL, then transfer the values to SPECIAL cells just before starting
;the main code body.  Thus the variable environment seen by code which initializes
;optional arguments is not identical to the macrocompiled case, but usually it
;doesn't matter.  The microcompiler always references (SPECIAL FOO) and MA
;does the best it can by referencing the PDL slot until the SPECIAL-binding is actually done.

(DEFUN CROSS-COMPILE (FCTN CC-MODE)
  (PROG (FCTN-NAME ALLVARS FREEVARS MAX-ARGS MIN-ARGS 
	 SLOTLIST CC-TOP-PDL-LEVEL CC-DROPTHRU
	 LOCAL-BLOCK-INDEX NUMBER-PUSHED-ARGS PUSHED-CALLS-LIST CC-LAST-OUT 
	 CC-NEXT-TO-LAST-OUT 
	 MAX-IP-PDL-LEVEL SV-NAME-LIST INDICATORS-SET SPECBIND-FLAG BBLKP-EXIT-FLAG 
	 CC-WORD-POINTER INST-NUMBER
	 *cc-instructions* *entry-points* *entry-sequence-specbinds*)
		;SPECBIND-FLAG IS T IF FCTN BINDS SPECIAL VARIABLES AND THUS
		;EXIT MUST CHECK TO SEE IF BINDING BLOCK OPEN AND IF SO, POP IT.
	(COND ((NEQ CC-MODE 'PRINT)
	       ;(MA-CODE-RESET)
	       ))
	(SETQ INST-NUMBER 0)
	(SETQ LOCAL-BLOCK-INDEX 0)		;COUNTER FOR LOCAL-BLOCK SLOTS
	(SETQ CC-DROPTHRU T)			;NIL IF JRST HAS BEEN COMPILED SO
						;CONTROL CAN NOT DROP THRU UNTIL TAG
						;GENERATED
	(SETQ NUMBER-PUSHED-ARGS 0)
	(SETQ MAX-IP-PDL-LEVEL 0)
	(SETQ MAX-ARGS (SETQ MIN-ARGS 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-OUT `(UPARAM FUNCTION-NAME ,FCTN-NAME))
	;(CC-ARG-SETUP)				;SET UP INITIAL SLOTLIST 
	;(CC-OUT `(UPARAM %MINARGS ,MIN-ARGS))
	;(CC-OUT `(UPARAM %MAXARGS ,MAX-ARGS))
	;(CC-OUT `(UPARAM ALLVARS  ,ALLVARS))
	(CC-PROCESS-CODE NIL)			;PROCESS CODE
   	;(CC-OUT `(UPARAM %MAX-IP-PDL-LEVEL ,MAX-IP-PDL-LEVEL))
	(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
 ;(grind-top-level cc-word-pointer)
  (SETQ CC-TOP-PDL-LEVEL (LENGTH SLOTLIST));"TOP-LEVEL" PDL LEVEL
  (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 (TEM TEM1)
	(COND ((NULL WD) (RETURN NIL))
	      ((ATOM WD) (GO TAG))
	      ((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)
	       (SETQ CC-DROPTHRU NIL)	;believe it..
	       (RETURN NIL))
	      ((EQ (CAR WD) 'PARAM) (SET (CAR WD) (CADR WD)) (RETURN NIL))
	      (t (fsignal "cc-3 ~s" wd))
	      ((EQ (CAR WD) 'RESTART-TAG) (GO RESTART-TAG))
	      ((EQ (CAR WD) 'COMMENT) (RETURN NIL))
  ;	      ((NULL CC-DROPTHRU)
  ;	       (RETURN NIL))	;CANT GET HERE ANYWAY.  THIS MAY CAUSE SOME LOSSAGE, THO.
	      ((EQ (CAR WD) 'BRANCH) (GO B1))
	      ((EQ (CAR WD) 'SETE) (RETURN (CC-SETE (CADR WD) (CADDR WD))))
	      ((EQ (CAR WD) 'CALL) (RETURN (CC-CALL NIL (CADR WD) (CADDR WD) NIL NIL)))
	      ((EQ (CAR WD) 'CALL0) (RETURN (CC-CALL0 (CADR WD) (CADDR WD))))
	      ((EQ (CAR WD) 'MOVE) (RETURN (CC-MOVE (CADR WD) (CADDR WD))))
	      ((MEMQ (CAR WD) '(CAR CDR CADR CDDR CDAR CAAR))
	       (RETURN (CC-CXR (CAR WD) (CADR WD) (CADDR WD))))
	      ((EQ (CAR WD) 'MOVEM) (RETURN (CC-MOVEM (CADDR WD))))
    ;	      ((MEMQ (CAR WD) '(*PLUS *DIF *TIMES *QUO *LOGAND *LOGXOR *LOGIOR))
    ;	       (RETURN (CC-ARITH (CAR WD) (CADDR WD))))
    ;	      ((MEMQ (CAR WD) '(= EQ > <))
    ;	       (RETURN (CC-PRED (CAR WD) (CADDR WD))))
	      ((EQ (CAR WD) 'BINDPOP)
	       (CLEARAC)
	       (RETURN (CC-OUTPUT-BIND 'POP (CC-VAR-ADR (CADDR WD)))))
	      ((EQ (CAR WD) 'BINDNIL)
	       (CLEARAC)
	       (RETURN (CC-OUTPUT-BIND 'NIL (CC-VAR-ADR (CADDR WD)))))
	      ((SETQ TEM (ASSQ (CAR WD) '((SETNIL .  A-V-NIL)
					  (SETZERO . (QUOTE 0)))))
	       (RETURN (CC-STORE-CONST (CDR TEM) (CADDR WD))))
	      ((EQ (CAR WD) 'PUSH-E)
	       (RETURN (CC-PUSH-E (CADDR WD))))
	      ((EQ (CAR WD) 'MISC)
	       (RETURN (CC-MISC (CADR WD) (CDDR WD))))
	      ((EQ (CAR WD) 'MISC1)
	       (RETURN (CC-MISC1 (CADR WD) (CDDR WD))))
	      ((EQ (CAR WD) 'POP) (RETURN (CC-POP (CADDR WD))))
	      ((EQ (CAR WD) 'ADI-CALL)
	       (RETURN (CC-ADI (CDR WD))))
	      ((EQ (CAR WD) 'NO-OP) (RETURN NIL))
	      ((eq (car wd) 'push-number)
	       (return (cc-push-number (cadr wd))))
  ;	      ((eq (car wd) 'label-pdl-slot)
  ;	       (return (cc-label-pdl-slot)))
	      ((eq (car wd) 'activate-open-call)
	       (return (cc-activate-open-call (cadr wd))))
	      ((eq (car wd) 'entry-sequence-specbinds)
	       (return (setq *entry-sequence-specbinds* (cadr wd))))
	      ((consp (car wd))
	       (return (cc-process-declaration (car wd))))
	      (T (BARF WD 'UNKNOWN-INST 'BARF)))	;BIND
  B1	(CC-BRANCH (CADR WD) (CADDR WD) (CADDDR WD) (CAR (LAST WD)))
  X1	(RETURN NIL)
  RESTART-TAG
	(LOADAC)
	(SETQ WD (CADR WD))
	(GO RESTART-TAG-1)
  TAG 	(CLEARAC)
  RESTART-TAG-1 
	(CC-OUT WD)
	(SETQ TEM (LENGTH SLOTLIST))
	(IF (NULL (GET WD 'CC-USED)) 
	    (COND ((NOT (= TEM CC-TOP-PDL-LEVEL))
		   (PUTPROP WD TEM 'CC-PDLLVL)))
	    (SETQ TEM1 (COND ((GET WD 'CC-PDLLVL)) (T CC-TOP-PDL-LEVEL)))
	    (COND ((NOT (= TEM TEM1))
		   (CC-ADJUST-SLOTLIST (- TEM TEM1))
		   (COND (CC-DROPTHRU (BARF WD 'SLOT-LIST-LOSES-AT-TAG 'BARF))))))
	(SETQ CC-DROPTHRU T)
	(GO X1)
))

(defun cc-process-declaration (decl-list) decl-list
  nil)		;hopefully, this decl info has previously been picked up by below construct.

(defun cc-get-following-declaration (prop-key)
  (and (consp (cadr cc-word-pointer))
       (consp (car (cadr cc-word-pointer)))
       (get-from-alternating-list (caar (cadr cc-word-pointer)) prop-key)))

;while translating a macro-instruction, the next <pseudo> macro-instruction may have the
; type declarations which apply to the current macro-instruction.  This somewhat kludgish
; frob looks for them and returns them if they are there.
(defun cc-declaration-info (var-spec &aux tem)
  (cond ((and (consp (cadr cc-word-pointer))	   
	      (consp (car (cadr cc-word-pointer))))
	 (car (cadr cc-word-pointer)))
	((and var-spec (setq tem (var-spec-type-from-declaration var-spec)))
	 `((type-specifier ,tem)))))

(DEFUN CC-TYPE-SPECIFIER-FROM-INFO-LIST (INFO-LIST)
 "Extract just the type-specifier from info-list, if any. (There might be other stuff there 
in case of CALL, etc"
  (LET ((TEM (ASSQ 'TYPE-SPECIFIER INFO-LIST)))
    (IF TEM (LIST TEM))))

(DEFUN CC-MERGE-TYPE-SPECIFIERS (IL1 IL2)
  (LET ((TS1 (ASSQ 'TYPE-SPECIFIER IL1))
	(TS2 (ASSQ 'TYPE-SPECIFIER IL2)))
    (COND ((AND TS1 TS2)
	   (IF (NOT (EQ (CADR TS1) (CADR TS2)))
	       (FERROR NIL "MERGED TYPES DIFFERS"))
	   (LIST TS1))
	  (TS1 (LIST TS1))
	  (TS2 (LIST TS2)))))

(DEFUN CC-ARG-SETUP NIL
  ;now just sets up slotlist, compiles no code.
  (PROG (TEM KIND TYPE) ;ARG-SPEC-FLAG T MEANS WE HAVE LOOKED TO
					;SEE IF WE NEED A SPECBIND AFTER ARGS INITED.
	(SETQ TEM ALLVARS)
    L	(COND ((NULL TEM) (GO X1)))
        (SETQ KIND (VAR-KIND (CAR TEM))
	      TYPE (VAR-TYPE (CAR TEM)))
  ;	(COND ((AND (NOT (MEMQ KIND '(FEF-ARG-REQ FEF-ARG-OPT)))
  ;		    (NULL ARG-SPEC-FLAG))
  ;		(CC-PROCESS-SPEC-BLOCK)	;THRU WITH ARGS
  ;		(SETQ ARG-SPEC-FLAG T)))
	(COND ((EQ TYPE 'FEF-SPECIAL)			;REMOTE???
	       (SETQ SV-NAME-LIST
		     (NCONC SV-NAME-LIST (LIST (CAAR TEM))))))
	(COND ((EQ KIND 'FEF-ARG-REQ)
	       (GO REQ-ARG))
	      ((EQ KIND 'FEF-ARG-OPT)
	       (GO OPT-ARG))
	      ((EQ KIND 'FEF-ARG-AUX)
	       (GO AUX-ARG))
	      ((EQ KIND 'FEF-ARG-FREE)
	       (GO L3))
	      ((MEMQ KIND '(FEF-ARG-INTERNAL FEF-ARG-INTERNAL-AUX))
	       (COND ((NOT (EQ TYPE 'FEF-SPECIAL)) ;REMOTE???
		      (GO AUX-ARG))))	;IF LOCAL, TAKES LOCAL SLOT, ETC
	      (T (BARF (CAR TEM) 'CC-ARG-SETUP 'BARF)))
    L3	(SETQ TEM (CDR TEM))
	(GO L)
    X1
  ;	(COND ((NULL ARG-SPEC-FLAG)
  ;	       (CC-PROCESS-SPEC-BLOCK)))
	(RETURN NIL)

    REQ-ARG	(SETQ MIN-ARGS (1+ MIN-ARGS))
    opt-arg-1	(PUSH-SLOTLIST 1 (LIST 'ARG (CAAR TEM)))
    		(SETQ MAX-ARGS (1+ MAX-ARGS))	;opt-arg-1 was here for microcompiler.
		(GO L3)
    OPT-ARG
  ;		(CC-OUT `(OPTIONAL-ARG-JUMP-GREATER R (CONSTANT ,(LENGTH SLOTLIST))
  ;				 (UTAG ,(SETQ TEM2 (GENSYM)))))
  ;		(SETQ LAP-ADR (CC-COM-INIT (CAR TEM)))
  ;		(RPLACA SLOTLIST (LIST 'ARG (CAAR TEM)))  ;doesnt do hack about compiling opt arg to stack, etc.
  ;		(CLEARAC)
  ;		(CC-OUT TEM2)
 ;		(CC-OUT `(CREATE-CUBBYHOLE ,LAP-ADR))
		(GO OPT-ARG-1)    
    AUX-ARG
 ;		(CC-OUT '(START-CUBBYHOLE))
 ;		(CC-OUT `(CREATE-CUBBYHOLE ,(CC-COM-INIT (CAR TEM))))
		(COND ((EQ TYPE 'FEF-SPECIAL) ;REMOTE???
		       (setq specbind-flag t)
		       ;(CC-OUTPUT-BIND 'INITIALIZING-POP (CC-SV-ADR (CAAR TEM)))
		       )
		      ((EQ TYPE 'FEF-LOCAL)
			(RPLACA SLOTLIST (LIST 'LOCVAR (CAAR TEM))))
		      (T (BARF (CAR TEM) 'CC-ARG-SETUP 'BARF)))
		(SETQ LOCAL-BLOCK-INDEX (1+ LOCAL-BLOCK-INDEX))
		(GO L3)
))

(DEFUN CC-OUTPUT-BIND (TYPE ADR)
  (declare (ignore type adr))
  (fsignal "dont do binds this way anymore!")
;  (SELECTQ TYPE
;    (POP (CC-OUT `(BNDPOP ,ADR))
;	 (POP-SLOTLIST 1 'D-PDL))
;    (INITIALIZING-POP (CC-OUT `(BNDPOP ,ADR))
;		      (POP-SLOTLIST 1 'INIT-VAR))
;    (NIL (CC-OUT `(BNDNIL ,ADR))))
;  (SETQ SPECBIND-FLAG T)
  )

;(DEFUN CC-PROCESS-SPEC-BLOCK NIL
;  (COND (SV-NAME-LIST
;	  (CLEARAC)
;	  (SETQ SPECBIND-FLAG T)
;	  (CC-OUT '(DO-SPECBIND)))))

;(COMMENT (DEFUN CC-PROCESS-SPEC-BLOCK NIL
;  (PROG (TEM PDL-INDEX)  
;	(COND ((NULL SV-NAME-LIST) (RETURN NIL)))
;	(CLEARAC)
;	(SETQ SPECBIND-FLAG T)
;	(CC-OUT '(JSP S (CC-LINKAGE SPECBN)))	;VALUE CELLS NOW.  **
;	(SETQ PDL-INDEX 0)
;	(SETQ TEM SLOTLIST)
;  L	(COND ((NULL TEM) (RETURN NIL))
;	      ((MEMQ (CADAR TEM) SV-NAME-LIST) 
;	       (CC-OUT-INST 0 PDL-INDEX (CC-SV-ADR (CADAR TEM)))))   ;**
;	(SETQ PDL-INDEX (1+ PDL-INDEX))
;   	(SETQ TEM (CDR TEM))
;	(GO L))))

;initializing for optional or aux arg.
; returns LAP-ADR for CREATE-CUBBYHOLE.
;(DEFUN CC-COM-INIT (VAR)	;COMPILE INITIALIZATION AND LEAVE IT ON TOP OF STACK
;  (PROG (INIT INIT-TYPE LAP-ADR)
;	(SETQ INIT (VAR-INIT VAR)
;	      INIT-TYPE (CAR INIT)
;	      LAP-ADR (VAR-LAP-ADDRESS VAR))
;	(CLEARAC)
;	(COND ((EQ INIT-TYPE 'FEF-INI-NONE)
;	       (GO NO-INIT))
;	      ((EQ INIT-TYPE 'FEF-INI-NIL)
;	       (GO INIT-NIL))
;	      ((EQ INIT-TYPE 'FEF-INI-PNTR)
;	       (GO INIT-PNTR))
;	      ((EQ INIT-TYPE 'FEF-INI-C-PNTR)
;	       (GO INIT-C-PNTR))
;	      ((EQ INIT-TYPE 'FEF-INI-SELF)
;	       (GO INIT-SELF))
;	      ((EQ INIT-TYPE 'FEF-INI-COMP-C)
;	       (GO NO-INIT))
;	      ((EQ INIT-TYPE 'FEF-INI-OPT-SA)
;   ;Note!! if generating input to microcompiler, compiler will leave variable on stack
;   ;  at end of variable initalizing code.  Normally, it would POP it into its home.
;   ;  This would cause the microcompiler to bomb since the home doesnt exist yet.
;	       (CC-PROCESS-CODE (CADR INIT))	;OPTIONAL STARTING ADR
;	       (CLEARAC)
;	       (POP-SLOTLIST 1 'D-PDL)
;  ;	       (COND ((EQ (VAR-KIND VAR) 'FEF-ARG-OPT) ;TOTAL HACK.  R MAY HAVE BEEN CLOBBERED
;  ;		      (CC-OUT '(MOVE R (CONSTANT 0) NIL)))); AND ONCE ONE OPT ARG IS
;						;COMPUTED, REST MUST BE TOO.
;	       (GO X1))
;	      ((EQ INIT-TYPE 'FEF-INI-EFF-ADR)
;	       (CC-OUT-MOVE 'MOVE '(PUSH-PDL SLOT) (CC-VAR-ADR (CADR INIT)) NIL)
;	       (GO X1))
;	      (T (BARF VAR 'CC-COM-INIT 'BARF)))
;    NO-INIT 
;    INIT-NIL	(CC-OUT '(MOVE (PUSH-PDL SLOT) (QUOTE NIL) NIL))
;    X1		(PUSH-SLOTLIST 1 '(INIT-VAR **FOO**))
;		(RETURN LAP-ADR)
;    INIT-PNTR 	(CC-OUT-MOVE 'MOVE '(PUSH-PDL SLOT) (CADR INIT) NIL)
;		(GO X1)
;    INIT-C-PNTR	(CC-OUT-MOVE 'MOVE
;			     '(PUSH-PDL SLOT)
;			     (LET ((I (CADR INIT)))
;			       (COND ((EQ (CAR I) 'LOCATIVE-TO-S-V-CELL)
;				      (CONS 'SPECIAL (CDR I)))
;				     (T I)))
;			     NIL)
;;THIS WINS BECAUSE (CADR A-G-PNTR) IS TYPICALLY (SPECIAL XXX) AS OPPOSED TO INIT-PNTR
;;CASE WHERE IT IS (QUOTE XXX).  THUS, THE LEVEL OF ADDRESSING DIFFERENCE IS EFFECTIVELY
;;HANDLED BY MA.
;		(GO X1)
;    INIT-SELF	(CC-OUT-MOVE 'MOVE '(PUSH-PDL SLOT) (CC-SV-ADR (VAR-NAME VAR)) NIL)
;		(GO X1)
;))


(DEFUN CC-PUSH-E (ADR)
  (CLEARAC)
  (CC-OUT `(MOVE-LOCATIVE-T ,(CC-VAR-ADR ADR)))
  (PUSH-SLOTLIST 1 '(D-PDL **FOO**))
 )

(DEFUN CC-POP (ADR)
  (COND ((CC-PUSH-P CC-LAST-OUT)	;PUSH, POP -> MOVE, MOVEM
	 ;THIS IS A TAD FASTER.
	 (CC-OUT-MOVE 'MOVE (CC-VAR-ADR ADR) (CADDR (CC-FLUSH-LAST-OUT))
		      (CC-DECLARATION-INFO ADR)))
	((CC-MOVE-T-P CC-LAST-OUT)   ;Collapse into previous instruction if possible.
	 (CC-OUT-MOVE 'MOVE (CC-VAR-ADR ADR) (CADDR (CC-FLUSH-LAST-OUT))
		      (CC-DECLARATION-INFO ADR)))
	(T		;** THIS HAS PROBLEMS.  Should not convert slot adr.
	  (CC-OUT-MOVE 'MOVE (CC-VAR-ADR ADR) '(PDL-POP)
		       (CC-DECLARATION-INFO ADR))))
  (POP-SLOTLIST 1 'D-PDL)
  )


(defun cc-push-number (number)
  (clearac)
  (cc-out `(move t (constant ,(dpb dtp-fix %%q-data-type number)) NIL))
  (push-slotlist 1 '(d-pdl **foo**)))

(defun cc-internal-floor-1 (round-code)
  (clearac)
  (cc-out `(move m-1 (constant ,round-code) NIL))
  (pop-slotlist 2 'd-pdl)
  (cc-out '(call (pops 2) nil (cc-linkage xfloor-1-uc-entry)))
  (push-slotlist 1 '(d-pdl **foo**))    ;logically, value is on stack.
)

(defun cc-internal-floor-2 (round-code)
  (clearac)
  (cc-out `(move m-1 (constant ,round-code) NIL))
  (cc-out '(call nil nil (cc-linkage xfloor-2-uc-entry)))
  ;pop two pdl slots then push two, no net effect.
)

(DEFUN CC-MOVEM (ADR)
  (LET ((INFO-LIST (CC-DECLARATION-INFO ADR)))
    (COND ((NOT (CC-PUSH-T-P CC-LAST-OUT))	;*** ???
	   (CC-OUT '(MOVE T (0 PP) NIL))))
    (CC-OUT-MOVE 'MOVE (CC-VAR-ADR ADR) 'k:r0	;T
		 INFO-LIST)
  ))

(DEFUN CC-STORE-CONST (CONST ADR)
  (CC-OUT-MOVE 'MOVE (CC-VAR-ADR ADR) CONST NIL))

;due to lossages in the compiler, it sometimes outputs the symbol PDL-POP and sometimes
; the list (PDL-POP).  Its not easy to fix due to P2ARGC pecularities.
(DEFUN PDL-POP-P (ADR)
  (OR (EQ ADR 'PDL-POP)
      (EQUAL ADR '(PDL-POP))))

(DEFUN CC-MOVE (DEST ADR)
  (cond ((k-destination-p dest)
	 (k-compute-move dest adr))
	(t
	 (PROG (k-dest) 
	       (COND ((AND (EQ DEST 'D-LAST)
			   (PDL-POP-P ADR))
		      (SETQ NUMBER-PUSHED-ARGS (1+ NUMBER-PUSHED-ARGS))
		      (POP-SLOTLIST 1 'D-PDL)
		      (PUSH-SLOTLIST 1 '(C-F-ARG **FOO**))	;FAKE OUT PDL ERROR CHECKING
		      (RETURN (CC-DEST-LAST k-dest)))	;COMPILE BETTER CODE FOR THIS CASE
		     ((AND (EQ DEST 'D-PDL)
			   (PDL-POP-P ADR))
		      (RETURN NIL)))		;A NO-OP, FLUSH.  ALSO, THIS DOESNT SEEM TO WORK
	       (LET ((INFO-LIST (CC-DECLARATION-INFO ADR)))
		 (GET-ADR-IN-T ADR INFO-LIST)	; IN THE HARDWARE!!
		 (CC-STORE-T-IN-DEST DEST k-dest INFO-LIST))))))

;dtp-nil data type on K is assigned code 0.  Thus NIL is all zeros.

(DEFUN CC-BRANCH (CONDITION SENSE POP-IF-NO-JUMP ADR)
  (PROG (INST TEM AC)
	(CLEARAC)
	(COND ((EQ CONDITION 'ALWAYS)
	       (CC-OUTJ 'k:branch ADR)
	       (RETURN NIL))
	      ((eq condition 'nilind)
	       (setq inst (cond ((eq sense 'true) 'k:br-zero)
				((eq sense 'false) 'k:br-not-zero)
				(t (go e1))))
	       (cc-out `(k:test ,inst))
	       (cc-outj 'k:branch adr))
;	      ((EQ CONDITION 'NILIND)
;	       (SETQ INST (COND ((EQ SENSE 'TRUE) 'JUMP-EQUAL)
;				((EQ SENSE 'FALSE) 'JUMP-NOT-EQUAL)
;				(T (GO E1))))
;	       (SETQ AC (COND ((AND (SETQ TEM CC-LAST-OUT)
;				    (CONSP TEM)
;				    (EQ (CAR TEM) 'MOVE)
;				    (ATOM (CADR TEM)))
;			       (CC-FLUSH-LAST-OUT)
;			       (CADDR TEM))
;			      (T (RESULT-ADDRESS))))
;	       (SELECTQ AC  ;This not only is an optimization but also avoids trying to
;			    ; reference A-V-NIL from the M side.
;		 (A-V-NIL (IF (EQ INST 'JUMP-EQUAL)
;			      (CC-OUTJ 'JUMP NIL NIL ADR)))
;		 (A-V-TRUE (IF (EQ INST 'JUMP-NOT-EQUAL)
;			       (CC-OUTJ 'JUMP NIL NIL ADR)))
;		 (OTHERWISE
;		  (CC-OUTJ INST AC 'A-V-NIL ADR))))
;	      ((EQ CONDITION 'ATOMIND)
;	       (SETQ INST (COND ((EQ SENSE 'TRUE) 'JUMP-IF-ATOM)
;				((EQ SENSE 'FALSE) 'JUMP-IF-NOT-ATOM)
;				(T (GO E1))))
;	       (SETQ AC (COND ((AND (SETQ TEM CC-LAST-OUT)
;				    (CONSP TEM)
;				    (EQ (CAR TEM) 'MOVE)
;				    (ATOM (CADR TEM)))
;			       (CC-FLUSH-LAST-OUT)
;			       (CADDR TEM))
;			      (T (RESULT-ADDRESS))))
;	       (IF (MEMQ AC '(A-V-NIL A-V-TRUE))
;		   (IF (EQ INST 'JUMP-IF-ATOM)
;		       (CC-OUTJ 'JUMP NIL NIL ADR))
;		   (CC-OUTJ INST AC NIL ADR)))
	      (T (GO E1)))
	(COND (POP-IF-NO-JUMP
		(CC-OUT '(DISCARD-TOP-OF-STACK))
		(POP-SLOTLIST 1 'D-PDL)))
	(RETURN NIL)
  E1	(BARF (LIST CONDITION SENSE POP-IF-NO-JUMP ADR) 'CC-BRANCH 'BARF)))


;A conditional branch has just been encountered.  Figure out what register
;holds the quantity being tested.  This is a bit painful since the macrocode
;uses condition code type conditions, while the microcode tests registers.
(DEFUN RESULT-ADDRESS ()
  (PROG (INST)
	(COND ((SYMBOLP CC-LAST-OUT)		;a merge in flow of control
	       (SETQ INST CC-NEXT-TO-LAST-OUT)
	       (COND ((ATOM INST) (GO E1))
		     ((EQ (CAR INST) 'MOVE)
		      (COND ((AND (CONSP (CADR INST))
				  (EQ (CAR (CADR INST)) 'PUSH-PDL))
			     (RETURN '(TOP-OF-PDL)))
			    (T (RETURN (CADR INST)))))
		     (T (GO X1)))))
	(SETQ INST CC-LAST-OUT)
	(COND ((ATOM INST) (GO E1))
	      ((EQ (CAR INST) 'MOVE)
	       (COND ((OR (SYMBOLP (CADR INST))	;Try to get register on push or pop
			  (EQUAL (CADDR INST) '(PDL-POP)))	;no "active" source.
		      (RETURN (CADR INST)))
		     (T (RETURN (CADDR INST))))))
  X1	(COND ((MEMQ (CAR INST) '(MOVE-LOCATIVE-T CALL ARG-CALL))
	       (RETURN 'k:r0	;T
		       ))
	      (T (GO E1)))
     E1	(RETURN 'k:r0
		;T
		)	;crufty nested conditionals can cause this. result in T.
	;(FERROR NIL "RESULT-ADDRESS")
	))

(DEFUN CC-ADI (X)
  (PROG (ADI TM MISC-TYPE ADR N-VALS CALL-TYPE RESTART-PC DEST) 
	(SETQ MISC-TYPE (CAR X))	;TYPE CALL INST WOULD HAVE USED
	(SETQ ADI (CADDDR X))
	(SETQ ADR (CADDR X))
	(SETQ DEST (CADR X))
	(COND ((NOT (AND (EQ (CAR ADR) 'QUOTE-VECTOR)
			 (MEMBER (SETQ TM (CADR ADR))
				 '(  (*FUNCELL *CATCH) ))))
;		(QLP2-U (LIST 'MOVE 'D-PDL ADR))
 )
	      (T (SETQ MISC-TYPE '%CATCH-OPEN)))
	(COND ((SETQ TM (MEMQ-ALTERNATE 'RESTART-PC ADI))
	       ;(QLP2-U (LIST 'MOVE 'D-PDL (CADR TM)))
	       (SETQ RESTART-PC (CADR TM))
	       (COND ((NOT (MEMQ MISC-TYPE '(%CATCH-OPEN)))
		      (BARF TM 'BAD-ADI-CALL-WITH-RESTART-PC 'BARF))) ))
	(COND ((MEMQ-ALTERNATE 'FEXPR-CALL ADI)
	       (COND ((NOT (EQ MISC-TYPE 'CALL))
		      (BARF MISC-TYPE 'BAD-FEXPR-ADI 'BARF)))
	       (SETQ CALL-TYPE 'FEXPR)
	       (SETQ MISC-TYPE '%FEXPR-CALL)))
	(COND ((MEMQ-ALTERNATE 'LEXPR-CALL ADI)
	       (COND ((NOT (EQ MISC-TYPE 'CALL))
		      (BARF MISC-TYPE 'BAD-LEXPR-ADI 'BARF)))
	       (SETQ CALL-TYPE 'LEXPR)
	       (SETQ MISC-TYPE '%LEXPR-CALL)))
	(COND ((SETQ TM (MEMQ-ALTERNATE 'MULTIPLE-VALUE ADI))
	       ;(QLP2-U (LIST 'MOVE 'D-PDL (CADR TM)))
	       (SETQ N-VALS (CADR (CADR (CADR TM))))
	       (SETQ MISC-TYPE (CDR (ASSQ MISC-TYPE '( (CALL . %CALL-MULT-VALUE)
						      (CALL0 . %CALL0-MULT-VALUE)
						      (%FEXPR-CALL . %FEXPR-CALL-MV)
						      (%LEXPR-CALL . %LEXPR-CALL-MV)
						      (%CATCH-OPEN . %CATCH-OPEN-MV) ) ))) ))
	(COND ((MEMQ MISC-TYPE '(NIL CALL CALL0))
		(BARF X 'BAD-ADI 'BARF)))
	(COND ((NOT (MEMQ MISC-TYPE '(%CALL0-MULT-VALUE %CALL-MULT-VALUE 
				     ;%CATCH-OPEN %CATCH-OPEN-MV
				     )))
	       (BARF X 'NOT-IMPLEMENTED-MC 'BARF))
	      (T (CC-CALL-MULT DEST MISC-TYPE N-VALS ADR CALL-TYPE RESTART-PC)))
))

(DEFUN CC-CALL-MULT (DEST TYPE N-VALS ADR CALL-TYPE RESTART-PC)
  (PROG NIL 
	(CC-CALL N-VALS DEST ADR CALL-TYPE RESTART-PC)
	(COND ((EQ TYPE '%CALL0-MULT-VALUE) (CC-DEST-LAST nil)))	;k-dest
))

(DEFUN CC-CALL (N-VALS DEST ADR CALL-TYPE RESTART-PC) CALL-TYPE ;avoid warning.
				;N-VALS NIL FOR OLD TYPE, N FOR N VALUES
				;CALL-TYPE NIL OR FEXPR OR LEXPR
				;RESTART-PC NIL OR TAG TO RESTART AT.
  (PROG (TARGET TARGET-ADDRESS tail-call-switch) 
	(CLEARAC)
	(SETQ TARGET-ADDRESS (CC-VAR-ADR ADR))
	(SETQ TARGET (COND ((AND (CONSP TARGET-ADDRESS)
				 (EQ (CAR TARGET-ADDRESS) 'FUNCTION))
			    (CADR TARGET-ADDRESS))
			   (T '(CANT FIGURE IT OUT))))
	(cond ((setq tail-call-switch (and (eq dest 'd-return)
					   (null bblkp-exit-flag)
					   (null specbind-flag)))
	       (setq dest 'return)))	;tail call doesnt really have a destination.
  ;however, setting dest to a k-destination will avoid it trying to do a dest last, etc.
  MACRO-CALL
	(COND ((AND (NOT (EQ TARGET-ADDRESS 'k:r0 	 ;compiled FUNCALL  ****
			     		     ;T
			     ))
		    (CONSP TARGET-ADDRESS)
		    (NOT (MEMQ (CAR TARGET-ADDRESS) '(QUOTE FUNCTION SPECIAL))))
	       (CC-OUT-MOVE 'MOVE 'k:r0
			    ;T
			    TARGET-ADDRESS NIL)
	       (SETQ TARGET-ADDRESS 'k:r0
		     ;T
		     )))
	(COND (RESTART-PC 
		(COND ((NOT (EQ TARGET '*CATCH)) 
		       (BARF TARGET 'BAD-TARGET-WITH-RESTART-PC 'BARF))
		      ((NULL N-VALS)
		       (CC-OUT-MOVE 'MOVE 'S `(CONSTANT (UTAG ,(CDR (CADR RESTART-PC)))) NIL) ;***
		       (PUSH-SLOTLIST 4 '(RESTART-PC **FOO**))  ;2 FOR BIND-STACK-LEVEL
		       (CC-OUT `(CALL (PUSHES ,(+ 4 %LP-CALL-BLOCK-LENGTH))
				      NIL (CC-LINKAGE UCTO)))
		       (PUSH-SLOTLIST %LP-CALL-BLOCK-LENGTH '(C-F **FOO**))
		       (GO RESTART-1))
		      (T
			(CC-OUT-MOVE 'MOVE 'S `(CONSTANT (UTAG ,(CDR (CADR RESTART-PC)))) NIL)
			(PUSH-SLOTLIST N-VALS '(D-PDL **FOO**))
			(PUSH-SLOTLIST 4 '(RESTART-PC **FOO**))  ;2 FOR BIND-STACK-LEVEL
			(PUSH-SLOTLIST 2 '(M-V-INFO **FOO**))
			(CC-OUT `(ARG-CALL (PUSHES ,(+ N-VALS 6 %LP-CALL-BLOCK-LENGTH))
					   N-VALS D-UCTOM))
			(PUSH-SLOTLIST %LP-CALL-BLOCK-LENGTH '(C-F **FOO**))
			(GO RESTART-1)))))
	(COND (N-VALS
	       (fsignal "foo")
	       (CC-OUT `(OPEN-CALL-MV (PUSHES ,(+ N-VALS 2 %LP-CALL-BLOCK-LENGTH))
					       ,N-VALS ,TARGET-ADDRESS))
	       (PUSH-SLOTLIST N-VALS '(D-PDL **FOO**))
	       (PUSH-SLOTLIST 2 '(M-V-INFO **FOO**)))
	      (tail-call-switch
	       (cc-out `(k:tail-open)))
	      ((eq dest 'k:o0)
	       (setq dest '(k:new-open 0)))
	      (T (CC-OUT `(K:OPEN ;(PUSHES ,%LP-CALL-BLOCK-LENGTH)
			    	     ;0
			    	     ;,TARGET-ADDRESS
			    ))))
	(PUSH-SLOTLIST %LP-CALL-BLOCK-LENGTH '(C-F **FOO**))
  RESTART-1
	(SETQ PUSHED-CALLS-LIST 
	  (CONS 
	   (LIST ;'MACRO-CALL
		 TARGET			;pc-target-function
		 NUMBER-PUSHED-ARGS	;pc-number-pushed-args
		 DEST			;pc-dest
		 N-VALS			;pc-n-vals
		 RESTART-PC		;pc-restart-pc
		 tail-call-switch	;pc-tail-call-switch
		 )
	   PUSHED-CALLS-LIST))
  X1	(SETQ NUMBER-PUSHED-ARGS 0)
	(RETURN NIL)
	))

(DEFUN CC-CALL0 (DEST ADR)
  (let ((k-dest nil))
    (CC-CALL NIL DEST ADR NIL NIL)
    (CC-DEST-LAST k-dest)))

(DEFUN CC-CXR (OP DEST ADR)
  (PROG (k-dest) 
	(GET-ADR-IN-T ADR)
	(CC-CALL-OUT 1 '((ARGS 1)) 'MISC-ENTRY 
		(CDR (ASSQ OP '((CAR . M-CAR)
				(CDR . M-CDR)
				(CAAR . M-CAAR)
				(CADR . M-CADR)
				(CDAR . M-CDAR)
				(CDDR . M-CDDR)))))
	(CC-STORE-T-IN-DEST DEST k-dest NIL)))

(DEFUN CC-RETURNS (DEST TYPE)		;NOTE: THIS FUNCTION IS A COMPLETE HACK
  (PROG (TEM k-dest)
	(CLEARAC)			;CROCK. NOTE THAT MUST BE A NOOP IN CASE OF
					;RETURN N
	(COND ((EQ TYPE 'RETURN-NEXT-VALUE)
	       (POP-SLOTLIST 1 'D-PDL)
	       (CC-OUT '(RETURN-NEXT-VALUE-OR-EXIT))
	       (CC-STORE-T-IN-DEST DEST k-dest NIL))
	      ((EQ TYPE '%RETURN-N)
	       (SETQ TEM (CADR (CADDR CC-LAST-OUT)))	;GET ACTUAL NUMBER OF VALUES
	       (CC-FLUSH-LAST-OUT)
	       (POP-SLOTLIST 1 'D-PDL)
	       (POP-SLOTLIST TEM 'D-PDL)
	       (CC-OUT-MOVE 'MOVE 'C `(CONSTANT ,TEM) NIL)
	       (CC-OUT `(RETURN-N-VALUES-AND-EXIT ,TEM))
	       (SETQ CC-DROPTHRU NIL))
	      ((EQ TYPE '%RETURN-2)
	       (POP-SLOTLIST 2 'D-PDL)
	       (CC-OUT '(RETURN-2-VALUES-AND-EXIT))
	       (SETQ CC-DROPTHRU NIL))
	      (T (POP-SLOTLIST 3 'D-PDL)
		 (CC-OUT '(RETURN-3-VALUES-AND-EXIT))
		 (SETQ CC-DROPTHRU NIL)))
))

	
(DEFUN CC-MISC (DEST TAIL)
  (PROG (MISC-FCTN NARGS k-dest)
	(SETQ MISC-FCTN (CAR TAIL))
	(COND ((MEMQ MISC-FCTN '(%RETURN-2 %RETURN-3 %RETURN-N RETURN-NEXT-VALUE))
	       (RETURN (CC-RETURNS DEST MISC-FCTN))))
	(CLEARAC)
	(COND ((OR (NULL MISC-FCTN)
		   (EQ MISC-FCTN 'FALSE))
	       (CC-OUT '(MOVE T (QUOTE NIL) NIL))
	       (GO X1))
	      ((EQ MISC-FCTN 'UNBIND)
	       (CC-UNBIND (1+ (CADR TAIL)))
	       (GO X1))
	      ((eq misc-fctn 'INTERNAL-FLOOR-1)
	       (cc-internal-floor-1 (ldb (byte 2 14.) dest))
	       (go x2))		;do not store in dest
	      ((eq misc-fctn 'INTERNAL-FLOOR-2)
	       (cc-internal-floor-2 (ldb (byte 2 14.) dest))
	       (go x2))		;do not store in dest
	      ((EQ MISC-FCTN '%SPREAD) ;only wins for LEXPR-FUNCALL.
	       (IF  (NEQ DEST 'D-LAST) (BARF DEST 'BAD-SPREAD 'BARF)) 
	       (LOADAC)		;CC-SPREAD takes arg in T
	       (POP-SLOTLIST 1 'D-PDL)
	       (CC-DEST-LAST k-dest 'SPREAD)
	       (GO X2))
	      ((AND (NULL (SETQ NARGS (GET MISC-FCTN 'QINTCMP)))
		    (NULL (CDR TAIL)))
		(BARF TAIL 'UNKNOWN-MISC 'BARF))
;	      ((EQ MISC-FCTN 'APPLY) (GO APPLY))
	      ((EQ MISC-FCTN 'BIND) (GO BIND))
	      ((NULL (CDR TAIL)) (GO X3))
	      (T (FERROR NIL "BAD MISC")
		 (GO X3A)))
 X3	(CC-CALL-OUT NARGS `((ARGS ,NARGS)) 'MISC-ENTRY MISC-FCTN)
 X3A	(POP-SLOTLIST NARGS 'D-PDL)
	(GO X1)
 BIND	(CC-CALL-OUT NARGS `((ARGS ,NARGS)) 'CC-LINKAGE 'XMBIND)
	(GO X3A)
; APPLY	(CC-CALL-OUT NARGS `((ARGS ,NARGS)) 'CC-LINKAGE 'UAPLY)
;	(GO X3A)
  X1	(CC-STORE-T-IN-DEST DEST k-dest NIL)
  X2   ))

(DEFUN CC-MISC1 (DEST TAIL)
  (PROG (MISC-FCTN NARGS k-dest)
	(SETQ MISC-FCTN (CAR TAIL))
	(cond ((memq misc-fctn '(%internal-list %internal-list*
				 %internal-list-in-area %internal-list*-in-area))
	       (let ((info (cc-get-following-declaration '%internal-list-args)))
		 (setq nargs (+ (car info) (if (cadr info) 2 1))))
  ;	       (cond ((or (not (eq (car cc-last-out) 'move))
  ;			  (not (ma-fixnum-constantp (third cc-last-out))))
  ;		      (barf cc-last-out 'unknown-before-%internal-list 'barf)))
   ;** this doesnt win for the -in-area frobs.  For now, it just bombs out.
  ;	       (setq nargs (1+ (ldb (byte 10. 0) (cadr (third cc-last-out)))))
	       (go x3)))
	(CLEARAC)
	(COND ((AND (NULL (SETQ NARGS (GET MISC-FCTN 'QINTCMP)))
		    (NULL (CDR TAIL)))
	       (if (null (setq nargs (get misc-fctn 'arglist)))
		   (BARF TAIL 'UNKNOWN-MISC 'BARF)
		 (setq nargs (length nargs))
		 (go x3)))
	      ((NULL (CDR TAIL)) (GO X3))
	      (T (FERROR NIL "BAD MISC")
		 (GO X3A)))
 X3	(CC-CALL-OUT NARGS `((ARGS ,NARGS)) 'MISC-ENTRY MISC-FCTN)
 X3A	(POP-SLOTLIST NARGS 'D-PDL)
 	(CC-STORE-T-IN-DEST DEST k-dest NIL)
	))
	
(DEFUN CC-UNBIND (NUM)
  (CC-OUT `(POP-SPECPDL ,NUM)))

(DEFUN CC-SETE (OP ADR)
 (LET ((VAR-ADR (CC-VAR-ADR ADR)))
   (CLEARAC)
   (COND ((MEMQ (CAR VAR-ADR) '(ARG LOCAL))	;If internal to processor, open code it
	  (CC-OUT-MOVE 'MOVE '(PUSH-PDL D-PDL) VAR-ADR NIL)
	  (LET ((M-OP (ASSQ OP '((CDR . M-CDR) (CDDR . M-CDDR)))))
	    (CC-CALL-OUT 1 '((ARGS 1)) 'MISC-ENTRY (IF M-OP (CDR M-OP) OP)))
	  (CC-OUT-MOVE 'MOVE VAR-ADR 'k:r0
		       ;T
		       NIL))
	 (T (CC-OUT `(,(CDR (ASSQ OP '((CDR . SECDR) (CDDR . SECDDR)
				       (1+ . SE1+) (1- . SE1-))))
		      ,VAR-ADR))))))

(DEFUN CC-ARITH (OP ADR)	;COMPILER SHOULDNT OUTPUT THESE WHEN MICROCOMPILING
  (BARF (LIST OP ADR) 'ADDRESSABLE-ARITH 'BARF))

(DEFUN CC-ADJUST-ADR (ADR AMT)
  (COND ((AND (EQ (CADR ADR) 'PP)
	      (NUMBERP (CAR ADR)))
	   (CONS (+ (CAR ADR) AMT) (CDR ADR)))
	(T ADR)))

(DEFUN CC-PRED (OP ADR)
  (GET-ADR-IN-T ADR)
  (CC-OUT `(CALL (POPS 1) ((ARGS 2)) ,(CDR (ASSQ OP '((= . (CC-LINKAGE QMEQL))
						      (EQ . (CC-LINKAGE QMEQ))
						      (< . (CC-LINKAGE QMLSP))
						      (> . (CC-LINKAGE QMGRP)))))))
  (POP-SLOTLIST 1 'D-PDL)
  (SETQ INDICATORS-SET T))  ;These just leave T or NIL in T.  Its not clear you can do
			    ; better, so this should probably be flushed. 

;PUT NEW --GENERATORS HERE


(DEFUN CC-OUT-EXIT NIL
  (fsignal "lose")	;this supposed to be handled by main compiler now.
  (COND ((AND (NULL BBLKP-EXIT-FLAG)
	      (NULL SPECBIND-FLAG))
	 (CC-OUT ;'(EXIT)
	   '(k:move k:return k:r0 k:boxed-right k:ch-return k:next-pc-return)
		 ))
	(T ;(CC-OUT '(POP-SPECPDL-AND-EXIT))	  ;POP BLOCK IF ONE OPEN
	 (let ((n *entry-sequence-specbinds*))
	   (case n
	     (0)
	     (1 (cc-out `(k:open-call (li:unbind-1 0) k:ignore nil)))
	     (t (let ((reg-ref (k-find-constant-register n)))
		  (cond (reg-ref
			 (cc-out `(k:open-call (li:unbind 1) k:ignore (k:o0 ,reg-ref k:boxed-right))))
			(t (cc-out `(k:movei k:o0 (quote ,n) k:boxed k:ch-open))
			   (cc-out `(k:call (li:unbind 1) k:ignore nil))))))))
	 (cc-out '(k:nop))
	 (cc-out '(k:move k:return-tail k:a0 k:boxed-right k:ch-return k:next-pc-return))))
  (SETQ CC-DROPTHRU NIL))

;does not hack slotlist at all.
(DEFUN CC-CALL-OUT (NUMBER-POPS CALL-INFO-LIST TYPE ENTRY)
  (PROG (TEM) 
	(cond ((setq tem (cc-declaration-info nil))
	       (setq call-info-list (append tem call-info-list))))
     	(COND ((SETQ TEM (GET ENTRY 'LAST-ARG-IN-T-ENTRY))
	       (GO T2)))
     T1	(CLEARAC)
	(CC-OUT `(CALL (POPS ,NUMBER-POPS) ,CALL-INFO-LIST (,TYPE ,ENTRY)))
	(RETURN NIL)
     T2	(COND ((CC-PUSH-T-P CC-LAST-OUT)
	       (CC-FLUSH-LAST-OUT)
	       (GO X1))
	      ((CC-CHANGE-PUSH-TO-MOVE-T)		;SAVE TIME OF PUSH FOLLOWED BY POP
	       (GO X1))
	      (T (GO T1)))
     X1	(COND ((ZEROP NUMBER-POPS)
	       (FERROR NIL "called last arg in t entry with 0 pops")))
     	(CC-OUT `(CALL (POPS ,(1- NUMBER-POPS)) 
		,CALL-INFO-LIST (CC-LINKAGE ,TEM))) ;comp for push on way in
	))

(DEFUN GET-ADR-IN-T (ADR &OPTIONAL INFO-LIST)
  (declare (ignore info-list))
  (PROG (TEM)
	(CLEARAC)
	(SETQ TEM (CC-VAR-ADR ADR))
	(COND ((AND (NOT (ATOM CC-LAST-OUT))
		    (EQ (CAR CC-LAST-OUT) 'MOVE)
		    (EQ (CADDR CC-LAST-OUT) 'k:r0
			;T
			)
		    (EQUAL TEM (CADR CC-LAST-OUT)))
	       (RETURN NIL)))
	(k-compute-move 'k:r0 tem)
	;(CC-OUT-MOVE 'MOVE 'k:r0
		     ;T
	;	     TEM INFO-LIST)
	))

(DEFUN CC-PUSH-T-P (INST)
  (AND (CC-PUSH-P INST)
       (EQ (CADDR INST) 'k:r0
	   ;T
	   )))

(DEFUN CC-PUSH-P (INST)
  (AND (CONSP INST)
       (EQ (CAR INST) 'MOVE)
       (CONSP (CADR INST))
       (EQ (CAADR INST) 'PUSH-PDL)))

(DEFUN CC-MOVE-T-P (INST)
  (AND (CONSP INST)
       (EQ (CAR INST) 'MOVE)
       (EQ (CADR INST) 'k:r0
	   ;T
	   )))

(DEFUN CC-CHANGE-PUSH-TO-MOVE-T NIL
  (IF (CC-PUSH-P CC-LAST-OUT)
      (SETQ CC-LAST-OUT (CONS 'MOVE (CONS 'k:r0
					  ;T
					  (CDDR CC-LAST-OUT))))))

(DEFUN CC-STORE-T-IN-DEST (DEST K-DEST INFO-LIST)
  (PROG ()
	(cond ((equal dest '(k:new-open 0))
	       (return (cc-dest-last dest)))
	      ((k-destination-p dest)
	       (setq k-dest dest))
	      ((and (null k-dest)
		    (memq dest '(d-next d-last)))
	       (setq k-dest (o-n number-pushed-args))))
	(COND ((MEMQ DEST '(D-INDS D-IGNORE 0)) (RETURN NIL))
	      ((EQ DEST 'D-PDL)
	       (PUSH-SLOTLIST 1 '(D-PDL **FOO**))
	       (GO PUSH-T))
	      ((MEMBER DEST '(D-NEXT D-LAST))
	       (PUSH-SLOTLIST 1 '(C-F-ARG **FOO**))
	       (SETQ NUMBER-PUSHED-ARGS (1+ NUMBER-PUSHED-ARGS))
	       (GO PUSH-T))
	      ((EQ DEST 'D-RETURN)
	       (RETURN (CC-OUT-EXIT)))
	      (T (BARF DEST 'CC-STORE-T-IN-DEST 'BARF)))
     PUSH-T
	(COND ((AND (NOT (ATOM CC-LAST-OUT))
		    (EQ (CAR CC-LAST-OUT) 'MOVE)
		    (EQ (CADR CC-LAST-OUT) 'k:r0
			;T
			))
;	       (SETQ CC-LAST-OUT 
;		     `(k:MOVE ,k-dest
;			    ;(PUSH-PDL ,DEST ,k-dest)
;			    ;,@(cddr cc-last-out)
;			    ,(convert-adr-to-k (CADDR CC-LAST-OUT))
;			    k:boxed-right))
;	       (setq cc-last-out
;		     (k-compute-move k-dest (caddr cc-last-out)))
	       (k-compute-move k-dest (caddr (cc-flush-last-out)))
	       ))
     X1	(IF (EQ DEST 'D-LAST) (CC-DEST-LAST k-dest))))

;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 cc-activate-open-call (nargs)
  (setq number-pushed-args nargs)	;somewhat of a kludge
  (cc-dest-last nil)
  )

(DEFUN CC-DEST-LAST (k-dest &OPTIONAL SPREAD-FLAG)
  ;SPREAD-FLAG T if comming from misc %SPREAD.
  (PROG (N-VALS DEST RESTART-PC PC POPS CALL-INFO-LIST TEM TARGET tail-call-switch)
	(COND ((NULL PUSHED-CALLS-LIST) (BARF 'PDL-SCREWED 'CC-DEST-LAST 'BARF)))
	(SETQ PC (CAR PUSHED-CALLS-LIST)
	      PUSHED-CALLS-LIST (CDR PUSHED-CALLS-LIST)
	      RESTART-PC (PC-RESTART-PC PC)
	      target (pc-target-function pc)
	      tail-call-switch (pc-tail-call-switch pc))
	(SETQ N-VALS (PC-N-VALS PC)
	      DEST (PC-DEST PC))
	(SETQ CALL-INFO-LIST `((ARGS ,NUMBER-PUSHED-ARGS)))
	(COND ((SETQ TEM (CC-DECLARATION-INFO NIL))
	       (SETQ CALL-INFO-LIST (APPEND TEM CALL-INFO-LIST))))
	(SETQ POPS `(POPS ,(+ NUMBER-PUSHED-ARGS	;MACRO-CALL
			      %LP-CALL-BLOCK-LENGTH
			      (COND (N-VALS 2) (T 0))
			      (COND (RESTART-PC 4) (T 0))
			      )))
	(cond (SPREAD-FLAG
	       (CC-OUT `(CALL ,POPS ,CALL-INFO-LIST (CC-LINKAGE CC-SPREAD))))
	      (t
;	       (cond (tp-in-t-flag
;		      (cond ((and (eq (car cc-last-out) 'k:move)
;				  (eq (cadr cc-last-out) 'k:r0))
;			     (setq cc-last-out `(,(car cc-last-out)
;						 ,(o-n (1- number-pushed-args))
;						 ,@(cddr cc-last-out))))
;			    (t (cc-out `(k:move ,(o-n (1- number-pushed-args))
;						k:r0 k:boxed-right))))))
	       (cond (tail-call-switch
		      (cc-out
			`(K:tail-call
			   (,target ,number-pushed-args))))
		     (t
		      (CC-OUT `(k:CALL		;,POPS
			 			;,CALL-INFO-LIST
						;,(COND (TP-IN-T-FLAG 'D-MMCALT)
						;	     (T 'D-MMCALL))
				 (,target ,number-pushed-args)
				 ,(cond ((equal dest '(k:new-open 0)) dest)
					((k-destination-p dest) dest)
					((eq dest 'd-return) 'k:a0)	;used to hold value in case of non-tail
					(t				; dest return.
					 (fsignal "foo")
					 'k:r0))
				 ))))))
 ;	(POP-SLOTLIST NUMBER-PUSHED-ARGS 'C-F-ARG)
	(POP-SLOTLIST %LP-CALL-BLOCK-LENGTH  'C-F)	;FLUSH WDS FOR CALLED PRGM FRAME
     	(COND (N-VALS (POP-SLOTLIST 2 'M-V-INFO)))
	(COND (RESTART-PC (POP-SLOTLIST 4 'RESTART-PC)))
	(SETQ NUMBER-PUSHED-ARGS (PC-NUMBER-PUSHED-ARGS PC))
	(cond ((and (null tail-call-switch)
		    (not (or (equal dest '(k:new-open 0))
			     (k-destination-p dest))))
	       (CC-STORE-T-IN-DEST DEST k-dest (CC-TYPE-SPECIFIER-FROM-INFO-LIST CALL-INFO-LIST))))
	(RETURN NIL)
	))



;(defun cc-label-pdl-slot ()
;  (setq cc-label-pdl-slot-flag t))

(DEFUN PUSH-SLOTLIST (NUMBER ITEM)
  (PROG ()
     L  (COND ((= 0 NUMBER) (RETURN NIL)))
;     	(setq slotlist
;	      (cons (cond (cc-label-pdl-slot-flag
;			   (setq cc-label-pdl-slot-flag nil)
;			   (incf cc-temporary-variable-counter)
;			   (append item (list (intern (format nil "TEMP~D"
;							      cc-temporary-variable-counter)))))
;			  (t item))
;		    slotlist))
	(SETQ SLOTLIST (CONS ITEM SLOTLIST))
	(COND ((> (LENGTH SLOTLIST) MAX-IP-PDL-LEVEL)
	       (SETQ MAX-IP-PDL-LEVEL (LENGTH SLOTLIST))))
	(SETQ NUMBER (1- NUMBER))
	(GO L)))

(DEFUN POP-SLOTLIST (NUMBER TYPE)
  (PROG NIL
     L  (COND ((= 0 NUMBER) (RETURN NIL))
	      ((NULL SLOTLIST) (BARF TYPE 'OVER-POP 'BARF))
	      ((NOT (OR (EQ TYPE (CAAR SLOTLIST))
			(EQ TYPE 'ANY)))
	       (BARF (LIST (LIST TYPE) (CAR SLOTLIST)) 'WRONG-TYPE-POP-SLOTLIST 'BARF)))
	(SETQ SLOTLIST (CDR SLOTLIST))
	(SETQ NUMBER (1- NUMBER))
	(GO L)))


(DEFUN CC-SV-ADR (VAR)
  (COND ((MEMQ VAR SV-NAME-LIST)
	 (LIST 'SPECIAL VAR))
	(T (BARF VAR 'CC-SV-ADR 'BARF))))


;ALLVARS IS AS DESCRIBED IN LISPM;QCDEFS

;SLOTLIST IS A DYNAMIC LIST, THE LENGTH OF WHICH CORRESPONDS TO THE NUMBER
;OF ACTIVE SLOTS ON THE PP PDL AT THE MOMENT.  EACH ENTRY IS A 2 LIST (<TYPE> <NAME>).
;**FOO** IS FREQUENTLY USED FOR NAME WHEN IT IS APPROPRIATE.  TYPES ARE:  
;	ARG <VARIBLE>
;   INIT-VAR **FOO**  DATA TEMPORARILY ON STACK BEFORE BEING USED TO INITIALIZE VARIABLE
;     D-PDL  **FOO**  DATA STORED TO DESTINATION PDL
;      C-F   **FOO**  DATA IS A MICRO-TO-MACRO CALL FRAME
;    C-F-ARG **FOO**  DATA IS ARGUMENT TO A MICRO-TO-MACRO CALL FRAME
; RESTART-PC **FOO**  DATA IS RESTART-PC ADI FOR *CATCH, ETC
;			(NORMALLY 4 QS LONG FOR RESTART-PC AND BIND-STACK-LEVEL ADI S)
;  M-V-INFO  **FOO**  DATA IS M-V ADI

;Convert VAR-SPEC (such as appears in the address of a macro-instruction) into
; form suitable for address of microinstruction.  This must be called in the correct
; context relative to instruction interpretation in order that CC-VAR-ADR sees and
; leaves the correct machine state (SLOTLIST, etc).
(DEFUN CC-VAR-ADR (VAR-SPEC)
  (PROG (TEM)
	(COND ((PDL-POP-P VAR-SPEC)
	       (GO LPDL))
	      ((EQ (CAR VAR-SPEC) 'SPECIAL)
	       (RETURN VAR-SPEC))
	      ((EQ (CAR VAR-SPEC) 'FIXE)
	       (COND ((SETQ TEM (LOOK-ON-ALLVARS (CADR VAR-SPEC)))
		      (RETURN (CADR VAR-SPEC)))
		     (T (BARF VAR-SPEC 'CC-VAR-ADR 'BARF))))
	      ((SETQ TEM (LOOK-ON-ALLVARS VAR-SPEC))
	       (RETURN VAR-SPEC))
	      ((EQ (CAR VAR-SPEC) 'QUOTE-VECTOR)
	       (RETURN (CADR VAR-SPEC)))
	      (T (BARF VAR-SPEC 'CC-VAR-ADR 'BARF)))
   LPDL (POP-SLOTLIST 1 'D-PDL)
	(RETURN '(PDL-POP)) ))

(DEFUN LOOK-ON-ALLVARS (VAR-SPEC)
  (PROG (L)
	(SETQ L ALLVARS)
     L	(COND ((NULL L) (RETURN NIL))
	      ((EQUAL VAR-SPEC (VAR-LAP-ADDRESS (CAR L)))
	       (RETURN (CAAR L))))
	(SETQ L (CDR L))
	(GO L)))

(DEFUN VAR-SPEC-TYPE-FROM-DECLARATION (VAR-SPEC)
  (LET ((DECL-PLIST (DECLARATIONS-FROM-ALLVARS VAR-SPEC)))
    (DO ((P DECL-PLIST (CDDR P)))
	((NULL P))
      (COND ((EQ (CAR P) 'TYPE)
	     (RETURN (CADR P)))))))

(DEFUN DECLARATIONS-FROM-ALLVARS (VAR-SPEC)
  (DOLIST (E ALLVARS)
    (IF (EQUAL VAR-SPEC (VAR-LAP-ADDRESS E))
	(RETURN (VAR-DECLARATIONS E)))))

(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-QUOTE-ADR (Q)
  (LIST Q))

(DEFUN CLEARAC NIL 
;  (COND (TP-IN-T-FLAG 
;	 (cond ((memq tp-in-t-flag '(d-next d-last))
;		(let ((dest (o-n (1- number-pushed-args))))
;		  (cond ((and (eq (car cc-last-out) 'k:move)
;			      (eq (cadr cc-last-out) 'k:r0))
;			 (setq cc-last-out
;			       `(k:move ,dest .,(cddr cc-last-out))))
;			(t
;			 (cc-out `(k:move ,dest k:r0 k:boxed-right))))))
;	       (t
;		(CC-OUT `(MOVE (PUSH-PDL ,TP-IN-T-FLAG) k:r0 ,TP-IN-T-INFO))))	;t
;	 (SETQ TP-IN-T-FLAG NIL)))
  )

(DEFUN LOADAC NIL
  (PROG NIL 
;	(COND ((NOT TP-IN-T-FLAG) 
;	       (IF (NOT (CC-CHANGE-PUSH-TO-MOVE-T))
;		   (CC-OUT '(MOVE k:r0 (PDL-POP) NIL)))	;t
;	       (SETQ TP-IN-T-FLAG 'D-PDL
;		     TP-IN-T-INFO NIL)))
	))

(DEFUN ASSURE-TP-COPY-IN-T NIL 
;  (COND ((NOT (OR (CC-PUSH-T-P CC-LAST-OUT)
;		  (AND (EQ (CAR CC-LAST-OUT) 'MOVE)
;		       (OR (AND (EQ (CADR CC-LAST-OUT) 'k:r0
;				    ;T
;				    )
;				(EQUAL (CADDR CC-LAST-OUT) '(0 PP)))
;			   (AND (EQUAL (CADR CC-LAST-OUT) '(0 PP))
;				(EQ (CADDR CC-LAST-OUT) 'k:r0
;				    ;T
;				    ))))
;		  ;(MEMBER CC-LAST-OUT 
;		  ;    '((MOVE k:r0 (0 PP))
;		  ;	 (MOVE (0 PP) k:r0) ))
;		  ))
;	 (CC-OUT '(MOVE k:r0 (0 PP) NIL))))
  )	;t

(DEFUN CC-ADJUST-SLOTLIST (N)
  (COND ((< N 0)(PUSH-SLOTLIST (- 0 N) '(D-PDL **FOO**)))
	(T (POP-SLOTLIST N 'D-PDL))))

(DEFUN CC-OUTJ (INST AD)
  (PROG (TEM) 
	(IF (NSYMBOLP AD) (FERROR NIL "~%bad tag ~s" AD))
	(COND ((GET AD 'CC-USED)
	       (SETQ TEM (COND ((GET AD 'CC-PDLLVL)) (T CC-TOP-PDL-LEVEL)))
	       (COND ((NOT (= (LENGTH SLOTLIST) TEM))
		      (BARF INST
			    'SLOTLIST-LOSES-AT-JUMP
			    'BARF))))
	      (T (PUTPROP AD T 'CC-USED)))
	(CC-OUT `(,INST ,AD))
	(COND ((EQ INST 'JUMP)
	       (SETQ CC-DROPTHRU NIL)))
	(COND ((NOT (= (SETQ TEM (LENGTH SLOTLIST)) CC-TOP-PDL-LEVEL))
	       (PUTPROP AD TEM 'CC-PDLLVL)))))

(DEFUN CC-OUT-INST (INST AC ADR)
  (CC-OUT `(,INST ,AC ,ADR)))

(DEFUN CC-OUT-MOVE (INST AC ADR INFO-LIST)
  (declare (ignore info-list))
  (CC-OUT `(,INST ,AC ,ADR ;,INFO-LIST
	    )))

(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)))

(DEFUN CC-NOOP-P (INST)
  (COND ((AND (EQ (CAR INST) 'MOVE)
	      (EQ (CADR INST) (CADDR INST))))))

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


;--old lambda microcode assembly language.  here just to aid interpretation of old code.
; <exp> can be either <reg> or (contents <reg>).

;  (move <reg1> <reg2>)
;  (move-as-locative <reg1> <reg2>)
;  (jump-equal op1 op2 tag) (jump-not-equal op1 op2 tag)
;  (jump nil nil tag) (call <pops or pushes> <info alist> tag)
;  (arg-call <pops or pushes> <info alist> tag)  
;    currently, info alist supports ARG N, which says how many args have been compiled for
;	 arg must be reducible to a 8 bit fixnum.
;     note:  tag must be one of the specially recognized D- frobs which has been 
;           provided for in the linkage section of UCADR.
;  + - * // logand logior logxor
;special case kludges
;  (SE{CDR, CDDR, 1+, 1-} <ADR>)  adr must be ref'ed by exit vector.
;  list  
;  (discard-top-of-stack)
;  (exit) (pop-specpdl-and-exit)
;tag can be local or (misc fctn) or (cc-linkage entry).