;-*- Mode:LISP; Package:COMPILER; Base:8; Readtable:ZL -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;       ** (c) Copyright 1984, Lisp Machine Inc. **

(defvar *microcompiler-verbose* nil
  "If non-NIL, will cause info to be printed out when microcompiling.")

;  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 (SI:FUNCTION-SPEC-GET FUNCTION-NAME 'MCLAP))))

(DEFUN MICRO-ASSEMBLE (MODE)	;this function called from MICRO-COMPILE in LISPM;MC
  (PROG (TEM FUNCTION-NAME OUTPUT)
	(setq default-cons-area working-storage-area)   ;try to avoid lossage.
	(COND ((NULL *UCADR-STATE-LIST*)
	       (GET-UCADR-STATE-LIST)
	       (MA-INITIALIZE-VARIABLES)))
     L  ;(ma-print-code)
	(when *microcompiler-verbose*
	  (PRINT '(MA-HOOK-UP-STATES)))
	(MA-HOOK-UP-STATES)
	(when *microcompiler-verbose*
	  (PRINT '(MA-HOOK-UP-OPERANDS)))
	(MA-HOOK-UP-OPERANDS)
	(COND (*MA-BRANCH-TENSION*
	       (when *microcompiler-verbose*
		 (PRINT '(MA-BRANCH-TENSION)))
	       (COND ((MA-BRANCH-TENSION)
		      (PRINC "Code improved, recycling")
		      (GO L)))))
       (comment
	(COND (*MA-CHART-TOPOLOGY*
	       (when *microcompiler-verbose*
		 (PRINT '(MA-CHART-TOPOLOGY)))
	       (MA-CHART-TOPOLOGY))) )
       (comment
	(COND ((AND *MA-CHART-TOPOLOGY*
		    *MA-COLAPSE-CUBBYHOLES*
		    (SETQ TEM (MA-FIND-CUBBYHOLES-TO-COLAPSE)))
	       (MA-COLAPSE-CUBBYHOLES TEM)
	       (GO L))) )
	(COND (*MA-OPTIMIZE*
	       (when *microcompiler-verbose*
		 (PRINT '(MA-OPTIMIZE)))
	       (COND ((MA-OPTIMIZE)	;returns T if significant change
		      (GO L)))))
	(when *microcompiler-verbose*
	  (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
	   (MA-INSTALL-MCLAP FUNCTION-NAME (SI:COPY-OBJECT-TREE OUTPUT)))  ;SOME STUFF IS PASSED
	;FROM THE COMPILER AND COULD BE IN A TEMPORARY AREA.  Note that the
	;  temporary-areas-only option to COPY-OBJECT-TREE will not do because permanent 
	;area stuff can point to the temporary area stuff.
	  (QFASL
	   (FASD-FORM `(MA-INSTALL-MCLAP ',FUNCTION-NAME ',OUTPUT)))
	  (REL
	   (QFASL-REL:DUMP-FORM `(MA-INSTALL-MCLAP ',FUNCTION-NAME ',OUTPUT)))
	  (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-OPS 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-BRANCH-TENSION (&AUX ANS)
  (DOLIST (SEQ *MA-SEQUENCES*)
    (LET* ((LAST-I (CAR (LAST (MA-ELEM-MEMBERS SEQ))))
	   (CODE (MA-INST-CODE LAST-I)))
      (COND ((AND (GET (CAR CODE) 'MA-JUMP)
		  (GET (CAR CODE) 'MA-NO-DROPTHRU))
	     (LET* ((TAG (MA-TAG-USED CODE))
		    (T-I (GET TAG 'MA-TAG-POINTER))
		    (T-CODE (MA-INST-CODE T-I)))
     ;ON UNCONDITIONAL TRANSFER TO EXIT, REPLACE TRANSFER BY EXIT.
	       (COND ((AND (NOT (GET (CAR T-CODE) 'MA-JUMP))
			   (GET (CAR T-CODE) 'MA-NO-DROPTHRU))
		      (SETF (MA-INST-CODE LAST-I) T-CODE)
		      (SETQ ANS T)
		      (GO X))))))
      (COND ((GET (CAR CODE) 'MA-JUMP)
	     (LET* ((TAG (MA-TAG-USED CODE))
		    (T-I (GET TAG 'MA-TAG-POINTER))
		    (T-CODE (MA-INST-CODE T-I)))
	       (COND ((EQ T-I (MA-INST-NEXT-INST LAST-I))
     ;ANY JUMP TO .+1, FLUSH
		      (MA-FLUSH-INST LAST-I)
		      (SETQ ANS T))
     ;JUMP TO UNCONDITIONAL JUMP, REPLACE BY WHERE THAT GUY GOES TO.
		     ((AND (GET (CAR T-CODE) 'MA-JUMP)
			   (GET (CAR T-CODE) 'MA-NO-DROPTHRU))
		      (LET ((T-TAG (MA-TAG-USED T-CODE)))
			(SETF (MA-INST-CODE LAST-I)
			      (SUBST T-TAG TAG CODE))
			(SETQ ANS T))))))))
      X )
  ANS)

(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

;trace paths from seq SEQ.  PATH-SO-FAR is a list of sequences by which we have gotten here
; from the beginning of the fctn.
(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
	;for every path by which we have gotten here previously, compare it to the current
	;way to get here to see if the two represent a bubble.  If so, record it.
	      (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 (TYPE-OF 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 (TYPE-OF 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 (TYPE-OF 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 (TYPE-OF SEQ) 'MA-SEQUENCE)) (FERROR NIL "~S not sequence"))
  (MEMQ LOOP (MA-ELEM-LOOPS SEQ)))

(DEFUN MA-BUBBLE-MEMBER (SEQ BUB)
  (IF (NOT (EQ (TYPE-OF 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))
	      (t
	       (MA-ADD-BUBBLE-PATH T1 (REVERSE-UP-TO-AND-INCLUDING T1 P1))
	       (MA-ADD-BUBBLE-PATH T1 (REVERSE-UP-TO-AND-INCLUDING T1 P2))
	       (return nil)))
  (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 (LOCF 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) (CONS INST NIL))
	(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))
	(cond ((and (get (car (ma-inst-code i1)) 'ma-jump)
		    (eq i2 (ma-inst-next-inst i1))
		  ;after-state not hooked on optional-arg-jump-greater, since pdl level dfr.
		    (not (eq (car (ma-inst-code i1)) 'optional-arg-jump-greater)))
	       (format t "~%Flush dead branch")
	       (ma-flush-inst i1)
	       (setf (ma-elem-members seq) (nbutlast (ma-elem-members seq)))))
	(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)
	(SETF (MA-ELEM-MEMBERS SEQ) (NCONC (MA-ELEM-MEMBERS SEQ) (CONS I2 NIL)))
	(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 (ATOM 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 OP1-OPER OP2-OPER)
	       (MULTIPLE-VALUE (DEST RESULT-DATA-TYPE) (MA-DEST-CODE INST))
	       (IF OP1 (SETQ OP1-OPER (MA-EMULATE-FETCH INST OP1 NSTATE)))
	       (IF OP2 (SETQ OP2-OPER (MA-EMULATE-FETCH INST OP2 NSTATE)))
	       (SETF (MA-INST-OPS INST)
		     (COND (OP2-OPER (LIST OP1-OPER OP2-OPER))
			   (OP1-OPER (LIST OP1-OPER))
			   (T NIL)))
	       (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 LOCAL))
		  (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 op (listp op) (listp (cdr op)) (eq (cadr op) 'invalid))
	 (ferror nil "Referencing invalid operand")))
  (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 (CONSP 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 LOCAL))
	 (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 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-OPS INST)		;save a list of the operands in OP1
			(CONS (CAR (MA-STATE-STACK-ALIST STATE)) ;the popping re-reverses them
			      (MA-INST-OPS 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 (prog (flag arg)
	     l  (cond ((null c-code) (return nil)))
		(setq flag (car c-code)
		       arg (cadr c-code)
		       c-code (cddr c-code))
		(cond ((eq flag 'registers-clobbered)
		       (cond ((eq arg t)
			      (SETF (MA-STATE-REGISTER-ALIST STATE) NIL))
			     (t
			      (dolist (a arg)
				(ma-invalidate-register-in-state a state)))))
		      ((eq flag 'registers-preserved)
		       (ma-invalidate-registers-in-state-except arg state))
		      ((eq flag 'operand-returned))
		      (t
		       (FERROR NIL "unknown context clobberage code")))
		(go l)))))

(defun ma-invalidate-register-in-state (reg state &aux tem)
  (cond ((setq tem (assq reg (ma-state-register-alist state)))
	 (cond ((not (eq (cadr tem) 'invalid))
		(ma-invalidate tem))))))
	
(defun ma-invalidate-registers-in-state-except (preserved state)
  (dolist (a-l (ma-state-register-alist state))
    (cond ((and (not (memq (car a-l) preserved))
		(not (eq (cadr a-l) 'invalid)))
	   (ma-invalidate a-l)))))

(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*)
			 (dolist (op (ma-inst-ops *inst*))
			   (IF (EQ IN-SLOT op)
			       (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)
  "returns two values, destination-location and data-type."
  (LET ((CODE (MA-INST-CODE *INST*)))
    (COND ((SETQ TEM (GET (CAR CODE) 'MA-DEST))
	   (FUNCALL TEM CODE))
	  ((SETQ TEM (GET (CAR CODE) 'MA-CLOBBERAGE-PROPERTY))
	   (PROG (FLAG ARG)
	      L  (COND ((NULL TEM) (RETURN NIL)))	;** should hack type **
		 (SETQ FLAG (CAR TEM)
		       ARG (CADR TEM)
		       TEM (CDDR TEM))
		 (COND ((EQ FLAG 'OPERAND-RETURNED)
			(RETURN ARG)))
		 (GO L))))))

(DEFUN MA-CONTEXT-CLOBBERAGE (INST &AUX TEM)
  (COND ((SETQ TEM (GET (CAR INST) 'MA-CONTEXT-CLOBBERAGE))
	 (FUNCALL TEM INST))
	(t ;(format t "~%Assuming inst ~s clobbers everything" inst)
	   't)))

(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)
    (COND ((MA-FIXNUM-CONSTANTP NAME)
	   (SETF (MA-OPERAND-TYPE OP) 'DTP-FIX)))
    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-check-sequence-members (&aux seq seq-members)
  (setq seq *ma-first-sequence*)
  (doinsts (e *ma-first-inst*)
   (cond ((null seq-members)
	  (setq seq-members (ma-elem-members seq)
		seq (ma-seq-next-sequence seq))))
   (cond ((not (eq e (car seq-members)))
	  (format t "~%Sequence mismatch, via inst ~s, via seq ~s" e (car seq-members))
	  (break "foo")))
   (setq seq-members (cdr seq-members))))

(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 (TYPE-OF E))
  (SELECTQ (TYPE-OF 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 tem)
  LOOP  (SETQ I FIRST-SEQ)
        (DOTIMES (C PC)
	  (SETQ I (MA-INST-NEXT-INST I)))
     	(FORMAT T "~%PC ~S: ~S" PC I)
	(SETQ CH (CHAR-UPCASE (TYI)))
	(SELECTQ CH
	  (#/!
	   (SETQ *MA-OPT-FLAG* NIL)
	   (MA-OPT-SEQUENCE (MA-INST-SEQUENCE I))
	   (FORMAT T "~%MA-OPT-FLAG ~s" *MA-OPT-FLAG*))
	  (#/D
	   (DESCRIBE I))
	  (#/E
	   (cond ((not (boundp 'lambda:lam-symbols-size))
		  (lambda:lam-dont-use-symbols)))
	   (LET ((E (MA-INST-EXPANSION I)))
	     (DOLIST (W E)
	       (LAMBDA:LAM-TYPE-OUT (IF (NUMBERP W) W (CAR W)) LAMBDA:LAM-UINST-DESC T T)
	       (IF (LISTP W) (PRINT (CDR W))))))
	  (#/I
	   (RETURN I))
	  (#/N
	   (cond ((ma-inst-next-inst i) (SETQ PC (1+ PC)))))
	  (#/O
	   (setq tem 1)
	   (dolist (op (ma-inst-ops i))
	     (FORMAT T "~% MA-INST-OP ~D " tem)
	     (MA-DESCRIBE-SLOT op)
	     (setq tem (1+ tem)))
	   (COND ((MA-INST-RESULT-OPERAND I)
		  (FORMAT T "~% MA-INST-RESULT-OPERAND")
		  (SI:DESCRIBE-1 (MA-INST-RESULT-OPERAND I)))))
	  (#/P
	   (SETQ PC (MAX 0 (1- PC))))
	  (#/Q
	   (RETURN PC))
	  (#/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)))
	  (#/T
	   (LET ((TAG (MA-FIND-TAG (MA-INST-CODE I))))
	     (SETQ PC (MA-FIND-PC (GET TAG 'MA-TAG-POINTER) FIRST-SEQ)))))
	(GO LOOP)))

(DEFUN MA-FIND-TAG (CODELIST)
  (DOLIST (E CODELIST)
    (IF (AND (CONSP E)
	     (EQ (CAR E) 'UTAG))
	(RETURN (CADR E)))))

(DEFUN MA-FIND-PC (INST FIRST-INST)
  (PROG (C I)
	(SETQ C 0 I FIRST-INST)
     L  (COND ((NULL I) (FERROR NIL "CANT FIND IT"))
	      ((EQ INST I) (RETURN C)))
	(SETQ I (MA-INST-NEXT-INST I)
	      C (1+ C))
	(GO L)))

(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)
(defprop jump-less-than conditional ma-jump)
(defprop jump-greater-or-equal conditional ma-jump)
(defprop jump-greater-than conditional ma-jump)
(defprop jump-less-or-equal conditional ma-jump)
(defprop jump-data-type-equal conditional ma-jump)
(defprop jump-data-type-not-equal 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)
  (let* ((info (fourth inst))
	 (byte-spec (cadr (assq 'byte-spec info)))
	 (type-specifier (cadr (assq 'type-specifier info))))
    (VALUES (SECOND INST)
	    (OR (CAR BYTE-SPEC)   ;type in byte spec if present
		(MA-SOURCE-OPERAND-TYPE (THIRD INST))
		(cdr (assq type-specifier '( (fixnum . dtp-fix))))))))

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

(DEFUN (ADD MA-OP2) (INST)
  (FOURTH INST))

(DEFUN (ADD MA-DEST) (INST)
  (VALUES (SECOND INST) 'DTP-FIX))

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

(DEFUN (SUB MA-OP2) (INST)
  (FOURTH INST))

(DEFUN (SUB MA-DEST) (INST)
  (VALUES (SECOND INST) 'DTP-FIX))

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

(DEFUN (AND MA-OP2) (INST)
  (FOURTH INST))

(DEFUN (AND MA-DEST) (INST)
  (VALUES (SECOND INST) 'DTP-FIX))

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

(DEFUN (IOR MA-OP2) (INST)
  (FOURTH INST))

(DEFUN (IOR MA-DEST) (INST)
  (VALUES (SECOND INST) 'DTP-FIX))

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

(DEFUN (XOR MA-OP2) (INST)
  (FOURTH INST))

(DEFUN (XOR MA-DEST) (INST)
  (VALUES (SECOND INST) 'DTP-FIX))

(DEFUN MA-SOURCE-OPERAND-TYPE (EXP)
  (IF (CONSP EXP)
      (COND ((EQ (CAR EXP) 'QUOTE)
	     (COND ((FIXP (CADR EXP))
		    'DTP-FIX)
		   ((MEMQ (CADR EXP) '(T NIL))
		    'T-OR-NIL)))
	    ((eq (car exp) 'constant)
	     (let ((dtp (ldb %%q-data-type (cadr exp))))
	       (cond ((= dtp dtp-fix)
		      'dtp-fix))))
	    ((and (eq (car exp) 'special)
		  (get (cadr exp) 'si:system-constant)
		  (boundp (cadr exp))
		  (fixp (symeval (cadr exp))))
	     'dtp-fix))))

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

(defun ma-no-context-clobberage (inst) inst nil)
(deff (:property move ma-context-clobberage) 'ma-no-context-clobberage)
		;actual clobberage reflected in operand mechanism
(deff (:property move-locative-t ma-context-clobberage) 'ma-no-context-clobberage)   ;should it be T?
(deff (:property create-cubbyhole ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property start-cubbyhole ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-not-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-data-type-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-data-type-not-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-greater ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property optional-arg-jump-greater ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-less ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-greater-or-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-greater-than ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-less-or-equal ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-if-atom ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property jump-if-not-atom ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property dynamic-stack-test ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property trap-unless-fixnum ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property discard-top-of-stack ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property se1+ ma-context-clobberage) 'ma-no-context-clobberage)	;?
(deff (:property se1- ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property secdr ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property secddr ma-context-clobberage) 'ma-no-context-clobberage)


(deff (:property add ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property sub ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property and ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property ior ma-context-clobberage) 'ma-no-context-clobberage)
(deff (:property xor ma-context-clobberage) 'ma-no-context-clobberage)

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

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

(DEFUN (ARG-CALL MA-DEST) (INST)
  (ma-compute-call-dest inst))

(DEFUN (ARG-CALL MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

(DEFUN (CALL MA-DEST) (INST) 
  (ma-compute-call-dest inst))

(DEFUN (CALL MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

(DEFUN (MV-MICRO-CALL MA-DEST) (INST) 
  (ma-compute-call-dest inst))

(DEFUN (MV-MICRO-CALL MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

;CAN RETURN:  NIL  -> NO CLOBBERAGE
;	      T    -> EVERYTHING CLOBBERED
;	      OR A KEYWORD LIST WITH KEYWORDS
;	:CLOBBERS <LIST>
;	:RETURNS  <LIST>
;       :PRESERVES <LIST>
(defun ma-compute-call-context-clobberage (rout &aux tem)
  (cond ((and (consp rout)
	      (memq (car rout) '(mc-linkage misc-entry))
	      (setq tem (getl (cadr rout) '(ma-clobberage-property))))
	 (cadr tem))
	((and (consp rout)
	      (memq (car rout) '(mc-linkage misc-entry))
	      (setq tem (getl (cadr rout) '(registers-clobbered))))
	 (list 'registers-clobbered (cadr tem)))
	((and (consp rout)
	      (memq (car rout) '(mc-linkage misc-entry))
	      (setq tem (getl (cadr rout) '(registers-preserved))))
	 (list 'registers-preserved (cadr tem)))
	(t t)))		;assume clobbers all unless otherwise known.

(defun ma-compute-call-dest (inst &aux tem)
  (VALUES 'T
	  (COND ((AND (CONSP (CAR (LAST INST)))
		      (MEMQ (CAAR (LAST INST)) '(MC-LINKAGE MISC-ENTRY))
		      (GET (CADAR (LAST INST)) 'RESULT-DATA-TYPE)))
		((EQ 'FIXNUM (CADR (ASSQ 'TYPE-SPECIFIER (THIRD INST))))
		 'DTP-FIX)
		((AND (SETQ TEM (MA-INST-NEXT-INST *INST*))
		      (SETQ TEM (MA-INST-CODE TEM))
		      (EQ (CAR TEM) 'MOVE)
		      (EQ (THIRD TEM) 'T)	;this guy is storing our result
		      (EQ 'FIXNUM (CADR (ASSQ 'TYPE-SPECIFIER (FOURTH TEM)))))
		 'DTP-FIX)	;He's storing a fixnum so we must have returnned one!
		  )))
;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)		;just to initialize
	(*PDL-BUFFER-WRITE-HAPPENING* NIL)
	)
    (COND ((NULL *MA-CONVERT-SEQUENCE-WISE*)
	   (MA-CONVERT-SIMPLE))
	  (T
	   (DOLIST (SEQ *MA-SEQUENCES*)
	     (ma-convert-sequence seq))))))

;convert reseting context every inst
(defun ma-convert-simple ()
    (DOINSTS (INST *MA-FIRST-INST*)
      (MA-CONVERT-INST-SIMPLE INST)))

(DEFUN MA-CONVERT-INST-SIMPLE (*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-sequence (*seq*)
  (setq *pdl-buffer-index* nil)
  (dolist (inst (ma-elem-members *seq*))
    (ma-convert-inst inst)))
  
;convert code, carrying over context of sequence.
(DEFUN MA-CONVERT-INST (*INST*)
  (LET ((*EMIT-LIST* NIL))
    (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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
			       LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SETA
			       LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
			       LAMBDA:LAM-IR-M-MEM-DEST (MC-LINKAGE-EVAL 'C)
			       LAMBDA:LAM-IR-A-SRC (MA-GET-A-CONSTANT BIT-MASK))
		      (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

			       LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (MA-GET-QUOTE-INDEX-VECTOR VC-LIST)
			       LAMBDA:LAM-IR-DISP-ADDR
			            (MC-LINKAGE-EVAL 'D-DO-SPECBIND-PP-BASED))))
	       (SETQ *PDL-BUFFER-INDEX* NIL)	;gets clobbered.
	       (RETURN NIL))
	      ((AND (CONSP (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)
  (let* ((source (third inst))
	 (dest (second inst))
	 (info (fourth inst))
	 (byte-spec (cadr (assq 'byte-spec info)))
	 (output-selector (cadr (assq 'output-selector info))))
    (SETQ CDR-CODING (IF (AND (CONSP dest)
			      (EQ (car dest) 'PUSH-PDL)
			      (MEMQ (CADR dest) '(D-NEXT D-LAST)))
			 (IF (EQ (CADR DEST) 'D-NEXT) CDR-NEXT CDR-NIL)
		       0))
    (cond ((and byte-spec
		(ma-fixnum-constantp source))
	   (SETQ SOURCE
		 `(CONSTANT ,(DPB (EVAL (CAR BYTE-SPEC)) %%Q-DATA-TYPE
				  (LAMBDA:LDB-BIG (BYTE (CADR BYTE-SPEC) (CADDR BYTE-SPEC))
						  (CADR SOURCE)))))
	   (SETQ BYTE-SPEC NIL)))	 
    (COND ((AND (MA-USES-PI DEST)
		(MA-USES-PI SOURCE))
	   (MA-CONVERT-LIST `((MOVE R ,SOURCE ,INFO)	;split since pi needs to change in 
			      (MOVE ,DEST R ,INFO))))	;middle.
	  ((AND (NOT (MEMQ SOURCE *M-REGISTERS*))	;Dont ref these from the A side
						; since may want to hack CDR-CODE.
		(NULL BYTE-SPEC)
		(ZEROP CDR-CODING)
		(NULL OUTPUT-SELECTOR)
		(SETQ A (MA-A-REFFABLE SOURCE CDR-CODING)))
	   (MULTIPLE-VALUE-BIND (FD RD) (MA-PREPARE-STORE DEST STACK)
	     (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
		      LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SETA
		      LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
		      LAMBDA:LAM-IR-FUNC-DEST FD
		      LAMBDA:LAM-IR-M-MEM-DEST RD
		      LAMBDA:LAM-IR-A-SRC A)
	     (MA-NOTE-PDL-WRITE FD STACK)
	     (MA-FINISH-STORE DEST)))
	  (T (SETQ M (MA-REF-M-SIDE SOURCE STACK))
	     (MULTIPLE-VALUE-BIND (FD RD) (MA-PREPARE-STORE DEST STACK)
	       (COND ((OR OUTPUT-SELECTOR ;sign extension only available on ALU. no masking needed
			  (AND (NUMBERP M)
			       (< M 40)
			       (ZEROP CDR-CODING)
			       (NULL BYTE-SPEC)))	;no masking needed
		      (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
			       LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SETM
			       LAMBDA:LAM-IR-OB (IF (EQ OUTPUT-SELECTOR 'SIGN-EXTEND-25)
						    LAMBDA:LAM-OB-ALU-EXTEND-25
						  LAMBDA:LAM-OB-ALU)
			       LAMBDA:LAM-IR-FUNC-DEST FD
			       LAMBDA:LAM-IR-M-MEM-DEST RD
			       LAMBDA:LAM-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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-BYTE	;automatically mask to 
				 LAMBDA:LAM-IR-FUNC-DEST FD	;Q-TYPED-POINTER
				 LAMBDA:LAM-IR-M-MEM-DEST RD
				 LAMBDA:LAM-IR-M-SRC M
				 LAMBDA:LAM-IR-A-SRC A	;maybe insert CDR-CODE
				 LAMBDA:LAM-IR-BYTL-1 (1- (COND ((NULL BYTE-SPEC) 30.)
								(T (CADR BYTE-SPEC))))
				 LAMBDA:LAM-IR-MROT   (COND ((OR (NULL BYTE-SPEC)
								 (= (CADDR BYTE-SPEC) 32.))
							     0)
							    (T (- 32. (CADDR BYTE-SPEC))))
				 LAMBDA:LAM-IR-BYTE-FUNC LAMBDA:LAM-BYTE-FUNC-LDB)))
	       (MA-NOTE-PDL-WRITE FD STACK)
	       (MA-FINISH-STORE DEST))))))

(DEFUN (ADD MA-ASSEMBLE) (INST)
  (MA-ASSEMBLE-ARITH INST LAMBDA:LAM-ALU-ADD-25))

(DEFUN (SUB MA-ASSEMBLE) (INST)
  (MA-ASSEMBLE-ARITH INST LAMBDA:LAM-ALU-SUB-25))

(DEFUN (AND MA-ASSEMBLE) (INST)
  (MA-ASSEMBLE-ARITH INST LAMBDA:LAM-ALU-AND-25))

(DEFUN (IOR MA-ASSEMBLE) (INST)
  (MA-ASSEMBLE-ARITH INST LAMBDA:LAM-ALU-IOR-25))

(DEFUN (XOR MA-ASSEMBLE) (INST)
  (MA-ASSEMBLE-ARITH INST LAMBDA:LAM-ALU-XOR-25))

(DEFUN MA-ASSEMBLE-ARITH (INST ALU-OP &AUX M A
				(STACK (MA-STATE-STACK-ALIST (MA-INST-BEFORE-STATE *INST*))))
  ;For now, dest is always T and S1 is always a register (or a FIXNUM constant).
  (LET* ((S1 (THIRD INST))	;ref this from A side
	 (S2 (FOURTH INST))
	 (DEST (SECOND INST))
	 ;(INFO (FIFTH INST))
	 )
    (SETQ A (MA-A-REFFABLE S1 0)
	  M (MA-REF-M-SIDE S2 STACK))
    (if (null a)
	(ferror nil "S1 is ~s, which is not reffable from A side" s1))
    ;No masking needed since high bits come from A side.
    (MULTIPLE-VALUE-BIND (FD RD) (MA-PREPARE-STORE DEST STACK)
      (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
	       LAMBDA:LAM-IR-ALUF ALU-OP
	       LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
	       LAMBDA:LAM-IR-FUNC-DEST FD
	       LAMBDA:LAM-IR-M-MEM-DEST RD
	       LAMBDA:LAM-IR-M-SRC M
	       LAMBDA:LAM-IR-A-SRC A)
      (MA-FINISH-STORE DEST))))

(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 LOCAL))
	       (AND (NULL *MA-SPECBIND-DONE*)
		    (EQ (CAR OP) 'SPECIAL)
		    (ASSOC OP STACK)))
	   (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

		    LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (MA-ADDRESS-PDL OP STACK)
		    LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-GET-LOCATIVE-TO-PDL)))
	  ((EQ (CAR OP) 'SPECIAL)
	   (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH
		    LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (MA-GET-QUOTE-INDEX OP)
		    LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-GET-LOCATIVE-TO-VC))
	   (SETQ *PDL-BUFFER-INDEX* NIL)))))

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

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

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

(DEFUN (OPEN-CALL-MV MA-ASSEMBLE) (INST)
  (let ((nvals (third inst))
	(target (fourth inst)))
  (cond ((not (eq target t))
	 (ma-emit-exit-ref target
			   (mc-linkage-eval 'd-read-exit-vector-and-load-t))))
  (ma-emit lambda:lam-ir-op lambda:lam-op-dispatch
	   lambda:lam-ir-disp-dispatch-constant nvals
	   lambda:lam-ir-disp-addr (mc-linkage-eval 'd-xcmv))
  (setq *pdl-buffer-index* nil)  
  ))

;MV-MICRO-CALL

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

(DEFUN (BNDPOP MA-ASSEMBLE) (INST)
  (MA-EMIT-EXIT-REF (SECOND INST)
		    (MC-LINKAGE-EVAL 'D-BNDPOP))
  (SETQ *PDL-BUFFER-INDEX* NIL))

(DEFUN (BNDNIL MA-ASSEMBLE) (INST)
  (MA-EMIT-EXIT-REF (SECOND INST)
		    (MC-LINKAGE-EVAL 'D-BNDNIL))
  (SETQ *PDL-BUFFER-INDEX* NIL))

(DEFUN (POP-SPECPDL MA-ASSEMBLE) (INST)
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH
	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (CADR INST)
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-POP-SPECPDL))
  (SETQ *PDL-BUFFER-INDEX* NIL))
  
(DEFPROP JUMP-EQUAL MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-NOT-EQUAL MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-DATA-TYPE-EQUAL MA-ASSEMBLE-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-DATA-TYPE-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 30. BITS IF NOT IN M-T.
	 (SETQ M1 (MA-EVAL-M-REG 'R))
	 (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-BYTE
		  LAMBDA:LAM-IR-BYTE-FUNC LAMBDA:LAM-BYTE-FUNC-LDB
		  LAMBDA:LAM-IR-A-SRC 2	       ;A-ZERO
		  LAMBDA:LAM-IR-M-SRC M
		  LAMBDA:LAM-IR-M-MEM-DEST M1
		  LAMBDA:LAM-IR-BYTL-1 (1- 30.)
		  LAMBDA:LAM-IR-MROT 0)
	 (SETQ M M1)))
  (IF (NULL (SETQ A (MA-A-REFFABLE (CADDR INST) 0)))
      (FERROR NIL "NOT REFFABLE FROM A SIDE ~S" (CADDR INST)))
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-JUMP
	   LAMBDA:LAM-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   LAMBDA:LAM-IR-JUMP-COND (EVAL (CADR
					  (ASSQ (CAR INST)
					     '((JUMP-EQUAL LAMBDA:LAM-JUMP-COND-M=A)
					       (JUMP-NOT-EQUAL LAMBDA:LAM-JUMP-COND-M-NEQ-A)
					       (JUMP-DATA-TYPE-EQUAL
						 LAMBDA:LAM-JUMP-COND-DATA-TYPE-EQUAL)
					       (JUMP-DATA-TYPE-NOT-EQUAL
						 LAMBDA:LAM-JUMP-COND-DATA-TYPE-NOT-EQUAL)
					       (JUMP-GREATER LAMBDA:LAM-JUMP-COND-M>A)
					       (OPTIONAL-ARG-JUMP-GREATER
						 LAMBDA:LAM-JUMP-COND-M>A)))))
	   LAMBDA:LAM-IR-M-SRC M
	   LAMBDA:LAM-IR-A-SRC A
	   LAMBDA:LAM-IR-N 1))

(DEFPROP JUMP-LESS-THAN MA-ASSEMBLE-NUMERIC-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-GREATER-OR-EQUAL MA-ASSEMBLE-NUMERIC-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-GREATER-THAN MA-ASSEMBLE-NUMERIC-JUMP MA-ASSEMBLE)
(DEFPROP JUMP-LESS-OR-EQUAL MA-ASSEMBLE-NUMERIC-JUMP MA-ASSEMBLE)

(DEFUN MA-ASSEMBLE-NUMERIC-JUMP (INST &AUX A M)
  (SETQ M (MA-REF-M-SIDE (CADR INST)))
  (SETQ A (MA-A-REFFABLE (CADDR INST) 0))
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-JUMP
	   LAMBDA:LAM-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   LAMBDA:LAM-IR-JUMP-COND (EVAL (CADR
					  (ASSQ (CAR INST)
					     '((JUMP-LESS-THAN LAMBDA:LAM-JUMP-COND-M<A)
					       (JUMP-GREATER-OR-EQUAL LAMBDA:LAM-JUMP-COND-M>=A)
					       (JUMP-GREATER-THAN LAMBDA:LAM-JUMP-COND-M>A)
					       (JUMP-LESS-OR-EQUAL
						 LAMBDA:LAM-JUMP-COND-M<=A)))))
	   LAMBDA:LAM-IR-M-SRC M
	   LAMBDA:LAM-IR-A-SRC A
	   LAMBDA:LAM-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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-JUMP
	   LAMBDA:LAM-IR-M-SRC M
	   LAMBDA:LAM-IR-A-SRC (MA-GET-A-CONSTANT (DPB DTP-LIST %%Q-DATA-TYPE 0))
	   LAMBDA:LAM-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   LAMBDA:LAM-IR-JUMP-COND (EVAL (CADR
					  (ASSQ (CAR INST)
					     '((JUMP-IF-ATOM
						 LAMBDA:LAM-JUMP-COND-DATA-TYPE-NOT-EQUAL)
					       (JUMP-IF-NOT-ATOM
						 LAMBDA:LAM-JUMP-COND-DATA-TYPE-EQUAL)
					       ))))
	   LAMBDA:LAM-IR-N 1)
 )
  
(comment
(DEFUN MA-ASSEMBLE-JUMP-ATOM (INST &AUX M)
  (SETQ M (MA-REF-M-SIDE (CADR INST)))
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH  ;SKIP ON ATOM OR SKIP ON NO-ATOM
	   LAMBDA:LAM-IR-M-SRC M
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL (COND ((EQ (CAR INST) 'JUMP-IF-ATOM)
							  'SKIP-IF-NO-ATOM)
							 (T 'SKIP-IF-ATOM)))
	   LAMBDA:LAM-IR-DISP-BYTL 5
	   LAMBDA:LAM-IR-MROT 8.)	;Q-DATA-TYPE
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-JUMP
	   LAMBDA:LAM-IR-JUMP-ADDR (MA-EVALUATE-TAG (FOURTH INST))
	   LAMBDA:LAM-IR-JUMP-COND LAMBDA:LAM-JUMP-COND-UNC
	   LAMBDA:LAM-IR-N 1)) )

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

(defun (trap-unless-fixnum ma-op1) (inst)
  (second inst))

(defun (trap-unless-fixnum ma-assemble) (inst)
  (let* ((arg (second inst))
	 (info (third inst)))
    (cond ((ma-fixnump arg info)
	   (cond ((and (ma-fixnum-constantp arg)
		       (eq (car arg) 'constant)
		       (not (or (= dtp-fix (ldb %%q-data-type (cadr arg)))
				(= dtp-character (ldb %%q-data-type (cadr arg))))))
		  (ferror nil "arg of TRAP-UNLESS-FIXNUM is a non-fixnum constant"))))
	  (t
	   (ma-emit lambda:lam-ir-op lambda:lam-op-dispatch
		    lambda:lam-ir-disp-bytl 5.
		    lambda:lam-ir-mrot (- 40 25.)
		    lambda:lam-ir-m-src (ma-ref-m-side arg)
		    lambda:lam-ir-disp-addr (mc-linkage-eval 'trap-unless-fixnum))))))
	  
(defun ma-fixnump (arg info)
  (or (ma-fixnum-constantp arg)
      (eq 'dtp-fix
	  (car (cadr (assq 'byte-spec info))))
      (eq 'fixnum
	  (cadr (assq 'type-specifier info)))))

(defun ma-fixnum-constantp (arg)
  (and (consp arg)
       (or (eq (car arg) 'constant)
	   (and (eq (car arg) 'quote)
		(fixp (cadr arg)))
	   (and (eq (car arg) 'special)
		(get (cadr arg) 'si:system-constant)
		(boundp (cadr arg))
		(fixp (symeval (cadr arg)))))))

(defun ma-fixnum-constant (arg)
  "Assuming ma-fixnum-constantp is T, this returns the constant value"
  (cond ((eq (car arg) 'constant) (cadr arg))
	((eq (car arg) 'quote) (cadr arg))
	((eq (car arg) 'special) (symeval (cadr arg)))
	(t (ferror nil ""))))

(DEFUN (DISPATCH MA-ASSEMBLE) (INST)
 ;(dispatch <dispatch-constant> <byte-spec> <m-source> <dispatch-table>)
  (LET ((M (MA-REF-M-SIDE (FOURTH INST)))
	(BYTE-SPEC (EVAL (THIRD INST))))
    (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH
	     LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (SECOND INST)
	     LAMBDA:LAM-IR-DISP-BYTL (LDB (BYTE 6 0) BYTE-SPEC)
	     LAMBDA:LAM-IR-MROT (- 40 (LDB (BYTE 6 6) BYTE-SPEC))
	     LAMBDA:LAM-IR-M-SRC M
	     LAMBDA:LAM-IR-DISP-ADDR (MA-EVALUATE-MC-LINKAGE (FIFTH INST))
	     )
    (SETQ *PDL-BUFFER-INDEX* NIL)))

(DEFUN (DISPATCH MA-DEST) (INST) 
  (ma-compute-call-dest inst))

(DEFUN (DISPATCH MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

(DEFUN (DISPATCH-XCT-NEXT MA-ASSEMBLE) (INST)
 ;(dispatch-xct-next <dispatch-constant> <byte-spec> <m-source> <dispatch-table>)
  (LET ((M (MA-REF-M-SIDE (FOURTH INST)))
	(BYTE-SPEC (EVAL (THIRD INST))))
    (MA-EMIT MA-I-XCT-NEXT-FLAG 1
	     LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH
	     LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (SECOND INST)
	     LAMBDA:LAM-IR-DISP-BYTL (LDB (BYTE 6 0) BYTE-SPEC)
	     LAMBDA:LAM-IR-MROT (- 40 (LDB (BYTE 6 6) BYTE-SPEC))
	     LAMBDA:LAM-IR-M-SRC M
	     LAMBDA:LAM-IR-DISP-ADDR (MA-EVALUATE-MC-LINKAGE (FIFTH INST))
	     )
    (SETQ *PDL-BUFFER-INDEX* NIL)))

(DEFUN (DISPATCH-XCT-NEXT MA-DEST) (INST) inst
  (values t nil))

(DEFUN (DISPATCH-XCT-NEXT MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

(DEFUN (DISPATCH-XCT-NEXT-WRITE-VMA MA-ASSEMBLE) (INST)
 ;(dispatch-xct-next <dispatch-constant> <byte-spec> <m-source> <dispatch-table>)
  (LET ((M (MA-REF-M-SIDE (FOURTH INST)))
	(BYTE-SPEC (EVAL (THIRD INST)))
	(dc (second inst)))
    (cond ((listp dc) (setq dc (ma-evaluate-mc-linkage dc))))
    (MA-EMIT MA-I-XCT-NEXT-FLAG 1
	     LAMBDA:LAM-IR-CLOBBERS-MEM-SUBR-BIT 1  ;avoid clobbering mem-subr in progress
	     LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH
	     LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT dc
	     LAMBDA:LAM-IR-DISP-WRITE-VMA 1
	     LAMBDA:LAM-IR-DISP-BYTL (LDB (BYTE 6 0) BYTE-SPEC)
	     LAMBDA:LAM-IR-MROT (- 40 (LDB (BYTE 6 6) BYTE-SPEC))
	     LAMBDA:LAM-IR-M-SRC M
	     LAMBDA:LAM-IR-DISP-ADDR (MA-EVALUATE-MC-LINKAGE (FIFTH INST))
	     )
    (SETQ *PDL-BUFFER-INDEX* NIL)))

(DEFUN (DISPATCH-XCT-NEXT-WRITE-VMA MA-DEST) (INST) inst
  (values 't nil))

(DEFUN (DISPATCH-XCT-NEXT-WRITE-VMA MA-CONTEXT-CLOBBERAGE) (INST)
  (ma-compute-call-context-clobberage (car (last inst))))

;(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
 (let ((amt-to-sub (LENGTH (MA-STATE-STACK-ALIST
			       (MA-INST-BEFORE-STATE *INST*)))))
   (if (zerop amt-to-sub)
       (ma-emit lambda:lam-ir-op lambda:lam-op-jump
		lambda:lam-ir-jump-cond lambda:lam-jump-cond-unc
		lambda:lam-ir-n 1
		lambda:lam-ir-r 1)	;use normal POPJ if no need to SUB-PP
     (MA-EMIT MA-I-XCT-NEXT-FLAG 1
	  LAMBDA:LAM-IR-POPJ-AFTER-NEXT 1
	  LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
	  LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SUB
	  LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
	  LAMBDA:LAM-IR-FUNC-DEST LAMBDA:LAM-FUNC-DEST-PDL-BUFFER-POINTER
	  LAMBDA:LAM-IR-M-SRC LAMBDA:LAM-M-SRC-PDL-BUFFER-POINTER
	  LAMBDA:LAM-IR-A-SRC (MA-GET-A-CONSTANT AMT-TO-SUB))))
 )

(DEFUN (POP-SPECPDL-AND-EXIT MA-ASSEMBLE) (INST) INST
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-POP-SPECPDL-AND-SUB-PP)))

(DEFUN (RETURN-2-VALUES-AND-EXIT MA-ASSEMBLE) (INST) INST
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-MR2V)))

(DEFUN (RETURN-3-VALUES-AND-EXIT MA-ASSEMBLE) (INST) INST
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-MR3V))) 

(defun (return-n-values-and-exit ma-assemble) (inst) inst
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (LENGTH (MA-STATE-STACK-ALIST
					     (MA-INST-BEFORE-STATE *INST*)))
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL 'D-MRNV)))
  
;D-MURV, D-MRNV, D-MR2V, D-MR3V
;RETURN-NEXT-VALUE-OR-EXIT, RETURN-N-VALUES-AND-EXIT

(DEFUN (DISCARD-TOP-OF-STACK MA-ASSEMBLE) (INST) INST
  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
	   LAMBDA:LAM-IR-M-SRC LAMBDA:LAM-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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (CADR (ASSQ 'ARGS (THIRD INST)))
	   LAMBDA:LAM-IR-DISP-ADDR (MC-LINKAGE-EVAL (FOURTH INST)))  ;D-MMCALL, etc
  (SETQ *PDL-BUFFER-INDEX* NIL))

;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

;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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU)))  ;insert no-op to avoid losing
	 LAMBDA:LAM-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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU)))  ;insert no-op to avoid losing
	 LAMBDA:LAM-M-SRC-C-PDL-BUFFER-POINTER)
	((OR (MEMQ (CAR OP) '(ARG LOCAL))
	     (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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU)))	;no-op
		  LAMBDA:LAM-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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU)))	;no-op
		   LAMBDA:LAM-M-SRC-C-PDL-BUFFER-INDEX))))
	((MEMQ (CAR OP) '(QUOTE SPECIAL FUNCTION))
	 (MA-REF-QUOTE-VECTOR OP)
	  LAMBDA:LAM-M-SRC-MD
  ;	 (MC-LINKAGE-EVAL 'T)	;use read-exit-vector-and-load-t to save here. 
				; needs to know if safe to clobber T, tho.
	 )
	(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 (CONSP 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 (CONSP OP)
		    (EQ (CAR OP) 'CONSTANT))
	       (SETQ TEM (CADR OP))		;constant is exactly what we want.
	       (GO CROCK))
	      ((AND (CONSP 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)))  ;supply data-type
								 ; (making it a bignum)
	       (GO CROCK))
	      ((AND (CONSP OP)
		    (EQ (CAR OP) 'SPECIAL)
		    (GET (CADR OP) 'SI:SYSTEM-CONSTANT)
		    (BOUNDP (CADR OP))
		    (FIXP (SYMEVAL (CADR OP))))
	       (SETQ TEM (DPB DTP-FIX %%Q-DATA-TYPE (SYMEVAL (CADR OP))))
	       (GO CROCK))
	      ((and (zerop cdr-code)
		    (consp op)
		    (eq (car op) 'special)
		    (let ((loc (value-cell-location (cadr op))))
		      (and (= (%p-data-type loc) dtp-one-q-forward)
			   ( (%pointer-difference a-memory-virtual-address (%p-pointer loc))
			      0)
			   (< (%pointer-difference (%p-pointer loc)
						   (%pointer-plus a-memory-virtual-address
								  size-of-hardware-a-memory))
			      0)
			   (return (%pointer-difference (%p-pointer loc)
							a-memory-virtual-address))))))
	      (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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
		    LAMBDA:LAM-IR-ALUF LAMBDA:LAM-ALU-SUB
		    LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
		    LAMBDA:LAM-IR-FUNC-DEST LAMBDA:LAM-FUNC-DEST-PDL-BUFFER-INDEX
		    LAMBDA:LAM-IR-M-SRC LAMBDA:LAM-M-SRC-PDL-BUFFER-POINTER
		    LAMBDA:LAM-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)
  stack
  (COND ((= FD LAMBDA:LAM-FUNC-DEST-C-PI)
	 (SETQ *PDL-BUFFER-WRITE-HAPPENING* *PDL-BUFFER-INDEX*)
	 )
	;((= FD LAMBDA:LAM-FUNC-DEST-C-PP)
	; (SETQ *PDL-BUFFER-WRITE-HAPPENING* (LENGTH STACK)))
	;((= FD LAMBDA:LAM-FUNC-DEST-C-PP-PUSH)
	; (SETQ *PDL-BUFFER-WRITE-HAPPENING* (1+ (LENGTH STACK))))
	))

(DEFUN MA-USES-PI (OP)
  (AND (CONSP OP)
       (OR (MEMQ (CAR OP) '(ARG LOCAL))
	   (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 LAMBDA:LAM-FUNC-DEST-C-PP-PUSH
		      0))
	     ((OR (MEMQ (CAR OP) '(ARG LOCAL))
		  (AND (NULL *MA-SPECBIND-DONE*)
		       (EQ (CAR OP) 'SPECIAL)
		       (ASSOC OP STACK)))
	      (COND ((ZEROP (SETQ TEM (MA-ADDRESS-PDL OP STACK)))
		     (RETURN LAMBDA:LAM-FUNC-DEST-C-PP 0))
		    (T
		      (MA-SET-PDL-INDEX-RELATIVE TEM STACK)
		      (RETURN LAMBDA:LAM-FUNC-DEST-C-PI
			      0))))
	     ((MEMQ (CAR OP) '(QUOTE SPECIAL FUNCTION))
	      (RETURN LAMBDA:LAM-FUNC-DEST-MD 0))
	     (T (FERROR NIL "")))))

(DEFUN MA-FINISH-STORE (OP)
  (COND ((AND (CONSP 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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-DISPATCH

	   LAMBDA:LAM-IR-DISP-DISPATCH-CONSTANT (MA-GET-QUOTE-INDEX QUAN)
	   LAMBDA:LAM-IR-DISP-ADDR DISP-ADR))


;(DEFUN MA-EMIT-SUB-PP (N)
;  (MA-EMIT LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-ALU
;	   LAMBDA:LAM-IR-M-SRC LAMBDA:LAM-M-SRC-PDL-BUFFER-POINTER
;	   LAMBDA:LAM-IR-A-SRC (MA-GET-A-CONSTANT N)
;	   LAMBDA:LAM-IR-FUNC-DEST LAMBDA:LAM-FUNC-DEST-PDL-BUFFER-POINTER
;	   LAMBDA:LAM-IR-OB LAMBDA:LAM-OB-ALU
;	   LAMBDA:LAM-IR-ALUF LAMBDA:LAM-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 in)
  (SETQ TAILP (LOCF 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)))
       (setq in (cond ((numberp e) e)
		      ((listp e) (car e))))
       (if (and in (not (zerop (ldb ma-I-XCT-NEXT-FLAG in))))
	   (rplacd tailp (setq tailp (list 0))))))  ;insert no-op after disptach-xct-next
  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)	;this sequence coded now.
      (SETQ TAILP (LOCF ANS))
      (IF (SETQ TEM (MA-MCLAP-SEQ SEQ))
	  (PROGN (RPLACD TAILP TEM)
		 (SETQ TAILP (LAST TEM))
		 (COND ((AND (MA-SEQ-NEXT-SEQUENCE SEQ)
			     (MA-SEQ-CHANGED (MA-SEQ-NEXT-SEQUENCE SEQ))
			     (MA-SEQ-DROPS-THRU-P SEQ))
			(RPLACD TAILP (SETQ TEM
					    (LIST
					      (MA-MCLAP-CODE-XFER-TO-SEQ
						  (MA-SEQ-NEXT-SEQUENCE SEQ)))))
			(SETQ TAILP (LAST TEM))))))
      (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 LAMBDA:LAM-IR-OP LAMBDA:LAM-OP-JUMP
	   LAMBDA:LAM-IR-JUMP-COND LAMBDA:LAM-JUMP-COND-UNC
	   LAMBDA:LAM-IR-JUMP-ADDR `(MCLAP-EVALUATE-TAG ,(CAR (MA-INST-TAGS-BEFORE
							       (CAR (MA-ELEM-MEMBERS SEQ)))))
	   LAMBDA:LAM-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 dispatch-hack-flag)
  (SETQ TAILP (LOCF 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)))))
   ;	       (format t "~%ln ~s, in ~s" ln in)
	       (cond ((AND *MA-COMBINE-DEST-FLAG*
   ;If ((functional-dest) setm m-x) follows ((m-x) <alu-or-byte> ... )
   ; combine the functional dest into the previous uinst.
		        LN IN
			(zerop (ldb ma-xcted-during-xct-next-flag ln))
			(= (ldb lambda:lam-ir-op in) lambda:lam-op-alu)
			(= (ldb lambda:lam-ir-a-mem-dest-flag in) 0)
			(= (ldb lambda:lam-ir-m-mem-dest in) 0)
			(= (ldb lambda:lam-ir-aluf in) lambda:lam-alu-setm)
			(= (ldb lambda:lam-ir-func-src-flag in) 0)  ;no functional sources.
			(or (= (ldb lam:lam-ir-op ln) lambda:lam-op-alu)
			    (= (ldb lam:lam-ir-op ln) lambda:lam-op-byte))
			(= (ldb lambda:lam-ir-a-mem-dest-flag ln) 0)
			(= (ldb lambda:lam-ir-func-dest ln) 0)
			(= (ldb lambda:lam-ir-m-src in)
			   (ldb lambda:lam-ir-m-mem-dest ln))
			)
		      (setq ln (dpb (ldb lambda:lam-ir-func-dest in)
				    lambda:lam-ir-func-dest
				    ln))
		      (format t "~%Combine dest hack! ~s ~s" i last-i)
		      (cond ((and (= (ldb lambda:lam-ir-func-dest ln)
				     lambda:lam-func-dest-c-pp-push)
				  (= (ldb lambda:lam-ir-m-src ln)
				     lambda:lam-m-src-c-pp-pop))
			     ;src of pdl-pop and dest of pdl-push dont work in same uinst.
			     ;change to source of pdl and dest of pdl.
			     (setq ln (dpb lambda:lam-func-dest-c-pp
					   lambda:lam-ir-func-dest
					   (dpb lambda:lam-m-src-c-pp
						lambda:lam-ir-m-src
						ln)))
			     (format t "~% pp-pop -> pp-push goes to pp -> pp")))
		      (cond ((numberp last-i) (setq last-i ln))
			    ((consp last-i) (rplaca last-i ln)))
		      (setq i last-i
			    last-i nil)
		      )
  ;Change xxx, unc-jump to jump-xct-next
		     ((AND *MA-HACK-XCT-NEXT*
			LN IN
			(zerop (ldb ma-xcted-during-xct-next-flag ln))
			(= (LDB LAMBDA:LAM-IR-OP IN) LAMBDA:LAM-OP-JUMP)
			(= (LDB LAMBDA:LAM-IR-JUMP-COND IN) LAMBDA:LAM-JUMP-COND-UNC)
			(= 1 (LDB LAMBDA:LAM-IR-N IN))
			(OR (= (SETQ TEM (LDB LAMBDA:LAM-IR-OP LN)) LAMBDA:LAM-OP-ALU)
			    (= TEM LAMBDA:LAM-OP-BYTE))
			;*** pdl-pass-around doesn't work between PI and PP
			(NOT (=  LAMBDA:LAM-FUNC-DEST-C-PI (LDB LAMBDA:LAM-IR-FUNC-DEST LN)))
			)
		      (SETQ IN (DPB 0 LAMBDA:LAM-IR-N IN))
		      (COND ((NUMBERP I) (SETQ I IN))
			    ((CONSP I) (RPLACA I IN)))
			;record xcted during xct-next so wont be moved again.
		      (setq ln (dpb 1 ma-xcted-during-xct-next-flag ln))
		      (cond ((numberp last-i) (setq last-i ln))
			    ((consp last-i) (rplaca last-i ln)))
		      (SETQ I (PROG1 LAST-I (SETQ LAST-I I))))
 ;also hack with dispatches.
		     ((and in (not (zerop (ldb ma-i-xct-next-flag in))))
		      (setq dispatch-hack-flag nil)
		      (cond ((and *ma-hack-xct-next*
				  ln
				  (zerop (ldb ma-xcted-during-xct-next-flag ln))
				  (OR (= (SETQ TEM (LDB LAMBDA:LAM-IR-OP LN))
					 LAMBDA:LAM-OP-ALU)
				      (= TEM LAMBDA:LAM-OP-BYTE))
				  (or (not (= 0 (ldb lambda:lam-ir-a-mem-dest-flag ln)))
				      (and (zerop (ldb lambda:lam-ir-func-dest ln))
					   (cond ((= (ldb lambda:lam-ir-m-mem-dest ln)
						     (ldb lambda:lam-ir-m-src in))
	;even tho m-dest of LN is same as m-source of IN we can reverse them if
	;IN is a dispatch and the bits to be dispatched on are comming from the m-side.
	;In that case, the dispatch instruction needs to be modified.
	; if the source of LN had a side effect (C-PDL-BUFFER-POINTER-POP) it would
	; need to be modified when copied to IN.  Since that case cant happen now, we just avoid
	; doing the hack to avoid a possible bug in the future.
						  (cond ((= (ldb lambda:lam-ir-m-src ln)
							    lambda:lam-m-src-c-pp-pop)
							 nil)
							((and (= (ldb lambda:lam-ir-op in)
								 lambda:lam-op-dispatch)
							      (or (and
								    (= (ldb lambda:lam-ir-op ln)
								       lambda:lam-op-alu)
								    (= (ldb lambda:lam-ir-aluf ln)
								       lambda:lam-alu-setm))
								  (and
								    (= (ldb lambda:lam-ir-op ln)
								       lambda:lam-op-byte)
								    (= (ldb lambda:lam-ir-byte-func ln)
								       LAMBDA:LAM-BYTE-FUNC-LDB)
								    (>= (1+ (ldb lambda:lam-ir-bytl-1 ln))
									(- 40 (ldb lambda:lam-ir-mrot in))))))
							 (setq dispatch-hack-flag t)
							 t)
							(t nil)))
						 (t t))))
	;dont reverse popj-after-next hacking pdl-pointer
	; with inst which depends on pdl-pointer.
				  (not (and (or (= (setq tem (ldb lambda:lam-ir-op in))
						   lambda:lam-op-alu)
						(= tem lambda:lam-op-byte))
					    (zerop (ldb lambda:lam-ir-a-mem-dest-flag in))
					    (= (ldb lambda:lam-ir-func-dest in)
					       lambda:lam-func-dest-pdl-buffer-pointer)
					    (or (= (setq tem (ldb lambda:lam-ir-m-src ln))
						   lambda:lam-m-src-c-pdl-buffer-pointer)
						(= tem lambda:lam-m-src-c-pp-pop)))))
	;reverse it and use xct-next only if ALU or BYTE with no funct dest, and with
	;  m-mem-dest, if any, not equal to m-src of the dispatch.

			     (cond (dispatch-hack-flag
				    (format t "~%dispatch hack!")
				    (setq in (dpb (ldb lambda:lam-ir-m-src ln)
						  lambda:lam-ir-m-src
						  in))
				    (cond ((numberp i) (setq i in))
					  ((consp i) (rplaca i in)))))
			;record xcted during xct-next so wont be moved again.
			     (setq ln (dpb 1 ma-xcted-during-xct-next-flag ln))
			     (cond ((numberp last-i) (setq last-i ln))
				   ((consp last-i) (rplaca last-i ln)))
			     (SETQ I (PROG1 LAST-I (SETQ LAST-I I))))
        ;insert noop for XCT-NEXT of dispatch.
			    (t (IF LAST-I (RPLACD TAILP (SETQ TAILP (LIST LAST-I))))
			       (setq last-i i
				     i (dpb 1 ma-xcted-during-xct-next-flag
					    0)))))))  ;insert no-op
	     (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.