;-*- MODE: LISP; PACKAGE: COMPILER; BASE: 8 -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;  compile fctn using c-m-x microcompile defun in zwei, then call this.
(DEFUN MA-TEST (&OPTIONAL LOAD-P RETEST-P)
  (PROG (FUNCTION-NAME)
	(COND ((NULL RETEST-P)
	       (PRINT '(TC 'STORE))
	       (TC 'STORE)))
	(SETQ FUNCTION-NAME (MICRO-ASSEMBLE 'COMPILE-TO-CORE))
	(FORMAT T "~% CONVERT-MCLAP~:[ ~; and LOAD~]" LOAD-P)
	(MCLAP-LOAD LOAD-P (GET FUNCTION-NAME 'MCLAP))))

(DEFUN MICRO-ASSEMBLE (MODE)	;this function called from MICRO-COMPILE in LISPM;MC
  (PROG (TEM FUNCTION-NAME OUTPUT)
	(COND ((NULL *UCADR-STATE-LIST*)
	       (GET-UCADR-STATE-LIST)
	       (MA-INITIALIZE-VARIABLES)))
     L	(PRINT '(MA-HOOK-UP-STATES))
	(MA-HOOK-UP-STATES)
	(PRINT '(MA-HOOK-UP-OPERANDS))
	(MA-HOOK-UP-OPERANDS)
	(COND (*MA-CHART-TOPOLOGY*
	       (PRINT '(MA-CHART-TOPOLOGY))
	       (MA-CHART-TOPOLOGY)))
	(COND ((AND *MA-CHART-TOPOLOGY*
		    *MA-COLAPSE-CUBBYHOLES*
		    (SETQ TEM (MA-FIND-CUBBYHOLES-TO-COLAPSE)))
	       (MA-COLAPSE-CUBBYHOLES TEM)
	       (GO L)))
	(COND (*MA-OPTIMIZE*
	       (PRINT '(MA-OPTIMIZE))
	       (COND ((MA-OPTIMIZE)	;returns T if significant change
		      (GO L)))))
	(PRINT '(MA-CONVERT))
	(MA-CONVERT)
	(SETQ FUNCTION-NAME (CADR (ASSQ 'FUNCTION-NAME *MA-PARAM-LIST*)))
	(SETQ OUTPUT (LIST *MA-PARAM-LIST* (MAKE-MCLAP)))
	(SELECTQ MODE
	  (COMPILE-TO-CORE
	   (PUTPROP FUNCTION-NAME OUTPUT 'MCLAP))
	  (QFASL
	   (FASD-FORM `(DEFPROP ,FUNCTION-NAME ,OUTPUT MCLAP)))
	  (REL
	   (QFASL-REL:DUMP-FORM `(DEFPROP ,FUNCTION-NAME ,OUTPUT MCLAP)))
	  (OTHERWISE (FERROR NIL "~%Unknown output mode ~s" MODE)))
	(RETURN FUNCTION-NAME)))


(DEFUN MA-CODE-RESET NIL
  (SETQ *MA-FIRST-INST* (MA-INITIALIZE-INST)
	*MA-INST-TAIL* *MA-FIRST-INST*
	*MA-PARAM-LIST* NIL
	*MA-INITIAL-STATE* NIL))

;Receive output of micro compiler, an instruction at a time.
(DEFUN MA-STORE-INST (INST)
  (COND ((NULL INST))
	((ATOM INST)
	 (IF (MA-INST-CODE *MA-INST-TAIL*)
	     (MA-STORE-NEXT-INST))
	 (SETF (MA-INST-TAGS-BEFORE *MA-INST-TAIL*)
	       (NCONC (MA-INST-TAGS-BEFORE *MA-INST-TAIL*)
		      (LIST INST)))
	 (PUTPROP INST *MA-INST-TAIL* 'MA-TAG-POINTER))
	((EQ (CAR INST) 'UPARAM)
	 (PUSH (LIST (CADR INST) (CADDR INST)) *MA-PARAM-LIST*))
	(T (IF (MA-INST-CODE *MA-INST-TAIL*)
	       (MA-STORE-NEXT-INST))
	   (SETF (MA-INST-CODE *MA-INST-TAIL*) INST))))

(DEFUN MA-STORE-NEXT-INST NIL
  (LET ((NEW-INST (MA-INITIALIZE-INST)))
    (SETF (MA-INST-NEXT-INST *MA-INST-TAIL*) NEW-INST)
    (SETF (MA-INST-PREVIOUS-INST NEW-INST) *MA-INST-TAIL*)
    (SETQ *MA-INST-TAIL* NEW-INST)))

(DEFUN MA-INITIALIZE-INST NIL
  (LET ((INST (MAKE-MA-INST))
	(BS (MAKE-MA-STATE))
	(AS (MAKE-MA-STATE)))
    (SETF (MA-INST-BEFORE-STATE INST) BS)
    (SETF (MA-INST-AFTER-STATE INST) AS)
    (SETF (MA-STATE-INST BS) INST)
    (SETF (MA-STATE-INST AS) INST)
    INST))

    
(DEFUN MA-FLUSH-INST (INST &OPTIONAL (C 1))
  (PROG (NEXT-I PREV-I TAGS)			
    L	(SETQ NEXT-I (MA-INST-NEXT-INST INST)
	      PREV-I (MA-INST-PREVIOUS-INST INST)
	      TAGS (MA-INST-TAGS-BEFORE INST))
	(IF PREV-I (SETF (MA-INST-NEXT-INST PREV-I) NEXT-I)
	           (SETQ *MA-FIRST-INST* NEXT-I))
	(IF (NULL NEXT-I)
	    (IF TAGS (FERROR NIL "tags dropping off into nothingness ~s" TAGS))
	    (SETF (MA-INST-PREVIOUS-INST NEXT-I) PREV-I)
	    (DOLIST (TAG TAGS)
	      (PUTPROP TAG NEXT-I 'MA-TAG-POINTER)
	      (PUSH TAG (MA-INST-TAGS-BEFORE NEXT-I))))
	(IF (ZEROP (SETQ C (1- C))) (RETURN T))
	(SETQ INST NEXT-I)
	(GO L)))

(DEFUN MA-UNHOOK-PRECEEDING-STATES (INST)
  (LET ((BS (MA-INST-BEFORE-STATE INST)))
    (DOLIST (PS (MA-STATE-PRECEEDING-STATES BS))
      (SETF (MA-STATE-FOLLOWING-STATES PS)
	    (DELQ BS (MA-STATE-FOLLOWING-STATES PS) 1)))))

(DEFUN MA-UNHOOK-FOLLOWING-STATES (INST)
  (LET ((AS (MA-INST-AFTER-STATE INST)))
    (DOLIST (FS (MA-STATE-FOLLOWING-STATES AS))
      (SETF (MA-STATE-PRECEEDING-STATES FS)
	    (DELQ AS (MA-STATE-PRECEEDING-STATES FS) 1)))))

;Clear out stuff possibly left there by previous tries of the program.
(DEFUN MA-CLEAR-CODE NIL
  (DOINSTS (INST *MA-FIRST-INST*)
    (MA-CLEAR-STATE (MA-INST-BEFORE-STATE INST))
    (MA-CLEAR-STATE (MA-INST-AFTER-STATE INST))
    (SETF (MA-INST-OP1 INST) NIL)
    (SETF (MA-INST-OP2 INST) NIL)
    (SETF (MA-INST-RESULT-OPERAND INST) NIL)
    (SETF (MA-INST-EXPANSION INST) NIL)
    (SETF (MA-INST-SEQUENCE INST) NIL)
    (SETF (MA-INST-CHANGED INST) NIL)))
	  
(DEFUN MA-CLEAR-STATE (ST)
  (SETF (MA-STATE-FILLED ST) NIL)
  (SETF (MA-STATE-PRECEEDING-STATES ST) NIL)
  (SETF (MA-STATE-FOLLOWING-STATES ST) NIL)
  (SETF (MA-STATE-REGISTER-ALIST ST) NIL)
  (SETF (MA-STATE-STACK-ALIST ST) NIL)
  (SETF (MA-STATE-PDL-BUFFER-INDEX ST) NIL)
  (SETF (MA-STATE-PDL-BUFFER-WRITE-HAPPENING ST) NIL))

(DEFUN MA-HOOK-UP-STATES ()
  (MA-CLEAR-CODE)		;in case of recycle
  (SETQ *MA-INITIAL-STATE* (MA-MAKE-INITIAL-STATE))
  (MA-LINK-STATES *MA-INITIAL-STATE* (MA-INST-BEFORE-STATE *MA-FIRST-INST*))
  (DOINSTS (INST *MA-FIRST-INST*)
     (MA-HOOK-UP-STATE INST)))
  
(DEFUN MA-HOOK-UP-OPERANDS ()
  (MA-HOOK-UP-INST *MA-INITIAL-STATE* *MA-FIRST-INST*)
  (MA-ADD-SEQUENCE *MA-FIRST-INST*)     ;identify sequences.
  (DOLIST (SEQ *MA-SEQUENCES*)		;fill in preceeding and following sequences
    (MA-HOOK-UP-SEQUENCE SEQ))
  )

(DEFUN MA-CHART-TOPOLOGY NIL	;gee - how about that name?
  (SETQ *MA-LOOPS* NIL *MA-BUBBLES* NIL)
  (DOLIST (SEQ *MA-SEQUENCES*)		;first pass fills in MA-SEQ-APATHS
    (SETF (MA-SEQ-APATHS SEQ) NIL)      ;initialize these in case a retry.
    (SETF (MA-ELEM-BUBBLES SEQ) NIL)
    (SETF (MA-ELEM-LOOPS SEQ) NIL)
    (SETF (MA-SEQ-PENDING-FS SEQ) (MA-SEQ-FOLLOWING-SEQUENCES SEQ))
    (SETF (MA-SEQ-LOOP-PATHS SEQ) NIL)
    (SETF (MA-SEQ-BUBBLE-PATHS SEQ) NIL)
    (SETF (MA-SEQ-LOOP-HEADS SEQ) NIL)
    (SETF (MA-SEQ-BUBBLE-HEADS SEQ) NIL))
  (MA-TRACE-PATHS *MA-FIRST-SEQUENCE* NIL)
; (MA-FIND-LOOP-ENTRIES-AND-EXITS)
  (DOLIST (SEQ *MA-SEQUENCES*)
    (SETF (MA-SEQ-ALL-LOOPS SEQ)
	  (MA-CHART-ENUMERATE-LOOPS SEQ NIL)))
  )

(DEFUN MA-CHART-ENUMERATE-LOOPS (ITEM ANS)
  (DOLIST (LOOP (MA-ELEM-LOOPS ITEM))
    (COND ((NOT (MEMQ LOOP ANS))
	   (PUSH LOOP ANS)
	   (SETQ ANS (MA-CHART-ENUMERATE-LOOPS LOOP ANS)))))
  (DOLIST (BUB (MA-ELEM-BUBBLES ITEM))
    (SETQ ANS (MA-CHART-ENUMERATE-LOOPS BUB ANS)))
  ANS)

(COMMENT
  ;this needs to be updated for bubbles and loops being members of loops.
(DEFUN MA-FIND-LOOP-ENTRIES-AND-EXITS NIL
  (DOLIST (LOOP *MA-LOOPS*)
    (SETF (MA-LOOP-ENTRIES LOOP) NIL)
    (SETF (MA-LOOP-EXITS LOOP) NIL))
  (DOLIST (LOOP *MA-LOOPS*)
    (DOLIST (SEQ (MA-ELEM-MEMBERS LOOP))
      (DOLIST (OTHER-SEQ (MA-SEQ-PRECEEDING-SEQUENCES SEQ))
	(COND ((NOT (MEMQ OTHER-SEQ (MA-ELEM-MEMBERS LOOP)))
	       (SETF (MA-LOOP-ENTRIES LOOP)
		     (CONS (CONS SEQ OTHER-SEQ) (MA-LOOP-ENTRIES LOOP))))))
      (DOLIST (OTHER-SEQ (MA-SEQ-FOLLOWING-SEQUENCES SEQ))
	(COND ((NOT (MEMQ OTHER-SEQ (MA-ELEM-MEMBERS LOOP)))
	       (SETF (MA-LOOP-EXITS LOOP)
		     (CONS (CONS SEQ OTHER-SEQ) (MA-LOOP-EXITS LOOP)))))))))


(DEFUN MA-TRACE-PATHS (SEQ PATH-SO-FAR &AUX TEM)
  (COND ((SETQ TEM (MEMQ SEQ PATH-SO-FAR))
	 (MA-RECORD-LOOP (NREVERSE (LDIFF PATH-SO-FAR (CDR TEM)))))
	(T (LET ((NEW-PATH (CONS SEQ PATH-SO-FAR)))
	     (DOLIST (PPATH (MA-SEQ-APATHS SEQ))
	       (MA-RECORD-BUBBLE NEW-PATH PPATH))
	     (SETF (MA-SEQ-APATHS SEQ)
		   (CONS NEW-PATH (MA-SEQ-APATHS SEQ)))
	     (DOLIST (FSEQ (MA-SEQ-FOLLOWING-SEQUENCES SEQ))
	       (MA-TRACE-PATHS FSEQ NEW-PATH))))))
)  ;end comment

(DEFUN MA-TRACE-PATHS (SEQ PATH-SO-FAR)
 (PROG (LOOP-FLAG NEW-PATH TEM)
       (SETQ NEW-PATH (CONS SEQ PATH-SO-FAR))
       (COND ((SETQ LOOP-FLAG (MEMQ SEQ PATH-SO-FAR))
	      (PUSH (NREVERSE (LDIFF PATH-SO-FAR (CDR LOOP-FLAG)))
		    (MA-SEQ-LOOP-PATHS SEQ)))
	     (T
	      (DOLIST (PPATH (MA-SEQ-APATHS SEQ))
		(MA-RECORD-BUBBLE NEW-PATH PPATH))
	      (SETF (MA-SEQ-APATHS SEQ)
		    (CONS NEW-PATH (MA-SEQ-APATHS SEQ)))))
   L   (COND ((NULL (SETQ TEM (MA-SEQ-PENDING-FS SEQ)))		;ready to exit?
	      (GO X)))
       (MA-TRACE-PATHS (PROG1 (CAR TEM) (SETF (MA-SEQ-PENDING-FS SEQ) (CDR TEM)))
		       NEW-PATH)
       (GO L)
   X   (COND ((AND (NULL LOOP-FLAG)
		   (NULL (MA-SEQ-BUBBLE-HEADS SEQ))  ;crock..  already done dont do it twice
		   (NULL (MA-SEQ-LOOP-HEADS SEQ)))
	      (SETF (MA-SEQ-BUBBLE-HEADS SEQ)
		    (MA-MAKE-BUBBLES
		      (MA-PROCESS-PATHS (MA-SEQ-BUBBLE-PATHS SEQ))))
	      (SETF (MA-SEQ-LOOP-HEADS SEQ)
		    (MAPCAR (FUNCTION MA-MAKE-LOOP)
			    (MA-PROCESS-PATHS (MA-SEQ-LOOP-PATHS SEQ))))))
))

(DEFUN MA-MAKE-BUBBLES (PATHS)
  (PROG (PATH BOTTOM OTHER-PATHS BUBS)
    L  (COND ((NULL PATHS) (RETURN BUBS)))
       (SETQ PATH (CAR PATHS) PATHS (CDR PATHS))
       (SETQ BOTTOM (MA-BOTTOM-SEQ (CAR (LAST PATH))))
       (SETQ OTHER-PATHS NIL)
       (DOLIST (P PATHS)
	 (COND ((EQ BOTTOM (MA-BOTTOM-SEQ (CAR (LAST P))))
		(PUSH P OTHER-PATHS)
		(SETQ PATHS (DELQ P PATHS 1)))))
       (IF OTHER-PATHS (PUSH (MA-MAKE-BUBBLE (CONS PATH OTHER-PATHS))
			     BUBS))
       (GO L)))

(DEFUN MA-BOTTOM-SEQ (ITEM)
  (SELECTQ (TYPEP ITEM)
    (MA-BUBBLE (MA-BUBBLE-BOTTOM ITEM))
    (MA-LOOP (FERROR NIL ""))
    (MA-SEQUENCE ITEM)
    (OTHERWISE (FERROR NIL ""))))

(DEFUN MA-MAKE-BUBBLE (PATHS &AUX TOP BOTTOM)
  (DOLIST (P PATHS)
    (LET ((TP (CAR P)))
      (COND ((EQ (TYPEP TP) 'MA-BUBBLE)
	     (SETQ TP (MA-BUBBLE-TOP TP))))
      (IF TOP (IF (NEQ TOP TP) (FERROR NIL "~%Tops dont agree"))
	  (SETQ TOP TP)))
    (LET ((B (CAR (LAST P))))
      (COND ((EQ (TYPEP B) 'MA-BUBBLE)
	     (SETQ B (MA-BUBBLE-BOTTOM B))))
      (IF BOTTOM (IF (NEQ BOTTOM B) (FERROR NIL "~%Bottoms dont agree"))
	  (SETQ BOTTOM B))))
  (DO ((L *MA-BUBBLES* (CDR L)))
      ((NULL L)
       (LET ((BUB (MAKE-MA-BUBBLE)))
	 (SETF (MA-BUBBLE-TOP BUB) TOP)
	 (SETF (MA-BUBBLE-BOTTOM BUB) BOTTOM)
	 (SETF (MA-BUBBLE-PATHS BUB) PATHS)
	 (SETQ *MA-BUBBLES* (NCONC *MA-BUBBLES* (LIST BUB)))
	 (LET (MEMS)
	   (DOLIST (P PATHS)
	     (DOLIST (E P)
	       (IF (NOT (MEMQ E MEMS))
		   (PUSH E MEMS))))
	   (SETF (MA-ELEM-MEMBERS BUB) MEMS)
	   (DOLIST (MEM MEMS)
	     (PUSH BUB (MA-ELEM-BUBBLES MEM))))
	 BUB))
    (COND ((AND (EQ TOP (MA-BUBBLE-TOP (CAR L)))
		(EQ BOTTOM (MA-BUBBLE-BOTTOM (CAR L))))
	   (FERROR NIL "~%duplicate bubble found")))))

(COMMENT
(DEFUN MA-ADD-BUBBLE-PATH (PATH BUB)
  (DOLIST (S PATH)
    (COND ((NOT (MEMQ BUB (MA-ELEM-BUBBLES S)))
	   (SETF (MA-ELEM-BUBBLES S) (CONS BUB (MA-ELEM-BUBBLES S))))))) 
 ) ;end comment

;paths must be lists of seqments (no bubbles or loops).
;In the returned path, any sequence which is a loop or bubble head is replaced
;by that loop or bubble.  Sequences immediately following the head sequence which
;are a member of the same loop or bubble are deleted.
(DEFUN MA-PROCESS-PATHS (PS)
  (LET (ANS)
    (DOLIST (P PS)
      (LET ((PP (MA-PROCESS-PATH P)))
	(COND ((NOT (MEMBER PP ANS))
	       (PUSH PP ANS)))))
    ANS))

(DEFUN MA-PROCESS-PATH (P &AUX TEM)
  (COND ((NULL P) NIL)
	((AND (SETQ TEM (MA-SEQ-LOOP-HEADS (CAR P)))
	      (NULL (CDR TEM)))
	 (CONS (CAR TEM)		;the loop
	       (MA-PROCESS-PATH (DO ((PP (CDR P) (CDR PP)))  ;delete other seqs which are
				    ((OR (NULL PP)	     ;members of this loop
					 (NOT (MA-LOOP-MEMBER (CAR PP) (CAR TEM))))
				     PP)))))
	((SETQ TEM (MA-SEQ-BUBBLE-HEADS (CAR P)))
	 (CONS (CAR TEM)		;the bubble
	       (MA-PROCESS-PATH (DO ((PP (CDR P) (CDR PP)))
				    ((OR (NULL PP)
					 (NOT (MA-BUBBLE-MEMBER (CAR PP) (CAR TEM))))
				     PP)))))
	(T (CONS (CAR P) (MA-PROCESS-PATH (CDR P))))))

(DEFUN MA-LOOP-MEMBER (SEQ LOOP)
  (IF (NOT (EQ (TYPEP SEQ) 'MA-SEQUENCE)) (FERROR NIL "~S not sequence"))
  (MEMQ LOOP (MA-ELEM-LOOPS SEQ)))

(DEFUN MA-BUBBLE-MEMBER (SEQ BUB)
  (IF (NOT (EQ (TYPEP SEQ) 'MA-SEQUENCE)) (FERROR NIL "~S not sequence"))
  (DOLIST (P (MA-BUBBLE-PATHS BUB))
    (IF (MEMQ SEQ P) (RETURN T))))

;p1, p2 are paths of sequences reaching a common sequence.  They are in
; deepest sequence first order.
(DEFUN MA-RECORD-BUBBLE (P1 P2)
  (PROG (BOTTOM T1 T2)
	(COND ((NOT (EQ (CAR P1) (CAR P2)))
	       (FERROR NIL "error recording bubble")))
	(SETQ BOTTOM (CAR P1))
  ;the top is the first one along each list that is a member of the other list.
  ;if these arent the same with respect to the two lists, its obviously hairy so
  ;forget it.
	(DOLIST (E (CDR P1))
	  (COND ((MEMQ E (CDR P2))
		 (SETQ T1 E)
		 (RETURN NIL))))
	(DOLIST (E (CDR P2))
	  (COND ((MEMQ E (CDR P1))
		 (SETQ T2 E)
		 (RETURN NIL))))
	(COND ((NOT (EQ T1 T2))
	       (FORMAT T "~%bubble being ignored ~s ~s" P1 P2)
	       (RETURN NIL)))
	(MA-ADD-BUBBLE-PATH T1 (REVERSE-UP-TO-AND-INCLUDING T1 P1))
	(MA-ADD-BUBBLE-PATH T1 (REVERSE-UP-TO-AND-INCLUDING T1 P2))
  (COMMENT
	(RETURN (MA-ADD-BUBBLE T1
			       BOTTOM
			       (REVERSE-UP-TO-AND-INCLUDING T1 P1)
			       (REVERSE-UP-TO-AND-INCLUDING T1 P2))))
  ))

(DEFUN MA-ADD-BUBBLE-PATH (SEQ PATH)
  (IF (NOT (MEMBER (CADR PATH) (MA-SEQ-FOLLOWING-SEQUENCES SEQ)))
      (FERROR NIL "~%screwwed up"))
  (IF (NOT (MEMBER PATH (MA-SEQ-BUBBLE-PATHS SEQ)))
      (PUSH PATH (MA-SEQ-BUBBLE-PATHS SEQ))))

(DEFUN REVERSE-UP-TO-AND-INCLUDING (E L)
  (PROG (ANS)
    L  (COND ((NULL L) (FERROR NIL "didnt find elem"))
	     ((EQ E (CAR L))
	      (RETURN (CONS E ANS))))
       (SETQ ANS (CONS (CAR L) ANS) L (CDR L))
       (GO L)))

;make new loop unless this a duplicate
(DEFUN MA-MAKE-LOOP (MEMS)
  (SETQ MEMS (SI:ELIMINATE-DUPLICATES MEMS))
  (DO ((L *MA-LOOPS* (CDR L)))
      ((NULL L)
       (LET ((LOOP (MAKE-MA-LOOP)))
	 (SETF (MA-ELEM-MEMBERS LOOP) MEMS)
	 (SETQ *MA-LOOPS* (NCONC *MA-LOOPS* (LIST LOOP)))
	 (DOLIST (MEM MEMS)
	   (PUSH LOOP (MA-ELEM-LOOPS MEM)))
	 LOOP))
    (COND ((SAME-MEMBERS MEMS (MA-ELEM-MEMBERS (CAR L)))
	   (RETURN (CAR L))))))

(DEFUN SAME-MEMBERS (L1 L2)
  (PROG NIL 
	(COND ((NOT (= (LENGTH L1) (LENGTH L2)))
	       (RETURN NIL)))
    L	(COND ((NULL L1) (RETURN T))
	      ((NOT (MEMQ (CAR L1) L2))
	       (RETURN NIL)))
	(SETQ L1 (CDR L1))
	(GO L)))

(COMMENT
;Sort a list of loops outermost first. Its a bit tricky since the INNER relation
; is sometimes undefined.  In such cases, the sort is to be stable, ie things stay
; in the same order unless there is positive reason to switch them.
;Proceedure:  look for a loop OUTER to the first one on the list.  If find one,
;   move it to the head of the list and loop back.  Then scan the list moving
;   any loop INNER to the first one adjacent to it.  Then repeat on the CDR of the list.
(DEFUN MA-SORT-LOOPS (L)		;** incomplete**
  (PROG (P1 TRAIL-P1 P2 TRAIL-P2 P3)
	(SETQ P1 L TRAIL-P1 (VALUE-CELL-LOCATION 'L))
     L0 (COND ((NULL P1) (RETURN L)))
	(SETQ P2 (CDR P1) TRAIL-P2 P1)
     L1 (COND ((NULL P2) (GO X1))
	      ((MA-OUTTER-P (CAR P2) (CAR P1))	;move to the head of the list
	       (RPLACD TRAIL-P2 (CDR P2))
	       (RPLACD P2 P1)
	       (RPLACD TRAIL-P1 P2)
	       (SETQ P1 (CDR TRAIL-P1))
	       (GO L0)))			;and go again
     X1 (SETQ P2 P1)
	(SETQ P3 (CDR P2))
     L3	(COND ((NULL P3)
	       (SETQ TRAIL-P1 (CDR P1)
		     P1 (CDR TRAIL-P1))
	       (GO L0))
	      ((MA-OUTTER-P (CAR P3) (CADR P2)) ))
	(SETQ P3 (CDR P3))
	(GO L3)
))

(DEFUN MA-INNER-P (L1 L2)
  (PROG TOP (L1-INNER-TO-L2 L2-INNER-TO-L1)
	(DO ((SEQL (MA-LOOP-SEQS L1) (CDR SEQL)))
	    ((NULL SEQL) (RETURN-FROM TOP NIL))		;return on disjoint
	  (COND ((MEMQ (CAR SEQL) (MA-LOOP-SEQS L2))
		 (RETURN NIL))))	            ;have common member, proceed to next step
	(SETQ L1-INNER-TO-L2 (MA-HALF-INNER L1 L2))
	(SETQ L2-INNER-TO-L1 (MA-HALF-INNER L2 L1))
	(RETURN (AND L1-INNER-TO-L2 (NOT L2-INNER-TO-L1)))))

(DEFUN MA-HALF-INNER (L1 L2)
  (PROG TOP NIL
	(DOLIST (ENTRIES (MA-LOOP-ENTRIES L1))
	  (COND ((NOT (MEMQ (CDR ENTRIES) (MA-LOOP-SEQS L2)))
		 (RETURN-FROM TOP NIL))))
	(DOLIST (EXITS (MA-LOOP-EXITS L1))
	  (COND ((NOT (MEMQ (CDR EXITS) (MA-LOOP-SEQS L2)))
		 (RETURN-FROM TOP NIL))))
	(RETURN T)))

 ) ;end comment

(DEFUN MA-HOOK-UP-SEQUENCE (SEQ)
  (DOLIST (PRE-STATE
	    (MA-STATE-PRECEEDING-STATES (MA-INST-BEFORE-STATE (CAR (MA-ELEM-MEMBERS SEQ)))))
    (LET ((INST (MA-STATE-INST PRE-STATE)))
      (COND ((EQ INST 'BEGINNING-OF-FUNCTION)
	     (SETQ *MA-FIRST-SEQUENCE* SEQ))
	    (T 
	      (SETF (MA-SEQ-PRECEEDING-SEQUENCES SEQ)
		    (ADD-TO-LIST (MA-INST-SEQUENCE INST)
				 (MA-SEQ-PRECEEDING-SEQUENCES SEQ)))))))
  (LET* ((LAST-INST (CAR (LAST (MA-ELEM-MEMBERS SEQ))))
	 (NEXT-INST (MA-INST-NEXT-INST LAST-INST)))
    (SETF (MA-SEQ-NEXT-SEQUENCE SEQ)
	  (IF NEXT-INST (MA-INST-SEQUENCE NEXT-INST)))
    (DOLIST (POST-STATE
	      (MA-STATE-FOLLOWING-STATES
		(MA-INST-AFTER-STATE LAST-INST)))
      (SETF (MA-SEQ-FOLLOWING-SEQUENCES SEQ)
	    (ADD-TO-LIST (MA-INST-SEQUENCE (MA-STATE-INST POST-STATE))
			 (MA-SEQ-FOLLOWING-SEQUENCES SEQ))))))

(DEFUN ADD-TO-LIST (ITEM LIST)
  (COND ((NOT (MEMQ ITEM LIST))
	 (CONS ITEM LIST))
	(T LIST)))

;Make inst the first instruction of a sequence.  Also include any instuctions
; that directly follow this one.
(DEFUN MA-ADD-SEQUENCE (INST)
  (PROG (SEQ I1 I2 FS)
	(SETQ SEQ (MAKE-MA-SEQUENCE))
	(SETF (MA-INST-SEQUENCE INST) SEQ)
	(SETF (MA-ELEM-MEMBERS SEQ) (LIST INST))
	(SETQ *MA-SEQUENCES* (NCONC *MA-SEQUENCES* (LIST SEQ)))
	(SETQ I1 INST)
    L   (COND ((NOT (= 1 (LENGTH (MA-STATE-FOLLOWING-STATES
				   (MA-INST-AFTER-STATE I1)))))
	       (GO X)))
	(SETQ FS (CAR (MA-STATE-FOLLOWING-STATES
			(MA-INST-AFTER-STATE I1))))
	(COND ((NOT (= 1 (LENGTH (MA-STATE-PRECEEDING-STATES FS))))
	       (GO X)))
	(SETQ I2 (MA-STATE-INST FS))
	(COMMENT (IF (MA-INST-TAGS-BEFORE I2)
		     (FORMAT T "~%tags in middle of seq ~s, inst ~s"
			     (MA-INST-TAGS-BEFORE I2) I2)))
	(SETF (MA-INST-SEQUENCE I2) SEQ)
	(NCONC (MA-ELEM-MEMBERS SEQ) (LIST I2))
	(SETQ I1 I2)
	(GO L)
   X    (DOLIST (FS (MA-STATE-FOLLOWING-STATES
		      (MA-INST-AFTER-STATE I1)))
	  (LET ((FI (MA-STATE-INST FS)))
	    (COND ((NULL (MA-INST-SEQUENCE FI))
		   (MA-ADD-SEQUENCE FI)))))))


;this currently not called.
(DEFUN MA-ORDER-SEQUENCES NIL
  (DO ((SL *MA-SEQUENCES* (CDR SL)))		;for each sequence
      ((NULL SL))
    (COND ((MA-ELEM-LOOPS (CAR SL))		;if it contains a loop
	   (DOLIST (LOOP (MA-ELEM-LOOPS (CAR SL)))  ;for each loop
	     (PROG (TRAILP SL1 ISL)		;move later sequences in that loop up
		   (SETQ TRAILP (SETQ ISL SL))  ;adjacent to the first one.
		L1  (COND ((NULL (SETQ SL1 (CDR TRAILP)))
			   (RETURN NIL))
			  ((AND (MEMQ LOOP (MA-ELEM-LOOPS (CAR SL1)))   ;seq in loop
				(NOT (EQ SL1 (CDR ISL))))        ;not already in right place
			   (RPLACD TRAILP (CDR SL1))	;This a member of same loop. move it
			   (RPLACD SL1 (CDR ISL))	;so it immediately follows.
			   (RPLACD ISL SL1)
			   (SETQ ISL (CDR ISL))
			   (GO L1)))
		   (SETQ TRAILP (CDR TRAILP))
		   (GO L1)))))))

(DEFUN MA-REF-RELATION (R1 R2 CONTEXT)
  (COND ((NEQ (CADR R1) (CADR R2))		;if different inst's 
	 (MA-INST-RELATION (CADR R1) (CADR R2) CONTEXT))
	((EQ (CAR R1) (CAR R2)) 'SAME)
	((AND (EQ (CAR R1) 'FETCH)
	      (EQ (CAR R2) 'STORE))
	 'BEFORE)		;FETCHes happen before STOREs
	(T 'AFTER)))

(DEFUN MA-INST-RELATION (I1 I2 CONTEXT)
  (COND ((EQ I1 I2) 'SAME)
	((NEQ (MA-INST-SEQUENCE I1) (MA-INST-SEQUENCE I2))
	 (MA-SEQUENCE-RELATION (MA-INST-SEQUENCE I1) (MA-INST-SEQUENCE I2) CONTEXT))
	((DOLIST (LOOP (MA-SEQ-ALL-LOOPS (MA-INST-SEQUENCE I1)))
	   (IF (NOT (MEMQ LOOP CONTEXT))
	       (RETURN T)))
	 'INDETERMINATE)
	((IN-LIST-BEFOREP I1 I2 (MA-ELEM-MEMBERS (MA-INST-SEQUENCE I1))) 'BEFORE)
	(T 'AFTER)))

(DEFUN IN-LIST-BEFOREP (E1 E2 L)
  (PROG (P)
	(SETQ P L)
    L	(COND ((NULL P) (FERROR NIL ""))
	      ((EQ E1 (CAR P)) (RETURN T))
	      ((EQ E2 (CAR P)) (RETURN NIL)))
	(SETQ P (CDR P))
	(GO L)))

;returns ordering relation between two sequences, which may be BEFORE, AFTER, INDETERMINATE,
; EXCLUSIVE, or HAIRY.
;CONTEXT may be NIL (meaning whole frob), a SEQUENCE, or a LOOP.
;Since the order of *MA-SEQUENCES* corresponds to a possible execution order,
; unless the two sequences are members of a LOOP or BUBBLE, the relation is just
; which comes first in *MA-SEQUENCES*.
;
(DEFUN MA-SEQUENCE-RELATION (SEQ1 SEQ2 CONTEXT)
 (PROG TOP (BASIC-RELATION SHARED-LOOPS SHARED-BUBBLES)
       (DOLIST (S *MA-SEQUENCES*)
	 (COND ((EQ S SEQ1)
		(RETURN (SETQ BASIC-RELATION 'BEFORE)))
	       ((EQ S SEQ2)
		(RETURN (SETQ BASIC-RELATION 'AFTER)))))
       (SETQ SHARED-LOOPS (LIST-INTERSECT (MA-SEQ-ALL-LOOPS SEQ1) (MA-SEQ-ALL-LOOPS SEQ2)))
       (SETQ SHARED-BUBBLES (LIST-INTERSECT (MA-ELEM-BUBBLES SEQ1) (MA-ELEM-BUBBLES SEQ2)))
       (DOLIST (L SHARED-LOOPS)
	 (COND ((NOT (MEMQ L CONTEXT))
		(RETURN-FROM TOP 'INDETERMINATE))))
       (DOLIST (B SHARED-BUBBLES)
	 (COND ((AND (NOT (MEMQ B CONTEXT))
		     NIL) ;on different forks
		(RETURN-FROM TOP 'EXCLUSIVE))))
       (RETURN BASIC-RELATION)		     
  ))

(DEFUN LIST-INTERSECT (L1 L2 &AUX ANS)
  (DOLIST (E1 L1)
    (DOLIST (E2 L2)
      (COND ((EQ E1 E2)
	     (SETQ ANS (CONS E1 ANS))))))
  ANS)

(DEFUN MA-FIND-CUBBYHOLES-TO-COLAPSE ()
  (DO ((LOSERS)
       (ANS)
       (P-ELIM *MA-CUBBYHOLES* (CDR P-ELIM))
       (ELIM)(INTO))
      ((NULL P-ELIM)
       (NREVERSE ANS))	;return in correct order
    (COND ((EQ (CAR (MA-CUBBYHOLE-NAME (SETQ ELIM (CAR P-ELIM))))
	       'SPECIAL))  ;Can't do anything with those
	  ((NOT (MEMQ ELIM LOSERS))	;flushed this one?
	   (COND ((MA-CUBBYHOLE-ARGP ELIM))	;can flush arg
		 ((NULL (MA-CUBBYHOLE-REFS ELIM))         ;includes stores, but then it would
		  (PUSH (LIST ELIM) ANS)		  ; be more hair to flush
		  (PUSH ELIM LOSERS)
		  (FORMAT T "~%Flushing cubbyhole ~s" (MA-CUBBYHOLE-PRINT-NAME ELIM)))
		 ((NOT (MA-CUBBYHOLE-REFS-INITIALIZATION-P ELIM))  ;can do it if it really
		  						   ; needs to be NIL to start
		  (DO ((P-INTO *MA-CUBBYHOLES* (CDR P-INTO)))
		      ((NULL P-INTO))
		    (COND ((EQ (CAR P-ELIM) (CAR P-INTO)))	;not into self
			  ((AND (NOT (MEMQ (SETQ INTO (CAR P-INTO)) LOSERS))
				(MA-CUBBYHOLES-COMBINABLE-P ELIM INTO))
			   (PUSH (CONS ELIM INTO) ANS)
			   (PUSH ELIM LOSERS)
			   (FORMAT T "~%Combining cubbyhole ~s into ~s"
				   (MA-CUBBYHOLE-PRINT-NAME ELIM)
				   (MA-CUBBYHOLE-PRINT-NAME INTO))
			   (DOLIST (N (MA-CUBBYHOLE-ALL-NAMES ELIM))
			     (PUSH N (MA-CUBBYHOLE-ALL-NAMES INTO)))
			   (SETF (MA-CUBBYHOLE-REFS INTO)		;update in case
				 (APPEND (MA-CUBBYHOLE-REFS ELIM)	;combine in another
					 (MA-CUBBYHOLE-REFS INTO)))
			   (RETURN T))))))))))

(DEFUN MA-CUBBYHOLE-PRINT-NAME (CUB)
  (MAPCAR #'MA-VAR-NAME (MA-CUBBYHOLE-ALL-NAMES CUB)))

(DEFUN MA-VAR-NAME (CUB-NAME)
  (COND ((DOLIST (V (CAR (MA-EVAL-SYM 'ALLVARS)))
	   (COND ((EQUAL CUB-NAME (VAR-LAP-ADDRESS V))
		  (RETURN (VAR-NAME V))))))
	(T CUB-NAME)))

(DEFUN MA-CUBBYHOLE-REFS-INITIALIZATION-P (CUBBY)
  (NOT (NULL (MA-OPERAND-USES (MA-INITIALIZING-OPERAND CUBBY)))))

(DEFUN MA-INITIALIZING-OPERAND (CUBBY)
  (MA-INST-RESULT-OPERAND (MA-INITIALIZING-INST CUBBY)))

(DEFUN MA-INITIALIZING-INST (CUBBY)
  (MA-INST-PREVIOUS-INST (MA-FIND-CUBBYHOLE-DCL CUBBY)))

(DEFUN MA-FIND-CUBBYHOLE-DCL (CUBBY)
 (LET ((NAME (MA-CUBBYHOLE-NAME CUBBY)))
  (DOINSTS (I *MA-FIRST-INST*)
     (COND ((AND (EQ (CAR (MA-INST-CODE I)) 'CREATE-CUBBYHOLE)
		 (EQUAL (CADR (MA-INST-CODE I)) NAME))
	    (RETURN I))))))

(DEFUN MA-CUBBYHOLES-COMBINABLE-P (ELIM INTO)
  (COND ((MA-CUBBYHOLE-ARGP ELIM) NIL) ;cant eliminate arg
	((MA-ALL-BEFORE (MA-LAST-USAGE-LIST INTO NIL)
			(MA-FIRST-USAGE-LIST ELIM NIL)
			NIL))		;context = entire function
	(T NIL)	;**
;	((MA-ALL-AFTER (MA-FIRST-USAGE-LIST ELIM NIL)
;		       (MA-LAST-USAGE-LIST INTO NIL)
;		       NIL))
	))

(DEFUN MA-ALL-BEFORE (L1 L2 CONTEXT)
  (PROG TOP NIL
	(DOLIST (R1 L1)
	  (DOLIST (R2 L2)
	    (IF (NOT (EQ (MA-REF-RELATION R1 R2 CONTEXT) 'BEFORE))
		(RETURN-FROM TOP NIL))))
	(RETURN T)))

(DEFUN MA-ALL-AFTER (L1 L2 CONTEXT)
  (PROG TOP NIL
	(DOLIST (R1 L1)
	  (DOLIST (R2 L2)
	    (IF (NOT (EQ (MA-REF-RELATION R1 R2 CONTEXT) 'AFTER))
		(RETURN-FROM TOP NIL))))
	(RETURN T)))

(DEFUN MA-FIRST-USAGE-LIST (CUBBYHOLE CONTEXT)
  (MA-ELIMINATE-AFTERS (MA-CUBBYHOLE-REFS CUBBYHOLE)
		       CONTEXT))

;Arg is a list of refs.  Filter out any which is clearly AFTER any of the others.
(DEFUN MA-ELIMINATE-AFTERS (L CONTEXT)
  (PROG (ANS)
	(DOLIST (R1 L)
	  (DOLIST (R2 L)
	    (COND ((EQ R1 R2))
		  ((EQ (MA-REF-RELATION R1 R2 CONTEXT) 'AFTER)
		   (GO FLUSH))))
	  (IF (NOT (MEMQ R1 ANS)) (PUSH R1 ANS))		;have to keep this one
	  FLUSH)
	(RETURN ANS)))

(DEFUN MA-LAST-USAGE-LIST (CUBBYHOLE CONTEXT)
  (MA-ELIMINATE-BEFORES (MA-CUBBYHOLE-REFS CUBBYHOLE)
			CONTEXT))

;Arg is a list of refs.  Filter out any which is clearly BEFORE any of the others.
(DEFUN MA-ELIMINATE-BEFORES (L CONTEXT)
  (PROG (ANS)
	(DOLIST (R1 L)
	  (DOLIST (R2 L)
	    (COND ((EQ R1 R2))
		  ((EQ (MA-REF-RELATION R1 R2 CONTEXT) 'BEFORE)
		   (GO FLUSH))))
	  (IF (NOT (MEMQ R1 ANS)) (PUSH R1 ANS))		;have to keep this one
	  FLUSH)
	(RETURN ANS)))

(DEFUN MA-CUBBYHOLE-ARGP (CUB)
  (EQ (CAR (MA-CUBBYHOLE-NAME CUB)) 'ARG))


(DEFUN MA-COLAPSE-CUBBYHOLES (LOSERS)
  (PROG (I)
    TOP	(SETQ I *MA-FIRST-INST*)
    L	(COND ((NULL I) (GO L1))
	      ((EQ (CAR (MA-INST-CODE I)) 'START-CUBBYHOLE) ;flush cubbyhole-creation
	       (PROG (FIRST-I COUNT)
		     (SETQ FIRST-I I COUNT 2)
		 LL  (SETQ I (MA-INST-NEXT-INST I))
		     (COND ((NULL I) (FERROR NIL ""))
			   ((EQ (CAR (MA-INST-CODE I)) 'CREATE-CUBBYHOLE)
			    (COND ((ASSQ (CDR (ASSQ (CADR (MA-INST-CODE I))
						    *MA-CUBBYHOLE-ALIST*))
					 LOSERS)
				   (FORMAT T "~%Flushing ~s" I)
				   (MA-FLUSH-INST FIRST-I COUNT)
				   (GO TOP))
				 (T (GO LLX)))))	;dont flush this one
		     (SETQ COUNT (1+ COUNT))
		     (GO LL))))
    LLX	(SETQ I (MA-INST-NEXT-INST I))
	(GO L)
  ;now flush it from MA-CODE
   L1   (DOINSTS (I *MA-FIRST-INST*)
	  (LET* ((CODE (MA-INST-CODE I))
		 (RNF (GET (CAR CODE) 'MA-RENAME-FUNCTION)))
	    (DOLIST (L LOSERS)
	      (SETQ CODE (COND (RNF (FUNCALL RNF L CODE))
			       ((NULL (CDR L))
				CODE)		;flushing this slot
			       (T		;renaming this slot
				(SUBST-ONE-LEVEL (MA-CUBBYHOLE-NAME (CAR L))
						 (MA-CUBBYHOLE-NAME (CDR L))
						 CODE)))))
	    (SETF (MA-INST-CODE I) CODE)))
	))

(DEFUN SUBST-ONE-LEVEL (FROM TO L)
  (IF (NLISTP L)
      L
      (CONS (IF (EQUAL FROM (CAR L)) TO (CAR L))
	    (SUBST-ONE-LEVEL FROM TO (CDR L)))))
;--

;link the AFTER state of this instruction to the BEFORE states of following
; instructions.
(DEFUN MA-HOOK-UP-STATE (INST)
  (LET ((CODE (MA-INST-CODE INST))
	(AFTER-STATE (MA-INST-AFTER-STATE INST))
	(TAG))
    (MA-LINK-STATES (MA-INST-BEFORE-STATE INST) AFTER-STATE)
    (IF (NULL (GET (CAR CODE) 'MA-NO-DROPTHRU))
	(MA-LINK-STATES AFTER-STATE		;dropthru first
			(MA-INST-BEFORE-STATE (MA-INST-NEXT-INST INST))))
    (COND ((AND (SETQ TAG (MA-TAG-USED CODE))	;** *CATCH ??
		(NOT (EQ (CAR CODE) 'OPTIONAL-ARG-JUMP-GREATER)))
	; OPTIONAL-ARG jumps would fake it out thinking the PDL level was wrong, etc
	   (MA-LINK-STATES AFTER-STATE
			   (MA-INST-BEFORE-STATE (GET TAG 'MA-TAG-POINTER))))))
)

(DEFUN MA-LINK-STATES (PRECEEDING-STATE FOLLOWING-STATE)
  (SETF (MA-STATE-FOLLOWING-STATES PRECEEDING-STATE)
	(NCONC (MA-STATE-FOLLOWING-STATES PRECEEDING-STATE)
	       (LIST FOLLOWING-STATE)))
  (SETF (MA-STATE-PRECEEDING-STATES FOLLOWING-STATE)
	(NCONC (MA-STATE-PRECEEDING-STATES FOLLOWING-STATE)
	       (LIST PRECEEDING-STATE)))
  )

(DEFUN MA-HOOK-UP-INST (IN-STATE-IMAGE INST)
 (PROG (CODE NSTATE)
   TOP (SETQ CODE (MA-INST-CODE INST))
      (COND ((NULL (MA-STATE-FILLED (MA-INST-BEFORE-STATE INST)))
	     (MA-COPY-STATE IN-STATE-IMAGE (MA-INST-BEFORE-STATE INST)))
	    (T (MA-MERGE-STATES INST (MA-INST-BEFORE-STATE INST) IN-STATE-IMAGE)))
      (COND ((NULL (MA-STATE-FILLED (SETQ NSTATE (MA-INST-AFTER-STATE INST))))
	     (MA-COPY-STATE (MA-INST-BEFORE-STATE INST) NSTATE)
	     (LET ((OP1 (MA-OP1-CODE CODE))
		   (OP2 (MA-OP2-CODE CODE))
		   (CONTEXT-CLOBBERAGE		;describes registers that get clobbered, etc.
		     (MA-CONTEXT-CLOBBERAGE CODE))
		   DEST RESULT-DATA-TYPE)
	       (MULTIPLE-VALUE (DEST RESULT-DATA-TYPE) (MA-DEST-CODE CODE))
	       (IF OP1 (SETF (MA-INST-OP1 INST)
			     (MA-EMULATE-FETCH INST OP1 NSTATE)))
	       (IF OP2 (SETF (MA-INST-OP2 INST)
			     (MA-EMULATE-FETCH INST OP2 NSTATE)))
	       (MA-EMULATE-INST-SLOTCHANGES INST CODE NSTATE)
	       (IF CONTEXT-CLOBBERAGE
		   (MA-EMULATE-CONTEXT-CLOBBERAGE CONTEXT-CLOBBERAGE NSTATE))
	       (IF DEST (MA-EMULATE-STORE INST DEST RESULT-DATA-TYPE NSTATE))
	       (LET ((NSTATES (MA-STATE-FOLLOWING-STATES NSTATE)))
		 (COND ((NULL NSTATES)
			(RETURN NIL))
		       ((NULL (CDR NSTATES))
			(SETQ IN-STATE-IMAGE NSTATE)	;"tail" recurse to avoid PCE
			(SETQ INST (MA-STATE-INST (CAR NSTATES)))
			(GO TOP))
		       (T (DOLIST (NS NSTATES)
			    (MA-HOOK-UP-INST NSTATE (MA-STATE-INST NS)))))))))
	    ))

;returns a CONS, CDR of which is the quantity list for the operand.
(DEFUN MA-EMULATE-FETCH (INST ADR STATE &AUX OP TEM)
  (SETQ OP (COND ((SYMBOLP ADR)
		  (ASSQ ADR (MA-STATE-REGISTER-ALIST STATE)))
		 ((MEMQ (CAR ADR) '(ARG LOCBLOCK))
		  (ASSOC ADR (MA-STATE-STACK-ALIST STATE)))
		 ((MEMBER ADR '((PDL-POP) (TOP-OF-PDL) (0 PP)))
		  (CAR (MA-STATE-STACK-ALIST STATE)))
		 ((EQ (CAR ADR) 'CONSTANT)	  ;A-MEMORY type constant
		  (CONS NIL (LIST (MA-MAKE-OPERAND ADR))))
		 ((MEMQ (CAR ADR) '(QUOTE FUNCTION SPECIAL))
		  (CONS NIL (LIST (MA-MAKE-OPERAND ADR))))   ;expects quantity list
		 (T (FERROR NIL "unknown adr"))))
  (COND ((EQUAL ADR '(PDL-POP))
	 (SETF (MA-STATE-STACK-ALIST STATE)
	       (CDR (MA-STATE-STACK-ALIST STATE)))))
  (COND ((AND INST OP)
	 (MAPC #'(LAMBDA (QUAN)
		   (SETF (MA-OPERAND-USES QUAN)
			 (CONS INST (MA-OPERAND-USES QUAN))))
	       (CDR OP))))
  (COND ((SETQ TEM (ASSOC ADR *MA-CUBBYHOLE-ALIST*))
	 (SETF (MA-CUBBYHOLE-REFS (CDR TEM))
	       (CONS (LIST 'FETCH INST) (MA-CUBBYHOLE-REFS (CDR TEM))))))
  OP)

(DEFUN MA-EMULATE-STORE (INST DEST RESULT-DATA-TYPE STATE &AUX OP TEM)
  (SETQ OP (MA-MAKE-OPERAND (FORMAT NIL "Result of ~S" (MA-INST-CODE INST))))
  (SETF (MA-OPERAND-TYPE OP) RESULT-DATA-TYPE)
  (COND ((AND (LISTP DEST)
	      (EQ (CAR DEST) 'PUSH-PDL))
	 (SETF (MA-STATE-STACK-ALIST STATE)
	       (CONS (CONS NIL (LIST OP))
		     (MA-STATE-STACK-ALIST STATE))))
	((SYMBOLP DEST)
	 (DO ((P (MA-STATE-REGISTER-ALIST STATE) (CDR P)))
	     ((NULL P)
	  ;    (FORMAT T "~%Creating register ~s, previous alist ~s"
	  ;            DEST (MA-STATE-REGISTER-ALIST STATE))
	      (SETF (MA-STATE-REGISTER-ALIST STATE)
		    (CONS (CONS DEST (LIST OP))
			  (MA-STATE-REGISTER-ALIST STATE))))
	   (COND ((EQ DEST (CAAR P))
	  ;       (FORMAT T "~%storing in ~s" DEST)
		  (RPLACA P (CONS DEST (LIST OP)))
		  (RETURN NIL)))))
	((MEMQ (CAR DEST) '(ARG LOCBLOCK))
	 (DO ((P (MA-STATE-STACK-ALIST STATE) (CDR P)))
	     ((NULL P)
	      (FERROR NIL "~%Unable to find cubbyhole ~S" DEST))
	   (COND ((EQUAL DEST (CAAR P))
  	  ;       (FORMAT T "~%storing in ~s" DEST)
		  (RPLACA P (CONS DEST (LIST OP)))
		  (RETURN NIL))))))
  (COND (INST (SETF (MA-OPERAND-SOURCE OP) INST)
	      (SETF (MA-INST-RESULT-OPERAND INST) OP)))
  (COND ((SETQ TEM (ASSOC DEST *MA-CUBBYHOLE-ALIST*))
	 (SETF (MA-CUBBYHOLE-REFS (CDR TEM))
	       (CONS (LIST 'STORE INST) (MA-CUBBYHOLE-REFS (CDR TEM))))))
  OP)

(DEFUN MA-EMULATE-INST-SLOTCHANGES (INST CODE STATE)
  (COND ((MEMQ (CAR CODE) '(CALL ARG-CALL OPEN-CALL OPEN-CALL-MV START-LIST START-LIST-AREA
			    MV-MICRO-CALL))
	 (COND ((EQ (CAR (CADR CODE)) 'PUSHES)
		(DOTIMES (C (CADR (CADR CODE)))
		  (SETF (MA-STATE-STACK-ALIST STATE)
			(CONS (LIST NIL) (MA-STATE-STACK-ALIST STATE)))))
	       ((EQ (CAR (CADR CODE)) 'POPS)
		(DOTIMES (C (CADR (CADR CODE)))		;"reference" the operands as they
		  (LET ((QUANS (CDR (CAR (MA-STATE-STACK-ALIST STATE)))))  ;are popped.
		    (DOLIST (QUAN QUANS)
		      (SETF (MA-OPERAND-USES QUAN)
			    (CONS INST (MA-OPERAND-USES QUAN)))))
		  (SETF (MA-INST-OP1 INST)		;save a list of the operands in OP1
			(CONS (CAR (MA-STATE-STACK-ALIST STATE)) ;the popping re-reverses them
			      (MA-INST-OP1 INST)))	;so the wind up first arg first.
		  (SETF (MA-STATE-STACK-ALIST STATE)
			(CDR (MA-STATE-STACK-ALIST STATE)))))))
	((EQ (CAR CODE) 'SUBI-PP)
	 (SETF (MA-STATE-STACK-ALIST STATE)
	       (NTHCDR (CADR CODE) (MA-STATE-STACK-ALIST STATE))))
	((MEMQ (CAR CODE) '(BNDPOP DISCARD-TOP-OF-STACK))
	 (SETF (MA-STATE-STACK-ALIST STATE)
	       (CDR (MA-STATE-STACK-ALIST STATE))))
	((EQ (CAR CODE) 'CREATE-CUBBYHOLE)
	 (RPLACA (CAR (MA-STATE-STACK-ALIST STATE))
		 (CADR CODE))     ;change from temp to cubbyhole
	 (MA-INITIALIZE-CUBBYHOLE-STRUCTURE (CADR CODE)))
	((MEMQ (CAR CODE) '(EXIT POP-SPECPDL-AND-EXIT
			    RETURN-NEXT-VALUE-OR-EXIT RETURN-N-VALUES-AND-EXIT
			    RETURN-2-VALUES-AND-EXIT RETURN-3-VALUES-AND-EXIT))
	 (PUSH INST *MA-FUNCTION-EXITS*)))
  STATE)

(DEFUN MA-EMULATE-CONTEXT-CLOBBERAGE (C-CODE STATE)
  (COND ((EQ C-CODE T)
	 (SETF (MA-STATE-REGISTER-ALIST STATE) NIL))
	(T (FERROR NIL "unknown context clobberage code"))))

(DEFUN MA-MERGE-STATES (*INST* INTO-STATE ADDED-STATE)
  (COND ((NOT (= (LENGTH (MA-STATE-STACK-ALIST INTO-STATE))
		 (LENGTH (MA-STATE-STACK-ALIST ADDED-STATE))))
	 (FERROR NIL "~%Stack lists not same length")))
  (SETF (MA-STATE-REGISTER-ALIST INTO-STATE)
	(MA-MERGE-REGISTER-ALISTS (MA-STATE-REGISTER-ALIST INTO-STATE)
				  (MA-STATE-REGISTER-ALIST ADDED-STATE)))
  (MA-MERGE-STACK-ALISTS (MA-STATE-STACK-ALIST INTO-STATE)
			 (MA-STATE-STACK-ALIST ADDED-STATE)))

;if register slot present but not in other, it becomes completely invalid.
;if register slots match, add the added-list operands to the into-list operands.
(DEFUN MA-MERGE-REGISTER-ALISTS (INTO-LIST ADDED-LIST)
  (PROG (TEM IP)	; registers-processed
	(SETQ IP INTO-LIST)
    L	(COND ((NULL IP)
	  	;Dont worry about added-list elems not present in into-list.
	       (RETURN INTO-LIST))
	      ((EQ (CADAR IP) 'INVALID))    ;forget it
	      ((SETQ TEM (ASSOC (CAAR IP) ADDED-LIST))  ;look for into-register on added-list
  ;	       (SETQ REGISTERS-PROCESSED (CONS (CAAR IP) REGISTERS-PROCESSED))
	       (MA-MATCH-SLOT-CONTENTS (CAR IP) TEM))
	      (T (MA-INVALIDATE (CAR IP))))
	(SETQ IP (CDR IP))
	(GO L)
))

;Value T if merged something (for debugging)
(DEFUN MA-MERGE-STACK-ALISTS (INTO-LIST ADDED-LIST &AUX MERGED)
  (DO ((ILP INTO-LIST (CDR ILP))
       (ALP ADDED-LIST (CDR ALP)))
      ((NULL ILP) INTO-LIST)
    (COND ((MA-MATCH-SLOT-CONTENTS (CAR ILP) (CAR ALP))
	   (SETQ MERGED T)))))

;Each slot point to a cons, the cdr of which is the operand list.
;Value T if merged something (for debugging)
(DEFUN MA-MATCH-SLOT-CONTENTS (IN-SLOT ADD-SLOT &AUX ADDED)
; (FORMAT T "~%Matching ~s and ~s" IN-SLOT ADD-SLOT)
  (LET ((I-IN-OPLIST (CDR IN-SLOT)))
    (COND ((EQ (CADR ADD-SLOT) 'INVALID)
	   (MA-INVALIDATE IN-SLOT))
	  (T 
	    (DOLIST (ADDED-OP (CDR ADD-SLOT))	;registers match, compare quanities
	      (COND ((NOT (MEMQ ADDED-OP I-IN-OPLIST))  ;dont add if already there.
		     (SETQ ADDED T)
		     (RPLACD IN-SLOT (CONS ADDED-OP (CDR IN-SLOT)))
      ;if this slot is OP1 or OP2 of its instruction and instruction has been
      ; processed (ie has after state), record ref of new operand
		;    (FORMAT T "~%adding ~s to ~s" ADDED-OP *INST*)
		     (IF (MA-INST-AFTER-STATE *INST*)
			 (IF (EQ IN-SLOT (MA-INST-OP1 *INST*))
			     (PUSH *INST* (MA-OPERAND-USES ADDED-OP))
			     )
			 (IF (EQ IN-SLOT (MA-INST-OP2 *INST*))
			     (PUSH *INST* (MA-OPERAND-USES ADDED-OP))))
		     )))
	    IN-SLOT)))
  ADDED)

(DEFUN MA-INVALIDATE (SLOT)
  (RPLACD SLOT (CONS 'INVALID (CDR SLOT))))

(DEFUN MA-OP1-CODE (INST &AUX TEM)
  (COND ((SETQ TEM (GET (CAR INST) 'MA-OP1))
	 (FUNCALL TEM INST))
	((GET (CAR INST) 'MA-JUMP)
	 (SECOND INST))))
	

(DEFUN MA-OP2-CODE (INST &AUX TEM)
  (COND ((SETQ TEM (GET (CAR INST) 'MA-OP2))
	 (FUNCALL TEM INST))
	((GET (CAR INST) 'MA-JUMP)
	 (THIRD INST))))

(DEFUN MA-DEST-CODE (INST &AUX TEM)
  (COND ((SETQ TEM (GET (CAR INST) 'MA-DEST))
	 (FUNCALL TEM INST))))

(DEFUN MA-CONTEXT-CLOBBERAGE (INST &AUX TEM)
  (COND ((SETQ TEM (GET (CAR INST) 'MA-CONTEXT-CLOBBERAGE))
	 (FUNCALL TEM INST))))

(DEFUN MA-TAG-USED (INST)
  (COND ((AND (GET (CAR INST) 'MA-JUMP)
	      (EQ (CAR (CADDDR INST)) 'UTAG))
	 (CADR (CADDDR INST)))
	((AND (EQ (CAR INST) 'MOVEI)		;Restart-PC on *catch open
	      (EQ (CAR (CADDR INST)) 'UTAG))
	 (CADR (CADDR INST)))))

(DEFUN MA-MAKE-INITIAL-STATE ()
  (SETQ *MA-CUBBYHOLES* NIL *MA-CUBBYHOLE-ALIST* NIL
	*MA-SEQUENCES* NIL *MA-FUNCTION-EXITS* NIL)
  (LET ((STATE (MAKE-MA-STATE)))
    (SETF (MA-STATE-STACK-ALIST STATE)
	  (DO ((VARL (CAR (MA-EVAL-SYM 'ALLVARS)) (CDR VARL))
	       (COUNT 0 (1+ COUNT))
	       (ANS))
	      ((NULL VARL) ANS)
	    (COND ((EQ (VAR-KIND (CAR VARL)) 'FEF-ARG-REQ)
		   (LET ((LAP-ADR (VAR-LAP-ADDRESS (CAR VARL))))
		     (COND ((NOT (OR (EQ (CAR LAP-ADR) 'SPECIAL)
				     (= COUNT (CADR LAP-ADR))))
		       ;maybe it shouldnt depend on this. At least it checks it.
			    (FERROR NIL "~%vars out of order")))
		     (SETQ ANS (CONS (CONS LAP-ADR
					   (LIST (MA-MAKE-OPERAND (VAR-NAME (CAR VARL)))))
				     ANS))
		     (MA-INITIALIZE-CUBBYHOLE-STRUCTURE LAP-ADR))))))
    (SETF (MA-STATE-INST STATE) 'BEGINNING-OF-FUNCTION)
    STATE))

(DEFUN MA-INITIALIZE-CUBBYHOLE-STRUCTURE (CUB-NAME)
  (LET ((CUB (MAKE-MA-CUBBYHOLE)))
    (PUSH CUB *MA-CUBBYHOLES*)
    (PUSH (CONS CUB-NAME CUB) *MA-CUBBYHOLE-ALIST*)
    (SETF (MA-CUBBYHOLE-NAME CUB) CUB-NAME)
    (SETF (MA-CUBBYHOLE-ALL-NAMES CUB) (LIST CUB-NAME))
    CUB))

;Find values assigned with UPARAM.
(DEFUN MA-EVAL-SYM (SYM &AUX TEM)
  (COND ((NULL (SETQ TEM (ASSQ SYM *MA-PARAM-LIST*)))
	 (FERROR NIL "~%UPARAM sym ~S undefined" SYM))
	(T (CDR TEM))))

(DEFUN MA-MAKE-OPERAND (NAME)
  (LET ((OP (MAKE-MA-OPERAND)))
    (SETF (MA-OPERAND-NAME OP) NAME)
    OP))

;--

(DEFUN MA-STATE-ACCESSIBLE-FROM-STATE-P (FROM TO)
  (PROG (STATE FOLLOWING-STATES STATES-TO-FOLLOW STATES-LOOKED-AT)
	(SETQ STATE FROM)
    L	(COND ((EQ STATE TO) (RETURN T)))
	(SETQ STATES-LOOKED-AT (CONS STATE STATES-LOOKED-AT))
	(COND ((NULL (SETQ FOLLOWING-STATES (MA-STATE-FOLLOWING-STATES STATE)))
	       (GO POP))
	      ((NULL (CDR FOLLOWING-STATES))
	       (SETQ STATE (CAR FOLLOWING-STATES))
	       (GO L))
	      (T (SETQ STATES-TO-FOLLOW (APPEND (CDR FOLLOWING-STATES) STATES-TO-FOLLOW))
		 (SETQ STATE (CAR FOLLOWING-STATES))
		 (GO L)))
    POP	(COND ((NULL STATES-TO-FOLLOW)
	       (RETURN NIL)))
	(SETQ STATE (CAR STATES-TO-FOLLOW) STATES-TO-FOLLOW (CDR STATES-TO-FOLLOW))
	(GO L)))


(DEFUN MA-PRINT-CODE NIL
  (DOINSTS (E *MA-FIRST-INST*)
    (IF (MA-INST-TAGS-BEFORE E) (PRINT (MA-INST-TAGS-BEFORE E)))
    (PRINT (MA-INST-CODE E))))

(DEFUN MA-DESCRIBE-CODE NIL
  (DOINSTS (I *MA-FIRST-INST*)
     (DESCRIBE I)))

(DEFUN MA-SHOW-STATES (&OPTIONAL WHICH)
  (DOINSTS (I *MA-FIRST-INST*)
    (FORMAT T "~%inst: ~S" I)
    (COND ((NOT (EQ WHICH 'AFTER))
	   (FORMAT T "  Before state")
	   (SI:DESCRIBE-1 (MA-INST-BEFORE-STATE I))))
    (COND ((NOT (EQ WHICH 'BEFORE))
	   (FORMAT T "  After state")
	   (SI:DESCRIBE-1 (MA-INST-AFTER-STATE I))))))

(DEFUN MA-SHOW-CUBBYHOLES (&OPTIONAL CUB)
  (COND ((NULL CUB)
	 (MAPC (FUNCTION DESCRIBE) *MA-CUBBYHOLES*))
	(T (DESCRIBE (CDR (ASSOC CUB *MA-CUBBYHOLE-ALIST*))))))

(DEFUN MA-SHOW-SEQUENCES NIL
  (MAPC (FUNCTION DESCRIBE) *MA-SEQUENCES*))

(DEFUN MA-SHOW-LOOPS NIL
  (MAPC (FUNCTION DESCRIBE) *MA-LOOPS*))

(DEFUN MA-SHOW-BUBBLES NIL
  (MAPC (FUNCTION DESCRIBE) *MA-BUBBLES*))

(DEFUN MA-SHOW-PATH (PATH)
  (DOLIST (P PATH)
    (MA-SHOW-ELEM P 0)))

(DEFUN MA-SHOW-ELEM (E INDENT)
  (FORMAT T "~%~VX~S:" INDENT (TYPEP E))
  (SELECTQ (TYPEP E)
    (MA-INST (PRIN1 (MA-INST-CODE E)))
    (MA-SEQUENCE
     (DOLIST (E1 (MA-ELEM-MEMBERS E))
       (MA-SHOW-ELEM E1 (+ INDENT 2))))
    (MA-BUBBLE
     (DO ((C 1 (1+ C))
	  (P (MA-BUBBLE-PATHS E) (CDR P)))
	 ((NULL P))
       (PRIN1 C)
       (DOLIST (E1 (CAR P))
	 (MA-SHOW-ELEM E1 (+ INDENT 2)))))
    (MA-LOOP
     (DOLIST (E1 (MA-ELEM-MEMBERS E))
       (MA-SHOW-ELEM E1 (+ INDENT 2))))))

(DEFUN MA-GRUBBLE (&OPTIONAL (PC 0) (FIRST-SEQ *MA-FIRST-INST*))
  (PROG (CH I)
  LOOP  (SETQ I FIRST-SEQ)
        (DOTIMES (C PC)
	  (SETQ I (MA-INST-NEXT-INST I)))
     	(FORMAT T "~%PC ~S: ~S" PC I)
	(SETQ CH (TYI))
	(COND ((EQ CH #/!)
	       (SETQ *MA-OPT-FLAG* NIL)
	       (MA-OPT-SEQUENCE (MA-INST-SEQUENCE I))
	       (FORMAT T "~%MA-OPT-FLAG ~s" *MA-OPT-FLAG*))
	      ((MEMQ CH '(#/P #/p))
	       (SETQ PC (MAX 0 (1- PC))))
	      ((MEMQ CH '(#/N #/n))
	       (SETQ PC (1+ PC)))
	      ((MEMQ CH '(#/S #/s))
	       (FORMAT T "~%  Before state")
	       (SI:DESCRIBE-1 (MA-INST-BEFORE-STATE I))
	       (FORMAT T "~%  After state")
	       (SI:DESCRIBE-1 (MA-INST-AFTER-STATE I)))
	      ((MEMQ CH '(#/D #/d))
	       (DESCRIBE I))
	      ((MEMQ CH '(#/O #/o))
	       (COND ((MA-INST-OP1 I)
		      (FORMAT T "~% MA-INST-OP1")
		      (MA-DESCRIBE-SLOT (MA-INST-OP1 I))))
	       (COND ((MA-INST-OP2 I)
		      (FORMAT T "~% MA-INST-OP2")
		      (MA-DESCRIBE-SLOT (MA-INST-OP2 I))))
	       (COND ((MA-INST-RESULT-OPERAND I)
		      (FORMAT T "~% MA-INST-RESULT-OPERAND")
		      (SI:DESCRIBE-1 (MA-INST-RESULT-OPERAND I)))))
	      ((MEMQ CH '(#/Q #/q))
	       (RETURN PC))
	      ((MEMQ CH '(#/E #/e))
	       (PRINT (MA-INST-EXPANSION I))))
	(GO LOOP)))

(DEFUN MA-DESCRIBE-SLOT (S)
  (FORMAT T "Slot: cubbyhole ~s " (CAR S))
  (MAPC (FUNCTION SI:DESCRIBE-1) (CDR S)))

;jumps that take two operands and a tag
(defprop jump-greater conditional ma-jump)
(defprop optional-arg-jump-greater conditional ma-jump)
(defprop jump always ma-jump)
(defprop jump-equal conditional ma-jump)
(defprop jump-not-equal conditional ma-jump)
(defprop jump-if-atom conditional ma-jump)
(defprop jump-if-not-atom conditional ma-jump)
(DEFPROP DYNAMIC-STACK-TEST CONDITIONAL MA-JUMP)

;These definitely cause a break in program flow.
(DEFPROP JUMP T MA-NO-DROPTHRU)
(DEFPROP EXIT T MA-NO-DROPTHRU)
(DEFPROP POP-SPECPDL-AND-EXIT T MA-NO-DROPTHRU)
(DEFPROP RETURN-N-VALUES-AND-EXIT T MA-NO-DROPTHRU)
(DEFPROP RETURN-2-VALUES-AND-EXIT T MA-NO-DROPTHRU)
(DEFPROP RETURN-3-VALUES-AND-EXIT T MA-NO-DROPTHRU)


;Ref consists of returning value
(DEFUN (EXIT MA-OP1) (INST) INST
  'T)

(DEFUN (POP-SPECPDL-AND-EXIT MA-OP1) (INST) INST
  'T)

(DEFUN (MOVE MA-OP1) (INST)
  (THIRD INST))

(DEFUN (MOVE MA-DEST) (INST)
  (PROG NIL (RETURN (SECOND INST) (CAR (FOURTH INST)))))   ;type in byte spec if present

(DEFUN (MOVE-LOCATIVE-T MA-OP1) (INST)
  (SECOND INST))
       
(DEFUN (MOVE-LOCATIVE-T MA-DEST) (INST) INST
  'T)

(DEFUN (OPEN-CALL MA-OP1) (INST)
  (FOURTH INST))

(DEFUN (ARG-CALL MA-DEST) (INST) INST
  'T)

(DEFUN (ARG-CALL MA-CONTEXT-CLOBBERAGE) (INST) INST
  'T)

(DEFUN (CALL MA-DEST) (INST) 
  (PROG NIL (RETURN 'T (COND ((AND (LISTP (CAR (LAST INST)))
				   (MEMQ (CAAR (LAST INST)) '(MC-LINKAGE MISC-ENTRY))
				   (GET (CADAR (LAST INST)) 'RESULT-DATA-TYPE)))))))

(DEFUN (CALL MA-CONTEXT-CLOBBERAGE) (INST) INST
  'T)

(DEFUN (MV-MICRO-CALL MA-CONTEXT-CLOBBERAGE) (INST) INST
  'T)

;MV-MICRO-CALL ?

;make a pass thru making octal numbers and field plugins.
(DEFUN MA-CONVERT ()
  (LET ((*MA-SPECBIND-DONE* NIL)
	(*PDL-BUFFER-INDEX* NIL)
	(*PDL-BUFFER-WRITE-HAPPENING* NIL))
    (DOINSTS (INST *MA-FIRST-INST*)
      (MA-CONVERT-INST INST))))

(DEFUN MA-CONVERT-INST (*INST*)
  (LET ((*EMIT-LIST* NIL))
    (SETQ *PDL-BUFFER-INDEX* NIL)		;For now.
    (MA-CONVERT-CODE (MA-INST-CODE *INST*))
    (SETF (MA-INST-EXPANSION *INST*) *EMIT-LIST*)))

(DEFUN MA-CONVERT-LIST (CODEL)
  (MAPC (FUNCTION MA-CONVERT-CODE) CODEL))

(DEFUN MA-CONVERT-CODE (CODE)
  (FUNCALL (GET (CAR CODE) 'MA-ASSEMBLE) CODE))

(DEFUN (DO-SPECBIND MA-ASSEMBLE) (INST) INST
  (PROG (BIT-MASK SLOTLIST BIT VC-LIST)
	(SETQ BIT-MASK 0 BIT 1)
	(SETQ SLOTLIST (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*)))
    L	(COND ((NULL SLOTLIST)
	       (SETQ *MA-SPECBIND-DONE* T)
	       (COND ((NOT (ZEROP BIT-MASK))
		      (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
			       CADR:CONS-IR-ALUF CADR:CONS-ALU-SETA
			       CADR:CONS-IR-OB CADR:CONS-OB-ALU
			       CADR:CONS-IR-M-MEM-DEST (MC-LINKAGE-EVAL 'C)
			       CADR:CONS-IR-A-SRC (MA-GET-A-CONSTANT BIT-MASK))
		      (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
			       CADR:CONS-IR-DISP-CONST (MA-GET-QUOTE-INDEX-VECTOR VC-LIST)
			       CADR:CONS-IR-DISP-ADDR
			            (MC-LINKAGE-EVAL 'D-DO-SPECBIND-PP-BASED))))
	       (SETQ *PDL-BUFFER-INDEX* NIL)	;gets clobbered.
	       (RETURN NIL))
	      ((AND (LISTP (CAAR SLOTLIST))
		    (EQ (CAAAR SLOTLIST) 'SPECIAL))
	       (SETQ BIT-MASK (LOGIOR BIT-MASK BIT))
	       (SETQ VC-LIST (NCONC VC-LIST (LIST (CAAR SLOTLIST))))))
	(SETQ SLOTLIST (CDR SLOTLIST) BIT (LSH BIT 1))
	(GO L)))
	
(DEFUN (MOVE MA-ASSEMBLE) (INST &AUX M A
				(STACK (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*)))
				CDR-CODING BYTE-SPEC TEM)
  (SETQ CDR-CODING (IF (AND (LISTP (CADR INST))
			    (EQ (CAADR INST) 'PUSH-PDL)
			    (MEMQ (SETQ TEM (CADADR INST)) '(D-NEXT D-LAST)))
		       (IF (EQ TEM 'D-NEXT) CDR-NEXT CDR-NIL)
		       0))
  (SETQ BYTE-SPEC (FOURTH INST))
  (COND ((AND (MA-USES-PI (SECOND INST))
	      (MA-USES-PI (THIRD INST)))
	 (MA-CONVERT-LIST `((MOVE TEM ,(CADDR INST))	;split since pi needs to change in 
			    (MOVE ,(CADR INST) TEM))))   ;middle.
	((AND (NOT (MEMQ (CADDR INST) *M-REGISTERS*))	 ;Dont ref these from the A side
							 ; since may want to hack CDR-CODE.
	      (NULL BYTE-SPEC)
	      (ZEROP CDR-CODING)
	      (SETQ A (MA-A-REFFABLE (CADDR INST) CDR-CODING)))
	 (MULTIPLE-VALUE-BIND (FD RD) (MA-PREPARE-STORE (CADR INST) STACK)
	   (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
		    CADR:CONS-IR-ALUF CADR:CONS-ALU-SETA
		    CADR:CONS-IR-OB CADR:CONS-OB-ALU
		    CADR:CONS-IR-FUNC-DEST FD
		    CADR:CONS-IR-M-MEM-DEST RD
		    CADR:CONS-IR-A-SRC A)
	   (MA-NOTE-PDL-WRITE FD STACK)
	   (MA-FINISH-STORE (CADR INST))))
	(T (SETQ M (MA-REF-M-SIDE (CADDR INST) STACK))
	 (MULTIPLE-VALUE-BIND (FD RD) (MA-PREPARE-STORE (CADR INST) STACK)
	   (COND ((AND (NUMBERP M)
		       (< M 40)
		       (ZEROP CDR-CODING)
		       (NULL BYTE-SPEC))		;no masking needed
		  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
			   CADR:CONS-IR-ALUF CADR:CONS-ALU-SETM
			   CADR:CONS-IR-OB CADR:CONS-OB-ALU
			   CADR:CONS-IR-FUNC-DEST FD
			   CADR:CONS-IR-M-MEM-DEST RD
			   CADR:CONS-IR-M-SRC M))
		 (T (SETQ A (MA-GET-A-CONSTANT
			      (DPB CDR-CODING
				   %%Q-CDR-CODE
				   (IF (NULL BYTE-SPEC)
				       0
				       (DPB (EVAL (CAR BYTE-SPEC))
					    %%Q-DATA-TYPE
					    0)))))
		    (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-BYTE  ;automatically mask to 
			     CADR:CONS-IR-FUNC-DEST FD		;Q-TYPED-POINTER
			     CADR:CONS-IR-M-MEM-DEST RD
			     CADR:CONS-IR-M-SRC M
			     CADR:CONS-IR-A-SRC A	        ;maybe insert CDR-CODE
			     CADR:CONS-IR-BYTL-1 (COND ((NULL BYTE-SPEC) 28.)
						       (T (1- (CADR BYTE-SPEC))))
			     CADR:CONS-IR-MROT   (COND ((OR (NULL BYTE-SPEC)
							    (= (CADDR BYTE-SPEC) 32.))
							0)
						       (T (- 32. (CADDR BYTE-SPEC))))
			     CADR:CONS-IR-BYTE-FUNC CADR:CONS-BYTE-FUNC-LDB)))
	   (MA-NOTE-PDL-WRITE FD STACK)
	   (MA-FINISH-STORE (CADR INST))))))

;(SETQ *PDL-BUFFER-INDEX* NIL) ?? ***
(DEFUN (MOVE-LOCATIVE-T MA-ASSEMBLE) (INST)
  (LET ((OP (CADR INST))
	(STACK (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*))))
    (COND ((OR (MEMQ (CAR OP) '(ARG LOCBLOCK))
	       (AND (NULL *MA-SPECBIND-DONE*)
		    (EQ (CAR OP) 'SPECIAL)
		    (ASSOC OP STACK)))
	   (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
		    CADR:CONS-IR-DISP-CONST (MA-ADDRESS-PDL OP STACK)
		    CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-GET-LOCATIVE-TO-PDL)))
	  ((EQ (CAR OP) 'SPECIAL)
	   (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
		    CADR:CONS-IR-DISP-CONST (MA-GET-QUOTE-INDEX OP)
		    CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-GET-LOCATIVE-TO-VC))))))

(DEFUN (CREATE-CUBBYHOLE MA-ASSEMBLE) (INST) INST NIL)
(DEFUN (START-CUBBYHOLE MA-ASSEMBLE) (INST) INST NIL)

(DEFUN (JUMP MA-ASSEMBLE) (INST) 
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-UNC
	   CADR:CONS-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   CADR:CONS-IR-N 1))

;open micro-macro call block, no extra hair.
(DEFUN (OPEN-CALL MA-ASSEMBLE) (INST)
  (COND ((EQ (FOURTH INST) 'T)
	 (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
		  CADR:CONS-IR-P 1
		  CADR:CONS-IR-N 1
		  CADR:CONS-IR-JUMP-ADDR
		     (MA-EVALUATE-MC-LINKAGE '(MC-LINKAGE P3ZERO))
		  CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-UNC)
	 (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
		  CADR:CONS-IR-ALUF CADR:CONS-ALU-SETM
		  CADR:CONS-IR-OB CADR:CONS-OB-ALU
		  CADR:CONS-IR-M-SRC (MA-EVAL-M-REG 'T)
		  CADR:CONS-IR-FUNC-DEST CADR:CONS-FUNC-DEST-PDL-BUFFER-PUSH))
	(T
	 (MA-EMIT-EXIT-REF (FOURTH INST)
			   (MC-LINKAGE-EVAL 'D-CALL-EXIT-VECTOR)))))

(DEFUN (CALL MA-ASSEMBLE) (INST)
 ;maybe insert MOVEI R NARGS at MCLAP time.
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-ADDR (MA-EVALUATE-MC-LINKAGE (FOURTH INST))
	   CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-UNC
	   CADR:CONS-IR-P 1
	   CADR:CONS-IR-N 1)
  (SETQ *PDL-BUFFER-INDEX* NIL))

(DEFUN (BNDPOP MA-ASSEMBLE) (INST)
  (MA-EMIT-EXIT-REF (SECOND INST)
		    (MC-LINKAGE-EVAL 'D-BNDPOP)))

(DEFUN (BNDNIL MA-ASSEMBLE) (INST)
  (MA-EMIT-EXIT-REF (SECOND INST)
		    (MC-LINKAGE-EVAL 'D-BNDNIL)))

(DEFUN (POP-SPECPDL MA-ASSEMBLE) (INST)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (CADR INST)
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-POP-SPECPDL)))
  
(DEFPROP JUMP-EQUAL MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-NOT-EQUAL MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-GREATER MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP OPTIONAL-ARG-JUMP-GREATER MA-ASSEMBLE-JUMP MA-ASSEMBLE)

(DEFUN MA-ASSEMBLE-JUMP (INST &AUX A M M1)
  (SETQ M (MA-REF-M-SIDE (CADR INST)))
  (COND ((NOT (SYMBOLP (CADR INST)))	;A CROCK FOR NOW.  MASK TO 29 BITS IF NOT IN M-T.
	 (SETQ M1 (MA-EVAL-M-REG 'TEM))
	 (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-BYTE
		  CADR:CONS-IR-A-SRC 2	       ;A-ZERO
		  CADR:CONS-IR-M-SRC M
		  CADR:CONS-IR-M-MEM-DEST M1
		  CADR:CONS-IR-BYTL-1 (1- 29.)
		  CADR:CONS-IR-MROT 0)
	 (SETQ M M1)))
  (SETQ A (MA-A-REFFABLE (CADDR INST) 0))
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   CADR:CONS-IR-JUMP-COND (EVAL (CADR
					  (ASSQ (CAR INST)
					     '((JUMP-EQUAL CADR:CONS-JUMP-COND-M=A)
					       (JUMP-NOT-EQUAL CADR:CONS-JUMP-COND-M-NEQ-A)
					       (JUMP-GREATER CADR:CONS-JUMP-COND-M>A)
					       (OPTIONAL-ARG-JUMP-GREATER
						 CADR:CONS-JUMP-COND-M>A)))))
	   CADR:CONS-IR-M-SRC M
	   CADR:CONS-IR-A-SRC A
	   CADR:CONS-IR-N 1))

(DEFPROP JUMP-IF-ATOM MA-ASSEMBLE-JUMP-ATOM MA-ASSEMBLE)
(DEFPROP JUMP-IF-NOT-ATOM MA-ASSEMBLE-JUMP-ATOM MA-ASSEMBLE)

(DEFUN MA-ASSEMBLE-JUMP-ATOM (INST &AUX M)
  (SETQ M (MA-REF-M-SIDE (CADR INST)))
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH  ;SKIP ON ATOM OR SKIP ON NO-ATOM
	   CADR:CONS-IR-M-SRC M
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL (COND ((EQ (CAR INST) 'JUMP-IF-ATOM)
							  'SKIP-IF-NO-ATOM)
							 (T 'SKIP-IF-ATOM)))
	   CADR:CONS-IR-DISP-BYTL 5
	   CADR:CONS-IR-MROT 8.)	;Q-DATA-TYPE
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-UNC
	   CADR:CONS-IR-N 1))

;jump to macro branch if USP > n.
(DEFUN (DYNAMIC-STACK-TEST MA-ASSEMBLE) (INST)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   CADR:CONS-IR-M-SRC CADR:CONS-M-SRC-MICRO-STACK
	   CADR:CONS-IR-A-SRC (MA-GET-A-CONSTANT (DPB 10. 3005 0))  ;7 levels MICRO-MICRO
	   CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-M>A
	   CADR:CONS-IR-N 1))

;(DEFUN (EXIT MA-ASSEMBLE) (INST) INST
;  (MA-EMIT-SUB-PP (LENGTH (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*)) )))

(DEFUN (EXIT MA-ASSEMBLE) (INST) INST
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-SUB-PP)))

(DEFUN (POP-SPECPDL-AND-EXIT MA-ASSEMBLE) (INST) INST
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-POP-SPECPDL-AND-SUB-PP)))

;D-MURV, D-MRNV, D-MR2V, D-MR3V
;RETURN-NEXT-VALUE-OR-EXIT, RETURN-N-VALUES-AND-EXIT, RETURN-2-VALUES-AND-EXIT,
; RETURN-3-VALUES-AND-EXIT.  MUST COMMUNICATE SUB-IP TO BE DONE.

(DEFUN (DISCARD-TOP-OF-STACK MA-ASSEMBLE) (INST) INST
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
	   CADR:CONS-IR-M-SRC CADR:CONS-M-SRC-C-PDL-BUFFER-POINTER-POP))

;used with D-UCTOM, D-MMISU, D-MMCALB, D-MMCALT, D-MMCALL
(DEFUN (ARG-CALL MA-ASSEMBLE) (INST)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (CADR (ASSQ 'ARGS (THIRD INST)))
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL (FOURTH INST)))  ;D-MMCALL, etc
  (SETQ *PDL-BUFFER-INDEX* NIL))

(DEFUN (START-LIST MA-ASSEMBLE) (INST)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (THIRD INST)
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-START-LIST))
  (SETQ *PDL-BUFFER-INDEX* NIL))	;can take error

(DEFUN (START-LIST-AREA MA-ASSEMBLE) (INST)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (THIRD INST)
	   CADR:CONS-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-START-LIST-AREA))
  (SETQ *PDL-BUFFER-INDEX* NIL))	;can take error

;SECDR SECDDR SE1+ SE1-
(DEFPROP SE1+ MA-SE MA-ASSEMBLE)
(DEFPROP SE1- MA-SE MA-ASSEMBLE)
(DEFPROP SECDR MA-SE MA-ASSEMBLE)
(DEFPROP SECDDR MA-SE MA-ASSEMBLE)

(DEFUN MA-SE (INST)
  (MA-EMIT-EXIT-REF (SECOND INST)
		    (MC-LINKAGE-EVAL
		      (CDR (ASSQ (CAR INST)
				 '( (SE1+ . D-SE1+) (SE1- . D-SE1-)
				   (SECDR . D-SECDR) (SECDDR . D-SECDDR))))))
  (SETQ *PDL-BUFFER-INDEX* NIL))	;could send message

;OPEN-CALL-MV
;MV-MICRO-CALL

;Return numeric quantity for M-SOURCE field.
(DEFUN MA-REF-M-SIDE (OP &OPTIONAL
			 (STACK (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*))))
  (COND ((ATOM OP)
	 (COND ((MA-EVAL-M-REG OP))
	       (T (FERROR NIL ""))))
	((EQUAL OP '(PDL-POP))
	 (COND ((AND *PDL-BUFFER-WRITE-HAPPENING*
		     (= *PDL-BUFFER-WRITE-HAPPENING* (LENGTH STACK)))
		(MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU)))  ;insert no-op to avoid losing
	 CADR:CONS-M-SRC-C-PDL-BUFFER-POINTER-POP)
	((MEMBER OP '((TOP-OF-PDL) (0 PP)))
	 (COND ((AND *PDL-BUFFER-WRITE-HAPPENING*
		     (= *PDL-BUFFER-WRITE-HAPPENING* (LENGTH STACK)))
		(MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU)))  ;insert no-op to avoid losing
	 CADR:CONS-M-SRC-C-PDL-BUFFER-POINTER)
	((OR (MEMQ (CAR OP) '(ARG LOCBLOCK))
	     (AND (NULL *MA-SPECBIND-DONE*)
		  (EQ (CAR OP) 'SPECIAL)
		  (ASSOC OP STACK)))
	 (LET ((IDX (MA-ADDRESS-PDL OP STACK)))
	   (COND ((ZEROP IDX)
		  (COND ((AND *PDL-BUFFER-WRITE-HAPPENING*
			      (= *PDL-BUFFER-WRITE-HAPPENING* (LENGTH STACK)))
			 (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU)))	;no-op
		  CADR:CONS-M-SRC-C-PDL-BUFFER-POINTER)
		 (T 
		   (MA-SET-PDL-INDEX-RELATIVE IDX STACK)
		   (COND ((AND *PDL-BUFFER-WRITE-HAPPENING*
			       (= *PDL-BUFFER-WRITE-HAPPENING* *PDL-BUFFER-INDEX*))
			  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU)))	;no-op
		   CADR:CONS-M-SRC-C-PDL-BUFFER-INDEX))))
	((MEMQ (CAR OP) '(QUOTE SPECIAL FUNCTION))
	 (MA-REF-QUOTE-VECTOR OP)
	 CADR:CONS-M-SRC-MD)
	(T (FERROR NIL ""))
))

(DEFUN MA-EVAL-M-REG (REG)
   (AND (MEMQ REG *M-REGISTERS*)
	(MC-LINKAGE-EVAL REG)))

;called from optimizer pattern to see if operand can live in A-MEM
(DEFUN MA-CAN-LIVE-IN-A-MEM (OP)
  (AND (LISTP OP)
       (EQ (CAR OP) 'QUOTE)
       (OR (MEMQ (CADR OP) '(T NIL))
	   (FIXP (CADR OP)))))

;number to ref quanity from A-side, or NIL if not possible.
;CDR-CODE can be 0, 1 (CDR-NIL) or 3 (CDR-NEXT).
(DEFUN MA-A-REFFABLE (OP CDR-CODE)
  (PROG (TEM)
	(COND ((SETQ TEM (MC-LINKAGE-EVAL OP T))
	       (IF (NOT (ZEROP CDR-CODE))
		   (FERROR NIL "")
		   (RETURN TEM)))
	      ((EQUAL OP '(QUOTE NIL))
	       (IF (ZEROP CDR-CODE)
		   (RETURN (MC-LINKAGE-EVAL 'A-V-NIL))
		   (SETQ TEM 0) (GO CROCK)))
	      ((EQUAL OP '(QUOTE T))
	       (IF (ZEROP CDR-CODE)
		   (RETURN (MC-LINKAGE-EVAL 'A-V-TRUE))
		   (SETQ TEM 5) (GO CROCK)))
	      ((AND (LISTP OP)
		    (EQ (CAR OP) 'CONSTANT))
	       (SETQ TEM (CADR OP))
	       (GO CROCK))
	      ((AND (LISTP OP)
		    (EQ (CAR OP) 'QUOTE)	;numeric constant can live in A-MEM
		    (FIXP (CADR OP)))
	       (SETQ TEM (DPB DTP-FIX %%Q-DATA-TYPE (CADR OP)))
	       (GO CROCK))
	      (T (RETURN NIL)))
     CROCK (RETURN (MA-GET-A-CONSTANT (DPB CDR-CODE %%Q-CDR-CODE TEM)))
))
	
;someday add ref var's via M-AP switch
(DEFUN MA-SET-PDL-INDEX-RELATIVE (N STACK)
  (LET ((ABS-INDEX (- (LENGTH STACK) N)))
    (COND ((NOT (EQ *PDL-BUFFER-INDEX* ABS-INDEX))
	   (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
		    CADR:CONS-IR-ALUF CADR:CONS-ALU-SUB
		    CADR:CONS-IR-OB CADR:CONS-OB-ALU
		    CADR:CONS-IR-FUNC-DEST CADR:CONS-FUNC-DEST-PDL-BUFFER-INDEX
		    CADR:CONS-IR-M-SRC CADR:CONS-M-SRC-PDL-BUFFER-POINTER
		    CADR:CONS-IR-A-SRC (MA-GET-A-CONSTANT N))
	   (SETQ *PDL-BUFFER-INDEX* ABS-INDEX)))))

;Return number to subtract from PP to address given frob.
(DEFUN MA-ADDRESS-PDL (OP STACK &AUX TEM)
  (COND ((SETQ TEM (ASSOC OP STACK))
	 (FIND-POSITION-IN-LIST TEM STACK))
	(T (FERROR NIL ""))))

;call this just after having emitted an uinst with functional destination FD.
;This function will set up *PDL-BUFFER-WRITE-HAPPENING* if necessary.
(DEFUN MA-NOTE-PDL-WRITE (FD STACK)
  (COND ((= FD CADR:CONS-FUNC-DEST-C-PI)
	 (SETQ *PDL-BUFFER-WRITE-HAPPENING* *PDL-BUFFER-INDEX*))
	((= FD CADR:CONS-FUNC-DEST-C-PP)
	 (SETQ *PDL-BUFFER-WRITE-HAPPENING* (LENGTH STACK)))
	((= FD CADR:CONS-FUNC-DEST-PDL-BUFFER-PUSH)
	 (SETQ *PDL-BUFFER-WRITE-HAPPENING* (1+ (LENGTH STACK))))))

(DEFUN MA-USES-PI (OP)
  (AND (LISTP OP)
       (OR (MEMQ (CAR OP) '(ARG LOCBLOCK))
	   (AND (NULL *MA-SPECBIND-DONE*)
		(EQ (CAR OP) 'SPECIAL)
		(ASSOC OP (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*)))))))

;emit instrution if necessary before generation of actual quantity. (This
; means set up the PDL-BUFFER.)  Returns two values, first number for
; functional destination, 2nd for register destination
;Note a possible problem if the FETCH changed the stack layout (ie was a
; C-PDL-BUFFER-POINTER-POP) and was split off in an already emitted uinst. 
; Then our PDL indexing would be off by one.  This can't happen, tho, because
; C-PDL-BUFFER-POINTER-POP does not get split off.
(DEFUN MA-PREPARE-STORE (OP STACK)
 (PROG (TEM)
       (COND ((ATOM OP)
	      (COND ((SETQ TEM (MA-EVAL-M-REG OP))
		     (RETURN 0 TEM))
		    (T (FERROR NIL ""))))
	     ((EQ (CAR OP) 'PUSH-PDL)
	      (RETURN CADR:CONS-FUNC-DEST-PDL-BUFFER-PUSH
		      0))
	     ((OR (MEMQ (CAR OP) '(ARG LOCBLOCK))
		  (AND (NULL *MA-SPECBIND-DONE*)
		       (EQ (CAR OP) 'SPECIAL)
		       (ASSOC OP STACK)))
	      (COND ((ZEROP (SETQ TEM (MA-ADDRESS-PDL OP STACK)))
		     (RETURN CADR:CONS-FUNC-DEST-C-PP 0))
		    (T
		      (MA-SET-PDL-INDEX-RELATIVE TEM STACK)
		      (RETURN CADR:CONS-FUNC-DEST-C-PI
			      0))))
	     ((MEMQ (CAR OP) '(QUOTE SPECIAL FUNCTION))
	      (RETURN CADR:CONS-FUNC-DEST-MD 0))
	     (T (FERROR NIL "")))))

(DEFUN MA-FINISH-STORE (OP)
  (COND ((AND (LISTP OP)
	      (MEMQ (CAR OP) '(QUOTE SPECIAL FUNCTION))
	      (NOT (AND (NULL *MA-SPECBIND-DONE*)
			(EQ (CAR OP) 'SPECIAL)
			(ASSOC OP (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*))))))
	 (MA-EMIT-EXIT-REF OP (MC-LINKAGE-EVAL 'D-WRITE-EXIT-VECTOR)))))

(DEFUN MA-REF-QUOTE-VECTOR (QUAN)
  (MA-EMIT-EXIT-REF QUAN (MC-LINKAGE-EVAL 'D-READ-EXIT-VECTOR)))

(DEFUN MA-EMIT-EXIT-REF (QUAN DISP-ADR)
  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-DISPATCH
	   CADR:CONS-IR-DISP-CONST (MA-GET-QUOTE-INDEX QUAN)
	   CADR:CONS-IR-DISP-ADDR DISP-ADR))


;(DEFUN MA-EMIT-SUB-PP (N)
;  (MA-EMIT CADR:CONS-IR-OP CADR:CONS-OP-ALU
;	   CADR:CONS-IR-M-SRC CADR:CONS-M-SRC-PDL-BUFFER-POINTER
;	   CADR:CONS-IR-A-SRC (MA-GET-A-CONSTANT N)
;	   CADR:CONS-IR-FUNC-DEST CADR:CONS-FUNC-DEST-PDL-BUFFER-POINTER
;	   CADR:CONS-IR-OB CADR:CONS-OB-ALU
;	   CADR:CONS-IR-ALUF CADR:CONS-ALU-SUB))

(DEFUN MA-INFO (FCTN)
  (LET ((FC (FSYMEVAL FCTN)))
    (COND ((= (%DATA-TYPE FC) DTP-U-ENTRY)
	   (LET* ((UEI (%MAKE-POINTER DTP-FIX FC))
		  (MSI (MICRO-CODE-ENTRY-AREA UEI))
		  (UADR (MICRO-CODE-SYMBOL-AREA MSI)))
	     (FORMAT T "~%Microcode-entry-index ~s, micro-code-symbol-index ~s, ucode adr ~s"
		     UEI MSI UADR))))))



;---
;mclap interface
(DEFUN MAKE-MCLAP NIL
  (COND ((NULL *MA-MAKE-MCLAP-SEQUENCE-WISE*)
	 (MA-MAKE-MCLAP-SIMPLE))
	(T
	 (DOLIST (SEQ *MA-SEQUENCES*)
	   (SETF (MA-SEQ-CHANGED SEQ) NIL))
	 (MA-MCLAP-TRACE-SEQ *MA-FIRST-SEQUENCE*))))

(DEFUN MA-MAKE-MCLAP-SIMPLE (&AUX ANS TAILP)
  (SETQ TAILP (VALUE-CELL-LOCATION 'ANS))
  (DOINSTS (I *MA-FIRST-INST*)
     (DOLIST (S (MA-INST-TAGS-BEFORE I))
       (RPLACD TAILP (SETQ TAILP (LIST S))))
     (DOLIST (E (MA-INST-EXPANSION I))
       (RPLACD TAILP (SETQ TAILP (LIST E)))))
  ANS)

(DEFUN MA-MCLAP-TRACE-SEQ (SEQ &AUX ANS TAILP TEM)
  (IF (OR (NULL SEQ) (MA-SEQ-CHANGED SEQ)) NIL
      (SETF (MA-SEQ-CHANGED SEQ) T)
      (SETQ TAILP (VALUE-CELL-LOCATION 'ANS))
      (IF (SETQ TEM (MA-MCLAP-SEQ SEQ))
	  (PROGN (RPLACD TAILP TEM)
		 (SETQ TAILP (LAST TEM))
		 (IF (AND (MA-SEQ-NEXT-SEQUENCE SEQ)
			  (MA-SEQ-CHANGED (MA-SEQ-NEXT-SEQUENCE SEQ))
			  (MA-SEQ-DROPS-THRU-P SEQ))
		     (RPLACD TAILP (SETQ TAILP (MA-MCLAP-CODE-XFER-TO-SEQ
						 (MA-SEQ-NEXT-SEQUENCE SEQ)))))))
      (IF (SETQ TEM (MA-MCLAP-TRACE-SEQ (MA-SEQ-NEXT-SEQUENCE SEQ)))
	  (PROGN (RPLACD TAILP TEM)
		 (SETQ TAILP (LAST TEM))))
      (DOLIST (FS (MA-SEQ-FOLLOWING-SEQUENCES SEQ))
	(IF (SETQ TEM (MA-MCLAP-TRACE-SEQ FS))
	    (PROGN (RPLACD TAILP TEM)
		   (SETQ TAILP (LAST TEM)))))
      ANS))

(DEFUN MA-MCLAP-CODE-XFER-TO-SEQ (SEQ)
  (MA-EVAL CADR:CONS-IR-OP CADR:CONS-OP-JUMP
	   CADR:CONS-IR-JUMP-COND CADR:CONS-JUMP-COND-UNC
	   CADR:CONS-IR-JUMP-ADDR `(MCLAP-EVALUATE-TAG ,(CAR (MA-INST-TAGS-BEFORE
							       (CAR (MA-ELEM-MEMBERS SEQ)))))
	   CADR:CONS-IR-N 1))

(DEFUN MA-SEQ-DROPS-THRU-P (SEQ)
  (MA-INST-DROPS-THRU-P (CAR (LAST (MA-ELEM-MEMBERS SEQ)))))

(DEFUN MA-INST-DROPS-THRU-P (INST)
  (NOT (GET (CAR (MA-INST-CODE INST)) 'MA-NO-DROPTHRU)))

(DEFUN MA-MCLAP-SEQ (SEQ &AUX ANS TAILP LAST-I TEM)
  (SETQ TAILP (VALUE-CELL-LOCATION 'ANS))
  (DOLIST (E (MA-ELEM-MEMBERS SEQ))
    (DOLIST (S (MA-INST-TAGS-BEFORE E))
      (IF LAST-I (PROGN (RPLACD TAILP (SETQ TAILP (LIST LAST-I)))
			(SETQ LAST-I NIL)))      
      (RPLACD TAILP (SETQ TAILP (LIST S))))
    (COND ((MA-INST-EXPANSION E)
	   (DOLIST (I (MA-INST-EXPANSION E))
						;maybe do XCT-NEXT hackery
	     (LET ((LN (COND ((NUMBERP LAST-I) LAST-I)
			     ((LISTP LAST-I) (CAR LAST-I))))
		   (IN (COND ((NUMBERP I) I)
			     ((LISTP I) (CAR I)))))
	       (IF (AND *MA-HACK-XCT-NEXT*
			LN IN
			(= (LDB CADR:CONS-IR-OP IN) CADR:CONS-OP-JUMP)
			(= (LDB CADR:CONS-IR-JUMP-COND IN) CADR:CONS-JUMP-COND-UNC)
			(= 1 (LDB CADR:CONS-IR-N IN))
			(OR (= (SETQ TEM (LDB CADR:CONS-IR-OP LN)) CADR:CONS-OP-ALU)
			    (= TEM CADR:CONS-OP-BYTE))
			(NOT (OR (= (SETQ TEM (LDB CADR:CONS-IR-FUNC-DEST LN))
				    CADR:CONS-FUNC-DEST-C-PP)
				 (= TEM CADR:CONS-FUNC-DEST-C-PI)
				 (= TEM CADR:CONS-FUNC-DEST-PDL-BUFFER-PUSH))))
		   (PROGN (SETQ IN (DPB 0 CADR:CONS-IR-N IN))
			  (COND ((NUMBERP I) (SETQ I IN))
				((LISTP I) (RPLACA I IN)))
			  (SETQ I (PROG1 LAST-I (SETQ LAST-I I)))
			  (RPLACD TAILP (SETQ TAILP (LIST LAST-I)))
			  (SETQ LAST-I I I NIL))))
	     (IF LAST-I (RPLACD TAILP (SETQ TAILP (LIST LAST-I))))
	     (SETQ LAST-I I)
	     ))))
  (IF LAST-I (PROGN (RPLACD TAILP (SETQ TAILP (LIST LAST-I)))
		    (SETQ LAST-I NIL)))
  ANS)

(DEFUN MA-GET-A-CONSTANT (CON)
  (COND ((ZEROP CON) 2)		;A-ZERO
	(T `(MCLAP-GET-A-CONSTANT ,CON))))

(DEFUN MA-GET-QUOTE-INDEX (QUAN &OPTIONAL IGNORE)  ;for compatibility.  flush extra arg soon.
 `(MCLAP-GET-QUOTE-INDEX ,QUAN))

(DEFUN MA-GET-QUOTE-INDEX-VECTOR (LIST-OF-QUANS)
  `(MCLAP-GET-QUOTE-INDEX-VECTOR ,LIST-OF-QUANS))

(DEFUN MC-LINKAGE-EVAL (REG &OPTIONAL NIL-OK)
  (LET ((ANS (CDR (ASSQ REG *MC-LINKAGE-ALIST*))))
    (COND ((AND NIL-OK (NULL ANS))
	   ANS)
	  ((NULL ANS)
	   (FORMAT T "~%MC-LINKAGE ~s undefined" REG)
	   0)
	  ((MEMQ REG *M-REGISTERS*)	;Assume M regs wont change.  
	   (CADR ANS))			;Flush mem designator, return numeric value
	  (T
	   `(MCLAP-LINKAGE-EVAL ,REG)))))	;if its non-NULL now, it will be at load time.
						;flush memory, gobble value

(DEFUN MA-EVALUATE-MC-LINKAGE (ADR)
  (COND ((NUMBERP ADR)
	 (FERROR NIL ""))
	((EQ (CAR ADR) 'MC-LINKAGE)
	 (MC-LINKAGE-EVAL (CADR ADR)))
	((EQ (CAR ADR) 'MICRO-MICRO-LINKAGE)
	 `(MCLAP-MICRO-MICRO-LINKAGE ,@(CDR ADR)))
	(T
	 `(MCLAP-EVALUATE-MC-LINKAGE ,ADR))))

(DEFUN MA-EVALUATE-TAG (ADR)
  (COND ((NOT (EQ (CAR ADR) 'UTAG))
	 (FERROR NIL "~%Bad adr ~S" ADR)))
  `(MCLAP-EVALUATE-TAG ,(CADR ADR)))



;jobs
;facilitate microcompiled - macro-compiled switching

;context-lost-p (sequence, loop, bubble)

;  WARN WHEN VARIOUS THINGS RUN OUT.  C-MEM, A-MEM, EXIT-VECTOR-SPACE
;  REDO OPERAND HOOKUP
;  CHECK UP ON VARIABLE INITIALIZATION WHEN COLAPSING CUBBYHOLES
;  MAKE USE OF STUFF THAT HAPPENS TO BE IN REGISTERS INSTEAD OF GOING TO PDL BUFFER
;  PRESERVE STUFF IN REGISTERS THAT CAN BE USED BY ABOVE HACK.
;  HACK %SPREAD.
;  OPEN CODE ARITHMETIC.
;  OPEN CODE %XBUS-READ AND %XBUS-WRITE, ETC ETC
;  ARRAY-REF OPTIMIZATIONS
;  MULTIPLE-VALUE  CALL AND RETURN
;  CATCH AND THROW
;  &REST ARGS  -- PROBABLY NOT ANYTIME SOON --
;  HAIRY OVERLAY SCHEME.  INTERFACE TO UCODE-MODULE STUFF.