(FILECREATED "21-Jun-86 14:53:24" {ERIS}<TAMARIN>WORK>DT>ASM.;28
 342272Q

      changes to:  (VARS ASMCOMS)
		   (FNS ASM.EATCODE ASM.EATCODE.DOLABEL)

      previous date: "13-Jun-86 12:27:17" {ERIS}<TAMARIN>WORK>DT>ASM.;27)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT ASMCOMS)

(RPAQQ ASMCOMS
 [(* see associated doc D2T.tedit and AsmInternal.tedit)
		  (FILES TAMGETMACHINE)
		  (* has TAM.GETMACHINE)
		  (LOCALVARS . T)
		  (COMS (* * globals)
			(* \ASM.OUTPUTLISTING gets the "output listing" when done -- \ASM.PVARMAP 
			   gets a map: non-name-table variables -> slot numbers -- \ASM.STATS gets a 
			   list <fn name, #ivars, #pvars, #fvars, max stk>)
			(GLOBALVARS \ASM.OUTPUTLISTING \ASM.PVARMAP \ASM.STATS)
			(* hash arrays for processing labels)
			(GLOBALVARS \ASM.LSEEN? \ASM.L2STACK \ASM.L2PC)
			(INITVARS \ASM.LSEEN? \ASM.L2STACK \ASM.L2PC))
		  (COMS (* * top level flow of control)
			(FNS ASM ASM.1))
		  (COMS (* * input header and name tables)
			(FNS ASM.EATHDR+NTS ASM.EATFNDECL ASM.EATDFNHEADERDECL ASM.EATVARDECLS)
			(FNS ASM.ALLOCVARS.D ASM.CKDIRVS.D)
			(FNS ASM.ALLOCVARS.T ASM.CKDIRVS.T)
			(FNS ASM.NA.D)
			(FNS ASM.CKVARNAME))
		  (COMS (* * code pass 1 -- IL -> OLT -- do all macro- and generic- expansion that 
			   can be done on first pass -- then repeat until stack modelling is finished 
			   if possible)
			(FNS ASM.ENTRYVECTOR)
			(FNS ASM.CODEPASS1 ASM.CODEPASS1.INNER ASM.EATCODE ASM.EATCODE.DOLABEL)
			(FNS ASM.STK.INSTR ASM.STKGENCLEVADJ ASM.STKAPPLYFN.LEVADJ.D)
			(FNS ASM.STK.PASSLABEL ASM.STK.JUMPTOLABEL)
			(FNS ASM.STKMAX ASM.STKADD)
			(FNS ASM.STKBIND.D ASM.STKUNBIND.D ASM.STKOK?.D)
			(FNS ASM.STKSET.T ASM.STKOK?.T))
		  (COMS (* * code pass 2 -- on OLT -- do variable-reference generics <on Tamarin the 
			   choice of opcodes may depend on stack-max?> -- determine length of 
			   everything including jump generics -- also uses ASM.VARGENC2BL 
			   ASM.JUMPGENC2BL)
			(FNS ASM.CODEPASS2 ASM.ALLCODELENGTHS ASM.REDOJGLENGTHS))
		  (COMS (* * emit header and name tables)
			(FNS ASM.MAKECODEARRAY ASM.EMITHDR+NTS)
			(FNS ASM.EMITHDR+NTS.D)
			(FNS ASM.EMITHDR+NTS.T)
			(FNS ASM.EMITANNT ASM.EMITPARTOFANNT)
			(FNS ASM.PUTB))
		  (COMS (* * code pass 3 -- on OLT emitting to CODEARRAY -- final syntax checking and 
			   emit byte code)
			(FNS ASM.EMITCODE ASM.EMITINSTR)
			(FNS ASM.EMITVANILLAINSTR ASM.EMITBIND.D ASM.EMITUNBIND.T ASM.EMITXBITS.N.FD 
			     ASM.EMITTYPEP ASM.EMITXVAR ASM.EMITJUMP.D ASM.EMITJUMP.T)
			(FNS ASM.EMITB ASM.EMITBS ASM.EMITBL ASM.EMITATOMINDEX ASM.EMITPCONST)
			(FNS ASM.VARGENC2BL ASM.XPDVARGENC)
			(FNS ASM.JUMPGENC2BL ASM.XPDJUMPGENC ASM.XPDJUMPGENC.D ASM.XPDJUMPGENC.T 
			     ASM.XPDJUMPGENC.X1 ASM.XPDJUMPGENC.X2))
		  (COMS (* * error handling and the "output listing" -- see AsmInternal.tedit)
			(FNS ASM.PHASEMARK ASM.ERR)
			(FNS ASM.LIST ASM.SMASHLIST)
			(FNS ASM.TOPIC ASM.SMASHTOPIC)
			(* * specific error messages that can be generated fom more than one place on 
			   different passes on the same instruction)
			(FNS ASM.ERR.NILLABEL ASM.ERR.LABELREPEATED ASM.ERR.LABELUNDEF)
			(FNS ASM.ERR.NOTLITATOM ASM.ERR.NOOPCODE)
			(FNS ASM.ERR.NILFORMAT ASM.ERR.FNXFORMAT ASM.ERR.BINDFORMAT 
			     ASM.ERR.JUMPFORMAT)
			(FNS ASM.ERR.STACKSTYLE ASM.ERR.UNKNOWNSTACK ASM.ERR.AMBIGSTACK))
		  (COMS (* * misc)
			(FNS ASM.VARLKUP ASM.GETOPCODE ASM.OLTAFTERCODE: ASM.CKOPNARGS 
			     ASM.CKVARALLOCSTYLE)
			(FNS ASM.OPKARGRANGE ASM.MAKEOPKBYTE)
			(FNS ASM.RANGE? ASM.POSINLIST ASM.CEIL)
			(FNS ASM.PVARMAP ASM.HELP)
			(FNS ASM.NEXTLABEL))
		  (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
											(NLAML)
											(LAMA ASM.ERR]
)



(* see associated doc D2T.tedit and AsmInternal.tedit)


(FILESLOAD TAMGETMACHINE)



(* has TAM.GETMACHINE)


(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(* * globals)





(* \ASM.OUTPUTLISTING gets the "output listing" when done -- \ASM.PVARMAP gets a map: 
non-name-table variables -> slot numbers -- \ASM.STATS gets a list <fn name, #ivars, #pvars, 
#fvars, max stk>)


(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ASM.OUTPUTLISTING \ASM.PVARMAP \ASM.STATS)
)



(* hash arrays for processing labels)


(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ASM.LSEEN? \ASM.L2STACK \ASM.L2PC)
)

(RPAQ? \ASM.LSEEN?
 NIL)

(RPAQ? \ASM.L2STACK
 NIL)

(RPAQ? \ASM.L2PC
 NIL)
(* * top level flow of control)


(DEFINEQ

(ASM

  [LAMBDA (INPUTLIST MACHINE OPTIONS ERRFILE)                (* jmh "31-May-86 11:23")


          (* * returns (nErrs . objectCodeThingy) -- returns outputList in \ASM.OUTPUTLISTING anyway -- returns 

	  non-name-table variable map in \ASM.PVARMAP and stats in \ASM.STATS)




          (* * MACHINE is something that TAM.GETMACHINE can decode, to use in setting up our machine-style specvars)




          (* * OPTIONS are list of or one of -- D= list error messages even if duplicated, and tag with phasemark)




          (* * if ERRFILE is NIL, error messages are printed to T and ASM.HELP calls HELP. else error messages are printed to

	  ERRFILE, ASM.HELP prints its arguments there, and ASM.HELP calls ERROR!)




          (* * ASM just initializes globalvars, declares specvars, and makes up the return value -- ASM.1 actually calls the 

	  phases)



    (if
 (
NLISTP
 OPTIONS)
	then
 (
SETQ
 OPTIONS (
LIST
 OPTIONS)))
    (DECLARE
 (
GLOBALVARS
 \ASM.OUTPUTLISTING \ASM.PVARMAP \ASM.STATS))
                                                             (* initialize global catchers-of-debug-info)

    (
SETQ
 \ASM.OUTPUTLISTING (
QUOTE
 ??))
    (
SETQ
 \ASM.PVARMAP (
QUOTE
 ??))
    (
SETQ
 \ASM.STATS (
QUOTE
 ??))
    (DECLARE
 (
GLOBALVARS
 \ASM.LSEEN? \ASM.L2STACK \ASM.L2PC))
                                                             (* initialize global arrays)

    [if
 (
OR
 (
NULL
 \ASM.LSEEN?)
		(
NULL
 \ASM.L2STACK)
		(
NULL
 \ASM.L2PC))
	then
 (LET ((N (
IQUOTIENT
 (
LENGTH
 INPUTLIST)
				     10)))
		    (
SETQ
 \ASM.LSEEN? (
HASHARRAY
 N))
		    (
SETQ
 \ASM.L2STACK (
HASHARRAY
 N))
		    (
SETQ
 \ASM.L2PC (
HASHARRAY
 N]
    (
CLRHASH
 \ASM.L2PC)
    (LET (TAM.OUTPUTSTYLE TAM.LINKINFO TAM.FNHDRSTYLE TAM.NTSTYLE TAM.VARALLOCSTYLE TAM.1STVARSLOT 
			  TAM.STACKSTYLE TAM.MAXSTACK TAM.VARXSTYLE TAM.ALPHASTYLE TAM.OPKSTYLE 
			  TAM.JUMPSTYLE TAM.ASMFNPROPS TAM.OPCODEPROPS TAM.LAMBDAEVS TAM.NLAMBDAEVS 
			  TAM.LAMBDA*EV TAM.NLAMBDA*EV)      (* what MACHINE is this?)

         (DECLARE
 (
SPECVARS
 TAM.OUTPUTSTYLE TAM.LINKINFO TAM.FNHDRSTYLE TAM.NTSTYLE 
				TAM.VARALLOCSTYLE TAM.1STVARSLOT TAM.STACKSTYLE TAM.MAXSTACK 
				TAM.VARXSTYLE TAM.ALPHASTYLE TAM.OPKSTYLE TAM.JUMPSTYLE 
				TAM.ASMFNPROPS TAM.OPCODEPROPS TAM.LAMBDAEVS TAM.NLAMBDAEVS 
				TAM.LAMBDA*EV TAM.NLAMBDA*EV))
         (
TAM.GETMACHINE
 MACHINE)
         (LET ((OLT (
CONS
))
	       LJL CODEARRAY LINKINFO OWNENTRYVECTOR?)

          (* the top-level variables the data flows through -- LJL is LabelandJumpList, for jump-length resolution;

	  is a list of Label or <TailofOLT Starting with JumpGeneric, PC, length>)



	      (DECLARE
 (
SPECVARS
 OLT LJL CODEARRAY LINKINFO OWNENTRYVECTOR?))
	      (LET ((ERRSYMBOL (
QUOTE
 !****))
		    (TOTALNERRS 0)
		    (ERRSOK? T)
		    TOPICERRS? LASTERRPHASE ERRPHASE ERRPHASEMARK ERRTOPIC)
                                                             (* error handling)

	           (DECLARE
 (
SPECVARS
 ERRFILE ERRSYMBOL TOTALNERRS ERRSOK? TOPICERRS? 
					  LASTERRPHASE ERRPHASE ERRPHASEMARK ERRTOPIC))
	           (LET [(DEBUG? (
INTERSECTION
 OPTIONS (
QUOTE
 (D DEBUG]
                                                             (* debug control)

		        (DECLARE
 (
SPECVARS
 DEBUG?))
		        (LET (IVARS PVARS FVARS NTVARS LTVARS)
                                                             (* tracking of vars by lists of 

							     (name . slot#))

			     (DECLARE
 (
SPECVARS
 IVARS PVARS FVARS NTVARS LTVARS))
			     (LET (FNTYPE FNNAME THEARGLIST STKMIN PV STARTPC NTSIZE NLOCALS 
					  FVAROFFSET LTSIZE (MAXSTK 0)
					  MAXPC INITTOS)     (* function-header like stuff)

			          (DECLARE
 (
SPECVARS
 FNTYPE FNNAME THEARGLIST STKMIN PV STARTPC 
							 NTSIZE NLOCALS FVAROFFSET LTSIZE MAXSTK 
							 MAXPC INITTOS))

          (* * actually do things)



			          (ASM.1
 INPUTLIST)

          (* * now return results ...)



			          (
SETQ
 \ASM.OUTPUTLISTING (
CAR
 OLT))
			          (
SETQ
 \ASM.PVARMAP (ASM.PVARMAP
))
			          (
SETQ
 \ASM.STATS (
LIST
 FNNAME (
LENGTH
 IVARS)
							     (
LENGTH
 PVARS)
							     (
LENGTH
 FVARS)
							     MAXSTK))
			          (
CONS
 TOTALNERRS (if
 TAM.LINKINFO
							 then
 (
CONS
 CODEARRAY LINKINFO)
						       else
 CODEARRAY])

(ASM.1

  [LAMBDA (IL)
                                                             (* jmh 
                                                                           "30-Mar-86 10:40")

            
            (* * actual top-level flow of control)


    (DECLARE
 (SPECVARS IL))
    (ASM.PHASEMARK
 (QUOTE atBeginning))
    (if
 (NLISTP IL)
        then
 (ASM.ERR
 "no input")
      else
  
            (* * first phase -- IL -> OLT + specvars --
            do code part repeatedly until stack modelling finished)


           (SETQ ERRSOK? T)
           (ASM.EATHDR+NTS
)
           (LCONC OLT (ASM.CODEPASS1
 (APPEND (ASM.ENTRYVECTOR
)
                                            IL))) 
            
            (* * second phase -- within OLT -- finish macro-
            and generic- expansion -- determine lengths of instructions)


           (ASM.CODEPASS2
) 
            
            (* * third = last phase -- OLT + specvars -> CODEARRAY --
            syntax checking within opcodes)


           (ASM.MAKECODEARRAY
)
           (ASM.EMITHDR+NTS
)
           (ASM.EMITCODE
))
    (ASM.PHASEMARK
 (QUOTE atEnd])
)
(* * input header and name tables)


(DEFINEQ

(ASM.EATHDR+NTS

  [LAMBDA NIL
    (DECLARE
 (
USEDFREE
 IL OWNENTRYVECTOR?)
	       (
USEDFREE
 TAM.FNHDRSTYLE TAM.VARALLOCSTYLE))
                                                             (* jmh "13-Jun-86 10:13")

    (ASM.PHASEMARK
 "input hdr + nts" 0)
    (ASM.EATFNDECL
)
    (ASM.EATDFNHEADERDECL
)
    (ASM.EATVARDECLS
)
    (if
 (
AND
 (
LISTP
 IL)
		 (
EQ
 (
CAR
 IL)
		       (
QUOTE
 LOCAL:)))
	then
 (ASM.LIST
 (pop
 IL))
	       (ASM.EATVARDECLS
 T))
    (if
 (
AND
 (
LISTP
 IL)
		 (
EQ
 (
CAR
 IL)
		       (
QUOTE
 CODE:)))
	then
 (ASM.LIST
 (pop
 IL))
	       (if
 (
AND
 (
LISTP
 IL)
			    (
EQ
 (
CAR
 IL)
				  (
QUOTE
 OWNENTRYVECTOR:)))
		   then
 (
SETQ
 OWNENTRYVECTOR? T)
			  (ASM.LIST
 (pop
 IL)))
      else
 (ASM.LIST
 (
QUOTE
 CODE:))
	     (ASM.ERR
 "CODE: supplied"))
    (ASM.PHASEMARK
 "after hdr+nts" 99)
    (
SELECTQ
 TAM.VARALLOCSTYLE
	       (D (ASM.ALLOCVARS.D
))
	       (ASM.ALLOCVARS.T
))
    (
SELECTQ
 TAM.FNHDRSTYLE
	       (D (ASM.CKDIRVS.D
))
	       (ASM.CKDIRVS.T
])

(ASM.EATFNDECL

  [LAMBDA NIL
                                                          (* jmh 
                                                                           "26-Feb-86 17:15")

    (DECLARE
 (USEDFREE IL FNTYPE FNNAME THEARGLIST IVARS))
    [if
 [NOT (AND (LISTP IL)
                      (LISTP (CAR IL))
                      (MEMB (CAAR IL)
                            (QUOTE (LAMBDA: NLAMBDA:]
        then
 (ASM.ERR
 "no fn decl")
      else
 (LET ((I (ASM.LIST
 (pop
 IL)))
                     NOSPREAD?)
                    (if
 [OR (NEQ 3 (LENGTH I))
                                [NOT (LITATOM (SETQ FNNAME (CADR I]
                                (MEMB FNNAME (QUOTE (NIL T)))
                                (NOT (OR (LISTP (SETQ THEARGLIST (CADDR I)))
                                         (LITATOM THEARGLIST]
                        then
 (ASM.ERR
 "fn decl ill-formed")
                      else
 (SETQ NOSPREAD?
                                (if
 (ASM.CKVARNAME
 THEARGLIST)
                                    then
 T
                                  elseif
 (AND THEARGLIST (NLISTP THEARGLIST))
                                    then
 (ASM.ERR
 "nospread arglist ill-formed" THEARGLIST)
                                          (SETQ THEARGLIST (QUOTE bad$arg))
                                          T
                                  else
 [SETQ THEARGLIST
                                            (for
 V in
 THEARGLIST
                                               collect
 (OR (ASM.CKVARNAME
 V)
                                                               (PROGN (ASM.ERR
 
                                                                             "varname ill-formed" V)
                                                                      (QUOTE bad$arg]
                                        NIL))
                            (SETQ FNTYPE (if
 (EQ (CAR I)
                                                     (QUOTE LAMBDA:))
                                             then
 (if
 NOSPREAD?
                                                          then
 (QUOTE LAMBDA*)
                                                        else
 (QUOTE LAMBDA))
                                           else
 (if
 NOSPREAD?
                                                        then
 (QUOTE NLAMBDA*)
                                                      else
 (QUOTE NLAMBDA]
    (if
 (NULL FNNAME)
        then
 (SETQ FNNAME (QUOTE bad$fn$name))
              (SETQ FNTYPE (QUOTE LAMBDA))
              (SETQ THEARGLIST (if
 [MEMB FNTYPE (QUOTE (LAMBDA NLAMBDA]
                                   then
 (LIST (QUOTE bad$arg))
                                 else
 (QUOTE bad$arg])

(ASM.EATDFNHEADERDECL

  [LAMBDA NIL
                                                          (* jmh 
                                                                           " 9-Nov-85 13:13")

    (DECLARE
 (USEDFREE IL STKMIN PV STARTPC NTSIZE NLOCALS FVAROFFSET))
    (if
 (AND (LISTP IL)
                 (LISTP (CAR IL))
                 (EQ (CAAR IL)
                     (QUOTE DFNHEADER:)))
        then
 (LET*((I (ASM.LIST
 (pop
 IL)))
                       (L (CDR I)))
                  (while
 (LISTP L) bind
 V A X
                     do
 (SETQ V (pop
 L))
                           (SETQ A (pop
 L))
                           (if
 (AND A (NOT (NUMBERP A)))
                               then
 (ASM.ERR
 "non-num arg" A)
                             else
 (SET (SELECTQ V
                                               (STKMIN: (QUOTE STKMIN))
                                               (PV: (QUOTE PV))
                                               (STARTPC: (QUOTE STARTPC))
                                               (NTSIZE: (QUOTE NTSIZE))
                                               (NLOCALS: (QUOTE NLOCALS))
                                               (FVAROFFSET: (QUOTE FVAROFFSET))
                                               (PROGN (ASM.ERR
 "bad keyword" V)
                                                      (QUOTE X)))
                                           A])

(ASM.EATVARDECLS

  [LAMBDA (LOCAL?)
    (DECLARE
 (USEDFREE IL FNTYPE THEARGLIST IVARS PVARS FVARS NTVARS LTVARS)
           (USEDFREE TAM.VARALLOCSTYLE))
                               (* jmh 
                                                                           "13-Mar-86 17:40")

            
            (* * loop processing var decls)


    (while
 [AND (LISTP IL)
                    (NOT (MEMB (CAR IL)
                               (if
 LOCAL?
                                   then
 (QUOTE (CODE:))
                                 else
 (QUOTE (LOCAL: CODE:] bind
 I VARTYPE
       do

            
            (* * I _ decl -- VARTYPE _ varType/NIL)


       (SETQ I (ASM.LIST
 (pop
 IL)))
       (SETQ VARTYPE (if
 (NLISTP I)
                         then
 (ASM.ERR
 "bad pseudolabel in decl section")
                               NIL
                       elseif
 (EQ (CAR I)
                                      (QUOTE *))
                         then
                                          (* comment)

                               NIL
                       elseif
 (ASM.CKVARALLOCSTYLE
 (SELECTQ (CAR I)
                                                               ((IVARS: IVAR:) 
                                                                    (QUOTE IVAR))
                                                               ((PVARS: PVAR:) 
                                                                    (QUOTE PVAR))
                                                               ((VARS: VAR:) 
                                                                    (QUOTE PVAR))
                                                               ((FVARS: FVAR:) 
                                                                    (QUOTE FVAR))
                                                               NIL))
                       else
 (ASM.ERR
 "not a var decl")
                             NIL)) 
            
            (* * loop over vars V in decl -- V_NIL to terminate processing of V)


       (if
 VARTYPE
           then

           (for
 V in
 (CDR I)
              do
 (if
 (NOT (SETQ V (ASM.CKVARNAME
 V)))
                         then
                                          (* disallow illformed 
                                                                           varnames)

                               (ASM.ERR
 "bad varname" V))
                    (if
 (AND V (OR (ASM.VARLKUP
 V IVARS)
                                       (ASM.VARLKUP
 V PVARS)
                                       (ASM.VARLKUP
 V FVARS)))
                        then
                                           (* disallow 
                                                                           redeclaring V)

                              (ASM.ERR
 "var redeclared" V)
                              (SETQ V NIL))
                    (if
 V
                        then
                                           (* disallow misc 
                                                                           other things)

                              (SELECTQ VARTYPE
                                  (IVAR                                    (* varallocstyle = D 
                                                                           -- ivar must be in 
                                                                           arglist)

                                        (if
 (NOT (SELECTQ FNTYPE
                                                         ([LAMBDA NLAMBDA] 
                                                              (MEMB V THEARGLIST))
                                                         (EQ V THEARGLIST)))
                                            then
 (ASM.ERR
 "IVAR not in arglist" V)
                                                  (SETQ V NIL)))
                                  (PVAR (SELECTQ TAM.VARALLOCSTYLE
                                            (D                             (* D-machine pvars 
                                                                           can't be in arglist, 
                                                                           except for LAMBDA*)

                                               (if
 (SELECTQ FNTYPE
                                                           ([LAMBDA NLAMBDA] 
                                                                (MEMB V THEARGLIST))
                                                           (NLAMBDA* (EQ V THEARGLIST))
                                                           (PROG1 NIL))
                                                   then
 (ASM.ERR
 "has to be IVAR" V)
                                                         (SETQ V NIL)))
                                            NIL))
                                  (FVAR                                    (* fvars can't be in 
                                                                           arglist)

                                        (if
 (SELECTQ FNTYPE
                                                    ([LAMBDA NLAMBDA] 
                                                         (MEMB V THEARGLIST))
                                                    (EQ V THEARGLIST))
                                            then
 (ASM.ERR
 "has to be IVAR" V)
                                                  (SETQ V NIL)))
                                  (ASM.HELP
 "bad VARTYPE 1" VARTYPE)))
                    (if
 V
                        then
                                           (* declare V by type, 
                                                                           localness -- no slot 
                                                                           allocated)

                              (LET ((VANDS (CONS V NIL)))
                                   (SELECTQ VARTYPE
                                       (IVAR (push
 IVARS VANDS))
                                       (PVAR (push
 PVARS VANDS))
                                       (FVAR (push
 FVARS VANDS))
                                       (ASM.HELP
 "bad varType" VARTYPE))
                                   (if
 (NOT LOCAL?)
                                       then
 (SETQ NTVARS (NCONC1 NTVARS VANDS))
                                     elseif
 (LITATOM (if
 (NLISTP V)
                                                             then
 V
                                                           else
 (CAR V)))
                                       then
 (SETQ LTVARS (NCONC1 LTVARS VANDS])
)
(DEFINEQ

(ASM.ALLOCVARS.D

  [LAMBDA NIL
    (DECLARE
 (USEDFREE FNTYPE THEARGLIST)
           (USEDFREE IVARS PVARS FVARS NTVARS LTVARS))
                 (* jmh 
                                                                           "13-Mar-86 13:09")

            
            (* * check all ivars are declared --
            note D-machine allows LAMBDA* arglist to be declared pvar)


    (SELECTQ FNTYPE
        (LAMBDA* (if
 (NOT (OR (ASM.VARLKUP
 THEARGLIST IVARS)
                                  (ASM.VARLKUP
 THEARGLIST PVARS)))
                     then
 (ASM.ERR
 "arglist var not declared" THEARGLIST)))
        (NLAMBDA* (if
 (NOT (ASM.VARLKUP
 THEARGLIST IVARS))
                      then
 (ASM.ERR
 "arglist var not declared" THEARGLIST)))
        (if
 [NOT (for
 V in
 THEARGLIST thereis
 (NOT (ASM.VARLKUP
 V IVARS T]
            then
 (ASM.ERR
 "arglist var not declared" V)))
            
            (* * smash slot nrs into the VANDS's --
            the entries of LT/NTVARS are therefore affected too)

            
            (* * ivars get their BX slot-nrs)


    (SELECTQ FNTYPE
        ([LAMBDA NLAMBDA] 
             (for
 VANDS in
 IVARS do
 (RPLACD VANDS (ASM.POSINLIST
 (CAR VANDS)
                                                                     THEARGLIST))))
        (if
 IVARS
            then
 (RPLACD (CAR IVARS)
                            0)))
            
            (* * pvars before fvars in the var section of the frame proper)


    (LET ((SLOTNR 0))
         [for
 VANDS in
 PVARS do
 (RPLACD VANDS (PROG1 SLOTNR (add
 SLOTNR 1]
         (for
 VANDS in
 FVARS do
 (RPLACD VANDS (PROG1 SLOTNR (add
 SLOTNR 1])

(ASM.CKDIRVS.D

  [LAMBDA NIL
    (DECLARE
 (USEDFREE IVARS PVARS FVARS NTVARS LTVARS)
           (USEDFREE PV STKMIN STARTPC NTSIZE NLOCALS FVAROFFSET LTSIZE))

                                                                           (* jmh 
                                                                           "13-Mar-86 16:37")

            
            (* * compute function-header like numbers for D machine --
            check DFNHEADER if any)


    (LET ((NRSLOTS (IPLUS (LENGTH PVARS)
                          (LENGTH FVARS)))
          (OLDPV PV)
          (OLDSTKMIN STKMIN)
          (OLDSTARTPC STARTPC)
          (OLDNTSIZE NTSIZE)
          (OLDNLOCALS NLOCALS)
          (OLDFVAROFFSET FVAROFFSET))
            
            (* * PV)


         (SETQ PV (SUB1 (FOLDHI NRSLOTS CELLSPERQUAD)))
         (if
 (AND OLDPV (IGREATERP OLDPV PV))
             then
 (ASM.ERR
 "PV: said" OLDPV "vs" PV))
            
            (* * STKMIN)


         [SETQ STKMIN (IPLUS 56Q (ITIMES 2 (IPLUS 1 (ASM.NA.D
)
                                                  (ITIMES 2 PV]
         (if
 (AND OLDSTKMIN (IGREATERP OLDSTKMIN STKMIN))
             then
 (ASM.ERR
 "STKMIN: said" OLDSTKMIN "vs" STKMIN))
            
            (* * NTSIZE)


         [SETQ NTSIZE (LET ((N (LENGTH NTVARS)))
                           (if
 (EQ 0 N)
                               then
 0
                             else
 (UNFOLD (FOLDHI (ADD1 N)
                                                     WORDSPERQUAD)
                                             WORDSPERQUAD]
         (if
 (AND OLDNTSIZE (NEQ OLDNTSIZE NTSIZE))
             then
 (ASM.ERR
 "NTSIZE: said" OLDNTSIZE "vs" NTSIZE))
            
            (* * NLOCALS)


         (SETQ NLOCALS (LENGTH PVARS))
         (if
 (AND OLDNLOCALS (IGREATERP OLDNLOCALS NLOCALS))
             then
 (ASM.ERR
 "NLOCALS: said" OLDNLOCALS "vs" NLOCALS))
            
            (* * FVAROFFSET)


         [SETQ FVAROFFSET (if
 (NULL (INTERSECTION FVARS NTVARS))
                              then
 0
                            else
 (IPLUS (fetch
 (CODEARRAY OVERHEADWORDS) of
 T)
                                            (LENGTH (INTERSECTION PVARS NTVARS))
                                            (LENGTH (INTERSECTION IVARS NTVARS]
         (if
 (AND OLDFVAROFFSET (NEQ OLDFVAROFFSET FVAROFFSET))
             then
 (ASM.ERR
 "FVAROFFSET: said" OLDFVAROFFSET "vs" FVAROFFSET))
            
            (* * STARTPC, incl LTSIZE)


         [SETQ LTSIZE (LET ((N (LENGTH LTVARS)))
                           (if
 (EQ 0 N)
                               then
 0
                             else
 (UNFOLD (FOLDHI (ADD1 N)
                                                     2)
                                             2]                            (* 2 = (WORDSPERQUAD 
                                                                           / 2))

         (SETQ STARTPC (UNFOLD (IPLUS (fetch
 (CODEARRAY OVERHEADWORDS) of
 T)
                                      (if
 (EQ 0 NTSIZE)
                                          then
 WORDSPERQUAD
                                        else
 (ITIMES 2 NTSIZE))
                                      (ITIMES 2 LTSIZE))
                              BYTESPERWORD))
         (PROG1 NIL 
            
            (* * don't test STARTPC against OLDSTARTPC because in case of LAMBDA*s 
            which didn't refer to their args at all, that is those whose ivar is a 
            dummy generated by DDISASM, we generate no LocalTable, but the compiler 
            does!)

])
)
(DEFINEQ

(ASM.ALLOCVARS.T

  [LAMBDA NIL
    (DECLARE
 (
USEDFREE
 FNTYPE THEARGLIST INITTOS)
	       (
USEDFREE
 IVARS PVARS FVARS NTVARS LTVARS)
	       (
USEDFREE
 TAM.1STVARSLOT))                  (* jmh "12-Jun-86 16:43")


          (* * leaves INITTOS pointing to last var slot used)




          (* * smashes slot nrs in VANDS's -- so entries of NT/LTVARS are affected too)



    (if
 (
IGREATERP
 (
LENGTH
 THEARGLIST)
		       7)
	then
 (ASM.ERR
 "too many arguments"))
    [
SELECTQ
 FNTYPE
	       [[LAMBDA NLAMBDA]
		 (for
 VANDS in
 PVARS bind
 SLOTNR do
 (if
 (
SETQ
 SLOTNR (ASM.POSINLIST

								      (
CAR
 VANDS)
								      THEARGLIST))
								then
 (
RPLACD
 VANDS
										 (
PLUS
 
										   TAM.1STVARSLOT 
											 SLOTNR]
	       (for
 VANDS in
 PVARS do
 (if
 (
EQ
 (
CAR
 VANDS)
							THEARGLIST)
						then
 (
RPLACD
 VANDS TAM.1STVARSLOT]

          (* * pvars then fvars, starting in rel var slot 8)



    (LET ((SLOTNR (
PLUS
 TAM.1STVARSLOT 8)))
         (for
 VANDS in
 PVARS when
 (
NULL
 (
CDR
 VANDS))
	    do
 (
RPLACD
 VANDS SLOTNR)
		 (add
 SLOTNR 1))
         (for
 VANDS in
 FVARS
	    do
 (
RPLACD
 VANDS SLOTNR)
		 (add
 SLOTNR 1))
         (
SETQ
 INITTOS (
SUB1
 SLOTNR])

(ASM.CKDIRVS.T

  [LAMBDA NIL
    (DECLARE
 (
USEDFREE
 TAM.NTSTYLE)
	       (
USEDFREE
 IVARS PVARS FVARS NTVARS LTVARS)
	       (
USEDFREE
 STARTPC NTSIZE NLOCALS FVAROFFSET LTSIZE))
                                                             (* jmh "12-Jun-86 16:46")


          (* * compute function-header like numbers for T machine)



    (LET [(FNHDRCELLS (
PLUS
 (fetch
 (TFNHDR OVERHEADCELLS) of
 T)
			      (
PROG1
 8                     (* for entry vector)
]

          (* * NTSIZE)



         (if
 (
NEQ
 TAM.NTSTYLE (
QUOTE
 D))
	     then
 (ASM.HELP
 "don't know nametable style" TAM.NTSTYLE))
         [
SETQ
 NTSIZE (LET ((N (
LENGTH
 NTVARS)))
			     (if
 (
EQ
 0 N)
				 then
 0
			       else
 (UNFOLD (FOLDHI (
ADD1
 N)
						      WORDSPERQUAD)
					      WORDSPERQUAD]

          (* * NLOCALS)



         (
SETQ
 NLOCALS (
LENGTH
 PVARS))

          (* * FVAROFFSET)



         [
SETQ
 FVAROFFSET (if
 (
NULL
 (
INTERSECTION
 FVARS NTVARS))
				then
 0
			      else
 (
IPLUS
 (UNFOLD FNHDRCELLS WORDSPERCELL)
					      (
LENGTH
 (
INTERSECTION
 PVARS NTVARS))
					      (
LENGTH
 (
INTERSECTION
 IVARS NTVARS]

          (* * STARTPC, incl LTSIZE)



         [
SETQ
 LTSIZE (LET ((N (
LENGTH
 LTVARS)))
			     (if
 (
EQ
 0 N)
				 then
 0
			       else
 (UNFOLD (FOLDHI (
ADD1
 N)
						      2)
					      2]             (* 2 = (WORDSPERQUAD / 2))

         (
SETQ
 STARTPC (CEIL (UNFOLD (
IPLUS
 (UNFOLD FNHDRCELLS WORDSPERCELL)
						(if
 (
EQ
 0 NTSIZE)
						    then
 WORDSPERQUAD
						  else
 (
ITIMES
 2 NTSIZE))
						(
ITIMES
 2 LTSIZE))
				       BYTESPERWORD)
			       BYTESPERCELL])
)
(DEFINEQ

(ASM.NA.D

  [LAMBDA NIL
    (DECLARE
 (
USEDFREE
 FNTYPE IVARS))
    (if
 (
EQ
 FNTYPE (
QUOTE
 LAMBDA*))
	then
 -1
      else
 (
LENGTH
 IVARS])
)
(DEFINEQ

(ASM.CKVARNAME

  [LAMBDA (VARNAME)
                                                    (* jmh 
                                                                           "26-Feb-86 12:30")

            
            (* * returns varname if ok, else NIL)


    (LET ((V VARNAME))
         (if
 (LISTP V)
             then
 (SETQ V (if
 (AND (EQ 2 (LENGTH V))
                                           (NUMBERP (CADR V)))
                                  then
 (CAR V)
                                else
 NIL)))
         (if
 (OR [AND (LITATOM V)
                          (NOT (FMEMB V (QUOTE (NIL T]
                     (STRINGP V))
             then
 VARNAME
           else
 NIL])
)
(* * code pass 1 -- IL -> OLT -- do all macro- and generic- expansion that can be done on 
first pass -- then repeat until stack modelling is finished if possible)


(DEFINEQ

(ASM.ENTRYVECTOR

  [LAMBDA NIL                                                (* jmh "31-May-86 11:25")


          (* * return the appropriate entry vector for this machine, function-type, and nr-of-args-expected)



    (DECLARE
 (
USEDFREE
 FNTYPE THEARGLIST OWNENTRYVECTOR?)
	       (
USEDFREE
 TAM.LAMBDAEVS TAM.NLAMBDAEVS TAM.LAMBDA*EV TAM.NLAMBDA*EV))
    (if
 OWNENTRYVECTOR?
	then
 NIL
      else
 (
SELECTQ
 FNTYPE
			[LAMBDA (
CAR
 (
NTH
 TAM.LAMBDAEVS (
ADD1
 (
LENGTH
 THEARGLIST]
			[NLAMBDA (
CAR
 (
NTH
 TAM.NLAMBDAEVS (
ADD1
 (
LENGTH
 THEARGLIST]
			(LAMBDA* TAM.LAMBDA*EV)
			(NLAMBDA* TAM.NLAMBDA*EV)
			(ASM.HELP
 "bad fnType" FNTYPE])
)
(DEFINEQ

(ASM.CODEPASS1

  [LAMBDA (IL)
                                                             (* jmh 
                                                                           "30-Mar-86 10:39")

            
            (* * code pass 1 -- IL for instrs -> OLT for instrs --
            do all macro- and generic- expansion that can be done on first pass --
            repeat with error messages suppressed <accumulating stack information in 
            \ASM.L2STACK> until stack modelling is complete or APPLYFN can't be 
            stackmodelled -- if there are errors, will need to do a final time to get 
            error messages printed to terminal)


    (DECLARE
 (GLOBALVARS \ASM.L2STACK)
           (USEDFREE ERRSOK? TOTALNERRS TAM.MAXSTACK MAXSTK))
    (LET ((TOTALNERRSBASE TOTALNERRS)
          OLT STACK STKPROGRESS? STKFAILURE? NFML (PASS 100)
          (MAXPASS 119))
         (DECLARE
 (SPECVARS OLT STACK STKPROGRESS? STKFAILURE? NFML))
            
            (* * stack modelling -- STACK is a list of possible stack values, which 
            depends on machine type -- STKPROGRESS? is set true whenever another stack 
            position at a label becomes known -- NFML is a numeric counter for making 
            labels from, so they'll be the same on every pass)

            
            (* * we do stack modelling by -- do left->right pass repeatedly, with 
            error messages disabled, as though from scratch except that stack 
            information accumulates in \ASM.L2STACK, until stack information stops 
            accumulating or APPLYFN-handling sets STKFAILURE? --
            then if there were errors do it once again with error messages enabled --
            the errors may go away now that stack modelling is completed --
            in either case we use the results of the last pass)


         (CLRHASH \ASM.L2STACK)
         (SETQ ERRSOK? NIL)
         (repeatuntil
 (OR STKFAILURE? (NOT STKPROGRESS?)
                          (IGEQ PASS MAXPASS)) do
 (SETQ TOTALNERRS TOTALNERRSBASE)
                                                  (ASM.CODEPASS1.INNER
 IL PASS)
                                                  (add
 PASS 1))
         (SETQ ERRSOK? T)
         (if
 (OR STKFAILURE? (IGREATERP TOTALNERRS TOTALNERRSBASE)
                 (IGEQ PASS MAXPASS))
             then
 (SETQ TOTALNERRS TOTALNERRSBASE)
                  (ASM.CODEPASS1.INNER
 IL PASS)
                  (if
 STKFAILURE?
                      then
 (ASM.ERR
 "stack modelling aborted")
                    elseif
 STKPROGRESS?
                      then
 (ASM.ERR
 "stack modelling didn't terminate at pass" PASS)))
         (if
 (AND TAM.MAXSTACK (IGREATERP MAXSTK TAM.MAXSTACK))
             then
 (ASM.ERR
 "max stack" MAXSTK "vs" TAM.MAXSTACK))
         (CAR OLT])

(ASM.CODEPASS1.INNER

  [LAMBDA (IL PASS)
                                                    (* jmh 
                                                                           " 4-Mar-86 19:04")

            
            (* * do one pass for ASM.CODEPASS1 --
            which has set ERRSOK? properly)


    (DECLARE
 (GLOBALVARS \ASM.LSEEN?)
           (USEDFREE TAM.STACKSTYLE INITTOS OLT NFML STACK STKPROGRESS?))
    (ASM.PHASEMARK
 "eat code" PASS)
    (SETQ OLT (CONS))
    (SETQ NFML 0)
    (CLRHASH \ASM.LSEEN?)
    (SETQ STACK (SELECTQ TAM.STACKSTYLE
                    (D (LIST (LIST 0)))
                    (LIST INITTOS)))
    (SETQ STKPROGRESS? NIL)
    (ASM.EATCODE
 IL)
    (if
 [OR (NLISTP (CDR OLT))
                (NOT (EQUAL (CAADR OLT)
                            (QUOTE (-X-]
        then
                                                           (* force terminating 
                                                                           -X-)

              (ASM.EATCODE
 (QUOTE ((-X-])

(ASM.EATCODE

  [LAMBDA (IL)                                               (* jmh "21-Jun-86 12:36")


          (* * this processes some instructions IL onto the specvar output stream OLT)




          (* * an AsmFn has one argument, an instruction, which has been ASM.LISTed AS A COMMENT ONLY <so error messages can 

	  be hung on it> -- the AsmFn can <1> return a list of instructions to be ASM.LISTed and ASM.STKMODELed and/or <2> 

	  itself call ASM.EATCODE on a list of instructions, so that their AsmFns get expanded as well)



    (DECLARE
 (
GLOBALVARS
 \ASM.LSEEN?)
	       (
USEDFREE
 TAM.ASMFNPROPS))
    (for
 I in
 IL bind
 ASMFN do
 (if
 (
NLISTP
 I)
					   then
            (* label)

						  (ASM.EATCODE.DOLABEL
 I)
					 elseif
 (
EQ
 (
QUOTE
 *)
							(
CAR
 I))
					   then
            (* comment)

						  (ASM.LIST
 I)
					 elseif
 (for
 PROPNAME in
 TAM.ASMFNPROPS
						     thereis
 (
SETQ
 ASMFN (
GETPROP
 (
CAR
 I)
											PROPNAME)))
					   then
            (* macro or vanilla generic)

						  (ASM.LIST
 (
CONS
 (
QUOTE
 *)
								      I))
						  (for
 J in
 (
APPLY*
 ASMFN I)
						     do
 (if
 (
NLISTP
 J)
							      then
 (ASM.EATCODE.DOLABEL
 J)
							    else
 (ASM.STK.INSTR
 J)))
					 else
              (* vanilla instr)

						(ASM.STK.INSTR
 I])

(ASM.EATCODE.DOLABEL

  [LAMBDA (I)                                                (* jmh "21-Jun-86 12:35")

    (ASM.LIST
 I)
    (if
 (
NULL
 I)
	then
 (ASM.ERR.NILLABEL
)
      elseif
 (
GETHASH
 I \ASM.LSEEN?)
	then
 (ASM.ERR.LABELREPEATED
)
      else
 (
PUTHASH
 I T \ASM.LSEEN?)
	     (ASM.STK.PASSLABEL
 I])
)
(DEFINEQ

(ASM.STK.INSTR

  [LAMBDA (I)
    (DECLARE
 (
GLOBALVARS
 \ASM.L2STACK)
	       (
USEDFREE
 STACK NFML TAM.STACKSTYLE))       (* jmh "21-May-86 13:31")

    (if
 (
OR
 (
NLISTP
 I)
		(
EQ
 (
QUOTE
 *)
		      (
CAR
 I)))
	then
 (ASM.HELP
 "non-instr" I)
      elseif
 (
NOT
 (
LITATOM
 (
CAR
 I)))
	then
 (ASM.LIST
 I)
	       (ASM.ERR.NOTLITATOM
)
      else
 (ASM.LIST
 I)
	     (LET [(LEVADJ (LET (OPCODE X)
			        (if
 (ASM.STKGENCLEVADJ
 (
CAR
 I))
				  elseif
 (
EQ
 (
CAR
 I)
						 (
QUOTE
 APPLYFN))
				    then
 (ASM.STKAPPLYFN.LEVADJ.D
)
				  elseif
 (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CAR
 I)))
				    then
 (if
 (
LISTP
 (
SETQ
 X (fetch
 (OPCODE LEVADJ)
								       of
 OPCODE)))
					       then
 (
CAR
 X)
					     elseif
 X
					     else
 (
CAR
 I))
				  else
 (ASM.ERR.NOOPCODE
)
					 0]
	          (
SELECTQ
 LEVADJ
			     (
RETURN
 (
SETQ
 STACK NIL))
			     (JUMP (ASM.STK.JUMPTOLABEL
 I)
				   (
SETQ
 STACK NIL))
			     (CJUMP (ASM.STKADD
 -1)
				    (ASM.STK.JUMPTOLABEL
 I))
			     (NCJUMP (ASM.STK.JUMPTOLABEL
 I)
				     (ASM.STKADD
 -1))
			     (FNX (if
 (
AND
 (
EQ
 3 (
LENGTH
 I))
					       (ASM.RANGE?
 (
CADR
 I)
							     0 255))
				      then
 (ASM.STKADD
 (
IDIFFERENCE
 1 (
CADR
 I)))
				    else
 (ASM.ERR.FNXFORMAT
)))
			     (SUBRCALL (if
 (
AND
 (
EQ
 3 (
LENGTH
 I))
						    (ASM.RANGE?
 (
CADR
 I)
								  0 255))
					   then
 (ASM.STKADD
 (
IDIFFERENCE
 1 (
CADDR
 I)))
					 else
 (ASM.ERR.NILFORMAT
 2)))
			     (BIND (ASM.STKBIND.D
 I))
			     (UNBIND (ASM.STKUNBIND.D
 I 1))
			     (DUNBIND (ASM.STKUNBIND.D
 I 0))
			     [TUNBIND (
SELECTQ
 TAM.STACKSTYLE
						 (D (ASM.ERR.STACKSTYLE
))
						 (if
 (
EQ
 2 (
LENGTH
 I))
						     then
 (ASM.STKSET.T
 (
CADR
 I)
									    (
SELECTQ
 (
CAR
 I)
										       (UNBIND 1)
										       (DUNBIND
											 0)
										       (ASM.ERR

											 
								      "bad levadj-TUNBIND opcode"
											 I)))
						   else
 (ASM.ERR.JUMPFORMAT
]
			     (POP (if
 (
AND
 (
EQ
 2 (
LENGTH
 I))
					       (ASM.RANGE?
 (
CADR
 I)
							     0 255))
				      then
 (ASM.STKADD
 (
IMINUS
 (
CADR
 I)))
				    else
 (ASM.ERR.NILFORMAT
 1)))
			     (-X- NIL)
			     (if
 (
NUMBERP
 LEVADJ)
				 then
 (ASM.STKADD
 LEVADJ)
			       else
 (ASM.ERR
 "unknown LEVADJ" LEVADJ)))
	          (ASM.STKMAX
])

(ASM.STKGENCLEVADJ

  [LAMBDA (OP)                                               (* jmh " 9-Nov-85 14:20")


          (* * returns the LEVADJ for the generic OP if OP is the kind of thing that gets expanded only in phase 2 <ie 

	  variable-reference generic or jump generic> -- else returns NIL)



    (
SELECTQ
 OP
	       ((IVAR PVAR FVAR VAR)
		 1)
	       ((IVAR_ PVAR_ FVAR_ VAR_)
		 0)
	       ((IVAR_^
		   PVAR_^
		   FVAR_^
		   VAR_^)
		 -1)
	       (JUMP (
QUOTE
 JUMP))
	       ((FJUMP TJUMP)
		 (
QUOTE
 CJUMP))
	       ((NFJUMP NTJUMP)
		 (
QUOTE
 NCJUMP))
	       NIL])

(ASM.STKAPPLYFN.LEVADJ.D

  [LAMBDA NIL
                                                          (* jmh 
                                                                           " 4-Mar-86 19:05")

            
            (* * figure out the stack effect for this APPLYFN, if its number of 
            arguments is supplied with a SIC-like form --
            else guess stack effect -1, error, and abort stack modelling --ÿHÿdetection 
            of the SIC-like form is pretty ad-hoc)


    (DECLARE
 (USEDFREE TAM.STACKSTYLE OLT STKFAILURE?))
    (SELECTQ TAM.STACKSTYLE
        (D (LET ((OLTAIL (NLEFT (CAR OLT)
                                5)))
                (if
 [NOT (AND (EQ 5 (LENGTH OLTAIL))
                                  (EQUAL (CAR (CADDR OLTAIL))
                                         (QUOTE (* forT2D: CHECKAPPLY*)))
                                  (EQUAL (CAR (CADDDR OLTAIL))
                                         (QUOTE (CHECKAPPLY*]
                    then
 (SETQ OLTAIL (CDDR OLTAIL)))
                (if
 [AND (MEMB (CAR (CAR (CAR OLTAIL)))
                                   (QUOTE ('0 '1 SIC)))
                             (MEMB (CAR (CAR (CADR OLTAIL)))
                                   (QUOTE (IVAR PVAR FVAR GVAR ACONST COPY.N]
                    then
 (IDIFFERENCE -1 (SELECTQ (CAR (CAAR OLTAIL))
                                                 ('0 0)
                                                 ('1 1)
                                                 (SIC (CADR (CAAR OLTAIL)))
                                                 (SHOULDNT)))
                  else
 (SETQ STKFAILURE? T)
                        (ASM.ERR
 "cant figure stack effect of APPLYFN")
                        -1)))
        (ASM.ERR.STACKSTYLE
])
)
(DEFINEQ

(ASM.STK.PASSLABEL

  [LAMBDA (LABEL)
                                            (* jmh " 1-Apr-86 15:33")

          
          (* * attribute any new stack info from previous instr to the label --

          rebuild STACK from the label's stack info)

          
          (* * an \ASM.L2STACK entry has the same format as STACK: a list of 

          possible-stacks)


    (DECLARE
 (GLOBALVARS \ASM.L2STACK)
           (USEDFREE STACK STKPROGRESS?))
    (if
 (NULL LABEL)
        then
 (ASM.HELP
 "NIL label")
      else
 (LET ((LABELSTACK (GETHASH LABEL \ASM.L2STACK)))
                (if
 (LDIFFERENCE STACK LABELSTACK)
                    then
 (SETQ STKPROGRESS? T))
                (if
 (OR (LDIFFERENCE STACK LABELSTACK)
                        (LDIFFERENCE LABELSTACK STACK))
                    then
 (SETQ STACK (UNION STACK LABELSTACK))
                         (PUTHASH LABEL (COPYALL STACK)
                                \ASM.L2STACK])

(ASM.STK.JUMPTOLABEL

  [LAMBDA (INSTR)
                                                      (* jmh 
                                                                           "27-Feb-86 11:55")

            
            (* * handle jump-to -- check syntax of jump instr, attribute STACK to 
            label -- note if this is new information)


    (DECLARE
 (GLOBALVARS \ASM.L2STACK)
           (USEDFREE STACK STKPROGRESS?))
    (if
 [NOT (AND (LISTP INSTR)
                      (EQ 2 (LENGTH INSTR))
                      (NLISTP (CADR INSTR]
        then
 (ASM.ERR.JUMPFORMAT
)
      else
 (LET*((LABEL (CADR INSTR))
                     (LABELSTK (GETHASH LABEL \ASM.L2STACK)))
                (if
 (LDIFFERENCE STACK LABELSTK)
                    then
 (SETQ STKPROGRESS? T)
                          (PUTHASH LABEL (COPYALL (UNION LABELSTK STACK))
                                 \ASM.L2STACK])
)
(DEFINEQ

(ASM.STKMAX

  [LAMBDA NIL
                                                          (* jmh 
                                                                           " 4-Mar-86 19:05")

            
            (* * update MAXSTK if STACK warrants it)


    (DECLARE
 (USEDFREE TAM.STACKSTYLE MAXSTK STACK))
    (for
 S in
 STACK when
 S bind
 SDEPTH do
 (SETQ SDEPTH (SELECTQ TAM.STACKSTYLE
                                                                               (D (CAR S))
                                                                               S))
                                                             (if
 (IGREATERP SDEPTH MAXSTK)
                                                                 then
 (SETQ MAXSTK SDEPTH])

(ASM.STKADD

  [LAMBDA (DELTA)
                                                          (* jmh 
                                                                           "27-Mar-86 15:44")

            
            (* * apply straightforward numeric addition to stack position)


    (DECLARE
 (USEDFREE TAM.STACKSTYLE STACK))
    (for
 STAIL on
 STACK bind
 S
       do
 (if
 (SETQ S (CAR STAIL))
              then
 (RPLACA STAIL (SELECTQ TAM.STACKSTYLE
                                     (D (AND (ASM.STKOK?.D
 S (QUOTE <before>))
                                             (add
 (CAR S)
                                                  DELTA)
                                             (ASM.STKOK?.D
 S (QUOTE <after>))))
                                     (AND (ASM.STKOK?.T
 S (QUOTE <before>))
                                          (add
 S DELTA)
                                          (ASM.STKOK?.T
 S (QUOTE <after>])
)
(DEFINEQ

(ASM.STKBIND.D

  [LAMBDA (I)
                                                          (* jmh 
                                                                           " 4-Mar-86 19:05")

    (DECLARE
 (USEDFREE TAM.STACKSTYLE STACK))
    (SELECTQ TAM.STACKSTYLE
        (D (if
 [AND (EQ 3 (LENGTH I))
                        (OR (NULL (CADR I))
                            (LISTP (CADR I]
               then

               [for
 STAIL on
 STACK bind
 S
                  do
 (if
 (SETQ S (CAR STAIL))
                             then
 (RPLACA STAIL (AND (ASM.STKOK?.D
 S (QUOTE <before>))
                                                         [add
 (CAR S)
                                                                (ADD1 (IMINUS (LENGTH (CADR I]
                                                         (ASM.STKOK?.D
 S (QUOTE <afterAdjust>))
                                                         (push
 S (CAR S]
             else
 (ASM.ERR.BINDFORMAT
)))
        (ASM.ERR.STACKSTYLE
])

(ASM.STKUNBIND.D

  [LAMBDA (I NEXTRA)
    (DECLARE
 (USEDFREE TAM.STACKSTYLE STACK))
                      (* jmh 
                                                                           " 4-Mar-86 19:06")

    (SELECTQ TAM.STACKSTYLE
        (D [if
 (NEQ 1 (LENGTH I))
               then
 (ASM.ERR.NILFORMAT
 0)
             elseif
 [OR (NULL STACK)
                            (for
 S in
 STACK thereis
 (NULL S))
                            (for
 S in
 (CDR STACK) thereis
 (NEQ (LENGTH S)
                                                                           (LENGTH (CAR STACK]
               then
 (ASM.ERR
 "stack ambiguous wrt binding marks")
                     (SETQ STACK NIL)
             else
 (for
 STAIL on
 STACK bind
 S
                         do
 (if
 (SETQ S (CAR STAIL))
                                    then
 (RPLACA STAIL
                                                    (AND (ASM.STKOK?.D
 S (QUOTE <before>))
                                                         (if
 (IGEQ 1 (LENGTH S))
                                                             then
 (ASM.ERR
 "no binding mark"
                                                                             (COPY S))
                                                                   NIL
                                                           else
 S)
                                                         (if
 (ILESSP (IDIFFERENCE (CAR S)
                                                                                NEXTRA)
                                                                        (CADR S))
                                                             then
 (ASM.ERR
 
                                                                            "would lose binding mark"
                                                                             (COPY S))
                                                                   NIL
                                                           else
 S)
                                                         (pop
 S)
                                                         (add
 (CAR S)
                                                                (SUB1 NEXTRA))
                                                         (ASM.STKOK?.D
 S (QUOTE <after>])
        (ASM.ERR.STACKSTYLE
])

(ASM.STKOK?.D

  [LAMBDA (S WHEN)
                                                         (* jmh 
                                                                           "29-Mar-86 09:27")

            
            (* * D-machine-- if this individual non-NIL stack position is ok, return 
            it, else generate an error in the listing and return NIL)


    (DECLARE
 (USEDFREE TAM.STACKSTYLE))
    (SELECTQ TAM.STACKSTYLE
        (D (if
 [OR (NLISTP S)
                   (NOT (NUMBERP (CAR S]
               then
 (ASM.ERR
 "bad stack" WHEN (COPYALL S))
             elseif
 (AND (NOT (CDR S))
                         (MINUSP (CAR S)))
               then
 (ASM.ERR
 "stack underflow" (COPYALL S))
             elseif
 (AND (CDR S)
                         (ILESSP (CAR S)
                                (CADR S)))
               then
 (ASM.ERR
 "relative stack underflow" (COPYALL S))
             else
 S))
        (ASM.HELP
 "bad stack style" TAM.STACKSTYLE])
)
(DEFINEQ

(ASM.STKSET.T

  [LAMBDA (LABEL DELTA)                                      (* jmh "13-Jun-86 12:12")


          (* * T-machine-- force the stack)



    (DECLARE
 (
GLOBALVARS
 \ASM.L2STACK)
	       (
USEDFREE
 TAM.STACKSTYLE STACK))
    (
SELECTQ
 TAM.STACKSTYLE
	       (D (ASM.HELP
 "bad stack style" TAM.STACKSTYLE))
	       (LET [(NEWSTACK (if
 (
AND
 (
LISTP
 LABEL)
					    (
EQ
 1 (
LENGTH
 LABEL))
					    (
NUMBERP
 (
CAR
 LABEL)))
				   then
 LABEL
				 else
 (
GETHASH
 LABEL \ASM.L2STACK]
		    (if
 (
OR
 (
NULL
 NEWSTACK)
				(
NULL
 (
CAR
 NEWSTACK)))
			then
 (ASM.ERR.UNKNOWNSTACK
)
		      elseif
 (
NEQ
 1 (
LENGTH
 NEWSTACK))
			then
 (ASM.ERR.AMBIGSTACK
 NEWSTACK)
		      else
 [
SETQ
 STACK (
LIST
 (
IPLUS
 DELTA (
CAR
 NEWSTACK]
			     (ASM.STKOK?.T
 (
CAR
 STACK)
					     (
QUOTE
 <after>])

(ASM.STKOK?.T

  [LAMBDA (S WHEN)
                                                         (* jmh 
                                                                           "30-Mar-86 10:21")

            
            (* * T-machine-- if this individual non-NIL stack position is ok, return 
            it, else generate an error in the listing and return NIL)


    (DECLARE
 (USEDFREE TAM.STACKSTYLE TAM.MAXSTACK STACK INITTOS))
    (SELECTQ TAM.STACKSTYLE
        (D (ASM.HELP
 "bad stack style" TAM.STACKSTYLE))
        (if
 (NOT (NUMBERP S))
            then
 (ASM.HELP
 "bad stack" STACK)
          elseif
 (ILESSP S INITTOS)
            then
 (ASM.ERR
 "stack underflow" WHEN (COPYALL STACK))
          else
 S])
)
(* * code pass 2 -- on OLT -- do variable-reference generics <on Tamarin the choice of opcodes
 may depend on stack-max?> -- determine length of everything including jump generics -- also 
uses ASM.VARGENC2BL ASM.JUMPGENC2BL)


(DEFINEQ

(ASM.CODEPASS2
  [LAMBDA NIL                                                              (* jmh 
                                                                           "28-Jan-86 19:09")
    (DECLARE (USEDFREE LJL))
    (LET ((JGTUDOK? T)
          (MAXPASS 219)
          (MINPASS 200)
          JGTUD? JGCL?)
         (DECLARE (SPECVARS JGTUDOK? JGTUD? JGCL?))
            
            (* * JumpGenericTargetUnDefinedOK? -- JumpGenericTargetUnDefined? --
            JumpGenericChangedLength? -- LabelandJumpList is a list of Label or 
            <TailOfOLTthatStartsWithJumpGeneric PC length>)

         (ASM.PHASEMARK "system generics pass" 200)
         (ASM.ALLCODELENGTHS)
         (if JGTUD?
             then (SETQ LJL (REVERSE LJL))
                  (repeatuntil (OR JGTUD? (NOT JGCL?)) as PASS from (ADD1 MINPASS)
                     do (if (IGEQ PASS MAXPASS)
                            then (ASM.HELP "loop goes on & on"))
                        (ASM.PHASEMARK "finish jump generics" PASS)
                        (SETQ JGTUD? NIL)
                        (SETQ JGCL? NIL)
                        (ASM.REDOJGLENGTHS PASS])

(ASM.ALLCODELENGTHS
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \ASM.L2PC)
           (USEDFREE STARTPC MAXPC LJL))                                   (* jmh 
                                                                           "28-Jan-86 19:05")
    (LET ((PC STARTPC))
         [for IL on (ASM.OLTAFTERCODE:) bind I BL OPCODE
            do (SETQ I (ASM.TOPIC IL))
               (if (NLISTP I)
                   then                                                    (* label)
                        (if (NULL I)
                            then (ASM.ERR.NILLABEL)
                          elseif (GETHASH I \ASM.L2PC)
                            then (ASM.ERR.LABELREPEATED)
                          else (PUTHASH I (LIST PC NIL)
                                      \ASM.L2PC)
                               (push LJL I))
                 elseif (NOT (LITATOM (CAR I)))
                   then (ASM.ERR.NOTLITATOM)
                 elseif (EQ (CAR I)
                            (QUOTE *))
                   then                                                    (* comment)
                 elseif (SETQ BL (ASM.VARGENC2BL I))
                   then                                                    (* var ref genc)
                        (if (LISTP BL)
                            then (add PC (LENGTH BL)))
                 elseif (SETQ BL (ASM.JUMPGENC2BL I PC))
                   then                                                    (* jump genc)
                        (if (LISTP BL)
                            then (LET ((N (LENGTH BL)))
                                      (push LJL (LIST IL PC N))
                                      (add PC N)))
                 elseif (SETQ OPCODE (ASM.GETOPCODE (CAR I)))
                   then (add PC (ADD1 (fetch (OPCODE OPNARGS) of OPCODE]
         (SETQ MAXPC PC])

(ASM.REDOJGLENGTHS
  [LAMBDA (PASS)
    (DECLARE (GLOBALVARS \ASM.L2PC)
           (USEDFREE LJL JGCL? MAXPC))                                     (* jmh 
                                                                           "28-Jan-86 19:13")
    (LET ((DELTA 0))
         [for X in LJL bind BL N M OLDPC
            do (if (NLISTP X)
                   then (if (NEQ 0 DELTA)
                            then (if [NOT (SETQ N (CAR (GETHASH X \ASM.L2PC]
                                     then (ASM.HELP "lost label" X)
                                   else (PUTHASH X (LIST (IPLUS DELTA N)
                                                         PASS)
                                               \ASM.L2PC)))
                 else (SETQ OLDPC (CADR X))
                      [if (NEQ 0 DELTA)
                          then (RPLACA (CDR X)
                                      (IPLUS DELTA (CADR X]
                      (SETQ BL (ASM.JUMPGENC2BL (ASM.TOPIC (CAR X))
                                      (CADR X)
                                      (CADDR X)
                                      PASS DELTA))
                      (if (NULL BL)
                          then (ASM.HELP "lost jump genericness" (CAAR X))
                        else (SETQ N (if (LISTP BL)
                                         then (LENGTH BL)
                                       else 0))
                             (if (NEQ N (CADDR X))
                                 then (SETQ M (IDIFFERENCE N (CADDR X)))
                                      (if (MINUSP M)
                                          then (ASM.HELP "jump genc got shorter" (LIST N (CADDR
                                                                                          X)))
                                        else (SETQ JGCL? T)
                                             (RPLACA (CDDR X)
                                                    N)
                                             (add DELTA M]
         (add MAXPC DELTA])
)
(* * emit header and name tables)


(DEFINEQ

(ASM.MAKECODEARRAY

  [LAMBDA NIL
    (DECLARE
 (USEDFREE TAM.OUTPUTSTYLE MAXPC CODEARRAY))
           (* jmh 
                                                                           " 4-Mar-86 18:46")

    (SETQ CODEARRAY (SELECTQ TAM.OUTPUTSTYLE
                        (D (LET ((REALSIZE (CEIL MAXPC BYTESPERQUAD))
                                 (ONPAGE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL))
                                               CELLSPERQUAD)))
                                (\CODEARRAY REALSIZE ONPAGE)))
                        (B (LET ((REALSIZE (CEIL MAXPC BYTESPERQUAD)))
                                (ARRAY REALSIZE (QUOTE BYTE)
                                       0 0 8)))
                        (ASM.HELP
 "bad outputStyle" TAM.OUTPUTSTYLE])

(ASM.EMITHDR+NTS

  [LAMBDA NIL
    (DECLARE
 (USEDFREE TAM.FNHDRSTYLE))
                            (* jmh 
                                                                           " 4-Mar-86 18:48")

    (ASM.PHASEMARK
 "emit hdr+nts" 300)
    (SELECTQ TAM.FNHDRSTYLE
        (D (ASM.EMITHDR+NTS.D
))
        (ASM.EMITHDR+NTS.T
])
)
(DEFINEQ

(ASM.EMITHDR+NTS.D

  [LAMBDA NIL
    (DECLARE
 (USEDFREE TAM.OUTPUTSTYLE TAM.NTSTYLE)
           (USEDFREE CODEARRAY MAXPC NTVARS LTVARS)
           (USEDFREE FNTYPE FNNAME STKMIN PV STARTPC NTSIZE NLOCALS FVAROFFSET))

                                                                           (* jmh 
                                                                           "13-Mar-86 10:35")

    (if
 (NEQ TAM.OUTPUTSTYLE (QUOTE D))
        then
 (ASM.HELP
 "bad outputStyle" TAM.OUTPUTSTYLE))
    (if
 (NEQ TAM.NTSTYLE (QUOTE D))
        then
 (ASM.HELP
 "bad nametable style with outputstyle=D" TAM.NTSTYLE))
    (LET [(ARGTYPE (SELECTQ FNTYPE
                       ([LAMBDA NIL] 
                            0)
                       (NLAMBDA 1)
                       (LAMBDA* 2)
                       (NLAMBDA* 3)
                       (ASM.HELP
 "bad fntype" FNTYPE]
         (replace
 (CODEARRAY STKMIN) of
 CODEARRAY with
 STKMIN)
         (replace
 (CODEARRAY PV) of
 CODEARRAY with
 PV)
         (replace
 (CODEARRAY STARTPC) of
 CODEARRAY with
 STARTPC)
         (replace
 (CODEARRAY NTSIZE) of
 CODEARRAY with
 NTSIZE)
         (replace
 (CODEARRAY NLOCALS) of
 CODEARRAY with
 NLOCALS)
         (replace
 (CODEARRAY FVAROFFSET) of
 CODEARRAY with
 FVAROFFSET)
         (replace
 (CODEARRAY NA) of
 CODEARRAY with
 (ASM.NA.D
))
         (replace
 (CODEARRAY ARGTYPE) of
 CODEARRAY with
 ARGTYPE)
         (replace
 (CODEARRAY FRAMENAME) of
 CODEARRAY with
 FNNAME)
         (ASM.EMITANNT
 (fetch
 (CODEARRAY OVERHEADWORDS) of
 T)
                NTVARS 4)
         (ASM.EMITANNT
 (IPLUS (fetch
 (CODEARRAY OVERHEADWORDS) of
 T)
                                  (ITIMES (if
 (ZEROP NTSIZE)
                                              then
 2
                                            else
 NTSIZE)
                                         2))
                LTVARS 2])
)
(DEFINEQ

(ASM.EMITHDR+NTS.T

  [LAMBDA NIL
    (DECLARE
 (
USEDFREE
 TAM.NTSTYLE)
	       (
USEDFREE
 CODEARRAY NTVARS LTVARS)
	       (
USEDFREE
 FNNAME STARTPC INITTOS NTSIZE NLOCALS FVAROFFSET)
	       (
GLOBALVARS
 \ASM.L2PC))                     (* jmh "13-Jun-86 10:36")

    (LET ((FNHDR (
ARRAYBASEPTR
 CODEARRAY))
	  (OVERHEADWORDS (UNFOLD (
PLUS
 (fetch
 (TFNHDR OVERHEADCELLS) of
 T)
					 (
PROG1
 8          (* for entry vector)
))
				 WORDSPERCELL)))

          (* * fn hdr proper -- already 0'ed -- the fields OBJECTHEADERCELL OBJECTSIZE NAMETABLE CODEBASE are not initialized

	  until loaded to Tamarin)



         (replace
 (TFNHDR FRAMENAME) of
 FNHDR with
 FNNAME)
         (replace
 (TFNHDR NTSIZE) of
 FNHDR with
 NTSIZE)
         (replace
 (TFNHDR NLOCALS) of
 FNHDR with
 NLOCALS)
         (replace
 (TFNHDR FVAROFFSET) of
 FNHDR with
 FVAROFFSET)
         (replace
 (TFNHDR MAXVAR) of
 FNHDR with
 INITTOS)
         (replace
 (TFNHDR PC) of
 FNHDR with
 STARTPC)
         (replace
 (TFNHDR SP) of
 FNHDR with
 INITTOS)

          (* * entry vector -- entry pc for FNi is: if label ENTRYi is defined, then that, elseif label ENTRY is defined, 

	  then that, else STARTPC)



         [LET (X DEFENTRYPC)
	      (
SETQ
 X (
GETHASH
 (
QUOTE
 ENTRY)
				   \ASM.L2PC))
	      (
SETQ
 DEFENTRYPC (if
 X
				     then
 (
CAR
 X)
				   else
 STARTPC))
	      (for
 I from
 0 to
 7
		 do
 (
SETQ
 X (
GETHASH
 (
PACK*
 (
QUOTE
 ENTRY)
						    I)
					   \ASM.L2PC))
		      (
TFNHDR.EVN
 FNHDR I (if
 X
						then
 (
CAR
 X)
					      else
 DEFENTRYPC]

          (* * name tables -- for now just like D)



         (if
 (
NEQ
 TAM.NTSTYLE (
QUOTE
 D))
	     then
 (ASM.HELP
 "don`t know nametable style" TAM.NTSTYLE))
         (ASM.EMITANNT
 OVERHEADWORDS NTVARS 4)
         (ASM.EMITANNT
 (
IPLUS
 OVERHEADWORDS (
ITIMES
 (if
 (
ZEROP
 NTSIZE)
							      then
 2
							    else
 NTSIZE)
							  2))
			 LTVARS 2])
)
(DEFINEQ

(ASM.EMITANNT

  [LAMBDA (W VANDSLIST GRANULE)
    (DECLARE
 (USEDFREE IVARS PVARS FVARS))
                         (* jmh 
                                                                           "13-Mar-86 13:21")

    (LET ((NTSIZE (ASM.CEIL
 (ADD1 (LENGTH VANDSLIST))
                         GRANULE)))
         (SETQ W (ASM.EMITPARTOFANNT
 W NTSIZE PVARCODE (INTERSECTION VANDSLIST PVARS)))
         (SETQ W (ASM.EMITPARTOFANNT
 W NTSIZE IVARCODE (INTERSECTION VANDSLIST IVARS)))
         (ASM.EMITPARTOFANNT
 W NTSIZE FVARCODE (INTERSECTION VANDSLIST FVARS])

(ASM.EMITPARTOFANNT

  [LAMBDA (W NTSIZE VARTYPECODE VANDSLIST)                   (* jmh " 8-Dec-85 13:24")


          (* * returns incremented W)



    (DECLARE
 (
USEDFREE
 CODEARRAY))
    (for
 VANDS in
 VANDSLIST
       do
 [CODESETA2 CODEARRAY (UNFOLD W BYTESPERWORD)
		       (\ATOMPNAMEINDEX (if
 (
LITATOM
 (
CAR
 VANDS))
					    then
 (
CAR
 VANDS)
					  else
 (
CAAR
 VANDS]
	    (CODESETA2 CODEARRAY (UNFOLD (
IPLUS
 W NTSIZE)
					 BYTESPERWORD)
		       (
IPLUS
 VARTYPECODE (
CDR
 VANDS)))
	    (add
 W 1))
    W])
)
(DEFINEQ

(ASM.PUTB

  [LAMBDA (PC B)
    (DECLARE
 (USEDFREE CODEARRAY TAM.OUTPUTSTYLE))
                 (* jmh 
                                                                           " 4-Mar-86 18:46")

    (SELECTQ TAM.OUTPUTSTYLE
        (D (CODESETA CODEARRAY PC B))
        (B (SETA CODEARRAY PC B))
        (ASM.HELP
 "don't know outputStyle" TAM.OUTPUTSTYLE])
)
(* * code pass 3 -- on OLT emitting to CODEARRAY -- final syntax checking and emit byte code)


(DEFINEQ

(ASM.EMITCODE

  [LAMBDA NIL
    (DECLARE
 (USEDFREE STARTPC MAXPC LJL))
                         (* jmh 
                                                                           "26-Feb-86 12:50")

    (LET ((PC STARTPC)
          (JGTUDOK? NIL)
          JGTUD?)
         (DECLARE
 (SPECVARS PC JGTUDOK? JGTUD?))
            
            (* * JumpGenericTargetUnDefinedOK? --
            JumpGenericTargetUnDefined?)


         (ASM.PHASEMARK
 "emit code" 400)
         [for
 IL on
 (ASM.OLTAFTERCODE:
) bind
 I BL
            do
 (SETQ I (ASM.TOPIC
 IL))
                  (if
 (NLISTP I)
                      then
                                             (* label)

                            (if
 (NULL I)
                                then
 (ASM.ERR.NILLABEL
))
                    elseif
 (NOT (LITATOM (CAR I)))
                      then
 (ASM.ERR.NOTLITATOM
)
                    elseif
 (EQ (CAR I)
                                   (QUOTE *))
                      then
                                             (* comment)

                    elseif
 (SETQ BL (ASM.VARGENC2BL
 I))
                      then
                                             (* var generic)

                            (if
 (LISTP BL)
                                then
 (ASM.EMITBL
 BL))
                    else
 (while
 (AND LJL (NLISTP (CAR LJL))) do
 (pop
 LJL))
                          (if
 (AND LJL (EQ IL (CAAR LJL)))
                              then
                                     (* jump generic)

                                    (SETQ BL (ASM.JUMPGENC2BL
 I PC (CADDAR LJL)))
                                    (if
 (LISTP BL)
                                        then
 (ASM.EMITBL
 BL))
                                    (pop
 LJL)
                            else
                                       (* vanilla opcode or 
                                                                           trash)

                                  (ASM.EMITINSTR
 I]
         (if
 (EQ MAXPC (ADD1 STARTPC))
             then
 (ASM.ERR
 "no function body output"))
         (if
 (IGREATERP PC MAXPC)
             then
 (ASM.HELP
 "code got larger in last pass" (LIST PC MAXPC])

(ASM.EMITINSTR

  [LAMBDA (I)
    (DECLARE
 (
USEDFREE
 PC IVARS PVARS FVARS TAM.STACKSTYLE TAM.JUMPSTYLE))
                                                             (* jmh "22-May-86 16:59")

    (LET [(OPCODE (ASM.GETOPCODE
 (
CAR
 I]
         (if
 (
NOT
 OPCODE)
	     then
 (ASM.ERR.NOOPCODE
)
	   else
 (LET ((OPNR (fetch
 (OPCODE OP#) of
 OPCODE))
			(OPNARGS (fetch
 (OPCODE OPNARGS) of
 OPCODE))
			(OPPRINT (fetch
 (OPCODE OPPRINT) of
 OPCODE)))
		       (DECLARE
 (
SPECVARS
 OPPRINT))
		       (
SELECTQ
 OPPRINT
				  ((NIL T)
				    (
SELECTQ
 (
CAR
 I)
					       (BIND (
SELECTQ
 TAM.STACKSTYLE
								(D (ASM.EMITBIND.D
 OPNR OPNARGS I))
								(ASM.ERR.STACKSTYLE
)))
					       ((UNBIND DUNBIND)
						 (
SELECTQ
 TAM.STACKSTYLE
							    (D (ASM.EMITXBITS.N.FD
 OPNR OPNARGS I))
							    (ASM.EMITUNBIND.T
 OPNR OPNARGS I)))
					       ((GETBITS.N.FD PUTBITS.N.FD)
						 (ASM.EMITXBITS.N.FD
 OPNR OPNARGS I))
					       (ASM.EMITVANILLAINSTR
 OPNR OPNARGS I)))
				  (SIC (ASM.CKOPNARGS
 OPNARGS 1)
				       (ASM.EMITVANILLAINSTR
 OPNR OPNARGS I))
				  [SNIC (ASM.CKOPNARGS
 OPNARGS 1)
					(if
 (
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
							    (ASM.RANGE?
 (
CADR
 I)
									  -256 -1)))
					    then
 (ASM.ERR.NILFORMAT
 1)
						   (add
 PC 2)
					  else
 (ASM.EMITB
 OPNR)
						 (ASM.EMITB
 (
LOGAND
 255 (
CADR
 I]
				  (SICX (ASM.CKOPNARGS
 OPNARGS 2)
					(if
 (
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
							    (ASM.RANGE?
 (
CADR
 I)
									  0 65535)))
					    then
 (ASM.ERR
 "should have 1 arg 0..65535")
						   (add
 PC 3)
					  else
 (ASM.EMITB
 OPNR)
						 (ASM.EMITBS
 (
CADR
 I)
							       2)))
				  (GCONST (ASM.CKOPNARGS
 OPNARGS 3)
					  (if
 (
NOT
 (
EQ
 2 (
LENGTH
 I)))
					      then
 (ASM.ERR
 "should have 1 arg")
						     (add
 PC 4)
					    else
 (ASM.EMITB
 OPNR)
						   (ASM.EMITB
 (
\HILOC
 (
CADR
 I)))
						   (ASM.EMITBS
 (
\LOLOC
 (
CADR
 I))
								 2)))
				  (ICONST (ASM.CKOPNARGS
 OPNARGS 4)
					  (if
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I]
					      then
 (ASM.ERR
 "should have 1 arg, a number")
						     (add
 PC 5)
					    else
 (ASM.EMITB
 OPNR)
						   (ASM.EMITBS
 (
LOGAND
 (MASK.1'S 0 32)
									   (
CADR
 I))
								 4)))
				  [PCONST (ASM.CKOPNARGS
 OPNARGS 4)
					  (if
 (
NOT
 (
EQ
 2 (
LENGTH
 I)))
					      then
 (ASM.ERR
 "should have 1 arg")
						     (add
 PC 5)
					    else
 (ASM.EMITB
 OPNR)
						   (ASM.EMITPCONST
 (
CADR
 I]
				  (TYPEP (ASM.EMITTYPEP
 OPNR OPNARGS I))
				  ((
ATOM
 FN)
				    (if
 (
NEQ
 OPNARGS 3)
					then
 (ASM.CKOPNARGS
 OPNARGS 2))
				    (if
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
							(
LITATOM
 (
CADR
 I]
					then
 (ASM.ERR
 "should have 1 arg, an atom")
					       (add
 PC 3)
				      else
 (ASM.EMITB
 OPNR)
					     (ASM.EMITATOMINDEX
 (
CADR
 I)
								  OPNARGS)))
				  (FNX (ASM.CKOPNARGS
 OPNARGS 3)
				       (if
 [
NOT
 (
AND
 (
EQ
 3 (
LENGTH
 I))
							   (ASM.RANGE?
 (
CADR
 I)
									 0 255)
							   (
LITATOM
 (
CADDR
 I]
					   then
 (ASM.ERR
 
							"should have 1 arg 0..255 and 1 atom arg")
						  (add
 PC 4)
					 else
 (ASM.EMITB
 OPNR)
						(ASM.EMITB
 (
CADR
 I))
						(ASM.EMITATOMINDEX
 (
CADDR
 I)
								     2)))
				  (SUBRCALL (ASM.CKOPNARGS
 OPNARGS 2)
					    (ASM.EMITVANILLAINSTR
 OPNR OPNARGS I))
				  (IVAR (ASM.EMITXVAR
 OPNR OPNARGS I IVARS (
QUOTE
 IVAR)))
				  ((PVAR VAR)
				    (ASM.EMITXVAR
 OPNR OPNARGS I PVARS (
QUOTE
 PVAR)))
				  (FVAR (ASM.EMITXVAR
 OPNR OPNARGS I FVARS (
QUOTE
 FVAR)))
				  (
RETURN
 (ASM.EMITVANILLAINSTR
 OPNR OPNARGS I))
				  ((JUMP JUMPX JUMPXX NEGJUMP)
				    (
SELECTQ
 TAM.JUMPSTYLE
					       (D (ASM.EMITJUMP.D
 OPNR OPNARGS I PC))
					       (ASM.EMITJUMP.T
 OPNR OPNARGS I PC)))
				  (if
 (
LISTP
 OPPRINT)
				      then
 (ASM.CKOPNARGS
 OPNARGS 1)
					     [if
 (
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
								 (
CADR
 I)))
						 then
 (ASM.ERR
 "should have 1 arg, a subopcode")
							(add
 PC 2)
					       else
 (LET [(ALPHA (if
 (
NUMBERP
 (
CADR
 I))
								     else
 (ASM.POSINLIST

									      (
CADR
 I)
									      OPPRINT]
						           (if
 (
NOT
 ALPHA)
							       then
 (ASM.ERR
 "subopcode not in" 
										 OPPRINT)
								      (add
 PC 2)
							     else
 (ASM.EMITB
 OPNR)
								    (ASM.EMITB
 ALPHA]
				    else
 (ASM.HELP
 "bad OPPRINT" OPPRINT])
)
(DEFINEQ

(ASM.EMITVANILLAINSTR

  [LAMBDA (OPNR OPNARGS I)                                   (* jmh "16-May-86 15:18")

    (DECLARE
 (
USEDFREE
 PC TAM.OPCODEPROPS))
    (LET ((ARGS (
CDR
 I)))
         (if
 (
LISTP
 OPNR)
	     then
 (LET ((OPKARGRANGE (ASM.OPKARGRANGE
 OPNR)))
		         [if
 (
OR
 (
NOT
 (
NUMBERP
 (
CAR
 ARGS)))
				     (
LESSP
 (
CAR
 ARGS)
					      (
CAR
 OPKARGRANGE))
				     (
GREATERP
 (
CAR
 ARGS)
						 (
CADR
 OPKARGRANGE)))
			     then
 (ASM.ERR
 "should have 1st arg in range" OPKARGRANGE)
				    (ASM.EMITB
 (
CAR
 OPNR))
			   else
 (ASM.EMITB
 (ASM.MAKEOPKBYTE
 OPNR (
CAR
 ARGS]
		         (pop
 ARGS))
	   else
 (ASM.EMITB
 OPNR))
         (if
 [
OR
 (
NEQ
 OPNARGS (
LENGTH
 ARGS))
		     (for
 ARG in
 ARGS thereis
 (
NOT
 (ASM.RANGE?
 ARG 0 255]
	     then
 (ASM.ERR.NILFORMAT
 OPNARGS)
		    (add
 PC OPNARGS)
	   else
 (for
 ARG in
 ARGS do
 (ASM.EMITB
 ARG])

(ASM.EMITBIND.D

  [LAMBDA (OPNR OPNARGS I)
    (DECLARE
 (USEDFREE PVARS PC))
                                  (* jmh 
                                                                           "11-Nov-85 19:45")

    (LET (SLOTNR)
         (ASM.CKOPNARGS
 OPNARGS 2)
         (if
 [NOT (AND (EQ 3 (LENGTH I))
                           (OR (NULL (CADR I))
                               (LISTP (CADR I)))
                           (OR (NULL (CADDR I))
                               (LISTP (CADDR I]
             then
 (ASM.ERR.BINDFORMAT
)
                   (add
 PC 3)
           elseif
 (AND (NULL (CADR I))
                           (NULL (CADDR I)))
             then
 (ASM.EMITB
 OPNR)
                   (ASM.EMITB
 0)
                   (ASM.EMITB
 0)
           elseif
 (AND (EQ 1 (LENGTH (CADR I)))
                           (SETQ SLOTNR (ASM.VARLKUP
 (CAADR I)
                                               PVARS))
                           (NULL (CADDR I)))
             then
 (ASM.EMITB
 OPNR)
                   (ASM.EMITB
 1)
                   (ASM.EMITB
 SLOTNR)
           elseif
 (AND (NULL (CADR I))
                           (EQ 1 (LENGTH (CADDR I)))
                           (SETQ SLOTNR (ASM.VARLKUP
 (CAADDR I)
                                               PVARS)))
             then
 (ASM.EMITB
 OPNR)
                   (ASM.EMITB
 16)
                   (ASM.EMITB
 SLOTNR)
           else
 (ASM.ERR
 "can only BIND 0 or 1 pvar -- sorry!")
                 (add
 PC 3])

(ASM.EMITUNBIND.T

  [LAMBDA (OPNR OPNARGS I)                                   (* jmh "13-Jun-86 12:16")

    (DECLARE
 (
GLOBALVARS
 \ASM.L2STACK))
    (ASM.CKOPNARGS
 OPNARGS 1)
    (if
 (
NOT
 (
EQ
 2 (
LENGTH
 I)))
	then
 (ASM.ERR.JUMPFORMAT
)
      else
 (LET* [(LABEL (
CADR
 I))
		    (STACK (if
 (
AND
 (
LISTP
 LABEL)
					(
EQ
 1 (
LENGTH
 LABEL))
					(
NUMBERP
 (
CAR
 LABEL)))
			       then
 LABEL
			     else
 (
GETHASH
 LABEL \ASM.L2STACK]
	           (if
 (
NULL
 STACK)
		       then
 (ASM.ERR.UNKNOWNSTACK
)
		     elseif
 (
NEQ
 1 (
LENGTH
 STACK))
		       then
 (ASM.ERR.AMBIGSTACK
)
		     else
 (ASM.EMITB
 OPNR)
			    (ASM.EMITB
 (
IPLUS
 (
CAR
 STACK)
						  (
SELECTQ
 (
CAR
 I)
							     (UNBIND 1)
							     (DUNBIND 0)
							     (ASM.ERR
 "bad T-unbind opcode" I])

(ASM.EMITXBITS.N.FD

  [LAMBDA (OPNR OPNARGS I)
    (DECLARE
 (
USEDFREE
 PC))                              (* jmh "10-Nov-85 17:18")

    (ASM.CKOPNARGS
 OPNARGS 2)
    (if
 (
NOT
 (
AND
 (
EQ
 4 (
LENGTH
 I))
			(ASM.RANGE?
 (
CADR
 I)
				      0 255)
			(ASM.RANGE?
 (
CADDR
 I)
				      0 15)
			(ASM.RANGE?
 (
CADDDR
 I)
				      1 16)))
	then
 (ASM.ERR
 "should have 3 args: 0..255 0..15 1..16")
	       (add
 PC 3)
      else
 (ASM.EMITB
 OPNR)
	     (ASM.EMITB
 (
CADR
 I))
	     (ASM.EMITB
 (
LOGOR
 (
LLSH
 (
CADDR
 I)
					   4)
				   (
SUB1
 (
CADDDR
 I])

(ASM.EMITTYPEP

  [LAMBDA (OPNR OPNARGS I)
                                             (* jmh 
                                                                           "26-Feb-86 12:58")

    (DECLARE
 (USEDFREE PC))
    (ASM.CKOPNARGS
 OPNARGS 1)
    (LET [(ALPHA (if
 (NEQ 2 (LENGTH I))
                     then
 NIL
                   elseif
 (ASM.RANGE?
 (CADR I)
                                     0 255)
                   else
 (SELECTQ (CADR I)
                                (ARRAYP \ARRAYP)
                                (STRINGP \STRINGP)
                                (FLOATP \FLOATP)
                                (SMALLP \SMALLP)
                                (STACKP \STACKP)
                                (FIXP \FIXP)
                                (LITATOM \LITATOM)
                                NIL]
         (if
 (NOT ALPHA)
             then
 (ASM.ERR
 "should have 1 arg, a typename or a 0..255")
                   (add
 PC 2)
           else
 (ASM.EMITB
 OPNR)
                 (ASM.EMITB
 ALPHA])

(ASM.EMITXVAR

  [LAMBDA (OPNR OPNARGS I VARLIST VARTYPE)                   (* jmh "16-May-86 15:22")

    (DECLARE
 (
USEDFREE
 PC TAM.VARXSTYLE))
    (LET (SLOTNR)
         (if
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
			     (
SETQ
 SLOTNR (
OR
 (
NUMBERP
 (
CADR
 I))
						  (ASM.VARLKUP
 (
CADR
 I)
								 VARLIST]
	     then
 (ASM.ERR
 "should have 1 arg, # or" VARTYPE)
		    (add
 PC OPNARGS 1)
	   elseif
 (
EQ
 0 OPNARGS)
	     then
 [LET ((RANGE (ASM.OPKARGRANGE
 OPNR)))
		         (if
 (
OR
 (
ILESSP
 SLOTNR (
CAR
 RANGE))
				     (
IGREATERP
 SLOTNR (
CADR
 RANGE)))
			     then
 (ASM.ERR
 "slot# out of range" SLOTNR RANGE)
				    (ASM.EMITB
 (
CAR
 OPNR))
			   else
 (ASM.EMITB
 (ASM.MAKEOPKBYTE
 OPNR SLOTNR]
	   else
 (ASM.EMITB
 OPNR)
		  (ASM.EMITB
 (
SELECTQ
 TAM.VARXSTYLE
					  (D (
LLSH
 SLOTNR 1))
					  SLOTNR])

(ASM.EMITJUMP.D

  [LAMBDA (OPNR OPNARGS I PC)
    (DECLARE
 (
GLOBALVARS
 \ASM.L2PC)
	       (
USEDFREE
 TAM.JUMPSTYLE))                   (* jmh "23-May-86 10:37")

    (LET (TARGET DELTA)
         (if
 (
NEQ
 TAM.JUMPSTYLE (
QUOTE
 D))
	     then
 (ASM.HELP
 "asm.emitjump.d bad tam.jumpstyle" TAM.JUMPSTYLE)
	   elseif
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
				  (
CADR
 I)
				  (
NLISTP
 (
CADR
 I]
	     then
 (ASM.ERR.JUMPFORMAT
)
		    (add
 PC OPNARGS 1)
	   elseif
 [
NOT
 (
SETQ
 TARGET (
CAR
 (
GETHASH
 (
CADR
 I)
							    \ASM.L2PC]
	     then
 (ASM.ERR.LABELUNDEF
)
		    (add
 PC OPNARGS 1)
	   else
 (
SETQ
 DELTA (
IDIFFERENCE
 TARGET PC))
		  (
SELECTQ
 OPNARGS
			     [0 (LET ((DELTAADJ (
IDIFFERENCE
 DELTA 2))
				      (RANGE (ASM.OPKARGRANGE
 OPNR)))
				     (if
 (
NOT
 (ASM.RANGE?
 DELTAADJ (
CAR
 RANGE)
								(
CADR
 RANGE)))
					 then
 (ASM.ERR
 "adj delta out of range:" DELTAADJ RANGE)
						(ASM.EMITB
 (
CAR
 OPNR))
				       else
 (ASM.EMITB
 (ASM.MAKEOPKBYTE
 OPNR DELTAADJ]
			     (1 (if
 (
NOT
 (ASM.RANGE?
 DELTA -128 127))
				    then
 (ASM.ERR
 "adj delta too big for one byte" DELTA)
					   (add
 PC 2)
				  else
 (ASM.EMITB
 OPNR)
					 (ASM.EMITB
 DELTA)))
			     (if
 (ASM.RANGE?
 DELTA -32768 32767)
				 then
 (ASM.EMITB
 OPNR)
					(ASM.EMITBS
 (
LOGAND
 65535 DELTA)
						      2)
			       else
 (ASM.ERR
 "adj delta too big for two bytes" DELTA)
				      (add
 PC 3])

(ASM.EMITJUMP.T

  [LAMBDA (OPNR OPNARGS I PC)
    (DECLARE
 (
GLOBALVARS
 \ASM.L2PC)
	       (
USEDFREE
 OPPRINT TAM.JUMPSTYLE))           (* jmh "23-May-86 10:39")

    (LET (TARGET DELTAADJ)
         (if
 TAM.JUMPSTYLE
	     then
 (ASM.HELP
 "asm.emitjump.t bad tam.jumpstyle" TAM.JUMPSTYLE)
	   else
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 I))
				(
CADR
 I)
				(
NLISTP
 (
CADR
 I]
	     then
 (ASM.ERR.JUMPFORMAT
)
		    (add
 PC OPNARGS 1)
	   elseif
 [
NOT
 (
SETQ
 TARGET (
CAR
 (
GETHASH
 (
CADR
 I)
							    \ASM.L2PC]
	     then
 (ASM.ERR.LABELUNDEF
)
		    (add
 PC OPNARGS 1)
	   else
 (
SETQ
 DELTAADJ (
IDIFFERENCE
 (
IDIFFERENCE
 TARGET PC)
						  OPNARGS))
		  (if
 (
EQ
 OPPRINT (
QUOTE
 NEGJUMP))
		      then
 (
SETQ
 DELTAADJ (
MINUS
 DELTAADJ)))
		  (
SELECTQ
 OPNARGS
			     [0 (LET (RANGE (ASM.OPKARGRANGE
 OPNR))
				     (if
 (
NOT
 (ASM.RANGE?
 DELTAADJ (
CAR
 RANGE)
								(
CADR
 RANGE)))
					 then
 (ASM.ERR
 "adj delta out of range:" DELTAADJ RANGE)
						(ASM.EMITB
 (
CAR
 OPNR))
				       else
 (ASM.EMITB
 (ASM.MAKEOPKBYTE
 OPNR DELTAADJ]
			     (1 (if
 (
NOT
 (ASM.RANGE?
 DELTAADJ 0 255))
				    then
 (ASM.ERR
 "adj delta out of range for one byte" DELTAADJ)
					   (add
 PC 2)
				  else
 (ASM.EMITB
 OPNR)
					 (ASM.EMITB
 DELTAADJ)))
			     (if
 (ASM.RANGE?
 DELTAADJ 0 65535)
				 then
 (ASM.EMITB
 OPNR)
					(ASM.EMITBS
 DELTAADJ 2)
			       else
 (ASM.ERR
 "adj delta out of range for two bytes" DELTAADJ)
				      (add
 PC 3])
)
(DEFINEQ

(ASM.EMITB

  [LAMBDA (B)
    (DECLARE
 (USEDFREE PC))
                                        (* jmh 
                                                                           "26-Feb-86 12:59")

    (if
 (NOT (ASM.RANGE?
 B 0 255))
        then
 (ASM.HELP
 "byte not 0..255" B))
    (ASM.PUTB
 PC B)
    (add
 PC 1])

(ASM.EMITBS

  [LAMBDA (X NB)
    (DECLARE
 (USEDFREE TAM.ALPHASTYLE))
                            (* jmh 
                                                                           "13-Mar-86 12:39")

    (if
 (NOT (ASM.RANGE?
 NB 1 (SELECTQ TAM.ALPHASTYLE
                                          (D 3)
                                          5)))
        then
 (ASM.HELP
 "#bytes too big" NB))
    (if
 [NOT (ASM.RANGE?
 X 0 (SUB1 (LSH 1 (ITIMES 10Q NB]
        then
 (ASM.ERR
 "# too big for #bytes" X NB)
      else
 (SELECTQ TAM.ALPHASTYLE
                   (D [for
 S from
 (ITIMES 10Q (SUB1 NB)) to
 0 by
 -10Q
                         do
 (ASM.EMITB
 (LOGAND 377Q (RSH X S])
                   (for
 S from
 0 to
 (ITIMES 10Q (SUB1 NB)) by
 10Q
                      do
 (ASM.EMITB
 (LOGAND 377Q (RSH X S])

(ASM.EMITBL

  [LAMBDA (BL)                                               (* jmh "12-Nov-85 13:30")

    (if
 (
LISTP
 BL)
	then
 (for
 B in
 BL do
 (ASM.EMITB
 B))
      else
 (ASM.HELP
 "arg not list" BL])

(ASM.EMITATOMINDEX

  [LAMBDA (
ATOM
 NRBYTES)                                   (* jmh "19-May-86 17:28")

    (DECLARE
 (
USEDFREE
 TAM.LINKINFO LINKINFO PC))
    (
SELECTQ
 TAM.LINKINFO
	       (T (push
 LINKINFO (
LIST
 ATOM NRBYTES PC)))
	       NIL)
    (ASM.EMITBS
 (\ATOMPNAMEINDEX ATOM)
		  NRBYTES])

(ASM.EMITPCONST

  [LAMBDA (X)
    (DECLARE
 (
USEDFREE
 TAM.LINKINFO LINKINFO PC))        (* jmh "19-May-86 18:39")

    (
SELECTQ
 TAM.LINKINFO
	       (T (push
 LINKINFO (
LIST
 X 4 PC)))
	       NIL)
    (ASM.EMITBS
 (
\LOLOC
 X)
		  2)
    (ASM.EMITB
 (
\HILOC
 X))
    (ASM.EMITB
 0])
)
(DEFINEQ

(ASM.VARGENC2BL

  [LAMBDA (INSTR)
                                                      (* jmh 
                                                                           "27-Feb-86 09:31")

            
            (* * returns <1> NIL if not a variable reference generic else <2> a list 
            of byte codes unless illformed, in which case <3> returns T after 
            declaring the error)


    (LET ((VARTYPE (SELECTQ (CAR INSTR)
                       ((IVAR IVAR_ IVAR_^) 
                            (QUOTE IVAR))
                       ((PVAR PVAR_ PVAR_^) 
                            (QUOTE PVAR))
                       ((VAR VAR_ VAR_^) 
                            (QUOTE VAR))
                       ((FVAR FVAR_ FVAR_^) 
                            (QUOTE FVAR))
                       NIL)))
         (if
 (NULL VARTYPE)
             then
 NIL
           elseif
 (NEQ 2 (LENGTH INSTR))
             then
 (ASM.ERR
 "needs one argument")
                   T
           elseif
 (NOT (SETQ VARTYPE (ASM.CKVARALLOCSTYLE
 VARTYPE)))
             then
 T
           else
 (ASM.XPDVARGENC
 VARTYPE (SELECTQ (CAR INSTR)
                                                    ((IVAR PVAR VAR FVAR) 
                                                         (QUOTE NIL))
                                                    ((IVAR_ PVAR_ VAR_ FVAR_) 
                                                         (QUOTE _))
                                                    ((IVAR_^ PVAR_^ VAR_^ FVAR_^) 
                                                         (QUOTE _^))
                                                    (ASM.HELP
 "no refType" (CAR INSTR)))
                           (CADR INSTR])

(ASM.XPDVARGENC

  [LAMBDA (VARTYPE REFTYPE VAR)                              (* jmh "16-May-86 15:29")


          (* * VARTYPE is one of IVAR PVAR VAR FVAR -- REFTYPE is one of NIL _ _^ -- returns a list of bytecodes if it can, 

	  else T in which case declares an error)



    (DECLARE
 (
USEDFREE
 TAM.VARXSTYLE TAM.OPCODEPROPS IVARS PVARS FVARS))
    (LET (VARLIST OPS SLOTNR OPCODE OPNR POPOPCODE SUBBL)

          (* * note OPS is a list of 3 elements-- two alternative names for the 1-byte opcode and one for the 2-byte opcode)



         (
SELECTQ
 VARTYPE
		    [IVAR (
SETQ
 VARLIST IVARS)
			  (
SETQ
 OPS (
SELECTQ
 REFTYPE
						 (NIL (
QUOTE
 (IVAR IVARK IVARX)))
						 (_ (
QUOTE
 (IVAR_ IVARK_ IVARX_)))
						 (_^ (
QUOTE
 (IVAR_^ IVARK_^ IVARX_^)))
						 (ASM.HELP
 "bad ivar RefType" REFTYPE]
		    [PVAR (
SETQ
 VARLIST PVARS)
			  (
SETQ
 OPS (
SELECTQ
 REFTYPE
						 (NIL (
QUOTE
 (PVAR PVARK PVARX)))
						 (_ (
QUOTE
 (PVAR_ PVARK_ PVARX_)))
						 (_^ (
QUOTE
 (PVAR_^ PVARK_^ PVARX_^)))
						 (ASM.HELP
 "bad pvar RefType" REFTYPE]
		    [VAR (
SETQ
 VARLIST PVARS)
			 (
SETQ
 OPS (
SELECTQ
 REFTYPE
						(NIL (
QUOTE
 (VAR VARK VARX)))
						(_ (
QUOTE
 (VAR_ VARK_ VARX_)))
						(_^ (
QUOTE
 (VAR_^ VARK_^ VARX_^)))
						(ASM.HELP
 "bad var RefType" REFTYPE]
		    [FVAR (
SETQ
 VARLIST FVARS)
			  (
SETQ
 OPS (
SELECTQ
 REFTYPE
						 (NIL (
QUOTE
 (FVAR FVARK FVARX)))
						 (_ (
QUOTE
 (FVAR_ FVARK_ FVARX_)))
						 (_^ (
QUOTE
 (FVAR_^ FVARK_^ FVARX_^)))
						 (ASM.HELP
 "bad fvar RefType" REFTYPE]
		    (ASM.HELP
 "bad VarType" VARTYPE))
         (if
 (
NOT
 (
SETQ
 SLOTNR (ASM.VARLKUP
 VAR VARLIST)))
	     then
 (ASM.ERR
 "var not declared or wrong type" VAR)
		    T
	   elseif
 (
AND
 [
OR
 (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CAR
 OPS)))
				 (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CADR
 OPS]
			   (
LISTP
 (
SETQ
 OPNR (fetch
 (OPCODE OP#) of
 OPCODE)))
			   [
IGEQ
 SLOTNR (
CAR
 (
SETQ
 OPKARGRANGE (ASM.OPKARGRANGE
 OPNR]
			   (
ILEQ
 SLOTNR (
CADR
 OPKARGRANGE)))
	     then
                                          (* 1-byte opcode)

		    (ASM.CKOPNARGS
 OPCODE 0)
		    (
LIST
 (ASM.MAKEOPKBYTE
 OPNR SLOTNR))
	   elseif
 (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CADDR
 OPS)))
	     then
                                          (* 2-byte opcode)

		    (ASM.CKOPNARGS
 OPCODE 1)
		    (
LIST
 (fetch
 (OPCODE OP#) of
 OPCODE)
			    (
SELECTQ
 TAM.VARXSTYLE
				       (D (
LLSH
 SLOTNR 1))
				       SLOTNR))
	   elseif
 [
AND
 (
EQ
 REFTYPE (
QUOTE
 _^))
			   (
SETQ
 POPOPCODE (ASM.GETOPCODE
 (
QUOTE
 POP)))
			   (
LISTP
 (
SETQ
 SUBBL (ASM.XPDVARGENC
 VARTYPE (
QUOTE
 _)
								    VAR]
	     then
 (
NCONC1
 SUBBL (fetch
 (OPCODE OP#) of
 POPOPCODE))
	   else
 (ASM.ERR
 "can't expand generic var ref with" TAM.OPCODEPROPS)
		  T])
)
(DEFINEQ

(ASM.JUMPGENC2BL

  [LAMBDA (INSTR PC OLDLEN PASS DELTA)                       (* jmh "22-May-86 17:25")


          (* * returns <1> NIL if not a jump generic, else <2> a list of byte codes if it can, else declares error and <3> 

	  returns T -- if the problem is just that the target label is undefined, then <1> declares error unless JGTUDOK?, 

	  <2> sets JGTUD?, <3> returns shortest-jump byte code -- if PASS is specified <then DELTA must be too and> if the 

	  target PC is not from that pass it is adjusted by DELTA)



    (DECLARE
 (
GLOBALVARS
 \ASM.L2PC)
	       (
USEDFREE
 JGTUD? JGTUDOK?))
    (LET (JUMPTYPE JUMPSIGN TARGETPC)
         (if
 (
NOT
 (
SETQ
 JUMPTYPE (
SELECTQ
 (
CAR
 INSTR)
						  (JUMP (
QUOTE
 JUMP))
						  (FJUMP (
QUOTE
 CJUMP))
						  (TJUMP (
SETQ
 JUMPSIGN T)
							 (
QUOTE
 CJUMP))
						  (NFJUMP (
QUOTE
 NCJUMP))
						  (NTJUMP (
SETQ
 JUMPSIGN T)
							  (
QUOTE
 NCJUMP))
						  NIL)))
	     then
 NIL
	   elseif
 [
NOT
 (
AND
 (
EQ
 2 (
LENGTH
 INSTR))
				  (
CADR
 INSTR)
				  (
NLISTP
 (
CADR
 INSTR]
	     then
 (ASM.ERR.JUMPFORMAT
)
		    T
	   else
 [if
 (
NOT
 (
SETQ
 TARGETPC (
GETHASH
 (
CADR
 INSTR)
							   \ASM.L2PC)))
		      then
 (
SETQ
 JGTUD? T)
			     (if
 (
NOT
 JGTUDOK?)
				 then
 (ASM.ERR.LABELUNDEF
))
		    else
 (
SETQ
 TARGETPC (if
 (
AND
 PASS (
NEQ
 PASS (
CADR
 TARGETPC)))
						then
 (
IPLUS
 (
CAR
 TARGETPC)
								DELTA)
					      else
 (
CAR
 TARGETPC]
		  (ASM.XPDJUMPGENC
 JUMPTYPE JUMPSIGN (if
 TARGETPC
							   then
 (
IDIFFERENCE
 TARGETPC PC)
							 else
 NIL)
				     OLDLEN])

(ASM.XPDJUMPGENC

  [LAMBDA (JUMPTYPE JUMPSIGN DELTA OLDLEN QUIET?)            (* jmh "23-May-86 12:25")


          (* * returns a list of byte codes if it can, else T -- DELTA can be NIL meaning ignore DELTA and just generate the 

	  shortest possible jump -- QUIET? means don't flag an error if can't generate a list of byte codes)



    (DECLARE
 (
USEDFREE
 TAM.OPCODEPROPS TAM.JUMPSTYLE))
    (if
 (
NOT
 DELTA)
	then
                                               (* guess DELTA to guarantee minimum-length opcode)

	       (
SETQ
 DELTA 2))
    (LET ((BL (
OR
 (
PROGN
                                 (* perhaps the relevant machine can do it in one 

							     instruction)

			     (
SELECTQ
 TAM.JUMPSTYLE
					(D (ASM.XPDJUMPGENC.D
 JUMPTYPE JUMPSIGN DELTA OLDLEN))
					(ASM.XPDJUMPGENC.T
 JUMPTYPE JUMPSIGN DELTA OLDLEN)))
		    (
AND
 (
EQ
 JUMPTYPE (
QUOTE
 CJUMP))
			   (
PROGN
                          (* try to simulate long CJUMP as opp-CJUMP JUMP)

				    (ASM.XPDJUMPGENC.X1
 JUMPSIGN DELTA)))
		    (
AND
 (
EQ
 JUMPTYPE (
QUOTE
 NCJUMP))
			   (
PROGN
                          (* try to simulate long NCJUMP as COPY opp-CJUMP JUMP 

							     POP)

				    (ASM.XPDJUMPGENC.X2
 JUMPSIGN DELTA)))
		    T)))
         (if
 (
AND
 (
NLISTP
 BL)
		      (
NOT
 QUIET?))
	     then
 (ASM.ERR
 "cant expand jump generic with OPCODEPROPS" TAM.OPCODEPROPS))
     BL])

(ASM.XPDJUMPGENC.D

  [LAMBDA (JUMPTYPE JUMPSIGN DELTA OLDLEN)                   (* jmh "23-May-86 11:20")


          (* * tries to make a 1-instruction jump -- returns a list of byte codes if it can, else NIL)



    (DECLARE
 (
USEDFREE
 TAM.ALPHASTYLE TAM.JUMPSTYLE TAM.OPCODEPROPS))
    (if
 (
NEQ
 TAM.JUMPSTYLE (
QUOTE
 D))
	then
 (ASM.HELP
 "asm.xpdjumpgenc.d bad tam.jumpstyle" TAM.JUMPSTYLE))
    (LET ((OPS (
SELECTQ
 JUMPTYPE
			  (JUMP (
QUOTE
 (JUMP JUMPX JUMPXX)))
			  [CJUMP (if
 JUMPSIGN
				     then
 (
QUOTE
 (TJUMP TJUMPX TJUMPXX))
				   else
 (
QUOTE
 (FJUMP FJUMPX FJUMPXX]
			  [NCJUMP (if
 JUMPSIGN
				      then
 (
QUOTE
 (NTJUMP NTJUMPX NTJUMPXX))
				    else
 (
QUOTE
 (NFJUMP NFJUMPX NFJUMPXX]
			  (ASM.HELP
 "bad jumpType" JUMPTYPE)))
	  OPCODE OPNR DELTAADJ OPKRANGE)
         (if
 [
AND
 (
EQ
 JUMPTYPE (
QUOTE
 JUMP))
		      (
EQ
 DELTA 1)
		      (
SETQ
 OPCODE (ASM.GETOPCODE
 (
QUOTE
 NOP)))
		      (
NLISTP
 (
SETQ
 OPNR (fetch
 (OPCODE OP#) of
 OPCODE]
	     then
                                          (* NOP)

		    (ASM.CKOPNARGS
 OPCODE 0)
		    (
LIST
 OPNR)
	   elseif
 (
AND
 (
OR
 (
NULL
 OLDLEN)
				 (
ILEQ
 OLDLEN 1))
			   (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CAR
 OPS)))
			   (
LISTP
 (
SETQ
 OPNR (fetch
 (OPCODE OP#) of
 OPCODE)))
			   (
SETQ
 OPKRANGE (ASM.OPKARGRANGE
 OPNR))
			   (
IGEQ
 (
SETQ
 DELTAADJ (
IDIFFERENCE
 DELTA 2))
				   (
CAR
 OPKRANGE))
			   (
ILEQ
 DELTAADJ (
CADR
 OPKRANGE)))
	     then
                                          (* 1-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 0)
		    (
LIST
 (ASM.MAKEOPKBYTE
 OPNR DELTAADJ))
	   elseif
 [
AND
 (ASM.RANGE?
 DELTA -128 127)
			   (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CADR
 OPS]
	     then
                                          (* 2-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 1)
		    (
LIST
 (fetch
 (OPCODE OP#) of
 OPCODE)
			    (
LOGAND
 255 DELTA))
	   elseif
 (
NOT
 (ASM.RANGE?
 DELTA -32768 32767))
	     then
                                          (* impossibly large jump)

		    (ASM.HELP
 "adj jump too big for 2 bytes" DELTA)
	   elseif
 (
SETQ
 OPCODE (ASM.GETOPCODE
 (
CADDR
 OPS)))
	     then
                                          (* 3-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 2)
		    [
CONS
 (fetch
 (OPCODE OP#) of
 OPCODE)
			    (
SELECTQ
 TAM.ALPHASTYLE
				       (D (
LIST
 (
LOGAND
 255 (
LRSH
 DELTA 8))
						  (
LOGAND
 255 DELTA)))
				       (
LIST
 (
LOGAND
 255 DELTA)
					       (
LOGAND
 255 (
LRSH
 DELTA 8]
	   else
 NIL])

(ASM.XPDJUMPGENC.T

  [LAMBDA (JUMPTYPE JUMPSIGN DELTA OLDLEN)                   (* jmh "23-May-86 12:32")


          (* * tries to make a 1-instruction jump -- returns a list of byte codes if it can, else NIL)



    (DECLARE
 (
USEDFREE
 TAM.ALPHASTYLE TAM.OPCODEPROPS TAM.JUMPSTYLE))
    (if
 TAM.JUMPSTYLE
	then
 (ASM.HELP
 "asm.xpdjumpgenc.t bad tam.jumpstyle" TAM.JUMPSTYLE))
    (LET ((OPS (
SELECTQ
 JUMPTYPE
			  (JUMP (
QUOTE
 (JUMPK JUMPX JUMPXX)))
			  [CJUMP (if
 JUMPSIGN
				     then
 (
QUOTE
 (TJUMPK TJUMPX TJUMPXX))
				   else
 (
QUOTE
 (FJUMPK FJUMPX FJUMPXX]
			  [NCJUMP (if
 JUMPSIGN
				      then
 (
QUOTE
 (NTJUMPK NTJUMPX NTJUMPXX))
				    else
 (
QUOTE
 (NFJUMPK NFJUMPX NFJUMPXX]
			  (ASM.HELP
 "bad jumpType" JUMPTYPE)))
	  (NEGOPS (
SELECTQ
 JUMPTYPE
			     (JUMP (
QUOTE
 (NJUMPK NJUMPX NJUMPXX)))
			     (CJUMP NIL)
			     (NCJUMP NIL)
			     (ASM.HELP
 "bad jumpType" JUMPTYPE)))
	  OP OPCODE OPNR DELTAADJ OPKRANGE)
         (if
 (
AND
 (
OR
 (
NULL
 OLDLEN)
			    (
ILEQ
 OLDLEN 1))
		      [
OR
 (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
IDIFFERENCE
 DELTA 1)))
				   (
SETQ
 OP (
CAR
 OPS)))
			    (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
MINUS
 DELTAADJ)))
				   (
SETQ
 OP (
CAR
 NEGOPS]
		      (
SETQ
 OPCODE (ASM.GETOPCODE
 OP))
		      (
LISTP
 (
SETQ
 OPNR (fetch
 (OPCODE OP#) of
 OPCODE)))
		      (
SETQ
 OPKRANGE (ASM.OPKARGRANGE
 OPNR))
		      (ASM.RANGE?
 DELTAADJ (
CAR
 OPKRANGE)
				    (
CADR
 OPKRANGE)))
	     then
                                          (* 1-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 0)
		    (
LIST
 (ASM.MAKEOPKBYTE
 OPNR DELTAADJ))
	   elseif
 (
AND
 [
OR
 (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
IDIFFERENCE
 DELTA 2)))
					(
SETQ
 OP (
CADR
 OPS)))
				 (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
MINUS
 DELTAADJ)))
					(
SETQ
 OP (
CADR
 NEGOPS]
			   (
ILEQ
 DELTAADJ 255)
			   (
SETQ
 OPCODE (ASM.GETOPCODE
 OP)))
	     then
                                          (* 2-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 1)
		    (
LIST
 (fetch
 (OPCODE OP#) of
 OPCODE)
			    DELTAADJ)
	   elseif
 (
AND
 [
OR
 (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
IDIFFERENCE
 DELTA 3)))
					(
SETQ
 OP (
CADDR
 OPS)))
				 (
AND
 (
ILEQ
 0 (
SETQ
 DELTAADJ (
MINUS
 DELTAADJ)))
					(
SETQ
 OP (
CADDR
 NEGOPS]
			   (
ILEQ
 DELTAADJ 65535)
			   (
SETQ
 OPCODE (ASM.GETOPCODE
 OP)))
	     then
                                          (* 3-byte jump)

		    (ASM.CKOPNARGS
 OPCODE 2)
		    [
CONS
 (fetch
 (OPCODE OP#) of
 OPCODE)
			    (
SELECTQ
 TAM.ALPHASTYLE
				       (D (
LIST
 (
LOGAND
 255 (
LRSH
 DELTAADJ 8))
						  (
LOGAND
 255 DELTAADJ)))
				       (
LIST
 (
LOGAND
 255 DELTAADJ)
					       (
LOGAND
 255 (
LRSH
 DELTAADJ 8]
	   elseif
 (
NOT
 (ASM.RANGE?
 (
SETQ
 DELTAADJ (
IDIFFERENCE
 DELTA 3))
					 -32767 32767))
	     then
                                          (* impossibly large jump)

		    (ASM.HELP
 "adj jump too big for 2 bytes" DELTAADJ)
	   else
 NIL])

(ASM.XPDJUMPGENC.X1

  [LAMBDA (JUMPSIGN DELTA)                                   (* jmh "23-May-86 11:15")


          (* * try to simulate long CJUMP as opp-CJUMP JUMP -- return byte list or NIL)



    (LET ((CJN 2)
	  (JN 3)
	  CJBL JBL)
         (
SETQ
 CJBL (ASM.XPDJUMPGENC
 (
QUOTE
 CJUMP)
					 (
NOT
 JUMPSIGN)
					 (
IPLUS
 CJN JN)
					 NIL))
         (
SETQ
 JBL (ASM.XPDJUMPGENC
 (
QUOTE
 JUMP)
					NIL
					(
IDIFFERENCE
 DELTA CJN)
					NIL))
         (while
 [
AND
 (
LISTP
 CJBL)
			 (
LISTP
 JBL)
			 (
OR
 (
NEQ
 CJN (
LENGTH
 CJBL))
			       (
NEQ
 JN (
LENGTH
 JBL]
	    do
 (
SETQ
 CJN (
LENGTH
 CJBL))
		 (
SETQ
 JN (
LENGTH
 JBL))
		 (
SETQ
 CJBL (ASM.XPDJUMPGENC
 (
QUOTE
 CJUMP)
						 (
NOT
 JUMPSIGN)
						 (
IPLUS
 CJN JN)
						 NIL))
		 (
SETQ
 JBL (ASM.XPDJUMPGENC
 (
QUOTE
 JUMP)
						NIL
						(
IDIFFERENCE
 DELTA CJN)
						NIL)))
         (if
 (
AND
 (
LISTP
 CJBL)
		      (
LISTP
 JBL))
	     then
 (
APPEND
 CJBL JBL)
	   else
 NIL])

(ASM.XPDJUMPGENC.X2

  [LAMBDA (JUMPSIGN DELTA)                                   (* jmh "23-May-86 11:15")


          (* * simulate long NCJUMP as COPY opp-CJUMP JUMP POP -- return byte list or NIL)



    (LET ((COPYOC (ASM.GETOPCODE
 (
QUOTE
 COPY)))
	  (POPOC (ASM.GETOPCODE
 (
QUOTE
 POP)))
	  (CJN 2)
	  (JN 3)
	  CJBL JBL)
         (if
 (
AND
 COPYOC POPOC)
	     then
 (ASM.CKOPNARGS
 COPYOC 0)
		    (ASM.CKOPNARGS
 POPOC 0)
		    (
SETQ
 CJBL (ASM.XPDJUMPGENC
 (
QUOTE
 CJUMP)
						    (
NOT
 JUMPSIGN)
						    (
IPLUS
 CJN JN)
						    NIL))
		    (
SETQ
 JBL (ASM.XPDJUMPGENC
 (
QUOTE
 JUMP)
						   NIL
						   (
IDIFFERENCE
 DELTA (
ADD1
 CJN))
						   NIL))
		    (while
 [
AND
 (
LISTP
 CJBL)
				    (
LISTP
 JBL)
				    (
OR
 (
NEQ
 CJN (
LENGTH
 CJBL))
					  (
NEQ
 JN (
LENGTH
 JBL]
		       do
 (
SETQ
 CJN (
LENGTH
 CJBL))
			    (
SETQ
 JN (
LENGTH
 JBL))
			    (
SETQ
 CJBL (ASM.XPDJUMPGENC
 (
QUOTE
 CJUMP)
							    (
NOT
 JUMPSIGN)
							    (
IPLUS
 CJN JN)
							    NIL))
			    (
SETQ
 JBL (ASM.XPDJUMPGENC
 (
QUOTE
 JUMP)
							   NIL
							   (
IDIFFERENCE
 DELTA (
ADD1
 CJN))
							   NIL)))
		    (if
 (
AND
 (
LISTP
 CJBL)
				 (
LISTP
 JBL))
			then
 (
APPEND
 (
LIST
 (fetch
 (OPCODE OP#) of
 COPYOC))
					 CJBL JBL (
LIST
 (fetch
 (OPCODE OP#) of
 POPOC)))
		      else
 NIL)
	   else
 NIL])
)
(* * error handling and the "output listing" -- see AsmInternal.tedit)


(DEFINEQ

(ASM.PHASEMARK

  [LAMBDA (NEWPHASE NEWPHASEMARK)                            (* jmh " 2-Dec-85 16:58")


          (* * declare the beginning of a phase -- set the topic and remember a tag for adding to error messages in debug 

	  mode)



    (DECLARE
 (
USEDFREE
 ERRPHASE ERRPHASEMARK ERRTOPIC TOPICERRS?))
    (if
 (
OR
 (
NULL
 NEWPHASE)
		(
LISTP
 NEWPHASE)
		(
LISTP
 NEWPHASEMARK))
	then
 (ASM.HELP
 "bad args" (
LIST
 NEWPHASE NEWPHASEMARK)))
    (
SETQ
 ERRPHASE NEWPHASE)
    (
SETQ
 ERRPHASEMARK (if
 NEWPHASEMARK
			   else
 NEWPHASE))
    (
SETQ
 ERRTOPIC NEWPHASE)
    (
SETQ
 TOPICERRS?])

(ASM.ERR

  [LAMBDA NARGS
                                                        (* jmh 
                                                                           "27-Feb-86 09:41")

            
            (* * returns NIL -- append error message to topic --
            print error message if ERRSOK?)


    (DECLARE
 (USEDFREE DEBUG? ERRSOK? ERRSYMBOL ERRFILE ERRPHASE ERRPHASEMARK ERRTOPIC TOPICERRS? 
                        LASTERRPHASE TOTALNERRS OLT))
    (LET*[[MSG (SELECTQ NARGS
                   (0 (ASM.HELP
 "no args"))
                   (1 (ARG NARGS 1))
                   (for
 I from
 1 to
 NARGS collect
 (ARG NARGS I]
          (LINE (if
 (NULL ERRTOPIC)
                    then
                                               (* topic is last of 
                                                                           OLT)

                          (CADR OLT)
                  elseif
 (NLISTP ERRTOPIC)
                    then
                                               (* topic is phase)

                          (if
 [NOT (AND (LISTP (CDR OLT))
                                            (EQ ERRTOPIC (CAADR OLT]
                              then
 (TCONC OLT (LIST ERRTOPIC)))
                          (CADR OLT)
                  elseif
 (NOT (TAILP ERRTOPIC (CAR OLT)))
                    then
 (ASM.HELP
 "ERRTOPIC not tail OLT")
                  else
                                                 (* topic is tail of 
                                                                           OLT)

                        (CAR ERRTOPIC)))
          (ALREADY? (AND (MEMBER MSG (CDR LINE]
     (if
 (OR DEBUG? (NOT ALREADY?))
         then
 (if
 (NOT (MEMB ERRSYMBOL LINE))
                      then
 (NCONC1 LINE ERRSYMBOL))
               [if
 DEBUG?
                   then
 (NCONC1 LINE (PACK* (QUOTE <)
                                                ERRPHASEMARK
                                                (QUOTE >]
               (NCONC1 LINE MSG)
               (if
 ERRSOK?
                   then
 (if
 (NEQ LASTERRPHASE ERRPHASE)
                                then
 (printout (OR ERRFILE T)
                                                ERRPHASE
                                                (QUOTE --)
                                                T)
                                      (SETQ LASTERRPHASE ERRPHASE))
                         (printout (OR ERRFILE T)
                                ERRSYMBOL , (CAR LINE)
                                , MSG T)))
     (if
 (NOT ALREADY?)
         then
 (SETQ TOPICERRS? T)
               (add
 TOTALNERRS 1)))
    NIL])
)
(DEFINEQ

(ASM.LIST

  [LAMBDA (INSTR)                                            (* jmh " 2-Dec-85 11:27")


          (* * appends <INSTR> to OLT and declares that to be the topic -- returns INSTR)



    (DECLARE
 (
USEDFREE
 ERRTOPIC TOPICERRS? OLT))         (* jmh " 4-Nov-85 16:57")

    (
TCONC
 OLT (
LIST
 INSTR))
    (
SETQ
 ERRTOPIC)
    (
SETQ
 TOPICERRS?)
    INSTR])

(ASM.SMASHLIST

  [LAMBDA (NEWINSTR)                                         (* jmh " 2-Dec-85 11:27")


          (* * used after ASM.LIST to modify the "output listing" line -- returns NEWINSTR)



    (DECLARE
 (
USEDFREE
 ERRTOPIC ERRSYMBOL OLT))
    (if
 ERRTOPIC
	then
 (ASM.HELP
 "ERRTOPIC not NIL"))
    (if
 (
NLISTP
 (
CDR
 OLT))
	then
 (ASM.HELP
 "null OLT"))
    (
RPLACA
 (
CADR
 OLT)
	      NEWINSTR)
    NEWINSTR])
)
(DEFINEQ

(ASM.TOPIC

  [LAMBDA (TAIL)                                             (* jmh " 2-Dec-85 11:29")


          (* * TAIL is tail of OLT -- makes <CAR TAIL> the topic line -- returns topic instr <without error marks> -- sets 

	  TOPICERRS? = that topic has error marks)



    (DECLARE
 (
USEDFREE
 ERRSYMBOL ERRTOPIC TOPICERRS?))
    (if
 (
NLISTP
 TAIL)
	then
 (ASM.HELP
 "arg not list" TAIL))
    (
SETQ
 ERRTOPIC TAIL)
    (
SETQ
 TOPICERRS? (
MEMB
 ERRSYMBOL (
CDAR
 TAIL)))
    (
CAAR
 TAIL])

(ASM.SMASHTOPIC

  [LAMBDA (NEWINSTR)                                         (* jmh " 2-Dec-85 11:29")


          (* * used after ASM.TOPIC to modify the "output listing" line -- returns NEWINSTR)



    (DECLARE
 (
USEDFREE
 ERRTOPIC))
    (if
 (
NLISTP
 ERRTOPIC)
	then
 (ASM.HELP
 "ERRTOPIC not list"))
    (
RPLACA
 (
CAAR
 ERRTOPIC)
	      NEWINSTR)
    NEWINSTR])
)
(* * specific error messages that can be generated fom more than one place on different passes
 on the same instruction)


(DEFINEQ

(ASM.ERR.NILLABEL

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:09")

    (ASM.ERR
 "NIL can't be a label"])

(ASM.ERR.LABELREPEATED

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:15")

    (ASM.ERR
 "label multiply defined"])

(ASM.ERR.LABELUNDEF

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:15")

    (ASM.ERR
 "label undefined"])
)
(DEFINEQ

(ASM.ERR.NOTLITATOM

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:11")

    (ASM.ERR
 "car of instr not litatom"])

(ASM.ERR.NOOPCODE

  [LAMBDA NIL
                                                          (* jmh 
                                                                           " 4-Mar-86 19:01")

    (DECLARE
 (USEDFREE TAM.OPCODEPROPS))
    (ASM.ERR
 "no OPCODE rec in" TAM.OPCODEPROPS])
)
(DEFINEQ

(ASM.ERR.NILFORMAT

  [LAMBDA (N)                                                (* jmh "20-Jan-86 18:48")

    (if
 (
ZEROP
 N)
	then
 (ASM.ERR
 "should have no args")
      else
 (ASM.ERR
 "should have args 0..255 --" N "of them"])

(ASM.ERR.FNXFORMAT

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:14")

    (ASM.ERR
 "should have 2 args: a 0..255 and an atom"])

(ASM.ERR.BINDFORMAT

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:14")

    (ASM.ERR
 "should have 2 args, each NIL or a list of pvars"])

(ASM.ERR.JUMPFORMAT

  [LAMBDA NIL                                                (* jmh " 9-Nov-85 15:14")

    (ASM.ERR
 "should have 1 arg, a label"])
)
(DEFINEQ

(ASM.ERR.STACKSTYLE

  [LAMBDA NIL
                                                          (* jmh 
                                                                           "13-Mar-86 10:42")

    (DECLARE
 (USEDFREE TAM.STACKSTYLE))
    (ASM.ERR
 "illegal instr with this stack style" TAM.STACKSTYLE])

(ASM.ERR.UNKNOWNSTACK

  [LAMBDA NIL
                                                          (* jmh 
                                                                           "20-Feb-86 23:32")

    (ASM.ERR
 "stack unknown at label"])

(ASM.ERR.AMBIGSTACK

  [LAMBDA (LABELSTACK)
                                                 (* jmh 
                                                                           "20-Feb-86 23:31")

    (ASM.ERR
 "stack ambiguous at label" (COPYALL LABELSTACK])
)
(* * misc)


(DEFINEQ

(ASM.VARLKUP

  [LAMBDA (VAR VARLIST DONTADD?)
                                       (* jmh 
                                                                           "26-Feb-86 13:09")

            
            (* * => slot number or NIL)


    (LET ((X (SASSOC VAR VARLIST)))
         (if
 X
             then
 (CDR X])

(ASM.GETOPCODE

  [LAMBDA (OPNAME)
    (DECLARE
 (USEDFREE TAM.OPCODEPROPS))
                           (* jmh 
                                                                           " 4-Mar-86 19:01")

    (LET (OPCODE)
         (if
 (for
 PROPNAME in
 TAM.OPCODEPROPS thereis
 (SETQ OPCODE (GETPROP OPNAME 
                                                                                          PROPNAME)))
             then
 OPCODE
           else
 NIL])

(ASM.OLTAFTERCODE:

  [LAMBDA NIL                                                (* jmh "12-Nov-85 13:30")


          (* * returns the tail of OLT after the CODE: pseudolabel)



    (DECLARE
 (
USEDFREE
 OLT))
    (if
 [
CDR
 (for
 IL on
 (
CAR
 OLT) thereis
 (
EQ
 (ASM.TOPIC
 IL)
							    (
QUOTE
 CODE:]
      else
 (ASM.HELP
 "no CODE:"])

(ASM.CKOPNARGS

  [LAMBDA (IS SHOULDBE)                                      (* jmh "12-Nov-85 13:30")

    (if
 (
LISTP
 IS)
	then
 (
SETQ
 IS (fetch
 (OPCODE OPNARGS) of
 IS)))
    (if
 (
NEQ
 IS SHOULDBE)
	then
 (ASM.HELP
 "bad OPNARGS" IS])

(ASM.CKVARALLOCSTYLE

  [LAMBDA (VARTYPE)
                                                    (* jmh 
                                                                           " 4-Mar-86 18:51")

            
            (* * if VARTYPE is ok for this machine, return it, else bitch and return 
            NIL)


    (DECLARE
 (USEDFREE TAM.VARALLOCSTYLE))
    (if
 [MEMB VARTYPE (SELECTQ TAM.VARALLOCSTYLE
                              (D (QUOTE (IVAR PVAR FVAR)))
                              (QUOTE (PVAR VAR FVAR]
        then
 VARTYPE
      else
 (ASM.ERR
 "can't use varType" VARTYPE "with varAllocStyle" TAM.VARALLOCSTYLE])
)
(DEFINEQ

(ASM.OPKARGRANGE

  [LAMBDA (OPNR)                                             (* jmh "16-May-86 15:46")


          (* * return list of 2 elements: the min and max implicit arguments for an opK-format opcode with this OP# range)



    (DECLARE
 (
USEDFREE
 TAM.OPKSTYLE))
    (if
 (
NLISTP
 OPNR)
	then
 (ASM.HELP
 "non-list OPNR"))
    (
SELECTQ
 TAM.OPKSTYLE
	       [D (
LIST
 0 (
DIFFERENCE
 (
CADR
 OPNR)
					  (
CAR
 OPNR]
	       (
LIST
 (
LOGAND
 15 (
CAR
 OPNR))
		       (
LOGAND
 15 (
CADR
 OPNR])

(ASM.MAKEOPKBYTE

  [LAMBDA (OPNR ARG)                                         (* jmh "16-May-86 15:51")


          (* * return the opcode byte for that implicit argument for the opK-format opcode with that OP# range)



    (DECLARE
 (
USEDFREE
 TAM.OPKSTYLE))
    (if
 (
NLISTP
 OPNR)
	then
 (ASM.HELP
 "non-list OPNR"))
    (
SELECTQ
 TAM.OPKSTYLE
	       (D (if
 (
IGEQ
 ARG (
DIFFERENCE
 (
CADR
 OPNR)
						  (
CAR
 OPNR)))
		      then
 (ASM.HELP
 "arg o/r")
			     (
CAR
 OPNR)
		    else
 (
IPLUS
 (
CAR
 OPNR)
				    ARG)))
	       (if
 [
OR
 (
ILESSP
 ARG (
LOGAND
 15 (
CAR
 OPNR)))
			   (
IGREATERP
 ARG (
LOGAND
 15 (
CADR
 OPNR]
		   then
 (ASM.HELP
 "arg o/r")
		 else
 (
LOGOR
 ARG (
LOGAND
 240 (
CAR
 OPNR])
)
(DEFINEQ

(ASM.RANGE?

  [LAMBDA (X MIN MAX)
                                                  (* jmh 
                                                                           "20-Feb-86 23:34")

    (if
 (AND (NUMBERP X)
                 (OR (NULL MIN)
                     (ILEQ MIN X))
                 (OR (NULL MAX)
                     (ILEQ X MAX)))
        then
 X
      else
 NIL])

(ASM.POSINLIST

  [LAMBDA (X L)                                              (* jmh "10-Nov-85 17:13")


          (* * if X is a member of L (EQ) then returns the 0-based index of X in L, else returns NIL)



    (LET (POS)
         (if
 (for
 E in
 L as
 old
 POS from
 0 thereis
 (
EQ
 X E))
	     then
 POS])

(ASM.CEIL

  [LAMBDA (N GRANULE)
    (
ITIMES
 (
IQUOTIENT
 (
IPLUS
 N GRANULE -1)
			   GRANULE)
	      GRANULE])
)
(DEFINEQ

(ASM.PVARMAP

  [LAMBDA NIL                                                (* jmh " 8-Dec-85 15:18")


          (* * returns informational map of oldslot -> newslot for compiler-generated temporaries)



    (DECLARE
 (
USEDFREE
 PVARS))
    (LET [(
MAP
 (for
 VANDS in
 PVARS when
 (
AND
 (
LISTP
 (
CAR
 VANDS))
						       (
EQUAL
 "pvar" (
CAAR
 VANDS)))
		    collect
 (
LIST
 (
CADAR
 VANDS)
				      (
CDR
 VANDS]
         (if
 MAP
	     then
 (
CONS
 "pvars: oldslot new" (
SORT
 MAP])

(ASM.HELP

  [LAMBDA (MSG1 MSG2)                                        (* jmh "14-Jan-86 12:41")

    (DECLARE
 (
USEDFREE
 ERRFILE ERRPHASEMARK))
    (if
 (
NULL
 ERRFILE)
	then
 (
HELP
 MSG1 MSG2)
      else
                                                 (* this is for running under NLSETQ with interrogation

							     of NIL results via (ERRORMESS 

							     (ERRORN)))

	     (printout ERRFILE (
QUOTE
 **ASM.HELP**% in% phase)
		       , ERRPHASEMARK , MSG1 , MSG2 T)
	     (
SETERRORN
 1 "asm.help")
	     (
ERROR!
])
)
(DEFINEQ

(ASM.NEXTLABEL

  [LAMBDA (TAG)
    (DECLARE
 (
USEDFREE
 NFML))                            (* jmh "29-May-86 11:26")

    (
PACK*
 TAG (
QUOTE
 $)
	     (
PROG1
 NFML (add
 NFML 1])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 ASM.ERR)
)
(PUTPROPS ASM COPYRIGHT ("Xerox Corporation" 3701Q 3702Q))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (10626Q 23754Q (ASM 10640Q . 21505Q) (ASM.1 21507Q . 23752Q)) (24026Q 54102Q (
ASM.EATHDR+NTS 24040Q . 26234Q) (ASM.EATFNDECL 26236Q . 33717Q) (ASM.EATDFNHEADERDECL 33721Q . 36626Q)
 (ASM.EATVARDECLS 36630Q . 54100Q)) (54103Q 66714Q (ASM.ALLOCVARS.D 54115Q . 57472Q) (ASM.CKDIRVS.D 
57474Q . 66712Q)) (66715Q 75025Q (ASM.ALLOCVARS.T 66727Q . 71441Q) (ASM.CKDIRVS.T 71443Q . 75023Q)) (
75026Q 75313Q (ASM.NA.D 75040Q . 75311Q)) (75314Q 76653Q (ASM.CKVARNAME 75326Q . 76651Q)) (77126Q 
100441Q (ASM.ENTRYVECTOR 77140Q . 100437Q)) (100442Q 113635Q (ASM.CODEPASS1 100454Q . 106157Q) (
ASM.CODEPASS1.INNER 106161Q . 110215Q) (ASM.EATCODE 110217Q . 113066Q) (ASM.EATCODE.DOLABEL 113070Q . 
113633Q)) (113636Q 125573Q (ASM.STK.INSTR 113650Q . 120774Q) (ASM.STKGENCLEVADJ 120776Q . 122135Q) (
ASM.STKAPPLYFN.LEVADJ.D 122137Q . 125571Q)) (125574Q 131442Q (ASM.STK.PASSLABEL 125606Q . 127562Q) (
ASM.STK.JUMPTOLABEL 127564Q . 131440Q)) (131443Q 135050Q (ASM.STKMAX 131455Q . 133101Q) (ASM.STKADD 
133103Q . 135046Q)) (135051Q 146003Q (ASM.STKBIND.D 135063Q . 137132Q) (ASM.STKUNBIND.D 137134Q . 
143776Q) (ASM.STKOK?.D 144000Q . 146001Q)) (146004Q 151237Q (ASM.STKSET.T 146016Q . 147643Q) (
ASM.STKOK?.T 147645Q . 151235Q)) (151610Q 163461Q (ASM.CODEPASS2 151622Q . 154013Q) (
ASM.ALLCODELENGTHS 154015Q . 157500Q) (ASM.REDOJGLENGTHS 157502Q . 163457Q)) (163532Q 165747Q (
ASM.MAKECODEARRAY 163544Q . 165200Q) (ASM.EMITHDR+NTS 165202Q . 165745Q)) (165750Q 171753Q (
ASM.EMITHDR+NTS.D 165762Q . 171751Q)) (171754Q 176114Q (ASM.EMITHDR+NTS.T 171766Q . 176112Q)) (176115Q
 200357Q (ASM.EMITANNT 176127Q . 177246Q) (ASM.EMITPARTOFANNT 177250Q . 200355Q)) (200360Q 201165Q (
ASM.PUTB 200372Q . 201163Q)) (201332Q 217443Q (ASM.EMITCODE 201344Q . 206047Q) (ASM.EMITINSTR 206051Q
 . 217441Q)) (217444Q 242100Q (ASM.EMITVANILLAINSTR 217456Q . 221461Q) (ASM.EMITBIND.D 221463Q . 
224557Q) (ASM.EMITUNBIND.T 224561Q . 226372Q) (ASM.EMITXBITS.N.FD 226374Q . 227600Q) (ASM.EMITTYPEP 
227602Q . 231706Q) (ASM.EMITXVAR 231710Q . 233570Q) (ASM.EMITJUMP.D 233572Q . 236676Q) (ASM.EMITJUMP.T
 236700Q . 242076Q)) (242101Q 246254Q (ASM.EMITB 242113Q . 242650Q) (ASM.EMITBS 242652Q . 244450Q) (
ASM.EMITBL 244452Q . 245031Q) (ASM.EMITATOMINDEX 245033Q . 245547Q) (ASM.EMITPCONST 245551Q . 246252Q)
) (246255Q 257557Q (ASM.VARGENC2BL 246267Q . 251626Q) (ASM.XPDVARGENC 251630Q . 257555Q)) (257560Q 
306625Q (ASM.JUMPGENC2BL 257572Q . 263100Q) (ASM.XPDJUMPGENC 263102Q . 266022Q) (ASM.XPDJUMPGENC.D 
266024Q . 273332Q) (ASM.XPDJUMPGENC.T 273334Q . 301610Q) (ASM.XPDJUMPGENC.X1 301612Q . 303675Q) (
ASM.XPDJUMPGENC.X2 303677Q . 306623Q)) (306743Q 315507Q (ASM.PHASEMARK 306755Q . 310174Q) (ASM.ERR 
310176Q . 315505Q)) (315510Q 317266Q (ASM.LIST 315522Q . 316335Q) (ASM.SMASHLIST 316337Q . 317264Q)) (
317267Q 321155Q (ASM.TOPIC 317301Q . 320331Q) (ASM.SMASHTOPIC 320333Q . 321153Q)) (321355Q 322317Q (
ASM.ERR.NILLABEL 321367Q . 321621Q) (ASM.ERR.LABELREPEATED 321623Q . 322064Q) (ASM.ERR.LABELUNDEF 
322066Q . 322315Q)) (322320Q 323253Q (ASM.ERR.NOTLITATOM 322332Q . 322572Q) (ASM.ERR.NOOPCODE 322574Q
 . 323251Q)) (323254Q 324706Q (ASM.ERR.NILFORMAT 323266Q . 323666Q) (ASM.ERR.FNXFORMAT 323670Q . 
324147Q) (ASM.ERR.BINDFORMAT 324151Q . 324440Q) (ASM.ERR.JUMPFORMAT 324442Q . 324704Q)) (324707Q 
326437Q (ASM.ERR.STACKSTYLE 324721Q . 325421Q) (ASM.ERR.UNKNOWNSTACK 325423Q . 326015Q) (
ASM.ERR.AMBIGSTACK 326017Q . 326435Q)) (326461Q 332665Q (ASM.VARLKUP 326473Q . 327220Q) (ASM.GETOPCODE
 327222Q . 330177Q) (ASM.OLTAFTERCODE: 330201Q . 331006Q) (ASM.CKOPNARGS 331010Q . 331435Q) (
ASM.CKVARALLOCSTYLE 331437Q . 332663Q)) (332666Q 335437Q (ASM.OPKARGRANGE 332700Q . 333754Q) (
ASM.MAKEOPKBYTE 333756Q . 335435Q)) (335440Q 337226Q (ASM.RANGE? 335452Q . 336272Q) (ASM.POSINLIST 
336274Q . 337027Q) (ASM.CEIL 337031Q . 337224Q)) (337227Q 341407Q (ASM.PVARMAP 337241Q . 340307Q) (
ASM.HELP 340311Q . 341405Q)) (341410Q 341736Q (ASM.NEXTLABEL 341422Q . 341734Q)))))
STOP