Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_FS_1_19910112 - kcc-5/fail/fail.fai
There are 6 other files named fail.fai in the archive. Click here to see a list.
;[SRI-NIC]SRC:<LOC.SUBSYS>FAIL.FAI.3, 21-Jun-85 15:36:00, Edit by KLH
;  Fixed polish fixup output at POLOUT to clear any unused reloc bits or
;  halfword at end of block (random leftover junk caused %LNKJPB load errs)
;<FAIL>FAIL.FAI.2, 17-Feb-85 02:01:26, Edit by SATZ
; Use device name passed to us for .REQUEST and .REQUIRE
; instead of the one devined by JFNS%. Also zero PPN field.
;ACCT:<UTILITIES.SUBSYS>FAIL.FAI.1, 12-Oct-81 17:07:42, Edit by B.BOMBADIL
;LOTS changes
;	REG - add IFB and IFNB pseudo-ops
;	RMK - better handling of .REQUIRE SYS:FOO, where FOO is on a directory
;	      other than the first one on the SYS: search path

	TITLE FAIL
SUBTTL CONDITIONAL ASSEMBLY


;VERSION STUFF
VFAIL__12				;REG 12/27/76
VMINOR__0
VWHO__0
VEDIT__0
	LOC	137
	BYTE(3)VWHO(9)VFAIL(6)VMINOR(18)VEDIT		;DEC-STYLE VERSION
	RELOC	0

XALL

;ITS ASSEMBLY ADDED 6/18/73 --PJ
;CMU ASSEMBLY ADDED 10/6/73 -- MM/FW
;DWP ASSEMBLY ADDED 27 FEB 74 -- INCREASES PLEN AND DELETES LITERAL COMPARE FOR LISP
;SYMDMP SWITCH: ADDS CODE THAT WRITES ASCII VERSION OF THE SYMBOL TABLE (FOR REG)
;KI10SW CONDITIONAL FOR KI-10 MNEMONICS
;TENEX ASSEMBLY MERGED 4/26/74
;TENEX I/O ADDED 11/13/74 -- TMW
;TOPS-20 ASSEMBLY ADDED.  12/5/76  REG

DEFINE SETSW(SWIT,VAL)<IFNDEF SWIT,<SWIT__VAL&1;>SWIT__SWIT&1>
DEFINE SETSWX(SWIT,VAL)<IFNDEF SWIT,<SWIT__VAL;>SWIT__SWIT>

;THE INTENTION OF THE FOLLOWING CODE IS TO ALLOW YOU TO MAKE A NEW ASSEMBLY WITH
;THE SAME SWITCHES THAT WERE ON IN THE FAIL WITH WHICH YOU ARE ASSEMBLING.
;THE ONLY TIME THIS DOESN'T WORK IS TO ASSEMBLE A VERSION TO RUN ELSEWHERE, IN
;WHICH CASE, THE SWITCHES MUST BE SET EXPLICITLY FROM THE TTY: OR BY A HEADER FILE

IFDEF	SPCWAR, <SETSW STANSW,1>	;STANFORD
IFDEF	.IOT,	<SETSW ITSSW,1>		;MIT 
IFDEF	CMUDEC,	<SETSW CMUSW,1>		;CMU
IFDEF	HALTF,	<SETSW TENEX,1>		;TENEX or TOPS-20
IFDEF	DMOVNM, <SETSW KI10SW,1>	;KI-10 OPCODES
IFOP	PSTIN,	<SETSW PSTISW,1>	;PSTIN JSYS EXISTS AT TENEX SITE
IFDEF 	KLGOT,	<SETSW IMSSSW,1>	;THIS IS IMSSS
IFDEF	SOUTR,	<SETSW TOPS20,1>	;THIS IS TOPS-20
IFDEF	AUXCAL,<SETSW TYMSW,1>
	
SETSW KI10SW,1			;KI-10 MNEMONICS (ALSO KL10 MNEMONICS)
SETSW ITSSW,0			;ITS (MIT) VERSION
SETSW CMUSW,0			;CMU VERSION
SETSW TENEX,0			;TENEX VERSION
SETSW TOPS20,0			;TOPS-20 VERSION
SETSW STANSW,0			;STANFORD VERSION
SETSW TYMSW,0			;TYMSHARE VERSION

SETSW DWPSW,0			;DAVID POOLE VERSION FOR LISP
SETSW SYMDMP,0			;REG VERSION FOR HARDCOPY OF INITIAL SYMBOL TABLE

SETSW STNKSW,ITSSW
SETSW EDITSW,STANSW!CMUSW!TYMSW	;SWITCH TO ALLOW CALLING EDITOR
				;NOT USEFUL WITH TOPS-10 RUN UUO WHICH CLOBBERS ACS

SETSW STOPSW,CMUSW		;SWITCH TO MAKE /R DEFAULT MODE (ONLY CMU LIKES IT)
SETSW TMPCSW,<1-<ITSSW!TENEX!TOPS20>>	;SWITCH TO ALLOW TMPCOR TYPE RPG INTERFACE

SETSW IMSSSW,0			;PRESENTLY CONTROLS ONLY DELETIONS IN PSTIN, LOCAL JSYSES
SETSW PSTISW,0			;ONE IF TENEX SITE HAS PSTIN JSYS
SETSW KAFLG,1			;IF PSTIN SIMULATION IS TO RUN ON A KA
SETSW KIFLG,<1-KAFLG>		;IF PSTIN TO RUN ON KI

IFN TENEX!TOPS20,<IFN ITSSW!CMUSW!STANSW!SYMDMP,<.FATAL  ILLEGAL SWITCH SETTINGS FOR TENEX>>

DEFINE ITS,<IFN ITSSW,>
DEFINE NOITS,<IFE ITSSW,>

DEFINE STINK,<IFN STNKSW,>
DEFINE NOSTINK,<IFE STNKSW,>

DEFINE TNX,<IFN TENEX!TOPS20,>
DEFINE NOTNX,<IFE TENEX!TOPS20,>
DEFINE T20,<IFN TOPS20,>
DEFINE NOT20,<IFE TOPS20,>
IFE STANSW!ITSSW!CMUSW!TENEX!TYMSW,<
	OSFAIL==<SIXBIT/TOPS10/>
	PRINTS	/TOPS10 VERSION
/>

IFN STANSW,<
	OSFAIL==<SIXBIT/SAIL/>
	PRINTS	/SAIL VERSION
/>

IFN TENEX,<
IFE TOPS20,<
	OSFAIL==<SIXBIT/TENEX/>
	PRINTS	/TENEX VERSION
/>;NO TOPS20
IFN TOPS20,<
	OSFAIL==<SIXBIT/TOPS20/>
	PRINTS	/TOPS20 VERSION
/>;TOPS20>;TENEX

IFN CMUSW,<
	OSFAIL==<SIXBIT/CMU/>
	PRINTS	/CMU VERSION
/
>

IFN ITSSW,<
	OSFAIL==<SIXBIT/ITS/>
	PRINTS	/ITS VERSION
/>

IFN TYMSW,<
	OSFAIL==<SIXBIT/TYMSHR/>
	PRINTS	/TYMSHARE VERSION
/>
SUBTTL AC'S, PDL'S, AND INITIAL CONSTANTS

;AC'S
;0 FOR FLAGS
T_1
FS_T+1
O_FS+1
N_4
NA_N+1
PN_NA+1
CP_7
B_10
C_B+1
L_12
TAC_13
BC_14
FC_15
M_16
P_17

ERPLEN__100			;NO. OF ERROR MESSAGES
SETSWX LINLEN,=120		;CHARACTERS/LINE
SETSWX LNPP,=60			;LINES/PAGE FOR MOST PEOPLE
IFN STANSW,<LNPP__=54>
CHRPL:	LINLEN			;CHaRacters Per Line - normally =120, but reduced
				;by eight for CREFFing. - JHS
HASH__=101			;HASH SIZE
PLEN__400

IFN DWPSW,{PLEN__2000}		;FOR MACRO EXPLOSIONS (I.E., LISP!)

CPLEN__200
RPGSW:	0
RPGNEED:0		;HACK FOR PEOPLE WHO LEAVE THE CRLF OFF THEIR COMMAND FILES
PDL:	BLOCK PLEN	;PDLOV ERR PRINT WILL OVERFLOW INTO CPDL
CPDL:	BLOCK CPLEN

LSTLAB:	BLOCK 5		;0=LAST LABEL DEFINED BY :
			;1=BLOCK NAME AT LAST :
			;2=LAST SYMBOL DEFIND BY : OR _
			;3=CURRENT BLOCK NAME
			;4=LOC OF LAST LABEL

PATCH:	BLOCK 20	;GOD FORBID ANYONE SHOULD EVER HAVE TO DEBUG THIS, BUT
PATCH1:	BLOCK 20	;HERE'S A LITTLE SPACE FOR YOU.
PATCH2:	BLOCK 20
PATCH3:	BLOCK 20


EFSLEN__500;LENGTH OF AREA FOR POLISH
EFS:	BLOCK EFSLEN

UNIVSW:	0			;SET TO -1 WHEN DOING UNIVERSAL PROGRAM
UNIVLH:	0			;LIST HEADER FOR THE UNIVERSALS
UNIVFF:	0			;FIRST FREE LOCATION ABOVE OU'S
UNIVBS:	0			;BASE OF THE OU'S
U.SYM:	0			;IN BEND, CHAIN OF SYMBOLS.
U.OPC:	0			;	  OPCODES
U.MAC:	0			;	  MACROS
US.S:	0			;ADDRESS OF "FREE STORAGE LIST" FOR SYMBOLS
US.M:	0			;	  FOR MACROS
US.O:	0			;	  FOR OPCODES

FUNSUP:	0			;SET TO -1 TO PREVENT .FUN FILE FROM BEING WRITTEN

IFE STANSW,<	NOTNX,<	NOITS,<INTTYF: 0 >>>

MACRT:	BLOCK HASH
SYMTAB:	BLOCK HASH
	0
LITPNT:	BLOCK HASH
	-1
LOB:	BLOCK 3
ODB:	BLOCK 3
OPCDS:	BLOCK HASH

TNX,<
DEFINE TSVAC (ACL) <
ZOT__0
FOR AC IN (ACL) <
	MOVEM	AC,TNXACS+ZOT
ZOT__ZOT+1
>>

DEFINE TRSTAC (ACL) <
ZOT__0
FOR AC IN (ACL) <
	MOVE	AC,TNXACS+ZOT
ZOT__ZOT+1
>>

TNXACS: BLOCK 4		;TEMP AC STORAGE FOR JSYS CALLS

MXCOR__762777			;MAX CORE AVAIL TO FAIL  (LEAVE RM FOR BUFFS, DDT)

;DEFINE BUFFER PAGES, ETC.
ZOT__763
FOR @' BUF IN (INDBF,LSTBF,BINBF,SRCBF) <
BUF'P__ZOT
BUF__BUF'P*1000
ZOT__ZOT+1
>
TRMP__ZOT
TRM__ZOT*1000
IBUF1_SRCBF

>;TNX

IFE STANSW,<
NOTNX,<
	0
IBUF1:	201,,IBUF2
	BLOCK 201+1
	0
IBUF2:	201,,IBUF3
	BLOCK 201+1
	0
IBUF3:	201,,IBUF4
	BLOCK 201+1
	0
IBUF4:	201,,IBUF5
	BLOCK 201+1
	0
IBUF5:	201,,IBUF1
	BLOCK 201+1
>;NOTNX
>;IFE STANSW

IFN STANSW,<
	0			;1 WORD FOR SYSTEM
IBUF1:	201,,.+204		;ANOTHER FOR SYSTEM
	BLOCK	203	;1 FOR SYS, 200 FOR DATA, 1 SPARE, 1 FOR SYS IN NEXT BUFFER
REPEAT =17,<	201,,.+204
		BLOCK	203	>;REPEAT =17
	201,,IBUF1
	BLOCK	202
>;

ITS,<
SRCSTS:	BLOCK 10	;FOR CHANNEL STATUS
>;ITS

IDB:	0
INPNT:	BLOCK 2

;MACRO TO MARK CURRENT PC AS LEGAL PLACE FOR MPV INTERRUPT
DEFINE LEG{FOR @! X_LEGNUM,LEGNUM{^^%$L!X::}^^LEGNUM__LEGNUM+1 }
LEGNUM__0

	DEFINE DELHN <
	DPB	B,LSTPNT	;PUT ZERO OVER DELETE
	ILDB	C,INPNT		;GET NEXT
	XCT	DELTAB(C)	;HANDLE
	ILDB	C,INPNT		;GET NEXT
	DPB	C,LSTPNT	;DEPOSIT FOR LIST >

	DEFINE GFST(A,B)
<	SKIPN A,B
	JSR NOFSL
>

;SRC1: SEARCH SYMBOL TABLE CHAIN
;	A= AC CONTAINING SIXBIT SYMBOL NAME
;	B= CONTAINS FIRST ADDR OF HASH CHAIN
;	C= ADDRESS TO JRST TO ON SUCCESS
;	D= INSTR. TO XCT IF YOU LOSE.
;	ASSUMES 2ND WORD OF SYMBOL ENTRY IS FULL WORD OF LINK TO NEXT ENTRY

	DEFINE SRC1 (A,B,C,D)
<	CAMN A,(B)
	JRST C
	SKIPN B,1(B)
	D
	CAMN A,(B)
	JRST C
	SKIPN B,1(B)
	D
	JRST .-10
>

;SRC2: SEARCH SYMBOL TABLE CHAIN.
;	A= AC CONTAINING 6BIT SYMBOL NAME
;	B= AC CONTAINING FIRST ADR. OF HASH CHAIN.
;	C= ADDRESS TO JUMP TO IF YOU FIND IT
;	D= INSTR TO XCT IF YOU FAIL, IF BLANK, FALL THROUGH.
;	ASSUMES 2ND WORD OF SYMBOL ENTRY CONTAINS RIGHT HALF LINK TO NEXT

	DEFINE SRC2 (A,B,C,D)
<	CAMN A,(B)
	JRST C
	HRRZ B,1(B)
	JUMPN B,.-3
	D
>

	DEFINE ACALL	;TO CALL ASSMBL
<	PUSHJ P,[POPJ CP,]>
	DEFINE RETN	;TO RETURN FROM ASSMBL
<	PUSHJ CP,[PUSH CP,[ASSMBL]
		POP CP,-2(CP)
		POPJ P,]>
	DEFINE EDEPO (AC,PNT,NUM)
<	MOVEI AC,177
LEG	IDPB AC,PNT
	MOVEI AC,NUM
LEG	IDPB AC,PNT
>
	DEFINE RVALUA	;TO CALL REVAL
<	PUSH P,[16]
	PUSHJ P,REVAL
	MOVE FS,(P)
	TRZE POLERF
	SETZM (FS)
>

IFN CMUSW,<
OPDEF	CMUDEC	[CALLI -2]
OPDEF	DECCMU	[CALLI -3]
>

TNX,<
OPDEF	OUTSTR	[7B8]
OPDEF	OUTCHR	[10B8]
OPDEF	UMOVE	[100B8]		;OPDEFS FOR TENEX
OPDEF	UMOVEI	[101B8]
OPDEF	UMOVEM	[102B8]
OPDEF	UMOVES	[103B8]
OPDEF	JSYS	[104B8]
NOT20,<IFE PSTISW,< DEFINE PSTIN <JSR .PSTIN> >;IFE PSTISW>;NOT20
>;TNX

OPDEF ERROR[11B8]
OPDEF FATAL[12B8]
OPDEF FOUT[13B8]
OPDEF OUTP[14B8]
OPDEF POUT[15B8]
OPDEF TRAN[16B8]
OPDEF BBOUT[17B8]
OPDEF CREF6 [20B8]
OPDEF CREF66 [21B8]
OPDEF CREF7 [22B8]

ITS,<
OPDEF USETI [74B8]
OPDEF RELEASE [71B8]
OPDEF CLOSE [70B8]
OPDEF TTYUUO [51B8]
OPDEF PTYUUO [711B8]
OPDEF CALLI [47B8]
OPDEF INIT [41B8]
OPDEF LOOKUP [76B8]
OPDEF ENTER [77B8]
OPDEF IN [56B8]
OPDEF OUT [57B8]
OPDEF INPUT [66B8]
OPDEF OUTPUT [67B8]
OPDEF INBUF [64B8]
OPDEF OUTBUF [65B8]
OPDEF STATO [61B8]
OPDEF STATZ [63B8]
OPDEF GETSTS [62B8]
OPDEF MTAPE [72B8]

OPDEF TTCALL [TTYUUO]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF INCHRS [TTYUUO 2,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF GETLIN [TTYUUO 6,]
OPDEF SETLIN [TTYUUO 7,]
OPDEF RESCAN [TTYUUO 10,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF CLRBFO [TTYUUO 12,]
OPDEF INSKIP [TTYUUO 13,]
OPDEF INWAIT [TTYUUO 14,]

OPDEF DEVCHR [CALLI 4]
OPDEF APRENB [CALLI 16]

OPDEF DSKPPN [CALLI 400071]
OPDEF PTWR1S [PTYUUO 7,]
OPDEF PTWRS9 [PTYUUO 12,]

IFNOP .OPEN,<

OPDEF .OPEN [41000,,0]
OPDEF .IOT [40000,,0]
OPDEF .CORE [43300,,0]	;43 6,0
OPDEF .RESET [42000,,37]
OPDEF .SUSET [43540,,0]	;43 13,0
OPDEF .DISMI [43040,,0]	;43 1,0
OPDEF .VALUE [43200,,0]	;43 4,0
OPDEF .CLOSE [42000,,7]
OPDEF .RDATE [42000,,46]
OPDEF .RTIME [42000,,45]
OPDEF .RCHST [42000,,103]
OPDEF .IOPUSH [42000,,13]
OPDEF .IOPOP [42000,,14]
OPDEF .GETSYS [42000,,23]
OPDEF .EVAL [42000,,73]

.SMASK_400006
.SSNAM_400016
.RMEMT__12
OPTCMD__40000	;BIT IN .OPTION THAT SAYS COMMAND TO BE READ
>;IFNOP .OPEN

INTERNAL GBOUT1
EXTERNAL STKTRN

;DDT COMMAND GOODIES

DDTCMD:	0	;DDT COMMAND FLAG

>;ITS

notnx,<
IFE STANSW,<
NOTNX,<		OPDEF	RESET	[CALLI	0]	>;NOTNX
TNX,<		OPDEF	RESET	[104000000147]	>;TNX

OPDEF	DEVCHR	[CALLI	4]
OPDEF	CORE	[CALLI	11]
OPDEF	EXIT	[CALLI	12]
OPDEF	UTPCLR	[CALLI	13]
OPDEF	DATE	[CALLI	14]
OPDEF	APRENB	[CALLI	16]
OPDEF	MSTIME	[CALLI	23]
OPDEF	PJOB	[CALLI	30]
OPDEF	RUN	[CALLI	35]
OPDEF	TMPCOR	[CALLI	44]
>;IFE STANSW
>;notnx

EXTERN .JBREL,.JBFF,.JBSA,.JBAPR,.JBTPC,.JBCNI

SNB__400000	;VERY HANDY NUMBER WHICH ONE GETS TIRED OF TYPING

LABLTP:	0
LABLTC:	0
LSTPNT:	0

IBUFR1_IBUF1
BLOCK:	1
DBLCK:	XWD DAF,-1

PCNT:	BLOCK 2		;LEAVE CONTIGUOUS & IN THIS ORDER
OPCNT:	BLOCK 2
WRD:	BLOCK 2
DPCNT:	BLOCK 2
	
NOTNX,<
;FILE-STACK
;0/ DEVICE
;1/ FILE
;2/ EXT
;3/ OLD INPNT (USELESS EXCEPT IF EXPANDING MACRO)
;4/ PPN
;5/ PAGE,,RECORD
;6/ TVFILE,,INLINE
;7/ ADDRESS OF FILE-INPNT (POINTS INTO MACRO-PDL SOMETIMES, OR TO INPNT)

FILSTL__10			;LENGTH OF EACH FILE-STACK ENTRY
>;NOTNX

TNX,<
;FILE-STACK
;0/ JFN (SGN BIT SET IF PMAPPABLE)
;1/ OLD INPNT
;2/ USER PAGE,,FILE PAGE
;3/ TVFILE,,INLINE
;4/ ADDR OF FILE-INPNT

FILSTL__5
>;TNX

FILSTK:	BLOCK FILSTL*10	;FILE-STACK - ROOM FOR 8 LEVELS OF FILE NESTING
FILSTP:	FILSTK		;POINTER TO NEXT AVAILABLE "ENTRY" IN FILE-STACK
FILSTC:	0		;STACK DEPTH
IRECN:		0		;RECORD NUMBER IN THE CURRENT INPUT FILE.
INPNTP:	INPNT		;INPNT-POINTER.  ALWAYS POINTS TO FILE-INPNT
ERCNT:		0		;COUNT OF ERRORS ON THIS LINE.

DEFINE PSHPNT(AC)<
	PUSH	M,INPNTP	;POINTER TO FILE-INPNT
	PUSH	M,INPNT		;INPUT BYTE POINTER
	MOVE	AC,INPNTP
	CAIN	AC,INPNT
	HRRZM	M,INPNTP	;NEW VALUE IF WE JUST PUSHED FILE-INPNT
>
SUBTTL DEFINITION OF FLAGS   FLAGS  FLAGS
;AC 0 IS FLAG REGISTER
;AC 0 FLAGS (LEFT HALF):

SFL__200000	;SCANNER AHEAD ONE CHR.
IFLG__100000	;SCAN SAW IDENT
NFLG__40000	;SCAN SAW NUMBER
SCFL__20000	;SCAN SAW SPC.CHR.
FLTFL__10000	;SCAN -- FLOATING POINT NUMBER
ESNG__4000	;EVAL SAW ONLY SINGLE THING
ESPF__2000	;EVAL SAW ONLY SPC CHR
REUNBF	__1000	;REVAL TEMP BIT -- UNBAL PARENS
OPFLG__400	;AN OPCODE WAS SEEN
RELEF__200	;REDUC -- RELOC ERROR
SOPF__100	;SCANS -- OPCODE FOUND
PSOPF__40	;SCANS -- PSEUDO-OP FOUND
MLFT__20	;LEFT HALF FIXUPS SHOULD BE GENERATED
UNDF__10	;MEVAL -- UNDEF.
PAWF__4	;PARENS AROUND WHOLE -- MEVAL
AUNDF__2	;ASSMBL -- PART IS UNDEFINED

;RIGHT HALF BITS:

NOFXF__200000	;MEVAL -- DONT GENERATE FIXUPS
IOSW__100000	;ASSMBL -- IO OPCODE
BDEV__40000	;BIN DEVICE EXISTS
LDEV__20000	;LIST DEVICE EXISTS
BLOSW__10000	;TEMP BIT FOR LISTING SYNC
ADFL__4000	;TEMP BIT USED BY ASSMBLE TO KEEP TRACK OF # OF ADRSES
FLFXF__2000	;USED BY ASSMBL TO TELL MEVAL TO MAKE FULL WORD FIXUPS
TRBF__1000	;ASSMBL -- TERMINATED BY ]
POLERF__400	;POLISH ERROR
MACUNF__200	;A MACRO WAS ENTERED (FOR UNDERLINING)
RWARN1==100	;BAD DIGIT IN NUMBER SCAN WARNING
RWARN2==40	;BAD DIGIT IN NUMBER SCAN WARNING
IOFLGS__BDEV!LDEV!BLOSW	;FLAGS PERTAINING TO I/O

;THE FOLLOWING ARE BITS USED TO IDENTIFY CHARACTERS IN THE TABLE
;LEFT HALF BITS:
;SNB OR 400000 (SIGN) ;NUMBER OR LETTER
NMFLG__200000	;NUMBER
SPFL__100000	;SPACE(TAB)
SPCLF__40000	;ANY SPC. CHR.
ARFL__20000	;ARITH OPERATOR
ARMD__10000	;ARITH OP MODIFIER (-,/,&,,UN -)
ARMD1__4000	;ADDITIONAL MODIFIER
UNOF__2000	;UNARY OP (- , ^E (NOT))
BFL__1000	;B
EFL__400	;E
DLETF__200	;DELETE
CRFG__100	;CR RET
LBRF__40	;< OR [
RBRF__20	;> OR ]
.FL__10	;.
LNFD__4	;LINE FEED
ENMF__2	;INDICATES THAT ANY STRING STARTING WITH
		;THIS CHR. WILL BE SCANNED AS A NUMERICAL VALUE
SCRF__1	;SPC.CHR. REQUIRING HANDLING BY SCANNER


;THE FOLLOWING ARE RIGHT HALF BITS

SHRPF__400000	;#
BSLF__200000	;\ (BACKSLASH) ()
UDARF__100000	;^ OR DOWN-ARROW
LACF__40000	;_ OR :
COMF__20000	;,
LFPF__10000	;(
RTPF__4000	;)
ATF__2000	;@
RBCF__1000
LBCF__400
INF__200	;
EPSF__100	;
TP2F__2	;SUB-CLASS 2
TP1F__1	;SUB-CLASS 1

;THE FOLLOWING ARE NUMBER (FLAG PART) BITS USED TO TELL
;	ABOUT NUMBERS AND SYMBOLS
;LEFT HALF:
DEFFL__200000	;UNDEFINED IF ON
VARF__100000	;"VAR"--(DEFINED WITH #)
INCF__20000	;"IN CORE" VALUE (IN ASSEMBLER CORE)
UPARF__10000	;UP ARROW (SYMBOL ONLY)
DAF__4000	;DOWN ARROW(SYMBOL ONLY)
DBLF__2000	;DOUBLE _ (__) (SYMBOL ONLY)
GLOBF__1000	;GLOBAL
INTF__400	;INTERNAL
EXTF__200	;EXTERNAL
UDSF__100	;SYMBOL HAS BEEN DEFINED WITH AN UNDEFINED DEFINITION
SYMFIX__40	;WE NEED A SYMBOL TABLE FIXUP FOR THIS SYMBOL
DBLUPF__20	;THIS IS A DOUBLE UPARROWED SYMBOL (SYMBOL ONLY);;;;
COLONF__10	;SYM WAS DEFINED WITH :
REFBIT__4	;SYM HAS BEEN REFERENCED
ITS,<ANONF__2>	;THIS SYMBOL ANONYMOUS TO LOADER
SUPBIT__1	;THIS BIT IS ON TO SUPPRESS SUPERFLUOUS DEFINITIONS

;RIGHT HALF HAS BITS FOR LEVELS AT WHICH DEFINED.

NOLIT

;RANDOM CONSTANT MEMORY CELLS

CPOPJ1:	AOS	(P)
CPOPJ:		POPJ	P,

NOTNX,<TTCRLF:>
IFN TOPS20,<TTCRLF:	>
CRLF:		BYTE(7)15,12

IFE TOPS20,,<TNX,<	TTCRLF:BYTE(7)37>>

STAR:		BYTE(7)15,12,"*"
BEGIN OPTBL  SUBTTL THE OPCODE TABLE
GLOBAL HASH
xall
	FOR @$ I_0,HASH-1
<	IBQ$I_0
>
	DEFINE ENT $(A,B,C)
<	XLIST
	IBQ_'A'-'A'/HASH*HASH
	IFL IBQ,<IBQ_-IBQ>
	EN1(A,\IBQ,B,C)
	LIST
>

;GOBBLE BIT 14 TO SIGNIFY CALLI (AT CMU)
	DEFINE EN1 $(A,B,C,D)
<	'A'
	IFIDN <>,<C>,<A IBQ$B>
	IFDIF <>,<D>,<777767,,IBQ$B>
	IFDIF <>,<C>,<IFIDN <>,<D>,<C$IBQ$B>>
	IBQ$B_.-2
	IFDIF <>,<D>,<D
C>
	>
	DEFINE EMO(A)
<	FOR @$ B IN(A)
<	ENT(B)
	ENT(B$I)
	ENT(B$M)
	ENT(B$S)
>
>

IFE STANSW!ITSSW,<
	DEFINE ECALLI $ (A,NUM)			;NEEDED FOR DEC SYSTEMS
<	ENT(A,NUM$B12+10B17+)
>>


	DEFINE ERG(A)
<FOR @$ Q IN (A)
<ENT(Q$B)
ENT(Q$I)
ENT(Q$M)
ENT(Q)
>
>

;THE EARLIER AN ENTRY APPEARS HERE, THE LONGER IT TAKES TO FIND IN SEARCHES

IFN KI10SW,<	ENT(ADJSP,105B8+)		;OPCODES FOR KL10 PROCESSOR TOO
		ENT(ADJBP,<<IBP 0,>>)			;IDIOT ALTERNATE NAME
		ENT(DFAD,110B8+)		;OPCODES FOR KI10 PROCESSOR
		ENT(DFSB,111B8+)
		ENT(DFMP,112B8+)
		ENT(DFDV,113B8+)
		ENT(DADD,114B8+)
		ENT(DSUB,115B8+)
		ENT(DMUL,116B8+)
		ENT(DDIV,117B8+)
		ENT(DMOVE,120B8+)
		ENT(DMOVN,121B8+)
IFE STANSW,<	ENT(FIX,122B8+)	;>	ENT(KIFIX,122B8+)	;DIFFERENT NAME
		ENT(EXTEND,123B8+)
		ENT(DMOVEM,124B8+)
		ENT(DMOVNM,125B8+)
		ENT(FIXR,126B8+)
		ENT(FLTR,127B8+)
		ENT(PORTAL,<<JRST 1,>>)
		ENT(MAP,257B8+)			>;IFN KI10SW

TNX,<
		ENT(ASSIGN,0,%ASSIG)		;ASSIGN PSEUDO-OP
T20,<
	ENT(ERJMP,<<JUMP 16,>>)
	ENT(ERCAL,<<JUMP 17,>>)
>;T20


>				;IFN TENEX

ENT (.WCTAB,0,%WCTAB)			;.WCTAB CHAR,VAL
ENT (.RCTAB,0,%RCTAB)			;.RCTAB CHAR
ENT (.COMMO,0,%COMMN)			;.COMMON  - FOR MACRO-10 
ENT (.ASSIG,0,%ASSIG)			;.ASSIGN PSEUDO-OP - SAME AS FOR TENEX
ENT (.TEXT,2,%ASCII)			;.TEXT FOR LINK-10
ENT (.DIREC,0,%DIREC)			;.DIRECTIVE LIKE IN MACRO-10
ENT (.FATAL,0,%FATAL)
ENT (GDEFIN,0,%GDEF)			;LIKE ^^DEFINE
ENT (PRINTX,0,%PRNTX)
ENT (PRINTS,0,%PRNTC)
ENT (SEARCH,0,%SEAR)
ENT (UNIVER,0,%UNIV)
ENT (SUPPRE,0,%SUPPR)
ENT (ASUPPR,0,%ASUPP)
ENT (XPUNGE,0,%XPUNG)
ENT (PURGE,0,%PURGE)
ENT (.LIBRA,17,%LBLCK)
ENT (.LOAD,16,%LBLCK)
ENT (.REQUE,17,%LBLCK)			;.REQUEST LIKE .LIBRARY
ENT (.REQUI,16,%LBLCK)			;.REQUIRE LIKE .LOAD
ERG (<SETM,SETA>)
ENT (PHASE,0,PHAZ)
ENT (DEPHAS,0,DPHAZ)
ENT (PZE, ,)
ENT (PAGE,0,%PAGE)
ENT (SUBTTL,0,%SUB)
ENT (RADIX,0,%RADIX)
ENT (TITLE,0,%TITLE)
ENT (END,9,%END)
ENT (PRGEND,0,%PRGEN)
	DEFINE IO(A)
<FOR B IN(A)
<ENT (B,B,%IO)
	>
>
IO(<CONSO,CONSZ,BLKI,BLKO,DATAI,DATAO,CONI,CONO>)
FOR @$ QRN IN (USE,SET,NOSYM,LIT,VAR,LIST,LALL)
<ENT(QRN,0,%$QRN)
>
ENT(XLIST,-1,%LIST)
ENT(XALL,-1,%LALL)
ENT(XLIST1,1,%LIST)
ENT(LOC,0,%ORG)
ENT(RELOC,-1,%ORG)
ENT(ORG,1,%ORG)
ENT(.ORG,1,%ORG)			;.ORG - SAME AS ORG
	DEFINE ENQ(A)
<	FOR B IN(A)
<ENT(B)
>
>

IFE STANSW!ITSSW,<
ENQ(<CALL,INIT,ENTER,LOOKUP,USETO,USETI,UGETF,MTAPE,RELEAS>)
ENQ(<CLOSE,OUTBUF,INBUF,CALLI,STATO,STATZ,GETSTS,SETSTS>)
ENQ(<INPUT,OUTPUT>)
>	;IFE STANSW!ITSSW

NOTNX,<
IFE STANSW!ITSSW,<	;THE FOLLOWING ARE FOR ALL DEC SYSTEMS
$IBQ_-1
FOR ZOT IN (<LIGHTS>
,RESET,DDTIN,SETDDT,DDTOUT,DEVCHR,DDTGT,GETCHR,<DDTRL>
,WAIT,CORE,EXIT,UTPCLR,DATE,LOGIN,APRENB,<LOGOUT>
,SWITCH,REASSI,TIMER,MSTIME,GETPPN,TRPSET,TRPJEN,<RUNTIM>
,PJOB,SLEEP,SETPOV,PEEK,GETLIN,RUN,SETUWP,<REMAP>
,GETSEG,GETTAB,SPY,SETNAM,TMPCOR,DSKCHR,SYSSTR,<JOBSTR>
,STRUUO,SYSPHY,FRECHN,DEVTYP,DEVSTS,DEVPPN,SEEK,<RTTRP>
,LOCK,JOBSTS,LOCATE,WHERE,DEVNAM,CTLJOB,GOBSTR,<>
,<>,HPQ,HIBER,WAKE,CHGPPN,SETUUO,DEVGEN,<OTHUSR>
,CHKACC,DEVSIZ,DAEMON,JOBPEK,ATTACH,DAEFIN,FRCUUO,<DEVLNM>
,PATH.,METER.,MTCHR.,JBSET.,POKE.,TRMNO.,TRMOP.,<RESDV.>
,UNLOK.,DISK.,DVRST.,DVURS.)
<IFDIF <>,<ZOT>,<ECALLI(ZOT,\$IBQ)>
$IBQ_$IBQ+1
>

>;IFE STANSW!ITSSW
>;NOTNX

TNX,<
;THIS ONE RESOLVES JSYS/CALLI CONFLICTS IN FAVOR OF THE JSYS
;PROBLEMS WITH RESET,WAIT,LOGIN,DEVNAM,PEEK
IFE STANSW!ITSSW,<	;THE FOLLOWING ARE FOR ALL DEC SYSTEMS
$IBQ_-1
FOR ZOT IN (<LIGHTS>
,<>,DDTIN,SETDDT,DDTOUT,DEVCHR,DDTGT,GETCHR,<DDTRL>
,<>,CORE,EXIT,UTPCLR,DATE,<>,APRENB,<LOGOUT>
,SWITCH,REASSI,TIMER,MSTIME,GETPPN,TRPSET,TRPJEN,<RUNTIM>
,PJOB,SLEEP,SETPOV,<>,GETLIN,RUN,SETUWP,<REMAP>
,GETSEG,GETTAB,SPY,SETNAM,TMPCOR,DSKCHR,SYSSTR,<JOBSTR>
,STRUUO,SYSPHY,FRECHN,DEVTYP,DEVSTS,DEVPPN,SEEK,<RTTRP>
,LOCK,JOBSTS,LOCATE,WHERE,<>,CTLJOB,GOBSTR,<>
,<>,HPQ,HIBER,WAKE,CHGPPN,SETUUO,DEVGEN,<OTHUSR>
,CHKACC,DEVSIZ,DAEMON,JOBPEK,ATTACH,DAEFIN,FRCUUO,<DEVLNM>
,PATH.,METER.,MTCHR.,JBSET.,POKE.,TRMNO.,TRMOP.,<RESDV.>
,UNLOK.,DISK.,DVRST.,DVURS.)
<IFDIF <>,<ZOT>,<ECALLI(ZOT,\$IBQ)>
$IBQ_$IBQ+1
>
>;IFE STANSW!ITSSW
>;TNX

IFN CMUSW,<	;THE FOLLOWING ARE FOR CMU ONLY !
$IBQ_-2
FOR ZOT IN (CMUDEC,DECCMU,MSGSND,MSGPOL,JENAPR,<UNLOCK>
,STOP,TIME,UNTIME,RSTUUO,INT11,LNKRDY,PRIOR,IMPUUO)
<IFDIF <>,<ZOT>,<ECALLI(ZOT,\$IBQ)>
$IBQ_$IBQ-1
>
>;IFN CMUSW

ENT(INTERN,0,%INT)
ENT(.GOPDE,0,%GOPDE)
ENT(OPDEF,0,%OPDEF)
ENT(ENTRY,0,%ENTRY)
ENT(LINK,0,%LINK)
ENT(LINKEN,0,%ENDL)
ENT(.LINK,0,%LINK)		;.LINK - LIKE LINK
ENT(.LNKEN,0,%ENDL)		;.LNKEND - LINKEND
ENT(RADIX5,0,%RAD5)
ENT(CREF,0,%ONCRF)
ENT(XCREF,0,%OFCRF)
ENT(NOLIT,0,%NOLIT)
ENT(ARRAY,0,%ARAY)
ENT(INTEGE,0,%INTEG)
ENT(GLOBAL,0,%GLOB)
	DEFINE MAT $(B)
<ENQ(<B$N,B$NE,B$NN,B$NA,B$O,B$ON,B$OE,B$OA>)
ENQ(<B$Z,B$ZE,B$ZN,B$ZA,B$C,B$CN,B$CE,B$CA>)
>

MAT(TS)
FOR @$ C IN(FAD,FSB,FMP,FDV)
<ENQ(<C,C$L,C$M,C$B,C$R,C$RL,C$RM,C$RB>)
>
ENQ(<AOBJN,AOBJP,FSC,IBP,BLT,JFCL,XCT>)
ENT(TTCALL,51B8+)
IFN STANSW,<
ENT(DPYOUT,703B8+)
ENT(INTJEN,723B8+)		;AN ALTERNATIVE TO INTDEJ
>
IFE STANSW<
ENT(OPEN,50B8+)
ENT(RENAME,55B8+)
ENT(TTYUUO,51B8+)
ENT(INCHRW,<<TTCALL 0,>>)
ENT(OUTCHR,<<TTCALL 1,>>)
ENT(INCHRS,<<TTCALL 2,>>)
ENT(OUTSTR,<<TTCALL 3,>>)
ENT(INCHWL,<<TTCALL 4,>>)
ENT(INCHSL,<<TTCALL 5,>>)
ENT(GETLIN,<<TTCALL 6,>>)
ENT(GETLCH,<<TTCALL 6,>>)	;DEC MNEMONIC
ENT(SETLIN,<<TTCALL 7,>>)
ENT(SETLCH,<<TTCALL 7,>>)	;DEC MNEMONIC
ENT(RESCAN,<<TTCALL 10,>>)
ENT(CLRBFI,<<TTCALL 11,>>)
ENT(CLRBFO,<<TTCALL 12,>>)
ENT(INSKIP,<<TTCALL 13,>>)
ENT(SKPINC,<<TTCALL 13,>>)	;ALTERNATE MNEMONIC
ENT(SKPINL,<<TTCALL 14,>>)	;DEC MNEMONIC
ENT(IONEOU,<<TTCALL 15,>>)	;NEW DEC TTCALL
ENT(IN,56B8+)
ENT(OUT,57B8+)
>	;IFE STANSW

ENT(JFFO,243B8+)
ENT(UFA,130B8+)
ENT(DFN,131B8+)
ENT(FADRI,145B8+)
ENT(FSBRI,155B8+)
ENT(FMPRI,165B8+)
ENT(FDVRI,175B8+)

IFN STANSW,<	ENT(KAFIX,247B8+)	>;IFN STANSW

ENT(JEN,<<JRST 12,>>)
ENT(HALT,<<JRST 4,>>)
ENT(JRSTF,<<JRST 2,>>)
ENT(JFOV,<<JFCL 1,>>)
ENT(JOV,<<JFCL 10,>>)
ENT(JCRY,<<JFCL 6,>>)
ENT(JCRY0,<<JFCL 4,>>)
ENT(JCRY1,<<JFCL 2,>>)
ENT(DEFINE,0,%DEF)
ENT(HISEG,0,%HISEG)
ENT(TWOSEG,0,%TWOSEG)
ENT(REPEAT,0,%REP)
ENT(FOR,0,%FOR)
ENT(POINT,0,%POINT)
ENT(BYTE,0,%BYTE)
ENT(OCT,10,%CON)
ENT(DEC,12,%CON)
ENQ(<JSP,JSA,JRA,ASH,ASHC,ROT,ROTC>)
ERG(<ANDCB,ORCM,ORCB,ORCA>)
MAT(TD)
DEFINE MAH $(A)
<EMO(<HRR$A,HRL$A,HLR$A,HLL$A>)
>
MAH(E)
MAH(O)
ERG(<AND,ANDCA,ANDCM,EQV,SETCA,SETCM,SETO,OR,IOR,XOR>)
ERG(<IMUL,MUL,DIV,IDIV>)
ENT(COMMEN,0,%COMMT)
ENT(EXTERN,0,%EXT)
DEFINE JSK(A)
<FOR @$ Q IN(A)
<ENQ(<Q,Q$L,Q$LE,Q$G,Q$GE,Q$N,Q$E,Q$A>)
>
>
JSK(<AOJ,SOJ,AOS,SOS>)

TNX,<	ENT(JSYS)
		EMO(UMOVE)	>

ENT(JSR)
JSK(CAM)
MAH()
JSK(CAI)
ENQ(<LDB,DPB,ILDB,IDPB>)
EMO(<MOVS,MOVM,MOVN>)
ERG(SETZ)
ENT(BLOCK,0,%BLOCK)
ENT(EXCH)
MAH(Z)
ENT(BEGIN,0,%BEG)
ENT(BEND,0,%BEND)
JSK(SKIP)
ERG(SUB)
ENQ(<LSH,LSHC>)
ERG(ADD)
JSK(JUMP)
MAT(TR)
MAT(TL)
ENQ(<PUSH,POP,POPJ,PUSHJ>)
ENT (ASCII,0,%ASCII)
ENT (ASCIZ,1,%ASCII)
ENT (ASCID,-1,%ASCII)
ENT(SIXBIT,0,%SIX)
ENT(XWD,0,%XWD)
EMO(MOVE)
ENT(JRST)
IFN TYMSW,<ENT(AUXCAL,42B8+)
ENT(CHANIO,43B8+)
ENT(OUTPTR,<<TTCALL 17,>>)
ENT (OUTCHI,<<TTCALL 16,>>)
ENT (IONEOU,<<TTCALL 15,>>)
ENT (SKPINL,<<TTCALL 14,>>)
ENT (SKPINC,<<TTCALL 13,>>)
$IBQ_-60
FOR ZOT IN (XCHARG,SETFRC,TYMCHG,DATUUO,DDT620,VALRMT,<INTRMT>
,IDLRMT,ZAPRMT,CRERMT,AUXRED,ZAPCIR,CREAUX,REDPIP,TINASS,SETTR2,<SETTR1>
,SETTIM,INTASS,INTACT,INTENB,INTADR,HANG,CHKLIC,LEVDEF,MOVBUF,<SETMOD>
,RUNSEG,SYSDVF,DISMIS,DSKCLR,SETJAL,ONEJOB,SETMAL,GETTMC,<SETTMC>
,REDNXT,WAITCH,POKE,SETPRV,SETLIC,SETE,ATTACH,<>,<>,<>,<>,<LIGHTS>
,RESET,DDTIN,SETDDT,DDTOUT,DEVCHR,DDTGT,GETCHR,DDTRL,WAIT,CORE,<EXIT>
,UTPCLR,DATE,LOGIN,APRENB,LOGOUT,SWITCH,REASSI,TIMER,MSTIME,<GETPPN>
,TRPSET,TRPJEN,RUNTIM,PJOB,SLEEP,SETPOV,PEEK,GETLIN,RUN,<SETUWP>
,REMAP,GETSEG,GETTAB,SPY,SETNAM,TMPCOR,DSKCHR,SYSSTR,JOBSTR,<STRUUO>
,SYSPHY,FRECHN,DEVTYP,DEVSTS,DEVPPN,SEEK,RTTRP,LOCK,JOBSTS,<LOCATE>
,WHERE,DEVNAM,CTLJOB,GOBSTR,<>,<>,HPQ,HIBER,WAKE,CHGPPN,<SETUUO>
,DEFGEN,OTHUSR,CHKACC,DEVSIZ)
<IFDIF <>,<ZOT>,<ECALLI(ZOT,\$IBQ)>
$IBQ_$IBQ+1
>> ;TYMSW

;ASSEMBLE TABLE OF OPCODES THAT HAVE BEEN DEFINED THUS FAR
^OPCDS1:FOR @$ I_0,HASH-1
<IBQ$I
>
FOR @$I_0,HASH-1
<IBQ$I_0
>
DEFINE MENT (AR,BR,QR)
<'AR'
IBQ_'AR'-'AR'/HASH*HASH
IFL IBQ,<IBQ_-IBQ>
MENQ (\IBQ)
0
XWD -1,BR
QR
	>
DEFINE MENQ $(A)
<IBQ$A
IBQ$A_.-2
>
FOR ROM IN (<IFE,2>,<IFG,7>,<IFN,6>,<IFL,1>,<IFGE,5>,<IFLE,3>)
<MENT (ROM,Q%IF)
>
FOR FOO IN (<IFIDN,-1,Q%IFD>,<IFDIF,0,Q%IFD>
	,<IFB,-1,Q%IFB>,<IFNB,0,Q%IFB>
	,<IFDEF,-1,QIF%D>,<IFNDEF,0,QIF%D>
	,<IFAVL,-1,QIF%A>,<IFNAVL,0,QIF%A>
	,<IFMAC,-1,QIF%M>,<IFNMAC,0,QIF%M>
	,<IFOP,-1,QIF%O>,<IFNOP,0,QIF%O>)
	<MENT(FOO)
>
^%IOWD:	'IOWD'
IBQ_'IOWD'-'IOWD'/HASH*HASH
MENQ (\IBQ)
0
2
.+1
%IOWD
ASCII/ XWD /
BYTE (7)"-","(",177,1,0,")",",",177,1,1,"-","1",40,177,3
FOR @! X IN(.,$.)
<	'X'
IBQ__'X'-'X'/HASH*HASH
MENQ \IBQ
0
-2,,SCAN!X
SCNMPT
>

'.FNAM1'				;ENTRIES FOR .FNAM1, .FNAM2 PSEUDO-MACROS
IBQ_'.FNAM1'-'.FNAM1'/HASH*HASH
MENQ \IBQ
0
-1,,%FNM1
SCNMPT

'.FNAM2'	
IBQ_'.FNAM2'-'.FNAM2'/HASH*HASH
MENQ \IBQ
0
-1,,%FNM2
SCNMPT


' .CPU.'				;.CPU. IS ALSO A PSEUDO-MACRO
IBQ_' .CPU.'-' .CPU.'/HASH*HASH
MENQ \IBQ
0
-1,,%CPU
SCNMPT

'.OSFAI'				;.OSFAIL PSEUDO-MACRO
IBQ_'.OSFAI' - '.OSFAI'/HASH*HASH
MENQ \IBQ
0
-1,,%OSFAI
SCNMPT

'.INSER'				;ENTRY FOR .INSERT AS A PSEUDO-MACRO
IBQ_'.INSER'-'.INSER'/HASH*HASH
MENQ \IBQ
0
-1,,0
%INSER


;GENERATE TABLE OF PREDFINED MACROS (INCLUDES IFS, IOWD, "." AND "$.")
^MACRT1: FOR @$ I_0,HASH-1
<IBQ$I
>

COMMENT %
		FAIL symbol table format		REG  3-18-74

There are three symbol tables: SYMTAB, MACRT, and OPCDS.  These store
user-defined symbols, macros, and opcodes.  SYMTAB is empty at the start
of an assembly.  MACRT and OPCDS are initialized from MACRT1 and OPCDS1
which contain FAIL's initial symbol table, including the definition of
all opcodes, pseudo-ops, IFs, IOWD, etc.  Also, the Stanford version adds
the Stanford CALLIs and IOT uuos to OPCDS1.

Every symbol table entry contains at least two words.  The first word
is the right-adjusted sixbit for the symbol name.  The right half of
the second word contains a pointer to the next symbol table entry, or
zero.   The symbol table entries are hash coded.  The hash function
is ABS(REM(sixbit symbol name, hash table length)).

OPCDS
	1. initialized from OPCDS1 - permanent definitions
	2. Added to by OPDEF pseudo-op
	3. user-defined opcodes are deleted at block-exit.
	   opcodes are written into the REL file.

	4. Entry format:
		0:  Symbol name in right-adjusted sixbit
		1:  code,,link to next
		if code has bits 13 and 14 off, then code,,0 is the value
		if code has bit 14 on then it is a predefined CALLI
		if code has bit 0 on, it is a pseudo-op
		otherwise, it is a user-defined opdef.

	  CALLIs:  at Stanford, bits 0-12 are the calli index, except
		if that field exceeds UCLDLN, add SLCOFF to it.
		at CMU, ASH bits 0-12 right 23 bits for the calli number.

	  Pseudo-ops: four word entries, others are:
		2: 0,,address of processing routine
		3: value (i.e., argument)

	  Opdefs: five word entries, others are:
		2: Block bit
		3: Value
		4: flags
	      

MACRT
	1. initialized from MACRT1 - permanent definitions
	2. Added to by DEFINE pseudo-op
	3. User macros are deleted at block-exit
	4. Entry format:
		0:  Macro name, right adjusted sixbit
		1:  0,,link to next
		2:  0
		3:  code,,number of arguments
		4:  processing address or definition string
		    code is negative for a macro-pseudo op:
			processing address is a dispatch. If bit
			17 is off, CREF information will not be emitted
			(for "." and "$.").  For "." and "$." bit 12
			(LBRF) must be on - see SPCCHK.
		    if code is zero, the right side is the number of arguments
		    else, the right side is an argument (as in the IFS).
			the address of the definition string is given.
		The macro definition string contains as its first word,
		length,,back-pointer.  Length is the length of the definition
		string, and the back-pointer points to the entry in MACRT.
		The ascii text of the macro body appear in sequential bytes.
		The code 177 3 terminates the macro, the code 177 1 n denotes
		argument n (first argument is number zero).

SYMTAB
	1. Initially empty
	2. Every symbol seen that is not a macro name or opcode
	   is added to this table
	3. Symbols that are defined within a block and are not up-arrowed
	   are deleted at block exit.  Symbol definitions are written into
	   the REL file
	4. Entry format:
		0:  Symbol name, right adjusted sixbit
		1:  0,,link to next
		2:  symbol flags,,block bits
		3:  value if defined, else fixup list
		4:  value flags if defined, else polish fixup list
%
BEGIN SYMWRT
;THIS IS THE CODE THAT DUMPS THE SYMBOL TABLE TO HELP REG MAKE THE FAIL MANUAL
;FAIRLY MINIMAL HACK.  CALLED FROM COMMAND:  ,FILE/Y
;NOT YET TENEXIZED...PROBABLY SHOULD BE...TMW

IFN SYMDMP,<
^^SYMWRT:
	TRNN	LDEV
	HALT			;MUST HAVE A LISTING, ELSE THIS IS POINTLESS
	MOVSI	M,-HASH
	MOVEI	BC,0		;FLAG NORMAL SYMBOL TABLE
SYMW1:	SKIPE	FC,OPCDS1(M)	;DOES THIS CHAIN EXIST?
	PUSHJ	P,SYMCH		;YES. PROCESS IT
	AOBJN	M,SYMW1		;LOOP THRU ALL CHAINS.
	MOVEI	BC,1		;FLAG MACRO TABLE
	MOVSI	M,-HASH
SYMW2:	SKIPE	FC,MACRT1(M)
	PUSHJ	P,SYMCH
	AOBJN	M,SYMW2
	CLOSE	4,
	RELEAS	4,
	EXIT

SYMCH:	MOVE	FS,(FC)		;GET A SIXBIT THING
	PUSHJ	P,SYM62A	;WRITE IN ASCII
	MOVEI	FS,[BYTE(7)11,40,40]
	PUSHJ	P,SYMSTR	;TAB
	JUMPN	BC,SYMCH6	;JUMP IF PROCESSING MACRO TABLE
	HLLZ	FS,1(FC)	;GET VALUE
	TLNE	FS,30		;SPECIAL VALUE?
	JRST	SYMCH2		;YES.
SYMCH0:	PUSHJ	P,SYMO2A	;OCTAL TO ASCII
SYMCH1:	MOVEI	FS,[BYTE(7)15,12]
	PUSHJ	P,SYMSTR
	HRRZ	FC,1(FC)
	JUMPN	FC,SYMCH
	POPJ	P,

SYMCH2:	TLZN	FS,10		;CALLI?
	JRST	SYMCH3		;NO.
	ROT	FS,15		;YES. ROTATE CALLI NUMBER						
	CAML	FS,UCLDLN
	ADD	FS,SCLOFF
	PUSH	P,FS		;SAVE NUMBER
	MOVEI	FS,[ASCIZ/CALLI /]
	PUSHJ	P,SYMSTR
	MOVE	T,(P)
	PUSHJ	P,SYMOCT	;WRITE OCTAL
	POP	P,FS
	CAIGE	FS,400000	;STANFORD?
	JRST	SYMCH1		;NO.
	MOVEI	FS,[ASCIZ/ S/]
	JRST	SYMC5A

SYMCH3:	JUMPL	FS,SYMCH4	;JUMP IF PSEUDO-OP
	MOVE	FS,3(FC)	;MUST BE OPDEF?
	JRST	SYMCH0

SYMCH4:	HRRZ	FS,2(FC)	;SEE IF WE KNOW THIS IS SPECIAL
	CAIN	FS,%IO		;IO OPCODE?
	JRST	SYMCH5		;YES
	MOVEI	FS,[ASCIZ/Pseudo-Op/]
	JRST	SYMC5A

SYMCH5:	MOVE	FS,3(FC)
	MOVEI	O,6		;ONLY 6 CHARACTERS
	PUSHJ	P,SYMO2B
	MOVEI	FS,[ASCIZ %,,0 I/O%]
SYMC5A:	PUSHJ	P,SYMSTR
	JRST	SYMCH1

SYMCH6:	SKIPGE	FS,3(FC)	;IS THIS A PERMANENT MACRO?
	JRST	SYMCH7		;NO.
	MOVEI	FS,[ASCIZ/Predefined Macro/]
	JRST	SYMC5A

SYMCH7:	HRRI	FS,[ASCIZ/Conditional/]
	TLNN	FS,1
	MOVEI	FS,[ASCIZ/Predefined Symbol/]
	JRST	SYMC5A

SYMOCT:	MOVEI	O,6
	IDIVI	T,10
	HRLM	T+1,(P)
	SUBI	O,1
	JUMPE	T,.+2
	PUSHJ	P,SYMOCT+1
	MOVEI	T," "
	JUMPLE	O,.+3
	PUSHJ	P,SYMOT
	SOJG	O,.-1
	HLRZ	T,(P)
	ADDI	T,"0"
	JRST	SYMOT

SYMO2A:	MOVEI	O,14
SYMO2B:	MOVEI	T,0
	LSHC	T,3
	ADDI	T,"0"
	PUSHJ	P,SYMOT
	SOJG	O,SYMO2B
	POPJ	P,

SYM62A:	JUMPE	FS,CPOPJ	;PRINT 6BIT IN FS AS ASCII
	MOVEI	T,0
	LSHC	T,6
	JUMPE	T,SYM62A
	ADDI	T," "		;MAKE ASCII, WRITE IT
	PUSHJ	P,SYMOT
	JRST	SYM62A

SYMOT:	SOSG LOB+2		;WRITE ONE CHARACTER FROM T
	OUTPUT 4,
	IDPB T,LOB+1
SYMOT1:	POPJ P,

SYMSTR:	HRLI	FS,440700
	ILDB	T,FS
	JUMPE	T,SYMOT1
	PUSHJ	P,SYMOT
	JRST	SYMSTR+1

>;IFN SYMDMP
BEND SYMWRT

BEND
;ROUTINE TO GET SYSTEM CALL DEFS FROM SYSTEM - STANFORD ONLY
IFN STANSW<
SYSTOP__265
CALLPT__272
SYS__400000

OPSET:	MOVEI T,SYSTOP		;GET SIZE OF MEMORY
	PEEK T,
	PEEK T,			;INDIRECT
	TDNE T,[-1,,401777]
	JRST OPSLUZ
	MOVSI T,-2000+1(T)		;MAKE PR WORD (WITH UWP BIT)
	SETPR2 T,
	JRST OPSLZ2
	MOVE C,SYS+CALLPT
	LDB NA,[221100,,C]	;# DEC CALLIS
	MOVEM NA,UCLDLN#
	SUBI NA,400000
	MOVNM NA,SCLOFF#
	LDB N,[331100,,C]	;TOTAL # CALLIS
	CAIG N,300
	CAIG N,400000(NA)
	JRST OPSLUZ		;UNREASONABLE CRAP
	MOVN NA,N
	MOVSI T,(NA)		;MAKE AOBJN PNTR
	MOVE L,SYS(C)
	CAME L,['RESET ']
	JRST OPSLUZ		;TABLE LOOKS WRONG
	MOVE O,.JBFF
	SETZM OPCDS		;INITIALIZE THIS
	MOVE N,[OPCDS,,OPCDS+1]	;IT WILL KEEP TRACK OF THE ENDS OF THE HASH CHAINS
	BLT N,OPCDS+HASH-1	;AS THEY ARE NEEDED
	MOVEI L,10		;BIT FOR CALLI OPCODE ENTRIES
	HRLI C,T
	MOVEI B,40		;INCREMENT
	PUSHJ P,OPST1		;DEFINE CALLIS
	HRR C,@C		;GET MAJOR OPCODE TABLE ADR
	MOVSI T,-40		;# LOW UUOS
	MOVEI L,40000		;STARTING VAL
	MOVEI B,1000		;INC
	PUSHJ P,OPST1		;DEFINE LOW UUOS
	HLL T,SYS-1(C)		;GET # HIGH UUOS IN LH
	TLC T,-1
	ADDI T,SYS		;CARRY WILL MAKE 2'S COMP
	MOVEI L,700000		;NEW INIT VAL (PNTR & INC SAME AS BEFORE)
	PUSHJ P,OPST1		;DEFINE HIGH UUOS
	MOVEI B,40		;NOW SET UP INC FOR SECONDARY OPCODES
OPSLP1:	HRR C,SYS-1(C)		;GET NEXT TABLE LOC
	TRNN C,-1
	JRST OPSDON		;DONE IF ADR 0
	HLRZ L,SYS-1(C)		;ELSE GET BASE VAL & CNT
	LDB T,[50400,,L]	;GET CNT-1
	MOVNI T,1(T)
	MOVSI T,(T)		;MAKE AOBJN PNTR
	ANDI L,777000		;ISOLATE STARTING VAL
	PUSHJ P,OPST1		;DEFINE THIS SECONDARY SET
	JRST OPSLP1		;AND TRY FOR ANOTHER GRP

OPSDON:	MOVEM O,.JBFF		;UPDATE BOTH
	HRLM O,.JBSA		;COPIES OF JOBFF
OPSTX:	SETOM OPSOK		;DON'T NEED TO DO THIS AGAIN
	MOVEI T,
	CORE2 T,		;FLUSH PR2
	POPJ P,
	POPJ P,

;ADDS A CALLI OR OTHER MNEMONIC AT THE END OF THE OPCDS1 TABLE.
OPST1:	TRNN C,600000
	TRNN C,-200
	JRST OPSLUZ		;BAD ADDRESS
	IORI T,SYS		;PUT OFFSET IN PNTR
OPSTL:	SKIPA N,@C
	LSH N,-6
	TRNN N,77		;RIGHT-JUSTIFY IF NECESSARY (SIGH)
	JUMPN N,.-2		;BUT AVOID LOOP ON 0
	JUMPE N,OPSNXT		;IGNORE 0'S
LEG	MOVEM N,(O)		;STORE NAME
	IDIVI N,HASH
	MOVM NA,NA
	SKIPE PN,OPCDS(NA)	;DO WE ALREADY KNOW THE END OF THIS CHAIN?
	JRST OPSTL2		;YES
	TROA PN,OPCDS1-1(NA)	;NO - FIND IT SO THESE CAN GO AT END
	MOVEI PN,(FS)		;WHERE THEY WON'T INTERFERE WITH
	HRRZ FS,1(PN)		;NORMAL OPCODES
	JUMPN FS,.-2
OPSTL2:	HRRM O,1(PN)		;LINK IN
LEG	MOVSM L,1(O)		;STORE VALUE
	MOVEM O,OPCDS(NA)	;THIS IS NOW END OF LIST
	ADDI O,2
OPSNXT:	ADDI L,(B)		;COUNT VALUE FIELD
	AOBJN T,OPSTL
	POPJ P,

OPSLUZ:	OUTSTR [ASCIZ /GARBAGEY DATA IN SYSTEM CALL TABLE/]
OPSLZ3:	OUTSTR [ASCIZ /, YOU LOSE!
/]
	EXIT

OPSLZ2:	OUTSTR [ASCIZ /SETPR2 TO GET CALLI NAMES FAILED/]
	JRST OPSLZ3

OPSEND__.	;OPSET THRU HERE GIVEN TO FREE STORAGE AFTER THE FIRST TIME

OPSOK:	0
>;IFN STANSW
ITS,<

;CONVERT SIXBIT TO ASCII AND TYPE
FNMOUT:	HRLI	1,440600		;BYTE POINTER IN LEFT HALF
	MOVEI	2,6			;COUNT
	ILDB	3,1			;GET A BYTE
	JUMPE	3,.+4			;IGNORE BLANKS
	ADDI	3," "			;MAKE ASCII
	OUTCHR	3			;TYPE IT
	SOJG	2,.-4			;FOR 6 CHARACTERS
	POPJ	P,

;CALLED AT INITIALIZATION TIME TO GOBBLE SYSTEM SYMBOLS INTO SYMBOL TABLE

	BEGIN GETSYS

^GETSYS:MOVE TAC,[RADIX50 0,SYSYMB]
	.EVAL TAC,
	JRST 4,.
	MOVE T,[RADIX50 0,SYSYME]
	.EVAL T,
	JRST 4,.
	ADDI T,1
	SUBB T,TAC		;LENGTH OF GETSYS AREA
	ASH TAC,-1		;GUESS AT CORE NEEDED
	IMULI TAC,5
	ADD TAC,.JBFF		;END OF GETSYS AREA
	CAMGE TAC,.JBREL
	JRST NONEED		;NO EXTRA CORE NEEDED
	PUSH P,TAC
	CORE TAC,
	JRST 4,.
	POP P,TAC
NONEED:	MOVE B,TAC		;BEGINING OF GETSYS AREA
	SUB B,T
	MOVN C,T
	HRL B,C			;AOBJN POINTER TO GETSYS AREA
	PUSH P,B
	MOVE C,[SIXBIT /CALLS/]
	.GETSYS B,
	JRST 4,.
	POP P,B		;B/ AOBJN POINTER TO GETSYS AREA
	MOVE C,.JBFF	;C/ POINTER TO ORIGIN OF FREE STORAGE
GETLOP:	CAIL C,(B)
	JRST 4,.
	MOVE N,(B)	;SQUOZE
	PUSHJ P,R50TOX	;CONVERT TO SIXBIT
	MOVEM L,(C)	;SAVE SIXBIT
	MOVE N,L
	IDIVI N,HASH
	MOVM NA,NA	;MAKE HASH POSITIVE.
	MOVE N,1(B)			;VALUE
	TDNN N,[777000,,0]		;OPCODE OR SYMBOL
	JRST [	MOVEI PN,SYMTAB(NA)	;SYMBOL
		SETZM 1(C)
		HRLOI NA,ANONF!UPARF!DBLUPF
		JRST LONG]
	MOVEI PN,OPCDS(NA)	;OPCODE
	TDNN N,[0,,-1]		;LONG OR SHORT ENTRY
	JRST [	MOVEM N,1(C)	;SHORT 
		MOVEI NA,2	;ENTRY LENGTH
		JRST GETLP1]
	MOVSI NA,20	;MARK AS LONG ENTRY OPCODE
	MOVEM NA,1(C)
	MOVE NA,[ANONF,,1]
LONG:	MOVEM NA,2(C)
	MOVEM N,3(C)	;VALUE
	SETZM 4(C)	;NO RELOCATION
	MOVEI NA,5	;ENTRY SIZE
GETLP1:	MOVE N,(PN)	;POINTER TO CHAIN
	HRRM N,1(C)	;NEW ENTRY POINTING TO CHAIN
	MOVEM C,(PN)	;POINTER TO CHAIN
	ADD C,NA	;UPDATE FREE STORAGE POINTER
	ADD B,[1,,1]
	AOBJN B,GETLOP	;MORE
	MOVEM C,.JBFF
	POPJ P,

;RADIX50 TO SIXBIT CONVERSION
;	CALLED WITH SQUOZE IN N
;	RETURNS SIXBIT IN L
;	NA CLOBBERED

R50TOX:	TLZ N,740000		;CLEAR FLAGS FOR SPITE
	MOVEI L,0
	JUMPE N,CPOPJ		;AVOID INFINITE LOOP
R50TX1:	IDIVI N,50
	JUMPE NA,R50XF1		;NULL
	CAIG NA,12
	JRST [	ADDI NA,'0'-1	;ITS A DIGIT
		JRST R50XF]
	CAIG NA,44
	JRST [	ADDI NA,'A'-13	;ITS A LETTER
		JRST R50XF]
	MOVE NA,.$%-45(NA)	;SPECIAL CHARATCER
R50XF:	OR L,NA
	ROT L,-6
R50XF1:	JUMPN N,R50TX1
	TRNE L,77
	POPJ P,
	LSH L,-6
	JRST .-3

.$%:	'.'
	'$'
	'%'

	BEND GETSYS

>;ITS
	SUBTTL	TENEX INITIAL SYMBOLS AND OPDEFS
TNX,<
NOT20,<

DEFINE	EENT(NAME,VALUE)<
	XLIST
	'NAME'
	600000+VALUE
	LIST
>

INISMT:
EENT (LGINX1,10)
EENT (LGINX2,11)
EENT (LGINX3,12)
EENT (LGINX4,13)
EENT (LGINX5,14)

EENT (CRJBX1,20)
EENT (CRJBX2,21)
EENT (CRJBX3,22)
EENT (CRJBX4,23)
EENT (CRJBX5,24)
EENT (CRJBX6,25)
EENT (CRJBX7,26)

EENT (LOUTX1,35)
EENT (LOUTX2,36)

EENT (CACTX1,45)
EENT (CACTX2,46)

EENT (EFCTX1,50)
EENT (EFCTX2,51)
EENT (EFCTX3,52)
EENT (GJFX1,55)
EENT (GJFX2,56)
EENT (GJFX3,57)
EENT (GJFX4,60)
EENT (GJFX5,61)
EENT (GJFX6,62)
EENT (GJFX7,63)
EENT (GJFX8,64)
EENT (GJFX9,65)
EENT (GJFX10,66)
EENT (GJFX11,67)
EENT (GJFX12,70)
EENT (GJFX13,71)
EENT (GJFX14,72)
EENT (GJFX15,73)
EENT (GJFX16,74)
EENT (GJFX17,75)
EENT (GJFX18,76)
EENT (GJFX19,77)
EENT (GJFX20,100)
EENT (GJFX21,101)
EENT (GJFX22,102)
EENT (GJFX23,103)
EENT (GJFX24,104)
EENT (GJFX25,105)
EENT (GJFX26,106)
EENT (GJFX27,107)
EENT (GJFX28,110)
EENT (GJFX29,111)
EENT (GJFX30,112)
EENT (GJFX31,113)
EENT (GJFX32,114)
EENT (GJFX33,115)

EENT (OPNX1,120)
EENT (OPNX2,121)
EENT (OPNX3,122)
EENT (OPNX4,123)
EENT (OPNX5,124)
EENT (OPNX6,125)
EENT (OPNX7,126)
EENT (OPNX8,127)
EENT (OPNX9,130)
EENT (OPNX10,131)
EENT (OPNX11,132)
EENT (OPNX12,133)
EENT (OPNX13,134)
EENT (OPNX14,135)
EENT (OPNX15,136)
EENT (OPNX16,137)
EENT (OPNX17,140)
EENT (OPNX18,141)
EENT (OPNX19,142)
EENT (OPNX20,143)
EENT (OPNX21,144)
EENT (OPNX22,145)
EENT (DESX1,150)
EENT (DESX2,151)
EENT (DESX3,152)
EENT (DESX4,153)
EENT (DESX5,154)
EENT (DESX6,155)
EENT (DESX7,156)

EENT (CLSX1,160)
EENT (CLSX2,161)

EENT (RJFNX1,165)
EENT (RJFNX2,166)
EENT (RJFNX3,167)

EENT (DELFX1,170)

EENT (SFPTX1,175)
EENT (SFPTX2,176)
EENT (SFPTX3,177)

EENT (CNDIX1,200)
EENT (CNDIX2,201)
EENT (CNDIX3,202)
EENT (CNDIX4,203)
EENT (CNDIX5,204)

EENT (SFBSX1,210)
EENT (SFBSX2,211)

EENT (IOX1,215)
EENT (IOX2,216)
EENT (IOX3,217)
EENT (IOX4,220)
EENT (IOX5,221)
EENT (IOX6,222)

EENT (PMAPX1,240)
EENT (PMAPX2,241)

EENT (SPACX1,245)

EENT (FRKHX1,250)
EENT (FRKHX2,251)
EENT (FRKHX3,252)
EENT (FRKHX4,253)
EENT (FRKHX5,254)
EENT (FRKHX6,255)

EENT (GTABX1,267)
EENT (GTABX2,270)

EENT (RUNTX1,273)

EENT (STADX1,275)
EENT (STADX2,276)

EENT (ASNDX1,300)
EENT (ASNDX2,301)
EENT (ASNDX3,302)

EENT (CSYNX1,312)

EENT (ATACX1,320)
EENT (ATACX2,321)
EENT (ATACX3,322)
EENT (ATACX4,323)
EENT (ATACX5,324)

EENT (DCHRX1,330)	;USED ?

EENT (STDVX1,332)

EENT (DEVX1,335)
EENT (DEVX2,336)
EENT (DEVX3,337)

EENT (MNTX1,345)
EENT (MNTX2,346)
EENT (MNTX3,347)

EENT (TERMX1,350)

EENT (ATIX1,352)
EENT (ATIX2,353)

EENT (DTIX1,355)

EENT (TTYX1,360)

EENT (CFRKX2,362)
EENT (CFRKX3,363)

EENT (KFRKX1,365)
EENT (KFRKX2,366)

EENT (RFRKX1,367)

EENT (GFRKX1,371)

EENT (GETX1,373)
EENT (GETX2,374)

EENT (SFRVX1,377)

EENT (NOUTX1,407)
EENT (NOUTX2,410)

EENT (IFIXX1,414)
EENT (IFIXX2,415)
EENT (IFIXX3,416)

EENT (GFDBX1,424)
EENT (GFDBX2,425)
EENT (GFDBX3,426)

EENT (CFDBX1,430)
EENT (CFDBX2,431)
EENT (CFDBX3,432)
EENT (CFDBX4,433)

EENT (DUMPX1,440)
EENT (DUMPX2,441)
EENT (DUMPX3,442)
EENT (DUMPX4,443)

EENT (RNAMX1,450)
EENT (RNAMX2,451)

EENT (BKJFX1,454)

EENT (TIMEX1,460)
EENT (ZONEX1,461)
EENT (ODTNX1,462)
;463 FREE
EENT (DILFX1,464)
EENT (TILFX1,465)
EENT (DATEX1,466)
EENT (DATEX2,467)
EENT (DATEX3,470)
EENT (DATEX4,471)
EENT (DATEX5,472)
EENT (DATEX6,473)
EENT (TMONX1,515)
EENT (SMONX1,515)

EENT (CPRTX1,520)

EENT (SACTX1,530)
EENT (SACTX2,531)
EENT (SACTX3,532)
EENT (SACTX4,533)

EENT (GACTX1,540)
EENT (GACTX2,541)

EENT (FFUFX1,544)
EENT (FFUFX2,545)
EENT (FFUFX3,546)

EENT (DSMX1,555)

EENT (RDDIX1,560)

EENT (SIRX1,570)

EENT (SSAVX1,600)
EENT (SSAVX2,601)

EENT (SEVEX1,610)

EENT (WHELX1,614)

EENT (CRDIX1,620)
EENT (CRDIX2,621)
EENT (CRDIX3,622)
EENT (CRDIX4,623)
EENT (CRDIX5,624)
EENT (CRDIX6,625)

EENT (GTDIX1,640)
EENT (GTDIX2,641)

EENT (FLINX1,650)
EENT (FLINX2,651)
EENT (FLINX3,652)
EENT (FLINX4,653)

EENT (FLOTX1,660)
EENT (FLOTX2,661)
EENT (FLOTX3,662)

EENT (FDFRX1,700)
EENT (FDFRX2,701)

EENT (ATPX1,710)
EENT (ATPX2,711)
EENT (ATPX3,712)
EENT (ATPX4,713)
EENT (ATPX5,714)
EENT (ATPX6,715)
EENT (ATPX7,716)
EENT (ATPX8,717)
EENT (ATPX9,720)
EENT (ATPX10,721)
EENT (ATPX11,722)
EENT (ATPX12,723)
EENT (ATPX13,724)

EENT (CVSKX1,730)
EENT (CVSKX2,731)

EENT (DPX1,734)
EENT (DPX2,735)

EENT (STRDX1,740)
EENT (STRDX2,741)
EENT (STRDX3,742)

EENT (STTX1,744)

;ADD JSYS ERROR CODES HERE

EENT (ILINS1,770)
EENT (ILINS2,771)
EENT (ILINS3,772)
INISME:	0				;ZERO TERMINATES
	BLOCK 40			;PATCH SPACE FOR 16 MORE


>;NOT20			;FOR TOPS-20 YOU SHOULD SEARCH MONSYM

	DEFINE JENT(NAME,NUMBER)<
XLIST
'NAME'
JSYS NUMBER
IFNOP NAME,<GDEFINE NAME <104B8+NUMBER>>
LIST
>

TNXOPS:				;TABLE OF TENEX OPDEFS STARTS HERE
$IBQ_0
FOR ZOT IN (<>,LOGIN,CRJOB,LGOUT,CACCT,EFACT,SMON,<TMON>
,GETAB,ERSTR,GETER,GJINF,TIME,RUNTM,SYSGT,<GNJFN>
,GTJFN,OPENF,CLOSF,RLJFN,GTSTS,STSTS,DELF,<SFPTR>
,JFNS,FFFFP,RDDIR,CPRTF,CLZFF,RNAMF,SIZEF,<GACTF>
,STDIR,DIRST,BKJFN,RFPTR,CNDIR,RFBSZ,SFBSZ,<SWJFN>
,BIN,BOUT,SIN,SOUT,RIN,ROUT,PMAP,<RPACS>
,SPACS,RMAP,SACTF,GTFDB,CHFDB,DUMPI,DUMPO,<DELDF>
,ASND,RELD,CSYNO,PBIN,PBOUT,PSIN,PSOUT,<MTOPR>
,CFIBF,CFOBF,SIBE,SOBE,DOBE,GTABS,STABS,<RFMOD>
,SFMOD,RFPOS,RFCOC,SFCOC,STI,DTACH,ATACH,<DVCHR>
,STDEV,DEVST,MOUNT,DSMNT,INIDR,SIR,EIR,<SKPIR>
,DIR,AIC,IIC,DIC,RCM,RWM,DEBRK,<ATI>
,DTI,CIS,SIRCM,RIRCM,RIR,GDSTS,SDSTS,<RESET>
,RPCAP,EPCAP,CFORK,KFORK,FFORK,RFORK,RFSTS,<SFORK>
,SFACS,RFACS,HFORK,WFORK,GFRKH,RFRKH,GFRKS,<DISMS>
,HALTF,GTRPW,GTRPI,RTIW,STIW,SOBF,RWSET,<GETNM>
,GET,SFRKV,SAVE,SSAVE,SEVEC,GEVEC,GPJFN,<SPJFN>
,SETNM,FFUFP,DIBE,FDFRE,GDSKC,LITES,TLINK,<STPAR>
,ODTIM,IDTIM,ODCNV,IDCNV,NOUT,NIN,STAD,<GTAD>
,ODTNC,IDTNC,FLIN,FLOUT,DFIN,DFOUT,<>,<>
,CRDIR,GTDIR,DSKOP,SPRIW,DSKAS,SJPRI,STO,<>
,<>,<>,<>,<>,<>,<>,<>,<>
,ASNDP,RELDP,ASNDC,RELDC,STRDP,STPDP,STSDP,<RDSDP>
,WATDP,<>,<>,<>,ATPTY,CVSKT,CVHST,<FLHST>
,GCVEC,SCVEC,STTYP,GTTYP,BPT,GTDAL,WAIT,<HSYS>
,USRIO,PEEK,MSFRK,ESOUT,SPLFK,ADVIS,JOBTM,<DELNF>
,SWTCH)
<IFDIF <ZOT>,<>,<JENT(ZOT,\$IBQ)>
$IBQ_$IBQ+1
>

T20,<
$IBQ_500
FOR ZOT IN (RSCAN,HPTIM,CRLNM,INLNM,LNMST,RDTXT,SETSN,<GETJI>
,MSEND,MRECV,MUTIL,ENQ,DEQ,ENQC,SNOOP,<SPOOL>
,ALLOC,CHKAC,TIMER,RDTTY,TEXTI,UFPGS,SFPOS,<SYERR>
,DIAG,SINR,SOUTR,RFTAD,SFTAD,TBDEL,TBADD,<TBLUK>
,STCMP,SETJB,GDVEC,SDVEC,COMND,PRARG,GACCT,<LPINI>
,GFUST,SFUST,ACCES,RCDIR,RCUSR)
<IFDIF <ZOT>,<>,<JENT(ZOT,\$IBQ)>
$IBQ_$IBQ+1
>

JENT(THIBR,770)		;Temporary JSYS Definitions
JENT(TWAKE,771)
JENT(MRPAC,772)
JENT(SETPV,773)
JENT(MTALN,774)
JENT(TTMSG,775)


>;T20

IFN IMSSSW,<			;LOCAL JSYSES FOR IMSSS INSTALLATION
$IBQ_600
FOR ZOT IN (PBTIN,TTCVT,KIDNO,LOGSV,DATSV,SCEDR,SCEDS,CNTSZ,SYSLK,<PSTIN>
,RAND,KLGOT,PTINF,GTINF,SETWS,CLRWS,AUTWS,RDWS,CLAWS,KLGIN,DEVCT,<DELCH>
,SJPCT,RJPCT,IIT,PARRD,PARST,STCHA,GTBLT,DRMOP,RECO,RDREC)
<IFDIF <ZOT>,<>,<JENT(ZOT,\$IBQ)>
$IBQ_$IBQ+1>
JENT(DATSX,660)
JENT(FONCT,661)
JENT(SETAU,677)
>;IMSSS

NOT20,<
JENT(MRPAC,772)
JENT(TTMSG,775)
JENT(EXEC,777)
>;NOT20
	0		;ZERO TO END THE TABLE

^INISM:	MOVEI	NA,1
	MOVEM	NA,OPDTMP	;BLOCK NUMBER OF DEFINITION
	MOVSI	NA,NONEM	;USUAL BITS FOR WRD+1
	MOVEM	NA,WRD+1
	MOVEI	NA,TNXOPS-2	;ADDRESS OF THE TABLE
	PUSH	P,NA
STNXP1:	AOS	(P)		;GET THE INDEX
	AOS	NA,(P)
	SKIPN	L,(NA)		;GET THE SIXBIT
	JRST	STNXP2		;ALL DONE
	MOVE	N,1(NA)
	MOVEM	N,WRD
	PUSHJ	P,OPDINS	;INSERT "OPDEF"
	MOVSI	NA,SUPBIT
	IORM	NA,2(PN)	;SET SUPPRESS BIT IN NEW DEFINITION
	JRST	STNXP1

STNXP2:	SUB	P,[1,,1]
	SETZM	WRD

T20,<	POPJ	P,		>;TOPS-20 HAS NO OTHER SYMBOLS
NOT20,<

	MOVEI	T,INISMT		;ADD TENEX INITIAL SYMBOLS
INISML:	GFST	(FS,FSTPNT)		;GET FREE STORAGE.
	SKIPN	N,0(T)			;ANY SYMBOLS LEFT?
	POPJ	P,			;NOPE. RETURN.
	MOVEM	N,0(FS)			;STORE SYMBOL NAME IN FS BLOCK
	IDIVI	N,HASH			;CALC. HASH CODE
	MOVMS	NA
	MOVE	L,SYMTAB(NA)		;LINK THIS FS BLOCK INTO SYMBOL TABLE
	MOVEM	FS,SYMTAB(NA)
	EXCH	L,1(FS)
	MOVEM	L,FSTPNT		;DELINK BLOCK FROM FREE LIST
	MOVE	L,1(T)
	MOVEM	L,3(FS)			;STORE VALUE
	SETZM	4(FS)			;NO RELOCATION
	MOVE	L,[SUPBIT!UPARF,1]	;OUTER BLOCK, UPARROWED, SUPPRESSED
	MOVEM	L,2(FS)
	ADDI	T,2
	JRST	INISML
>;NOT20


>;TNX
BEGIN INIT 	SUBTTL DEVICE INITIALIZATION

^FNREAD: JSR IN			;FILE NAME READER INSTRUCTION (GETS CLOBBERED)

;THIS IS WHAT WE CALL TO SCAN FILE NAMES FROM THE INPUT STREAM
^AFSCAN:PUSHJ	P,SCAN1		
	MOVE	2,C		;MOVE CHARACTER TO RIGHT AC
	POPJ	P,

NOTNX,<NOITS,<

BEGIN NAME
;CALL WITH:
;RETURN: SIXBIT LEFT ADJUSTED IN 6,
;SIXBIT (OR OCTAL) RIGHT ADJUSTED IN SVNAM.  OCTAL IN 13 (NOT STANSW!IMSSSW).
;DELIMITER IN 2

;YOU MUST NOT CLOBBER AC #7 = CP!!!

^NAME:	0
IFE STANSW!IMSSSW,<	MOVEI	13,0>		;SAIL and IMSSS like sixbit ppns
NA1:	XCT	FNREAD
	CAIE	2,11
	CAIN	2," "
	JRST	NA1		;SKIP BLANKS AND TABS
	MOVEM	5,NAMES5#	;SAVE AN AC
	TDZA	6,6		;INITALIZE 6BIT AC AND SKIP
LOOP1:	XCT	FNREAD		;GET A CHR
	CAIE	2,"."
	SKIPL	5,CTAB(2)	;CHECK FOR NUMBER OR LETTER
	JRST	STOPN		;NO, SOME DELIMITER
	TLNE	6,770000	;SEEN 6 CHARS YET?
	JRST	LOOP1		;YES, IGNORE THIS
	LSH	6,6		;MAKE ROOM
	ANDI	5,77		;SIXBIT ONLY, FROM CHAR TABLE
	IORI	6,(5)
	MOVEI	2,40(5)		;GET UPPER CASE VERSION OF CHAR
IFE STANSW!IMSSSW,<	LSH	13,3		;MAKE OCTAL PPN IN 13
			IORI	13,-'0'(5)	;MAKE OCTAL PPN>
	JRST	LOOP1

STOPN:	MOVE	5,NAMES5	;RESTORE AC
	JUMPE	6,@NAME		;IF 0 RETURN
	JRST	.+2
STOPN2:	XCT	FNREAD
	CAIE	2," "
	CAIN	2,11
	JRST	STOPN2		;DON'T STOP AT BLANK OR TAB. GET REAL DELIMITER
IFE STANSW!IMSSSW,<	MOVEM 13,SVNAM>		;SAVE OCTAL FOR PPNS
IFN STANSW!IMSSSW,<	MOVEM 6,SVNAM>		;SAVE RIGHT ADJUSTED SIXBIT FOR PPNS
STOPN1:	TLNE	6,770000	;NOW, LEFT JUSTIFY
	JRST	@NAME
	LSH	6,6
	JRST	STOPN1

IFN CMUSW,<
^RDPPN:	0
	SETZM	PPNBUF
	SETZM	PPNBUF+1
	SETZM	PPNBUF+2
	MOVEM	5,RDPTMP#
RDPPN1:	XCT	FNREAD
	CAIE	2," "
	CAIN	2,11
	JRST	RDPPN1		;SKIP BLANKS AND TABS
	MOVEI	5,=13		;MAX CHARACTER COUNT
	SKIPA	6,[440700,,PPNBUF]
RDPPN2:	XCT	FNREAD
	CAIN	2,","
	JRST	RDPPOK		;COMMA IS LEGAL
	SKIPL	CTAB(2)
	JRST	RDPPX		;OTHER DELIMS NOT.
	CAIL	2,"A"+40
	CAILE	2,"Z"+40
	JRST	.+2
	SUBI	2,40		;MAKE UPPER CASE
RDPPOK:	IDPB	2,6
	SOJG	5,RDPPN2
RDPPX:	MOVE	6,[4,,PPNBUF]	
	CMUDEC	6,		;CONVERT STRING TO 36 BIT NUMBER
	JFCL			;(BARF?) (SOMEONE, SOMEWHERE WILL LOSE)
	MOVE	5,RDPTMP
	JRST	@RDPPN

PPNBUF: BLOCK 3>
BEND NAME

BEGIN GETFIL
;RETURNS +1 IF LOSE
;	 +2 IF WIN. 1:DEVICE, 5:FILE, 3: EXT, 4: PPN

^SVNAM:	0

^^GETFIL:0
	JSR	NAME			;READ A NAME
	JUMPE	6,@GETFIL		;RETURN IF NONE THERE
	AOS	GETFIL			;ELSE SET FOR SKIP RETURN
	CAIE	2,":"			;DEVICE NAME?
	JRST	NODEV			;NO, TRY FILE NAME
	MOVE	1,6			;SET DEVICE
	JSR	NAME			;GET ANOTHER NAME
	JUMPE	6,@GETFIL		;NONE, END  (PTR: IS LEGAL)
NODEV:	MOVE	5,6			;FILE NAME
	CAIE	2,"."			;MAYBE EXTENSION?
	JRST	NOEXT			;NO.
	JSR	NAME			;GET EXT - NULL EXT IS NOT AN ERROR.
	HLLZ	3,6			;SET EXTENSION  (CLEARS RH BITS FROM 3)
NOEXT:	CAIE	2,"<"			;ALLOW BROKETS TO DENOTE PPNS
	CAIN	2,"["			;CHECK FOR PPN
	JRST	INPPN			;READ PPN
	JRST	@GETFIL			;NO, RETURN
INPPN:
IFE CMUSW,<	JSR	NAME		;GET LEFT HALF
		JUMPE	6,ERR3		;NOT THERE
		HRLZ	4,SVNAM		;GET LEFT HALF
		CAIE	2,","		;MUST BE THERE
		JRST	ERR3
		JSR	NAME		;REPEAT FOR RIGHT HALF
		HRR	4,SVNAM	>
IFN CMUSW,<	JSR	RDPPN	>
	CAIE	2,">"			;ALLOW BROKET
	CAIN	2,"]"			;] PRESENT?
	XCT	FNREAD			;YES SKIP IT. (NOT AN ERROR TO OMIT)
	JRST	@GETFIL
	BEND	GETFIL
>;NOITS>;NOTNX

TNX,<
;TGETF -- GET TENEX FILE NAME FROM INPUT STREAM.
;PRESENTLY CALLED ONLY BY INITL, .INSERT CODE BUT MAY BE USED BY .LOAD, .LIB
;	IF ANYBODY EVER FIXES THE LOADER...
;VERY QUICK AND DIRTY.  NO INTERACTIVE USE OF GTJFN BECAUSE OF SWITCHES...
^^TGETF: 0
	XCT 	FNREAD
	CAIE	2,11		;TAB
	CAIN	2," "
	JRST	.-3		;SKIP LEADING SPACES, TABS
	SKIPA	1,[POINT 7,GTNAM]
TGETF1:	XCT	FNREAD
	JSR	ISTRM		;CHECK FOR 'TERMINAL' IN SWITCH CONTEXT
	JRST	TGETFX		;YEP
	CAIE	2,15		;THROW OUT CR
	IDPB	2,1		;SAVE CHAR FOR GTJFN IN INITIT
	JRST	TGETF1		;BACK FOR MORE
TGETFX:	CAME	1,[POINT 7,GTNAM]
	AOS	TGETF		;IF SUCCESSFUL
	JRST	@TGETF

;PRESENTLY CALLED FROM .LIBRARY (.LOAD) ONLY.
^^TGETFY: XCT 	FNREAD		;slurp something
	CAIE	2,11		;TAB
	CAIN	2," "
	JRST	TGETFY		;SKIP LEADING SPACES, TABS
	SKIPA	1,[POINT 7,GTNAM]
TGETY1:	XCT	FNREAD
	CAIE	2,15		;also break on CR for .LOAD
	JSR	ISTRM		;CHECK FOR 'TERMINAL' IN SWITCH CONTEXT
	JRST	TGETY2		;YEP
	IDPB	2,1		;SAVE CHAR FOR GTJFN IN INITIT
	JRST	TGETY1		;BACK FOR MORE
TGETY2:	CAME	1,[POINT 7,GTNAM]
	AOS	(P)		;SOMETHING WAS SEEN
	TLO	SFL		;SET SCANNER AHEAD
	POPJ	P,

ISTRM:	0
	MOVE	6,[XWD -TRMTL,TRMTBL]
	CAME	2,(6)
	AOBJN	6,.-1		;IF MORE TO DO
	SKIPL	6
	AOS	ISTRM		;NON-TERMINAL EXIT
	JRST	@ISTRM

TRMTBL:	"/"
	"_"
	","
	"="
	"("
	"@"
	"!"
	" "
	11			;TAB
	12			;LF, BECAUSE RPG FLUSHES CR
	")"			;FOR SCAN IN SEARCH PSEUDO OP
TRMTL__.-TRMTBL

>;TNX
ITS,< 	BEGIN ITSSCN 		;ITS STYLE COMMAND LINE SCANNER

DEV_1
FN1_5
FN2_3
SNAME_4
BREAK_2
CHAR_7
ACPTR_13
AC_6

^^LIMBO:	0	;SCANNER READ AHEAD CHARACTER
			;SCANNER WILL NOT LET US LEAVE UNTIL ZERO

GETCC:	0			;GET CHARACTER FOR COMMAND LINE SCANNER
	SKIPE	LIMBO
	SKIPA	BREAK,LIMBO
	XCT	FNREAD		;READ NEXT CHARACTER (USUALLY JSR IN).
	SETZM	LIMBO
	JRST	@GETCC

NAME:	0			;BREAK OFF WORD FROM INPUT STREAM
NA1:	JSR	GETCC
	CAIE	BREAK," "
	CAIN	BREAK,11
	JRST	NA1		;IGNORE LEADING BLANKS AND TABS
	MOVE	ACPTR,[440600,,AC]	;DEPOSIT LEFT ADJUSTED SIXBIT
	TDZA	AC,AC
NAME1:	JSR	GETCC		;GET CHARACTER
	JSR	BRKTST		;CHECK FOR A BREAK
	JRST	NAMBRK		;THIS IS A BREAK CHARACTER
NAME2:	TLNE	ACPTR,770000	;IGNORE EVERYTHING AFTER 6 CHARACTERS
	IDPB	CHAR,ACPTR
	JRST	NAME1

NAMBRK:	JUMPN	CHAR,@NAME	;NO TRAILING SPACES
NAMBR1:	JSR	GETCC
	CAIE	BREAK," "
	CAIN	BREAK,11
	JRST	NAMBR1		;FLUSH TRAING SPACES
	JSR	BRKTST		;IS THIS A REAL BREAK?
	JRST	@NAME		;YES. RETURN THAT BREAK CHARACTER
	MOVEM	BREAK,LIMBO	;NO.  WE CONSIDER THAT SPACE WAS THE BREAK.
	MOVEI	BREAK," "	;PUT THE OTHER BREAK BACK (INTO LIMBO) FOR LATER
	JRST	@NAME

;CONVERTS BREAK TO SIXBIT AND PUTS RESULT IN CHAR
;^Q QUOTES NEXT CHARACTER
;FAILS TO SKIP ON BREAK CHARACTER <NON-SIXBIT SPACE , : ; @ _ ( ) >

BRKTST:	0
	CAIN	BREAK,11
	MOVEI	BREAK," "
	JSR	SIXTST
	JUMPL	CHAR,[	CAIE BREAK,21		;^Q
			JRST @BRKTST		;NON-SIXBIT BREAKS US
			JSR GETCC
			JSR SIXTST
			JUMPL CHAR,@BRKTST	;NON-SIXBIT
			JRST BRKT1]
	JUMPE CHAR,@BRKTST
	CAIE CHAR,','
	CAIN CHAR,'_'
	JRST @BRKTST
	CAIE CHAR,':'
	CAIN CHAR,';'
	JRST @BRKTST
	CAIE CHAR,'('
	CAIN CHAR,')'
	JRST @BRKTST
	CAIE CHAR,'@'
	CAIN CHAR,'/'
	JRST @BRKTST
	CAIE CHAR,'+'		;MAKE + AND = WORK (ALTERNATIVES TO , AND _)
	CAIN CHAR,'='
	JRST @BRKTST
BRKT1:	AOS BRKTST		;WHEW!
	JRST @BRKTST

;CONVERT BREAK TO SIXBIT

SIXTST:	0
	MOVNI	CHAR,1
	CAIL	BREAK," "
	CAILE	BREAK,"_"
	JRST	SIXT1		;MIGHT BE LOWER CASE
	MOVEI	CHAR,-" "(BREAK)
	JRST 	@SIXTST

SIXT1:	CAIL	BREAK,"a"
	CAILE	BREAK,"z"
	JRST	@SIXTST
	MOVEI	CHAR,-100(BREAK)	;LOWER CASE TO SIXBIT
	JRST	@SIXTST

;THIS ROUTINE SCANS COMMAND LINE FOR FILE SPECIFICATION

^^GETFIL:0
	JSR	NAME		;GET A WORD
	JUMPE	AC,@GETFIL
	AOSA	GETFIL		;ARRANGE FOR SKIP RETURN
GETF1:	JSR	NAME
	JUMPE	AC,@GETFIL
	CAIE	BREAK,":"	;DEVICE NAME?
	JRST	GETF2		;NO.
	MOVE	DEV,AC
	JRST	GETF1

GETF2:	CAIE	BREAK,";"	;USER NAME?
	JRST	GETF3		;NO
	MOVE	SNAME,AC	;REMEMBER USER NAME.
	JRST	GETF1		;(SET SNAME WITH DSKPPN UUO AT INITIT)

GETF3:	CAIE	BREAK," "	;BREAK IS BLANK?
	JRST	GETF4
	JUMPN	FN1,[MOVE FN2,AC
		JRST GETF1]
	MOVE	FN1,AC
	JRST	GETF1

GETF4:	JUMPN	FN1,[MOVE FN2,AC
		JRST @GETFIL]
	MOVE	FN1,AC
	JRST	@GETFIL

	BEND ITSSCN
>;ITS
	BEGIN INITIT

;IO CHANNELS:  2: INPUT, 3: BINARY, 4: LISTING, 6: RPG OR COMMAND
;   CHANNEL 1 IS USED FOR UNIVERSAL FILE I/O

NOTNX,<

^^INITIT:0
	DPB	6,[POINT 4,INIT1,12]	;CLOBBER IO CHANNEL IN INIT
	SETZM	FPPN			;IN CASE WE DO NOT STORE
	MOVEM	1,NAM			;SET NAME
	MOVEM	1,LFDEV			;SAVE DEVICE (LAST FILE DEVICE)
	MOVEM	5,FNAM			;AND FILE NAME
ITS,<		MOVEM	3,FEXT		;WHOLE WORD FOR FNAM2>
NOITS,<		HLLZM	3,FEXT		;HALF WORD FOR EXTENSION
		CAIGE	6,5		;PPNS FOR SPECIAL ONES
		CAIN	6,2	>	;NO PPN UNLESS INPUT
	MOVEM	4,FPPN
	CAIN	6,2			;SKIP UNLESS INPUT FILE.
	MOVEM	4,SAVPPN		;SAVE PPN FOR EDITOR.  TVR 10/72
ITS,<		DSKPPN	4,		;SET SNAME FOR LOOKUP >
IFN STANSW,<	MOVSI	1,400000	;ASSUME DMP NEVER.
		CAIE	6,4	>	;SKIP IF IO CODE 4 - LIST FILE.
	MOVEI	1,0			;NOT A LIST FILE.
	MOVEM	1,FEXT+1		;STANSW: LIST FILE PROT=400, DUMP NEVER.
	MOVE	1,TBL1-2(6)		;GET BUFFER INFO
	MOVEM	1,INIT2			;STORE FOR INIT

INIT1:	INIT	0,@TBL3-2(6)		;CLOBBER CHANNEL IN INIT
^NAM:	0				;DEVICE NAME HERE
INIT2:	0				;AND BUFFER HEADERS HERE
	JRST	ERR1			;DEVICE NOT AVAILABLE
INIT3:	MOVE	1,[FNAM,,LNAM]
	BLT	1,LNAM+3		;SAVE LAST FILE NAME ATTEMPTED
	XCT	TBL2-2(6)		;LOOKUP OR ENTER
	JRST	INIT4			;LOSE
	CAIE	6,2			;INPUT FILE?
	JRST	@INITIT			;NO. RETURN NOW.
					;SET UP FILNM FOR ERROR TYPEOUT

ITS,<		MOVE	6,[2,,SRCSTS]
		.RCHST	6,
		MOVE	5,[440600,,SRCSTS+1]	;FILE NAME  >;ITS

NOITS,<		SKIPN	5,LNAM			;FILE NAME 
		SETZM	LNAM+1			;NULL FILE IMPLIES NULL EXT 
		SKIPN	5
		MOVE	5,LFDEV			;USE DEVICE NAME IF NULL FILE>;NOITS


IFE STANSW,<	NOTNX,<	NOITS,<
		SETZM	INTTYF			;ASSUME INPUT DEVICE IS NOT TTY
		MOVEI	6,2			;CHANNEL NUMBER
		DEVCHR	6,			;GET DEVICE CHARACTERISTICS
		TLNE	6,10
		SETOM	INTTYF			;THIS IS A TTY.  SEE INP.
>;NOITS >;NOTNX >;IFE STANSW

	SETZM	FILNM
	SETZM	FILNM+1
	SETZM	FILNM+2
	SETZM	FILNM+3
	SETZM	FILNM+4			;6 DEV, :, 6 NAME, . 6 EXT, NULL
	MOVE	6,[440700,,FILNM]
	MOVEI	3," "
	IDPB	3,6
	JSR	NOLS3			;CONVERT SIXBIT TO ASCII
ITS,<		MOVEI	3," " >		;A MATTER OF TASTE
NOITS,<		HLLZS	3,LNAM+1	;LEFT HALF ONLY
		MOVEI	5,":"		;(POSSIBLE DEVICE NAME)
		JUMPE	3,[SKIPN LNAM	;WAS THERE A FILE NAME?
			IDPB	5,6	;SEND : FOR DEVICE
			JRST	NOLS4]	;DON'T TYPE A BLANK EXTENSION
		MOVE	5,LNAM+1	;EXTENSION
		MOVEI	3,"." >
	IDPB	3,6			;SPACE OR POINT BETWEEN FILE NAMES
	JSR	NOLS3
	MOVEI	3,0
NOLS4:	IDPB	3,6			;NULL MARKS END OF FILE NAME
	SKIPE	3,FILSTC		;GET FILE-STACK DEPTH
	OUTSTR	[ASCIZ/  /]		;TYPE 2 LEADING SPACES FOR EACH LEVEL DEEP
	SOJG	3,.-1
	OUTSTR	FILNM
	OUTSTR	TTCRLF
	JRST	@INITIT			;RETURN

ITS,<
NOLS3:		0
		MOVEI	4,6
		ILDB	3,5
		ADDI	3," "		;CONVERT TO ASCII
		IDPB	3,6
		SOJG	4,.-3
		JRST	@NOLS3

>;ITS

NOITS,<
NOLS3:		0
NOLS3A:		MOVEI	4,0
		LSHC	4,6
		ADDI	4," "
		IDPB	4,6
		JUMPN	5,NOLS3A
		JRST	@NOLS3
>;NOITS



INIT4:	CAIE	6,2			;INPUT FILE?
	JRST	ERR2			;NO. WE CAN'T WIN
ITS,<		JUMPN	3,ERR2		;LOSE IF EXPLICIT EXT
		MOVSI	3,360000 >	;GREATER THAN  
NOITS,<		TRNN	3,-1		;SKIP IF THIS WAS DEFAULT EXT
		JRST	ERR2		;NO. USER SPECIFIED EXT.
		MOVEI	3,0	>	;TRY NULL EXTENSION
	MOVEM	3,FEXT
	JRST	.+2			;TRY AGAIN
^REENT:	MOVEM	1,INITIT		;JSP HERE TO DO ENTER OVER AFTER UTPCLR
	MOVEM	4,FPPN
	JRST	INIT3


TBL3:	1				;SOURCE MODE 1
	14				;BINARY MODE 14
	1				;LISTING MODE 1
	16			;UNKNOWN
	1				;COMMANDS MODE 1

TBL1:	IDB
	ODB,,0
	LOB,,0
	0
	CTLBUF

TBL2:	LOOKUP	2,FNAM
	ENTER	3,FNAM
	ENTER	4,FNAM
	LOOKUP	5,FNAM
	LOOKUP	6,FNAM


^^FNAM:	0
FEXT:	0
	0
^FPPN:	0

^^LFDEV: 0				;LAST DEVICE ATTEMPTED
^^LNAM:	BLOCK	4			;LAST NAME ATTEMPTED (FOR LOOKUP)
>;NOTNX

TNX,<
;INITIT -- GTJFN AND OPEN FILE
;GTNAM SHOULD BE SET UP ON ENTRY.  PNTR TO STRING END IN 1, TERMINATOR IN 2.
;DEFAULT EXT STRING PTR IN 3, 'CHANNEL' IN 6 AS BEFORE.
^^INITIT: 0
	MOVE	5,2			;SAVE TERMINATOR
	MOVEM	3,GTEXT			;SAVE EXT FOR GTJFN
	SETZ	3,
	IDPB	3,1			;TERMINAL NULL
	MOVEI	1,GTTBL			;PARAM BLOCK FOR GTJFN
	HRROI	2,GTNAM			;FILE NAME STRING
	MOVE	3,TBL3-2(6)		;GTJFN BITS FOR CHAN
	MOVEM	3,GTTBL
	GTJFN
	JRST	ERR1			;CAN'T FOR ONE REASON OR ANOTHER
	MOVEM	1,JFNTBL-2(6)		;SAVE JFN
	MOVE	2,TBL2-2(6)		;OPENF FLAGS FOR CHAN
	OPENF
	JRST	ERR2			;CAN'T OPEN
	DVCHR
	SETZ	1,
	LDB	2,DEVPTR		;PICK UP DEVICE TYPE
	SKIPN	2
	TLO	1,400000		;IF DISK
	CAIN	2,12			;TTY:?
	TLO	1,200000		;YEP
	HLLM	1,JFNTBL-2(6)		;SAVE FLAGS
	CAIE	6,2
	JRST	INITX1			;NOT SOURCE FILE
	JSR	XJFNS
INITX:	MOVE	2,5			;RESTORE TERMINATOR
	JRST	@INITIT			;EXIT

INITX1:	CAIE	6,6			;IF INDIRECT
	SKIPL	1,JFNTBL-2(6)
	JRST	INITX			;IF NOT PMAPPABLE
	HRLI	1,11			;FDBSIZ,,JFN
	HRLZI	2,007700		;BYTE SIZE BITS
	LDB	3,SZPTR			;LOAD UP CORRECT SIZE
	LSH	3,=24			;JUSTIFY
	CHFDB				;SET SIZE FOR PEOPLE WHO DON'T PMAP
	JRST	INITX

SZPTR:	POINT	6,TBL2-2(6),5		;POINTER TO BYTE SIZE FIELD IN OPENF PARAM
DEVPTR:	POINT	9,2,17			;POINTER TO DEVICE TYPE FIELD IN DVCHR RET

;GTJFN PARAMETER BLOCK
^^GTTBL: 0				;FLAG,,DEF VER
	XWD	377777,377777		;NO JFNS
^^GTDEV:0				;DEF DEV
	0				;DEF DIR
	0				;DEF NAME
^^GTEXT:0				;DEF EXT
	0				;PROT
	0				;ACCT
	0				;REQ JFN

^^GTNAM: BLOCK =26			;FILE NAME STRING

;JFN TABLE
;B0 SET IF FILE IS PMAPPABLE
^^JFNTBL: BLOCK 5

;OPENF FLAG BITS
TBL2:	XWD	440000,200000		;INPUT: 36 BIT, READ ONLY
	XWD	440000,300000		;BIN: 36 BIT, READ/WRITE...
	XWD	070000,300000		;LIST: 7 BIT, READ/WRITE...
	0				;UNUSED (I HOPE)
	XWD	440000,200000		;IND: 36 BIT, READ ONLY

;GTJFN FLAG BITS
TBL3:	XWD	100000,0		;INPUT: OLD FILE
	XWD	400000,0		;BIT: FOR OUTPUT
	XWD	400000,0		;LIST: FOR OUTPUT
	0				;UNUSED
	XWD	100000,0		;IND: OLD FILE

MAKSIX:	0
	MOVEI	2,0
	MOVEI	3,6
MAKSX1:	ILDB	4,1
	JUMPE	4,MAKSX2		;STOP AT NULL
	CAIL	4," "			;FLUSH IF OUT OF RANGE
	CAIL	4,140			;THERE SHOULD BE NO LOWERCASE 
	JRST	MAKSX3
	LSH	2,6
	IORI	2,-" "(4)
MAKSX3:	SOJG	3,MAKSX1		;LOOP UNTIL DONE
MAKSX2:	JUMPE	2,@MAKSIX
	TLNE	2,770000
	JRST	@MAKSIX
	LSH	2,6
	JRST	.-3

^^XJFNS:0				;CALLED FROM .INSRT TOO
	HRRZ	2,JFNTBL		;JFN AGAIN
	HRROI	1,FILNM1		;GET THE FIRST FILE NAME 
	MOVSI	3,001000		;FILE NAME ONLY. NO PUNCT.
	JFNS	
	MOVE	1,[POINT 7,FILNM1]
	JSR	MAKSIX			;CONVERT NAME TO SIXBIT
	MOVEM	2,FILNM1		;SAVE FOR .FNAM1 FUNCTION
	HRROI	1,FILNM2
	HRRZ	2,JFNTBL
	MOVSI	3,000100		;EXTENSION ONLY. NO PUNCT.
	JFNS
	MOVE	1,[POINT 7,FILNM2]
	JSR	MAKSIX
	MOVEM	2,FILNM2
	HRRZ	2,JFNTBL		;JFN
	HRROI	1,FILNM			;FOR TITLES
	MOVE	3,[XWD 211110,1]	;DEF DEV, FRC DIR, NAME, EXT, VER W/PUNC
	JFNS
	HRROI	1,[ASCIZ/  /]		;2 SP FOR EACH NESTING LEVEL
	SKIPE	3,FILSTC
	PSOUT
	HRROI	1,[ASCIZ/  /]		;2 SP FOR EACH NESTING LEVEL
	SOJG	3,.-2
	HRROI	1,FILNM
	PSOUT				;AND FILE NAME
	SETZ	3,			;END WITH A WORD OF NULLS
	REPEAT	5,<IDPB 3,1>
	SUBI	1,FILNM
	MOVNS	1
	HRLM	1,FILCNT
	HRROI	1,TTCRLF		;CRLF FOR USER'S TERMINAL
	PSOUT
	JRST	@XJFNS
>;TNX
	BEND INITIT

^RELFIL:BLOCK 5			;SAVE REL FILE NAME FOR RENAME AT END
;PROCESS ENTIRE COMMAND LINE (CO-ROUTINE) DOES @ AND ! COMMANDS

^INITL:	0
	SETZM	RPGNEED		;CLEAR EOF HACK FOR COMMAND FILE

NOTNX,<

	MOVEI	1,0
NOITS,<	HRLOI	3,'REL'>	;NOITS, -1 RH FLAGS DEFAULT EXTENSION
ITS,<		SETZM	 LIMBO
		MOVSI	3,'REL'	>;ITS
	SETZB	5,4		;NO FILE NAME, PPN
	JSR	GETFIL
	JRST	NOBIN		;NO FILE THERE
	CAIN	2,"!"		;CHECK FOR LOAD COMMAND
	JRST	DOLOD
	JUMPN	1,.+2		;NULL DEVICE?
	MOVSI	1,'DSK'		;YES. ASSUME DSK
	CAIN	2,"@"
	JRST	DOAT		;PROCESS COMMAND FILE.
	MOVEM	5,RELFIL	;FILE NAME
NOITS,<	HLLZM	3,RELFIL+1 >	;STORE REL FILE EXT. (NOT RIGHT HALF BITS)
ITS,<	MOVEM	3,RELFIL+1 >	;STORE THE WHOLE WORD FOR EXT
	MOVEM	1,RELFIL+4	;DEVICE NAME
	TRO	BDEV		;INDICATE WE HAVE A BINARY DEVICE
	MOVEI	6,3		;DEVICE 3 FOR BINARY

ITS,<	CAIE	2,15
	CAIN	2,12
	SKIPA	2,[12]		;PRECISELY <FILE SPEC>CRLF. SET DELIM TO LF
	JRST	INITL1
	MOVEM	2,RPGNEED
	SETZM	MOINSW
	MOVSI	3,'REL'
	EXCH	3,RELFIL+1
	CAMN	3,RELFIL+1
	MOVEI	3,0
	MOVEM	3,SOUT		;SAVE SOURCE FILE EXT
	MOVSI	3,'REL'		;USE DEFAULT BINARY FILE EXT
	JSR	INITIT
	OUTBUF	3,2
	MOVE	3,SOUT		;EXTENSION
	MOVE	1,RELFIL+4	;DEVICE
	MOVE	5,RELFIL	;FILE NAME
	JRST	NOLS3
>;ITS

INITL1:	JSR	INITIT
IFE STANSW,<	OUTBUF	3,2	>;NO STANFORD
IFN STANSW,<	OUTBUF	3,=10	>;STANFORD
	JSR	SWITCH		;GO SEE IF WE HAVE A SWITCH TO PROCESS
NOBIN:	CAIE	2,","		;DOES HE WANT LISTING
	JRST	NOLST		;APPEARANTLY NOT
	MOVSI	1,'DSK'		;ASSUME DSK OUTPUT
	SETZB	5,4		;NO FILE, NO PPN
IFN STANSW,<MOVSI 3,'LST'>	;ASSUME LST
IFE STANSW,<MOVSI 3,'CRF'>	;FOR CREF.
	JSR	GETFIL
	JRST	NOLST		;MUST BE ,_
	MOVEI	6,4		;SET IO CHANNEL FOR LISTING
	JSR	INITIT
	TRO	LDEV
	SETOM	LISTSW
IFE STANSW,<	OUTBUF	4,5 	>;NOT STANFORD
IFN STANSW,<	OUTBUF	4,=10	>;STANFORD
	JSR	SWITCH
NOLST:	CAIE	2,"_"
	CAIN	2,"="		;ALTERNATIVE FOR RPG HACKERS
	JRST	.+2
	JRST	ERR3
	SETZM	MOINSW		;HAVEN'T SEEN ANY INPUT FILES ON THIS LINE
	MOVSI	1,'DSK'		;DEFAULT DEVICE
NOLS2:	MOVEI	5,12
	MOVEM	5,RPGNEED	;SET EOF HACK. IN CASE OF EARLY EOF ON COMMAND FILE
	SETZB	4,5		;NO PPN, NO FILE.
NOITS,<	HRLOI	3,'FAI'	>	;ASSUME DEFAULT EXT
ITS,<	MOVEI	3,0 >		;ASSUME NO EXTENSION
	JSR	GETFIL
	JRST	[CAIN 2,12	;FILE SPEC WAS EMPTY.
		SKIPN MOINSW	;HAVE WE SEEN A FILE ON THIS LINE?
		JRST ERR3
		SKIPN RPGSW	;RPG MODE?
		OUTSTR [BYTE(7)15,12,"_"]	;PROMPT IF WE'RE TAKING TTY COMMANDS
		SETZM MOINSW			;THIS IS TO CATCH CRLF AS ILLEGAL
		JRST NOLS2]	;SAW  ...FILE,<CRLF> (OR ..._<CRLF>)
NOLS3:	MOVEM	1,SAVDEV#	;SAVE FOR NEXT TIME
	MOVEI	6,2		;DEVICE 2 = INPUT FILE.
	JSR	INITIT

	SETZM	IRECN		;INITIALIZE RECORD NUMBER FOR RANDOM ACCESS IO
	MOVEI	12,IBUFR1	;ADDRESS OF THE FIRST BUFFER
	TLO	12,400000
	MOVEM	12,IDB		;SET UP BUFFER
	JSR	SWITCH		;SEE IF THERE ARE ANY SWITCHES
	SETZM	MOINSW#
NOITS,<		CAIN	2,";"	;ALLOW SEMICOLON TO EQUAL COMMA (RPG HACKERS)
		SETOM	MOINSW	>
	CAIE	2,"+"		;ALLOW + TO DENOTE MORE INPUT (RPG HACKERS)
	CAIN	2,","
	SETOM	MOINSW		;SAY HE HAS MORE TO COME

>;NOTNX

TNX,<
	HRROI	3,[ASCIZ /REL/]	;DEF EXT FOR BIN FILE
	JSR	TGETF		;GET TENEX FILE NAME
	JRST	NOBIN		;NO FILE FOUND
	CAIN	2,"!"
	JRST	DOLOD		;WANTS .SAV FILE RUN
	CAIN	2,"@"
	JRST	DOAT		;INDIRECT COMMAND FILE
	TRO	BDEV		;GOT A BIN FILE
	MOVEI	6,3		;GOES ON CHANNEL 3
	JSR	INITIT		;GTJFN,OPENF
	SETOM	ODB		;IN CASE IT IS PMAPABLE...
	SETZM	ODB+2		;CLEAR COUNTER
	JSR	SWITCH		;LOOK FOR SWITCHES
NOBIN:	CAIE	2,","
	JRST	NOLST		;BIN_
	HRROI	3,[ASCIZ /LST/]	;DEF LIST EXTENSION
	JSR	TGETF		;GET TENEX FILE NAME
	JRST	NOLST		;BIN,_
	MOVEI	6,4		;CHANNEL FOR FOR LIST FILE
	JSR	INITIT		;GTJFN,OPENF
	SETOM	LOB		;IN CASE IT IS PMAPABLE, FIX IT SO WE GET 0 FIRST
	SETZM	LOB+2		;CLEAR COUNTER!!
	TRO	LDEV
	SETOM	LISTSW
	JSR	SWITCH		;LOOK FOR SWITCHES
NOLST:	CAIE	2,"_"
	CAIN	2,"="
	JRST	.+2
	JRST	ERR3		;NO BACK ARROW
	SETZM	MOINSW#
NOLS2:	MOVEI	5,12		;EOF JOINS HERE...
	MOVEM	5,RPGNEED	;SUPER DUPER HACK	
	HRROI	3,[ASCIZ /FAI/]	;DEF SOURCE EXT
	JSR	TGETF		;GET TENEX FILE NAME
	JRST	[CAIN 2,12
		 SKIPN MOINSW
		 JRST ERR3
		 SKIPN	RPGSW
		 OUTSTR [ASCIZ /
_/]				;PROMPT INTERACTIVE USER.
		 SETZM MOINSW
		 JRST NOLS2]
	MOVEI	6,2		;SOURCE ON CHAN 2
	JSR	INITIT		;GTJFN, OPENF
	JSR	SWITCH		;LOOK FOR SWITCHES
	SETZM	MOINSW
	CAIN	2,","
	SETOM	MOINSW		;IF MORE FILES ON THIS LINE
	SETOM	IRECN		;FIRST INCR WILL MAKE THIS ZERO
	MOVEI	1,400000	;THIS FORK
	DIR			;DISABLE INTERRUPTS
	TRNE	LDEV
	SKIPGE	JFNTBL+2
	JRST	.+2		;NO LIST OR PMAPABLE
	MOVE	3,LSTBF		;GUARANTEE THAT IT IS MAPPED
	TRNE	BDEV
	SKIPGE	JFNTBL+1
	JRST	.+2		;NO BIN OR PMAPABLE
	MOVE	3,BINBF		;GUARANTEE THAT IT IS MAPPED
	SKIPL	JFNTBL
	MOVE	3,SRCBF		;GUARANTEE THAT IT IS MAPPED
	MOVE	3,TRM		;ALWAYS HIT TERMINATOR PAGE...
	CIS			;IN CASE THERE WERE ANY PAGE FAULTS
	EIR			;TURN INTERRUPTS ON AGAIN

>;TNX

	AOS	INITL		;FORM SKIP RETURN
	MOVEM	17,INSV+17	;SAVE ACS FOR CO-ROUTINE CALL FROM EOF
	MOVEI	17,INSV
	BLT	17,INSV+16
	MOVE	17,INSV+17
	JRST	@INITL		;RETURN TO CALLER.

INSV:	BLOCK 20		;SAVE AC'S FOR CO-ROUTINE CALL FROM EOF
^^TSV:	BLOCK 20		;SAVE MAIN AC'S FROM EOF DURING CO-ROUTINE CALL

^EOF:	0			;HERE AT EOF ON INPUT FILE
	SKIPN	MOINSW		;ARE THERE MORE INPUT FIELDS?
	JRST	FAT		;NO. LOSE BIG
NOTNX,<	RELEAS	2,>		;YES.  RELEASE INPUT FILE
	MOVEM	17,TSV+17	;SAVE OUR AC'S
	MOVEI	17,TSV
	BLT	17,TSV+16
TNX,<	JSR	CLSSRC>
	MOVEI	17,EOFRT	;SETUP RETURN ADDRESS FROM INITL
	MOVEM	17,INITL
	MOVSI	17,INSV		;RESTORE AC'S THAT INITL SAVED
	BLT	17,17
ITS,<	MOVE	17,TPDP	>	;I WANT A PUSH DOWN POINTER!
TNX,<	MOVE	17,TPDP	>	;INITL DOES UUOS, NEEDS STACK
NOTNX,<	MOVE	1,SAVDEV>	;GET THE LAST DEVIC NAME THAT WE WERE USING
	JRST	NOLS2		;JUMP INTO INITL
EOFRT:	JRST	FAT		;RETURN FROM INITL - FAILURE
	MOVSI	17,TSV		;SUCCESS.  RESTORE MAIN AC'S
	BLT	17,17
	JRST	@EOF		;RETURN TO CALLER. WE HAVE MORE FILE TO MUNCH


NOTNX,<

SWPR:	BLOCK 6			;PUT PARAMS FOR SWAP HERE
^^SAVPPN: 0

DOLOD:	JUMPN	1,.+2		;CHANGE DEFAULT TO SYS
	MOVSI	1,'SYS'
	TRNE	3,-1		;RH OF 3 WILL BE NON-ZERO IF EXPLICT EXTENSION SEEN
	MOVSI	3,0		;DEFAULT TO MONITOR SUPPLIED .DMP (OR .SAV, ETC.)
	MOVEM	1,SWPR		;DEVICE
	MOVEM	5,SWPR+1	;FILE NAME
	MOVEM	3,SWPR+2	;EXTENSION
	MOVEM	4,SWPR+4	;PPN
	MOVEI	1,SWPR
	SKIPGE	RPGSW
	HRLI	1,1		;START IN RPG MODE IF WE WERE STARTED IN RPG MODE
	JSR	DELRPG
	RESET
	MOVE	0,.JBFF
	CORE	0,		;SHRINK BECAUSE TOPS-10 IS STUPID
	JFCL
	RUN	1,
	JRST	4,		;(AT STANFORD, YOU CAN'T GET HERE.)


DOAT:	MOVEI	6,6		;HERE WHEN FILE@ COMMAND IS SEEN.
ITS,<	CAMN	3,['REL   ']
	MOVSI	3,'CMD'		;CHANGE DEFAULT EXTENSION >  ;ITS
NOITS,<	TLZ	3,(3)>		;IF NO EXT GIVEN, RIGHT HALF IS -1. MAKE NULL
	MOVEI	6,6		;DEVICE 6
	JSR	INITIT		;GO GET IT SET UP
	PUSHJ	P,RPGS1		;NOW FAKE READING THE RPG FILE.
	JRST	RPGGO		;SET RETURN FROM RPGS1
>;NOTNX

IFN TENEX!ITSSW,<
TPDP:	-20,,TPDL-1
TPDL:	BLOCK 20
>

TNX,<
STRTCD:
	PHASE	5		;TO EXEC IN ACS
NOT20,<
	HRR	2,3		;400000,,PG		;5
	PMAP			;OUT OF CORE		;6
	AOBJN	3,.-2		;IF MORE PAGES		;7
>;NOT20
T20,<
	PMAP
	JFCL
	JFCL
>;T20
	MOVE	1,4		;400000,,JFN		;10
	GET			;LOAD FORK UP		;11
	MOVEI	1,400000	;THIS FORK		;12
	GEVEC						;13
	HRRZ	1,.JBSA		;ASSUME 10/50 FORMAT	;14
	TLNN	2,777000				;15
	HRRZ	1,2		;TENEX FORMAT		;16
XXSTRT::JRST	(1)		;START US UP		;17
				;THIS GETS CLOBBERED TO JRST 1(1) 
				;FOR RPG MODE STARTUP
	DEPHASE
LCD__.-STRTCD

DOLOD:	SETZ	3,
	IDPB	3,1		;TERMINAL NULL ON FILE NAME
NOT20,<	HRROI	3,[ASCIZ /SAV/]	;DEF RUN EXTENSION >;NOT20
T20,<	HRROI	3,[ASCIZ /EXE/]	;DEF RUN EXTENSION  >;T20
	MOVEM	3,GTEXT
	HRROI	3,[ASCIZ/SYS/]
	MOVEM	3,GTDEV		;default device for run
	JSR	DELRPG		;DELETE RPG FILE, IF ANY.
	MOVEI	1,GTTBL		;GTJFN PARAM BLOCK
	HRROI	2,GTNAM		;FILE NAME STRING
	MOVE	3,[XWD 100000,0];OLD FILE
	MOVEM	3,GTTBL
	GTJFN
	JRST	TNXERR		;LOSE BIG
	HRLI	1,400000	;THIS FORK
	MOVE	4,1		;400000,,JFN OF NEW FILE
	MOVEI	1,400000	;THIS FORK
	SETO	2,		;ALL INTS
	DIC			;OFF!!
	SETO	1,
	MOVE	2,[XWD STRTCD,5]
	BLT	2,5+LCD-1	;MOVE STARTUP CODE TO ACS
	SKIPGE	RPGSW		;IN RPG MODE?
	HRRI	XXSTRT,1	;SET ENTRY OFFSET
NOT20,<
	HRLZI	2,400000
	MOVE	3,[XWD -777,1]
>;NOT20
T20,<
	MOVE	2,[400000,,1]	;PROCESS HANDLE,,FIRST PAGE
	MOVE	3,[400000,,777]	;PAGE COUNT
>;T20
	JRST	5		;LOAD ON TOP OF SELF AND START

^TNXERR:	
	MOVEI	1,101
	HRLOI	2,400000	;PROCESS HANDLE, MOST RECENT ERROR
	MOVEI	3,0
	ERSTR
	JFCL
	JFCL
	HALTF
	JRST	.-1
DOAT:	MOVEI	6,6		;CHAN 6 FOR INDIRECT FILE
	SETZ	3,		;NO DEF EXT
	JSR	INITIT		;GTJFN, OPENF
	HLLOS	RPGSW		;0,,-1 IS INDIRECT (I HOPE)
	SETZM	CTLBUF+2	;CLEAR COUNTER
	MOVEI	1,400000	;THIS FORK
	DIR			;KILL INTERRUPTS
	MOVE	3,INDBF		;MAP BUFFER PAGE
	CIS			;CLEAR INTERRUPTS
	EIR			;ENABLE INTERRUPTS
	JRST	RPGGO		;OFF WE GO...

>;TNX
ERR3:	OUTSTR	[ASCIZ /INPUT SYNTAX ERROR/]
ERR:	OUTSTR	TTCRLF
	MOVEI	4,0
	SKIPN	RPGSW		;IF IN RPG MODE, SCAN TO END OF LINE
	JRST	@INITL
ERRL:	CAIN	2,12
	JRST	@INITL
	JSR	IN
	JRST	ERRL

NOTNX,<
ERR1:	OUTSTR	[ASCIZ /DEVICE NOT AVAILABLE: /]
	MOVE	7,NAM
ERRM:	PUSHJ	P,MS6
	OUTSTR	TTCRLF
	MOVEI	4,0
	JRST	@INITL

ERR2:	CAIE	6,3				;SKIP IF ENTER FAILURE ON BINARY
	CAIN	6,4				;SKIP IF NOT ENTER FAILURE ON LIST
	SKIPA	6,[[ASCIZ /ENTER FAILED /]]	;ENTER FAILURE
	MOVEI	6,[ASCIZ /FILE NOT FOUND /]	;LOOKUP FAILURE
	OUTSTR	(6)
	MOVE	7,FNAM
	PUSHJ	P,MS6
	OUTCHR	["."]
ITS,<	MOVE	7,FNAM+1>
NOITS,<	HLLZ	7,FNAM+1>
	JRST	ERRM

MS6:	MOVEI	6,0				;PRINT SIXBIT CONTENTS OF 7
	JUMPE	7,CPOPJ
	LSHC	6,6
	ADDI	6," "
	OUTCHR	6
	JRST	MS6
>;NOTNX


TNX,<
ERR1:	OUTSTR	[ASCIZ /Can't get JFN: /]
	OUTSTR	GTNAM
ERR1A:	OUTSTR	TTCRLF
	MOVE	2,5				;RESTORE TERMINATOR
	JRST	@INITL				;FAIL

ERR2:	OUTSTR	[ASCIZ /Can't open file: /]
	MOVEI	1,101				;PRIMARY OUTPUT
	HRRZ 	2,JFNTBL-2(6)			;JFN
	MOVE	3,[XWD 211110,1]		;DEF DEV,FRC DIR,NAM,EXT,VER W/PUNC
	JFNS					;SPIT OUT OFFENDING FILE NAME
	MOVE	1,2
	RLJFN					;RELEASE JFN
	JFCL
	JRST	ERR1A
>;TNX
	BEGIN SWITCH
^SWITCH:0
	CAIE	2,"/"
	CAIN	2,"("
	JRST	.+2
	JRST	@SWITCH		;WE'RE NOT INTERESTED IN THIS CHARACTER.
	SETZM	LPARF#		;NOT IN PARENTHESES SWITCHES
	CAIN	2,"("
	SETOM	LPARF		;MARK PARENS TYPE SWITCH
SW0:	MOVEI	10,0		;NUMBER COUNT
SW1:	JSR	IN		;GET A SWITCH
	CAIN	2,")"		;SEE IF END
	JRST	RPAR		;YES
	CAIG	2,"9"
	CAIGE	2,"0"
	JRST	SW1A
	IMULI	10,=10		;ACCUMULATE NUUMBERS
	ADDI	10,-"0"(2)
	JRST	SW1

SW1A:	CAIL	2,140		;CHANGE LOWER TO UPPER
	SUBI	2,40
	CAIL	2,"A"
	CAILE	2,"Z"
	JRST	ERR4		;OUT FOR BOUNDS - ILLEGAL
	HLRZ	7,TBL1-"A"(2)	;GET INSTRUCTION
	CAIN	7,(<JUMPA>)	;IS THIS ILLEGAL ON INPUT?
	CAIE	6,2		;YES. SKIP IF THIS INPUT TERM
	JRST	OK		;SWITCH IS OK HERE
	JRST	ERR5		;ILLEGAL ON INPUT TERM

OK:	XCT	TBL1-"A"(2)	;PERFORM SWITCH FUNCTION
SW4:	SKIPE	LPARF		;IN PARENS?
	JRST	SW0		;YES - LOOK FOR MORE
SW3:	JSR	IN		;GET ANOTHER CHR
	JRST	SWITCH+1

RPAR:	SKIPE	LPARF		;IN PARENS?
	JRST	SW3		;YES, EXIT TIME
	JRST	ERR3		;NO, LOSAGE

ERR4:	SKIPA	6,[[ASCIZ /UNKNOWN SWITCH: /]]
ERR5:	MOVEI	6,[ASCIZ /SWITCH ILLEGAL ON INPUT TERM: /]
	OUTSTR	(6)
	OUTCHR	2
	JRST	ERR

;IF THE INSTRUCTION IS A JUMPA, IT IS ILLEGAL ON THE INPUT TERM

IFE SYMDMP,<SYMWRT__ERR4>	

TBL1:	NOTNX,<JRST	ADV;>	JRST ERR4	;A - ADVANCE
	NOTNX,<JRST	BSP;>	JRST ERR4	;B - BACKSPACE
	JUMPA	CREFST		;C - CREF (ILLEGAL ON INPUT TERM)
	JRST	ERR4		;D - ILLEGAL
	JUMPA	SLSHE		;E - SET MAIN PDL LENGTH (ILLEGAL ON INPUT)
	SETZM	ERSTSW		;F - DON'T STOP AT ERRORS
	JRST	ERR4		;G - ILLEGAL
	JRST	ERR4		;H - ILLEGAL
	SETOM	XL1IG		;I - IGNORE XLIST1
	JRST	ONCRF		;J - TURN ON CREF FOR THIS (INPUT) TERM
	SETZM	XCRFSW		;K - TURN OFF CREF FOR THIS (INPUT) TERM
	SETOM	NOLTSW		;L - DON'T LIST LITERAL VALUES WITH TEXT
	JRST	ERR4		;M - ILLEGAL
	SETOM	TTYERR		;N - DON'T LIST ERRORS ON TTY
	SETOM	FUNSUP		;O - OMIT .FUN FILE OUTPUT
	JUMPA	SLSHP		;P - SET SIZE OF PDL (ILLEGAL ON INPUT TERM)
	JRST	ERR4		;Q - ILLEGAL
	SETOM	ERSTSW		;R - STOP ON ERRORS
	SETOM	SYMOUT		;S - LIST SYMBOL TABLE
	NOTNX,<JRST	LND;>	JRST ERR4	;T - ADVANCE TO END OF TAPE
	SETOM	UNDLNS		;U - UNDERLINE MACRO EXPANSION
	JUMPA	PAGER		;V - SET PAGE LENGTH FOR LISTING
	NOTNX,<JRST	WND;>	JRST ERR4	;W - REWIND TAPE
	SETOM	NOEXP		;X - DON'T LIST MACRO EXPANSIONS
	JRST	SYMWRT		;Y - FOR REG'S SYMBOL TABLE OUTPUT
	JUMPA	ZER		;Z - ZERO DECTAPE DIRECTORY
;THE MAGTAPE SWITCHES
NOTNX,<
ZER:	DPB	6,[POINT 4,ZERA,12]		;/Z SWITCH
	DPB	6,[POINT 4,ZERA+1,12]
ZERA:	UTPCLR
	CLOSE
	JSP	1,REENT				;GO DO ENTER AGAIN
	JRST	SW4

	DEFINE MAG (A,B)
<	DPB	6,[POINT 4,.+1,12]
	MTAPE	A
	SOJG	10,.-1				;DO IT A NUMBER OF TIMES
	IFN B,<	XCT .-2
		DPB	6,[POINT 4,.+3,12]
		DPB	6,[POINT 4,.+3,12]
		DPB	6,[POINT 4,.+3,12]
		MTAPE	0
		STATO	1B24
		MTAPE	16>
	JRST	SW4
>

WND:	MAG 1,0
ADV:	MAG 16,0
BSP:	MAG 17,1
LND:	MAG 10,0
>;NOTNX

TNX,<
ZER:	HRRZ	1,JFNTBL-2(6)		;JFN
	DVCHR				;CONVERT TO DEVICE
	INIDR				;GOD HELP YOU IF THIS IS NOT DTAN:
	JRST	[OUTSTR	[ASCIZ /Can't clear directory: /]
		 MOVEI	1,101		;PRIMARY OUTPUT
		 HRRZ	2,JFNTBL-2(6)	;JFN
		 MOVE	3,[XWD 111110,1];FRC DEV, DIR, NAM, EXT, VER W/PUNC
		 JFNS			;SPIT IT OUT
		 MOVE	1,2
		 CLOSF			;HAVENT MAPPED ANYTHING ANYHOW
		 JFCL
		 JRST	ERR]
	JRST	SW4

;NO HOPE OF MAGTAPES EVER WORKING ANYHOW...
>;TNX

CREFST:	SETOM	CREFSW
	SETOM	XCRFSW
	MOVEI	10,LINLEN-8
	MOVEM	10,CHRPL	;SET CHRPL SO CREF LISTINGS WON'T OVERFLOW - JHS
	JRST	SW4

ONCRF:	SKIPE	CREFSW
	SETOM	XCRFSW
	JRST	SW4

SLSHP:	SKIPN	10
	MOVEI	10,1
	ADDM	10,PSWIT
	JRST	SW4

SLSHE:	SKIPN	10
	MOVEI	10,1
	ADDM	10,ESWIT
	JRST	SW4

PAGER:	CAIL	10,20
	MOVEM	10,PAGSIZ	;SET PAGE SIZE FROM V SWITCH
	JRST	SW4

BEND SWITCH
;	HERE FOR FATAL ERROR. END OF FILE AND NO END STATEMENT
FAT:
	MOVEI	3,LITMS
	SKIPE	LITPG
	PUSHJ	P,FMES			;IN LITERAL.

	MOVEI	3,TXTMS
	SKIPE	TXTPG
	PUSHJ	P,FMES			;IN ASCII, SIXBIT

	MOVEI	3,SARMS
	SKIPE	SARGPG
	PUSHJ	P,FMES			;MACRO ARGUMENT SCAN

	MOVEI	3,REPMS
	SKIPE	REP0PG	
	PUSHJ	P,FMES			;REPEAT 0, CONDITIONAL, OR COMMENT

	MOVEI	3,TXTIMS
	SKIPE	TXTIPG			;FOR OR DEFINE?
	PUSHJ	P,FMES
	FATAL	[ASCIZ /FATAL END OF FILE & NO END STMT/] ;COUP DE GRAS

;FMES IS ALSO CALLED BY PSLIT TO HELP POOR USERS DETECT TROUBLE SOONER

^FMES:	MOVE	2,[ASCII /     /]	;5 BLANKS
	SKIPG	1,@-1(3)		;SKIP IF THERE'S AN SOS LINE NUMBER
	MOVEM	2,@-1(3)		;STORE BLANKS INTO LINE NUMBER WORD
	JUMPGE	1,FMES2			;JUMP IF THERE WAS AN SOS NUMBER OR EMPTY
	MOVEI	1,1(1)			;LINE NUMBER CAME FROM INLINE.
	MOVSI	4,440700
	HRRI	4,@-1(3)		;MAKE POINTER TO THE LINE NUMBER TEXT WORD
	PUSHJ	P,RNUM			;CONVERT TO TEXT.
FMES2:	MOVE	1,-2(3)			;GET PAGE NUMBER
	MOVE	4,-1(3)			;GET ADDRESS OF LINE NUMBER TEXT
	ADDI	4,2			;ADVANCE PAST THE TEXT OF " PAGE "
	HRLI	4,(<POINT 7,0,6>)	;POINTER TO TRAILING BLANK OF " PAGE "
	PUSHJ	P,RNUM			;CONVERT PAGE NUMBER TO PAGE NUMBER.
NOTNX,<
	MOVE	1,[POINT 7,-5(3)]	;POINTER TO THE FILE NAME (LEADING SPACE)
	ILDB	2,1			;READ A BYTE... APPEND FILE NAME TO END OF
	IDPB	2,4			;STUFF A BYTE ... ERROR MESSAGE
	JUMPN	2,.-2			;LOOP. END ON NULL
>;NOTNX
TNX,<
	MOVE	1,4			;CORRECT BYTE POINTER
	HRRZ	2,-3(3)			;JFN
	MOVE	4,3			;SAVE ADDR
	MOVE	3,[XWD 211110,1]	;DEF DEV, FRC DIR,NAM,EXT,VER W/PUNC
	JFNS				;EXPAND IT
	MOVE	3,4			;RESTORE ADDR
>;TNX
	ERROR	(3)			;MAKE AN ERROR MESSAGE
	POPJ	P,

RNUM:	IDIVI	1,=10
	HRLM	2,(P)
	SKIPE	1
	PUSHJ	P,RNUM
	HLRZ	1,(P)
	ADDI	1,"0"
	IDPB	1,4
	POPJ	P,

^LITFIL:BLOCK NOTNX,<5;> 1		;FILE NAME IN WHICH LITERAL OCCURS
^LITPG:	0				;PAGE NUMBER
	LITLIN				;POINTER TO LINE NUMBER
^LITMS:	ASCII /  LITERAL LINE /		;PRECISELY SOME MULTIPLE OF 5 CHARACTERS
^LITLIN:0				;LINE NUMBER HERE BECOMES TEXT.
	ASCII / PAGE /			;PRECISELY 6 CHARACTERS
	BLOCK NOTNX,<4;> =27				;TEXT OF PAGE NUMBER, FILE NAME COPIED HERE

^TXTFIL:BLOCK NOTNX,<5;> 1
^TXTPG:	0
	TXLIN
TXTMS:	ASCII /TEXT STATEMENT LINE /
^TXLIN:	0
	ASCII / PAGE /
	BLOCK NOTNX,<4;> =27

^SARFIL:BLOCK NOTNX,<5;> 1
^SARGPG:0
	SARLN
SARMS:	ASCII /REPEAT OR MACRO ARGUMENT LINE /
^SARLN:	0
	ASCII / PAGE /
	BLOCK NOTNX,<4;> =27

^REPFIL:BLOCK NOTNX,<5;> 1
^REP0PG:0
	REPPG
REPMS:	ASCII / REPEAT 0, CONDITIONAL, OR COMMENT LINE /
^REPPG:	0
	ASCII / PAGE /
	BLOCK NOTNX,<4;> =27

^TXTIFL:BLOCK NOTNX,<5;> 1
^TXTIPG:0
	TXTIL
TXTIMS:	ASCII / FOR OR DEFINE LINE /
^TXTIL:	0
	ASCII / PAGE /
	BLOCK NOTNX,<4;> =27

BEND INIT
BEGIN RPG 	SUBTTL INITIALIZATION OF PROGRAM
;SETRPG.  CALLED WITH PUSHJ.  SKIPS ON FAILURE OF ANY KIND

^SETRPG:
	SKIPL	RPGSW			;IN RPG MODE?
	JRST	CPOPJ1			;NO. GIVE THE SKIP RETURN
NOTNX,<
IFN TMPCSW,<	MOVSI	1,'FAI'
		MOVEM	1,RPGNAM	;FILE NAME ARGUMENT FOR TMPCOR
		MOVE	1,[-200,,RPGBUF-1]
		MOVEM	1,RPGNAM+1	;IOWD FOR READING TMPCOR FILE
		MOVE	1,[POINT 7,RPGBUF]
		MOVEM	1,CTLBUF+1	;BYTE POINTER FOR IN
		MOVE	1,[2,,RPGNAM]	;READ AND DELETE FILE.
		TMPCOR	1,
		JRST	DSKRPG		;NOT IN SERVICE, OR NO FILE THERE
		CAILE	1,200		;MAKE SURE WE GOT IT ALL
		JRST	RPGIN5		;WE LOSE.
		SETZM	RPGBUF(1)	;CLEAR FIRST FREE WORD. NEED A NULL AT END
		IMULI	1,5		;CNVT WC FROM TMPCOR TO CHAR CNT
		ADDI	1,1		;BE SURE TO INCLUDE THE EXTRA NULL
		MOVEM	1,CTLBUF+2	;SAVE BYTE COUNT
		SETOM	TMPCOR#		;FLAG WE ARE DOING TMPCORE
		JRST	RPGS5
>;IFN TMPCSW

DSKRPG:	MOVSI	1,'FAI'
	PJOB	2,			;JOB NUMBER
	MOVEI	4,3			;3 CHARACTERS OF JOB NUMBER
	IDIVI	2,=10			;3_LEAST SIGNIFICANT DIGIT
	IORI	1,20(3)			;INCLUDE IN NAME
	ROT	1,-6
	SOJG	4,.-3			;LOOP FOR 3 CHARACTERS
	MOVSI	2,'TMP'			;FILE EXTENSION
	MOVEM	1,RPGNAM		;STORE FILE NAME FOR RPG FILE
	MOVEM	2,RPGNAM+1
	SETZM	RPGNAM+3		;PPN
	INIT	6,1
	'DSK   '
	CTLBUF
	JRST	CPOPJ1			;SEE US LOSE. (SKIP RETURN)
	LOOKUP	6,RPGNAM		;NOW SEE IF FILE IS THERE
	JRST	CPOPJ1			;LOSE (SKIP RETURN)
^RPGS1:	MOVEI	1,RPGBUF		;THIS IS WHERE WE WANT OUT BUFFER PUT
	EXCH	1,.JBFF			;(SAVE .JBFF)
	INBUF	6,1			;GET ONE BUFFER.
	MOVEM	1,.JBFF			;(RESTORE OLD .JBFF)
>;NOTNX

TNX,<
T20,<			;RELEASE 3 of TOPS-20 simulates TMPCOR....
	MOVE	1,[1,,400000]		;READ for this fork
	MOVEI	2,RPGBUF		;ARG BLOCK
	MOVEI	3,200			;
	PRARG
	CAILE	3,200			;number of words read
	JRST	[OUTSTR [asciz/Too many words in TMP file
/]
		JRST CPOPJ1]		;return to tty scanner
	JUMPE	3,DSKRPG		;the bus isn't running.  take subway
	MOVN	3,3
	MOVSI	3,(3)
	HRRI	3,RPGBUF
TMCLP1:	HLRZ	1,(3)
	CAIN	1,'FAI'			;is this the right place?
	JRST	TMCLP2			;yes.  stop the bus
	AOBJN	3,TMCLP1
	JRST	DSKRPG			;transfer to the subway

TMCLP2:	HRRZ	1,(3)
;	SUBI	1,1			;removed for release 4
	IMULI	1,5			;CONVERT TO CHARACTER COUNT
	MOVEM	1,CTLBUF+2		;store count
	HRLI	3,000700
	MOVEM	3,CTLBUF+1		;store byte pointer
	SETOM	TMPCOR#
	JRST	RPGS5		
>;T20
DSKRPG:	GJINF
	MOVE	2,3		;JOB NO TO 2
	HRROI	1,RPGFIL
	MOVE	3,[XWD 140003,=10]	;LEADING FILL ZEROES, BASE 10
	NOUT
	JRST	CPOPJ1		;HUH?
	HRROI	2,RPGFI1
	SETZ	3,
	SOUT
	IDPB	3,2		;END WITH A NULL
	HRLZI	1,100001	;OLD FILE, SHORT FORM
	HRROI	2,RPGFIL
	GTJFN
	JRST	CPOPJ1		;OOPS, NO FILE
	MOVE	2,[XWD 440000,200000]	;36 BIT, READ ONLY
	OPENF
	JRST	[RLJFN
		 JRST	CPOPJ1
		 JRST	CPOPJ1]
	MOVEM	1,JFNTBL+4	;SAVE JFN
	SETZM	CTLBUF+1	;KILL COUNTER
	MOVEI	1,400000	;THIS FORK
	DIR			;INT OFF
	MOVE	3,INDBF		;MAP PAGE FOR BUFFER
	CIS			;CLEAR AN MPV INTERRUPT
	EIR			;REEANBLE INTS
>;TNX
RPGS5:	HLLOS	RPGSW			;(IF DOING @ FILE, SET RPGSW TO 0,,-1)

	POPJ	P,			;NON-SKIP FOR SUCCESS.

TNX,<
RPGFIL:	ASCIZ	/nnnFAI.TMP/		;RPG FILE NAME
RPGFI1:	ASCIZ	/FAI.TMP/
>;TNX

^RPGRS:	LDB	2,CTLBUF+1		;SCAN TO END OF LINE
RPGRS2:	CAIN	2,12
	JRST	RPGGO
	JSR	IN
	JRST	RPGRS2

;RPGIN IS CALLED FROM IN TO READ NEXT CHARACTER FROM RPG OR @ FILE.
;RETURNS CHARACTER IN 2.
; IF EOF OR ERROR ON RPG FILE, JUMPS TO RPGXIT


RPGIN3:	AOS	CTLBUF+1		;HERE TO FLUSH SOS LINE NUMBER
	MOVNI	2,5			;GRONK BYTE POINTER.
	ADDM	2,CTLBUF+2		;ADJUST BYTE COUNT.  GET NEXT CHARACTER
^RPGIN:	SOSG	CTLBUF+2		;CALLED FROM IN
	JRST	RPGIN2			;END OF BUFFER.
RPGIN1:	IBP	CTLBUF+1		;ADVANCE BYTE POINTER
	MOVE	2,@CTLBUF+1		;GET THE CURRENT WORD
	TRNE	2,1			;SOS LINE NUMBER?
	JRST	RPGIN3			;YES.  FLUSH IT
	LDB	2,CTLBUF+1
	JUMPE	2,RPGIN			;IGNORE NULLS
	CAIE	2,14			;IGNORE FORM FEEDS
	CAIN	2,15			;IGNORE CR'S
	JRST	RPGIN
	JRST	@IN

RPGIN2:					;HERE AT END OF BUFFER.
T20,<	SKIPE	TMPCOR			;exit at eof on tmpcor
	HALTF				>;T20
NOTNX,<
IFN TMPCSW,<	SKIPE TMPCOR		;AT EOB IN TMPCORE, EXIT
		EXIT			>;IFN TMPCSW
	IN	6,			;READ NEXT
	JRST	RPGIN1			;GOT SOME. DO IT.
	STATZ	6,20000			;EOF?
	JRST	RPGIN4			;YES. 
RPGIN5:	OUTSTR	[ASCIZ /ERROR READING COMMAND (OR RPG) FILE, OR TMPCOR TOO BIG/]
>;NOTNX

TNX,<
	TSVAC	<1,3>
	HRRZ	1,JFNTBL-2+6		;IND FILE JFN
	MOVE	2,[POINT 36,INDBF]
	HRROI	3,-1000			;MAX NO BYTES
	SIN
	ADDI	3,1000			;COMPUTE BYTES XFERED
	IMULI	3,5			;CONV TO 7 BIT BYTES
	MOVEM	3,CTLBUF+2		;SET COUNT
	MOVE	2,[POINT 7,INDBF]
	MOVEM	2,CTLBUF+1		;AND POINTER
	TRSTAC	<1,3>
	SKIPE	CTLBUF+2
	JRST	RPGIN1			;GOT SOME
	JRST	RPGIN4			;EOF
>;TNX
RPGXIT:	JSR	DELRPG			;DELETE RPG FILE
	SKIPGE	RPGSW			;RPG MODE?
NOTNX,<	EXIT>				;YES. DIE NOW.
TNX,<	HALTF>
	SETZM	RPGSW
	JRST	STRT1


RPGIN4:	MOVEI	2,0			;PERHAPS HE NEEDS A TERMINATOR
	EXCH	2,RPGNEED		;SEE IF HE DOES.
	JUMPE	2,RPGXIT		;JUMP IF NO PROVIDED FOR HIM
	DPB	2,CTLBUF+1		;GOT ONE. PUT WHERE WE CAN SEE IT AGAIN.
	JRST	@IN			;GIVE IT TO HIM.

^DELRPG:0
NOTNX,<
IFN TMPCSW,<	SKIPE	TMPCOR		;DOING TMPCOR?
		JRST	@DELRPG		;YES.  LET'S NOT DELETE RPG FILE >
	SKIPGE	RPGSW			;SKIP IF @ FILE, OR NOT RPG MODE
	RENAME	6,ZEROS			;RENAME TO DELETE CURRENT FILE
	JFCL				;IGNORE FAILURE FROM DELETE
	RELEAS	6,
	JRST	@DELRPG
>;NOTNX
TNX,<
T20,<	SKIPN	TMPCOR			;NO DELETE IF TMPCOR >;T20
	SKIPN	RPGSW			;EITHER RPG OR INDIRECT MODE?
	JRST	@DELRPG			;NEITHER
	HRRZ	1,JFNTBL-2+6
	HRLI	1,400000		;KEEP JFN THRU CLOSE
	CLOSF
	JFCL
	SKIPL	RPGSW			;RPG MODE?
	JRST	DELRP1			;NO. MUST BE INDIRECT FILE.
	HRRZ	1,JFNTBL-2+6		;GET THE JFN AGAIN
	HRLI	1,400000		;KEEP JFN
	DELF				;DELETE FILE
	JFCL
DELRP1:	HRRZ	1,JFNTBL-2+6
	RLJFN
	JFCL
	SETZM	JFNTBL-2+6
	JRST	@DELRPG
>;TNX

^CTLBUF:BLOCK 3
NOTNX,<RPGBUF:	BLOCK 203>			;BUFFER SPACE FOR RPG/TMPCOR/COMMAND-FILE
TNX,<RPGBUF__INDBF>
RPGNAM:	BLOCK 4
ZEROS:	REPEAT 4,<0>
BEND RPG
;HERE TO READ COMMAND LINE OR CMD FILE

IN:	0				;JSR HERE.  RETURN CHARACTER IN 2.
	SKIPE	RPGSW			;RPG MODE?  (RPG OR @ FILE)
	JRST	RPGIN			;YES. DO IT FROM FILE
IN1:	ILDB	2,TTYPTR		;GET A BYTE FROM THE TTY
	JUMPN	2,@IN			;IF NOT NULL, RETURN IT
	MOVE	2,[440700,,TTYBUF]	;INITIALIZE BYTE POINTER
	MOVEM	2,TTYPTR
NOTNX,<
	MOVEM	2,SOUT
ITS,<
	AOSN	DDTCMD
	JRST	[MOVE	2,[TTYBUF,,TTYBUF+1]
		SETZM	TTYBUF
		BLT	2,TTYBUF+TTYBFL-1
		.BREAK	12,[5,,TTYBUF]
		JRST	IN1]
>;ITS	
IN2:	INCHWL	2			;WAIT FOR A NEW LINE
	ANDI	2,177			;MASK CHARACTER
	JUMPE	2,IN2			;FLUSH NULLS
	CAIN	2,15
	JRST	IN2			;AND FLUSH CRS
	IDPB	2,SOUT			;STORE CHARACTERS
	CAIE	2,12
	JRST	IN2	
	MOVEI	2,			;STOP ON LF. INVENT A NULL
	IDPB	2,SOUT
	JRST	IN1			;IT'S NOT OBVIOUS WHY IT'S DONE THIS WAY

SOUT:	0
>;NOTNX
TNX,<
	TSVAC	<1,3>
	HRROI	1,TTYBUF
	MOVEI	2,5*TTYBFL-2
NOT20,<		SETZ	3,		;SHORT FORM CALL
		PSTIN			;IMSSS LOCAL >;NOT20
T20,<		HRROI	3,[ASCIZ/*/]
		RDTTY
		ERJMP	.+1		
		MOVEI	3,0		>;T20
	IDPB	3,1			;END WITH NULL
	TRSTAC	<1,3>
	JRST	IN1			;ONWARD...
>;TNX

TTYPTR:	0
TTYBFL__40
TTYBUF:	BLOCK TTYBFL
;	START HERE


STRT:	TDZA	T,T
	MOVNI	T,1
	MOVEM	T,RPGSW			;SAVE STATE OF RPG SWITCH
	MOVE	T,[JSR UUO]
	MOVEM	T,41			;UUO HANDLER
	MOVE	T,[350700,,TLBLK+1]
	MOVEM	T,LSTPNT		;SET UP EARLY FOR ERR PRT
	MOVE	P,[-PLEN,,PDL-1]	;AND THE STACK.
	PUSHJ	P,GTCPTM		;GET STARTING CPU TIME

ITS,<		SETZM	DDTCMD
		.SUSET	[.ROPTI,,1]
		TLNE	1,OPTCMD
		SETOM	DDTCMD		>;ITS

	PUSHJ	P,CORINI		;SET UP MPV INTERRUPTS (FOR OPSET)
T20,<	SETZM	TMPCOR#>		;no tmpcor to start
IFN TMPCSW,<	SETZM	TMPCOR# >	;

IFN STANSW,<	SKIPN	OPSOK
		PUSHJ	P,OPSET		;DEFINE SYSTEM OPCODES FIRST TIME >;STANSW

	SETZM	UNIVSW			;NOT DOING UNIVERSALS YET
	PUSHJ	P,SETRPG
	JRST	RPGGO			;WE ARE HAVE STARTED RPG MODE SUCESSFULLY
	SETZM	RPGSW			;REG/RPH 11/26/74. RPGSW_0 IF SETRPG FAILS
NOITS,<	HLLZS	42>			;NOT IN RPG MODE. CLEAR ERROR CELL.
;HERE AFTER COMPLETE ASSEMBLY, OR WHEN COMMAND FILE RUNS OUT.
STRT1:	MOVE	P,[-PLEN,,PDL-1]	;DON'T USE OLD STACK MADE BY /E
	SKIPE	RPGSW			;ARE WE IN RPG MODE?
	JRST	RPGRS			;SCAN TO END OF LINE OF RPG FILE. TO RPGGO
	RESET
	PUSHJ	P,CORINI		;RE-ENABLE INTS AFTER RESET (SIGH)
	PUSHJ	P,USHUFF		;SHUFFLE UNIVERSALS. SET JOBFF FROM JOBSA
NOTNX,<		MOVE	1,.JBFF		;SHRINK CORE BEFORE CONTINUING
		CORE	1,
		JFCL		>;NOTNX
RPGGO:	MOVE	P,[-PLEN,,PDL-1]
	PUSHJ	P,USHUFF		;SHUFFLE UNIVERSALS. SET JOBFF FROM JOBSA

	FOR A IN (NOEXP#,TTYERR#,SYMOUT#,XL1IG#,PSWIT#,ESWIT#,<LISTSW#>
	,NOLTSW#,CREFSW#,XCRFSW#,INLINE#,<UNDLNS#>
	,PGNM,SPGNM,TTYPTR,INCLIN#,FUNSUP)
<	SETZM A
>

IFE STOPSW,<	SETZM ERSTSW#	;>SETOM ERSTSW#

	MOVSI	1
	MOVEM	CHRCNT#
	SETOM	LNCNT		;SET THESE TWO CELLS TO FORCE HEADING
	AOS	PGNM
	MOVEI
	SKIPN	RPGSW

NOITS,<	OUTSTR	STAR >

ITS,<
	JRST [	MOVEI 1,[.FNAM1]
		PUSHJ P,FNMOUT
		OUTCHR ["."]
		MOVEI 1,[.FNAM2]
		PUSHJ P,FNMOUT
		OUTCHR [15]
		OUTCHR [12]
		SKIPL DDTCMD
		OUTCHR ["*"]
		JRST .+1]
>;ITS

	MOVEI	1,FILSTK
	MOVEM	1,FILSTP	;INITIALIZE FILE-STACK POINTER
	SETZM	FILSTC		;FILE-STACK DEPTH

	MOVE	1,[CXTAB,,CTAB]		;INITIALIZE CHARACTER TABLE
	BLT	1,CTAB+177

	JSR	INITL		;DECODE COMMAND FILE, SET UP BUFFERS..
	JRST	[RESET		;SOMETHING IS AMISS.  AVOID WRITING ANYTHING
		SKIPE	RPGSW
		NOTNX,<EXIT;> HALTF	;IN CASE OF RPG, THE PARTY'S OVER
		JRST	STRT1]	;FOR MANUAL USER, TRY AGAIN
	MOVE	1,.JBFF
	MOVEM	1,IOFF#		;SAVE ADDRESS ABOVE THE IO BUFFERS
IFN STANSW,<	PUSHJ P,TVSKIP >;MAYBE SKIP DIRECTORY AT STANFORD
IFE STANSW,<	PUSHJ P,INP >	;READ INITIAL RECORD


;HERE FROM PRGEND TO START NEXT ASSEMBLY.
STRT2:	MOVE	P,[-PLEN,,PDL-1]
	MOVE	1,IOFF
	MOVEM	1,.JBFF		;RESET .JBFF TO INCLUDE IO BUFFERS - NOT MACRO PDL
	PUSHJ	P,USHUF1	;SHUFFLE UNIVERSALS.  (IOACTIVE. DON'T REDUCE .JBFF)
	SETZM	SYMTAB
	MOVE	1,[XWD SYMTAB,SYMTAB+1]
	BLT	1,HASH-1+SYMTAB		;CLEAR USER SYMBOL TABLE
	MOVE	1,[XWD OPCDS1,OPCDS]	;INITIALIZE OPCODE TABLE FROM
	BLT	1,HASH-1+OPCDS		;PREFINED+CALLIS
	MOVE	1,[XWD MACRT1,MACRT]	;INITIALIZE MACRO TABLE
	BLT	1,HASH-1+MACRT

	MOVE	1,[CXTAB,,CTAB]		;INITIALIZE CHARACTER TABLE
	BLT	1,CTAB+177

	SETZM	LSTLAB			;CLEAR LAST LABLE NAMES
	MOVE	1,[LSTLAB,,LSTLAB+1]
	BLT	1,LSTLAB+4

ITS,<	PUSHJ	P,GETSYS	>	;GET SYSTEM SYMBOLS
	ANDI	IOFLGS		;CLEAR ALL BUT I/O FLAGS
	FOR A IN (LOCNT#,%BCUR,POLPNT#,SEG#,<RTFLST#>
	,XPUNGS#,SYMEM#,CODEM#,VARLST#,LGARB,XL2SW#,TABMSW#)
<	SETZM A
>
	SETOM	XPNDSW
	SETOM	INMCSW#
	SETOM	TITLSW#
	MOVE	FS,['.MAIN']
	MOVEM	FS,BNAM		;SET INITIAL PROGRAM NAME
	MOVEM	FS,LSTLAB+3
	PUSHJ	P,R5CON
	MOVEM	FS,TPOL3	;SAVE RADIX50 FOR NAME BLOCK OUTPUT
	MOVSI	FS,12		;PROCESSOR ID 12 = FAIL IN BLOCK TYPE 6
	MOVEM	FS,TPOL4
	MOVE	2,[XWD -ERPLEN,ERPD-1]
	MOVEM	2,ERPNT
	MOVE	1,PSWIT
	ADDI	1,1
	LSH	1,7		;FORM MACRO PDL LENGTH

	SKIPG	3,ESWIT		;ANY EXTRA LONG MAIN PDL?
	JRST	.+3		;NO.
	LSH	3,7
	ADDI	3,PLEN		;SIZE OF NEW PDL
	
	MOVE	M,.JBFF
	MOVEI	2,=1024*5(M)	;FIRST FREE +  5K
	ADDI	2,(1)		;+SIZE OF MACRO PDL
	ADDI	2,(3)		;+SIZE OF MAIN PDL
NOTNX,<	CORE	2,>		;GET THE CORE.  IF ANYONE NEEDS LESS THAN
TNX,<	MOVEM	2,.JBREL
	CAILE	2,MXCOR		;WATCH FOR OVERFLOW INTO BUFFERS AND DDT
>;TNX
	PUSHJ	P,COERR		;5 K, HE DESERVES OUR CONGRATULATIONS.
	ADDM	1,.JBFF		;ADVANCE JOBFF PAST THE MACRO PDL
	SUBI	M,1
	MOVNS	1
	HRL	M,1		;MACRO PDL POINTER NOW IS IN M

	JUMPE	3,STRT2A	;JUMP UNLESS BUILDING EXTRA PDL
	MOVE	P,.JBFF		;HERE'S WHERE THE PDL STARTS
	ADDM	3,.JBFF		;ADVANCE JOBFF PAST THE MAIN PDL
	SUBI	P,1
	MOVNS	3
	HRL	P,3		;MAIN PDL POINTER NOW IS IN M
STRT2A:

	HRRZ	2,.JBREL	;GET END OF CORE
	MOVEI	3,-1(2)
	HRRZ	5,.JBFF		;GET END OF PROGRAM
	SUB	3,5		;FORM LENGTH OF FREE AREA
	ASH	3,-1
	MOVEM	2,MTBLST#	;SET END OF FREE AREA
	MOVE	2,5
	ADD	2,3
	MOVEM	2,MTBPNT#	;FORM START OF FREE AREA
	IDIVI	3,5		;FORM COUNT
	MOVEM	5,FSTPNT#	;START OF FREE STRG
	ADDI	5,5		;INCREMENT TO NEXT
	MOVEM	5,-4(5)		;STORE LINK
	SOJG	3,.-2		;LOOP
	SETZM	-4(5)		;TERMINATE
	SETZM	LOCNT
	SETZM	ABSCNT#
	MOVEI	T,LOCNT
	MOVEM	T,CURBRK#
	MOVEI	CP,400000
	MOVEM	CP,HICNT#
	HLLOS	BRK#

	SETZM	PCNT		;LOCATION COUNTERS.  RELOC 0
	MOVEI	T,1
	MOVEM	T,PCNT+1
	SETZM	OPCNT
	MOVEM	T,OPCNT+1
	SETZM	DPCNT
	MOVEM	T,DPCNT+1

	MOVEI	CP,ASSMBL		;GET ADDRESS
	MOVEM	CP,CPDL			;INITIALIZE THE SPECIAL PDL
	MOVE	CP,[XWD CPDL,CPDL+1]	;USED FOR THE
	BLT	CP,CPDL+CPLEN-1		;RECURSIVE CO-ROUTINE ASSMBL
	MOVE	CP,[XWD SNB+CPLEN-3,CPDL+CPLEN-2]

	SETZB	BC,FBLK+1
	MOVE	FC,[XWD -22,FBLK+2]
	PUSHJ	P,SBINI		;INITIALIZE SYMBOL OUTPUT.
	MOVNI	B,BBLK+2
	HRRM	B,BFX
	MOVNI	B,FBLK+2
	HRRM	B,FFX
	MOVE	B,[POINT 7,TLBLK+1,6]
	MOVEM	B,LSTPNT
	MOVSI	B,(<ASCII /	/>)
	MOVEM	B,TLBLK+1
	MOVE	B,[POINT 7,CREFTB,13]
	MOVEM	B,CREFPT
	MOVE	B,[LSH N,3]
	MOVEM	B,SRAD
	MOVE	B,CTAB+"8"
	MOVEM	B,RTEST

	MOVEI	B,LINLEN		;NORMAL LINE SIZE - JHS
	SKIPE	CREFSW			;EXCEPT, ARE WE CREFFING?
	MOVEI	B,LINLEN-10		;YES - REDUCE LINE SIZE BY 8
	MOVEM	B,CHRPL

	MOVEI	B,LNPP
	SKIPN	PAGSIZ
	MOVEM	B,PAGSIZ		;INITIALIZE PAGE SIZE UNLESS SET BY SWITCH.
	MOVE	B,[LITPNT-1,,LITPNT]
	BLT	B,LITPNT+HASH-1
	MOVEI	B,1
	MOVEM	B,BLOCK
	MOVE	B,[XWD DAF,-1]
	MOVEM	B,DBLCK
	MOVE	B,[XWD SNULN,NULN]
	BLT	B,NULN+5
	MOVE	B,[XWD -EFSLEN,EFS-1]
	MOVEM	B,EFSPNT#
	SETZM	TITCNT+1
	MOVE	B,[XWD -1,TITCNT+1]
	MOVEM	B,TITCNT
	MOVE	B,[XWD -1,SUBCNT+1]
	MOVEM	B,SUBCNT
NOTNX,<	MOVE	B,[BYTE (7)15,12,15,12]>
TNX,<	MOVE	B,[BYTE (7)11,11,11,11,11]
	SETZM	SUBCNT+2
>;TNX
	MOVEM	B,SUBCNT+1
	SETZM	GARBAG
IFN STANSW,<	MOVEI	C,OPSET
		MOVEI	B,OPSEND
		PUSHJ	P,MACRET >	;GIVE OPCODE-GETTER TO FREE STORAGE
TNX,<	PUSHJ	P,INISM >	;SET INITIAL SYMBOL TABLE.
	JRST	MAIN			;OFF TO SEE THE WIZARD, THE WONDERFUL ...
;NOFSL

CELCNT:	0

BEGIN	NOFSL

^NOFSL:	0				;JSR HERE WHEN OUT OF FREE STORAGE
	PUSH	P,O
	PUSH	P,T		;SAVE
	PUSH	P,FS		;...
	PUSH	P,N
	PUSH	P,NA
	MOVEI	NA,GARBAG-1
	SKIPN	T,GARBAG	;GET GARBAGE LIST
	JRST	NOGAR		;NONE
	SETZB	FS,CELCNT	;ZERO CELL COUNT
LOOP2:	MOVE	O,2(T)		;GET START ADDRESS
	MOVE	N,(T)		;GET COUNT
	CAIGE	N,5		;BIG ENOUGH?
	JRST	NOMO		;NO
LOOP1:	MOVEM	FS,1(O)		;DEPOSIT POINTER
	MOVE	FS,O		;FORM NEW ONE
	ADDI	O,5
	SUBI	N,5		;DECREASE COUNT
	AOS	CELCNT	
	CAIL	N,5		;ROOM FOR MORE?
	JRST	LOOP1		;YES
NOMO:	JUMPE	N,USET		;USED IT ALL?
	MOVEM	N,(T)		;NO, DEPOSIT NEW COUNT
	MOVEM	O,2(T)		;DEPOSIT NEW START
	MOVE	NA,T
	SKIPN	T,1(T)		;GET NEXT
	JRST	NOMGAR		;NO MORE GARBAGE
	JRST	LOOP2

USET:	MOVE	O,1(T)		;GET POINTER
	MOVEM	O,1(NA)		;REMOVE THIS CELL...
	MOVEM	FS,1(T)		;& PUT INTO
	MOVE	FS,T		;FREE STORAGE
	AOS	CELCNT
	SKIPE	T,O
	JRST	LOOP2
NOMGAR:	SKIPE	T,GARBAG
	MOVE	T,3(T)
	MOVEM	T,LGARB
	MOVE	T,CELCNT
	CAIGE	T,20		;WERE AT LEAST 20 CELLS CREATED?
	JRST	NOTNUF		;NO
LOOP4:	MOVE	T,NOFSL		;GET ADDRESS
	LDB	O,[POINT 4,-2(T),12]	;GET AC FLD
	DPB	O,[POINT 4,RSET,12]	;DEPOSIT
	POP	P,NA
	POP	P,N			;RESTORE
	HRRM	FS,RSET		;DEPOSIT FREE STORAGE POINTER
	POP	P,FS
	POP	P,T
	POP	P,O
RSET:	MOVEI 			;LOAD NEW POINTER  ***AC AND ADDRESS CLOBBERED***
	JRST	@NOFSL		;RETURN

NOGAR:	MOVEI	FS,0
NOTNUF:	MOVE	T,.JBREL	;GET END OF CORE
	SUB	T,MTBPNT	;SUB CURRENT START OF FREE AREA
	CAIGE	T,300		;AT LEAST 300 WORDS LEFT?
	PUSHJ	P,COEXP		;NO, EXPAND CORE
	MOVE	T,.JBREL	;GET DIF
	SUB	T,MTBPNT	;...
	LSH	T,-1		;DIV BY 2
	ADD	T,MTBPNT	;USE HALF FOR FREE STRG
	MOVE	O,MTBPNT	;GET START
LOOP3:	MOVEM	FS,1(O)		;DEPOSIT POINTER
	MOVE	FS,O		;GET NEW ONE
	ADDI	O,5		;GO TO NEXT
	CAMGE	O,T		;FAR ENOUGH?
	JRST	LOOP3		;NO
	MOVEM	O,MTBPNT	;YES, DEPOSIT NEW MTBPNT
	JRST	LOOP4	
;CORINI, COEXP, WAIT, TSINT, PDLOV, PDLOVI

SV:	BLOCK	2		;TEMP CELLS FOR MPV INTERRUPTS

NOTNX,<	

^COERR:	OUTSTR	[ASCIZ/
Need more core but none is available.  Strike any key to try again:/]
	PUSHJ	P,WAIT
^COEXP:	MOVE	T,.JBREL	;GET CURRENT END OF CORE
	ADDI	T,2000		;EXPAND BY 1K
	CORE	T,
	JRST	COERR		;NO CORE
	POPJ	P,

^WAIT:	CLRBFI
	INCHRW	T
	CAIN	T,15
	INCHRW	T
	POPJ	P,

^CORINI:MOVEI	T,IFE STANSW,<620000;>220000	;REPETITIVE ENABLE ON DEC SYSTEMS
	APRENB	T,
	MOVEI	T,.JBAPR-1
	PUSHJ	T,CORI2
	HRRZS	O,T		;TRAP HERE TO SEE HOW MUCH PC CHANGED
	SUBI	O,@.JBTPC
	JRST	2,1(T)		;SKIP TEST INSTR, CLEAR FLAGS (ESP. BIS)

CORI2:	JSP	T,.+1
	SETZM	-1		;GET PC OFFSET FOR WRITE INSTRUCTIONS
	MOVEM	O,REGOFF#
	JSP	T,.+1
	DPB	[,-1]		;GET OFFSET FOR BYTE INSTRUCTIONS
	MOVEM	O,BYTOFF#
	MOVEI	T,.JBAPR-1
	PUSHJ	T,CPOPJ		;SET TRAP ADDRESS TO TSINT
^TSINT:	MOVEM	FS,SV		;SAVE
	MOVEM	T,SV+1
	MOVE	T,.JBCNI
	TRNE	T,200000
	JRST	PDLOVI
	MOVE	FS,.JBTPC	;GET PC WORD
	TLNE	FS,20000	;TEST BIS FLAG TO SEE IF LOSING INST WAS BYTE INST
	SKIPA	FS,BYTOFF	;SELECT APPROPRIATE OFFSET
	MOVE	FS,REGOFF
	ADDB	FS,.JBTPC	;ADD OFFSET TO PC WORD
	ANDI	FS,-1		;GET RID OF FLAGS
	MOVSI	T,-LEGCNT
LOP1:	CAME	FS,LEGTAB(T)	;SEE IF LEGAL PC
	AOBJN	T,LOP1
	JUMPL	T,MPVOK
	OUTSTR	[ASCIZ/
Assembler error: Unexpected ILL MEM REF. at user PC = /]
	PUSH	P,FS
	PUSH	P,FS+1
	PUSHJ	P,OCTTYO
	POP	P,FS+1
	POP	P,FS
	OUTSTR	TTCRLF
	PUSHJ	P,TTYERP
	OUTSTR	[ASCIZ/Type any key to continue anyway:  /]
	PUSHJ	P,WAIT
MPVOK:	PUSHJ	P,COEXP		;EXPAND CORE
	MOVE	FS,SV
	MOVE	T,SV+1		;RESTORE
	JRST	2,@.JBTPC	;& RETURN

OCTTYO:	IDIVI	FS,10
	HRLM	FS+1,(P)
	JUMPE	FS,.+2
	PUSHJ	P,OCTTYO
	HLRZ	FS,(P)
	ADDI	FS,"0"
	OUTCHR	FS
	POPJ	P,

>;NOTNX

PDLOVI:	MOVEI	T,[ASCIZ /UNRECOGNIZABLE/]
	JUMPL	CP,.+2
	MOVEI	T,[ASCIZ /COROUTINE/]
	JUMPL	M,.+2
	MOVEI	T,[ASCIZ /MACRO/]
	JUMPL	P,.+3
^PDLOV:	MOVEI	T,[ASCIZ /MAIN/]
	ANDI	P,-1		;AVOID RECURSIVE PDLOVS
	OUTSTR	(T)
	OUTSTR	[ASCIZ / PDL OVERFLOW,  CAN'T CONTINUE.
/]
	JUMPL	M,.+2
	OUTSTR	[ASCIZ \USE /P TO EXPAND MACRO PDL
\]
	JUMPL	P,.+2
	OUTSTR	[ASCIZ \USE /E TO EXPAND MAIN PDL
\]
	PUSHJ	P,LSTCHK		;MAKE SURE WE CAN TYPE LISTING BUFFER
	PUSHJ	P,TTYERP
TNX,<	HALTF  JRST .-1>
NOTNX,<	HALT	. >



TNX,<
^COEXP:	MOVE	T,.JBREL	;HERE TO EXPAND CORE - GET CURRENT END OF CORE
	TRO	T,1777		;JUST TO BE ON PAGE BOUND ALWAYS
	ADDI	T,2000
	CAILE	T,MXCOR		;WATCH BUFFERS AND DDT
	JRST	COERR		;REALLY?
	MOVEM	T,.JBREL	;MAINTAIN THE FICTION
	POPJ	P,

^COERR:	OUTSTR	[ASCIZ /
Virtual memory is full.  Can't continue.
/]
	HALTF
	JRST	.-1

^WAIT:	MOVEI	1,100			;PRIMARY INPUT
	CFIBF
	PBIN				;WAIT
	POPJ 	P,

^CORINI:RESET				;WHY NOT?
^CORINX:MOVEI	1,400000		;THIS FORK
	MOVE	2,[LEVTAB,,CHNTAB]
	SIR				;SET TABLE ADDR
	EIR				;ENABLE SYSTEM
	MOVE	2,[000400,,020000]	;PDLOV, NXPG
	AIC				;ARM
	POPJ	P,

;STORAGE FOR INTERRUPT SYSTEM
SVEADR:	0			;EFFECTIVE ADDR OF ILLEGAL REFERENCE
^SVPCS:	BLOCK	3		;PC AT INTERRUPT TIME
^LEVTAB:SVPCS
	SVPCS+1
	SVPCS+2
^CHNTAB:BLOCK	=9
	XWD	1,PDLOVI	;PDL OVERFLOW
	BLOCK	=12
	XWD	1,TSINT		;NXPG 
	BLOCK	=9

^TSINT:	MOVEM	FS,SV		;SAVE
	MOVEM	T,SV+1
	MOVEI	1,400000	;THIS FORK
	GTRPW
	TLNE	1,1
	JRST	LEGREF		;MONITOR MODE IS SPURIOUS
	HRRZ	2,1		;EFFECTIVE ADDR OF OFFENDING WORD
	MOVEM	2,SVEADR	;SAVE IT
	CAMG	2,.JBREL
	JRST	LEGREF		;FIRST HIT ON ALLOCATED PAGE
IFN TOPS20,<	CAIL	2,700000	;IS THIS A REFERENCE TO IOSPACE?
	JRST	LEGREF		>;YES, I HOPE.  LET IT BE.
	HRRZ	FS,SVPCS	;ADDR OF OFFENDING INSTR
IFE TOPS20,<	SUBI FS,1	>	;PC+1 ON TENEX
;DONT BELIEVE JSYS MANUAL ABOUT THAT TRAP WORD...
	MOVSI	T,-LEGCNT
LOP1:	CAME	FS,LEGTAB(T)	;SEE IF LEGAL PC
	AOBJN	T,LOP1
	JUMPL	T,MPVOK
	OUTSTR	[ASCIZ/
Assembler error: Unexpected ILL MEM REF. at user PC = /]
	PUSH	P,1
	PUSH	P,2
	PUSH	P,3
	HRRZ	2,FS		;ARGUMENT IN 2
	MOVEI	1,101		;PRIMARY OUTPUT DEVICE
	MOVE	3,[140006,,10]	;6 CHARACTERS, RADIX 8, LEADING 0 FILL
	NOUT
	JFCL
	POP	P,3
	POP	P,2
	POP	P,1
	OUTSTR	TTCRLF
	PUSHJ	P,TTYERP
	OUTSTR	[ASCIZ/Type any key to continue anyway:/]
	PUSHJ	P,WAIT
MPVOK:	MOVE	T,SVEADR	;GET ADDRESS THAT WE MUST MAKE LEGAL
	IORI	T,1777
	CAILE	T,MXCOR		;WITHIN MAX ALLOCATION OF VIRTUAL MEM?
	JRST	COERR		;NO.  LOSE
	MOVEM	T,.JBREL	;SIMULATE THIS ADDRESS BEING LEGAL
LEGREF:	MOVE	FS,SV
	MOVE	T,SV+1		;RESTORE
	DEBRK			;DISMISS INTERRUPT

>;TNX
	
BEND	NOFSL
SUBTTL CHARACTER TABLE FOR SCANNER

CTAB:	BLOCK 200
CXTAB:	0			;0   NULL
	XWD SPCLF,UDARF!TP1F	;1   DOWN ARROW
	XWD SPCLF,0		;2   ALPHA
	XWD SPCLF,0		;3   BETA
	XWD SPCLF!ARFL!ARMD,6	;4   LOGICAL AND (CARET)
	XWD SPCLF!ARFL!UNOF,12	;5   LOGICAL NOT
	XWD SPCLF,EPSF		;6   EPSILON
	XWD SPCLF,0		;7   PI
	XWD SPCLF,0		;10  LAMBDA
	XWD SCRF!SPFL!SPCLF,5	;11  TAB
	XWD SPCLF!LNFD!SCRF,1	;12  LINE FEED
	XWD SPCLF,0		;13  VERTICAL TAB
	XWD SPCLF!SCRF!LNFD,7	;14  FF (LOOKS SOMETHING LIKE LF)
	XWD SPCLF!CRFG,6	;15  CR (6 IS FOR LOUT)
	XWD SPCLF,0		;16  INFINITY
	XWD ARFL!SPCLF!ARMD!ARMD1,10	;17  PARTIAL (REMAINDER IN DIVISION)
	XWD SPCLF,INF		;20  CONTAINMENT (OPEN HORSE SHOE)
	XWD SPCLF,0		;21  (CLOSE HORSE SHOE)
	XWD SPCLF,0		;22  SET INTERSECTION
	XWD SPCLF,0		;23  SET UNION
	XWD SPCLF,0		;24  FOR ALL
	XWD SPCLF!ARFL!UNOF!ARMD1,12	;25  THERE EXISTS - JFFO OPERATOR
	XWD SPCLF!ARFL,4	;26  CIRCLE TIMES
	XWD SPCLF!LNFD!CRFG,2	;27  DOUBLE ARROW.  SIMULATE CRLF
	XWD SNB!.FL!ENMF,'.'	;30  UNDERSCORE (LOOKS LIKE . IN SYMS)
	XWD SPCLF,BSLF		;31  RIGHT ARROW 
	XWD SPCLF,UDARF!TP2F	;32  TILDA - SAME AS UPARROW
	XWD SPCLF!ARFL!ARMD1,6	;33  NOT EQUALS  (XOR)
	XWD SPCLF,0		;34  LESS OR EQUAL
	XWD SPCLF!ARFL!ARMD1,6	;35  GREATER OR EQUAL  (XOR)
	XWD SPCLF,0		;36  EQUIVALENCE
	XWD SPCLF!ARFL,6	;37  LOGICAL OR
	XWD SCRF!SPCLF!SPFL,5	;40  SPACE
	XWD SPCLF!ARFL,6	;41  ! LOGICAL OR
	XWD SPCLF!SCRF!ENMF,2	;"
	XWD SPCLF,SHRPF		;#
	XWD SNB!ENMF,'$'	;$
	XWD SNB!ENMF,'%'	;%
	XWD SPCLF!ARFL!ARMD,6	;&
	XWD SPCLF!SCRF!ENMF,3	;'
	XWD SPCLF,LFPF		;(
	XWD SPCLF,RTPF		;)
	XWD SPCLF!ARFL,10	;*
	XWD SPCLF!ARFL,12	;+
	XWD SPCLF,COMF		;,
	XWD SPCLF!ARFL!ARMD!UNOF,12	;-
	XWD SNB!.FL!ENMF,'.'	;.
	XWD ARFL!SPCLF!ARMD,10	;/
	XWD SNB!NMFLG!ENMF,'0'	;0
	XWD SNB!NMFLG!ENMF,'1'	;1
	XWD SNB!NMFLG!ENMF,'2'	;2
	XWD SNB!NMFLG!ENMF,'3'
	XWD SNB!NMFLG!ENMF,'4'
	XWD SNB!NMFLG!ENMF,'5'
	XWD SNB!NMFLG!ENMF,'6'
	XWD SNB!NMFLG!ENMF,'7'
	XWD SNB!NMFLG!ENMF,'8'
	XWD SNB!NMFLG!ENMF,'9'
	XWD SPCLF,LACF!TP2F	;:
	XWD SPCLF!CRFG,2	;;
	XWD SPCLF!SCRF!ENMF!LBRF,10	;WILL BE XWD SPCLF!ENMF!LBRF,LBCF!TP2F;<
	XWD SPCLF!SCRF!ENMF,4	;=
	XWD SPCLF!SCRF!RBRF,11		;WILL BE XWD SPCLF!RBRF,TP2F!RBCF;>
	XWD SPCLF,UDARF!TP1F	;? SAME AS DOWN-ARROW
	XWD SPCLF,ATF		;@
	XWD SNB!ENMF,'A'	;A
	XWD SNB!ENMF!BFL,'B'	;B 	POSSIBLE BINARY SHIFTING
	XWD SNB!ENMF,'C'	;C
	XWD SNB!ENMF,'D'	;D
	XWD SNB!ENMF!EFL,'E'	;E	POSSIBLE EXPONENT IN FLOATING NUMBER
FOR I_'F','Z'
<XWD SNB!ENMF,I
	>
	XWD SPCLF!ENMF!LBRF,TP1F;[
	XWD SPCLF,BSLF		;\
	XWD SPCLF!RBRF,TP1F	;]
	XWD SPCLF,UDARF!TP2F	;^
	XWD SPCLF,LACF!TP1F	;_
	XWD SPCLF,ATF		;140 ` SAME AS @
	XWD SNB!ENMF,'A'	;a
	XWD SNB!ENMF!BFL,'B'	;b
	XWD SNB!ENMF,'C'	;c
	XWD SNB!ENMF,'D'	;d
	XWD SNB!ENMF!EFL,'E'	;e
	FOR I_'F','Z'
<XWD SNB!ENMF,I
>
	XWD SPCLF!SCRF,10	;WILL BE XWD SPCLF,LBCF!TP2F;{
	XWD SPCLF!ARFL!UNOF!ARMD!ARMD1,12	;174 VERTICAL BAR - ABS OPERATOR
	XWD SPCLF!SCRF,11	;WILL BE XWD SPCLF,RBCF!TP2F;}
	XWD SPCLF!SCRF,11	;AS ABOVE
	XWD SPCLF!SCRF!DLETF,0	;DELETE
	0
COMBTS__SCRF!SPCLF!ENMF!LBRF!RBRF!DLETF!LNFD	;OR OF BITS FOR LF DEL <>{}
BEGIN SCAN  SUBTTL SCANNER AND FRIENDS

	;RETURNS WITH NEXT THING
;IF AN IDENTIFIER -- SIXBIT IN L
;IF A NUMBER -- VALUE IN N AND NA
;IF A SPC. CHR. -- BITS FOR CHR IN N
;IN ALL CASES, THE NEXT NON-BLANK CHR. AFTER THE
;	THING RETURNED IS IN C AND ITS BITS ARE IN B.

^SCAN:	MOVEI	L,1			;PREPARE TO TEST FOR LINE NUM
	TLZE	SFL			;SHOULD WE RETURN CURRENT THING?
	JRST	AHEDW			;YES
LOOP3:	ILDB	C,INPNT			;GET CHR.
LOOP3A:	IDPB	C,LSTPNT		;DEPOSIT FOR LISTING
^AHED:	TDNE	L,@INPNT		;LINE NUM?
	JRST	LNUM			;YES
	SKIPL	B,CTAB(C)		;GET BITS, IS IT NUM OR LET?
AHEDW:	JUMPGE	B,SPCRET		;NO
	TLNE	B,NMFLG			;NUM?
	JRST	NUMS			;YES.  COLLECT NUMBER
	HRRZ	L,B			;IT'S A LETTER, PUT IN L
LOOP3B:					;here from DSCAN; ACT NORMAL
REPEAT 5,<	ILDB	C,INPNT		;GET NEXT
		IDPB	C,LSTPNT	;DEPOSIT FOR LIST
		SKIPL	B,CTAB(C)	;GET BITS
		JSR	NOLT		;NOT LET OR NUM
		LSH	L,6
		ORI	L,(B)		;OR IN SIXBIT>
LOOP1:	ILDB	C,INPNT			;GET NEXT CHR.
	IDPB	C,LSTPNT		;DEPOSIT FOR LIST
	SKIPL	B,CTAB(C)		;GET BITS, LET OR NUM?
	JSR	NOLT			;NO
	JRST	LOOP1			;YES,SKIP

NOLT:	0
	JUMPN	B,NOLT1
	JSP	B,NULSKP
	ILDB	C,INPNT
	IDPB	C,LSTPNT
	SKIPGE	B,CTAB(C)
	JRST	@NOLT
NOLT1:	TLNE	B,SCRF			;SPC HANDLING?
	XCT	NOLB(B)			;YES
	TLO	SFL!IFLG		;SET 'SCAN AHEAD' AND 'IDENT'
	TLZ	NFLG!SCFL!FLTFL		;CLEAR NUM & SPC.CHR.
	POPJ	P,

DEFINE EMPS  (A)
<	PUSHJ	P,LBROK
	JRST	A>
;HERE TO SCAN NUMBERS
^RTEST:	SNB!NMFLG!ENMF,,'8'	;Test for bad digits
NUMS:	MOVEI	N,-20(B)	;PUT VALUE IN N  FIRST DIGIT
	TRZ	RWARN1!RWARN2	;CLEAR DIGIT WARNINGS FOR BAD RADIX
	CAML	B,RTEST		;SKIP IF THIS DIGIT IS OK
	TRO	RWARN1		;SET FIRST DIGIT IS BAD FLAG
	SKIPA	NA,FLTB-20(B)	;FLOATING VALUE ACCUMULATES IN NA
LOOP2A:	JSP	B,NULSKP
LOOP2:	ILDB	C,INPNT		;GET NEXT CHR.
	IDPB	C,LSTPNT
NLOP:	SKIPL	B,CTAB(C)	;GET BITS
	JRST	NONM		;NOT A LETTER OR A NUMBER
	TLNN	B,NMFLG		;NUM?
	JRST	NLET		;NO, LETTER FOLLOWS NUMBER (OR .)
^SRAD:	LSH	N,3		;MULT BY RADIX (THIS GETS CLOBBERED)
	ADDI	N,-20(B)	;ADD IN THIS DIGIT
	FMPR	NA,[10.0]	;MULT FLOATING BY 10
	FADR	NA,FLTB-20(B)	;ADD IN THIS DIGIT
	TRNN	RWARN1!RWARN2	;IS EITHER WARNING SET?
	CAML	B,RTEST		;NO WARNING YET.  SHOULD WE SET IT?
	TRO	RWARN2		;YES.  THIS IS DEFINITE MISTAKE.
	JRST	LOOP2

NLET:	TLNE	B,.FL		;LETTER FOLLOWS NUM.  IS IT "."?
	JRST	DOT		;YES, DO FLOATING POINT THING
	TLNE	B,BFL		;B?
	JRST	BSH		;B-SHIFT OPERATOR
	TLNE	B,EFL		;E?
	JRST	EXP
	ERROR	[ASCIZ/LETTER FOLLOWS NUM -- SYNTAX/]
NONM:	JUMPE	B,LOOP2A	;NULL TYPE CHR?
	TRNE	RWARN2		;NUMBER ERROR?
	ERROR	[ASCIZ/INCORRECT DIGITS FOR THIS RADIX/]
NONM1:	TLNE	B,SCRF		;SPC HAND?
	XCT	NOTB(B)		;YES
	MOVEI	NA,
	TLO	SFL!NFLG	;SET 'AHEAD' AND NUM
	TLZ	SCFL!IFLG!FLTFL	;CLEAR SPC,CHR & IDENT
	POPJ	P,

FLTB:	DEC 0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0

NOTB:	JRST	NOND
	PUSHJ	P,LSTLF
	JFCL
	JFCL
	JFCL
	JSR	SPCSKP
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BNOTB

BNOTB:	PUSHJ	P,RTBFND
	JRST	NONM
	JRST	LOOP2

NOND:	DELHN
	JRST	NLOP

EQLS:	PUSHJ	P,SCAN1		;PEEK AHEAD
	CAIE	C,74		;POINTED BRACKET?
	JRST	EQLS1		;NO
	MOVEI	N,12
	MOVEM	N,DHRADX	;SAVE FOR HACK RADIX
	PUSHJ	P,SPCRET	;MAKE IT LOOK REAL
	JRST	XSCANS		;TIE THE STACK IN KNOTS!

EQLS1:	TLO	SFL		;MAKE SURE WE SCAN THIS AGAIN
	PUSH	P,SRAD		;SAVE CURRENT RADIX
	PUSH	P,RTEST
	MOVE	N,[IMULI N,12]	;SET TO 10...
	MOVEM	N,SRAD		;...
	MOVE	N,CTAB+"0"
	ADDI	N,12
	MOVEM	N,RTEST
	PUSHJ	P,SCAN		;SCAN NUMBER
	POP	P,RTEST
	POP	P,SRAD		;RESTORE RADIX
	TLNN	NFLG		;WAS A NUMBER SEEN?
	ERROR	[ASCIZ/NOT A NUMBER AFTER EQUALS/]
	POPJ	P,
;HERE TO DO FLOATING POINT NUMBERS

DOT:	MOVE	N,NA		;GET FLOATING NUM SO FAR
	SKIPA	NA,[1.0]	;Accumulate divisor
LOOP5A:	JSP	B,NULSKP
LOOP5:	ILDB	C,INPNT		;GET NEXT
	IDPB	C,LSTPNT	;DEPOSIT
DNLOP:	SKIPL	B,CTAB(C)	;GET BITS
	JRST	DNONM		;NOT NUM - Do DIVISION
	TLNN	B,NMFLG		;NUM?
	JRST	DNLET		;NO,LETTER
	FMPR	N,[10.0]	;ACCUMULATE NEW DIGIT
	FADR	N,FLTB-20(B)
	FMPR	NA,[10.0]	;And accumulate divisor
	JRST	LOOP5

DNLET:	FDVR	N,NA		;DIVIDE TO ADJUST FRACTION DIGITS
	TLNE	B,EFL		;E?
	JRST	EXP1		;YES
	ERROR	[ASCIZ/LETTER FOLLOWS NUM -- SYNTAX/]
	JRST	DNONM2		;some ordinary letter has been seen

EXP:	MOVE	N,NA		;GET FLOATING VERSION
EXP1:	PUSHJ	P,SCAN1		;GET NEXT CHR.
	MOVEI	NA,EXT1
	HRRM	NA,EXTP
	TLNN	B,UNOF		;- OR  NOT (TREAT BOTH THE SAME)?
	JRST	PT5		;NO
	MOVEI	NA,EXT2		;YES, HANDLE...
	HRRM	NA,EXTP		;...
	PUSHJ	P,SCAN1		;GET NEXT
PT5:	TLNN	B,NMFLG		;NUM?
	ERROR	[ASCIZ/NO NUM AFTER E/]
	MOVEI	NA,-20(B)	;GET VALUE
	PUSHJ	P,SCAN1		;GET NEXT
	TLNN	B,NMFLG		;NUM?
	JRST	PT6		;NO
	ADDI	NA,12		;SECOND HALF OF TABLE
	FMPR	N,@EXTP		;SCALE
	MOVEI	NA,-20(B)	;GET VALUE
	PUSHJ	P,SCAN1		;GET NEXT
PT6:	FMPR	N,@EXTP		;SCALE
	TLNE	B,NMFLG
	ERROR	[ASCIZ/TOO MANY NUMS AFTER E/]
	JRST	DNONM2		;anything special already done by SCAN1

DNONM:	JUMPE	B,LOOP5A	;NULL TYPE?
DNONM1:	TLNE	B,SCRF		;SPECIAL AHNDLE?
	XCT	DNOTB(B)	;YES, HANDLE
	FDVR	N,NA		;DIVIDE TO ADJUST FRACTION DIGITS
DNONM2:	MOVSI	NA,FLTFL	;SET AS FLOATING
	TLO	SFL!NFLG!FLTFL	;SET NUM&FLOATING & AHEAD
	TLZ	IFLG!SCFL	;CLEAR SPC CHR. & IDENT
	POPJ	P,

DNOTB:	JRST	DNDH		;DELETE
	PUSHJ	P,LSTLF		;LF
	JFCL
	JFCL
	JFCL
	JSR	SPCSKP
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BDNOTB

BDNOTB:	PUSHJ	P,RTBFND
	JRST	DNONM1
	JRST	LOOP5

DNDH:	DELHN
	JRST	DNLOP

EXTP:	XWD	NA,EXT1
EXT1:	1.0
	10.0
	100.0
	1000.0
	10000.0
	100000.0
	1000000.0
	10000000.0
	100000000.0
	1000000000.0
	1.0
	1.0E10
	1.0E20
	1.0E30
	1.0E40
	1.0E50
	1.0E60
	1.0E70
	1.0E80
	1.0E90

EXT2:	1.0
	0.1
	0.01
	0.001
	0.0001
	0.00001
	0.000001
	0.0000001
	0.00000001
	0.000000001
	1.0
	1.0E-10
	1.0E-20
	1.0E-30
	1.0E-40
	1.0E-50
	1.0E-60
	1.0E-70
	1.0E-80
	1.0E-90
;DSCAN, DSCANM, DSCANS
;DSCAN HANDLE ^D69, etc,  CALLED TO SIMULATE SCANS,SCANM, and SCAN

DHTBL:	10,,'O'
	12,,'D'
	 2,,'B'
DHTBLN==.-DHTBL

;SCAN ALLOWING ^D89 for instance.  ^ SEEN ALREADY.  NEXT MUST
;BE EITHER: ^, an identifier and colon, or one of the special forms
^DSCANS:PUSHJ	P,DSCANM	;SIMULATE CALL TO SCANM
	TLNE	N,LBRF		;WAS EITHER [ or < SEEN?
	TLNN	SCFL		;SPECIAL CHARACTER?
	JRST	SCANS1		;NOT SPECIAL
	SKIPE	DHACK		;SKIP IF ORDINARY RETURN FROM DSCAN
	TRNE	N,TP1F		;< SEEN?
	JRST	SCANS1		;NOPE.  IT WAS [
^XSCANS:PUSH	P,SRAD		;ENTER HERE FROM SCANS IF SPECIAL FLAG
	PUSH	P,RTEST
	MOVSI	TAC,(<IMULI N,>)
	HRR	TAC,DHRADX
	MOVEM	TAC,SRAD
	ADDI	TAC,'0'
	HRRM	TAC,RTEST
	PUSHJ	P,SCANS1
	POP	P,RTEST
	POP	P,SRAD
	POPJ	P,

DSCANM:	PUSHJ	P,DSCAN		;SIMULATION OF SCANM
	TLNN	IFLG		;IDENT SEEN?
	POPJ	P,		;NOPE
	JRST	SCANM1		;LET THE REAL SCANM TAKE OVER


DSCAN:	SETZM	DHACK#		;ASSUME NORMAL
	TLZE	SFL		;SHOULD WE RETURN CURRENT THING?
	JRST	DAHDW
DSLP3:	ILDB	C,INPNT		;GET CHR.
DSLP3A:	IDPB	C,LSTPNT	;DEPOSIT FOR LISTING
	SKIPL	B,CTAB(C)	;GET BITS, IS IT NUM OR LET?
DAHDW:	JUMPGE	B,SPCRET	;NO
	TLNE	B,NMFLG		;NUM?
	JRST	NUMS		;YES.  COLLECT NUMBER  ERROR!
	HRRZ	L,B		;IT'S A LETTER, PUT IN L
	MOVSI	B,-DHTBLN
	HRRZ	C,DHTBL(B)
	CAME	C,L
	AOBJN	B,.-2
	JUMPGE	B,LOOP3B	;NOT A SPECIAL LEAD IN CHR.
	HLRZ	C,DHTBL(B)
	MOVEM	C,DHRADX#	;RADIX TO ACCUMULATE WITH
	SETOM	DHACK		;ASSUME WE HAVE A CHANCE
	MOVEI	NA,0		;ACCUMLATE SLUDGE HERE
REPEAT 5,<
	ILDB	C,INPNT		;GET NEXT
	IDPB	C,LSTPNT	;DEPOSIT FOR LIST
	SKIPL	B,CTAB(C)	;GET BITS
	JSR	DSNOLT		;NOT LET OR NUM
	LSH	L,6
	ORI	L,(B)		;OR IN SIXBIT
	TLNN	B,NMFLG		;NUMBER?
	SETZM	DHACK		;NO.  GIVE UP
	MOVEI	B,-'0'(B)	;REDUCE CHARACTER TO NUMBER
	CAML	B,DHRADX	;LESS THAN CURRENT RADIX?
	SETZM	DHACK		;no give up
	IMUL	NA,DHRADX
	ADDI	NA,(B)
>
DSLP1:	ILDB	C,INPNT		;GET NEXT CHR.
	IDPB	C,LSTPNT	;DEPOSIT FOR LIST
	SKIPL	B,CTAB(C)	;GET BITS, LET OR NUM?
	JSR	DSNOLT		;NO
	TLNN	B,NMFLG		;NUMBER?
	SETZM	DHACK		;NO.  GIVE UP
	MOVEI	B,-'0'(B)	;REDUCE CHARACTER TO NUMBER
	CAML	B,DHRADX	;LESS THAN CURRENT RADIX?
	SETZM	DHACK		;no give up
	IMUL	NA,DHRADX
	ADDI	NA,(B)
	JRST	DSLP1	

DSNOLT:	0
	JUMPN	B,DSNLT1
	JSP	B,NULSKP
	ILDB	C,INPNT
	IDPB	C,LSTPNT
	SKIPGE	B,CTAB(C)
	JRST	@DSNOLT
DSNLT1:	TLNE	B,SCRF		;SPC HANDLING?
	XCT	DSNOLB(B)	;YES
;NOW, IF NEXT CHARACTER IS A COLON, LEFT ARROW, OR EQUALS, THEN 
;WHAT WE'VE PARSED IS AN IDENTIFIER.  IF DHACK IS ZERO, WE
;PARSED AN IDENTIFIER (AND ERROR IS HAPPENING).  OTHERWISE,
;WE HAVE A NUMBER, EXCEPT, IF THE IDENTIFIER WE HAVE IS ONE
;LETTER LONG AND TERMINATES WITH AN OPEN BROKET, WE ARE SETTING
;THE RADIX WHILE A COMPLEX ATOM IS PARSED.
	SKIPE	DHACK
	TRNE	B,LACF		;COLON OR LEFT-ARROW OR EQUAL?
	JRST	DSNIDN		;RETURN AN IDENTIFIER
	TRNE	B,LBCF		;BROKET SEEN?
	JRST	DSNBRK		;YES.  HANDLE IT.
DSNNUM:	MOVE	N,NA
	MOVEI	NA,0
	TLO	SFL!NFLG
	TLZ	SCFL!IFLG!FLTFL
	POPJ	P,

DSNBRK:	TRNE	L,7700		;ONE CHARACTER ONLY IN NAME? ^D<23*3>
	JRST	DSNNUM		;NO.  DO YOUR WORST.
	TLZ	NFLG!FLTFL!IFLG
	TLO	SCFL!SFL
	MOVE	N,B		;RETURN FLAGS IN N (LIKE SPCRET)
	JSR	SPCSKP
	POPJ	P,		;RETURN SPECIAL CHARACTER


DSNIDN:	TLO	SFL!IFLG	;SET 'SCAN AHEAD' AND 'IDENT'
	TLZ	NFLG!SCFL!FLTFL	;CLEAR NUM & SPC.CHR.
	POPJ	P,

DSNOLB:	JRST	DSNOLD		;DEL
	PUSHJ	P,LSTLF		;LF
	JFCL			;"
	JFCL			;'
	MOVE	B,CTAB+"_"	;MAKE = LOOK LIKE _ AFTER SYMS
	JSR	SPCSKP		;SP or TAB
	JFCL			;unknown
	PUSHJ	P,NEWPAG	;FF
	PUSHJ	P,LBROK		;Handle open broket or brace
	JRST	DBNOLB		;Handle close broket or brace

DBNOLB:	PUSHJ	P,RTBFND
	JRST	DSNOLT+1
	ILDB	C,INPNT
	IDPB	C,LSTPNT
	SKIPL	B,CTAB(C)
	JRST	DSNOLT+1
	JRST	@DSNOLT

DSNOLD:	DELHN
	SKIPL	B,CTAB(C)
	JRST	DSNOLT+1
	JRST	@DSNOLT
^SPCSKP:0		;skip until non blank
	PUSH	P,L
	MOVEI	L,1
SPCCN1:	ILDB	C,INPNT		;GET NEXT
SPCCN2:	IDPB	C,LSTPNT	;DEPOSIT
SPCCN3:	XCT	AHED
	JRST	[JSR SLNUM
		JRST SPCCN1]
	SKIPGE	B,CTAB(C)	;GET BITS
	JRST	SPCKRT		;NNUM OR LET
SPCCON:	JUMPE	B,SPCNUL
	TLNE	B,SCRF		;SPC. HAND?
	XCT	SPKT(B)		;YES
SPCKRT:	POP	P,L
	JRST	@SPCSKP

SPCNUL:	JSP	B,NULSKP
	JRST	SPCCN1
	JRST	SPCCN2

SPKT:	JRST	SPCDEL
	JFCL
	JFCL
	JFCL
	JFCL
	JRST	SPCCN1
	JFCL
	JFCL
	EMPS	BSPKT

BSPKT:	PUSHJ	P,RTBFND
	JRST	SPCKRT
	JRST	SPCCN1

SPCDEL:	DELHN
	JRST	SPCCN3

SPCRET:	JUMPE	B,LOOP3Q	;IGNORE CHR?
	TLNE	B,SCRF		;DOES THIS CHR REQUIRE SPEC. ATT. BY SCAN?
	XCT	SPCTB(B)	;YES, HANDLE
SPCRT2:	TLZ	IFLG!NFLG!FLTFL	;CLEAR IDENT ,NUM
	TLO	SCFL!SFL	;SET SPC CHR,AHEAD
	MOVE	N,B		;PUT BITS IN N
	JSR	SPCSKP		;SKIP TO NEXT NON-BLANK CHR.
	POPJ	P,

LOOP3Q:	JSP	B,NULSKP
	JRST	LOOP3
	JRST	LOOP3A

NULSKP:	JUMPN	C,(B)			;IF NOT A NULL
NULSK1:	SKIPE	@INPNT			;ZERO WORD?
	JRST	LOOP3Z			;NO
	MOVSI	TAC,700			;SKIP REST OF WORD
	HRR	TAC,INPNT		;AND PREPARE TO SKIP MORE
	SKIPN	1(TAC)
	AOJA	TAC,.-1
	MOVEM	TAC,INPNT
LOOP3Z:	ILDB	C,INPNT			;NO, A NULL, GET NEXT
	JUMPE	C,NULSK1		;SKIP NULLS IN TAIL OF WORD/TMW
	JRST	2,@[20000,,1(B)]	;SET BIS & GO TO IDPB FOR LISTING
BSPCTB:	PUSHJ	P,RTBFND
	JRST	SPCRET
	JRST	LOOP3

^BROKCT:0

LBROK:	HRRI	B,LBCF!TP2F
	TLZ	B,SCRF
	AOS	BROKCT
	POPJ	P,

SPCTB:	JRST	DELT		;DELETE -- HANDLE
	PUSHJ	P,LSTLF		;HANDLE LINE FEED
	JRST	DQT		;HANDLE DOUBLE QUOTE
	JRST	SQT		;HANDLE SINGLE QUOTE
	JRST	EQLS		;HANDLE =
	JRST	LOOP3		;SKIP SPACES
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BSPCTB
^RTBFND:HRRI	B,TP2F!RBCF
	TLZ	B,SCRF
	SKIPN	RTFLST		;ANY TO CHECK?
	POPJ	P,		;NO
	PUSH	P,N		;SAVE
	MOVE	N,BROKCT	;GET CURRENT COUNT
	CAMN	N,@RTFLST	;SAME?
	JRST	RFNDQ		;YES
	SOS	BROKCT		;NO, DECREMENT COUNT AND RETURN
	POP	P,N
	POPJ	P,

RFNDQ:	PUSH	P,L
	MOVE	L,RTFLST	;GET POINTER
	MOVE	N,FSTPNT	;PUT THIS ONE...
	EXCH	N,1(L)		;BACK ON FREE STRG.
	MOVEM	L,FSTPNT	;...
	MOVEM	N,RTFLST	;...
	SOS	BROKCT		;DECREMENT COUNT
	POP	P,L
	POP	P,N
	JRST	CPOPJ1		;SKIP REUTRN
;HANDLE SOS LINE NUMBERS, PAGE MARKS.
LNUM:	JSR	SLNUM
	JRST	LOOP3

				;WE GET HERE AND WE'VE IDPB'D INTO LSTPNT
^SLNUM:	0			;SKIP LINE NUMBERS OR PAGE MARKS
	CAIGE	C,60		;NUMBER?
	JRST	POPMK		;NO.  THIS MUST BE A PAGE MARK
LNMC:	MOVE	C,@INPNT
	MOVEM	C,TLBLK
	MOVEM	C,SVLNUM
	AOS	INPNT		;SKIP LINE NUM WD
	SKIPL	@INPNT		;SEE IF WE RAN OFF BUFFER (RUBOUT WD WILL BE NEG)
	JRST	.+3		;STILL IN BUFFER
	PUSHJ	P,INP		;GET NEXT BUFFER
	IBP	INPNT		;AND SKIP TAB
	MOVEI	C,0
	DPB	C,LSTPNT	;NULL OUT THAT SPURIOUS DIGIT
	JRST	@SLNUM

POPMK:	MOVE	C,[ASCID/     /]
	CAME	C,@INPNT	;PAGE MARK?
	JRST	LNMC		;NO
	AOS	INPNT		;SKIP FIRST PAGE MARK WD
	SKIPGE	@INPNT
	PUSHJ	P,INP		;READ ANOTHER BUFFER IF NEEDED
	AOS	INPNT		;SKIP SECOND PAGE MARK WD
	MOVSI	C,440700
	HLLM	C,INPNT
	TRNE	LDEV		;MAKE SURE THERE IS A LIST DEV
	SKIPN	XPNDSW		;AND THAT WE HAVE NOT SAID XLIST
	TDZA	C,C
	MOVEI	C,14		;IN THAT CASE WE WILL MAKE A PAGE HEADING
	DPB	C,LSTPNT	;NULL (OR FF) OUT THAT SPACE.
	PUSH	P,SLNUM		;PREPARE TO RETURN
^NEWPAG:SKIPL	AHED		;DON'T UPDATE THESE CELLS IF TEXT IS FROM MACRO
	JRST	LSTFRC
	SETZM	INLINE
	AOS	PGNM
	SETZM	SPGNM
	JRST	LSTFRC
NOLD:	DELHN
	SKIPL	B,CTAB(C)
	JRST	NOLT+1
	JRST	@NOLT

DELT:	DELHN
	JRST	AHED

^DELTAB:PUSHJ	P,INPDT		;GET NEXT BUFFER (SOMETIMES DOES: IBP LSTPNT)
	PUSHJ	P,GETARG	;GO TO MACRO ARGUMENT
	POP	M,INPNT		;LEAVE ARGUMENT
	PUSHJ	P,LVMAC		;LEAVE MACRO
	PUSHJ	P,LVREP		;LEAVE REPEAT
	PUSHJ	P,LVFORL	;LEAVE NUMERIC FOR
	PUSHJ	P,LVFORI	;LEAVE "IN" FOR
	PUSHJ	P,EFORSH	;LEAVE "E" FOR
DEFINE  QUOT  ' (M)
<	MOVEI	L,1
	SETZB	N,NA
QP'M:	ILDB	C,INPNT
QQ'M:	IDPB	C,LSTPNT
QT'M:	XCT	AHED
	JRST	[JSR	SLNUM
		JRST	QP'M]
	JUMPE	C,QN'M
	MOVE	B,CTAB(C)
	TLNE	B,SCRF
	XCT	SCQT'M(B)
QU'M:
IFE M,<		TRZN	C,100
		TRZA	C,40
		TRO	C,40>
	LSH	N,6+M
	OR	N,C
	JRST	QP'M

BSCQT'M:PUSHJ	P,RTBFND
	JRST	QU'M
	JRST	QP'M

QN'M:	JSP	B,NULSKP
	JRST	QP'M
	JRST	QQ'M
>


SCQT1:	JRST	DH1
	PUSHJ	P,LSTLF
	JRST	SCR1
	JFCL
	JFCL
	JFCL
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BSCQT1

SCQT0:	JRST	DH0
	PUSHJ	P,LSTLF
	JFCL
	JRST	SCR0
	JFCL
	JFCL
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BSCQT0

DQT:	QUOT(1)

	DEFINE	QUOTS ' (A)
<SCR'A:	JSR	SPCSKP
	TLO	SFL!NFLG
	TLZ	SCFL!IFLG
	POPJ	P,

DH'A:	DELHN
	JRST	QT'A
>

	QUOTS(1)
SQT:	QUOT(0)
	QUOTS(0)
NOLB:	JRST	NOLD
	PUSHJ	P,LSTLF
	JFCL
	JFCL
	MOVE	B,CTAB+"_"	;MAKE = LOOK LIKE _ AFTER SYMS
	JSR	SPCSKP
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BNOLB
BNOLB:	PUSHJ	P,RTBFND
	JRST	NOLT+1
	ILDB	C,INPNT
	IDPB	C,LSTPNT
	SKIPL	B,CTAB(C)
	JRST	NOLT+1
	JRST	@NOLT
BSH:	TRNE	RWARN2
	ERROR	[ASCIZ/INCORRECT DIGITS FOR THIS RADIX/]
	PUSH	P,N		;SAVE THE NUMBER WE HAVE SO FAR
	PUSH	P,SRAD		;CONVERT RADIX FOR NUMBERS TO =10
	PUSH	P,RTEST
	MOVE	N,[IMULI N,=10]
	MOVEM	N,SRAD
	MOVE	N,CTAB+"0"
	ADDI	N,12
	MOVEM	N,RTEST
	MOVEI	N,1(P)
	BLT	N,4(P)		;SAVE 0,1,2,3 ON STACK
	ADD	P,[4,,4]
	TDO	[OPFLG,,NOFXF]	;NO OPCODE LOOKUP, NO FIXUPS WANTED
	PUSHJ	P,SCANS		;EVALUATE ARGUMENT FOLLOWING THE B
	TLNN	UNDF!ESPF
	TRNE	NA,17
	PUSHJ	P,BSH1
	MOVSI	NA,-3(P)	;RESTORE ACS
	BLT	NA,3
	SUB	P,[4,,4]
	MOVN	NA,N		;GET THE SHIFT FACTOR
	POP	P,RTEST
	POP	P,SRAD
	POP	P,N		;THE ORIGINAL NUMBER
	LSH	N,=35(NA)
	JRST	NONM1

BSH1:	ERROR	[ASCIZ/Undefined B-Shift argument - taken as 0/]
	MOVEI	N,0
	POPJ	P,
;	LEAVE MACRO, REPEAT, LVMAC,LVREP,GETARG

LVMAC:	POP	M,C		;GET OLD MTBPNT
	JUMPE	C,LVNO		;NO ARGS?
	POP	M,B		;GET OLD NEW MTBPNT
	PUSHJ	P,MACRET
	SKIPA
LVNO:	SUB	M,[1(1)]
	POP	M,INPNT		;SET SCAN POINTER BACK
	POP	M,INPNTP

;THIS IS SUPPOSED TO ADD A CLOSE CHARACTER AFTER THE MACRO EXPANSION
;UNFORTUNATELY, IT ALSO CAUSES THE CLOSE CHARACTER TO BE UNDERLINED.
	MOVEI	C,IFN STANSW,<"";>"^"	;INDICATE END OF MACRO ON LISTING
	DPB	C,LSTPNT		;STUFF A BYTE
	IBP	LSTPNT			;ACCOUNT FOR THE CLOSING CHARACTER

	POP	M,C			;RESTORE CHR. SIZE FOR LISTING
	DPB	C,[POINT 6,LSTPNT,11]
	HRRZM	C,XPNDSW
	HLRZM	C,INMCSW
	POP	M,C
	MOVEM	C,AHED
	MOVEM	C,LOOP6
	SKIPE	UNDLNS		;UNDERLINING?
	SKIPE	NOEXP		;NO EXPAND?
	JRST	ARNMC		;NO
	SKIPN	INMCSW		;IN A MACRO?
	JRST	ARNMC		;YES
	HRR	C,LSTPNT
	ADDI	C,TLBLK-MBLK	;GO BACK TO NORMAL POINTER
	HRRM	C,LSTPNT
ARNMC:	POP	M,C		;GET CHR.
	JRST	CPOPJ1		;SKIP NEXT ILDB

GETARG:	ILDB	C,INPNT		;GET ARG #
	ADD	C,(M)		;GET POINTER
	PUSH	M,INPNT		;SAVE OLD PNTR.
	MOVE	C,(C)
	MOVEM	C,INPNT
	POPJ	P,

LVREP:	SOSG	-1(M)		;DECREMENT COUNT
	JRST	LRDON		;DONE
	MOVE	C,(M)		;GET...
	HRLI	C,440700	;POINTER
	MOVEM	C,INPNT
	POPJ	P,

LRDON:	POP	M,C		;GET POINTER
	SUB	M,[1(1)]
	POP	M,B		;GET OLD NEW MTBPNT
	PUSHJ	P,MACRET
ALDON:	PUSHJ	P,LSTCHK	;A GOOD PLACE TO CATCH LOSSAGE FROM MOBY LINES
	POP	M,INPNT		;RESTORE SCAN POINTER
	POP	M,INPNTP
	POP	M,C		;RESTORE...
	DPB	C,[POINT 6,LSTPNT,11]	;LISTING
	HRRZM	C,XPNDSW
	HLRZM	C,INMCSW
	POP	M,C
	MOVEM	C,AHED		;RESTORE LINE NUM SKIPPING
	MOVEM	C,LOOP6
	SKIPE	UNDLNS		;UNDERLINING?
	SKIPE	NOEXP		;NO EXPAND?
	POPJ	P,
	SKIPN	INMCSW		;IN A MACRO?
	POPJ	P,
	HRR	C,LSTPNT
	ADDI	C,TLBLK-MBLK
	HRRM	C,LSTPNT
	POPJ	P,
;	LVFORL, LVFORI, EFORSH

LVFORL:	MOVE	B,-4(M)			;GET INCREMENT
	ADDB	B,-2(M)			;ADD NUM
	SKIPG	-4(M)			;NEG INCREMENT?
	JRST	NTST			;YES
	CAMLE	B,-3(M)			;DONE?
	JRST	LFDON			;YES
NLFD:	MOVE	C,(M)			;GET ARG POINTER
	ADD	C,[XWD 440700,2]
	PUSHJ	P,BKSLSH		;CON TO ASCII
	EDEPO	(B,C,2)			;DEPOSIT END OF ARG
	MOVE	B,-1(M)			;GET START
	ADD	B,[XWD 440700,2]
	MOVEM	B,INPNT
	JRST	LSTCHK

NTST:	CAML	B,-3(M)			;DONE? (NEGATIVE INCREMENT)
	JRST	NLFD			;NO
LFDON:	HRRZ	C,-1(M)			;GET START OF THROW-AWAY
	SUB	M,[5(5)]	
	POP	M,B			;GET OLD NEW MTBPNT
	PUSHJ	P,MACRET
	JRST	ALDON

LVFORI:	MOVE	B,(M)			;GET ARG POINTER
	MOVE	B,1(B)			;GET POINTER
	ILDB	C,B			;GET FIRST CHR. OF SECOND ARG
	CAIE	C,177			;IS IT DELETE?
	JRST	IFORSH			;NO, GET NEXT ARG SETUP
	SUB	M,[2(2)]		;YES, NO MORE ITERATIONS
	POP	M,C			;GET START OF THROW-AWAY
	POP	M,B			;GET OLD NEW MTBPNT
	PUSHJ	P,MACRET
	JRST	ALDON

^EFORSH:MOVE	B,(M)			;GET ARG POINTER
	ILDB	C,1(B)			;GET NEXT CHR.
	MOVE	B,(B)			;GET FIRST ARG POINTER
	IDPB	C,B			;DEPOSIT CHR.
	CAIN	C,177			;DONE?
	JRST	DYES			;YES
	MOVE	B,-1(M)			;GET TEXT POINTER
	MOVEM	B,INPNT			;DEPOSIT
	JRST	LSTCHK

DYES:	POP	M,C			;GET STRT OF REMOVABLE AREA
	SUBI	C,2			;ADJUST
	SUB	M,[1,,1]		;ADJUST STACK
	POP	M,B			;END OF REMOVABLE AREA
	PUSHJ	P,MACRET
	JRST	ALDON			;
	SUBTTL SCAN1,SCNTIL, SCANM

^SCAN1:	TLZE	SFL		;AHEAD?
	JRST	S1PT		;YES
^SCAN1A:MOVEI	L,1		;PREPARE TO TEST FOR LINE NUM
LOOP4:	ILDB	C,INPNT		;GET CHR.
LOOP4A:	IDPB	C,LSTPNT	;DEPOSIT FOR LISTING
^LOOP6:	TDNE	L,@INPNT	;LINE NUM?
	JRST	[JSR	SLNUM
		JRST	LOOP4]
	SKIPN	B,CTAB(C)	;GET BITS, NULL CHR?
	JRST	LOOP4Q		;YES, NULL CHR.
S1PT:	TLNE	B,SCRF		;SPECIAL HANDLING?
	XCT	SC1T(B)		;YES, HANDLE
	POPJ	P,

LOOP4Q:	JSP	B,NULSKP
	JRST	LOOP4
	JRST	LOOP4A

SC1T:	JRST	SC1DH
	PUSHJ	P,LSTLF
	JFCL
	JFCL
	JFCL
	JFCL
	JFCL
	PUSHJ	P,NEWPAG
	EMPS	BSC1T

BSC1T:	PUSHJ	P,RTBFND
	POPJ	P,
	JRST	LOOP4

SC1DH:	DELHN
	JRST	LOOP6
^SCNTIL:TLZE	SFL			;AHEAD?
	JRST	LOPP3			;YES
LOPP1:	ILDB	C,INPNT			;GET CHR.
LOPP1A:	IDPB	C,LSTPNT		;DEPOSIT
LOPP2:	SKIPN	B,CTAB(C)		;GET BITS
	JRST	LOPP1Q			;NULL CHR
LOPP3:	TLNE	B,SCRF			;SPECIAL?
	XCT	STTB(B)			;YES
	MOVSI	B,777777-COMBTS		;WATCH US SKIP COMMENTS FAST
	MOVE	TAC,INPNT
LOP69:
REPEAT 5,<	ILDB	C,TAC
		IDPB	C,LSTPNT
		TDNN	B,CTAB(C)
		JRST	LOP105	>
	JRST	 LOP69

LOP105:	MOVEM	TAC,INPNT
	JRST	LOPP2

LOPP1Q:	JSP	B,NULSKP
	JRST	LOPP1
	JRST	LOPP1A

STTB:	JRST	STDH			;DELETE
	JRST	LSTLF			;LINE FEED, FORCE LISTING AND RETURN
	JFCL
	JFCL
	JFCL
	JFCL
	JFCL
	JRST	NEWPAG			;FORM FEED, ADVANCE PAGE AND RETURN
	EMPS	BSTTB

BSTTB:	PUSHJ	P,RTBFND
	JRST	LOPP1
	JRST	LOPP1

STDH:	DELHN
	JRST	LOPP2
^SLURP:	PUSH	P,BROKCT	;ROUTINE TO EAT TEXT UP TO MATCHING BROKET
	SETZM	BROKCT
	JSP	TAC,SLRP0
	SOSL	BROKCT
	JRST	SLRP1
	POP	P,TAC
	ADDM	TAC,BROKCT
	POPJ	P,

^SLURPC:MOVE	TAC,CTAB(C)	;EATS TEXT UP TO MATCHING CHAR
	TLNN	TAC,777777-COMBTS
	TLNN	TAC,SCRF
	JRST	.+3
	ERROR	[ASCIZ /ILLEGAL DELIMETER/]
	POPJ	P,
	PUSH	P,TAC
	HRLOI	TAC,SCRF	;-1 INDEX MEANS EXIT VIA SLRPX
	MOVEM	TAC,CTAB(C)
	TLZ	SFL
	JSP	TAC,SLRP0
	PUSHJ	P,RTBFND
	JRST	SLRP1
	JRST	SLRP1

SLRP0:	HRRM	TAC,SRBINS
	MOVEI	L,1		;FOR LINE NUMBER TEST
	TLZE	SFL
	JRST	SLRP2
SLRP1:	ILDB	C,INPNT
SLRP1A:	IDPB	C,LSTPNT
SLRP2:	XCT	AHED		;TEST FOR LINE NUMBER IF APPROPRIATE
	JRST	[JSR SLNUM	;FLUSH LINE NUMBER (SPECIAL)
		JRST SLRP1]
	SKIPN	B,CTAB(C)
	JRST	SLRPN
SLRP3:	TLNE	B,SCRF
	XCT	SLTB(B)
	MOVSI	B,777777-COMBTS	;PREPARE TO IGNORE ALMOST EVERYTHING
	MOVE	TAC,INPNT
SLRP4:
REPEAT 5,<
		ILDB	C,TAC
		IDPB	C,LSTPNT
		TDNN	B,CTAB(C)
		JRST	SLRP5	
>
	JRST	SLRP4

SLRP5:	MOVEM	TAC,INPNT
	JRST	SLRP2

;XCT TABLE FOR SPECIAL CHARACTER DISPATCH
	JRST	SLRPX		;EXIT FROM SLURPC RESTORE CTAB
SLTB:	JRST	SLDH
	JRST	[PUSHJ P,LSTLF	;FORCE LISTING NOW
		JRST SLRP1]
	REPEAT	7-2,<JFCL>
	PUSHJ	P,NEWPAG
	AOS	BROKCT
SRBINS:	JRST	.-.		;ADDRESS GETS CLOBBERED


SLRPN:	JSP	B,NULSKP
	JRST	SLRP1
	JRST	SLRP1A

SLDH:	DELHN
	JRST	SLRP2

SLRPX:	POP	P,B
	MOVEM	B,CTAB(C)
	POPJ	P,
;SCANM	HERE FOR SCAN IF MACROS ARE TO BE EXPANDED
;SCANM1 alternate entry from DSCANM
^SCANM:	PUSHJ	P,SCAN
	TLNN	IFLG		;IDENTIFIER?
	POPJ	P,		;NO
SCANM1:	MOVE	N,L		;GET SIXBIT
	IDIVI	N,HASH		;HASH
	MOVMS	NA
	SKIPN	TAC,MACRT(NA)	;GET START OF MACRO TABLE CHAIN
	POPJ	P,		;NONE THERE.
	SRC1(L,TAC,SCNMF,<POPJ P,>)	;SEARCH FOR THIS IDENT AS A MACRO
SCNMF:	MOVEI	NA,(TAC)	;NA=SYMBOL BLOCK FOR THIS MACRO
	SKIPN	N,3(NA)		;ANY ARGS?
	JRST	NOAG		;NO
	JUMPL	N,SCNMPO	;JUMP IF MACRO "PSEUDO OP" (IFs, ".", .FNAM1, ETC)
	PUSH	P,NA		;SAVE POINTER TO MACRO SYMBOL ENTRY
	PUSH	P,MTBPNT	;SAVE ARGUMENT POINTER
	PUSHJ	P,ARGIN		;GET ARGUMENTS
	JUMPN	C,.+2
	IBP	LSTPNT
	POP	P,N		;GET POINTER TO THE ARGUMENT LIST
	HRRZM	NA,MTBPNT	;DEPOSIT NEW POINTER TO MACRO FREE SPACE
	POP	P,NA		;RESTORE POINTER TO MACRO SYMBOL ENTRY
NOAG:	SKIPE	XCRFSW			;CREF IN PROGRESS RIGHT NOW?
	JRST	[CAIN	NA,%IOWD	;YES.  IS THE IOWD PREDEFINED MACRO?
		CREF7	5,(NA)		;YES. IOWD.  CREF IT AS AN OPCODE/PSEUDO-OP
		CAIE	NA,%IOWD
		CREF6	5,(NA)		;OTHERWISE CREF IT AS A MACRO
		JRST	.+1]
	PUSH	M,C			;SAVE CHR.
;	TRNE B,LBCF!RBCF	;DID WE FUCK UP BROKCT?
;	JRST [	TRNE B,LBCF
;		SOSA BROKCT
;		AOS BROKCT
;		JRST .+1]
	PUSH	M,AHED		;SAVE STATE OF LINE NUMBER LOOKING FOR
	LDB	C,[POINT 6,LSTPNT,11]	;SAVE STATE...
	HRL	C,INMCSW		;IN MACRO &...
	PUSH	M,C			;INSIDE MACRO FLAG,,STATE OF LISTING
	PSHPNT	(C)			;SAVE SCAN POINTER, ETC
	PUSH	M,MTBPNT
	PUSH	M,N			;DEPOSIT ARG POINTER
	TLZ	SFL			;CLEAR "SCAN AHEAD"
IFN STANSW,<	MOVEI N,"";>MOVEI N,"^"
	DPB	N,LSTPNT		;ERASE LAST CHR IN LISTING
	MOVEI	N,
	SKIPE	NOEXP			;NO MACRO EXPAND?
	DPB	N,[POINT 6,LSTPNT,11]	;YES,DISCONTINUE LISTING
	SKIPE	NOEXP
	SETZM	XPNDSW
	SETZM	INMCSW			;FLAG WE ARE INSIDE MACRO EXPANSION
	MOVE	N,4(NA)			;GET TEXT POINTER
	HRLI	N,700			;MAKE INTO BYTE POINTER
	MOVEM	N,INPNT			;SET MACRO-INPNT (DISTINCT FROM FILE-INPNT)
	MOVSI	N,(<SKIPA>)
	MOVEM	N,AHED			;AVOID SKIPING...
	MOVEM	N,LOOP6			;LINE NUMBERS
	SKIPN	NOEXP			;NO EXPAND?
	SKIPN	UNDLNS			;UNDERLINE?
	JRST	SCANM			;NO
	HRRZ	N,LSTPNT		;GET LIST. POINTER
	CAIL	N,TLBLK			;ALREADY CHANGED?
	SUBI	N,TLBLK-MBLK		;NO,CHANGE IT
	HRRM	N,LSTPNT
	TRO	MACUNF			;SET BIT - MACRO UNDERSCORE
	JRST	SCANM

SCNMPO:	TLNE N,1		;MACRO PSEUDO OP.  EMIT TO CREF?
	SKIPN XCRFSW		;YES. BUT ARE WE DOING CREF?
	JRST @4(NA)		;NO TO ONE OF THE ABOVE, PROCESS PSEUDO-OP
	CREF7 5,(NA)		;EMIT TO CREF AND PROCESS
	JRST @4(NA)

^SCNMPT:TLZ IFLG		;HERE FOR "." AND "$." FAKE SCANS INTO CALLING
	POPJ P,			;SPCCHK	 ...ALSO .FNAM1,.FNAM2
;ARITHMETIC IFS,  IFIDN

^REPSW:	0				;0 FOR CONDITIONALS, -1 FOR REPEATS
Q%SV:	0
Q%SVBL: 0

^Q%IF:	DPB	N,[POINT 3,Q%T,8]	;DEPOSIT TEST CONDITION
	MOVEI	N,1(P)
	BLT	N,4(P)			;SAVE AC'S
	ADD	P,[4,,4]
	TDO	[OPFLG,,NOFXF]
	PUSHJ	P,MEVAL			;GET VALUE
	TLNN	UNDF!ESPF
	TRNE	NA,17			;CHECK FOR DEFINED
	PUSHJ	P,IFER			;ERROR - ARGUMENT IS UNDEFINED. 
	MOVSI	NA,-3(P)
	BLT	NA,3			;RESTORE AC'S
	SUB	P,[4,,4]
Q%T:	SKIP	N			;***INSTRUCTION IS CLOBBERED***
	TDZA	N,N			;N_0 AND SKIP.
	MOVEI	N,1			;N_1
	SETZM	REPSW			;DO NOT INSERT CR LF AT END OF CONDITIONAL
	PUSHJ	P,REP			;DO THE REPEAT.  N IS THE REPEAT COUNT
	JRST	SCANM

IFER:	ERROR	[ASCIZ /UNDEFINED IF ARGUMENT - TAKEN AS 0/]
	MOVEI	N,0
	POPJ	P,

^Q%IFD:	HRREM	N,Q%SV			;SAVE "VALUE" (0 OR -1)
	JSR	LGET			;GET THE {
	MOVE	NA,MTBPNT		;MAKE POINTER
	HRLI	NA,440700		;...
	PUSHJ	P,SARGIN		;READ IN FIRST ARG.
	MOVEI	N,0			;FIVE MORE ZEROES TO END THE FIRST ARG
REPEAT 5,<LEG	IDPB	N,NA>
	HRRZ	N,NA			;N_STARTING ADDRESS OF SECOND ARG.
	HRLI	NA,440700		;MAKE POINTER
	JSR	LGET			;GET THE {
	PUSHJ	P,SARGIN		;READ IN SECOND ARG
	MOVEI	TAC,0			;SUPPLY EXTRA ZEROS
REPEAT 5,<LEG	IDPB	TAC,NA>
	HRRZ	NA,NA			;ENDING ADDRESS OF SECOND ARG.
	SUB	NA,N
	ADD	NA,MTBPNT
	CAME	NA,N			;SAME LENGTH?
	JRST	FLS			;NO. - FALSE
	MOVE	NA,MTBPNT		;GET POINTER
	MOVE	PN,N			;SAVE END
Q%LOP:	MOVE	TAC,(N)			;GET WORD
	XOR	TAC,(NA)		;ARE THEY THE SAME?  TAC_0 IF SO.
	TRZ	TAC,1			;(IGNORE BIT 35 IN COMPARE)
	JUMPN	TAC,FLS			;JUMP IF DIFFERENT. (FALSE)
	ADDI	NA,1
	CAMGE	NA,PN			;DONE?
	AOJA	N,Q%LOP			;NO.  ADVANCE N AND LOOP.
TR:	SETCMM	Q%SV			;TRUE - COMPLEMENT FLAG
FLS:	AOS	N,Q%SV			;FALSE.  GET VALUE (N_0 OR 1)
	SETZM	REPSW			;NO CRLF AT END
	PUSHJ	P,REP			;DO IT
	JRST	SCANM


;handler for IFB and IFNB.   Enter with N=0 for IFNB
^Q%IFB:	HRREM	N,Q%SVBL		;SAVE "VALUE" (0 OR -1)
	JSR	LGET			;GET THE {
	MOVE	NA,MTBPNT		;MAKE POINTER
	HRLI	NA,440700		;...
	PUSHJ	P,SARGIN		;READ IN the ARG.
	MOVEI	N,0			;ZERO TO END THE ARG
	IDPB	N,NA
	MOVE	NA,MTBPNT		;GET POINTER
	HRLI	NA,440700		;to the argument string
Q%IFBL:	ILDB	TAC,NA			;read argument string
	JUMPE	TAC,Q%IFBT		;was all blank
	CAIE	TAC,40
	CAIN	TAC,11
	JRST	Q%IFBL			;LOOP WHILE BLANKS ARE SEEN
	SETO	TAC,
Q%IFBT:	MOVEI	N,1			;assume it's ok
	CAMN	TAC,Q%SVBL
	MOVEI	N,0			;if equal, we don't expand
	SETZM	REPSW			;NO CRLF AT END
	PUSHJ	P,REP			;DO IT
	JRST	SCANM
; IFDEF, IFAVL, IFMAC AND IFOP

QERR:	ERROR	[ASCIZ/NOT IDENT AFTER IFDEF,IFAVL, ETC. /]
	JRST	SCANM

^QIF%D:	HRREM	N,Q%SV		;SAVE VALUE
	PUSHJ	P,SCAN		;GET SYMBOL
	TLNN	IFLG		;IDENT?
	JRST	QERR		;NO
	MOVE	NA,L		;GET SIXBIT
	IDIVI	NA,HASH		;HASH
	MOVM	PN,PN
	SKIPN	PN,SYMTAB(PN)	;GET START OF CHAIN
	JRST	QICOM		;NONE
	SRC1	(L,PN,DFND,JRST QICOM)
DFND:	MOVE	N,2(PN)		;GET FLAGS
	TLNE	N,DEFFL		;DEFINED ANYWHERE?
	JRST	QICOM		;NO
	JRST	TR

^QIF%A:	HRREM	N,Q%SV		;SAVE VALUE
	PUSHJ	P,SCAN		;GET SYMBOL
	TLNN	IFLG		;IDENT?
	JRST	QERR		;NO
	MOVE	NA,L		;GET SIXBIT
	IDIVI	NA,HASH		;HASH
	MOVM	PN,PN
	SKIPN	PN,SYMTAB(PN)	;GET START
	JRST	QICOM		;NONE
	SRC1	(L,PN,AFND,JRST QICOM)
AFND:	MOVE	N,2(PN)		;GET FLAGS
	TLNN	N,DEFFL		;DEFINED AT ALL?
	TDNN	N,BLOCK		;YES. DEFINED IN THIS BLOCK?
	JRST	QICOM		;NO
	JRST	TR		;YES

QICOM:	MOVE	NA,L		;GET SIXBIT
	IDIVI	NA,HASH		;HASH
	MOVM	PN,PN
	SKIPN	PN,MACRT(PN)	;GET START OF MACRO TABLE
	JRST	QIOP		;NONE
	SRC1	(L,PN,TR,JRST QIOP)
QIOP:	MOVE	NA,L		;GET SIXBIT
	IDIVI	NA,HASH		;HASH
	MOVM	PN,PN
	SKIPN	PN,OPCDS(PN)	;GET START
	JRST	FLS		;NONE
	SRC2	(L,PN,TR)
	JRST	FLS

;IFOP IFNOP			;REG 3-15-74
^QIF%O:	HRREM	N,Q%SV		;SAVE VALUE
	PUSHJ	P,SCAN		;GET SYMBOL
	TLNN	IFLG		;IDENT?
	JRST	QERR		;NO
	JRST	QIOP

;IFMAC IFNMAC
^QIF%M:	HRREM	N,Q%SV		;SAVE VALUE
	PUSHJ	P,SCAN		;GET SYMBOL
	TLNN	IFLG		;IDENT?
	JRST	QERR		;NO
	MOVE	NA,L		;GET SIXBIT
	IDIVI	NA,HASH		;HASH
	MOVM	PN,PN
	SKIPN	PN,MACRT(PN)	;GET START
	JRST	FLS		;NONE
	SRC2	(L,PN,TR)
	JRST	FLS		;NONE
;	.INSERT

;FORMAT IS  .INSERT DEV:FILE.EXT[PRJ,PRG]
;THIS USES THE SAME SCANNER AS THE COMMAND LINE SCANNER!  MODIFIERS BEWARE!!

^%INSER:
	MOVE	N,FILSTP	;GET FILE-STACK POINTER
	CAIL	N,FILSTP	;POINTS BEYOND END OF FILE-STACK?
	JRST	INSRET		;YES. TOO MANY NESTED INSERTS

NOTNX,<	HRLI	N,LFDEV		;SOURCE,,DESTINATION IN N.
	MOVEI	NA,(N)
	BLT	N,5(NA)		;STORE PERMANENT FILE PARAMETERS (DEV,FIL,EXT,PPN)
	MOVE	N,LFDEV		;GET DEVICE NAME OF PRESENT DEV
	DEVCHR	N,		;GET DEC-STYLE CHARACTERISTICS
	TLNN	N,200000	;MUST BE DSK.
	JRST	INSRED		;LOSE.
>;NOTNX				;SO FAR I'M HAPPY.  LET'S PARSE A FILE NAME.

TNX,<	MOVE	NA,JFNTBL	;INPUT JFN PLUS FLAGS
	MOVEM	NA,(N)		;STACK IT
	JUMPGE	NA,INSRED	;NON-DISK DEVICE. >;TNX

	MOVEM	16,TSV+16	;SAVE AC'S DURING FILE NAME SCAN
	MOVEI	16,TSV
	BLT	16,TSV+15
	MOVE	16,TSV+16	;RESTORE 16 NOW (MACRO PDL)

	PUSH	P,FNREAD	;SAVE NORMAL COMMAND LINE READER.
	MOVE	N,[PUSHJ P,AFSCAN]
	MOVEM	N,FNREAD

ITS,<		PUSH	P,LIMBO
		SETZM	LIMBO	>

NOTNX,<		MOVSI	1,'DSK'	;ASSUMED DEVICE
		SETZB	5,4	;NO ASSUMPTION ABOUT FILE NAME OR PPN	>;NOTNX

NOITS,<		MOVEI	3,0		;NO ASSUMPTION ABOUT EXTENSION >;NOITS
ITS,<		MOVSI	3,360000 	;USE "GREATER THAN" AS EXTENSION >;ITS

;GETFIL CALLS SCAN1.  CLOBBERS AC'S 0-13.
;0 IS SETUP CORRECTLY
;1,2,4,5,6,12,13 ARE CONSIDERED SCRATCH (T,FS,N,NA,PN,TAC)
;10,11 (B,C) ARE SET CORRECTLY TO LAST CHARACTER SEEN
;7 (CP) IS USED AS THE COROUTINE PDL

	SETZM	INSRFG#		;FLAG FOR SUCESSFUL SCAN
	JSR	NOTNX,<GETFIL;> TGETF	;GET A FILE NAME
	SETOM	INSRFG		;CAN'T PARSE FILE NAME.
	MOVEM	16,TSV+16	;SAVE M SINCE SCANNER MAY BE INSIDE A MACRO

ITS,<		POP	P,LIMBO		>

	POP	P,FNREAD
	TLO	SFL		;LETS SEE THE CHARACTER BY WHICH WE TERMINATED
	SKIPE	INSRFG
	JRST	INSREF		;SCAN ERROR.
	TRZ	NOFXF
INSR1:	PUSHJ	P,SCAN1
	TLNN	B,CRFG!LNFD!RBRF	;SCAN TO NEXT LF OR RIGHT BRACE
	JRST	INSR1
	MOVEM	16,TSV+16	;SAVE M SINCE SCANNER MAY BE INSIDE A MACRO
	TLNE	B,RBRF		;BRACE?
	JRST	ISWITC		;YES (AVOID FORM FEED, ETC)
	TLNN	B,LNFD		;LINE FEED YET
	PUSHJ	P,SCNTIL
	MOVEI	16,1
	MOVEM	16,LNCNT	;ARRANGE FOR NEXT LF TO MAKE NEW PAGE
ISWITC:	MOVE	16,@INPNTP	;GET FILE-INPNT  (INPUT BYTE POINTER)
	SUB	16,INPOFS	;BYTE-OFFSET
	MOVEM	16,@INPNTP	;SAVE BYTE-OFFSET (MAY CLOBBER REAL INPNT)
	MOVE	16,INPNT	;GET PRESENT INPNT (NEEDED IF CALLED FROM MACRO)
	MOVE	15,FILSTP	;FILE-STACK POINTER
	MOVEM	16,NOTNX,<3(15);> 1(15)	;SAVE OLD-INPNT
	HRLZ	16,PGNM		;GET PAGE NUMBER
	HRR	16,IRECN	;GET RECORD NUMBER
	MOVEM	16,NOTNX,<5(15);> 2(15)	;SAVE RECORD NUMBER AND PAGE NUMBER
	HRRZ	16,INLINE

IFN STANSW,<	HRL	16,TVFILE	>;SAVE STATE OF TVFILE

	MOVEM	16,NOTNX,<6(15);> 3(15)
	MOVE	16,INPNTP	;GET POINTER TO FILE-INPNT
	MOVEM	16,NOTNX,<7(15);> 4(15)	;SAVE ON FILE-STACK
	ADDI	15,FILSTL	;PUSH FILE-STACK POINTER PAST THIS ENTRY
	MOVEM	15,FILSTP	;SAVE IT.
	AOS	FILSTC		;INCREMENT FILE-STACK DEPTH
	MOVEI	6,INSNOF	;SET UP FOR FAILURE FROM INITIT
	MOVEM	6,INITL		;(ICK!)
	MOVEI	6,2		;SET FOR DEVICE 2 (INPUT FILE)
	JSR	INITIT		;SWITCH TO ALTERNATE INPUT FILE.

NOTNX,<	MOVEI	NA,IBUFR1	;ADDRESS OF THE FIRST BUFFER
	TLO	NA,400000
	MOVEM	NA,IDB		;SET UP BUFFER >;NOTNX

	SETZM	IRECN		;SET RECORD COUNT
	MOVE	16,[TSV+1,,1]
	BLT	16,16		;RESTORE OLD AC'S (0 AND P ARE OK)
	SETZM	PGNM		;SETUP LINE AND PAGE STUFF
	AOS	PGNM
	SETZM	INLINE
	SETZM	SPGNM
	SETZM	TLBLK		;FLUSH SOS LINE #
	SETZM	SVLNUM		;"
	PUSHJ	P,TVSKIP	;SETUP TO READ FIRST RECORD, AND RETURN
	JRST	SCANM		;CONTINUE MACRO-SCAN

INSREF:	ERROR	[ASCIZ/CAN'T PARSE FILE NAME/]
	MOVE	16,[TSV+1,,1]	;(PRESENT CONTENTS OF 0 ARE RIGHT)
	BLT	16,16		;RESTORE AC'S (EXCEPT P)
	JRST	SCANM		;RETURN AND DON'T SWITCH.

INSRET:	ERROR	[ASCIZ/.INSERT NESTED TOO DEEP/]
	JRST	SCANM

INSRED:	ERROR	[ASCIZ/MUST SWITCH FROM DSK:/]
	JRST	SCANM

INSNOF:	FATAL	[ASCIZ/FATAL: CANNOT LOCATE INSERTED FILE/]
SUBTTL SCANS -- MAIN SCANNER IF SYMBOLS ARE TO BE LOOKED UP

;SCANS 	GO HERE FOR SCAN IF MACROS ARE TO BE EXPANDED AND
;	SYMBOLS ARE TO BE LOOKED UP

;SCANS1 is alternate entry point to SCANS from DSCANS

^SCANS:	PUSHJ	P,SCANM		;ANY MACRO FOUND WILL BE EXPANDED.
SCANS1:	TLNN	IFLG		;IDENT?
	JRST	SPCCHK		;NO, SPC CHR.
	TLNN	OPFLG		;HAS AN OPCODE BEEN SEEN?
	SKIPN	PN,OPCDS(NA)	;NO. CHECK OPCODE TABLE GET START OF CHAIN
	JRST	PT1		;NONE
	SRC2	(L,PN,PT2)
PT1:	SKIPN	TAC,SYMTAB(NA)
	JRST	PT4		;NONE THERE AT ALL
	CAMN	L,(TAC)
	JRST	PT69		;FIRST SYM IN LIST. DON'T MOVE IT.
SR:	SKIPN	PN,1(TAC)
	JRST	PT4		;END OF LIST
	CAMN	L,(PN)		;IF IT MATCHES
	JRST	PT3
	SKIPN	TAC,1(PN)	;ELSE TRY NEXT
	JRST	PT4		;HERE IF SYM NOT FOUND
	CAME	L,(TAC)		;SEE US PLAY LEAPFROG WITH AC'S
	JRST	SR		;KEEP LOOKING
	EXCH	TAC,PN		;STRAIGHTEN OUT AC'S
;HERE PN IS SYM FOUND, AND TAC IS PREVIOUS SYM IN LIST
;SYM IS MOVED TO FRONT OF LIST TO FIND "POPULAR" SYMS FAST
PT3:	MOVE	N,2(PN)
	TDNN	N,BLOCK		;RIGHT BLOCK?
	JRST	PT4		;NO - MUST NOT BE THERE
	EXCH	N,1(PN)		;NEXT GUY
	EXCH	N,1(TAC)	;DELINK & GET CURRENT (SAME AS PN)
	EXCH	N,SYMTAB(NA)	;SWAP CURRENT WITH FIRST
	EXCH	N,1(PN)		;AND POINT CURRENT AT REST OF LIST (RESTORING N)
PT69R:	SKIPE	XCRFSW
	CREF6	1,(PN)
PT3B:	TRNE	B,SHRPF!UDARF	;# OR ^ NEXT?
	JRST	VRHN		;YES
PT3A:	TLNE	N,DEFFL		;DEFINED?
	JRST	NODF		;NO
	TLON	N,REFBIT
	JRST	[TLZ N,SUPBIT	;NO LONGER SUPPRESSED
		MOVEM N,2(PN)	;STORE NEW FLAGS
		JRST .+1]
	MOVE	N,3(PN)		;YES,GET VALUE ...
	MOVE	NA,4(PN)		;....
	POPJ	P,

NODF:	MOVE	N,PN		;NO DEFINITION. VALUE IS POINTER
	HLLZ	NA,2(PN)
	POPJ	P,

PT1X:	TRNN	B,SHRPF		;TERMINATES WITH SHARP?
	TRNE	B,TP2F		;NO. UPARROW?
	JRST	PT1		;TERMINATES WITH ^ (OR TILDE) OR #
	JRST	PT2X		;TERMINATES WITH DOWN-ARROW (OR ?) ASSUME THIS IS OPCODE

;HERE FROM MEVAL&DEFN WHEN SYMBOL WAS FOUND AS AN OPCODE,
; BUT WE WANT TO DEFINE IT AS A LABEL (PARAMETER, ETC.)
^RESCN:	MOVE	N,L		;GET SIXBIT
	IDIVI	N,HASH		;HASH
	MOVMS	NA
	JRST	PT1
;HERE WHEN AN OPCODE IS FOUND
PT2:	TRNE	B,SHRPF!UDARF		;TERMINATES WITH # OR ^
	JRST	PT1X			;YES. IT MIGHT NOT BE AN OPCODE!
PT2X:	TLO	SOPF			;OPCODE FOUND
^OPVAL:	MOVEI	NA,			;ZERO NA
	HLLZ	N,1(PN)			;GET FLAGS (VALUE)
	TLNN	N,30			;REGULAR OPCODE?
	POPJ	P,			;YES, RETURN IT

NOITS,<		TLZE	N,10	;CALLI?
		JRST	CALLOP	;YES. >

	JUMPL	N,PSOP		;PSEUDO-OP?

	MOVE	N,2(PN)		;THIS IS AN OPDEF
	TLON	N,REFBIT	;MARK AS REFERENCED IN FLAG WORD
	JRST	[TLZ	N,SUPBIT	;AND NOT SUPPRESSED.
		MOVEM	N,2(PN)		;(ONLY WRITE IF IT NEEDS TO.)
		JRST	.+1]
	MOVE	N,3(PN)		;NO, GET VALUE
	MOVE	NA,4(PN)	;AND VALUE FLAGS
	POPJ	P,		;RETURN

PSOP:	TLO	PSOPF		;PSEUDO-OP SEEN
	MOVE	NA,2(PN)	;GET PSEUDO-OP ROUTINE ADDRESS
	MOVE	N,3(PN)		;GET VALUE
	POPJ	P,

NOITS,<
CALLOP:
IFN STANSW,<	ROT	N,15
		CAML	N,UCLDLN 	;SMALLER THAN STANFORD SPECIAL CALLIS?
		ADD	N,SCLOFF	;NO. ADD OFFSET TO MAKE CALLI 400000+ >

IFE STANSW,<	ASH	N,-27		;SIGN EXTEND CALLI NUMBER TO RIGHT SIDE >

		HRLI	N,(<CALLI>)
		POPJ	P,
>;NOITS

^MKNEW:	PUSH	P,N		;SAVE
	PUSH	P,NA
	PUSH	P,L
	MOVE	 L,(PN)		;GET SIXBIT
	MOVE	N,L
	IDIVI	N,HASH		;HASH
	MOVM	NA,NA
	PUSHJ	P,PT4		;MAKE A PLACE
	POP	P,L		;RESTORE
	POP	P,NA
	POP	P,N
	POPJ	P,
PT69:	MOVEI	PN,(TAC)	;UNSHUFFLE AC'S
	MOVE	N,2(PN)
	TDNE	N,BLOCK		;RIGHT BLOCK?
	JRST	PT69R		;YES
PT4:	GFST	PN,FSTPNT	;MAKE AN ENTRY FOR A NEW SYMBOL.  GET SOME FREE STG.
	SKIPE	XCRFSW
	CREF6	1,(PN)
	MOVEM	L,(PN)		;DEPOSIT SIXBIT
	MOVE	N,SYMTAB(NA)	;GET CURRENT POINTER
	MOVEM	PN,SYMTAB(NA)	;REPLACE WITH POINTER HERE
	EXCH	N,1(PN)		;POINT NEW TO OLD AND ...
	MOVEM	N,FSTPNT	;ADVANCE FREE STRG PNT.
	SETZM	3(PN)		;NO FIXUPS YET
	SETZM	4(PN)		;NO POLFIX'S YET
	MOVSI	N,DEFFL		;UNDEFINED
	OR	N,BLOCK		;GET BLOCK BIT
PT4A:	TRNE	B,SHRPF!UDARF	;# OR ^ NEXT?
	JRST	VARH		;YES
	MOVEM	N,2(PN)		;SET FLAGS
	HLLZ	NA,N
	MOVEI	N,(PN)		;VALUE IS POINTER
	POPJ	P,

MAKEXT:	PUSHJ	P,SCAN1A	;SKIP THE ^
	MOVE	L,(PN)		;RESTORE SIXBIT IN CASE LABEL
	TLNN	N,DEFFL
	TLOA	N,INTF!REFBIT	;CONSIDER THESE TO BE REFERENCES
	TLO	N,EXTF!REFBIT
	POPJ	P,

EXTH:	PUSHJ	P,MAKEXT		;FIRST OCCURANCE OF SYMBOL HAS ^ FOLLOWING
	JRST	PT4A

;HERE WHEN FIRST OCCURENCE OF SYMBOL HAS ^ OR # FOLLOWING.
VARH:	TRNE	B,UDARF			;# OR ^ ?
	JRST	EXTH			;WAS ^
	PUSHJ	P,SCAN1A		;PASS THE #
	TRNE	B,SHRPF			;IS NEXT ANOTHER #?
	JRST	EXTH			;YES.  ## MEANS EXTERNAL
	TLO	N,VARF!UDSF!REFBIT	;SET # BIT. CONSIDER THIS TO BE A REFERENCE
	MOVEM	N,2(PN)			;& STORE
	SKIPN	XCRFSW
	JRST	VARH1			;NOT DOING CREF
	MOVEI	NA,2			;GIVE # TO CREF
	SKIPE	LISTSW
	IDPB	NA,CREFPT
VARH1:	GFST	NA,FSTPNT
	MOVEM	PN,(NA)
	MOVE	N,VARLST
	MOVEM	NA,VARLST
	EXCH	N,1(NA)
	MOVEM	N,FSTPNT
	SETZM	2(NA)			;ONE WORD
	HLLZ	NA,2(PN)		;GET FLAGS
	MOVE	N,PN			;VALUE IS POINTER
	POPJ	P,			;RETURN
;HERE WHEN SYMBOL NAME HAS BEEN SEEN BEFORE, AND THIS TIME HAS # OR ^ FOLLOWING.

EXHN:	PUSHJ	P,MAKEXT
	MOVEM	N,2(PN)
	JRST	PT3B

VRHN:	TLON	N,REFBIT
	MOVEM	N,2(PN)		;CONSIDER THIS IS A REFERENCE
	TRNE	B,UDARF
	JRST	EXHN
	PUSHJ	P,SCAN1A
	TRNE	B,SHRPF		;## SEEN?
	JRST	EXHN		;MEANS EXTERNAL
	SKIPN	XCRFSW
	JRST	VRHN1		;NOT DOING CREF
	MOVEI	NA,2
	SKIPE	LISTSW
	IDPB	NA,CREFPT
VRHN1:	TLNN	N,DEFFL
	JRST	PT3A		;ALREADY DEFINED, JUST LEAVE IT
	TLOE	N,UDSF!VARF	;TURN ON AND CHECK
	JRST	PT3P
	MOVEM	N,2(PN)		;SAVE FLAGS
	GFST	NA,FSTPNT	;GET FREE STORAGE
	MOVEM	PN,(NA)		;SAVE PNTR TO SYMBOL
	MOVE	N,VARLST
	MOVEM	NA,VARLST	;PUT ON VARIABLE LIST
	EXCH	N,1(NA)
	MOVEM	N,FSTPNT
	SETZM	2(NA)		;MARK AS ONE WORD VARIABLE
	SKIPA	N,2(PN)
PT3P:	MOVEM	N,2(PN)		;SAVE FLAGS
	JRST	PT3A
SPCCHK:	TLNN	NFLG		;NUMBER?
	TLNN	N,LBRF		;NO. LEFT BRACKET, OR "." OR "$." KLUDGE?
	POPJ	P,		;NO
	TLNN	SCFL
	JRST	(N)		;NOT  A SPECIAL CHAR; IT MUST BE "." "$."
					;ALSO .FNAM1,.FNAM2
	PUSH	P,EFSPNT
	MOVEM	FS,EFSPNT
	ADD	P,[XWD 12,12]
	JUMPGE	P,PDLOV
	MOVSI	TAC,PCNT	;PUSH PCNT & +1...
	HRRI	TAC,-11(P)	; OPCNT & +1...
	BLT	TAC,-4(P)	;& WRD & +1
	HRRZI	TAC,-3(P)
	BLT	TAC,(P)		;SAVE AC'S
	TLZ	MLFT		;...0 TO 3
	TRNN	N,TP1F		;[ OR <?
	JRST	IRBO		;BROKET
				;NO. SQUARE BRACKET - DO LITERALS
;HERE WE DO LITERALS
;LITNUL KNOWS WHAT'S PUSHED ON THE STACK!
	GFST	T,FSTPNT	;GET FREE STRG.
	SETZM	(T)		;ZERO COUNT
	GFST	(N,<1(T)>)	;GET NEXT
	MOVEM	N,2(T)		;DEPOSIT POINTER TO VALUE
	MOVEM	N,OPCNT		;SET CURRENT LOC. TO IN CORE &...
	MOVEM	N,PCNT		;HERE
	MOVSI	TAC,INCF	;AND TO "IN CORE"
	MOVEM	TAC,OPCNT+1	;...
	MOVEM	TAC,PCNT+1	;...
	SETZM	(N)		;ZERO REVERSE FIXUP POINTER FOR VALUE
	SETZM	2(N)		;NO FLAGS
	SETZM	3(N)		;NO BACK PNTR
	MOVE	TAC,1(N)	;GET POINTER TO REST OF FREE STRG
	MOVEM	TAC,FSTPNT	;& DEPOSIT
	SETZM	3(T)		;NO FIXUPS YET
	SETZM	4(T)		;...
	PUSH	P,LITFIL

NOTNX,<	PUSH	P,LITFIL+1
	PUSH	P,LITFIL+2	>;NOTNX

	PUSH	P,LITPG
	PUSH	P,LITLIN
	PUSH	P,LABLTP
	PUSH	P,LABLTC
	PUSH	P,N
	PUSH	P,T
	SETZM	LABLTP			;INIT FOR ANY LABELS...
	SETZM	LABLTC			;IN THIS LITTERAL
	SKIPN	T,TLBLK
	HRRO	T,INLINE
	MOVEM	T,LITLIN
	MOVE	T,PGNM
	MOVEM	T,LITPG

NOTNX,<	MOVE	T,[FILNM,,LITFIL]
	BLT	T,LITFIL+4		>;NOTNX

TNX,<	MOVE	T,JFNTBL		;JFN FOR CURRENT INPUT FILE
	MOVEM	T,LITFIL		>;TNX

TCALL:	ACALL			;CALL ASSEMBL
	SKIPN	WRD+1		;EMPTY?
	JRST	LEMP		;YES
	AOS	@(P)		;COUNT # OF WORDS IN LIT.
	AOS	LABLTC
LEMCON:	MOVE	N,-1(P)		;GET POINTER TO VALUE
	MOVE	TAC,WRD
	MOVEM	TAC,3(N)	;SET VALUE...
	MOVE	TAC,WRD+1
	MOVEM	TAC,4(N)	;...
	TRZE	TRBF		;TERM BY ]?
	JRST	ANOBR		;YES
	GFST	T,FSTPNT	;GET FREE STRG.
	MOVEM	T,1(N)		;POINT TO HERE
	MOVEM	N,3(T)		;POINT BACK
	MOVEM	T,PCNT		;SET LOC...
	MOVEM	T,OPCNT		;COUNTERS
	MOVE	N,1(T)		;GET REST OF FREE STRG.
	MOVEM	N,FSTPNT	;SET FSTPNT
	MOVEM	T,-1(P)		;SET NEW POINTER
	SETZM	(T)		;ZERO REVERSE FIXUP POINTER
	SETZM	2(T)		;NO FLAGS
	JRST	TCALL

ANOBR:	SETZM	1(N)		;ZERO VALUE POINTER(NO MORE)
	POP	P,NA
	MOVE	T,LABLTP
	HRLM	T,2(NA)		;STORE PNTR TO LABELS
	MOVE	T,(NA)		;INVENT A CONSTANT HASH FCN	FORMERLY: T,3(N)
	IDIVI	T,HASH
	MOVMS	FS
	MOVE	O,LITPNT(FS)
	MOVEM	NA,LITPNT(FS)
;	PUSHJ	P,LITCOM	;THIS MIGHT SAVE CORE, BUT IT WASTES LOTS OF TIME.
	MOVEM	O,1(NA)
	MOVE	PN,NA
LITNUL:	MOVE	T,NOTNX,<-13(P);> -11(P) ;GET OLD FLAGS
	TDZ	REFLAG
	AND	T,REFLAG
	OR	T		;RESTORE CERTAIN FLAGS
	TDZ	[XWD NFLG!SCFL!PSOPF!SOPF,TRBF]
	TLO	IFLG
	SUB	P,[1,,1]
	POP	P,LABLTC	;RESTORE OLD COUNT
	POP	P,LABLTP	;RESTORE OLD
	POP	P,LITLIN
	POP	P,LITPG

NOTNX,<	POP	P,LITFIL+2
	POP	P,LITFIL+1	>;NOTNX

	POP	P,LITFIL
	HRLZI	N,-2(P)
	ADDI	N,1
	BLT	N,3		;RESTORE AC'S
	MOVSI	N,-11(P)
	HRRI	N,PCNT
	BLT	N,PCNT+5	;RESTORE PCNT ETC.
	SUB	P,[XWD 12,12]
	PUSHJ	P,SCAN1		;GET A PEEK AT NEXT (FOR CALLER)
	TLO	SFL		;BUT ONLY A PEEK
	MOVSI	NA,DEFFL
	MOVE	N,PN		;MARK AS UNDEFINED LABEL
	POP	P,EFSPNT
	JUMPN	N,.+3
	MOVEI	NA,
	TLC	IFLG!NFLG	;JUST GIVE 0 IF NULL
	POPJ	P,

LEMP:	TRNN	TRBF		;TERM BY > OR ]?
	JRST	TCALL		;NO
	MOVE	T,-1(P)		;PNTR TO VAL
	MOVE	N,FSTPNT
	MOVEM	N,1(T)
	MOVEM	T,FSTPNT	;RETURN UNUSED BLK
	SKIPE	N,3(T)		;GET LAST PNTR
	JRST	ANOBR		;FINISH IT OFF
	ERROR	[ASCIZ/NULL LITERAL/]	;OOPS
	POP	P,PN
	MOVEM	T,1(PN)
	MOVEM	PN,FSTPNT	;RETURN HEADER
	MOVEI	PN,
	JRST	LITNUL
;PROCESS "PREDEFINED SYMBOLS"  $. . .FNAM1 .FNAM2

^SCAN.:	MOVE	N,DPCNT		;HERE FOR .
	MOVE	NA,DPCNT+1
	TLO	IFLG
	POPJ	P,

^SCAN$.:TLO	IFLG		;HERE FOR $.
	MOVE	N,OPCNT
	MOVE	NA,OPCNT+1
	TLNN	NA,INCF
	POPJ	P,		;NOT IN LIT - EASY
	GFST	PN,FSTPNT	;IN LIT - KLUDGE UP A PSEUDO LITLAB
	MOVEI	T,
	EXCH	T,1(PN)
	MOVEM	T,FSTPNT
	SETZM	(PN)		;THIS WILL DISTINGUISH IT
	SETZM	3(PN)
	SETZM	4(PN)
	MOVSI	T,DEFFL!UDSF
	PUSHJ	P,MAKLL
	MOVEI	N,(PN)
	MOVSI	NA,DEFFL!UDSF
	POPJ	P,

;THIS IS A LOW PRIORITY ITEM FOR TENEXIZING -- SO IT ISN'T
^%FNM1:					;.FNAM1
ITS,<	MOVE	N,SRCSTS+1 >		;ITS - GET FULL WORD FILE NAME
NOTNX,<NOITS,<	MOVE	N,LNAM	>>
TNX,<	MOVE	N,FILNM1	>
	MOVEI	NA,0			;NO RELOCATION
	TLO	IFLG			;IDENTIFIER
	POPJ	P,

^%FNM2:	
ITS,<	MOVE	N,SRCSTS+2 >
NOTNX,<NOITS,<	HLLZ	N,LNAM+1 >>
TNX,<	MOVE	N,FILNM2	>;TNX
	MOVEI	NA,0
	TLO	IFLG
	POPJ	P,

^%CPU:	JFCL	17,.+1			;.CPU. PSEUDO-MACRO.  CLEAR FLAGS
	MOVEI	N,1			;INITIAL ASSUMPTION (1=PDP6)
	JRST	.+1
	JFCL	1,%166			;166 PROCESSOR HAS PC CHANGE FLAG
	MOVNI	NA,1
	AOBJN	NA,.+1
	JUMPN	NA,%KA			;KA10 CARRIES ACROSS HALFWORDS
	MOVEI	NA,0
	BLT	NA,0
	JUMPE	NA,%KI			;KL10 ALWAYS UPDATES BLT POINTER
%KL:	ADDI	N,1			;KL = 4
%KI:	ADDI	N,1			;KI = 3
%KA:	ADDI	N,1			;KA = 2
%166:	MOVEI	NA,0			;166= 1.  SET RELOCATION TO ZERO
	TLO	IFLG			;SET IDENTIFIER SEEN
	POPJ	P,			;RETURN VALUE.

^%OSFAI:MOVE	N,[OSFAIL]
	MOVEI	NA,0
	TLO	IFLG			;IDENT SEEN.
	POPJ	P,
;COMPLEX ATOMS - EXPRESSIONS INSIDE BROKETS

^REFLAG:OPFLG!RELEF!MLFT!UNDF!ESPF!PAWF,,NOFXF!IOSW!ADFL!FLFXF

IRBO:	PUSH	P,[0]		;HERE TO DO COMPLEX ATOMS (BROKETED EXPRESSION)
	PUSH	P,[0]
DRIBL:	TRO	NOFXF		;NO FIXUPS
	ACALL
	TLNE	AUNDF
	ERROR	[ASCIZ /UNDEFINED WORD IN <>/]
	TRZN	TRBF		;WAS EXPRESSION TERMINATED BY ] OR >?
	JRST	NIRBO		;NO.  FLUSH UNTIL WE GET A BROKET
NEMP:	TLON	SFL		;HAVE WE SCANNED AHEAD?
	PUSHJ	P,SCAN		;NO, DO IT
	MOVE	T,-5(P)		;GET OLD FLAGS
	TDZ	0,REFLAG
	AND	T,REFLAG	;RESTORE APPROPRIATE FLAGS
	OR	0,T
	TDZ	0,[SOPF!SCFL!PSOPF!IFLG,,TRBF]
	TLO	0,NFLG
	MOVE	N,WRD
	MOVE	NA,WRD+1	;RETURN VALUE
	MOVSI	L,-4(P)
	ADDI	L,1
	BLT	L,3		;RESTORE AC'S
	MOVSI	L,-13(P)
	HRRI	L,PCNT
	BLT	L,PCNT+5	;RESTORE PCNT ETC.
	SUB	P,[XWD 14,14]
	POP	P,EFSPNT
	POPJ	P,


NIRBO:	MOVEI	N,-1(P)		;SAVE VALUE WE SCANNED.
	HRLI	N,WRD		;...
	BLT	N,(P)	
SLOP:	TRO	NOFXF		;NO FIXUPS
	ACALL			;READ STUFF AND THROW IT AWAY
	TRZN	TRBF		;TERM BY ] OR >?
	JRST	SLOP		;NO.  READ MORE AND THROW IT AWAY
	MOVSI	N,-1(P)		;PUT OLD VALUE...
	HRRI	N,WRD		;IN...
	BLT	N,WRD+1		;WRD
	JRST	NEMP
BEGIN INP 			;INP  USED BY SCAN TO GET NEXT BUFFER

IFN STANSW,<
^^TVFILE:0
TVMSK:	ASCII /________________00000______/
TVTXT:	ASCII /COMMENT    VALID 00000 PAGES/
LTVTXT__.-TVTXT
>;STANSW

^^INPOFS: 0			;USED WHEN SWITCHING TO CALCULATE OFFSET.
INTEM:	0
	0
RDDELF:	0

EOFPOP:	MOVEM	17,TSV+17
	MOVEI	17,TSV
	BLT	17,TSV+16

TNX,<	JSR	CLSSRC>

	MOVNI	7,FILSTL
	ADDB	7,FILSTP	;POP STACK
	SOS	FILSTC		;DECREMENT FILE-STACK DEPTH

NOTNX,<	MOVE	1,(7)		;DEVICE
	MOVE	5,1(7)		;FILE
	MOVE	3,2(7)		;EXT
	MOVE	4,4(7)		;PPN
	MOVEI	6,2		;IO CHANNEL NUMBER
	JSR	INITIT		;LOOKUP THE FILE 	>;NOTNX

TNX,<	MOVE	1,(7)
	MOVEM	1,JFNTBL	;JFN	>;TNX


	MOVE	1,NOTNX,<7(7);> 4(7)
	MOVEM	1,INPNTP	;POINTER TO FILE-INPNT (CURRENTLY THE BYTE-OFFSET)
	MOVE	1,NOTNX,<3(7);> 1(7)	;GET OLD-INPNT
	MOVEM	1,INPNT		;RESTORE OLD-INPNT (COULD BE THE BYTE-OFFSET THOUGH)
	MOVE	1,@INPNTP	;GET THE REAL BYTE-OFFSET
	MOVEM	1,BYPOFF#	;SAVE BYTE POINTER OFFSET
	MOVE	1,NOTNX,<5(7);> 2(7)	;GET RECORD NUMBER
	HLRZM	1,PGNM		;STORE FILE PAGE NUMBER
	MOVE	2,NOTNX,<6(7);> 3(7)
	HRRZM	2,INLINE

IFN STANSW,<	HLREM	2,TVFILE	;RESTORE TVFILE >;STANSW

NOTNX,<	USETI	2,(1)		;SET FOR CORRECT RECORD NUMBER
	MOVEM	1,IRECN		;SET RECORD NUMBER (AVOID INCREMENT LATER) >;NOTNX

TNX,<	HRRZM	1,IRECN
	JSR	XJFNS		;SEE INITIT
>;TNX
	
NOTNX,<	MOVEI	1,IBUFR1	;ADDRESS OF THE FIRST BUFFER
	TLO	1,400000
	MOVEM	1,IDB		;SET UP BUFFER	>;NOTNX

	MOVSI	17,TSV
	BLT	17,17
	JRST	NXTFL1		;PROCESS "NEXT FILE"

^NXTFL:	SETZM	BYPOFF		;BYTE POINTER OFFSET
	SKIPE	FILSTC		;ANYTHING ON THE FILE-STACK?
	JRST	EOFPOP		;YES.  PROCESS IT.
	JSR	EOF		;GET NEXT FILE IF ANY
	SETZM	PGNM
	AOS	PGNM
	SETZM	INLINE
NXTFL1:	SETZM	SPGNM
	SETZM	TLBLK		;FLUSH SOS LINE #
	SETZM	SVLNUM		;"
	TRNN	LDEV
	JRST	.+4
	MOVEI	TAC,14
	SKIPE	XPNDSW
	IDPB	TAC,LSTPNT
	PUSHJ	P,LSTFRC
	SKIPE	RDDELF
	IBP	LSTPNT		;NEED THIS BECAUSE NEXT CHR GETS STOWED WITH DPB
	SETZM	RDDELF
	SKIPE	BYPOFF		;ANY BYTE-POINTER OFFSET?
	JRST	INPX0		;YES. LET'S SKIP THIS.


^^TVSKIP:			;ROUTINE TO IDENTIFY TVEDIT FILES
	SETZM	RDDELF
	SETZM	BYPOFF

NOTNX,<	IN	2,		;READ FIRST REC
	AOSA	IRECN		;COUNT A RECORD READ
	JRST	INP0		;LOSE	>;NOTNX

TNX,<	SETZM	IRECN	
	JSR	TNXIN		>;TNX

IFN STANSW,<				;AT STANFORD, IDENTIFY TV FORMAT FILES
		SETZM	TVFILE		;FIRST ASSUME NON-TV
		MOVSI	B,-LTVTXT
		MOVSI	TAC,B
		ADD	TAC,INPNT
		IBP	TAC
TVSKP1:		MOVE	C,@TAC		;SEE IF THIS IS A DIRECTORY
		XOR	C,TVTXT(B)
		TDNN	C,TVMSK(B)
		AOBJN	B,TVSKP1
		JUMPL	B,INP0A
		SETOM	TVFILE		;REMEMBER THIS FOR EDITOR CALL >;STANSW

	JRST	INP0A

^^INP:	TDZA	B,B		;FLAG THAT THIS IS NOT A CALL VIA DELTAB
^INPDT:	MOVEI	B,1
	MOVEM	B,RDDELF	;SAVE FLAG
	AOS	IRECN		;INCREMENT RECORD NUMBER.
	SETZM	BYPOFF		;NO BYTE-POINTER OFFSET
INPX0:
NOTNX,<	INPUT	2,		>;NOTNX - GET NEXT BUFFERFUL
TNX,<	JSR	TNXIN		>;TNX

NOTNX,<
INP0:	STATZ	2,740000
	FATAL	[ASCIZ \FATAL I/O ERROR ON INPUT\]
	STATZ	2,20000
	JRST	NXTFL			>;NOTNX

INP0A:	MOVE	B,INPNT			;INPNT IS IDB+1
	IBP	B
	HRRZM	B,INPOFS		;STORE FIRST ADDRESS
	MOVE	B,IDB+2			;CHARATER COUNT
	MOVEM	B+1,INTEM		;B+1 IS ABOUT TO BE CLOBBERED
	ADDI	B,4			;ROUND UP TO MAKE A WORD COUNT
	IDIVI	B,5			;B_NUMBER OF WORDS IN BUFFER
	ADD	B,INPOFS		;ADDRESS OF END OF BUFFER
	MOVE	B+1,[BYTE(7)177,0]
	MOVEM	B+1,(B)			;STUFF 177 0 INTO END OF BUFFER.
IFE STANSW,<NOTNX,<NOITS,<
	SKIPN	INTTYF			;IS INPUT DEVICE A TTY?
	JRST	INP0A9			;NO. FORGET THIS
	MOVE	B,IDB+1			;GET THE BYTE POINTER
INP0A0:	ILDB	B+1,B			;GET A BYTE
	CAIE	B+1,"Z"-100
	JRST	INP0A1
	MOVEI	B+1,0			;LOOK THRU BUFFER FLUSHING ^Z.
	DPB	B+1,B
INP0A1:	CAIE	B+1,177			;177 MARKS END OF BUFFER
	JRST	INP0A0			;LOOP.
>;NOITS>;NOTNX  >;IFE STANSW

INP0A9:	MOVE	B+1,INTEM		;RESTORE B+1
	SKIPN	B,BYPOFF		;ANY BYTE-OFFSET?
	POPJ	P,
	ADD	B,INPOFS		;ADD FIRST ADDRESS TO THE OFFSET.
	PUSH	P,B			;B NOW CONTAINS THE FILE-INPNT
	MOVE	B,FILSTP		;GET FILE-STACK POINTER
	MOVE	B,NOTNX,<3(B);> 1(B)	;GET OLD-INPNT
	MOVEM	B,INPNT			;SAVE IT (IN CASE WE'RE IN A MACRO)
	POP	P,@INPNTP		;STORE NEW FILE-INPNT
	SETZM	BYPOFF			;DEPARTMENT OF REDUNDANCY DEPARTMENT
	POPJ	P,

TNX,<
;READ NEXT BUFFER FULL (GENERALLY A PMAP, WE HOPE)
TNXIN:	0
	TSVAC	<1,2,3>
	SKIPL	1,JFNTBL
	JRST	TNXIN2			;IF NOT A PMAPPABLE FILE
	HRRZS	1,1
	MOVE	2,[XWD 2,11]		;TWO WDS, FDBBYV,FDBSIZ
	MOVEI	3,2			;TO AC 2
	GTFDB
	LSH	2,-30			;JUSTIFY BYTE SIZE
	ANDI	2,77			;AND MASK OFF
	CAIE	2,7			;IS IT 7 BIT ASCII?
	IMULI	3,5			;MUST BE FULL WORDS...
	MOVE	2,IRECN
	IMULI	2,1000*5		;TOT BYTES NOT INCL THIS PAGE
	CAML	2,3
	JRST	NXTFL			;EOF
	ADDI	2,1000*5
	SUB	3,2			;SIZE-TOT BYTES TO END OF THIS PAGE
	SKIPL	3
	SETZ	3,			;EOF NOT ON THIS PAGE
	ADDI	3,1000*5
	MOVEM	3,INPNT+1		;CORRECT NUMBER OF BYTES (I HOPE)
	HRLS	1,1
	HRR	1,IRECN			;JFN,,PAGE
	MOVE	2,[XWD 400000,SRCBFP]	;THIS FORK, SOURCE BUFFER PAGE
	HRLZI	3,100400		;READ/CPY WRITE
	PMAP
TNXIN1:	MOVE	1,[POINT 7,SRCBF]
	MOVEM	1,INPNT			;SET POINTER
	TRSTAC	<1,2,3>
	JRST	@TNXIN

TNXIN2:	TLNE	1,200000		;TERMINAL BIT
	JRST	TNXIN3			;IS A TTY...SPEC EOF CONVENTION
	HRRZS	1,1			;CLEAR FLAGS
	MOVE	2,[POINT 36,SRCBF]
	MOVNI	3,1000
	SIN
	ADDI	3,1000			;FORM COUNT OF BYTES READ
	IMULI	3,5			;CONV TO 7 BIT BYTES
	JUMPE	3,NXTFL			;LOSE
	MOVEM	3,INPNT+1		;SET COUNTER
	SETZ	3,
REPEAT 5,<	IDPB	3,2		;SO THE BUFEND DETECTION WONT FUCK UP >
	JRST	TNXIN1

TNXIN3:	TLNE	1,100000		;OUR OWN EOF BIT
	JRST	NXTFL			;YEP....
	HRROI	1,SRCBF
	MOVEI	2,1000*5-1		;LV ROOM FOR LF
TNXI3A:	SETZ	3,
NOT20,<
	PSTIN				;HAD BETTER BE CONTROLLING TTY
>;NOT20
T20,<	HRLI	2,(1B0!1B3)		;BREAK ON CRLF, ESC, OR ^Z.
	RDTTY
	ERJMP	.+1
	HRRZ	2,2		;leave count only
>;T20
	LDB	3,1			;GET TERMINATOR
	CAIN	3,32			;CTRLZ FOR EOF?
	JRST	TNXI3B			;IF EOF...
T20,<	CAIN	3,12			;BREAK ON LF TOO 
	JRST	TNXI3D			;SPECIAL PLACE FOR LF >;T20
	CAIN	3,15			;IS IT CR?
	JRST	TNXI3C			;YES, CR
	JUMPG	2,TNXI3A		;ARB TERMINATOR, ROOM REMAINS
	MOVEI	3,1000*5-1
	MOVEM	3,INPNT+1		;UNLIKELY BUT BUFFER IS FULL
	JRST	TNXIN1
TNXI3B:	MOVEI	3,15			;CR
	DPB	3,1			;STORE OVER CTRLZ
	MOVE	3,JFNTBL
	TLO	3,100000		;EOF BIT
	MOVEM	3,JFNTBL
TNXI3C:	MOVEI	3,12			;LF
	IDPB	3,1			;STORE IT
	SOJ	2,			;AND ACCOUNT FOR IT
TNXI3D:	SUBI	2,1000*5-1
	MOVNS	2,2			;NUMBER OF BYTES READ
	MOVEM	2,INPNT+1
	SETZ	3,
REPEAT	5,<	IDPB	3,1		;SO BUF TERM TEST WONT FUCKUP >
	JRST	TNXIN1
>;TNX

BEND INP

BEND SCAN
SUBTTL REVAL  -- EVALUATES EXPRESION INTO LIST-POLISH
BEGIN REVAL
^REVAL:	MOVE O,FS	;INITIALIZE
	TLNE SCFL	;SPC CHR?
	JRST SPC1	;YES
REVAL1:	PUSH FS,N	;PUT NUM...
	PUSH FS,NA	;INTO STRG
	TLNN B,ARFL	;ARITH OP COMING UP?
	JRST NOA1	;NO
	TLZE B,UNOF
	CAIN C,"-"
	JRST .+2
	PUSHJ P,UOPERR
REVALU:	MOVE T,B	
	TLO T,SNB	;MARK AS OPERATOR
	PUSH FS,FS	;STORE POINTER TO NUM...
	PUSH FS,T	;WITH OPERATOR
	HRRZ O,FS	;SET "OLD OP" POINTER
LOOP2:	PUSHJ P,SCANS	;GET A PREVIEW
LOOP4:	TLNN B,ENMF	;NOT A NUM COMING?
	JRST SPC2	;NOT A NUM COMING
	PUSHJ P,SCANS	;GET NEXT NUM
LOOP4A:	HRRZ T,B	;ENTER HERE FROM SPC2B
	TLNN B,ARFL	;ARITH OP COMING?
	MOVEI T,16	;NO,SET LEVEL=16
LOOP3:	CAIGE T,@(O)	;COMPARE NEW OP LEVEL WITH OLD
	JRST NLOW	;NEW ONE LOWER
	PUSH FS,N	;PUT NUM...
	PUSH FS,NA	;IN STRG
	HRLM FS,-1(O)	;AND POINT OLD OP AT IT
LOOP1:	CAML T,-1(P)	;COMPARE NEW OP WITH LIMIT
	JRST NGL	;NEW GREATER OR EQUAL LIMIT
	MOVE T,B	;MARK NEW OP ...
	TLO T,SNB	;AS OPERATOR
	TLZE T,UNOF
	CAIN C,"-"
	JRST .+2
	PUSHJ P,UOPERR
	PUSH FS,O	;POINT TO OLD OP
	PUSH FS,T	;WITH NEW
	HRRZ O,FS	;SET "OLD OP"
	JRST LOOP2

NGL:	MOVEM O,-1(P)	;RETURN "OLD OP"
	POPJ P,

NLOW:	PUSH P,O	;SAVE "OLD OP"
	MOVEI O,@(O)	;GET LEVEL OF OLD OP
	PUSH P,O	;USE AS LIMIT
	PUSHJ P,REVAL	;CALL REVAL
	MOVE O,-1(P)	;GET OD OP POINTER
	EXCH T,(P)	;GET RETURNED VALUE
	HRLM T,-1(O)	;POINT OLD OP AT IT
	POP P,T		;RESTORE T
	SUB P,[XWD 1,1]	;POP
	JRST LOOP1

UOPERR:	ERROR	[ASCIZ/UNARY OPERATOR ILLEGAL AFTER AN EXPRESSION/]
	TRO	POLERF
	MOVEI	C,"+"	;CHANGE TO A BINARY OPERATOR
	MOVE	B,[SNB!SPCLF!ARFL,,12]
	MOVE	T,B
	POPJ	P,
SPC2:	TLNE B,UNOF	;UNARY OPERATOR?
	JRST UNAR	;YES
	TRNE B,LFPF	;(?
	JRST LFTP
	TRNE B,UDARF	;POSSIBLE UPARROW?
	TRNN B,TP2F	;DEFINITE UPARROW?
	JRST SPC2A	;NOT UPARROW
	TLZ SFL		;SKIP THE ^
	PUSHJ P,DSCANS	;TRY TO READ DECIMAL (OR WHATEVER) NUMBER
	TLNE NFLG	;GOT A NUMBER?
	JRST LOOP4A	;YES.  USE IT.
SPC2A:	TRO POLERF	;SET ERROR FLAG
	ERROR [ASCIZ/ILLEGAL CHR AFTER OPERATOR/]
	JRST NGL	;RETURN

UNAR:	HRRI B,2	;MARK AS UNARY
	PUSH P,O	;SAVE OLD OP PNT
	MOVEI O,@(O)	;GET LEVEL OF OLD OP
	PUSH P,O	;USE AS LIMIT IN CALL
	PUSHJ P,REVALU	;CALL REVAL(OTHER ENTRANCE)
OLF:	MOVE O,-1(P)	;GET OLD OP
	EXCH T,(P)	;GET RETURNED VALUE
	HRLM T,-1(O)	;PNT OLD OP AT IT
	POP P,T		;RESTORE T
	SUB P,[XWD 1,1];POP
	JRST LOOP1

LFTP:	TLZ SFL		;IGNORE PAREN
	PUSHJ P,SCANS	;GET NEXT
	PUSH P,O	;SAVE O
	PUSH P,[16]	;SET LIMIT =16
	PUSHJ P,REVAL	;CALL REVAL
	MOVE O,-1(P)	;GET OLD OP
	EXCH T,(P)	;GET RETURNED VALUE
	HRLM T,-1(O)	;PNT OLD OP AT IT
	POP P,T		;RESTORE T
	SUB P,[XWD 1,1]
	TRNN B,RTPF	;RIGHT PAREN LAST THING?
	JRST NRP	;NO
	PUSHJ P,SCANS	;GET THE RIGHT PAREN FF.
	TLNN B,ARFL	;ARITH OP NEXT?
	JRST NGL	;NO
	HRRZ T,B	;YES, SET T ...
	CAIL T,@(O)	;COMPARE LEVEL
	JRST LOOP1	;AND PROCEED
	MOVE T,B
	TLO T,SNB
	TLZE T,UNOF
	CAIN C,"-"
	JRST .+2
	PUSHJ P,UOPERR
	PUSH P,O	;SAVE OLD OP
	HLRZ O,-1(O)	;GET RETURNED VALUE BACK
	PUSH FS,O	;POINT NEW OP AT IT
	PUSH FS,T	;PUSH OP
	HRRZ O,FS	;SET OLD OP
	HRRZ T,@(P)	;GET LEVEL
	PUSH P,T
	PUSHJ P,LOOP2
	JRST OLF

NRP:	TLON REUNBF	;SET UNBAL FLAG
	ERROR [ASCIZ/UNBAL PARENS/]
	TRO POLERF	;SET ERROR FLAG
	JRST NGL	;RETURN
SPC1:	TLNE N,UNOF	;UNARY OPERATOR?
	JRST UNAR1	;YES
	TRNE N,LFPF	;(?
	JRST LFTP1	;YES
	TRNE N,UDARF	;POSSIBLE UPARROW?
	TRNN N,TP2F	;YES.  IS IT REALLY UPARROW?
	JRST SPC1A	;NOT UPARROW
	PUSHJ P,DSCANS	;TRY TO FIND A NUMBER
	TLNE NFLG	;GOT A NUMBER?
	JRST REVAL1	;YES!
SPC1A:	ERROR[ASCIZ/ILLEGAL CHR STARTS EXPRESSION/]
	TRO POLERF	;SET ERROR FLAG
	MOVEI T,16
	JRST NGL

UNAR1:	PUSH FS,FS	;PUSH ANY OLD THING
	HLLZ T,N
	OR T,[XWD SNB,2];MARK AS UNARY OP
	PUSH FS,T
	HRRZ O,FS
	JRST LOOP4

LFTP1:	PUSHJ P,SCANS	;GET
^LFTP2:	PUSH P,[16]	;SET LIMIT=16
	PUSHJ P,REVAL	;GET VALUE
	POP P,O	;GET VALUE
	TRNN B,RTPF	;)?
	JRST NRP	;NO
	PUSHJ P,SCANS	;GET PAST THE )
	TLNE B,ARFL	;ARITH OP NEXT?
	JRST PARAR	;YES
	TLO O,SNB	;MARK VALUE AS "PARENS AROUND WHOLE"
	MOVEM O,-1(P)	;RETURN
	POPJ P,

^PARAR:	PUSH FS,O	;POINT TO VALUE...
	MOVE T,B	;...
	TLO T,SNB	;...
	TLZE T,UNOF
	CAIN C,"-"
	JRST .+2
	PUSHJ P,UOPERR
	PUSH FS,T	;FROM CURRENT OP
	HRRZ O,FS	;SET OLD OP
	JRST LOOP2

NOA1:	HRRZM FS,-1(P)	;RETURN OPERAND
	MOVEI T,16	;SET LEVEL=16
	POPJ P,		;RETURN

BEND
SUBTTL	REDUC -- REDUCES THE LIST STRUCTURE POLISH POINTED TO BY FS

BEGIN REDUC
^REDUC:	SKIPL (FS)	;SINGLE OPERAND?
	POPJ P,		;YES
	PUSH P,FS	;SAVE POINTER
	MOVE O,(FS)	;GET BITS
	TLNE O,UNOF	;UNARY OP?
	JRST PT1	;YES
	MOVE FS,-1(FS)	;GET POINTER TO FIRST OPERAND
	SKIPGE (FS)	;OPERATOR OR OPERAND?
	PUSHJ P,REDUC	;OPERATOR, REDUCE
PT1:	MOVE FS,(P)	;GET POINTER
	MOVS FS,-1(FS)	;GET POINTER TO SECOND OPERAND
	SKIPGE (FS)	;OPERATOR?
	PUSHJ P,REDUC	;YES, REDUCE
	MOVE FS,(P)	;GET POINTER
	MOVE O,(FS)	;GET BITS
	TLNE O,UNOF	;UNARY OP?
	JRST PT2	;YES
	MOVE O,-1(FS)	;GET PNTR TO FIRST OP
	SKIPGE FS,(O)	;OPERAND?
	JRST CPOP	;NO, CAN'T REDUCE
	TLNE FS,DEFFL	;DEFINED?
	JRST CPOP	;NO, CAN'T REDUCE
PT2:	MOVE FS,(P)	;GET PNTR.
	MOVS FS,-1(FS)	;GET PNTR TO SECOND OP
	SKIPGE T,(FS)	;OPERAND?
	JRST CPOP	;NO, CAN'T REDUCE
	TLNE T,DEFFL	;DEFINED?
	JRST CPOP	;NO, CAN'T REDUCE
	MOVE T,(P)		;GET POINTER
	MOVE T,(T)		;GET OPERATION
	DPB T,[POINT 5,T,4]	;TACK ARMD & ARMD1 ...
	LDB T,[POINT 7,T,6]	;ONTO LEVEL
	HRRZ T,OPTB1-10(T)	;GET DISPATCH ADDRESS
	JUMPN T,(T)		;DO IT.
	ERROR [ASCIZ/UNKNOWN ILLEGAL OPERATOR IN POLISH REDUCTION/]
	SETZB O,T		;SET VALUES TO ZERO AND FALL INTO RRETT
RRETT:	POP P,FS	;GET POINTER
	MOVEM T,-1(FS)	;DEPOSIT VALUE
	MOVEM O,(FS)	;DEPOSIT BITS
	POPJ P,		;RETURN

CPOP:	POP P,O
	POPJ P,

DEFINE AROP(BOP,SPC1,SPC2,BTOP,MGNM,Q)
<	MOVE T,-1(O)	;GET SECOND OP
	SPC1
	BOP T,-1(FS)	;BOP FIRST OP
	SPC2
	MOVE O,(O)	;GET BITS FOR SECOND OP
	BTOP O,(FS)	;BTOP BITS FOR FIRST
	TRNE O,MGNM	;LEGAL RELOC?
	JRST CPOP	;NO
Q	DPB O,[POINT 4,(FS),35]
Q	MOVE O,(FS)	;GET NEW BITS
	JRST RRETT
>

;HERE ARE THE ROUTINES FOR THE REDUCTION OF POLISH EXPRESSIONS BY THE ASSEMBLER
TM:	0		;TEMP CELL FOR ROUTINES BELOW

ADOP:	AROP(ADD,,,ADD,12)
SBOP:	AROP(SUB,,,SUB,12)
MULOP:	AROP(IMUL,,,OR,17,<;>)
DIVOP:	AROP(IDIV,<MOVEM FS,TM>,<MOVE FS,TM>,OR,17,<;>)
ANOP:	AROP(AND,,,OR,17,<;>)
OROP:	AROP(OR,,,OR,17,<;>)
XROP:	AROP(XOR,,,OR,17,<;>)
LSHF:	AROP(LSH @ ,<HRRZS -1(FS)>,,OR,17,<;>)

REMOP:	MOVE	T,-1(O)		;GET SECOND OP
	MOVEM	FS,TM
	IDIV	T,-1(FS)	;DIVIDE BY FIRST OP
	MOVE	T,FS		;GET RESULT INTO T
	MOVE	FS,TM		;RESTORE FS
	MOVE	O,(O)		;GET BITS FOR SECOND OP
	OR	O,(FS)		;OR BITS FOR FIRST
	JRST	UNMIN2		;CHECK FOR LEGAL RELOC

UNMIN:	MOVN	T,-1(FS)	;NEGATE NUM
UNMIN1:	MOVE	O,(FS)		;GET BITS
UNMIN2:	TRNE	O,17		;RELOC LEGAL?
	JRST	CPOP		;NO
	JRST	RRETT

UNABS:	MOVM	T,-1(FS)	;ABSOLUTE VALUE
	JRST	UNMIN1

UNNOT:	SETCM	T,-1(FS)	;INVERT NUM
	JRST	UNMIN1		;CHECK FOR LEGAL RELOC

JFFOOP:	MOVE	T,-1(FS)	;GET OPERAND
	MOVEM	FS,TM		;SAVE T+1
	JFFO	T,.+2		;SET FS AND JUMP
	MOVEI	FS,44		;T WAS ZERO.  DESIRED RESULT IS 44
	MOVE	T,FS		;RESULT IN T
	MOVE	FS,TM		;RESTORE FS
	JRST	UNMIN1		;MAKE SURE WE HAVE NO RELOC PROBLEMS

;DISPATCH TABLE FOR POLISH OPERATORS.
;RH IS ADDRESS FOR REDUCTION.
;LH IS CORRESPONDING OPERATOR FOR THE LOADER (SHIFTED BY 6) USED BY LABINS&POLOUT

^^OPTB1:1300,,UNNOT		;10  NOT  (^E)
	1500,,JFFOOP		;11 
	1400,,UNMIN		;12 UNARY -
	1700,,UNABS		;13 ABSOLUTE VALUE
	0
	0
	0
	0
	1100,,LSHF		;20 
	0
	0
	0
	0
	0
	0
	0
	1000,,OROP		;30 
	1200,,XROP		;31 XOR
	 700,,ANOP		;32 
	0
	0
	0
	0
	0
	 500,,MULOP		;40 *
	0
	 600,,DIVOP		;42 /
	1600,,REMOP		;43 
	0
	0
	0
	0
	 300,,ADOP		;50 +
	0
	 400,,SBOP		;52 BINARY -

BEND
SUBTTL MEVAL -- MAIN EVALUATER  -------

;MEVAL -- EVALUATES AN ADDRESS FIELD EXPRESSION & GENERATES
;FIXUPS.   RETURNS OPCODES UNTOUCHED.
;IF MLFT IS ON, GENERATES LEFT HALF FIXUPS INSTEAD OF RIGHT.

BEGIN MEVAL
^MEVAL:	TLZ SOPF!PSOPF!PAWF!ESPF!UNDF
	MOVE FS,EFSPNT
	PUSHJ P,SCANS 	;GET THING
	TLNE SCFL	;SPEC. CHR?
	JRST MSPEC	;YES
	TLNE NFLG	;NUM?
	JRST MNUM	;YES
	TRNE B,LACF	;TERM BY _ OR :?
	JRST DEFN	;YES
	TLNE SOPF	;OPCODE?
	TLOA OPFLG
MNUM:	TLOA OPFLG	;STOP OPCODE LOOKUP
	POPJ P,
	TLNE B,ARFL	;ARITH OP NEXT?
	JRST NONSIM	;YES
	TLNN NA,DEFFL	;DEFINED?
	POPJ P,		;YES
	TLO UNDF	;NO, SET BIT
	TRNE NOFXF	;GENERATE FIXUPS?
	POPJ P,		;NO
	MOVE T,OPCNT+1	;GET CURRENT OUTPUT LOC. COUNTER BITS
	TLNE T,INCF	;IN CORE?
	JRST NOTHER	;YES
	SKIPN O,3(PN)	;GET FIXUP POINTER
	JRST NOTHER	;NONE
LOOP1:	SKIPN (O)	;ZERO DEVIATION?
	JRST FND1	;YES, FOUND
LOOP2:	SKIPE O,1(O)	;END OF CHAIN?
	JRST LOOP1	;NO
NOTHER:	GFST O,FSTPNT	;GET SOME FREE STRG
	SETZM (O)	;ZERO DEVIATION
LOOP4:	MOVEM T,4(O)	;DEPOSIT CURRENT LOCAT. CNT.FLAGS
	MOVE TAC,OPCNT	;GET CURRENT LOC. CNT.
	MOVEM TAC,3(O)	;DEPOSIT
	SETZM 2(O)	;MAKE FLAGS
	TLNE MLFT	;LEFT HALF?
	JRST	[AOS 2(O)	;YES SET BIT
		TLNE T,INCF	;IN CORE?
		MOVEM O,2(TAC)	;YES
		JRST SARND]
	TLNE T,INCF	;IN CORE?
	MOVEM O,(TAC)	;YES, SET REVERSE FIXUP PNTR.
	MOVEI T,2
	TRNE FLFXF	;FULL WORD FIXUPS?
	ORM T,2(O)	;YES, MARK
SARND:	MOVE T,3(PN)	;FIXUP PNTR.
	EXCH T,1(O)	;PUT NEW THINGS...
	MOVEM O,3(PN)	;INTO CHAIN
	MOVEM T,FSTPNT	;ADVANCE FREE STRG PNTR.
	SETZB N,NA	;VALUE IS 0
	HRRZS O
	POPJ P,

FND1:	MOVE TAC,4(O)	;GET NUM FLAGS
	TLNE TAC,INCF	;IN CORE?
	JRST LOOP2	;YES
	MOVE TAC,2(O)	;GET FLAGS
	TLNN MLFT	;LEFT HALF NOW?
	TRCN TAC,1	;IS THIS LEFT HALF?
	TRNN TAC,1	;OR THIS?
	JRST LOOP2	;NO MATCH
	TRNN FLFXF	;FULL WORD NOW?
	TRCN TAC,2	;IS THIS FULL WORD?
	TRNN TAC,2	;OR THIS?
	JRST LOOP2	;NO MATCH
FND1A:	MOVE N,OPCNT	;GET NEW VALUE AND SWITCH WITH OLD.
	MOVE NA,OPCNT+1	;FOR SIMPLE FIXUP, VALUE RETURNED IS LOCATION OF
	EXCH N,3(O)		;THE  PREVIOUS REFERENCE.
	EXCH NA,4(O)		;NEW VALUE IS LOC. CNTR.
	HRRZS O
	POPJ P,
NONSIM:	TLZ RELEF!REUNBF	;CLEAR FLAGS
	TLO OPFLG	;INHIBIT OPCODE LOOKUP
	MOVE FS,EFSPNT
NONSM2_.+2		;RET FROM REVAL
	RVALUA
	PUSHJ P,REDUC	;REDUCE TO VALUE IF POS.
	TLNE RELEF	;RELOC ERROR?
	ERROR [ASCIZ/RELOCATION ERROR/]
	POP P,FS	;GET POINTER TO POLISH
	SKIPGE FS	;PARENS AROUND WHOLE?
	TLO PAWF	;YES
	SKIPGE O,(FS)	;DEFINED?
	JRST NOTDF	;NO
	MOVE N,-1(FS)	;GET VALUE...
	MOVE NA,O	;AND VALUE FLAGS
	TLNE NA,DEFFL	;MAKE SURE UNDEF HAS BEEN SET RIGHT
	TLO UNDF
	POPJ P,

NOTDF:	TLO UNDF	;UNDEF.
	TRNE NOFXF	;GENERATE NO FIXUPS?
	POPJ P,		;NO
	HRRZ T,O	;GET LEVEL
	CAIE T,12	;+ OR -?
	JRST POLFIX	;NO
	MOVE PN,-1(FS)	;GET POINTER TO RIGHT ARG.
	MOVS T,PN	;GET POINTER TO LEFT ARG.
	SKIPGE N,(PN)	;GET RIGHT ARG -- OPERAND?
	JRST POLFIX	;NO
	SKIPGE NA,(T)	;GET LEFT ARG. -- OPERAND?
	JRST POLFIX	;NO
	TLNN NA,DEFFL	;LEFT ARG DEFINED?
	JRST OK1	;YES
	TLNE N,DEFFL	;RIGHT ARG DEFINED?
	JRST POLFIX	;NO
	TLNE O,ARMD	;+ OR -?
	JRST POLFIX	;-
	EXCH PN,T
	EXCH NA,N	;SWITCH ARGS
OK1:	TRNE NA,17	;ANY RELOC ON LEFT ARG?
	JRST POLFIX	;YES
	TLNN O,ARMD	;-?
	SKIPA NA,-1(T)	;NO, GET VALUE
	MOVN NA,-1(T)	;YES, GET NEGATIVE VALUE
	MOVE PN,-1(PN)	;GET SYMBOL TABLE POINTER
^CCFIX:	MOVE T,OPCNT+1	;GET FLAGS
	TLNE T,INCF	;IN CORE?
	JRST NOF	;YES
	SKIPN O,3(PN)	;GET FIXUP CHAIN
	JRST NOF	;NONE
SRC:	SRC1(NA,O,FND2,JRST NOF)
^DBLUP:	0
FND2:	MOVE TAC,4(O)	;GET NUM FLAGS
	TLNE TAC,INCF	;IN CORE?
	JRST SRC+2	;YES
	MOVE TAC,2(O)	;GET FLAGS
	TLNN MLFT	;LEFT HALF NOW?
	TRCN TAC,1	;IS THIS LEFT HALF?
	TRNN TAC,1	;OR THIS?
	JRST SRC+2	;NO MATCH, CONTINUE SEARCH
	TRNN FLFXF	;FULL WORD NOW?
	TRCN TAC,2	;IS THIS FULL WORD?
	TRNN TAC,2	;OR THIS?
	JRST SRC+2	;NO MATCH
	JRST FND1A
NOF:	GFST O,FSTPNT	;GET SOME FREE STRG.
	MOVEM NA,(O)	;STORE DEVIATION
	JRST LOOP4

MSPEC:	TDNN	N,[XWD UNOF,LFPF!UDARF]	;( OR UP/DOWN arrow OR UNARY OP?
	JRST	[TLO OPFLG!ESPF
		POPJ P,]
	TRNE	N,LFPF
	JRST	IXTST		;( SEE IF INDEX
	TLNE	N,UNOF
	JRST	NONSIM		;UNARY OP
	SETZM	DBLUP		;NO DOUBLE UP ARROW YET.
	PUSH	P,		;SAVE FLAGS
	PUSH	P,N		;SAVE UP/DOWN
	TLO	OPFLG		;INHIBIT OPCODE SEARCH
	TRNN	N,TP1F		;UP OR DOWN?
	JRST	MSPE2		;UP ARROW SEEN
MSPE1:	PUSHJ	P,SCANS		;GET IDENTIFIER
	TLNE	IFLG		;IDENT SEEN?
	TRNN	B,LACF		;YES.  WAS : or = SEEN NEXT?
	JRST	ERR1		;NO IDENT OR IMPROPER TERMINATION
	MOVEM	L,LSTLAB+2	;SAVE SIXBIT OF LAST NAME DEFINED
	POP	P,L		;GET UP/DOWN FLAG
	ANDI	L,TP1F!TP2F	;SET UP/DOWN ONLY
	TRNE	B,TP1F		;= OR : NEXT?
	JRST	LADF		;= NEXT
	JRST	PTQ1		;: NEXT

MSPE2:	PUSHJ	P,DSCANS	;GET IDENT - POSSIBLE NUMBER HERE (^D69)
	TLNN	IFLG		;IDENT?
	JRST	[TLNE	NFLG	;POSSIBLE NUMBER?
		JRST	[SUB P,[2,,2]
			JRST MNUM]	;TREAT AS NUMBER
		TRNN	N,TP2F	;ANOTHER ^
		JRST	ERR1	;NO -- LOSE
		SETOM	DBLUP	;SET ^^FLAG
		JRST	MSPE1]	;GOBBLE ORDINARY IDENT NEXT
	TRNN	B,LACF		;: OR _ NEXT?
	JRST	ERR1		;NO - ERROR
	MOVEM	L,LSTLAB+2	;SAVE SIXBIT
	POP	P,L
	MOVEI	L,TP2F		;SET UPARROW
	TRNE	B,TP1F		;_ OR :?
	JRST	LADF		;_
PTQ1:	MOVE	NA,PCNT+1	;GET LOCATION FLAGS
	TLNE	NA,INCF		;IN CORE?
	JRST	PTQ2		;AVOID CONFUSION CAUSED BY LABELS IN LITERALS
	MOVE	N,LSTLAB+2	;SET UP LABEL NAME
	MOVEM	N,LSTLAB
	MOVE	N,LSTLAB+3	;AND BLOCK NAME
	MOVEM	N,LSTLAB+1	;FOR ERROR MESSAGE PRINTER
	MOVE	N,PCNT		;GET CURRENT LOC...
	MOVEM	N,LSTLAB+4	;DEPOSIT FOR ERROR PRINT
PTQ2:	MOVE	N,PCNT		;(NECESSARY IF WE TAKE THE SHORT CUT)
	EXCH	L,(P)		;GET OLD FLAGS, SAVE LABINS FLAGS
	ANDCA	L,[XWD OPFLG,0]	;CLEAR ALL BUT OPFLG
	ANDCM	L		;TURN OFF OPFLG IF IT WAS OFF
	PUSHJ	P,SCAN1A	;LOOK FOR ANOTHER :
	POP	P,L		;GET BACK FLAGS FOR LABINS
	TLO	L,COLONF	;MARK : TYPE
	TRNN	B,LACF		;ANOTHER :?
	JRST	.+3		;NO
	TLZ	SFL		;SKIP SECOND :
	TLO	L,DBLF		;MARK __ TYPE (::)
	PUSHJ	P,LABINS	;INSERT (DEFINE) LABEL
	SETZM	DBLUP		;FLUSH ARROWS THAT ARE LURKING
	SKIPE	XCRFSW		;CREF?
	SKIPN	LISTSW		;YES. AND LISTING?
	JRST	MEVAL		;NO.
	MOVEI	N,2		;YES
	IDPB	N,CREFPT
	JRST	MEVAL


ERR1:	SUB	P,[1,,1]
	ERROR	[ASCIZ/NO IDENT OR NO : OR _ AFTER UP-ARROW OR DOWN-ARROW/]
	POP	P,N
	ANDCA	N,[XWD OPFLG,0]	;GETSTORE ...
	ANDCM	N		;OLD OPFLG
	JRST	MEVAL
;HERE WHEN = OR : SEEN FOLLOWING A SYMBOL NAME
DEFN:	PUSH	P,			;SAVE OLD FLAGS
	TLO	OPFLG		;INHIBIT OPCODE LOOKUP
	TLNE	SOPF		;FOUND AS OPCODE?
	PUSHJ	P,RESCN		;YES , FIND AS LABEL
	MOVEM	L,LSTLAB+2	;SAVE SIXBIT
	MOVEI	L,		;NO FLAGS (NO ^ OR DOWN-ARROW)
	TRNN	B,TP1F		;_ OR :?
	JRST	PTQ1		;:
LADF:	MOVEI	O,0			;INITIALIZE COUNT
LLOP:	SKIPE	XCRFSW			;CREF IN PROGRESS NOW?
	JRST	[MOVEI	TAC,7		;YES DELETE PREVIOUS SYMBOL OUTPUT
		SKIPE	LISTSW		;LISTING IN PROGRESS NOW?
		IDPB	TAC,CREFPT	;YES.
		JRST	.+1]
	SKIPE	DBLUP			;^^ SEEN?
	TLO	L,DBLUPF		;YES.  MARK IT
	SETZM	DBLUP			;CLEAR CORE FLAG
	PUSH	P,PN			;SAVE POINTER INTO SYMTAB
	PUSH	P,L			;SAVE FLAGS
	ADDI	O,1			;COUNT
	TLZ	SFL			;SKIP THE _
	CAIN	C,"="			;WAS CHAR REALLY =?
	JRST	EQLDEF			; = SEEN.  CHECK FOR ==
LLOP1:	PUSHJ	P,SCANS			;GET NEXT
	TLNE	SCFL			;SPC CHR?
	JRST	SCHAN			;YES
	TLNN	IFLG			;IDENT?
	JRST	LNMM			;NO, MUST BE A NUM.
	TRNN	B,LACF			;_ OR : NEXT?
	JRST	LNMM			;NO. MUST BE THE VALUE TO ASSIGN
	MOVEI	L,0			;YES
	JRST	LLOP

SCHAN:	TRNN	N,LACF			;_ OR : NEXT?
	JRST	SCNT			;NO
	TRNN	N,TP1F			;SKIP IF _ NEXT
	SKIPA	N,[INTF,,0]		;WAS :  MUST BE =: OR ==:
SCHLA:	MOVSI	N,DBLF			;SET __
	ORM	N,(P)			;SET FLAG (EITHER DBLF OR INTF)
	JRST	LLOP1

SCNT:	TRNN	N,UDARF			;^ OR DOWN-ARROW?
	JRST	LNMM			;NO
	PUSH	P,N			;SAVE CHR.
	TRNN	N,TP1F		;UP OR DOWN?
	JRST	SCNT2		;UPARROW
SCNT1:	PUSHJ	P,SCANS		;GET IDENTIFIER
	TLNE	IFLG		;IDENT SEEN?
	TRNN	B,LACF		;YES, AND : OR = NEXT?
	JRST	ERR2		;NO TO ONE OF ABOVE
	POP	P,L
	ANDI	L,TP1F!TP2F	;MASK OUT IRRELEVANCIES
	JRST	LLOP		;DO REST

SCNT2:	PUSHJ	P,DSCANS	;GET IDENT (POSSIBLE NUMBER: ^D69)
	TLNE	NFLG		;POSSIBLE NUMBER.
	JRST	[SUB	P,[1,,1]
		JRST	LNMM]		;HANDLE AS A NUMBER
	TLNN	IFLG			;IDENT SEEN NEXT?
	JRST	[TRNN	N,TP2F		;ANOTHER ^ NEXT?
		JRST	ERR2		;NO.  AN ERROR.
		SETOM	DBLUP		;MARK CORE FLAG FOR ^^
		JRST	SCNT1]		;FIND IDENT
	TRNN	B,LACF			;: OR _ NEXT?
	JRST	ERR2			;NOPE, LOSE
	POP	P,L			;GET CHARACTER BACK
	ANDI	L,TP1F!TP2F		;CLEAR REST
	JRST	LLOP

ERR2:	SUB	P,[1,,1]
	ERROR	[ASCIZ/NO IDENT OR NO _ AFTER UP-ARROW OR DOWN-ARROW/]
	TLNN	B,CRFG			;CR NEXT?
	JRST	LLOP1			;NO. TRY AGAIN
	TLO	SFL			;SET SCAN AHEAD (AVOID ERRORS ABOUT COMMENTS
	SETZB	N,NA
	JRST	LLOP2			;"DEFINE" THE SYMBOLS WE'VE SEEN.

EQLDEF:	PUSHJ	P,SCAN1			;KLUDGE TO MAKE == WORK
	CAIN	C,"="
	JRST	SCHLA			;IF VERY NEXT CHAR IS =, TREAT IT AS _
	TLO	SFL			;OTHERWISE REPROCESS IT NORMALLY
	JRST	LLOP1
LNMM:	PUSH P,O	;SAVE COUNT
	MOVE FS,EFSPNT
	TLZ RELEF!REUNBF	;CLEAR FLAGS
	RVALUA
	PUSHJ P,REDUC	;REDUCE TO VALUE
	POP P,FS	;GET POINTER
	TLNE RELEF	;RELOC ERROR?
	ERROR[ASCIZ/RELOCATION ERROR/]
	SKIPGE NA,(FS)	;DEFINED?
	JRST [	ERROR[ASCIZ/UNDEFINED VALUE AFTER_/]
		MOVEI NA,;THIS IS TO FIX MYSTERIOUS BUG
		JRST .+1]
	TLZE NA,DEFFL	;DEFINED?
	JRST .-2	;NO , ERROR
	MOVE N,-1(FS)	;GET VALUE
	POP P,O		;GET COUNT
LLOP2:	POP P,L		;GET FLAGS
	POP P,PN	;GET POINTER
	SKIPE XCRFSW
	CREF6 1,(PN)
	PUSHJ P,LABINS	;INSERT DEFINITION
	SKIPE XCRFSW
	JRST	[MOVEI L,2
		SKIPE LISTSW
		IDPB L,CREFPT
		JRST .+1]
	SOJG O,LLOP2	;COUNT, DONE?
	EXCH N,WRD
	EXCH NA,WRD+1
	PUSHJ P,LBLOUT	;LIST VALUE
	MOVEM N,WRD
	MOVEM NA,WRD+1
	POP P,N		;YES, RESTORE OPFLG ...
	ANDCA N,[XWD OPFLG,0]	;...
	ANDCM	N	;...
	SETZM	DBLUP		;FLUSH ARROWS THAT ARE LURKING
	JRST MEVAL
;SAW ( CHECK FOR INDEX CONSTRUCT & GET OUT QUICKLY IF SO
IXTST:	TLO OPFLG
	PUSHJ P,SCANS	;SEE WHAT FOLLOWS
	TRNE B,RTPF
	TLNE SCFL
	JRST IXTST2	;SPEC CHR AFTER ( OR NOT ) AFTER THAT
	PUSHJ P,SCAN1A
	TLNE B,ARFL
	JRST IXTST3	;ARITH OP AFTER )
	TLO PAWF	;HURRAY, IT'S AN INDEX
	TLNE B,SPFL
	JSR SPCSKP	;MAKE SURE WE'RE PAST BLANK
	TLNE NA,DEFFL
	TLO UNDF
	POPJ P,		;SEE HOW EASY THAT WAS

;HERE WE SIMULATE HAVING GOTTEN THIS FAR INTO REVAL
IXTST2:	TLZ RELEF!REUNBF
	MOVE FS,EFSPNT
	PUSH P,[16]
	PUSHJ P,LFTP2
	JRST NONSM2

;HERE WE SIMULATE HAVING GOTTEN EVEN FARTHER INTO REVAL
IXTST3:	TLZ RELEF!REUNBF
	MOVE FS,EFSPNT
	PUSH FS,N
	PUSH FS,NA
	MOVEI O,(FS)
	PUSH P,[16]
	PUSHJ P,PARAR
	JRST NONSM2
POLFIX:	MOVE T,MTBPNT	;GET NEXT FREE AREA
	MOVE N,OPCNT	;GET FIXUP LOCATION
LEG	MOVEM N,2(T)	;DEPOSIT
	MOVE O,OPCNT+1	;GET FLAGS
LEG	MOVEM O,3(T)	;DEPOSIT
	TLNN O,INCF	;IN CORE?
	JRST NOINCF	;NO
	TLNE MLFT	;LEFT HALF?
	JRST [HRROM T,2(N);YES -- SET REVERSE PNTR
	JRST NOINCF]
	HRROM T,(N)	;SET REVERSE POINTER
NOINCF:	SETZM 1(T)	;CLEAR COUNT
	HRRO O,T	;GET STRT POINTER
	ADDI T,5	;INCREMENT POINTER
	PUSHJ P,POLMOV	;MOVE POLISH
	SUBI T,1
	MOVEM T,MTBPNT	;UPDATE FREE AREA POINTER
	SUBI T,(O)		;FORM LENGTH
	TLNE MLFT	;LEFT HALF?
	TLO T,1		;YES
	TRNE FLFXF	;FULL WORD FIXUP?
	TLO T,2		;YES
	MOVSM T,(O)	;DEPOSIT
	SETZB N,NA	;"VALUE" IS 0
	SKIPE 1(O)	;NO UNDEFS?
	POPJ P,
	MOVE T,3(O)	;GET FIXUP LOC FLAGS
	TLNE T,INCF	;IN CORE?
	POPJ P,		;YES
	MOVE T,POLPNT	;GET CURRENT POINTER
	MOVEM T,1(O)	;PUT IN...
	HRRZM O,POLPNT	;CHAIN..
	POPJ P,
POLMOV:	SKIPL N,(FS)	;OPERATOR OR OPERAND?
	JRST OPRD	;OPERAND
LEG	MOVEM N,(T)	;DEPOSIT
	TLNE N,UNOF	;UNARY OP?
	JRST UNPT	;YES
	MOVE N,-1(FS)	;GET POINTERS
	ADDI T,2	;INCREMENT POINTER
LEG	MOVSM T,-3(T)	;DEPOSIT FIRST POINTER
	PUSH P,T	;SAVE NEW POINTER
	PUSH P,N	;SAVE OLD POINTER
	HLRZ FS,N	;SET NEW OLD POINTER
	PUSHJ P,POLMOV	;PUT IN FIRST OPERAND
	POP P,FS	;GET LEFT OPERAND OLD POINTER
	POP P,N		;GET OLD NEW POINTER
	HRRM T,-3(N)	;DEPOSIT NEW LEFT POINTER
	JRST POLMOV	;MOVE LEFT OPERAND

UNPT:	MOVE N,-1(FS)	;GET OPERANDS
	ADDI T,2
LEG	MOVSM T,-3(T)	;DEPOSIT NEW POINTER
	HLRZ FS,N	;SET UP POINTER
	JRST POLMOV

OPRD:	TLNN N,DEFFL	;DEFINED?
	JRST DEFND	;YES
LEG	MOVEM N,(T)	;DEPOSIT FLAGS
	MOVE N,-1(FS)	;GET "VALUE"
LEG	MOVEM N,-1(T)	;DEPOSIT
	MOVE NA,O	;GET STRT OF POLFIX
	HRLI NA,-1(T)	;GET POINTER
	EXCH NA,4(N)	;INSERT POLFIX IN CHAIN
LEG	MOVEM NA,1(T)	;...
	ADDI T,3	;INCREMENT
	AOS 1(O)		;COUNT UNDEF SYMBOL
	POPJ P,

DEFND:
LEG	MOVEM N,(T)	;DEPOSIT FLAGS
	MOVE N,-1(FS)	;GET VALUE
LEG	MOVEM N,-1(T)	;DEPOSIT
	ADDI T,2	;INCR. POINTER
	POPJ P,
BEND
BEGIN LABINS

COMMENT +
LABINS	-- CALL, TO DEFINE A LABEL, WITH THE VALUE
	IN N & NA, THE POINTER TO THE TABLE ENTRY IN
	PN  AND FLAGS (AS FOLLOWS) IN L (LH SAME AS IN SYM)
	RH:	TP1F -- DOWN-ARROW
		TP2F -- ^
	LH:	DBLF -- __ OR ::
		COLONF -- : TYPE (ERR ON REDEF)
		INTF --  ==: OR =: OCCURRED  SET INTERNAL
		DBLUPF -- ^^ OCCURRED IN SYMBOL
+

^^LVDEF:
	MOVEI	L,		;HERE TO DEFINE LITERALS & VARIABLES
	MOVSI	T,UDSF!VARF
	ANDCAB	T,2(PN)
^^LABINS:
	HLLZ T,L
	IOR T,2(PN)	;GET FLAGS
	TLNE L,DBLUPF	;WAS ^^ SEEN?
	SETOM DBLUP	;YES.  MARK IN CORE CELL TOO.
	TLZE T,EXTF
	TLO T,INTF	;TURN EXTERNAL  INTERNAL IF DEFINED
	TLNE T,UDSF	;UNDEFINED - DEFINED
	JRST ERR	;YES
	TLZN T,DEFFL	;DEFINED?
	JRST DEFD	;YES
	TRNE L,TP1F	;DOWN-ARROW?
	OR T,DBLCK
	TRNE L,TP2F	;^?
	TLO T,UPARF	;YES
	SKIPE	DBLUP
	TLO T,DBLUPF	;DOUBLE UP ARROW FLAG.
	TLNE NA,INCF	;IN CORE VALUE
	JRST LILHN	;YES
	MOVEM T,2(PN)
	EXCH N,3(PN)	;SWITCH VALUE WITH FIXUP POINTER
	EXCH NA,4(PN)	;SWITCH VALUE FLAGS WITH POLFIX PNTR.
	SKIPE N		;SKIP IF NO FIXUPS
	PUSHJ P,GFIX	;DO FIXUPS.
	MOVE N,NA
	SKIPE NA	;SKIP IF NO POLFIXES.
	PUSHJ P,PFIX	;DO POLFIXES
	MOVE N,3(PN)	;RESTORE N ...
	MOVE NA,4(PN)	;AND NA
	MOVE T,2(PN)	;GET FLAGS
	TLNN T,SYMFIX	;SEE IF SYMBOL TABLE FIXUP NEEDED
	POPJ P,		;NO
	MOVE FS,1(PN)	;BLOCK NAME
	PUSHJ P,R5CON
	MOVEM FS,SYMFXP+5
	MOVE FS,(PN)	;SYMBOL NAME
	PUSHJ P,R5CON
	MOVEM FS,SYMFXP+4
	MOVE N,3(PN)
	HLRM N,SYMFXP+2	;VALUE IN 2 HALVES
	HRLM N,SYMFXP+3
	DPB NA,[POINT 1,SYMFXP+1,2]	;RELOC
	LSH NA,-2
	DPB NA,[POINT 1,SYMFXP+1,1]
	POUT 6,SYMFXP
	MOVE NA,4(PN)	;GET RELOC BACK
	POPJ P,

^SYMFXP:	11,,4		;SYMBOL TABLE FIXUPS
		0		;RELOC BITS FOR SYMBOL VALUE
		1,,0		;OPERAND,,LEFT HALF
		0,,-6		;RIGHT HALF,,FULL-WORD SYMBOL STORE OPERATOR
		0		;R50 SYMBOL NAME
		0		;R50 BLOCK NAME


LILHN:	TLO T,DEFFL!UDSF	;MARK AS UNDEFINED - DEFINED
^MAKLL:	MOVEM T,2(PN)		;DEPOSIT FLAGS
	GFST T,FSTPNT
	MOVE FS,LABLTP	;GET POINTER TO LIST OF LIT. LABS
	EXCH FS,1(T)	;CONS ON
	MOVEM FS,FSTPNT
	MOVEM T,LABLTP
	MOVE FS,(PN)	;GET SIXBIT
	MOVEM FS,(T)	;DEPOSIT
	MOVE FS,LABLTC	;GET COUNT
	MOVEM FS,3(T)	;DEPOSIT
	MOVEM PN,4(T)	;THE LOCATION OF THE SYMBOL BLOCK
	POPJ P,
;GFIX:	CALL WITH POINTER TO DEFINED SYMBOL IN PN AND
;   FIRST FIXUP POINTER IN N.   USES T,FS,L,TAC

^GFIX:	MOVSI T,REFBIT
	IORM T,2(PN)	;MUST BE REFERENCED IF FIXUP NEEDED
LOOP1:	MOVE FS,4(PN)	;GET FLAGS
	MOVE TAC,2(N)	;GET FIXUP FLAGS
	MOVE L,4(N)	;GET VALUE FLAGS
	MOVE T,3(PN)	;GET VALUE
	ADD T,(N)	;ADD DEVIATION
	TRNE TAC,2	;FULL WORD?
	JRST FULFX	;YES
	DPB L,[POINT 1,FS,34];SET LEFT HALF RELOC BIT
	HRL T,3(N)	;PUT IN POINTER
	TLNE L,INCF	;IN CORE?
	JRST INCFX	;YES
	TRNN TAC,1	;LEFT HALF?
	JRST .+4	;NO
	CAML FC,[-1,,0]
	PUSHJ P,BFFRC	;FORCE BINARY AND FIXUPS: DON'T SEND -1 AS LAST WORD
	FOUT LFX	;SEND -1 SIGNIFYING LEFT HALF FIXUP
	FOUT T		;OUTPUT FIXUP
LOOP2:	MOVE	L,FSTPNT	;RETURN TO FREE STORAGE
	EXCH	L,1(N)		;LINK TO NEXT FIXUP INTO L
	MOVEM	N,FSTPNT
	SKIPE	N,L		;GET NEXT, DONE?
	JRST	LOOP1		;DO MORE.
	POPJ	P,

FULFX:	TLNE L,INCF	;IN CORE?
	JRST FINCFX	;YES
	HRLM T,FULF+3	;DEPOSIT VALUE
	HLRM T,FULF+2	;...
	DPB FS,[POINT 1,FULF+1,2];DEP. RELOC.
	LSH FS,-2
	DPB FS,[POINT 1,FULF+1,1];...
	MOVE T,3(N)	;GET FIXUP PLACE
	HRLM T,FULF+4	;DEPOSIT
	DPB L,[POINT 1,FULF+1,4];DEP. RELOC.
	PUSHJ P,BFRC	;FORCE OUT BIN
	POUT 5,FULF	;OUTPUT POLFIX
	JRST LOOP2

LFX:	-1		;WORDS FOR LEFT HALF FIXUP
	0

FULF:	XWD 11,3	;FULLWORD FIXUPS
	0
	XWD 1,0
	XWD 0,-3
	0

FINCFX:	MOVE TAC,3(N)	;GET PLACE	FULL-WORD IN-CORE FIXUP
	MOVEM T,3(TAC)	;DEPOSIT VALUE...
	ORM FS,4(TAC)	;& RELOC.
	SETZM (TAC)
	JRST LOOP2

INCFX:	TRNE TAC,1	;LEFT HALF?
	JRST LINCFX	;YES
	MOVS TAC,T	;RIGHT-HALF INCORE FIXUP
	HRRM T,3(TAC)	;DEPOSIT VALUE
	DPB FS,[POINT 1,4(TAC),35];DEPOSIT RELOC.
	SETZM (TAC)	;ZERO REVERSE POINTER
	JRST LOOP2

LINCFX:	MOVS TAC,T	;LEFT-HALF INCORE FIXUP
	HRLM T,3(TAC)	;DEPOSIT VALUE
	DPB FS,[POINT 1,4(TAC),33];DEPOSIT RELOC.
	SETZM 2(TAC)	;ZERO REVERSE POINTER
	JRST LOOP2
DAREDF:	MOVE FS,BLOCK	;GET BLOCK BIT
	TRNE L,TP2F
	LSH FS,-1
	SKIPE DBLUP
	MOVEI FS,1
	SUBI FS,1	;FORM ALL HIGHER BLOCK BITS
	AND FS,T	;ANY HIGHER LEVEL BITS ON
	JUMPE FS,DEFD1	;NO
	SKIPE XCRFSW
	JRST	[MOVEI FS,7
		SKIPE LISTSW
		IDPB FS,CREFPT
		JRST .+1]
	PUSHJ P,MKNEW	;CREATE A NEW ENTRY
	ERROR [ASCIZ /WARNING - DOWN-ARROWED SYMBOL REDEFINED/]
	JRST LABINS

DEFD:	TLNE T,DAF	;DOWN ARROW?
	JRST DAREDF	;YES
DEFD1:	TLZ T,UPARF	;CLEAR UPARROW BIT
	TLNN T,COLONF
	TLNE L,COLONF
	JRST CHKDEF	;PROBABLY ERR IF EITHER NEW OR OLD IS : TYPE
DEFOK:	TRNE L,TP1F	;DOWN-ARROW?
	OR T,DBLCK
	TRNE L,TP2F	;^?
	TLO T,UPARF	;YES
	SKIPE DBLUP
	TLO T,DBLUPF
	MOVEM T,2(PN)	;STORE FLAGS
	MOVEM N,3(PN)	;DEPOSIT VALUE
	MOVEM NA,4(PN)	;...
	POPJ P,

CHKDEF:	CAMN N,3(PN)
	CAME NA,4(PN)
	JRST ERR
	JRST DEFOK	;NOT ERR IF REDEF WITH SAME VAL

ERR:	ERROR[ASCIZ/MULTIPLE DEFINITION/]
	POPJ P,
;PFIX:	CALL WITH POINTER TO DEFINED SYMBOL IN PN AND POLISH
;	FIXUP CHAIN POINTER IN N.   USES T,FS,TAC,L

^PFIX:	MOVSI T,REFBIT
	IORM T,2(PN)	;INDICATE REFERENCED
PFIX1:	MOVS T,N	;GET OPERAND POINTER
	MOVE FS,3(PN)	;GET VALUE
	MOVEM FS,(T)	;DEPOSIT
	MOVE FS,4(PN)	;GET FLAGS
	MOVEM FS,1(T)	;DEPOSIT
	MOVE FS,2(T)	;SAVE NEXT...
	MOVEM FS,T2SAV	;POINTER
	SOSLE 1(N)	;DECREMENT UNDEF SYM COUNT
	JRST SUL	;Some Undefs. Left
	MOVEI FS,5(N)	;GET START OF POLISH
	PUSH P,O	;SAVE O
	PUSHJ P,REDUC	;REDUCE
	POP P,O		;RESTORE O
	SKIPGE FS,5(N)	;VALUE OR OPERATOR?
	JRST PLOUT	;OPERATOR
	MOVE L,3(N)	;GET FIXUP FLAGS
	TLNE L,INCF	;IN CORE FIXUP?
	JRST PINC	;YES
	MOVE TAC,(N)	;GET LEFT HALF FLAG
	TRNE TAC,2	;FULL WORD?
	JRST PFULX	;YES
	TRNN TAC,1	;LEFT HALF?
	JRST .+4	;NO
	CAML FC,[-1,,0]
	PUSHJ P,BFFRC	;FORCE BINARY AND FIXUPS NOW. (AVOID SENDING -1 AS LAST WORD)
	FOUT LFX	;SEND -1 SIGNIFYING LEFT HALF FIXUP
	MOVE T,4(N)	;GET VALUE
	HRL T,2(N)	;GET FIXUP
	DPB L,[POINT 1,FS,34];DEPOSIT FIXUP RELOC
	FOUT T		;PUT OUT FIXUP
PPT1:	PUSH P,B	;SAVE
	PUSH P,C
	HRRZ C,N	;GET START ADDRESS
	HLRZ B,(N)	;GET LENGTH
	ADD B,C		;GET END
	PUSHJ P,MACRET	;RETURN SPACE
	POP P,C		;RESTORE
	POP P,B
SUL:	SKIPE N,T2SAV	;GET NEXT POLFIX
	JRST PFIX1
	POPJ P,		;NO MORE
PFULX:	MOVE T,4(N)	;GET VALUE
	HLRM T,FULF+2	;DEPOSIT
	HRLM T,FULF+3	;...
	DPB FS,[POINT 1,FULF+1,2];DEPOSIT RELOC
	LSH FS,-2
	DPB FS,[POINT 1,FULF+1,1]
	MOVE T,2(N)	;GET FIXUP
	HRLM T,FULF+4	;DEPOSIT
	DPB L,[POINT 1,FULF+1,4];DEPO. RELOC
	PUSHJ P,BFRC	;FORCE OUT BIN
	POUT 5,FULF	;PUT OUT FIXUP
	JRST PPT1
PINF:	MOVE T,4(N)	;GET VALUE
	MOVE TAC,2(N)	;GET LIT LOC
	MOVEM T,3(TAC)	;DEPOSIT VALUE
	ORM FS,4(TAC)	;DEPOSIT RELOC
	SETZM (TAC)
	JRST PPT1
PINC:	MOVE TAC,(N)	;GET FLAGS
	TRNE TAC,2	;FULL WORD?
	JRST PINF	;YES
	TRNE TAC,1	;LEFT HALF?
	JRST PINCL	;YES
	MOVE TAC,2(N)	;GET LIT LOC.
	MOVE T,4(N)	;GET VALUE
	HRRM T,3(TAC)	;DEPOSIT
	SETZM (TAC)	;CLEAR REVERSE POINTER
	DPB FS,[POINT 2,4(TAC),35];DEP RELOC.
	JRST PPT1
PINCL:	MOVE TAC,2(N)	;GET LIT LOC.
	MOVE T,4(N)	;GET VALUE
	HRLM T,3(TAC)	;DEPOSIT
	SETZM 2(TAC)	;CLEAR REV. PNTR.
	DPB FS,[POINT 2,4(TAC),33];DEP RELOC.
	JRST PPT1
HALOUT:	HRROM L,HALP1	;DEPOSIT RIGHT HALF OF POINTER
	SETCMM HALP1	;AND COMPLEMENT IT
	IBP L		;INCREMENT RELOC POINTER
	TDNE L,HALP1	;DID IT GO TO NEXT WORD?
	JRST HALP2	;YES
HALRET:
LEG	IDPB TAC,HALP3	;DEPOSIT HALFWORD
	MOVSS TAC
LEG	DPB TAC,L	;DEPOSIT RELOC
	AOS HALP4	;COUNT
	POPJ P,

HALP2:	ADDI L,=18	;INCREMENT RELOC POINTER
LEG	SETZM	(L)	; Ensure unused reloc bits will be clear
	AOS HALP3	;INCREMENT HALFWORD POINTER
	JRST HALRET

T2SAV:	0
HALP1:	0		; Check RH to see when reloc BP (in L) overflows wd.
HALP3:	0		; Halfword BP into block being written
HALP4:	0		; # of halfwords deposited in block

PLOUT:	MOVE L,3(N)	;GET FIXUP FLAGS
	TLNE L,INCF	;IN CORE?
	JRST SUL	;YES
	MOVEI FS,5(N)
	PUSHJ P,POLOUT
	JRST PPT1
^POLOUT:
	HRRZ	L,MTBPNT		;GET A FREE PLACE TO PUT FIXUP
	PUSH	P,N			;SAVE N
	ADD	L,[XWD 442200,2]	;MAKE HALFWORD POINTER
	SETZM	HALP4			;ZERO COUNT
	MOVEM	L,HALP3			;DEPOSIT
	ADD	L,[440100000001-442200000002]	;MAKE RELOC POINTER
LEG	SETZM	(L)			; Ensure unused reloc bits will be 0
	PUSHJ	P,PPFFXX		;DO FIXUP
	POP	P,N			;GET N
	HRRZ	T,(N)			;GET FLAGS
	MOVN	TAC,T			;FORM...
	ADDI	TAC,-1			;STORE OP
	PUSHJ	P,HALOUT		;OUTPUT IT
	MOVE	TAC,2(N)		;GET FIXUP
	HRL	TAC,3(N)		;& RELOC
	PUSHJ	P,HALOUT		;OUTPUT IT
	MOVE	T,MTBPNT		;GET START
	MOVE	FS,HALP4		;GET COUNT
	TRNE	FS,1			; If it's odd,
	 JRST [	SETZ TAC,		; there is an empty RH left... ensure
		IDPB TAC,HALP3		; that it's clear, to avoid LINK
		AOJA FS,.+1]		; %LNKJPB errors.
	LSH	FS,-1			;FORM REAL COUNT
	HRLI	FS,11			;BLOCK TYPE
LEG	MOVEM	FS,(T)			;DEPOSIT
	PUSHJ	P,BFRC			;FORCE OUT BINARY
	MOVN	TAC,HALP3		;FORM...
	ADDI	TAC,-1(T)		;LENGTH
	HRL	TAC,T			;GET START
	MOVSM	TAC,HALP3
	BBOUT	HALP3
	POPJ	P,			;RETURN

PPTT1:	MOVS	FS,-1(FS)	;GET ARG POINTER
PPFFXX:	SKIPL	T,(FS)		;OPERAND OR OPERATOR?
	JRST	POPND		;OPERAND
	DPB	T,[POINT 5,T,4]	;CALUCULATE OPERATOR INDEX
	LDB	T,[POINT 7,T,6]	;INCLUDE MODIFIER BITS
	LDB	TAC,[POINT 12,OPTB1-10(T),11]	;CONVERT INDEX TO LOADER'S FORMAT
	JUMPN	TAC,.+2
	ERROR	[ASCIZ/UNKNOWN OPERATOR IN EMISSION OF POLISH FIXUP/]
	PUSHJ	P,HALOUT	;PUT OUT OPERATOR
	MOVE	T,(FS)
	TLNE	T,UNOF		;UNARY OP?
	JRST	PPTT1		;YES
	MOVE	FS,-1(FS)	;GET FIRST ARG POINTER
	PUSH	P,FS		;SAVE
	PUSHJ	P,PPFFXX	;PUT OUT
	MOVS	FS,(P)		;GET SECOND ARG POINTER
	SUB	P,[1(1)]
	JRST	PPFFXX		;PUT OUT & RETURN

POPND:	TLNE T,DEFFL	;DEFINED?
	JRST POPUN	;NO
	MOVE TAC,-1(FS)	;GET VALUE
	TLNN TAC,-1	;SHORT OR LONG WORD?
	TRNE T,14	;LEFT RELOC?
	JRST POPLNG	;LONG
	MOVEI TAC,	;GET FLAGS
	PUSHJ P,HALOUT	;PUT OUT
	MOVE TAC,-1(FS)	;GET WORD
	DPB T,[POINT 2,TAC,17];DEPOSIT RELOC
	JRST HALOUT	;PUT OUT HALFWORD & RETURN

POPLNG:	LDB N,[POINT 2,T,32];GET LEFT RELOC
	MOVEI TAC,1
	PUSHJ P,HALOUT
	MOVS TAC,-1(FS)
	HRL TAC,N
	PUSHJ P,HALOUT	;PUT OUT LEFT HALF
	HRRZ TAC,-1(FS)	;GET RIGHT HALF
	DPB T,[POINT 2,TAC,17];DEPOSIT RELOC
	JRST HALOUT	;PUT IT OUT & RETURN

POPUN:	MOVEI TAC,2
	PUSHJ P,HALOUT
	MOVE N,-1(FS)	;GET POINTER
	MOVE FS,(N)	;GET SIXBIT
	PUSHJ P,R5CON	;CON TO RADIX50
	TLO FS,40000	;MARK AS EXTERNAL (POLISH TYPE)
	HLRZ TAC,FS	;PUT OUT LEFT HALF
	PUSHJ P,HALOUT
	HRRZ TAC,FS	;PUT OUT RIGHT HALF...
	JRST HALOUT	;AND RETURN

	BEND	LABINS
SUBTTL ASSMBL -- ASSEMBLES A LINE & RETURNS VALUE
;	CALLED IN A STRANGE FASHION BECAUSE IT IS
;	RECURSIVE AND A CO-ROUTINE

BEGIN ASSMBL
	^NONEM__10	;TEMP BIT USED TO MAKE NONZERO INDICATION
^RBARET:TRO TRBF	;TERM BY ]
	TRNE NOFXF	;NO FIXUPS?
	JRST ARET	;YES, DONT LIST
	SKIPE WRD+1
	PUSHJ P,BLOUT
^ARET:	RETN
^ASSMBL:TDZ[XWD OPFLG!AUNDF,ADFL!TRBF!IOSW]
	SETZM WRD	;CLEAR WRD
	SETZM WRD+1
LOOP1:
LOOP2:	SKIPN WRD+1	;EMPTY SO FAR?
	TRO FLFXF	;YES, TELL MEVAL TO GENERATE FULL WORD FIXUPS
	PUSHJ P,MEVAL	;GET NEXT THING
	TRZ FLFXF
	TLNE SOPF	;OPCODE?
	JRST OPCD	;YES
	TLNE ESPF	;SPC CHR?
	JRST SPCL	;YES
	TLNE PAWF	;()?
	JRST IXFLD	;YES
	TRNE B,COMF	;TERM BY ,?
	JRST ACFLD	;YES
	TROE ADFL	;ALREADY GOT AN ADDRESS?
	JRST LERRA	;YES
	TLNE UNDF	;DEFINED?
	TLO AUNDF	;NO
	SKIPN WRD+1	;ANYTHING YET?
	JRST EMP	;NO
	HRRM N,WRD	;DEPOSIT AS ADDRESS
	ANDI NA,1	;GET RELOCATION
LOOP69:	ORM NA,WRD+1	;DEPOSIT
	JRST LOOP2	
EMP:	MOVEM N,WRD	;DEPOSIT VALUE
	HLL NA,		;GET AUNDF FLAG (MEANS FW FIXUP GENERATED)
	AND NA,[AUNDF,,5]	;ISOLATE FLAG & RELOCATION
	TLO NA,NONEM	;SET "NON EMPTY"
	MOVEM NA,WRD+1	;DEPOSIT
	JRST LOOP2	

LERRA:	ERROR[ASCIZ/TWO ADDRESS FIELDS OR UNDEF OPCODE/]
	JRST LOOP1	;NO OR NO

OPCD:	SKIPN XCRFSW	;CREF?
	JRST OPCD2
	MOVE FS,1(PN)	;PN STILL POINTS TO ENTRY, GET FLAGS
	JUMPL FS,ORDOP
	TLNN FS,20	;IS IT REGULAR TYPE?
	JRST ORDOP	;YES
	HRRZ FS,2(PN)	;BLOCK BITS
	JUMPE FS,ORDOP
	CREF6 5,(PN)	;OPDEF, PUT OUT AS MACRO
	SKIPA
ORDOP:	CREF7 3,L	;YES
OPCD2:	TLNE PSOPF	;PSEUDO OP?
	JRST (NA)	;YES
^OPCDR:	MOVEM N,WRD	;DEPOSIT IN WRD
	TLO NA,NONEM	;SET NON-EMPTY
	MOVEM NA,WRD+1	;DEPOSIT
	TRNE N,-1
	TRO ADFL	;TO WARN ABOUT MISUSED CALLIS
	JRST LOOP2
IXFLD:	TLNE UNDF	;DEFINED?
	ERROR[ASCIZ/UNDEFINED INDEX FIELD/]
	MOVSS N
	TRNE N,-1	;RIGHT HALF ZERO?
	TRON ADFL	;GOT AN ADDRESS?
	JRST	IXFLD1	;NO ADDRESS YET, OR RIGHT HALF IS ZERO
	TRZ	N,-1
	ERROR	[ASCIZ/INDEX EXPRESSION WAS TRUNCATED TO AVOID CLOBBERING ADDRESS FIELD/]
IXFLD1:	ORM N,WRD	;OR INTO WRD
	TRZE NA,17	;RELOC?
	ERROR [ASCIZ/RELOCATABLE INDEX FIELD/]
	TLOA NA,NONEM	;SET "NON-EMPTY"
ACFL2:	DPB N,[270400,,WRD]	;STORE AC FIELD
ACFL3:	ORB NA,WRD+1	;OR IN, GET OLD FLAGS
	TLNE NA,AUNDF
	ERROR [ASCIZ /AC OR INDEX FIELD CLOBBERED BY FIXUP/]
	JRST LOOP1

ACFLD:	PUSHJ P,SCAN1A	;GET NEXT
	TRNE B,COMF	;ANOTHER ,?
	JRST CCOM	;YES
	TLNE UNDF	;DEFINED?
	ERROR[ASCIZ/UNDEFINED AC FIELD/]
	TRZE NA,17	;RELOC?
	ERROR[ASCIZ/RELOC AC FLD/]
	TLO NA,NONEM	;SET "NON-EMPTY"
	TRNN IOSW	;IO OP?
	JRST ACFL2	;NO
	LSH N,-2
	DPB N,[POINT 7,WRD,9]
	JRST ACFL3
CCOM:	TLZ	SFL		;SKIP THE ,
	SKIPE	WRD+1		;ANYTHING ASSEMBLED YET?
	ERROR	[ASCIZ /ILLEGAL ,,/]	;YES -- COMPLAIN
	TLNN	UNDF		;UNDEFINED?
	JRST	CCOM2		;NO. JUST STORE VALUE.
	TLO	AUNDF		;YES -- TELL SOMEONE
	JUMPL	O,CCPOL		;JUMP IF WE HAVE SCREWED POLISH FIXUPS.
	MOVE	T,4(O)		;NO WE DID A REGULAR FIXUP
	JUMPE	NA,CCFOK	;JUMP IF WE CREATED A NEW FIXUP
CCOM0:	MOVEM	N,3(O)		;RESTORE
	MOVEM	NA,4(O)		;OLD VALUE & FLAGS
	MOVE	NA,(O)		;LINKED TO WRONG THING -- GET OFFSET
	TLO	MLFT		;LET'S DO IT LEFT THIS TIME
	PUSHJ	P,CCFIX		;HAVE TO DO THIS OVER AGAIN
	TLZ	MLFT		;STOP DOING LEFT HALF FIXUPS, FRED - REG/JBR
	JRST	CCOM2		;NOW FINISH

CCFOK:	JUMPN	N,CCOM0		;IN ABS ASSEMBLY, NEED TO TEST N TOO.
				;JUMP IF THAT WASN'T A NEW FIXUP
	MOVEI	T,1		;LH ONLY
	DPB	T,[(200)2(O)]	;FIX FLAGS
	MOVE	T,4(O)		;SEE IF
	TLNN	T,INCF		;IN CORE?
	JRST	CCOM2		;NO -- OK
	MOVE	T,3(O)		;YES -- WHERE?
CCRFX:	SETZM	(T)		;NO LONGER RH
	MOVEM	O,2(T)		;NOW LH REV PNTR
	JRST	CCOM2		;NOW STORE

CCPOL:	MOVEI	T,1		;LH ONLY
	DPB	T,[(200+O)]	;FIX FLAGS IN FIXUP
	MOVE	T,3(O)		;SEE WHAT IT'S FOR
	TLNN	T,INCF		;SOMETHING IN CORE?
	JRST	CCOM2		;NO -- ALL DONE
	MOVE	T,2(O)		;YES -- FIND OUT WHERE
	JRST	CCRFX		;NOW FIX REV PNTRS
CCOM2:	HRLM	N,WRD		;STORE LH
	DPB	NA,[20200,,NA]	;MOVE RELOC BITS
	TRZ	NA,3		;& FLUSH FROM RH
	TLO	NA,NONEM	;SOMETHING THERE
	TLO	OPFLG		;STOP OPCODE LOOKUP
	JRST	LOOP69		;SET FLAGS & GO ON
SPCL:	TLNE N,CRFG!LNFD;CR?
	JRST SCR	;YES
	TRNE N,ATF	;@?
	JRST SAT
	TLNE N,RBRF	;> OR ]?
	JRST RBARET	;YES, RETURN
	MOVSI NA,NONEM	;PREPARE TO MAKE NON-EMPTY
	TRNE N,COMF	;IF COMMA
	JRST LOOP69	;CAUSE 18-BIT TRUNCATION
	ERROR[ASCIZ/UNREC SPC CHR/]
	JRST LOOP1
^ASCR:
SCR:	TRNE NOFXF	;NO FIXUPS TO BE GEN'D?
	JRST .+3	;YES, DON'T LIST BINARY
	SKIPE WRD+1	;ANYTHING?
	PUSHJ P,BLOUT	;YES, DEPOSIT BINARY
	TLNN N,LNFD	;LINE FEED?
	PUSHJ P,SCNTIL	;NO, SKIP TO IT
	JRST ARET

SAT:	MOVSI N,20	;GET @ BIT
	MOVSI NA,NONEM	;GET NON-EMPTY BIT
	ORM N,WRD	;DEPOSIT
	ORM NA,WRD+1	;...
	JRST LOOP1
BEND ASSMBL
BEGIN POPS 	SUBTTL  PSEUDO-OP ROUTINES	;BLOCK, HISEG, TWOSEG

^%BLOCK:MOVE N,OPCNT+1	;ILLEGAL IN LIT
	TLNE N,INCF
	JRST PSLIT
	TRO NOFXF	;NO FIXUPS IF UNDEF
	PUSHJ P,MEVAL	;GET VALUE
	TRNN NA,17
	TLNE ESPF!UNDF	;SPC. CHR?
	JRST BERR	;YES
	JUMPGE N,.+2
	ERROR [ASCIZ/NEGATIVE ARGUMENT TO BLOCK/]
	PUSHJ P,BFFRC	;FORCE OUT BINARY AND THEN FIXUPS
	ADDM N,PCNT	;ADD TO LOC CNTRS
	ADDM N,OPCNT	;....
	HRRZS PCNT
	HRRZS OPCNT
	SETZM WRD+1
	SOS OPCNT
	PUSHJ P,VBLOUT
	AOS OPCNT
	MOVE N,OPCNT
	CAMGE N,BRK	;HIGH SEGMENT?
	JRST .+5	;NO,LOW SEG
	CAMGE N,HICNT	;YES, IS OPCNTHICNT?
	JRST .+5	;NO
	MOVEM N,HICNT	;YES,INCREMENT HIGH
	JRST .+3
	CAML N,@CURBRK	;IS OPCNTLOCNT?
	MOVEM N,@CURBRK	;YES,INCREMENT LOW
	JRST SPCFN
BERR:	ERROR[ASCIZ/NOT EXPRESSION AFTER BLOCK/]
	SETZM WRD+1
	JRST SPCFN


^%HISEG:SETZM WRD+1
	SETOM SEG
	MOVEI N,400000
	MOVEM N,OPCNT
	MOVEM N,PCNT
	MOVEM N,DPCNT
	HRRM N,HIBLK+2
	MOVEI N,1
	MOVEM N,OPCNT+1
	MOVEM N,PCNT+1
	MOVEM N,DPCNT+1
	SETZM BRK
	POUT 3,HIBLK
	JRST SPCFN

HIBLK:	XWD 3,1
	XWD 200000,0
	XWD 400000,400000

^%TWOSEG:TRO NOFXF
	SETOM SEG
	PUSHJ P, MEVAL
	MOVEM N,NA
	SETZM WRD+1
	TLNE ESPF	;ARGUMENT?
	MOVEI N,400000	;NO
	TLNE UNDF	;YES. DEFINED?
	JRST TWOERR	;NO. ERROR
	HRRZM N,BRK
	HRRM N,HIBLK+2
	POUT 3,HIBLK	;YES
	MOVE N,NA
	TLNN ESPF
	JRST SPCFN
	JRST NSPCFN

TWOERR:	ERROR[ASCIZ/TWOSEG ARGUMENT UNDEFINED./]
	JRST SPCFN
;	ASCII, ASCIZ, ASCID, .TEXT	SPCFN,SCR
TM1:	0

^%ASCII:
	TLZ	SFL		;CLEAR SCAN AHEAD
	MOVEM	N,TM1		;SAVE VALUE (-1=ASCID,0=ASCII,1=ASCIZ,2=.TEXT)
	HRRM	C,TM2		;SAVE TERM CHR.
	HRRM	C,TXM2		;SAVE TERM CHR FOR TEXT TOO.

;IN CASE OF ACCIDENT, WE SAVE WHERE WE STARTED.
	SKIPN	C,TLBLK		;GET SOS LINE NUMBER
	HRRO	C,INLINE	;NONE. USE OUR COUNT
	MOVEM	C,TXLIN		;SAVE AS LINE NUMBER WHERE TEXT PSEUDO-OP BEGINS
	MOVE	C,PGNM		;GET PAGE NUMBER
	MOVEM	C,TXTPG		;SAVE PAGE WHERE TEXT PSEUDO-OP BEGINS

NOTNX,<	MOVE	C,[FILNM,,TXTFIL]
	BLT	C,TXTFIL+4	;SAVE CURRENT FILE NAME  >;NOTNX

TNX,<	MOVE	C,JFNTBL
	MOVEM	C,TXTFIL	;JFN OF THE FILE	 >;TNX

	CAIN	N,2		;.TEXT?
	JRST	TXLP2		;YES.

LOOP2:	MOVEI	N,		;CLEAR
	MOVEI	NA,5		;COUNT
LOOP1:	PUSHJ	P,SCAN1		;GET CHR.
TM2:	CAIN	C,0-0		;TERM CHR?
	JRST	FND		;YES
	LSH	N,7		;NO,SHIFT
	OR	N,C		;AND INSERT
	SOJG	NA,LOOP1	;5 CHRS?
	LSH	N,1		;YES
	SKIPGE	TM1		;ASCID?
	ORI	N,1		;YES
	MOVEM	N,WRD		;DEPOSIT VALUE
	MOVSI	N,NONEM		;PREPARE FLAGS
	MOVEM	N,WRD+1		;DEPOSIT
	PUSHJ	P,BLOUT		;LIST BINARY
	RETN			;COROUTINE RETURN
	JRST	LOOP2		;CONTINUE

FND:	SETZM	TXTPG		;CLEAR STATE OF BEING INSIDE TEXT-OP
	CAIN	NA,5		;NONE IN THIS WORD?
	JRST	NONW		;YES, NONE
	LSH	N,7		;ADJUST
	SOJG	NA,.-1		;...
	LSH	N,1
	SKIPGE	TM1		;ASCID?
	ORI	N,1		;YES
	MOVEM	N,WRD		;DEPOSIT VALUE
LOP1:	MOVSI	N,NONEM
	MOVEM	N,WRD+1		;SET FLAGS
^SPCFN:	TRZ	NOFXF
	PUSHJ	P,SCAN1		;GET CHR.
	TLNN	B,CRFG!RBRF	;CR, OR ], OR >?
	JRST	SPCFN		;NO
	TLNE	B,CRFG		;CR?
	JRST	SCR		;YES. 
	TLO	SFL		;SET SCANNER AHEAD TO RESCAN ] OR >
	PUSHJ	P,SCAN		;EXIT SCAN VIA SPCRET, DOING GOOD THINGS
	JRST	RBARET		;RETURN FROM ASSMBL FOR ] OR >

^SCR:	SKIPE	WRD+1		;ANYTHING?
	PUSHJ	P,BLOUT		;YES. LIST IT.
	TLNN	B,LNFD		;LF YET?
	PUSHJ	P,SCNTIL	;NO, GET TO IT
	JRST	ARET

NONW:	SETZM	WRD		;ZERO WORD
	SKIPLE	TM1		;ASCIZ?
	JRST	LOP1		;YES, RETURN 0
	SETZM	WRD+1		;"NOTHING ON LINE"
	JRST	SPCFN		;RETURN


TXLP2:	SETZB	N,WRD+1		;CLEAR AC
	MOVEI	NA,5		;COUNT
TXLP1:	PUSHJ	P,SCAN1		;GET CHR.
TXM2:	CAIN	C,0-0		;TERM CHR?
	JRST	TXFND		;YES
	LSH	N,7		;NO,SHIFT
	IORI	N,(C)		;AND INSERT
	SOJG	NA,TXLP1	;5 CHRS?
TXLP3:	LSH	N,1		;YES. MOVE ONE MORE
	MOVEM	N,WRD		;DEPOSIT VALUE
	POUT	1,WRD		;WRITE THE WORD IN THE BINARY
	PUSHJ	P,LBLOUT	;LIST BINARY
	SKIPE	TM1		;LAST TIME THRU?
	JRST	TXLP2		;NO. CONTINUE
	JRST	SPCFN		;FLAG NOTHING IN WORD.  RETURN

TXFND:	SETZM	TXTPG		;CLEAR STATE OF BEING INSIDE TEXT-OP
	LSH	N,7		;ADJUST
	SOJG	NA,.-1		;...
	SETZM	TM1		;FLAG EXIT FROM .TEXT
	JRST	TXLP3
;	XWD	NSPCFN	.RCTAB	.WCTAB

^%XWD:	TLO	MLFT		;LEFT HALF
	PUSHJ	P,MEVAL
	TLNE	ESPF		;SPC CHR?
	JRST	XER		;YES - ERROR
	TRNN	B,COMF		;TERM BY ,?
	ERROR	[ASCIZ/NO COMMA AFTER XWD OR BLANK FIELD/]
	TRNE	NA,14		;LEFT HALF RELOC?
	ERROR	[ASCIZ/LEFT HALF OF EXPRESSION RELOCATABLE/]
	PUSH	P,N		;SAVE
	PUSH	P,NA		;SAVE
	TRNE	B,COMF		;IF NOT COMMA, DON'T SKIP DELIM.
	PUSHJ	P,SCAN		;SKIP THE ,
	TLNE	B,CRFG!RBRF	;NOTHING MORE?
	JRST	[SETZB N,NA	;NO. USE ZERO FOR RIGHT HALF.
		JRST XWD3]
	TLZ	MLFT		;NO LONGER LEFT HALF
	PUSHJ	P,MEVAL
	TLNE	ESPF		;SPC CHR?
	JRST	XERQ		;YES
	TRNE	NA,14		;LEFT HALF RELOC?
	ERROR	[ASCIZ/LEFT HALF OF EXPRESSION RELOCATABLE/]
XWD3:	TLO	NA,NONEM
	MOVEM	N,WRD		;DEPOSIT VALUE
	MOVEM	NA,WRD+1
	POP	P,NA		;GET BITS
	DPB	NA,[POINT 2,WRD+1,33]	;DEPOSIT RELOC
	POP	P,NA		;GET VALUE
	HRLM	NA,WRD		;DEPOSIT
	JRST	SPCFN

XERQ:	SUB	P,[2,,2]
XER:	ERROR	[ASCIZ/NO EXPRESSION AFTER XWD/]
^NSPCFN:TLNN	N,CRFG!RBRF	;CR RET?
	JRST	SPCFN		;NO
	TRZ	NOFXF
	TLNE	N,CRFG		;CR?
	JRST	ASCR
	JRST	RBARET

^%RCTAB:TRO	NOFXF
	PUSHJ	P,MEVAL		;GET CHAR TO READ
	TRNN	NA,17		;NO RELOC ALLOWED
	TLNE	UNDF!ESPF
	JRST	CHERR
	ANDI	N,177
	MOVE	N,CTAB(N)
	MOVEM	N,WRD
	SETZM	WRD+1
	JRST	SPCFN

CHERR2:	ERROR [ASCIZ/NO COMMA IN .WCTAB/]
	JRST SPCFN

CHERR3:	POP P,(P)
CHERR:	ERROR [ASCIZ/ILLEGAL VALUE TO CTAB/]
	JRST SPCFN

^%WCTAB:TRO	NOFXF
	PUSHJ	P,MEVAL		;GET CHAR TO SET
	TRNN	NA,17
	TLNE	UNDF!ESPF
	JRST	CHERR
	TRNN	B,COMF
	JRST	CHERR2
	PUSH	P,N		;SAVE CHAR
	PUSHJ	P,SCAN		;SKIP ,
	TRO	NOFXF
	PUSHJ	P,MEVAL		;VALUE TO SET IT TO
	TRNN	NA,17
	TLNE	UNDF!ESPF
	JRST	CHERR3
	POP	P,TAC
	ANDI	TAC,177
	MOVEM	N,CTAB(TAC)
	JRST	SPCFN
;	LIT, RADIX
^%LIT:	MOVE N,OPCNT+1
	TLNE N,INCF
	JRST PSLIT	;NOT IN LIT
	PUSHJ P,LITOUT
	SETZM WRD+1
	JRST SPCFN

^%RADIX:TRO NOFXF
	PUSHJ P,MEVAL	;GET VALUE
	TRNN NA,17
	TLNE ESPF!UNDF	;SPC. CHR?
	JRST RERR	;YES
	PUSHJ P,RADX	;SET RADIX
	SETZM WRD+1
	JRST SPCFN

RERR:	ERROR[ASCIZ/NOT EXPRESSION AFTER RADIX/]
	TLNE ESPF
	JRST NSPCFN
	JRST SPCFN

^RADX:	MOVE NA,[IMULI N,];PREPARE INSTRUCTION
	HRR NA,N
	CAIN N,10	;OCTAL?
	MOVE NA,[LSH N,3];YES
	MOVEM NA,SRAD	;SET RADIX
	MOVE	NA,CTAB+"0"
	ADDI	NA,(N)
	MOVEM	NA,RTEST
	POPJ P,
;	DEC AND OCT, %IO - HANDLE MACHINE IO OPCODES, PSLIT

CONSVR:	0
CONSVT:	0

^%CON:	MOVE	TAC,SRAD	;SAVE CURRENT RADIX - OCT AND DEC
	MOVEM	TAC,CONSVR
	MOVE	TAC,RTEST
	MOVEM	TAC,CONSVT
	PUSHJ	P,RADX		;SET RADIX
	MOVSI	N,NONEM
	MOVEM	N,WRD+1
CONLOP:	PUSHJ	P,SCANM		;GET NUM
	TLNN	NFLG		;NUM?
	JRST	CONERR		;NO
	MOVEM	N,WRD		;DEPOSIT NUMBER
	TRNN	B,COMF		;TERM BY ,?
	JRST	CONLST		;NO, LAST ONE
	PUSHJ	P,BLOUT		;PRINT BINARY
	RETN			;CO-ROUTINE WILL RETURN BELOW FOR NEXT
	TLZ	SFL		;SKIP THE ,
	JRST	CONLOP

CONERR:	ERROR	[ASCIZ/NOT A NUMBER/]
CONLST:	MOVE	TAC,CONSVR	;RESTORE RADIX
	MOVEM	TAC,SRAD
	MOVE	TAC,CONSVT
	MOVEM	TAC,RTEST
	JRST	SPCFN


^%IO:	TRO IOSW	;TURN ON IO SWITCH - HARDWARE I/O MNEMONIC SEEN.
	MOVEI NA,	;CLEAR OUT BITS
	JRST OPCDR	;PROCEED

^PSLIT:	ERROR	[ASCIZ /ILLEGAL PSEUDOOP IN LITERAL/]
	ADD	P,[17,,17]
	MOVEM	16,(P)
	MOVEI	16,-16(P)
	BLT	16,-1(P)
	MOVE	16,(P)
	MOVEI	3,LITMS
	PUSHJ	P,FMES		;LITERAL LINE N PAGE P FILE FOO.BAR
	MOVSI	16,-16(P)
	BLT	16,16
	SUB	P,[17,,17]
	SETZM	WRD+1
	JRST	SPCFN
;	PHASE, DEPHASE, LIST, XLIST, XLIST1, COMMENT

PERR:	ERROR	[ASCIZ/UNDEFINED OR SPECIAL CHR/]
	JRST	SPCFN

^PHAZ:	MOVE	N,OPCNT+1		;PHASE
	TLNE	N,INCF
	JRST	PSLIT			;NOT LEGAL IN LITERAL
	TRO	NOFXF
	PUSHJ	P,MEVAL			;GET VALUE
	TLNE	UNDF!ESPF		;DEFINED?
	JRST	PERR			;NO. LOSE
	MOVEM	N,PCNT			;DEPOSIT VALUE...
	MOVEM	NA,PCNT+1		;RELOCATION
	JRST	SPCFN

^DPHAZ:	MOVE	N,OPCNT+1
	TLNE	N,INCF
	JRST	PSLIT
	MOVE	N,[XWD OPCNT,PCNT]
	BLT	N,PCNT+1
	JRST	SPCFN

^%LIST:	JUMPE	N,LST1			;JUMP IF LIST
	JUMPL	N,LST2			;JUMP IF XLIST
	SKIPN	XL1IG			;SKIP IF IGNORE XLIST1 (/I SWITCH)
LST2:	SETOM	XL2SW			;XLIST: TERMINATE LISTING
	JRST	SPCFN

LST1:	SETZM	XL2SW			;TERMINATE THINKING ABOUT XLIST
	SKIPN	LISTSW			;LISTING DEVICE EXISTS?
	JRST	SPCFN			;NO
	TRO	LDEV			;YES. START LISTING
	MOVE	N,LSTPNT		;GET THE LISTING BYTE POINTER
	MOVEI	NA,0
REPEAT 5,<	IDPB	NA,N	>	;STUFF NULL BYTES IN
	SETZM	(N)
	HRLI	N,(N)
	ADDI	N,1
	BLT	N,LTEST-1		;CLEAR OUT THE LISTING BUFFER
	JRST	SPCFN

^%COMMT:				;COMMENT
	SKIPN	TAC,TLBLK		;REPEAT 0
	HRRO	TAC,INLINE
	MOVEM	TAC,REPPG
	MOVE	TAC,PGNM
	MOVEM	TAC,REP0PG
NOTNX,<	MOVE	TAC,[FILNM,,REPFIL]
	BLT	TAC,REPFIL+4
>;NOTNX
TNX,<
	MOVE	TAC,JFNTBL
	MOVEM	TAC,REPFIL	;SAVE JFN OF FILE
>;TNX
	PUSHJ	P,SLURPC	;EAT EVERYTHING UP TO MATCHING CHAR
	SETZM	REP0PG
	JRST	SPCFN
;	BYTE
^%BYTE:	TRNN B,LFPF	;( NEXT?
	JRST BERR1	;NO
	SETZM WRD
	TRO NOFXF	;NO FIXUPS
	MOVE N,[POINT 3,WRD]
	MOVEM N,PNTR
PARLOP:	PUSH P,SRAD	;SAVE RADIX
	PUSH	P,RTEST
	MOVEI N,12
	PUSHJ P,RADX	;CONVERT TO DEC.
	PUSHJ P,MEVAL	;GET VALUE
	TLNN PAWF	;()?
	ERROR[ASCIZ/AMBIGUITY ERROR/]
	TLNE UNDF!ESPF	;UNDEF OR SPC CHR?
	ERROR[ASCIZ/UNREC OR UNDEF SIZE/]
	TRNE NA,17	;RELOC FIELD?
	ERROR[ASCIZ/RELOC SIZE/]
	POP	P,RTEST
	POP P,SRAD	;RESTORE RADIX
	DPB N,[POINT 6,PNTR,11];DEPOSIT SIZE
	TRNE B,LFPF	;( NEXT?
	JRST PARLOP	;YES
	TRNE B,COMF	;, NEXT?
	JRST NULF	;YES
BLOP:	PUSHJ P,MEVAL	;GET NEXT BYTE
	TLNE UNDF	;UNDEF?
	ERROR[ASCIZ/UNDEF BYTE/]
	TRNE NA,17	;RELOC?
	ERROR[ASCIZ/RELOC BYTE/]
	TLNE ESPF	;SPC CHR?
	ERROR[ASCIZ/SPC. CHR. IN BYTE FIELD/]
DBYT:	IDPB N,PNTR	;DEPOSIT
	HRRZ NA,PNTR	;DID WE ADVANCE...
	CAIE NA,WRD	;TO NEXT WORD?
	JSR GOTWRD	;YES
	TRNN B,COMF	;, NEXT?
	JRST NOCOM	;NO
	PUSHJ P,SCAN 	;GET THE ,
	TRNE B,COMF	;, NEXT?
	JRST NULF	;YES
	TRNN B,LFPF	;( NEXT?
	JRST BLOP	;NO
NULF:	SETZB N,NA	;ZERO BYTE
	JRST DBYT
NOCOM:	TRNE B,LFPF	;(NEXT?
	JRST PARLOP	;YES
	MOVSI N,NONEM
	MOVEM N,WRD+1
	TRZ NOFXF	;RESTORE
	JRST SPCFN	;LEAVE, THROUGH

GOTWRD:	0
	MOVSI N,NONEM	;MARK WRD+1...
	EXCH N,WRD+1	;AND GET NEXT BYTE...
	MOVEM N,NSAV	;& SAVE
	PUSHJ P,BLOUT	;LIST BINARY
	RETN		;RETURN THIS WORD
	MOVE N,NSAV
	MOVEM N,WRD	;GET SAVED BYTE
	SOS PNTR	;ADJUST PNTR
	JRST @GOTWRD

BERR1:	ERROR[ASCIZ/NOT SIZE FIELD AFTER BYTE/]
	JRST SPCFN
PNTR:	0
NSAV:	0
;	POINT
^%POINT:PUSH P,SRAD	;SAVE CURRENT RADIX
	PUSH	P,RTEST
	MOVEI N,12
	PUSHJ P,RADX	;SET RADIX TO DEC.
	TRO NOFXF	;NO FIXUPS THIS FIELD
	PUSHJ P,MEVAL
	TRNN NA,17
	TLNE UNDF!ESPF	;SPC CHR. OR UNDEF?
	JRST PER1	;YES
	POP P,RTEST
	POP P,SRAD	;RESTORE RADIX
	SETZM WRD
	SETZM WRD+1
	DPB N,[POINT 6,WRD,11];DEPOSIT SIZE
	TRNN B,COMF	;, NEXT?
	JRST PER2	;NO
	TLZ SFL		;SKIP THE ,
PPT3:	TRZ ADFL!NOFXF	;FIXUPS OK NOW
PLOP:	PUSHJ P,MEVAL	;GET NEXT EXPR.
	TLNE ESPF	;SPC. CHR?
	JRST PSPC	;YES
	TLNE PAWF	;()?
	JRST PAWT	;YES
	TROE ADFL	;GOT AN ADDRESS ALREADY?
	JRST LERR	;YES
	HRRM N,WRD	;DEPOSIT ADDRS.
	ORM NA,WRD+1	;DEPOSIT RELOC
PPT:	TLNE B,CRFG!RBRF	;CR OR ] OR >?
	JRST PEND	;YES
	TRNN B,COMF	;TERM BY ,?
	JRST PLOP	;NO
	TLZ SFL		;SKIP THE ,
PPT2:	MOVSI NA,NONEM
	ORM NA,WRD+1
	TRO NOFXF
	PUSH P,SRAD	;SAVE RADIX
	PUSH	P,RTEST
	MOVEI N,12
	PUSHJ P,RADX	;SET TO DEC.
	PUSHJ P,MEVAL	;GET VALUE
	TRNN NA,17
	TLNE ESPF!UNDF	;SPC CHR. OR UNDEF?
	JRST PER3	;YES
	MOVNS N		;INVERT & ADD...
	ADDI N,43	;43
	DPB N,[POINT 6,WRD,5]	;& DEPOSIT
PPT1:	POP	P,RTEST
	POP P,SRAD
	TRZ NOFXF
	JRST SPCFN

PAWT:	MOVSS N		;SWAP HALVES
	TRNE NA,17	;RELOC?
	ERROR[ASCIZ/RELOC INDEX FIELD/]
	TLZ N,777760	;CLEAR PART
	ORM N,WRD	;OR IN
	TLNE UNDF	;DEFINED?
	ERROR[ASCIZ/UNDEF INDEX FIELD/]
	JRST PPT

PSPC:	TRNE N,COMF	;,?
	JRST PPT2	;YES
	TRNE N,ATF	;@?
	JRST PSAT	;YES
	ERROR[ASCIZ/UNREC SPC CHR/]
	JRST PPT

PSAT:	MOVSI N,20	;GET @ BIT
	ORM N,WRD	;DEPOSIT
	JRST PPT

PEND:	MOVEI NA,44	;GET 44
	DPB NA,[POINT 6,WRD,5];DEPOSIT AS POSITION
	MOVSI NA,NONEM	;MARK NONEMPTY
	ORM NA,WRD+1
	JRST SPCFN

PER1:	ERROR[ASCIZ/UNREC, UNDEF, OR RELOC SIZE/]
	JRST PPT1

PER2:	ERROR[ASCIZ/NO COMMA AFTER SIZE/]
	JRST PPT3

PER3:	ERROR[ASCIZ/UNREC, UNDEF, OR RELOC POSITION/]
	JRST PPT1

LERR:	ERROR[ASCIZ/UNREC SYNTAX/]
	JRST PPT
;	SIXBIT
^%SIX:	TLZ	SFL			;SKIP CHR.
	MOVEM	N,TM1			;SAVE VALUE (OF OP)
	HRRM	C,TM3			;SAVE TERM CHR.

;IN CASE OF ACCIDENT, WE SAVE SOME THINGS HERE
	SKIPN	C,TLBLK
	HRRO	C,INLINE
	MOVEM	C,TXLIN
	MOVE	C,PGNM
	MOVEM	C,TXTPG
NOTNX,<	MOVE	C,[FILNM,,TXTFIL]
	BLT	C,TXTFIL+4
>;NOTNX
TNX,<
	MOVE	C,JFNTBL
	MOVEM	C,TXTFIL	;SAVE JFN
>;TNX

LOPS2:	MOVEI N,	;CLEAR
	MOVEI NA,6	;COUNT
LOPS1:	PUSHJ P,SCAN1	;GET CHR.
TM3:	CAIN C,		;TERM CHR?
	JRST SFND	;YES
	LSH N,6		;NO, SHIFT
	TRZN C,100	;CONVERT...
	TRZA C,40	;TO...
	TRO C,40	;SIXBIT
	OR N,C		;INSERT
	SOJG NA,LOPS1	;6 CHRS?
	MOVEM N,WRD	;YES
	MOVSI NA,NONEM	;PREPARE FLAGS
	MOVEM NA,WRD+1	;DEPOSIT
	PUSHJ P,BLOUT	;LIST BINARY
	RETN		;RETURN WRD
	JRST LOPS2

SFND:	SETZM TXTPG
	CAIN NA,6	;NONE IN THIS WORD?
	JRST SNON	;NONE
	LSH N,6		;ADJUST
	SOJG NA,.-1	;...
	MOVEM N,WRD	;DEPOSIT VALUE
	MOVSI NA,NONEM	;AND...
	MOVEM NA,WRD+1	;FLAGS
	JRST SPCFN	;RETURN

SNON:	SETZM WRD+1
	JRST SPCFN
;	OPDEF

OPERR1:	ERROR	[ASCIZ/NO IDENTIFIER AFTER OPDEF/]
	SETZM	WRD+1
	JRST	SPCFN

OPERR2:	SUB	P,[1,,1]
	ERROR	[ASCIZ/VALUE OF OPDEF MUST BE DEFINED -- USE A MACRO/]
	SETZM	WRD+1
	JRST	SPCFN

^OPDTMP:0

^%OPDEF:SKIPA	N,BLOCK		;DEFINE AT CURRENT BLOCK
^%GOPDE:MOVEI	N,1		;DEFINE AT OUTERMOST BLOCK (GOPDEF)
	MOVEM	N,OPDTMP	;STORE BLOCK LEVEL FOR THIS DEFINITION.
	PUSHJ	P,SCAN		;GET SIXBIT
	TLNN	IFLG		;IDENT?
	JRST	OPERR1		;NO. ILLEGAL
	PUSH	P,L		;SAVE SIXBIT
OPDF1A:	PUSHJ	P,SCAN		;GET NEXT
	TLNN	SCFL		;SPC. CHR?
	JRST	OPDF1A		;NO.  IGNORE IT.
	TLNN	N,LBRF		;[ OR <?
	JRST	OPDF1A		;NO
	TRO	NOFXF		;YES, NO FIXUPS
	ACALL
	TLNE	AUNDF		;DEFINED?
	JRST	OPERR2		;NO
	TRZN	TRBF		;TERMINATED BY ] OR >?
	ERROR	[ASCIZ/UNRECOGNIZED TERMINATION CHARACTER -- OPDEF/]
	POP	P,L		;GET SIXBIT
	PUSHJ	P,OPDINS	;INSERT OPDEF
OPDF4:	SKIPE	XCRFSW
	CREF6	6,(PN)
	PUSHJ	P,LBLOUT
	TRZ	NOFXF
	SETZM	WRD+1
	JRST	SPCFN

;CALL OPDINS WITH L=SIXBIT, WRD,WRD+1 SETUP, AND OPDTMP SETUP TO BLOCK  
^OPDINS:MOVE	N,L
	IDIVI	N,HASH		;HASH
	MOVM	NA,NA
	SKIPN	PN,OPCDS(NA)
	JRST	OPDF2		;NO PREVIOUS DEFINITION.
	SRC2	L,PN,OPDFF	;CHECK FOR PREVIOUS DEFINITION
OPDF2:	MOVEI	NA,OPCDS-1(NA)	;SEARCH FOR PLACE TO INSERT NEW DEF.
				;NA_"PREVIOUS ITEM".
OPDF2A:	SKIPN	T,1(NA)		;T_"NEXT"
	JRST	OPDF2B		;NO NEXT.  INSERT AFTER (NA)
	SKIPL	PN,1(T)		;IS "NEXT" PERMANENT?
	TLNN	PN,20		;NO.  SKIP IF MADE BY OPDEF
	JRST	OPDF2B		;"NEXT" IS PERMANENT.  INSERT AFTER (NA)
	HRRZ	PN,2(T)		;GET BLOCK BITS
	CAMG	PN,OPDTMP	;SKIP IF "NEXT" IS NESTED DEEPER THAN THIS DEF.
	JRST	OPDF2B		;"NEXT" IS AT SAME OR OUTER LEVEL AS THIS DEF.
	MOVE	NA,T
	JRST	OPDF2A

OPDF2B:	GFST	PN,FSTPNT	;INSERT DEFINITION
	MOVEM	L,(PN)		;DEPOSIT SIXBIT
	MOVSI	N,20		;MARK THIS OPCODE WAS DEFINED BY THE USER
	HRR	N,1(NA)		;INSERT...
	EXCH	N,1(PN)		;IN LIST
	HRRM	PN,1(NA)
	MOVEM	N,FSTPNT
	MOVE	N,OPDTMP
	MOVEM	N,2(PN)		;SET BLOCK BIT
OPDF3:	MOVE	T,WRD
	MOVE	N,WRD+1
	MOVEM	T,3(PN)		;INVALIDATE EACH INTERMEDIATE DEFINITION.
	MOVEM	N,4(PN)
	POPJ	P,

OPDFF:	SKIPL	N,1(PN)		;HERE IF PREVIOUS DEFINITION EXISTS.  CHECK ITS TYPE
	TLNN	N,20		;SKIP IF OLD DEFINITION WAS BY OPDEF.
	JRST	OPDF2		;OLD IS PERMANENT - MUST INSERT NEW
	HRRZ	T,2(PN)		;BLOCK NUMBER OF PREVIOUS DEFINITION.
	CAMN	T,OPDTMP
	JRST	OPDF3		;SAME BLOCK - CLOBBER VALUE OF OLD DEF.
	MOVE	T,OPDTMP
	CAIE	T,1		;IS THIS .GOPDEF?
	JRST	OPDF2		;NO.  INSERT LOCAL DEFINITION.
	MOVE	T,3(PN)		;INVALIDATE EACH INTERMEDIATE DEFINITION.
	MOVE	N,4(PN)
	CAMN	T,WRD
	CAME	N,WRD+1
	ERROR	[ASCIZ/AN OPDEF, GLOBAL TO THIS BLOCK, IS BEING CHANGED/]
	HRRZ	PN,PN
	MOVEI	N,OPCDS-1(NA)	;N_"PREVIOUS NODE ADDRESS"
OPDFF1:	HRRZ	T,1(N)		;T_NEXT NODE ADDRESS
	CAIN	T,(PN)		;SAME AS THE ONE WE'RE DELETING?
	JRST	OPDFF2		;YES.  DELINK THIS NODE.
	MOVEI	N,(T)		;MAKE THIS NODE THE "PREVIOUS NODE"
	JRST	OPDFF1

OPDFF2:	EXCH	PN,FSTPNT	;FREE LIST POINTS TO (PN). PN CONTAINS FREE POINTER
	EXCH	PN,1(T)		;PN_REMAINDER OF OPCODE CHAIN.  FREE LIST RESTORED.
	HRRM	PN,1(N)		;STORE IN PREVIOUS NODE.
	JRST	OPDINS		;DIFFERENT BLOCK - INSERT NEW
;	.LOAD AND .LIBRARY PSEUDO-OPS

;FORMAT IS  .LOAD DEV:FILE[PRJ,PRG]
;	OR  .LOAD DEV:FILE.REL[PRJ,PRG]

;FILE EXTENSION REL IS ASSUMED, IF AN EXTENSION IS SEEN, IT MUST BE REL.
;THIS USES THE SAME SCANNER AS THE COMMAND LINE SCANNER!  MODIFIERS BEWARE!!

;IF ANYBODY EVER FIXES THE LOADER, THIS SHOULD BE TENEXIZED...

LIBBLK:	0,,3			;BLOCK TYPE 16 (OR 17), 3 DATA WORDS
	0			;RELOCATION IS ZERO
	0			;FILE NAME (SIXBIT)
	0			;PPN (WHATEVER'S RIGHT)
	0			;DEVICE (SIXBIT)

^%LBLCK:
	HRLM	N,LIBBLK	;STORE THE REQUEST TYPE (16 OR 17)
	SETZM	LIBBLK+1
	PUSH	P,CP		;SAVE FOR LATER.  VERY IMPORTANT
	PUSH	P,O		;THIS MAY BE NEEDED
	PUSH	P,FNREAD	;SAVE NORMAL COMMAND LINE READER.
	MOVE	N,[PUSHJ P,AFSCAN]
	MOVEM	N,FNREAD

ITS,<		PUSH	P,LIMBO	>;ITS

NOTNX,<		MOVSI	1,'DSK'		;ASSUMED DEVICE
		SETZB	5,4		;NO ASSUMED NAME OR PPN
		MOVSI	3,'REL'		;ASSUME EXT>;NOTNX


;GETFIL CALLS SCAN1.  CLOBBERS AC'S 0-13.
;0 IS SETUP CORRECTLY
;1,2,4,5,6,13 ARE CONSIDERED SCRATCH (T,FS,N,NA,PN,TAC)
;10,11 (B,C) ARE SET CORRECTLY TO LAST CHARACTER SEEN
;3,7 (O,CP) ARE PRESERVED BY PUSHING AND POPPING

NOTNX,<	JSR	GETFIL		;GET A FILE NAME 
	JRST	LIBER1		;ERROR: Can't parse name
	JUMPE	3,LBLCK1	;HAPPY WITH NO EXTENSION
	CAME	3,['REL   ']
	ERROR	[ASCIZ/EXTENSION MUST BE REL/]
LBLCK1:	MOVEM	1,LIBBLK+4	;STORE DEVICE
	MOVEM	4,LIBBLK+3	;STORE PPN
	MOVEM	5,LIBBLK+2	;STORE FILE NAME
>;NOTNX

TNX,<	PUSHJ	P,TGETFY	;GET TENEX FILE SPEC
	JRST	LIBER1		;CAN'T PARSE NAME
	MOVEI	3,0
	IDPB	3,1		;NULL TO FINISH TEXT STRING
	MOVSI	1,(1B2) 	;OLD ONLY.
	MOVEM	1,GTTBL
	MOVEI	1,[ASCIZ/REL/]	;DEFAULT EXTENSION OF REL.
	MOVEM	1,GTEXT
	MOVEI	1,GTTBL		; GET A JFN FROM THIS MESS.
	HRROI	2,GTNAM		; STRING START THERE.
	GTJFN
	JRST	[OUTSTR	[ASCIZ/CAN'T FIND /]
		 OUTSTR	GTNAM
		 OUTSTR	[ASCIZ/, PASSING FILE NAME TO LINKER
/]
		 MOVSI 	1,(1B12!1B17) ; JUST TRY FOR THE FAKE FILE NAME
		 HRROI	2,GTNAM	; AND LET LINK DO THE REST.
		 GTJFN
		 JRST	LIBER1	; THROW UP OUR HANDS IN DISGUST.
		 JRST	.+1]	; ELSE WIN.
	HRRZM	1,LIBBLK+1	;A SAFE PLACE.
	SETZM	LIBBLK+4	;CLEAR DEVICE FIELD
	MOVE	1,[POINT 7,GTNAM1] ;A PLACE TO PUT DEVICE STRING
	MOVE	2,[POINT 7,GTNAM] ;FROM HERE
LBLCK2:	ILDB	3,2		;GET A BYTE
	IDPB	3,1		;PUT A BYTE
	JUMPN	3,LBLCK2	;UNTIL WE SEE NULL
	PUSHJ	P,MSIX
	CAIN	3,":"		;FIELD TERMINATED BY THIS CHARACTER
	 MOVEM	1,LIBBLK+4	;SAVE DEVICE
T20,<
REPEAT 0,<
	HRROI	1,GTNAM1	;GET DIRECTORY AND DEVICE
	MOVE	2,LIBBLK+1
	MOVE	3,[110000,,1]	;PUNCTUATE PROPERLY
	JFNS
	MOVSI	1,1		;EXACT MATCH
	HRROI	2,GTNAM1	
	RCDIR			;CONVERT TO DIRECTORY NUMBER FOR SPECIFIC STRUCTURE
	TLNE	1,(1b3)		;skip if ok.
	ERROR	[ASCIZ/CAN'T TRANSLATE TO DIRECTORY NUMBER/]
	HRLI	3,4		;THE "PROJECT" PART
	MOVEM	3,LIBBLK+3	;SAVE PPN
>;REPEAT 0
	SETZM	LIBBLK+3	;ZERO PPN
>;T20	
NOT20,<	HRROI	1,GTNAM1	;STORE DIRECTORY NAME HERE
	MOVE	2,LIBBLK+1	;JFN
	MOVSI	3,010000	;OUTPUT DIR NAME ONLY
	JFNS
	HRROI	2,GTNAM1	;STRING OF DIR NAME
	MOVEI	1,0		;EXACT MATCH
	STDIR
	JFCL
	ERROR	[ASCIZ/CAN'T TRANSLATE TO DIRECTORY NUMBER/]
	HRLI	1,4
	MOVEM	1,LIBBLK+3	;STORE PPN
>;NOT20

	HRROI	1,GTNAM1	;STORE FILE NAME HERE
	MOVE	2,LIBBLK+1	;JFN
	MOVSI	3,001000	;FILE NAME
	JFNS
	PUSHJ	P,MSIX
	MOVEM	1,LIBBLK+2	;file
	HRROI	1,GTNAM1
	MOVE	2,LIBBLK+1
	MOVSI	3,000100	;EXT
	JFNS
	PUSHJ	P,MSIX
	JUMPE	1,MSRT
	CAME	1,['REL   ']
	ERROR	[ASCIZ/EXTENSION MUST BE REL/]
MSRT:	MOVE	1,LIBBLK+1
	RLJFN
	JUMP	16,.+1
	SETZM	LIBBLK+1
>;TNX
	POUT	5,LIBBLK
LIBRET:
ITS,<		POP	P,LIMBO		>
	POP	P,FNREAD
	POP	P,O
	POP	P,CP
	TLO	SFL		;LET SPCFN SEE THE CHARACTER BY WHICH WE TERMINATED
	JRST	SPCFN		;FINISH UP

LIBER1:	ERROR	[ASCIZ/CAN'T PARSE FILE NAME/]
	JRST	LIBRET

TNX,<
GTNAM1:	BLOCK	=26

MSIX:	MOVEI	1,0		;ACCUMULATE SIXBIT HERE
	MOVE	2,[POINT 7,GTNAM1]
	MOVE	4,[POINT 6,1]
MSIXLP:	ILDB	3,2		;GET A BYTE
	JUMPE	3,CPOPJ		;RETURN ON NULL
	CAIE	3,":"
	CAIN	3,"."
	POPJ	P,
	TRZ	3,40
	TRNE	3,100
	TRO	3,40
	TLNN	4,770000	;SKIP IF THERE'S ROOM FOR A BYTE
	JRST	[ERROR [ASCIZ/FILE NAME COMPONENT EXCEEDS 6 LETTERS/]
		POPJ	P,]
	IDPB	3,4
	JRST	MSIXLP
>;TNX
;	PURGE	XPUNGE

PU6:	ERROR	[ASCIZ/NO SUCH SYMBOL/]
PURCON:	TRNN	B,COMF		;HERE TO CONTINUE SCAN.  COMMA NEXT?
	JRST	SPCFN		;NO. DONE
	TLZ	SFL		;SKIP THE COMMA
^%PURGE:
	PUSHJ	P,SCAN		;GET AN ID NAME
	TLNN	IFLG		;IDENT?
	JRST	PNOI		;NO. LOSE
	MOVE	N,L
	IDIVI	N,HASH
	MOVM	NA,NA
	MOVEI	PN,OPCDS-1(NA)	;DEFINED AS AN OPCODE?
	PUSHJ	P,PRSRCH
	JRST	PU2		;NO.
PU1:	PUSHJ	P,PU1C		;DELINK THIS
	MOVE	NA,1(N)
	TLNN	NA,30		;REGULAR OPCODE? 
	JRST	PU1O		;YES. (WE CAN'T RECLAIM SPACE)
IFN CMUSW!STANSW,<	TLNE NA,10	;PREDEFINED CALLI?
			JRST PU1O>	;YES.  CAN'T RECLAIM SPACE EITHER
	JUMPGE	NA,PU1D		;JUMP IF AN OPDEF, WE CAN RECLAIM SPACE.
PU1O:	SKIPE	XCRFSW		;CREFFING?
	CREF7	3,(N)		;YES. EMIT NORMAL OPCODE TO CREF.
	JRST	PURCON

PU1D:	SKIPE	XCRFSW
	CREF6	5,(N)		;EMIT USE OF OPDEF TO CREF.
	SKIPE	CREFSW		;CREF IN PROGRESS? (EVEN IF XCREF)
	CREF66	13,(N)		;YES.  EMIT OPDEF "DEFINITION" TO CREF

PU1B:	PUSH	P,[PURCON]	;SET RETURN ADDRESS FROM PU1A
PU1A:	MOVE	PN,FSTPNT
	HRRZM	PN,1(N)		;STORE POINTER TO FREE LIST IN US
	MOVEM	N,FSTPNT	;STORE POINTER TO US IN FREE LIST.
	POPJ	P,

PU1C:	MOVE	NA,1(N)		;GET LINK OUT
	HRRM	NA,1(PN)	;STORE IN PREVIOUS.  DELINKS N.
	POPJ	P,

PU3A:	TLNE	NA,1		;MACRO PSEUDO OP.  EMIT TO CREF?
PU3B:	SKIPN	XCRFSW		;YES. BUT ARE WE DOUING CREF?
	JRST	.+2		;NO TO ONE OF THE ABOVE.
	CREF7	5,(N)		;EMIT TO CREF
	PUSHJ	P,PU1C		;DELINK MACRO-ENTRY
	JRST	PU1B		;RETURN MACRO-ENTRY

PU2:	MOVEI	PN,MACRT-1(NA)	;DEFINED AS A MACRO?
	PUSHJ	P,PRSRCH
	JRST	PU4		;NO
PU3:	SKIPGE	NA,3(N)		;SKIP IF REGULAR MACRO (OR IOWD)
	JRST	PU3A		;SPECIAL MACRO PSEUDO-OP (IF, "." OR .FNAM1)
	CAIN	N,%IOWD		;IS THIS IOWD?
	JRST	PU3B		;YES
	SKIPE	XCRFSW		;CREF IN PROGRESS RIGHT NOW?
	CREF6	5,(N)		;CREF A MACRO REFERENCE
	SKIPE	CREFSW		;CREF IN PROGRESS AT ALL?
	CREF66	13,(N)		;YES. EMIT MACRO "DEFINITION" TO CREF
	PUSH	P,B		;PURGE A MACRO. COPIED FROM MAC&REDEF
	PUSH	P,C
	MOVE	C,4(N)		;POINTER TO MACRO DEF.
	PUSHJ	P,PU1C		;DELINK SYMBOL ENTRY
	PUSHJ	P,PU1A		;GIVE BACK 5-WORD BLOCK POINTED TO BY N.
	HLRZ	B,(C)		;WORD COUNT OF MACRO DEF
	ADDI	B,(C)		;COMPUTE ADDRESS ABOVE THE MACRO DEF.
	PUSHJ	P,MACRET	;GIVE BACK THE MACRO DEFINITION.
	POP	P,C
	POP	P,B
	JRST	PURCON
	
PU4:	MOVEI	PN,SYMTAB-1(NA)	;DEFINED AS A SYMBOL?
	PUSHJ	P,PRSRCH
	JRST	PU6
	MOVE	NA,2(N)		;GET THE BLOCK BITS AND SYMBOL FLAGS
	TDNN	NA,BLOCK	;THIS BLOCK?
	JRST	PU6		;NO.
	TLNE	NA,DEFFL!SYMFIX!INTF!EXTF!UDSF	;THESE ARE ALL REASONS NOT TO.
	JRST	PNOD
	SKIPE	XCRFSW		;CREF RIGHT NOW?
	CREF6	1,(N)		;YES.  THIS IS A REFERENCE TO SYMBOL
	SKIPE	CREFSW		;ARE WE DOING CREF? (EVEN IF XCREF)
	CREF66	11,(N)		;YES. OUTPUT DEFINITION
	PUSHJ	P,PU1C		;DELINK SYMBOL ENTRY
	JRST	PU1B		;RETURN NODE TO FREE LIST


PNOD:	ERROR	[ASCIZ/CAN'T PURGE SYMBOL/]
	JRST	PURCON

PNOI:	ERROR	[ASCIZ/NOT IDENT/]
	JRST	SPCFN

;SEARCH FOR A SYMBOL TO PURGE (REMEMBER PREVIOUS LINK)
;CALL WITH:  MOVEI PN,SYMTAB-1(NA)
;	     PUSHJ P,PRSRCH
PRSRCH:	HRRZ	N,1(PN)		;IS THERE A FORWARD LINK?
	JUMPE	N,CPOPJ		;IF NOT, FAIL.
	CAMN	L,(N)		;DOES IT MATCH?
	JRST	PRSRC1		;YES. PN IS PREVIOUS, N IS CURRENT.
	MOVEI	PN,(N)		;PREVIOUS_CURRENT
	JRST	PRSRCH

PRSRC1:	AOS	(P)
	POPJ	P,

^%XPUNG:
	SETOM	XPUNGSW		;SET FLAG FOR BEND TO EXPUNGE SYMBOLS
	JRST	SPCFN
;	SUPPRESS	ASUPPRESS

SUPON1:	SKIPN	3(N)		;THIS IS EXTERNAL. SKIP IF ANY FIXUPS
	SKIPE	4(N)
	POPJ	P,		;THERE ARE FIXUPS.  DON'T SUPPRESS SYMBOL.
SUPON2:	TLO	NA,SUPBIT	;DEFINED AND NOT REFERENCED.  TURN ON SUPPRESS BIT
	MOVEM	NA,2(N)		;TURN ON THE SUPRRESS BIT FOR THIS SYMBOL
	POPJ	P,

;HERE TO SUPPRESS ONE SYMBOL POINTED TO BY N.  CLOBBERS NA.
SUPONE:	MOVE	NA,2(N)		;GET THE VALUE FLAGS
	TLNE	NA,EXTF		;IS THIS DECLARED EXTERNAL?
	JRST	SUPON1		;YES. HANDLE SPECIALLY.
	TLNN	NA,DEFFL!REFBIT!INTF	;IS THIS REF'D, INT OR UNDEF?
	JRST	SUPON2		;NO. DEFINED BUT NOT REFERENCED.
	POPJ	P,

SU3:	SKIPE	XCRFSW
	CREF7	3,(N)		;EMIT OPCODE (NOT OPDEF) TO CREF
	JRST	SUPCON

SU2:	SKIPE	XCRFSW
	CREF6	1,(N)		;EMIT SYMBOL TO CREF
SU1:	PUSHJ	P,SUPONE	;SUPPRESS SYMBOL
SUPCON:	TRNN	B,COMF		;HERE TO CONTINUE SCAN.  COMMA NEXT?
	JRST	SPCFN		;NO. DONE
	TLZ	SFL		;SKIP THE COMMA
^%SUPPR:
	PUSHJ	P,SCAN		;GET AN ID NAME
	TLNN	IFLG		;IDENT?
	JRST	SNOI		;NO. LOSE
	MOVE	N,L
	IDIVI	N,HASH
	MOVM	NA,NA
	MOVEI	PN,SYMTAB-1(NA)	;ENTRY AS A SYMBOL?
	PUSHJ	P,PRSRCH
	JRST	.+2		;NO.
	JRST	SU2		;YES.
	MOVEI	PN,OPCDS-1(NA)	;ENTRY AS AN OPDEF?
	PUSHJ	P,PRSRCH
	JRST	SNOS		;NO. WELL, WE CAN'T DO THAT.
	MOVE	NA,1(N)		;GET OPCODE VALUE
	TLNN	NA,20		;SKIP IF THIS IS AN OPDEF
	JRST	SU3		;CAN'T DO THIS TO OPCODES
	JUMPL	NA,SU3		;CAN'T DO THIS TO PSEUDO-OPS
	SKIPE	XCRFSW
	CREF6	5,(N)		;EMIT OPDEF TO CREF
	JRST	SU1		;BUT WE CAN DO IT TO OPDEFS

SNOI:	ERROR	[ASCIZ/NOT IDENT/]
	JRST	SPCFN

SNOS:	ERROR	[ASCIZ/NO SUCH SYMBOL/]
	JRST	SUPCON

^%ASUPP:
	MOVSI	PN,-HASH
ASUPP1:	SKIPN	N,SYMTAB(PN)	;GET A HASH POINTER
	JRST	ASUPP3		;NONE THERE
ASUPP2:	PUSHJ	P,SUPONE	;SUPPRESS IT.
	HRRZ	N,1(N)		;LINK ON.
	JUMPN	N,ASUPP2	;THRU ALL THIS CHAIN
ASUPP3:	AOBJN	PN,ASUPP1

	MOVSI	PN,-HASH	;NOW FOR THE OPDEFS
ASUPP4:	SKIPN	N,OPCDS(PN)	;GET A HASH POINTER
	JRST	ASUPP6		;NONE THERE
ASUPP5:	MOVE	NA,1(N)		;MAKE SURE THIS IS AN OPDEF
	TLNE	NA,20		;THIS BIT IS ON FOR OPDEF AND PSUEDO
	JUMPG	NA,.+2		;JUMP IF OPCODE (AND NOT PSEUDO)
	JRST	ASUPP6		;NO USER DEFINED CODES AFTER THIS POINT.
	MOVE	NA,2(N)
	TLNN	NA,REFBIT	;REFERENCED YET?
	TLO	NA,SUPBIT	;NO.  SET SUPRESSION BIT
	MOVEM	NA,2(N)
	HRRZ	N,1(N)		;LINK ON.
	JUMPN	N,ASUPP5	;THRU ALL THIS CHAIN
ASUPP6:	AOBJN	PN,ASUPP4
	SKIPE	UNIVSW
	SETOM	UASUPF#		;SET UNIVERSAL-ASUPPRESS
	JRST	SPCFN
;	SHUFFLE UNIVERSAL SYMBOLS

Comment $

	Up and down, up and down,
	I will lead them up and down:
	I am fear'd in field and town:
	Goblin, lead them up and down.

				A Midsummer Night's Dream, Act III Scene 2


All the universal symbols are divided into four categories:
	VOU Very Old Universals
	OU  Old Universals
	SU  Scattered Universals
	NU  New Universals

The different categories are distinguished as follows:
	VOU Left half of JOBSA points above the highest VOU symbol
	OU  UNIVBS = first word of OU area.  UNIVFF = first word above OU area
	SU  are compact but they are scattered around above UNIVFF
	NU  have not been compacted yet.

There are two calls on the shuffler, USHUFF, where there's no io active
(except @ file, RPG file, or TMPCOR file), and USHUF1 when there is 
io active that shouldn't be disturbed.
For USHUFF, OU are compacted into VOU, and USHUF1 is called.
For USHUF1, SU are moved to high core.  NU are compacted to high core.
   Then both are joined with OU.   If called from USHUFF, the OU
   become VOU by advancing JOBFF and lh of JOBSA
$
 
^USHUFF:			;HERE WHEN NO IO ACTIVE. REDUCE JOBFF
	HLRZ	1,.JBSA		;SET JOBFF FROM LH. OF JOBSA.
	HRRZM	1,.JBFF		
	SKIPN	2,UNIVBS	;ARE THERE ANY OU?
	JRST	USHUF1		;NO.

	SUBI	1,(2)		;THIS IS THE OFFSET AMOUNT (NEGATIVE)
	MOVEI	3,UNIVLH-1
USHF.1:	MOVEI	2,(3)		;SHUFFLE POINTER.
	HRRZ	3,1(2)		;ADVANCE TO NEXT UNIV TABLE 3=CURRENT, 2=PREVIOUS
	JUMPE	3,USHF.2	;JUMP IF NO MORE
	CAMGE	3,.JBFF		;SKIP IF THESE ARE NOT VOU
	JRST	USHF.2		;VOU SYMBOLS DON'T GET MOVED
	CAMGE	3,UNIVFF	;SKIP IF THESE ARE SU
	ADDM	1,1(2)		;OU WILL BE MOVED. ADJUST PREVIOUS POINTER.
	JRST	USHF.1		;LOOP. UNTIL WE FIND VOU.

;BLT OU TO VOU ADDRESSES
USHF.2:	HRLZ	3,UNIVBS	;GET SOURCE
	HRR	3,.JBFF		;DESTINATION
	MOVE	4,UNIVFF	;LAST WORD OF SOURCE, +1
	SUB	4,UNIVBS	;-FIRST WORD OF SOURCE, =LENGTH
	ADD	4,.JBFF		;+DESTINATION = LAST WORD OF DESTINATION,+1
	BLT	3,-1(4)
	HRRZM	4,.JBFF
	HRLM	4,.JBSA
	SETZM	UNIVBS		;NO OU SYMBOLS ANY MORE.
	SETZM	UNIVFF		;JOBFF=LH(JOBSA) SET TO FIRST FREE SPACE FOR NU.

^USHUF1:			;HERE AFTER PRGEND, DON'T CONFLICT WITH BUFFERS
	MOVE	16,MTBPNT	;HERE'S WHERE WE MOVE SU TO GET THEM TO SAFETY.
	MOVEM	16,SUNBAS#	;BASE OF SU SYMBOLS
	MOVEI	3,UNIVLH-1
USHX.1:	MOVEI	2,(3)
	HRRZ	3,1(2)		;ADVANCE TO NEXT GROUP.  3=CURRENT, 2= PREVIOUS
	JUMPE	3,USHX.4	;JUMP IF NO MORE
	CAMGE	3,.JBFF		;SKIP IF THESE ARE NOT VOU AND NOT OU
	JRST	USHX.4		;THESE ARE VOU OR OU, NO MORE SU.
	MOVE	16,MTBPNT	;DESTINATION OF BLT
	HRRM	16,1(2)		;FIX THE BACK POINTER TO SHOW WHERE IT'S BEING PUT
	HRLI	16,(3)		;SOURCE,,DESTINATION
USHX.2:	HLRZ	4,1(3)		;GET THE LENGTH OF THIS GROUP
	ADDI	4,(16)		;LAST WORD OF DESTINATION+1
	CAMG	4,.JBREL	;MAKE SURE IT'S THERE
	JRST	USHX.3		;IS OK.
	PUSHJ	P,COEXP
	JRST	USHX.2

USHX.3:	MOVEI	3,(16)		;ADJUST CURRENT POINTER TO NEW LOC
	BLT	16,-1(4)	;MOVE CRUD
	MOVEM	4,MTBPNT	;UPDATE FS. POINTER
	JRST	USHX.1		;LOOP THRU ALL SU SYMBOLS

USHX.4:	SKIPN	UNIVSW		;WAS THERE A UNIVERSAL FILE LAST?
	JRST	USHY		;NO. NOTHING TO DO.
	SETZM	UNIVSW		;CLEAR IT TO AVOID A SECOND CALL

;JOBFF IS THE LOWEST ADDRESS AVAILABLE FOR UNIVERSALS.
;COPY ALL THE UNVERSALS TO THE TOP OF CORE.
;RELOCATE NU SYMBOLS TO ADDRESS CONTAINED IN JOBFF.
;IF JOBFF=LH(JOBSA) THEN ADVANCE AND SET JOBFF AND JOBSA.
;IF JOBFF .NE. LH(JOBSA) STORE JOBFF IN UNIVBS, ADVANCE JOBFF AND STORE IN UNIVFF
;BNAM IS THE BLOCK NAME FOR THE UNIVERSALS.
;U.SYM, U.OPC, U.MAC ARE PARAMETERS

	HRRZ	16,MTBPNT		;POINTER TO MACRO FREE SPACE.
	MOVEI	14,(16)			;ADDRESS OF THE UNIV BLOCK

	MOVNI	15,(16)			;OFFSET (NEGATIVE) TO LOCATE AT "ZERO"

LEG	SETZM	1(14)
	MOVE	1,BNAM			;BLOCK NAME FOR THE UNIV SYMBOLS
	MOVEM	1,(14)
	ADDI	16,5			;ADVANCE FREE POINTER

	MOVEI	12,0
	MOVEI	11,U.SYM-1
	PUSHJ	P,USHUF2
LEG	MOVEM	12,2(14)		;STORE SYM POINTER.

	MOVEI	12,0
	MOVEI	11,U.OPC-1
	PUSHJ	P,USHUF2
LEG	MOVEM	12,3(14)		;STORE OPC POINTER.

	MOVEI	12,0
	MOVEI	11,U.MAC-1
	PUSHJ	P,USHUF3
LEG	MOVEM	12,4(14)		;STORE MAC POINTER

;14 = FIRST ADDRESS. 16=LAST ADDRESS+1.
	MOVEM	16,MTBPNT		;STORE FIRST FREE ADDRESS
	MOVEI	10,(16)			;GET LAST ADDRESS+1
	SUBI	10,(14)			;-FIRST ADDRESS = NUMBER OF WORDS
	HRLM	10,1(14)		;STORE WORD COUNT HERE.

;HERE WE WRITE THE .FUN FILE IF WE MUST
	SKIPE	FUNSUP			;SUPRESS FUN FILE?
	JRST	USHF1B			;YES.
;PARAMETERS FOR WRITING FUN FILE:  14 IS FIRST ADDRESS 16 IS LAST ADDRESS+1
;ONE EXTRA WORD 0(16) IS WRITTEN BECAUSE OF LOSING DISK CHANNEL AT STANFORD
NOTNX,<
	MOVSI	FS,'DSK'
	MOVEI	T,17
	MOVEI	O,0
	OPEN	1,T
	JRST	[OUTSTR	[ASCIZ/DSK: OPEN TO WRITE .FUN FILE LOST
/]
		JRST	USHF1B]
	SKIPN	1,BNAM			;GET BLOCK NAME (UNIVERSAL NAME)
	MOVSI	1,'FUN'
	TLNE	1,770000
	JRST	.+3
	LSH	1,6
	JRST	.-3
	MOVSI	2,'FUN'			;LEAVE HIGH DATE ZERO FOR DEFAULT
	SETZB	3,4			;LOW DATE AND PPN DEFAULT
	ENTER	1,1
	JRST	[OUTSTR	[ASCIZ/ENTER TO WRITE .FUN FILE FAILED
/]
		JRST	USHF1B]
>;NOTNX
TNX,<
	SKIPN	1,BNAM			;NORMAL NAME IS FROM UNIV NAME
	MOVSI	1,'FUN'			;DEFAULT NAME IS FUN.FUN
	TLNE	1,770000
	JRST	.+3
	LSH	1,6
	JRST	.-3
	MOVE	2,[POINT 7,GTNAM]	;PLACETO ASSEMBLE ASCIZ STRIN
	PUSHJ	P,UNXNM
	MOVEI	3,"."
	IDPB	3,2
	MOVSI	1,'FUN'
	PUSHJ	P,UNXNM
	MOVEI	3,0
	IDPB	3,2
	HRROI	2,GTNAM
	MOVSI	1,400001		;NEXT VERSION.  SHORT FORM
	GTJFN				;GET JFN FOR FUN FILE
	JRST	UNVOER			;OPEN/GETJFN ERROR
	HRRZM	1,UNVJFN#
	HRRZ	1,1
	MOVE	2,[447400,,300000]	;DUMP MODE.
	OPENF
	JRST	UNVOER
	JRST	UNVOK

UNXNM:	LDB	3,[POINT 6,1,5]
	ADDI	3," "
	IDPB	3,2
	LSH	1,6
	JUMPN	1,UNXNM
	POPJ	P,

UNVOER:	OUTSTR	[ASCIZ\I/O failure when writing .FUN file.
\]
	JRST	USHF1B
>;TNX
UNVOK:
LEG	SETZM	(16)			;WE NEED THIS WORD AT STANFORD AI
	MOVEI	3,(14)			;FIRST ADDRESS
	SUBI	3,1(16)			;-(LAST ADDRESS+1) = -(WC+1)
	HRLI	3,-1(14)		;MA-1 IN LEFT HALF
	MOVS	3,3			;IOWD IN 3
	MOVEI	4,0
NOTNX,<
	OUTPUT	1,3
	CLOSE	1,
	RELEAS	1,
>;NOTNX
TNX,<
	MOVE	1,UNVJFN
	MOVEI	2,3			;POINTER TO COMMAND LIST
	DUMPO				;WRITE DATA
	JRST	UNVOER
	MOVE	1,UNVJFN
	CLOSF				;CLOSE AND RELEASE JFN
	JRST	UNVOER
>;TNX

USHF1B:	MOVE	15,UNIVLH		;GET POINTER OTHER U TABLES
	HRRM	15,1(14)		;STORE POINTER HERE
	HRRZM	14,UNIVLH		;STORE MAIN POINTER.
	SETZM	UASUPF			;NO LONGER UNIVERSAL-ASUPPRESS

USHY:	MOVE	4,SUNBAS
	CAML	4,MTBPNT
	POPJ	P,			;NOTHING TO DO

;SOURCE IS SUNBAS, DESTINATION IS JOBFF.  JUST QUICK RELOCATE ALL POINTERS
	SUB	4,.JBFF			;THIS IS DISTANCE MOVED (POSITIVE)
	MOVN	4,4			;OFFSET (NEGATIVE)
	MOVEI	3,UNIVLH-1
USHY.1:	MOVEI	2,(3)
	HRRZ	3,1(2)		;ADVANCE TO NEXT GROUP.  3=CURRENT, 2= PREVIOUS
	JUMPE	3,USHY.2	;JUMP IF NO MORE
	CAMGE	3,SUNBAS	;SKIP IF THESE ARE SU OR NU
	JRST	USHY.2		;NO MORE SU!
	ADDM	4,1(2)		;SET OFFSET IN PREVIOUS POINTER
	JRST	USHY.1		;LOOP

USHY.2:	MOVS	10,SUNBAS	;SOURCE
	HRR	10,.JBFF	;DESTINATION
	MOVE	16,MTBPNT	;GET THE LAST ADDRESS
	SUB	16,SUNBAS	;CALCULATE LENGTH
	ADD	16,.JBFF	;LAST ADDRESS+1 OF BLT
	BLT	10,-1(16)	;DO IT.
	MOVE	11,.JBFF	;GET OLD JOBFF
	MOVEM	16,.JBFF	;SET NEW JOBFF
	HLRZ	10,.JBSA	;GET JOBSA
	CAMN	10,11		;SAME AS OLD JOBFF?
	JRST	[HRLM	16,.JBSA	;YES STORE JOBSA TOO
		POPJ	P,]		;ALL DONE NOW.
	MOVEM	16,UNIVFF		;FIRST FREE ABOVE OU'S
	MOVEM	11,UNIVBS		;BASE OF OU'S
	POPJ	P,


;HERE TO MOVE SYMBOL,OPCODE, OR MACRO-ENTRY FROM (11) TO (16)
;UPDATES 
USHUF4:	MOVE	10,4(11)		;GET LAST WORD.
LEG	MOVEM	10,4(16)		;STORE IN FREE SPACE
	MOVE	10,3(11)
	MOVEM	10,3(16)
	MOVE	10,2(11)
	TLZ	10,REFBIT		;CLEAR REFBIT - UNIV NOT REFERENCED YET
	SKIPE	UASUPF			;UNIVERSAL-ASUPPRESS?
	TLO	10,SUPBIT		;YES.  SET SUPPRESS BIT
	MOVEM	10,2(16)
	MOVE	10,0(11)
	MOVEM	10,0(16)

	MOVE	10,1(11)		;PRESERVE LEFT HALF IN CASE OF OPDEF
	HRR	10,12
	MOVEM	10,1(16)		;STORE POINTER TO PREVIOUS SYMBOL

	MOVEI	12,(16)			;GET POINTER TO THIS
	ADD	12,15			;ADD OFFSET = FINAL ADDRESS AFTER BLT
	ADDI	16,5
	POPJ	P,

;HERE FOR LIST OF OPC AND SYM
USHUF2:	HRRZ	11,1(11)		;ADVANCE TO NEXT ENTRY.
	JUMPE	11,CPOPJ		;JUMP IF THERE IS NO NEXT.
	PUSHJ	P,USHUF4
	JRST	USHUF2			;ADVANCE TO NEXT ENTRY

;HERE FOR MACRO LIST
USHUF3:	SKIPN	11,1(11)		;ADVANCE TO NEXT ENTRY
	POPJ	P,
	PUSHJ	P,USHUF4		;MOVE THE MACRO-ENTRY
	MOVE	10,16			;GET FREE ADDRESS
	ADD	10,15			;ADD OFFSET TO MAKE CORRECT ADDRESS
	EXCH	10,-1(16)		;EXCH WITH MACRO-BODY ADDRESS
	HRRM	12,(10)			;SET BACK-POINTER ADDRESS IN THE MACRO-BODY
	HLRZ	7,(10)			;GET THE SIZE OF THE MACRO-BODY
	ADDI	7,(16)			;CALCULATE FINAL ADDRESS+1
	MOVS	10,10			;SOURCE ADDRESS IN LEFT
	HRRI	10,(16)			;DESTINATION IN RIGHT
LEG	SETZM	(7)			;ADDRESS BEYOND THE BLT
	BLT	10,-1(7)
	MOVEI	16,(7)			;FIXUP FREE STORAGE POINTER.
	JRST	USHUF3			;LOOP FOR ALL MACROS
;	SEARCH

SRNOI:	ERROR	[ASCIZ/SEARCH - NO ID/]
	JRST	SPCFN

SERCN0:	TRNN	B,LFPF		;TERMINATED BY LEFT PARENS?
	JRST	SPCFN		;NO.  WE'RE DONE
	TLZ	SFL		;CLEAR SCAN AHEAD
	PUSHJ	P,SCAN1		;GET NEXT CHARACTER
	TDNN	B,[CRFG,,RTPF]	;RIGHT PARENS OR END OF LINE?
	JRST	.-2		;NO.  GO UNTIL WE GET ONE
SERCON:	TRNE	B,RTPF		;RIGHT PARENS?
	PUSHJ	P,SCAN1		;YES. GET NEXT AFTER PARENS
	TLO	SFL		;SET SCAN AHEAD.  CHARACTER NEEDS TO BE SEEN AGAIN
	TRNN	B,COMF		;TERMINATED BY COMMA?
	JRST	SERCN0		;NO. CHECK FOR TERMINATED BY LEFT PARENS.
	TLZ	SFL		;CLEAR SCAN AHEAD
^%SEAR:	PUSHJ	P,SCANM		;GET AN ID NAME
	TLNN	IFLG
	JRST	SRNOI		;NO ID AFTER SEARCH
	MOVEI	N,UNIVLH-1	;SEARCH FOR RIGHT NAME
SEAR1:	HRRZ	N,1(N)
	JUMPE	N,SRTRD		;LOSE IF THERE ARE NO MORE
	CAME	L,(N)		;MATCHES?
	JRST	SEAR1		;NO. LOOP ON

;NOW, N IS THE POINTER TO THE UNIVERSAL BLOCK.
;2(N) SYMBOLS - ADD TO END OF SYMBOL TABLE
;3(N) OPCODES - INSERT IN OPCODE TABLE IN FRONT OF PREDEFINED OPCODES
;4(N) MACROS -  INSERT AT THE END
SEAR1A:	PUSH	P,N		;SAVE FOR GOOD LUCK.
	MOVEI	PN,1(N)		;POINTER (POINTER TO THE SYMBOLS)-1
SEAR2:	HRRZ	PN,1(PN)	;ADVANCE
	JUMPE	PN,SEAR3	;NO MORE SYMBOLS
	ADD	PN,(P)		;ADD BASE OFFSET TO PN.
	GFST	(N,FSTPNT)	;GET FREE STORAGE
	MOVE	NA,1(N)		;GET NEXT POINTER
	MOVEM	NA,FSTPNT	;KEEP FREE LIST HONEST
	MOVSI	NA,(PN)		;SOURCE
	HRR	NA,N		;DESTINATION
	BLT	NA,4(N)		;COPY NAME AND DEFINITION TO NEW BLOCK
	SETZM	1(N)		;CLEAR LINK ADDRESS
;The following code was added by REG. Apparently he wanted to normalize
; the flags.  However in the original form it removed the effect of
; downarrows in the unv file.  I now copy their effect.  If that isn't
; good enough, feel free to simply delete these lines.  -- Clh
	HLLO	NA,2(N)		;old flags,,-1
	TLNN	NA,DAF		;if downarrow, that's right
	HRRI	NA,1		;but if not, set for outer block only
	HRRM	NA,2(N)		;now put in the normalized block level
;End of section referred to above ^^
	PUSH	P,N		;SAVE BLOCK ADDRESS
	MOVE	N,(PN)		;SYMBOL NAME
	IDIVI	N,HASH
	MOVM	NA,NA		;HASH VALUE
;NA = HASH VALUE.  SEEK END OF THE LIST
	MOVEI	N,SYMTAB-1(NA)	;PREVIOUS ADDRESS
SEAR2A:	MOVEI	NA,(N)
	HRRZ	N,1(NA)		;GET NEXT ADDRESS
	JUMPN	N,SEAR2A
	POP	P,1(NA)		;STORE NEW SYMBOL BLK ADDR AT END OF LIST.
	JRST	SEAR2		;GET NEXT SYMBOL

SEAR3:	MOVE	N,(P)		;GET UNIV BLK ADDR FROM STACK
	MOVEI	PN,2(N)
SEAR3A:	HRRZ	PN,1(PN)
	JUMPE	PN,SEAR4	;NO OPCODES LEFT.  DO MACROS
	ADD	PN,(P)
	GFST	(N,FSTPNT)	;GET FREE STORAGE
	MOVE	NA,1(N)		;GET NEXT POINTER
	MOVEM	NA,FSTPNT	;KEEP FREE LIST HONEST
	MOVSI	NA,(PN)		;SOURCE
	HRR	NA,N		;DESTINATION
	BLT	NA,4(N)		;COPY NAME AND DEFINITION TO NEW BLOCK
	HLLZS	1(N)		;CLEAR LINK ADDRESS
	PUSH	P,N		;SAVE BLOCK ADDRESS.
	MOVE	N,(PN)		;SYMBOL NAME
	IDIVI	N,HASH
	MOVM	NA,NA		;HASH VALUE
	MOVEI	NA,OPCDS-1(NA)	;PREVIOUS ADDRESS
SEAR3B:	MOVEI	N,(NA)
	HRRZ	NA,1(N)		;GET NEXT ADDRESS
	JUMPE	NA,SEAR3C	;NO NEXT ADDR. N=ADDR OF LAST BLOCK
	HLRZ	L,1(NA)		;GET THE CODE BITS
	CAIN	L,20		;PRECISELY 20 MEANS OPDEF
	JRST	SEAR3B		;THIS IS AN OPDEF.  ADVANCE N TO CURRENT (NA) BLOCK
SEAR3C:	POP	P,L		;GET ADDR OF NEW SYMBOL
	HRRM	NA,1(L)		;STORE LINK OUT
	HRRM	L,1(N)		;STORE LINK IN
	JRST	SEAR3A		;DO MORE.

SEAR4:	MOVE	N,(P)		;GET UNIV BLK ADDR FROM STACK
	MOVEI	PN,3(N)
SEAR4A:	HRRZ	PN,1(PN)
	JUMPE	PN,[POP P,(P)	;FIX STACK
		JRST SERCON]	;NO MACROS LEFT.  GET NEXT ARGUMENT
	ADD	PN,(P)
	GFST	(N,FSTPNT)	;GET FREE STORAGE
	MOVE	NA,1(N)		;GET NEXT POINTER
	MOVEM	NA,FSTPNT	;KEEP FREE LIST HONEST
	MOVSI	NA,(PN)		;SOURCE
	HRR	NA,N		;DESTINATION
	BLT	NA,4(N)		;COPY NAME AND DEFINITION TO NEW BLOCK
	HLLZS	1(N)		;CLEAR LINK ADDRESS
	MOVE	NA,(P)		;GET OFFSET
	ADDM	NA,4(N)		;ADD TO THIS BLOCK.  POINTS AT OLD DEFINITION
	PUSH	P,N		;SAVE BLOCK ADDRESS.
	MOVE	N,(PN)		;SYMBOL NAME
	IDIVI	N,HASH
	MOVM	NA,NA		;HASH VALUE
	HRRZ	N,MACRT1(NA)	;INSERT IN FRONT OF PERMANENT DEFINITIONS
	PUSH	P,N		;TARGET ADDRESS - A PERMANENT DEF.
	MOVEI	N,MACRT-1(NA)	;PREVIOUS ADDRESS
SEAR4B:	MOVEI	NA,(N)
	HRRZ	N,1(NA)		;GET NEXT ADDRESS
	CAME	N,(P)		;MATCHES THE PERMANENT DEFINITION?
	JUMPN	N,SEAR4B	;NO MATCH.  LOOP WHILE THERE'S STILL A LIST
	CAME	N,(P)		;MAKE SURE WE'RE WINNING.
	ERROR	[ASCIZ/FAIL BUG IN SEARCH /]
	SUB	P,[1,,1]	;THROW AWAY ADDRESS
	POP	P,L		;ADDRESS OF MACRO HEADER BLOCK
	HRRM	N,1(L)		;MAKE THIS BLOCK POINT TO PERMANENT DEFS.
	HRRM	L,1(NA)		;AND INSERT THIS NEW MACRO BLK ADDR INTO LIST.
	HLRZ	N,@4(L)		;LENGTH OF MACRO DEFINTION
	ADD	N,MTBPNT	;LAST ADDRESS OF DESTINATION+1
LEG	SETZM	-1(N)		;MAKE SURE ADDRESS EXISTS
	HRLZ	NA,4(L)		;ADDRESS OF MACRO DEFINITION (SOURCE)
	HRR	NA,MTBPNT	;ADDRESS OF MACRO FREE STORAGE. (DESTINATION)
	HRRM	NA,4(L)		;STORE NEW ADDRESS OF MACRO DEFINITION.
	BLT	NA,-1(N)
	HRRM	L,@MTBPNT	;STORE BACK POINTER IN MACRO DEFINITION
	MOVEM	N,MTBPNT	;UPDATE FREE STG POINTER
	JRST	SEAR4A
;	SEARCH	- CONTINUED. FIND AND READ A SUITABLE FUN FILE

SRTRD:	PUSH	P,L		;SAVE NAME OF THIS UNIVERSAL TABLE.
	TRNN	B,LFPF		;TERMINATED BY LEFT PARENS?
	JRST	SRTRD1		;NO.  THIS MEANS WE TAKE <NAME>.FUN AS THE FILE
	TLZ	SFL		;ADVANCE OVER THE PARENS

;THIS USES THE SAME SCANNER AS THE COMMAND LINE SCANNER!  MODIFIERS BEWARE!!
;CODE COPIED FROM .LOAD

	PUSH	P,CP		;THIS GETS CLOBBERED AND IT'S SLIGHTLY NECESSARY
	PUSH	P,O		;THIS MAY BE NEEDED
	PUSH	P,FNREAD	;SAVE NORMAL COMMAND LINE READER.
	MOVE	N,[PUSHJ P,AFSCAN]
	MOVEM	N,FNREAD
ITS,<		PUSH	P,LIMBO	>
	SETZM	UNVGTE#		;NO ERROR YET
NOTNX,<	MOVSI	1,'DSK'		;ASSUMED DEVICE
	SETZB	5,4		;NO ASSUMPTION ABOUT FILE NAME OR PPN
	MOVSI	3,'FUN'		;ASSUME EXT

;GETFIL CALLS SCAN1.  CLOBBERS AC'S 0-13.
;0 IS SETUP CORRECTLY
;1,2,4,5,6,13 ARE CONSIDERED SCRATCH (T,FS,N,NA,PN,TAC)
;10,11 (B,C) ARE SET CORRECTLY TO LAST CHARACTER SEEN
;3,7 (O,CP) ARE PRESERVED BY PUSHING AND POPPING

	JSR	GETFIL		;GET A FILE NAME
>;NOTNX

TNX,<	HRROI	1,[ASCIZ/DSK/]
	MOVEM	1,GTDEV		;DEFAULT DEVICE
	HRROI	1,[ASCIZ/FUN/]
	MOVEM	1,GTEXT		;DEFAULT EXTENSION
	JSR	TGETF		;READ USER'S SPEC INTO GTNAM
>;TNX

	CAIA			;ERROR
	TRNN	B,RTPF		;TERMINATED BY RIGHT PARENS?
	SETOM	UNVGTE		;ERROR

TNX,<	MOVEI	2,0
	IDPB	2,1		;TERMINATE NAME WITH A NULL >;TNX

	MOVE	PN,O		;PN _ EXTENSION
ITS,<		POP	P,LIMBO		>
	POP	P,FNREAD
	POP	P,O
	POP	P,CP
	SKIPE	UNVGTE			;ANY ERROR?
	JRST	SRCER2			;YES, COMPLAIN.

;1=T=DEVICE, 5=NA=FILE, 6=PN=EXT, 4=N=PPN
	PUSHJ	P,UNVOPN		;OPEN DEVICE.
	JRST	SRCER1			;NOT FOUND
SRTRD0:	POP	P,L			;GET NAME OF UNIVERSAL TABLE.
	MOVEM	L,(N)			;STORE IT (NEED NOT BE SAME AS IN FILE)
	MOVE	PN,UNIVLH		;GET LIST HEADER
	HRRM	PN,1(N)			;STORE IT INTO NEW UNIV TABLE
	HRRZM	N,UNIVLH		;AND STORE NEW UNIV ADDRESS IN LIST HEAD
	JRST	SEAR1A			;WE DID IT.  NOW PROCESS AS NORMAL

;HERE WHEN "SEARCH FOO" APPEARS.  LOOK FOR FOO.UNV ON DSK:,SYS: UNV:
SRTRD1:	MOVE	NA,L			;GET THE SOUGHT NAME INTO NA
	TLNE	NA,770000
	JRST	.+3			;JUMP WHEN LEFT ADJUSTED
	LSH	NA,6
	JRST	.-3			;LOOP UNTIL LEFT ADJUSTED
NOTNX,<	MOVSI	PN,'FUN'		;SET UP EXTENSION
	MOVEI	N,0			;PPN=0
>;NOTNX
TNX,<	HRROI	PN,[ASCIZ/FUN/]
	MOVEM	PN,GTEXT
	MOVE	1,NA
	MOVE	2,[POINT 7,GTNAM]
	PUSHJ	P,UNXNM		;COPY FILE NAME TO GTNAM IN ASCII
	IDPB	1,2		;TERMINATE WITH NULL
>;TNX
	MOVSI	FS,-SRDVTL
SRTRD2:	MOVE	T,SRDVTB(FS)		;GET A DEVICE NAME
TNX,<	MOVEM	T,GTDEV			;SAVE DEVICE NAME>;TNX
	PUSHJ	P,UNVOPN		;OPEN THE DEVICE
	JRST	SRTRD3			;NOT THERE
	JRST	SRTRD0			;WE HAVE IT.

SRTRD3:	AOBJN	FS,SRTRD2
	ERROR	[ASCIZ/NO SUCH UNIVERSAL TABLE/]
SRCERR:	POP	P,L			;LOSE. RESET STACK
	JRST	SERCON


NOTNX,<	DEFINE	UNVDVM(A)<SIXBIT/A/> >;NOTNX
TNX,<	DEFINE	UNVDVM(A)<-1,,[ASCIZ/A/]> >;TNX
SRDVTB:
	FOR ZOT IN (DSK,UNV,SYS) <
	UNVDVM(ZOT) >
SRDVTL__.-SRDVTB

SRCER1:	ERROR	[ASCIZ/BINARY UNIVERSAL FILE (OR DEVICE) COULD NOT BE FOUND/]
	JRST	SRCERR

SRCER2:	ERROR	[ASCIZ/CAN'T PARSE FILE NAME/]
	JRST	SRCERR

NOTNX,<

SRCTMP:	BLOCK	4

;ENTER WITH 2=DEVICE, 5=FILE, 6=EXT, 4=PPN
UNVOPN:	MOVEM	T,SRCTMP+1
	MOVEI	T,17
	MOVEM	T,SRCTMP
	SETZM	SRCTMP+2
	OPEN	1,SRCTMP		;TRY TO OPEN DEVICE
	JRST	UNVRD3
	MOVEM	NA,SRCTMP
	HLLZM	PN,SRCTMP+1
	SETZM	SRCTMP+2
	MOVEM	N,SRCTMP+3
	LOOKUP	1,SRCTMP
	JRST	UNVRD3			;FAIL
	HLRES	SRCTMP+3		;FORM -WC IN SRCTMP+3  RPH/REG 11/25/74
UNVRD0:	MOVE	T,MTBPNT		;GET FREE STORAGE ADDRESS
	SUB	T,SRCTMP+3		;CALCULATE NEXT FREE ADDRESS
	CAMG	T,.JBREL
	JRST	UNVRD1			;IS OK
	PUSHJ	P,COEXP
	JRST	UNVRD0			;LOOP UNTIL BIG ENOUGH

UNVRD1:	HRL	T,SRCTMP+3		;GET -WC
	HRR	T,MTBPNT
	SUBI	T,1
	MOVEM	T,SRCTMP		;STORE IOWD
	SETZM	SRCTMP+1		;STOP COMMAND LIST
	INPUT	1,SRCTMP
	STATZ	1,740000
	JRST	UNVRD2			;INPUT ERROR
	MOVE	N,MTBPNT		;GET FREE STORAGE ADDRESS
	SUB	N,SRCTMP+3		;CALCULATE NEXT FREE ADDRESS
	EXCH	N,MTBPNT		;ADVANCE FS.  GET POINTER TO UNIV. TABLE
	AOS	(P)
UNVRD2:	CLOSE	1,
UNVRD3:	RELEAS	1,
	POPJ	P,
>;NOTNX

TNX,<
;DEVICE NAME, EXTENSION IN GTDEV, GTEXT.  FILE STRING IN GTNAM

UNVOPN:	PUSH	P,FS
	MOVEI	1,GTTBL			;PARAMETERS FOR LONG GTJFN
	HRROI	2,GTNAM			;STRING FROM USER OR FILE NAME
	MOVSI	3,100000		;ACCESS OLD FILE
	MOVEM	3,(1)			;FLAGS IN PARAM BLOCK
	SETZM	UNVJFN			;NO JFN YET
	GTJFN				;GET A HANDLE ON FILE.
	JRST	UNVOPX			;NO SUCH FILE (OR DEVICE) ETC.
	HRRZM	1,UNVJFN		;SAVE JFN
	MOVE	2,[447400,,200000]	;READ ACCESS IN DUMP MODE
	OPENF				;OPEN FILE
	JRST	UNVOPX			;ERROR
	HRRZ	1,UNVJFN
	MOVE	2,[1,,12]		;GET SIZE OF FILE IN WORDS
	MOVEI	3,5
	GTFDB				;SIZE OF FILE TO 4
	MOVE	T,MTBPNT
	ADDI	T,(5)
LEG	SETZM	(T)			;REFERENCE CORE/EXPAND CORE
	MOVN	3,5
	HRL	3,3			;-WC IN LEFT HALF
	HRR	3,MTBPNT
	SUBI	3,1			;MA-1 IN RIGHT.
	MOVEI	4,0			;COMMAND LIST IN 3 AND 4
	HRRZ	1,UNVJFN
	MOVEI	2,3			;POINTER TO COMMAND LIST
	DUMPI				;READ DUMP INPUT
	JRST	UNVOPX			;LOSE.
	AOS	-1(P)			;WIN
	MOVE	N,MTBPNT
	ADD	N,5
	EXCH	N,MTBPNT		;ADVANCE FS POINTER.  RETURN 
					;POINTER TO NEW UNIV. BLOCK
UNVOPX:	SETZM	GTDEV			;RESTORE DEVICE NAME TO DEFAULT
	HRRZ	1,UNVJFN		;IS THIS JFN STILL HERE?
	JUMPE	1,UNVOPY		;NO.
	CLOSF				;CLOSE AND RELEASE JFN
	CAIA
	SETZM	UNVJFN
	SKIPE	1,UNVJFN
	RLJFN				;RELEAS
	JFCL
	SETZM	UNVJFN
UNVOPY:	POP	P,FS
	POPJ	P,
>;TNX
;	HERE IS A MACRO FOR TITLE, SUBTTL, UNIVERSAL
	DEFINE TIT $(TITCNT,Q,EXTRA,X1)
<	MOVE T,[POINT 7,TITCNT+1]
IFN X1,<
	MOVEI	FS,0
TLOP:	PUSHJ	P,SCAN1		;GET CHARACTER
	JUMPGE	B,TPOL		;JUMP IF NOT NUM OR LET
	LSH	FS,6		;ACCUMULATE SIXBIT
	ORI	FS,(B)
	TLNE	FS,770000	;6 CHARACTERS YET?
	JRST	TPOL		;YES
	IDPB	C,T		;NOT YET. STUFF THE ASCII
	JRST	TLOP	

TPOL:	AOSE TITLSW
	ERROR [ASCIZ /TWO TITLE STATEMENTS, OR TITLE APPEARS AFTER CODE EMITTED/]
	SKIPL RPGSW
	JRST TPOL1
	PUSH P,C
	PUSH P,T
	IDPB C,T
	MOVEI C,15
	IDPB C,T
	MOVEI C,12
	IDPB C,T
	MOVEI C,0
	IDPB C,T
	OUTSTR	[ASCIZ /FAIL:  /]
	OUTSTR	TITCNT+1
	POP P,T
	POP P,C
TPOL1:	MOVEM FS,BNAM		;DEPOSIT BLOCK NAME
	MOVEM FS,LSTLAB+3
	PUSHJ P,R5CON
	MOVEM FS,TPOL3		;SAVE RADIX50 FOR NAME BLOCK OUTPUT
	JRST TLOP$Q+1
>;IFN X1
TLOP$Q:	PUSHJ P,SCAN1	;GET CHR.
	TLNE B,CRFG	;CR?
	JRST .+3	;YES
	IDPB C,T	;DEPOSIT
	JRST TLOP$Q
	EXTRA
	MOVEI N,
	REPEAT 5,<	IDPB N,T>
	SUBI T,TITCNT+1	;FORM COUNT
	MOVNS T		;NEGATE
	HRLM T,TITCNT	;DEPOSIT
	JRST SCR
>
;	TITLE, UNIVERSAL, SUBTTL, GLOBAL

^%UNIV:	SETOM	UNIVSW		;SET FLAG FOR THIS BEING A UNIVERSAL ASSEMBLY
	SETZM	UASUPF		;NOT DOING UNIVERSAL-ASUPPRESS YET
^%TITLE:
	TIT(TITCNT,1,,1)


^%SUB:	TIT(SUBCNT,A,<NOTNX,<MOVEI N,15
	IDPB N,T
	MOVEI NA,12
	IDPB NA,T
	IDPB N,T
	IDPB NA,T>;NOTNX
TNX,<	MOVEI	N,11
	IDPB	N,T
	IDPB	N,T>;NTX
				>,0)

^%GLOB:	PUSHJ P,SCANM	;GET IDENT
	TLNN IFLG	;IDENT?
	JRST NOIG	;NO
	MOVE N,L	;GET SIXBIT
	IDIVI N,HASH	;HASH
	MOVMS NA
	SKIPN PN,SYMTAB(NA);GET POINTER
	JRST GER1	;NONE
GSR:	SRC1(L,PN,FNDG,JRST GER1)
GER1:	ERROR[ASCIZ/GLOBAL -- NO PREVIOUS DEFINITION/]
	JRST CONTG

FNDG:	MOVE N,2(PN)	;GET FLAGS
	TLNE N,UDSF	;UDEFINED-DEFINED IS GOOD ENOUGH
	JRST GLDEF
	TLNE N,DEFFL	;DEFINED?
	JRST GSR+2	;NO, TRY AGAIN
GLDEF:	OR N,BLOCK	;TURN ON BLOCK BIT
	TLNN N,DAF	;DOWN ARROW?
	TLO N,GLOBF	;NO, SET GLOBAL
	MOVEM N,2(PN)	;RESTORE FLAGS
CONTG:	TRNN B,COMF	;, NEXT?
	JRST SPCFN	;NO, DONE
	TLZ SFL		;SKIP THE ,
	JRST %GLOB	;CONTINUE

NOIG:	ERROR[ASCIZ/NOT IDENT AFTER GLOBAL/]
	JRST NSPCFN
;	EXTERN, INTERN, PAGE, LALL, XALL, NOSYM, NOLIT, CREF, XCREF
^%EXT:	PUSHJ P,SCANS	;GET IDENT
	TLNN IFLG	;IDENT?
	JRST NOIE	;NO
	MOVE T,2(PN)	;GET FLAGS
	TLNN T,DEFFL	;DEFINED?
	JRST EER1	;YES
	TLNE T,INTF
	JRST EER2
	TLO T,EXTF	;TURN ON EXT FLAG
	MOVEM T,2(PN)	;DEPOSIT
CONTE:	TRNN B,COMF	;, NEXT?
	JRST SPCFN	;NO, DONE
	TLZ SFL		;SKIP THE ,
	JRST %EXT
EER1:	ERROR[ASCIZ/EXTERNAL -- ALREADY DEFINED/]
	JRST CONTE
EER2:	ERROR [ASCIZ /EXTERNAL -- ALREADY INTERNAL/]
	JRST CONTE
NOIE:	ERROR[ASCIZ/NOT IDENT AFTER EXTERN/]
	JRST NSPCFN

^%INT:	PUSHJ P,SCANS	;GET IDENT
	TLNN IFLG	;IDENT?
	JRST NOII	;NO
	MOVE T,2(PN)
	TLNE T,EXTF
	JRST IER1
	TLO T,INTF
	MOVEM T,2(PN)
CONTI:	TRNN B,COMF	;, NEXT?
	JRST SPCFN	;NO
	TLZ SFL		;YES, SKIP THE ,
	JRST %INT
IER1:	ERROR [ASCIZ /INTERNAL -- ALREADY EXTERNAL/]
	JRST CONTI
NOII:	ERROR[ASCIZ/NOT IDENT AFTER INTERN/]
	JRST NSPCFN

^%PAGE:	MOVEI TAC,14
	IDPB TAC,LSTPNT
	JRST SPCFN

^%LALL:	JUMPL N,LAL
	SETZM NOEXP
	JRST SPCFN
LAL:	SETOM NOEXP
	JRST SPCFN

^%NOSYM:SETZM SYMOUT
	JRST SPCFN

^%NOLIT:SETOM NOLTSW
	JRST SPCFN

^%ONCRF:SKIPE CREFSW
	SETOM XCRFSW
	JRST SPCFN

^%OFCRF:SETZM XCRFSW
	JRST SPCFN
;	INTEGER, ARRAY, .COMMON
^%INTEG:PUSHJ P,SCANS	;GET A SYMBOL
	TLNN IFLG
	JRST NOII2	;NOT IDENT
	MOVE T,2(PN)
	TLON T,UDSF!VARF	;SET FLAGS
	TLNN T,DEFFL
	JRST NXT	;BUT IGNORE IF DEFINED
	MOVEM T,2(PN)
	GFST TAC,FSTPNT	;GET FREE BLOCK
	MOVE T,VARLST
	MOVEM TAC,VARLST
	EXCH T,1(TAC)
	MOVEM T,FSTPNT
	MOVEM PN,(TAC)
	SETZM 2(TAC)	;ONE WORD
NXT:	TRNN B,COMF	;IS IT A COMMA NEXT
	JRST SPCFN	;GO AWAY
	TLZ SFL		;GET PAST IT
	JRST %INTEG	;AND TRY FOR MORE
NOII2:	ERROR [ASCIZ /NOT IDENT AFTER INTEGER/]
	JRST NSPCFN

^%ARAY:	SETZM ARCNT#	;NUMBER OF THINGS PUSHED INTO STACK
%ARAY1:	PUSHJ P,SCANS	;GET A SYMBOL
	TLNN IFLG
	JRST NOAR	;NOT IDENT SO LOSE
	MOVE T,2(PN)	;CHECK FLAGS
	TLON T,UDSF!VARF
	TLNN T,DEFFL
	ERROR [ASCIZ /ARRAY NAME ALREADY DEFINED/]
	MOVEM T,2(PN)	;BUT THEM BACK
	GFST TAC,FSTPNT
	MOVE T,VARLST
	MOVEM TAC,VARLST
	EXCH T,1(TAC)
	MOVEM T,FSTPNT
	MOVEM PN,(TAC)
	PUSH P,TAC
	AOS ARCNT
	TLNE B,LBRF	;CHECK FOR < OR [
	TRNN B,TP1F	;AND THEN MAKE SURE OF [
	JRST ARR3
	TLZ SFL		;STOP SCANNING AHED
	TRO NOFXF
	PUSHJ P,MEVAL
	TRNN NA,17
	TLNE UNDF!ESPF	;CHECK SPECIAL OR UNDEF
	JRST ARAYER
	SUBI N,1	;STORE ONE LESS
ARRY:	POP P,TAC	;GET BACK A POINTER
	MOVEM N,2(TAC)
	SOSLE ARCNT
	JRST ARRY	;GET MORE
	TLNE B,RBRF
	TRNN B,TP1F
	JRST ARR2
	PUSHJ P,SCAN
	TRNN B,COMF
	JRST SPCFN
	TLZ SFL
	JRST %ARAY
ARR3:	TRNN B,COMF
	JRST ARR1
	TLZ SFL
	JRST %ARAY1	;GO GET ANOTHER NAME

ARR1:	ERROR [ASCIZ /NEED [ AFTER ID IN ARRAY OR COMMON/]
	JRST COMAER	;GO GET STUFF OFF STACK

ARAYER:	ERROR [ASCIZ /ILLEGAL EXPRESSION AFTER [/]
	JRST COMAER

ARR2:	ERROR [ASCIZ /NO ] AFTER EXPRESSION/]
	JRST COMAER

NOAR:	ERROR [ASCIZ /NEED IDENT/]
	JRST COMAER

	POP P,TAC
COMAER:	SOSL ARCNT
	JRST .-2
	JRST NSPCFN

^%COMMN:			;.COMMON
	SETZM	ARCNT#		;NUMBER OF THINGS PUSHED INTO STACK
COMM1:	PUSHJ	P,SCANM		;GET A SYMBOL (ALLOW MACRO EXPANSION)
	TLNN	IFLG
	JRST	NOAR		;NOT IDENT SO LOSE
	MOVE	FS,L		;GET SIXBIT NAME
	PUSHJ	P,R5CON		;CONVERT TO RADIX50
	PUSH	P,FS		;SAVE RADIX50 NAME ON STACK.
	AOS	ARCNT		;COUNT NUMBER OF THINGS PUSHED.
	TLNE	B,LBRF		;CHECK FOR < OR [
	TRNN	B,TP1F		;AND THEN MAKE SURE OF [
	JRST	COMM3		;PERHAPS A COMMA
	TLZ	SFL		;STOP SCANNING AHEAD
	TRO	NOFXF		;DON'T GENERATE FIXUPS
	PUSHJ	P,MEVAL		;GET EXPRESSION
	TRNN	NA,17
	TLNE	UNDF!ESPF	;CHECK SPECIAL OR UNDEF
	JRST	ARAYER
	MOVEM	N,COMMB2	;SAVE VALUE
	TLNE	B,RBRF
	TRNN	B,TP1F
	JRST	ARR2		;FAILED TO TERMINATE WITH ]
COMM2:	POP	P,COMMB1	;STORE RADIX50 NAME INTO LOADER BLOCK.
	POUT	4,COMMB		;SEND COMMON BLOCK TO LOADER
	SOSLE	ARCNT		;COUNT DOWN, POPPING STACK
	JRST	COMM2		;GET MORE
	PUSHJ	P,SCAN		;SCAN NEXT CHARACTER
	TRNN	B,COMF		;COMMA?
	JRST	SPCFN		;NO. WE'RE DONE.
	TLZ	SFL		;SKIP THE COMMA
	JRST	%COMMN		;BACK TO THE TOP.

COMM3:	TRNN	B,COMF		;COMMA BETWEEN NAMES?
	JRST	ARR1		;NO.
	TLZ	SFL		;YES.  SKIP COMMA.
	JRST	COMM1		;GO GET ANOTHER NAME

COMMB:	20,,2			;BLOCK TYPE 20. 2 WORDS
	0			;ZERO RELOCATION BITS
COMMB1:	0			;STORE COMMON NAME HERE
COMMB2:	0			;AND BLOCK SIZE HERE
;	ENTRY
	BEGIN ENTRY
^^%ENTRY:
	SKIPE CODEM	;WAS CODE EMITTED?
	ERROR [ASCIZ /ENTRY AFTER CODE EMITTED/]
	PUSH P,BC	;USE THIS REGISTER AS AOBJN POINTER
	MOVE BC,[XWD -=18,ENTBLK]	;FOR STORING ENTRIES
ENTR1:	PUSHJ P,SCANS	;FIND A SYMBOL
	TLNN IFLG	;WAS THERE A SYMBOL THERE?
	JRST NOII	;NO, GIVE ERROR
	MOVSI T,INTF	;SET AS INTERNAL
	ORM T,2(PN)	;INTO FLAGS
	MOVE FS,(PN)	;GET THE SIXBIT FOR THIS ONE
	PUSHJ P,R5CON	;CONVERT TO RADIX50
	MOVEM FS,(BC)	;PUT INTO ENTRY BLOCK
	AOBJP BC,EMIT	;PUT OUT BLOCK IF OUT OF ROOM
GOENT:	TRNN B,COMF	;COMMA FOLLOWING?
	JRST ENDENT	;ALL DONE
	TLZ SFL		;SET TO IGNORE COMMA
	JRST ENTR1	;AND GET MORE

ENDENT:	HLRZ TAC,BC	;GET THE CURRENT COUNT
	CAIN TAC,-=18	;SEE IF ANY HAVE BEEN PUT IN
	JRST FINENT	;NO, MUST HAVE BEEN A MULTIPLE OF 18
	ADDI TAC,=18	;GET COUNT (IF YOU IGNORE LEFT HALF
	HRRM TAC,ENTWHO	;PUT IN BLOCK HEADER
	ADDI TAC,2
	MOVNS TAC
	HRLM TAC,ENTHD	;AND -COUNT INTO OUTPUT POINTER
	BBOUT ENTHD	;DO THE OUTPUT
FINENT:	POP P,BC	;RESTORE THIS
	SETZM WRD+1	;TELL THEM NOTHING THERE
	JRST SPCFN	;FINISH UP LINE

NOII:	ERROR [ASCIZ /NOT IDENT AFTER ENTRY/]
	JRST FINENT	;FINISH UP

EMIT:	MOVE TAC,[XWD -=20,ENTWHO]	;AMOUTN TO DUMP
	MOVEM TAC, ENTHD
	MOVEI TAC,=18	;NUMBER OF WORDS IN THE BLOCK
	HRRM TAC,ENTWHO	;INTO BLOCK HEADER
	BBOUT ENTHD	;OUTPUT IT
	MOVE BC,[XWD -=18,ENTBLK]
	JRST GOENT	;AND CONTINUE

ENTHD:	ENTWHO
ENTWHO:	XWD 4,0
	0	;RELOCATION BITS
ENTBLK:	BLOCK =18

BEND ENTRY
;	LINK, LINKEND

^%ENDL:	PUSHJ P,BFFRC	;FORCE OUT BINARY AND FIXUPS
	TRO NOFXF
	PUSHJ P,MEVAL
	MOVNS N		;USE NEGATIVE OF NUMBER
	JRST LINK1	;GO CHECK AND GET REST OF JUNK

^%LINK:	PUSHJ P,BFRC	;FORCE OUT BINARY AND FIXUPS
	TRO NOFXF
	PUSHJ P,MEVAL
LINK1:	TLNN ESPF!UNDF
	TRNE NA,17	;IF SPECIAL CHR OR UNDEF EXPR
	JRST LNKERR	;GIVE ERROR MESSAGE
	MOVEM N,LNKNUM	;STORE NUMBER FOR OUTPUT
	TRNN B,COMF	;THERE SHOULD BE A COMMA THERE
	ERROR [ASCIZ /NO COMMA AFTER LINK NUMBER/]
	TLZ SFL		;SKIP THE COMMA
	PUSHJ P,MEVAL	;GET THE ADDRESS
	TLNE UNDF!ESPF
	JRST LNKERR	;UNDEF OR SPECIAL NOT PERMITTED
	DPB NA,[POINT 1,LKRLC,3]	;PUT IN RELOC BIT
	HRRZM N,LNKADR	;AND ADDRESS
	POUT 4,LNKBLK	;OUTPUT IT
	SKIPA
LNKERR:	ERROR [ASCIZ /NOT EXPRESSION AFTER LINK OR LINKEND/]
	SETZM WRD+1	;RETURN NOTHING
	JRST SPCFN	;DONE

LNKBLK:	XWD 12,2	;HEADER
LKRLC:	0		;RELOC BITS
LNKNUM:	0		;NUMBER OF LINK
LNKADR:	0		;ADDRESS OF LINK
;	RADIX50	PRINTX PRINTC .FATAL
^%RAD5:	TRO	NOFXF
	PUSHJ	P,MEVAL			;GET NUMBER
	TRNN	NA,17
	TLNE	UNDF!ESPF		;IF UNDEF OR SPECIAL CHR
	JRST	RAD5ER
	TRNN	B,COMF
	ERROR	[ASCIZ /NO COMMA AFTER RADIX50/]
	LSH	N,-2			;JUSTIFY
	DPB	N,[POINT 4,WRD,3]	;SAVE IN WORD
	TLZ	SFL			;IGNORE COMMA
	PUSHJ	P,SCAN			;GET IDENT
	TLNN	IFLG
	ERROR	[ASCIZ /NO IDENT AFTER RADIX50/]
	MOVE	FS,L			;GET SIXBIT
	PUSHJ	P,R5CON			;AND CONVERT
	IORM	FS,WRD			;PUT IN
	MOVSI	N,NONEM			;THERE IS SOMETHING THERE
	MOVEM	N,WRD+1			;WITH NO RELOC
	JRST	SPCFN			;AND AWAY WE GO

RAD5ER:	ERROR	[ASCIZ /NOT EXPRESSION AFTER RADIX50/]
	SETZM	WRD+1
	JRST	SPCFN

;TYPE THE ARGUMENT TO PRINTX WITH FILE NAME, PAGE NUMBER, ETC.
^%PRNTX:PUSHJ	P,ERRHED	;TYPE FILE NAME, ETC. ON TTY
	TLZ	SFL		;CLEAR SCANNER AHEAD. WE'RE TAKING THAT CHR.
PRNTX1:	OUTCHR	C
	TRZ	NOFXF
	PUSHJ	P,SCAN1		;GET CHR.
	TLNN	B,CRFG!RBRF	;CR, OR ], OR >?
	JRST	PRNTX1
	OUTSTR	TTCRLF
	TLNE	B,CRFG		;CR?
	JRST	SCR		;YES. 
	TLO	SFL		;SET SCANNER AHEAD TO RESCAN ] OR >
	PUSHJ	P,SCAN		;EXIT SCAN VIA SPCRET, DOING GOOD THINGS
	JRST	RBARET		;RETURN FROM ASSMBL FOR ] OR >

;TYPE THE ARGUMENT TO .FATAL AND DIE.

^%FATAL:OUTSTR	[ASCIZ/.FATAL /]
	TLZ	SFL		;MARK THAT WE'VE USED UP A CHARACTER
FATAL1:	OUTCHR	C
	TRZ	NOFXF
	PUSHJ	P,SCAN1		;GET CHR.
	TLNN	B,CRFG!RBRF	;CR, OR ], OR >?
	JRST	FATAL1		;NO. TYPE IT.
	OUTSTR	TTCRLF
	FATAL	[ASCIZ/.FATAL PSEUDO-OP ENCOUNTERED./]

;TYPE TEXT DELIMITED LIKE "ASCIZ" ON TERMINAL.
^%PRNTC:
	TLZ	SFL		;CLEAR SCAN AHEAD
	HRRM	C,PRNTC2	;SAVE TERM CHR IN INSTRUCTION

;IN CASE OF ACCIDENT, WE SAVE WHERE WE STARTED.
	SKIPN	C,TLBLK		;GET SOS LINE NUMBER
	HRRO	C,INLINE	;NONE. USE OUR COUNT
	MOVEM	C,TXLIN		;SAVE AS LINE NUMBER WHERE TEXT PSEUDO-OP BEGINS
	MOVE	C,PGNM		;GET PAGE NUMBER
	MOVEM	C,TXTPG		;SAVE PAGE WHERE TEXT PSEUDO-OP BEGINS

NOTNX,<	MOVE	C,[FILNM,,TXTFIL]
	BLT	C,TXTFIL+4	;SAVE CURRENT FILE NAME >;NOTNX

TNX,<	MOVE	C,JFNTBL
	MOVEM	C,TXTFIL	;SAVE INPUT JFN 	>;TNX

PRNTC1:	PUSHJ	P,SCAN1		;GET CHR.
PRNTC2:	CAIN	C,		;TERM CHR? (ADDRESS PART CLOBBERED)
	JRST	PRNTC3		;YES
	OUTCHR	C		;NO. TYPE IT.
	JRST	PRNTC1

PRNTC3:	SETZM	TXTPG		;CLEAR STATE OF BEING INSIDE TEXT-OP
	JRST	SPCFN
;	ASSIGN	FOR TENEX (RST 9 MARCH 70) (NOT SUPPORTED BY OLD LOADER!)
;	FOR TENEX, THIS IS ASSIGN, ELSEWHERE, .ASSIGN

;SYNTAX IS:   ASSIGN ID1,ID2,EXP
;EXP IS OPTIONAL (1 IS THE DEFAULT).
;THE EFFECT IS TO ASSIGN THE VALUE OF ID1 TO ID2 AND THEN TO INCREMENT THE
;VALUE OF ID1 BY EXP.


ASHED:	-5,,ASWHO
ASWHO:	100,,3
	0
ASBLK:	BLOCK 3

ASSNE1:	ERROR	[ASCIZ/NO IDENT/]
	JRST	NSPCFN

ASSNE2:	ERROR	[ASCIZ/ALREADY DEFINED/]
	JRST	NSPCFN

ASSNE3:	ERROR	[ASCIZ/NEED COMMA/]
	JRST	NSPCFN

^%ASSIG:
	PUSHJ	P,BFFRC			;FORCE OUT ANY BINARY AND FIXUPS
	PUSHJ	P,SCANS			;GET IDENT
	TLNN	IFLG			;IS IDENT NEXT?
	JRST	ASSNE1
	MOVE	T,2(PN)			;GET FLAGS FOR THIS IDENT
	TLNN	T,DEFFL			;ALREADY DEFINED?
	JRST	ASSNE2
	TLO	T,EXTF			;MAKE IT EXTERNAL
	MOVEM	T,2(PN)
	TRNN	B,COMF			;WAS IDENT TERMINATED BY COMMA?
	JRST	ASSNE3
	MOVE	FS,(PN)			;GET SYMBOL
	PUSHJ	P,R5CON			;CONVERT TO RADIX 50
	MOVEM	FS,ASBLK		;PUT IN BLOCK FOR OUTPUT
	TLZ	SFL			;SKIP OVER THE COMMA
	PUSHJ	P,SCANM			;GET SECOND IDENT
	MOVE	FS,L
	PUSHJ	P,R5CON			;CONVERT TO RADIX 50
	MOVEM	FS,ASBLK+1
	MOVEI	N,1			;DEFAULT INCREMENT IS 1
	TRNN	B,COMF			;IF NO COMMA
	JRST	ASGN1
	TLZ	SFL			;SKIP THE COMMA
	TRO	NOFXF			;NO FIXUPS ALLOWED
	PUSHJ	P,MEVAL			;EVALUATE THE EXPRESSION
	TRNN	NA,17			;MUST NOT BE RELOCATED
	TLNE	UNDF!ESPF		;OR UNDEFINED OR SPECIAL RELOCATION
	JRST	PER1			;IF IT IS, OUTPUT ERROR MESSAGE
ASGN1:	MOVEM	N,ASBLK+2		;STORE SIZE IN BLOCK FOR OUTPUT
	BBOUT	ASHED			;OUTPUT THE BLOCK
	JRST	SPCFN			;AND CONTINUE
;	.DIRECT

DIRCO1:	ERROR	[ASCIZ/UNKNOWN FUNCTION NAME/]
DIRCON:	TRNN	B,COMF		;HERE TO CONTINUE SCAN.  COMMA NEXT?
	JRST	SPCFN		;NO. DONE
	TLZ	SFL		;SKIP THE COMMA
^%DIREC:
	PUSHJ	P,SCANM		;GET AN ID NAME
	TLNN	IFLG		;IDENT?
	JRST	PNOI		;NO. LOSE  "NOT IDENT"
	MOVSI	N,-DIRTLN
	CAME	L,DIRTBL(N)
	AOBJN	N,.-1
	JUMPGE	N,DIRCO1
	XCT	DIRTB2(N)
	JRST	DIRCON

DIRTBL:	'  KA10'		;DENOTE CODE TO RUN ON KA10 ONLY
	'  KI10'		;DENOTE CODE TO RUN ON KI10 ONLY
	'.ITABM'		;
	'.XTABM'		;IGNORE TABS AND BLANKS IN MACRO ARGS,
	'.NOBIN'		;NO BINARY OUTPUT
	'.NOUNV'		;NO BINARY UNIVERSAL OUTPUT
DIRTLN__.-DIRTBL

DIRTB2:	PUSHJ	P,DIRSTA	;KA10
	PUSHJ	P,DIRSTI	;KI10
	SETZM	TABMSW		;.ITABM
	SETOM	TABMSW		;.XTABM
	PUSHJ	P,DIRBSP	;.NOBIN
	SETOM	FUNSUP		;.NOUNV - SUPPRESS FUN FILE

DIRSTA:	SKIPA	N,[1]		;SET KA10
DIRSTI:	MOVEI	N,2		;SET KI10
	DPB	N,[POINT 6,TPOL4,5]	;STORE WHERE TITLE OUTPUT WILL DO IT.
	SKIPLE	TITLSW		;TITLE OUTPUT ALREADY?
	ERROR	[ASCIZ/KA10 OR KI10 DIRECTIVE MUST PRECEDE CODE EMISSION/]
	POPJ	P,

DIRBSP:	TRZN	BDEV		;CLEAR BINARY DEVICE
	POPJ	P,
NOTNX,<
	CLOSE	3,1		;CLOSE OUTPUT.  SUPRRESS CLOSE OUTPUT
	RELEAS	3,1		;RELEASE FILE.  SUPPRESS CLOSE OUTPUT
>;NOTNX
TNX,<
	HRRZ	1,JFNTBL-2+3	;JFN FOR BINARY FILE
	TLO	1,400000	;DON'T RELEASE JFN
	CLOSF
	JRST	DIRBXX
	HRRZ	1,JFNTBL-2+3
	SETZM	JFNTBL-2+3
	DELF
DIRBXX:	PUSHJ	P,[ERROR [ASCIZ/(Can't delete binary file.)/]
		POPJ P,]
>;TNX
	POPJ	P,

BEND POPS
	SUBTTL	MAIN: THIS HERE IS THE ASSEMBLER

MAINQ:	MOVE	N,PCNT+1	;GET RELOC
	MOVEM	N,DPCNT+1	;AND SET RELOC OF .
	MOVE	N,PCNT
	MOVEM	N,DPCNT
MAIN:	TLZ	OPFLG!MLFT
	ACALL			;CALL ASSMBL
	SKIPN	WRD+1		;ANYTHING ON LINE?
	JRST	MAINQ		;NO, NOTHING
	OUTP	WRD		;OUTPUT THE STUFF
	AOS	OPCNT		;INCREMENT
	MOVE	N,OPCNT
	CAMGE	N,BRK		;HIGH SEGMENT?
	JRST	MAIN.1		;NO,LOW SEGMENT
	CAML	N,HICNT		;YES. IS OPCNTHICNT?
	MOVEM	N,HICNT 	;YES. INCREMENT HIGH
	JRST	MAIN.2

MAIN.1:	CAML	N,@CURBRK	;IS OPCNTLOCNT?
	MOVEM	N,@CURBRK	;YES, INCREMENT LOW
MAIN.2:	AOS	N,PCNT		;INCREMENT
	MOVEM	N,DPCNT		;SET ADDRESS OF  .
	SKIPN	N,POLPNT	;ANY POLFIXES FOR NOW?
	JRST	MAIN		;NO
	SETZM	POLPNT		;CLEAR POINTER
	PUSHJ	P,BFRC		;FORCE OUT BIN
MAINL:	MOVEI	FS,5(N)		;SET UP POINTER
	MOVE	NA,1(N)		;GET NEXT PNTR.
	PUSHJ	P,POLOUT	;PUT OUT POLFIX
	SKIPN	N,NA		;ANY MORE?
	JRST	MAIN		;NO
	JRST	MAINL		;YES
BEGIN UUO  SUBTTL UUO HANDLER AND OUTPUT ROUTINES

^UUO:	0
	PUSH	P,TAC			;SAVE AN AC.
	LDB	TAC,[POINT 5,40,8]	;GET UUO #
	MOVE	TAC,UUOTB(TAC)		;GET DISPATCH ADDRESS
	EXCH	TAC,(P)			;RESTORE AC, PUT DISPATCH ADDRESS ON STACK
	PUSHJ	P,@(P)			;CALL ROUTINE
	SUB	P,[1,,1]		;REMOVE DISPATCH ADDR FROM STACK
	JRST	@UUO			;RETURN

UUOTB:			;UUO DISPATCH TABLE

NOTNX,<FOR I_0,10
<ILUUO
>>;NOTNX

TNX,<FOR I_0,6
<ILUUO
>
UOUTST
UOUTCH
>;TNX

UERR
UFAT
UFOUT
UOUTP
UPOUT
UTRAN
UBBOUT
UCREF6
UCRF66
UCREF7
FOR I_23,37
<ILUUO
>
ILUUO:	OUTSTR	[ASCIZ/ILLEGAL USER UUO
/]
	JRST	4,CPOPJ

BEND UUO
; BINARY I/O HANDLING ROUTINES


BEGIN BIO
^BBLK:	XWD	1,0
	BLOCK	23
^FBLK:	XWD	10,0
	BLOCK	23

^UOUTP:	JUMPN	BC,NOINI		;NOT FIRST WORD?
	MOVE	TAC,OPCNT		;GET OUTPUT ADDRESS
	MOVEM	TAC,BBLK+2		;STORE
	MOVE	TAC,OPCNT+1		;GET RELOCATION
	LSH	TAC,2			;SHIFT
	MOVEM	TAC,BBLK+1		;STORE
	MOVE	BC,[XWD -21,BBLK+3]
NOINI:	MOVE	TAC,@40			;GET WORD
	MOVEM	TAC,(BC)		;STORE
	AOS	40
	MOVE	TAC,@40			;GET RELOC
	DPB	TAC,[POINT 1,TAC,34]
	LDB	TAC,[POINT 2,TAC,34]
	OR	TAC,BBLK+1		;OR IN
	AOBJP	BC,FULL			;FULL?
	LSH	TAC,2			;NO
	MOVEM	TAC,BBLK+1		;STORE
	POPJ	P,

FULL:	MOVEM	TAC,BBLK+1		;STORE RELOCATION
	MOVEI	TAC,22
	HRRM	TAC,BBLK		;SET COUNT
	MOVE	BC,[XWD -24,BBLK]	;OUTPUT COUNT
	PUSHJ	P,GBOUT			;OUTPUT THE BLOCK
	MOVEI	BC,
	POPJ	P,
;UBBOUT, GBOUT

UBBSV:	0

^UBBOUT:MOVEM	BC,UBBSV
	MOVE	BC,40
	MOVE	BC,(BC)
	PUSHJ	P,GBOUT
	MOVE	BC,UBBSV
	POPJ	P,

^GBOUT:	HLRZ	TAC,(BC)	;GET BLOCK TYPE
	CAIE	TAC,4		;IGNORE IF ENTRY
	SETOM	CODEM		;FLAG THAT CODE WAS PUT OUT
	CAIN	TAC,2		;ALSO CHECK SYMBOLS
	SETOM	SYMEM
	TRNN	BDEV		;BIN DEVICE?
	POPJ	P,		;NO
	SKIPG	TITLSW		;TITLE (NAME) OUTPUT YET?
	SKIPN	CODEM		;NO. IS THIS AN ENTRY BLOCK?
	JRST	GBOUT0		;TITLE (NAME) IS OUT OR THIS IS AN ENTRY BLOCK.
	SKIPL	TITLSW		;TITLE SET BY USER YET?
	JRST	GBOUTT		;YES. DO TITLE NOW.
	SKIPN	SYMEM		;IS THIS A SYMBOL GOING OUT.
	JRST	GBOUT0		;NO. WELL, WE CAN WAIT LONGER TO INVENT NAME BLOCK
GBOUTT:	PUSH	P,BC
	MOVE	BC,[-4,,TPOL2]
	HRRZM	BC,TITLSW	;SET WE HAVE WRITTEN TITLE.
	PUSHJ	P,GBOUT0	;WRITE 4 WORDS OF NAME BLOCK.
	POP	P,BC		;RESTORE ACTUAL BINARY POINTER.

GBOUT0:
STINK,<	PUSHJ	P,STKTRN	;TRANSLATE TO STINK FORMAT
	PUSHJ	P,GBOUT1
	POPJ	P,		;STKTRN SKIPS UPON OCCASION 

^^GBOUT1:	>;STINK

GBOUT2:	MOVE	TAC,(BC)	
	SOSLE	ODB+2
	JRST	GBPT
GBOUT3:	
NOTNX,<	OUT	3,
	JRST	GBPT
	OUTSTR	[ASCIZ /OUTPUT ERROR ON BINARY FILE.  TYPE ANY CHAR TO RETRY./]
	PUSH	P,T
	PUSHJ	P,WAIT
	POP	P,T
	OUTSTR	TTCRLF
	JRST	GBOUT3
>;NOTNX

TNX,<
	TSVAC	<1,2,3>
	SKIPL	JFNTBL-2+3
	JRST	GBOU3B		;IF FILE NOT PMAPPABLE
	AOS	1,ODB		;BUMP PAGE NUMBER
	HRL	1,JFNTBL-2+3	;JFN,,PAGE
	MOVE	2,[XWD 400000,BINBFP]	;THIS FORK, BIN BUFF PG
	HRLZI	3,140000	;READ/WRITE
	PMAP			;CREATE NEW FILE PAGE!
GBOU3A:	MOVEI	1,1000
	MOVEM	1,ODB+2		;SET BYTE COUNTER
	MOVE	1,[POINT 36,BINBF]
	MOVEM	1,ODB+1		;SET POINTER
	TRSTAC	<1,2,3>
	JRST	GBPT

GBOU3B:	HRRZ	1,JFNTBL-2+3	;JFN
	HRROI	2,BINBF
	MOVNI	3,1000
	SKIPL	ODB+2		;SKIP IF FIRST BUFFER NOT YET READY
	SOUT
	JRST	GBOU3A
>;TNX

GBPT:	IDPB	TAC,ODB+1
	AOBJN	BC,GBOUT2
	POPJ	P,

^BFRC:	JUMPE	BC,CPOPJ
^BFX:	MOVEI	TAC,(BC)		;ADDRESS GETS FIXED UP TO -(BBLK+2)
	HRRM	TAC,BBLK		;COUNT
	MOVE	TAC,BBLK+1		;GET RELOC BITS
	LSH	TAC,-2
	LSH	TAC,2
	AOBJN	BC,.-1			;SHIFT RELOC BITS
	MOVEM	TAC,BBLK+1
	MOVN	BC,BBLK			;GET - COUNT
	HRLI	BC,-2(BC)		;SUBTRACT 2 & PUT IN LEFT HALF
	HRRI	BC,BBLK			;SET ADRESS
	PUSHJ	P,GBOUT
	MOVEI	BC,
	POPJ	P,

TPOL2:	6,,2		;BUILD NAME BLOCK HERE.
	0
^^TPOL3:0		;THIS IS WHERE WE PUT THE RADIX50 PROGRAM NAME.
^^TPOL4:12,,0		;PROCESSOR TYPE 12 = FAIL.
^UFOUT:	MOVE	TAC,@40			;GET WORD
	MOVEM	TAC,(FC)		;DEPOSIT
	AOS	40
	MOVE	TAC,@40			;GET RELOC
	ANDI	TAC,3	
	OR	TAC,FBLK+1		;OR IN
	AOBJP	FC,FFUL			;FULL?
	LSH	TAC,2			;NO, SHIFT
	MOVEM	TAC,FBLK+1		;STORE
	POPJ	P,

FFUL:	MOVEM	TAC,FBLK+1		;STORE RELOC BITS
	MOVEI	TAC,22
	HRRM	TAC,FBLK		;SET COUNT
	PUSHJ	P,BFRC			;FORCE OUT BIN
	MOVE	BC,[-24,,FBLK]
	PUSHJ	P,GBOUT			;OUTPUT IT
	MOVE	FC,[-22,,FBLK+2]	;INIT
	SETZB	BC,FBLK+1
	POPJ	P,
;BFFRC, FFX, UPOUT

^BFFRC:	PUSHJ	P,BFRC			;FORCE BINARY, AND THEN...
	CAMN	FC,[-22,,FBLK+2]	;FORCE ANY FIXUPS
	POPJ	P,
^FFX:	MOVEI	TAC,(FC)		;ADDRESS GETS FIXED UP TO -(FBLK+2)
	HRRM	TAC,FBLK		;SET COUNT
	MOVE	TAC,FBLK+1		;GET RELOC BITS
	LSH	TAC,-2
	LSH	TAC,2			;SHIFT
	AOBJN	FC,.-1			;LOOP
	MOVEM	TAC,FBLK+1
	MOVN	FC,FBLK			;GET  -COUNT
	HRLI	FC,-2(FC)		;SUB 2 & PUT IN LEFT
	HRRI	FC,FBLK			;SET ADDRESS
	EXCH	FC,BC
	PUSHJ	P,GBOUT			;OUTPUT IT
	MOVE	BC,FC
	MOVE	FC,[-22,,FBLK+2]	;INIT
	SETZM	FBLK+1
	POPJ	P,

^UPOUT:	PUSH	P,BC			;SAVE
	MOVE	BC,40			;GET ADDRESS
	LDB	TAC,[POINT 4,BC,12]	;GET COUNT
	MOVNS	TAC			;NEGATE
	HRL	BC,TAC			;PUT IN LEFT
	PUSHJ	P,GBOUT			;OUTPUT IT
	POP	P,BC			;RESTORE
	POPJ	P,

^BNAM:	BLOCK	=20			;BLOCK NAMES
;R5CON
;	COMVERTS SIXBIT IN FS TO RADIX50 & PUTS RESULT IN FS,   USES N

^R5CON:	MOVEM	FS,R5C1
	MOVE	FS,[POINT 6,R5C1]
	MOVEM	FS,R5C1+1
	ILDB	FS,R5C1+1	;GET FIRST CHR.
	MOVE	FS,R5TAB(FS)	;CON TO R5
	ILDB	N,R5C1+1
	IMULI	FS,50
	ADD	FS,R5TAB(N)
	ILDB	N,R5C1+1
	IMULI	FS,50
	ADD	FS,R5TAB(N)
	ILDB	N,R5C1+1
	IMULI	FS,50
	ADD	FS,R5TAB(N)
	ILDB	N,R5C1+1
	IMULI	FS,50
	ADD	FS,R5TAB(N)
	ILDB	N,R5C1+1
	IMULI	FS,50
	ADD	FS,R5TAB(N)
	POPJ P,

R5C1:	BLOCK 2
R5TAB:	FOR I_0,'$'-1
	<0
	>
	46
	47
		FOR I_'%'+1,'.'-1
<0
>
	45
	FOR I_'.'+1,'0'-1
<0
>
	FOR I_1,12
<I
>
	FOR I_'9'+1,'A'-1
<0
>
	FOR I_13,44
<I
>
	FOR I_'Z'+1,77
<0
>

BEND
BEGIN LIO  SUBTTL	LISTING I/O STUFF

^UERR:	LDB	TAC,LSTPNT		;GET CURRENT CHR
	PUSH	P,TAC			;SAVE
	MOVEI	TAC,177			;GET DELETE
	DPB	TAC,LSTPNT		;OUTPUT
	MOVEI	TAC,13			;PRINT...
	IDPB	TAC,LSTPNT		;INTEGRAL SIGN
ARNT:	POP	P,TAC			;GET BACK THAT CHR
	IDPB	TAC,LSTPNT
	MOVE	TAC,ERPNT		;GET ERROR POINTER
	PUSH	TAC,40			;SAVE ADDRESS
	AOS	ERCNT			;COUNT
	MOVEM	TAC,ERPNT
	POPJ	P,

^UFAT:	PUSHJ	P,UERR			;PUT OUT MESSAGE
	PUSHJ	P,LSTFRC
	JRST	FEND

^BLOUT:	TRNE	LDEV			;LIST DEVICE?
	SKIPE	XL2SW			;INSIDE XLIST?
	POPJ	P,			;NO LIST DEVICE, OR IN XLIST
	MOVE	TAC,PCNT+1
	TLNE	TAC,INCF		;IN CORE?
	JRST	LBLOUT			;YES
	TROE	BLOSW			;SET & TEST
	JSR	BLOT			;NO LSTFRC SINCE LAST BLOUT
BLRET:	PUSH	P,T			;SAVE T
	PUSH	P,FS			;SAVE FS
	MOVS	FS,OPCNT		;GET OUTPUT LOCATION
	MOVE	TAC,OPCNT+1		;GET RELOC
	PUSHJ	P,OCON			;CONVERT TO ASCII OCTAL
	MOVEM	T,LBLK			;STORE IN BUFFER
	MOVEM	FS,LBLK+1		;...
LBCON:	MOVE	FS,WRD			;GET LEFT HALF
	MOVE	TAC,WRD+1		;GET RELOC...
	LSH	TAC,-2			;...
	PUSHJ	P,OCON			;CONVERT
	MOVEM	T,LBLK+2
	MOVEM	FS,LBLK+3
	MOVS	FS,WRD			;GET RIGHT HALF
	MOVE	TAC,WRD+1		;GET RELOC
	PUSHJ	P, OCON			;CONVER
	MOVEM	T,LBLK+4
	MOVEM	FS,LBLK+5
	POP	P,FS			;RESTORE...
	POP	P,T
	POPJ	P,

BLOT:	0
	PUSHJ	P,LSTCHK		;MAKE SURE LOUT IS INTACT
	MOVE	TAC,[-6,,LBLK]
	PUSHJ	P,LOUT			;OUTPUT THE BINARY OCTAL...
	MOVE	TAC,[-1,,LCR]
	PUSHJ	P,LOUT			;AND A CRLF
	JRST	@BLOT

^LBLOUT:TRNE	LDEV			;LIST DEVICE?
	SKIPE	NOLTSW			;NO LITTERAL LIST?
	POPJ	P,			;NO
	TROE	BLOSW			;SET & TEST
	JSR	BLOT			;NO LSTFRC SINCE...
	PUSH	P,T			;SAVE
	PUSH	P,FS
	MOVE	T,[BLNKS,,LBLK]
	BLT	T,LBLK+1		;BLANK LOCATION FIELD
	JRST	LBCON

BLNKS:	ASCII	/     /
	BYTE	(7)40,40,11
	ASCII	/     /
	BYTE	(7)40,40,11
^VBLOUT:TRNN	LDEV		;LIST DEVICE?
	POPJ	P,		;NO
	TROE	BLOSW		;ANY LSTFRC SINCE?
	JSR	BLOT		;NO
	PUSH	P,T		;SAVE
	PUSH	P,FS
	MOVS	FS,OPCNT	;GET LOCATION
	MOVE	TAC,OPCNT+1	;&RELOC
	PUSHJ	P,OCON		;CONVERT TO ASCII
	MOVEM	T,LBLK
	MOVEM	FS,LBLK+1
	MOVE	T,[BLNKS,,LBLK+2]
	BLT	T,LBLK+5	;BLANK VALUE
	POP	P,FS
	POP	P,T
	POPJ	P,

^UTRAN:	TRNN	LDEV		;LIST DEV EXIST?
	POPJ	P,		;NO
	TROE	BLOSW		;SET & TEST
	JSR	BLOT		;EXTRA BINARY, DUMP IT
	MOVS	TAC,40		;GET ADDRESS
	HRRI	TAC,LBLK	;SET UP BLT WRD
	BLT	TAC,LBLK+5	;BLT
	POPJ	P,

LCR:	BYTE	(7)15,12

^OCON:	HRRI	FS,0		;CONVERT OCTAL IN LH OF FS TO ASCII IN FS AND T.
	MOVEI	T,0
	LSHC	T,3		;MOVE DIGIT IN.
	LSH	T,4		;SHIFT TO MAKE ROOM FOR THE NEXT.
	LSHC	T,3
	LSH	T,4
	LSHC	T,3
	LSH	T,4
	LSHC	T,3
	LSH	T,4
	LSHC	T,3
	LSH	T,1
	IOR	T,[ASCII/00000/]
	LSH	FS,-4			;SHIFT THE LAST DIGIT BACK.
	IOR	FS,[BYTE(7)60,40,11,0,0]
	TRNE	TAC,1			;RELOC?
	ADD	FS,[BYTE(7)0,<"'"-40>]
	POPJ	P,
^LSTLF:	SKIPGE	AHED		;LINE FEED SEEN -- IF NOT FROM MACRO
	SETOM	INCLIN		;PREPARE TO UPDATE LINE NUM (FOR NON-SOS FILES)
^LSTFRC:PUSHJ	P,LSTCHK	;CHECK FOR CLOBBERAGE
	JRST	FLST

LBCLOB:	ASCII / ****** LISTING LINE CLOBBERED ******/
LBCLBL__.-LBCLOB

^LSTCHK:MOVNI	TAC,1
	CAMN	TAC,LTEST	;OVERRUN?
	POPJ	P,		;NO
	CAMN	TAC,LTEST2
	JRST	LST2OK
	MOVE	TAC,SVLNUM
	MOVEM	TAC,TLBLK
	MOVE	TAC,[LBCLOB,,TLBLK+1]
	BLT	TAC,TLBLK+LBCLBL		;CLOBBER LISTING LINE
	MOVE	TAC,[440700,,TLBLK+LBCLBL+1]
	MOVEM	TAC,LSTPNT
LST2OK:	OUTSTR	[ASCIZ /Line buffer overflow -- assembler clobbered.
/]

NOTNX,<	SETZB	TAC,.JBAPR			;NO MORE MPV INTERRUPTS
	APRENB	TAC,				;ENABLE NO INTERRUPTS
>;NOTNX

TNX,<	MOVEI	1,400000			;THIS FORK
	DIR					;DISABLE INTERRUPTS
>;TNX

	PUSHJ	P,TTYERP
	MOVE	TAC,[JRST LSTFRC]
	MOVEM	TAC,STRT+2			;MAKE IT DIFFICULT TO RESTART
NOTNX,<	JRST	4,LSTFRC	>;NOTNX
TNX,<	HALTF
	JRST	.-1		>;TNX

^ERRHED:OUTSTR	FILNM			;TYPE CURRENT FILE NAME (CALLED FROM PRINTX)
	OUTSTR	[ASCIZ /,  PAGE  /]	
	PUSH	P,NA
	MOVE	N,PGNM
	PUSHJ	P,PGOUT
	SKIPE	TLBLK
	JRST	ERRHD1			;SOS LINE NUM EXISTS -- USE IT
	OUTSTR	[ASCIZ /,  LINE  /]
	MOVE	N,INLINE
	ADDI	N,1
	PUSHJ	P,PGOUT			;NO NUM -- USE OUR OWN
ERRHD1:	POP	P,NA
	OUTSTR	TTCRLF
	POPJ	P,


^TTYERP:PUSH	P,TAC
	MOVE	TAC,LSTPNT
	TLO	TAC,700		;SIZE MIGHT BE 0 IN MACRO
	PUSH	P,T
	MOVEI	T,15		;MAKE SURE WE GET A CR-LF
	IDPB	T,TAC
	MOVEI	T,12
	IDPB	T,TAC
	PUSH	P,N
	PUSHJ	P,ERRHED		;TYPE ERROR HEADING TEXT
	MOVEI	N,TLBLK
	SKIPN	TLBLK			;ANY SOS LINE NUM?
	SKIPA	TAC,[350700,,1(N)]	;NO, SKIP IT
	MOVSI	TAC,(<440700,,(N)>)	;YES, PRINT IT
CLOP3:	ILDB	T,TAC			;GET CHR OF LINE
	JUMPE	T,CLOP5
CLOP6:	CAIN	T,177			;DELETE?
	JRST	CLOP2			;YES
CLOP4:	OUTCHR	T			;TYPE IT
	CAIE	T,12			;DONE IF IT'S LF
	JRST	CLOP3
	MOVE	TAC,LSTPNT
	MOVEI	T,
	IDPB	T,TAC		;NULL OUT FORCED CRLF (MAY SCREW UNDERLINE KLUDGE)
	IDPB	T,TAC
	POP	P,N
	POP	P,T
TTYERX:	POP	P,TAC
	POPJ	P,

CLOP2:	ILDB	T,TAC
	CAIN	T,13			;INTEGRAL SIGN?
	HRROI	T,12			;YES, USE LINE-FEED (BUT AVOID COMPARE)
	JRST	CLOP4

CLOP5:	TRNE	TAC,-LBFSZ		;NULL - SEE IF REALLY UNDERLINE KLUDGE
	JRST	CLOP3			;CAN'T BE IF OFF END
	XORI	N,MBLKTLBLK		;TRY OTHER BUFFER
	LDB	T,TAC
	JUMPN	T,CLOP6			;YUP - TIME TO SWITCH BUFFERS
	XORI	N,MBLKTLBLK
	JRST	CLOP3

PGOUT:	IDIVI	N,12
	JUMPE	N,.+4
	HRLM	NA,(P)
	PUSHJ	P,PGOUT
	HLRZ	NA,(P)
	MOVEI	T,"0"(NA)
	OUTCHR	T
	POPJ	P,
;	DATA AREA FOR LISTING STUFF

^TITCNT:	XWD -1,.+1
	0
	BLOCK 40

HEDCNT:	XWD -LHEAD,.+1
	ASCII /		FAIL	/
HEAD:	BLOCK 4
NOTNX,<^FILNM:	BLOCK 5;> BYTE (7)11,11
	ASCII /   Page/
PG:	ASCII /  /
	BLOCK 3		;ALLOW ROOM FOR BLOCK NAME TOO
	11*200*2	;FINISH WITH A TAB
LHEAD__.-HEDCNT-1

^SUBCNT:	XWD -1,.+1
NOTNX,<	BYTE (7)15,12,15,12;> BYTE (7)11,11,11,11,11
	BLOCK 40
PTPNT:	0

TNX,<
^FILCNT:	XWD -1,FILNM		;LH GETS CLOBBERED
^FILNM1:	0
^FILNM2:	0
^FILNM:	BLOCK =28	;ROOM FOR TENEX FILE NAME AND MISC JUNK
>;TNX

;I SEE IT, I UNDERSTAND IT, BUT I DON'T BELIEVE IT.  REG
;FROM A DEC SYSTEM, I'LL BELIEVE ANYTHING... TMW
NOTNX,<
MOTAB:
FOR ZOT IN (NAJ,BEF,RAM,RPA,YAM,NUJ,LUJ,GUA,PES,TCO,VON,CED)<"ZOT"
>
>;NOTNX

^SPGNM:	0
^PGNM:	0
^LNCNT:	0
^PAGSIZ:0		;PAGE SIZE FOR LISTING
^ERPD:	BLOCK ERPLEN
^ERPNT:0
^PGBF:	0		;FOR TYPING PAGE NUMBERS IN ERROR MESSAGES--DCS 2/6/70
	0	
^XPNDSW:0
^SVLNUM:0
	BYTE (7)11,11,11
LBFSZ__200		;SIZE OF LINE BUFFER - MUST BE POWER OF 2 (SEE TTYERP)
^MBLK:	BLOCK LBFSZ
LTEST2:	-1
^LBLK:	BLOCK 6
^TLBLK:	BLOCK LBFSZ
^LTEST:	-1
;HERE SPEC CHRS & LINE OVERFLOW ARE HANDLED
	JRST	LOUT2	;FOR SLURP HACK ETC.
LOUTTB:	JRST	LOUTDL	;RUBOUT
	JRST	LOUTLF	;LF
	JFCL		;" or <==> (^W)
	JRST	LOUT2	;'
	JRST	LOUT2	;=
	JRST	LOUTSP	;SP & TAB
	JRST	LOUTCR	;CR
	JRST	LOUTFF	;FF
	JRST	LOUT2	;<{
	JRST	LOUT2	;>}

LOUTLF:	SOSLE	LNCNT
	JRST	LOUT3		;JUST OUTPUT IF NO PAGE OFLO
	SKIPL	LNCNT		;DON'T CLOBBER CHAR IF ABOUT TO DO HEADING
	MOVEI	T,14		;ELSE TURN INTO FF
LOUTFF:	SKIPGE	LNCNT		;IF ALREADY OFF PAGE
	JRST	LOUTH		;THEN DO HEADING
	SKIPGE	CHRCNT		;SEE IF DOING CREF STUFF
	JRST	LOUT3		;AND AVOID SPECIAL TREATMENT FOR FF
	MOVSI	TAC,1		;OTHERWISE USE A BIG NUMBER
	MOVEM	TAC,CHRCNT	;TO GET US TO LOUTH ON THE NEXT CHAR
	SETOM	LNCNT		;MARK US OFF PAGE
	JRST	LOUT3		;AND GO OUTPUT FF

LOUTCR:	HLLZS	CHRCNT		;CR RESETS POS EXCEPT HEADING FLAG
	JRST	LOUT3

LOUTSP:	CAIE	T,11		;SEE IF THIS "SPACE" IS A TAB
	JRST	LOUT2		;NO
	MOVEI	TAC,7		;YES - UPDATE POS TO TAB STOP
	IORM	TAC,CHRCNT	;(ACTUALLY 1 SHORT)
	JRST	LOUT2		;AOS AT LOUT2 WILL MAKE IT RIGHT

LOUTOV:	TLNE	TAC,-1		;CHECK IF THIS IS REALLY HEADING FLAG
	JRST	LOUTH		;YES
	HRROI	TAC,[ASCIZ /
/]
	PUSHJ	P,LOUT		;JUST OFLO - STICK IN CRLF
	JRST	LOUT1A		;& REPROCESS CURRENT CHAR
LOUTDL:	SKIPLE	LNCNT
	JRST	LOUT3		;PASS RUBOUT QUIETLY IF HEADING NOT NEEDED
LOUTH:	PUSHJ	P,LOUTH1	;DO HEADING STUFF
	JRST	LOUT1A		;REPROCESS CURRENT CHAR

LOUTH1:	HRROI	TAC,[BYTE (7)15]	;HEADING TIME - FIRST OUTPUT CR
	PUSHJ	P,LOUT
	SETZM	CHRCNT		;& CLEAR FLAG
	MOVE	TAC,PAGSIZ
	MOVEM	TAC,LNCNT	;RESET LINE COUNTER
	MOVE	TAC,TITCNT
	PUSHJ	P,LOUT
	PUSHJ	P,PTIM
	MOVE	TAC,HEDCNT
	PUSHJ	P,LOUT
	MOVE	TAC,SUBCNT		;SUBTTL

TNX,<	PUSHJ	P,LOUT
	MOVE	TAC,FILCNT		;FILE NAME
	PUSHJ	P,LOUT
	HRROI	TAC,[BYTE(7)15,12,15,12]  >;TNX

	JRST	 LOUT

	DEFINE DEP
<	ADDI N,60
	ADDI NA,60
	IDPB N,PTPNT
	IDPB NA,PTPNT
>
PTIM:	PUSH P,N
	PUSH P,NA
NOTNX,<
	DATE N,		;GET DATE
	MOVE NA,[POINT 7,HEAD]
	MOVEM NA,PTPNT
	IDIVI N,=31	;GET DAY
	MOVEM N,PG+1	;SAVE
	MOVEI N,(NA)1	;GET DAY
	IDIVI N,12	;CON TO DEC
	SKIPN N		;ZERO LEADING DIGIT?
	MOVNI N,20	;YES, CON TO BLANK
	DEP
	MOVEI N,"-"
	IDPB N,PTPNT
	MOVE N,PG+1	
	IDIVI N,=12	;GET MONTH & YEAR
	MOVE NA,MOTAB(NA);GET MONTH NAME
	IDPB NA,PTPNT	;DEPOSIT
	LSH NA,-7
	IDPB NA,PTPNT
	LSH NA,-7
	IDPB NA,PTPNT
	MOVEI NA,"-"
	IDPB NA,PTPNT
	ADDI N,=64
	IDIVI N,12
	DEP
	MOVEI N,40
	IDPB N,PTPNT
	IDPB N,PTPNT
	MSTIME N,	;GET TIME
	IDIVI N,=60000	;THROW AWAY M.S & SEC
	IDIVI N,=60	;GET HRS & MINS
	MOVEM NA,PG+1	;SAVE MINS
	IDIVI N,12	;CON TO DEC
	SKIPN N
	MOVNI N,20
	DEP
	MOVE N,PG+1
	MOVEI NA,":"
	IDPB NA,PTPNT
	IDIVI N,12
	DEP
>;NOTNX
TNX,<
	TSVAC	<1,2,3>
	HRROI	1,HEAD
	SETO	2,		;USE CURRENT DATE/TIME
	HRLZI	3,000200	;PROPER FORMAT AS BEFORE
	ODTIM
	TRSTAC	<1,2,3>
>;TNX
	SETZM PG+1
	SETZM PG+2
	SETZM PG+3
	HRRZS PG+4
	MOVE N,[POINT 7,PG,13]
	MOVEM N,PTPNT
	MOVE N,PGNM	;GET PAGE NUM
	PUSHJ P,PGCON
	AOS N,SPGNM
	CAIG N,1
	JRST PTIM2
	MOVEI NA,"-"
	IDPB NA,PTPNT
	PUSHJ P,PGCON
PTIM2:	MOVEI N,15
	IDPB N,PTPNT
	MOVEI N,12
	IDPB N,PTPNT
	MOVE NA,[440600,,LSTLAB+3]	;TO GET BLOCK NAME
REPEAT 6,<	ILDB N,NA
		ADDI N,40
		IDPB N,PTPNT>
	POP P,NA
	POP P,N
	POPJ P,
PGCON:	IDIVI N,12	;CON TO DEC
	JUMPE N,PGCOA	;0?
	HRLM NA,(P)	;SAVE REMAINDER
	PUSHJ P,PGCON
	HLRZ NA,(P)	;GET REMAINDER
PGCOA:	ORI NA,60
	IDPB NA,PTPNT
	POPJ P,
FLST:	SKIPN	ERCNT		;ANY ERRORS?
	JRST	QLST		;NO
	SKIPN	TTYERR		;IF ANYBODY WILL WANT MESSAGE,
	JRST	LSTAR		;THEN PRINT STARS
	SKIPN	LISTSW
	JRST	QLST		; DON'T EVEN CONSIDER IT
LSTAR:	PUSH	P,N
	MOVEI	N,[ASCIZ /#####/]
	SKIPL	ERCNT		;DON'T PRINT STARS FOR PRINTX
	PUSHJ	P,ERLST		;PRINT STARS
	POP	P,N
	SKIPN	TTYERR		;LIST ERRORS ON TTY?
	PUSHJ	P,TTYERP	;YES - DO IT
QLST:	AOSN	INCLIN				;IF NECESSARY,
	AOS	INLINE				;UPDATE LINE NUM AFTER TTYERP
	TRNE	LDEV				;LISTING?
	JRST	YESL				;YES
	HRRZ	TAC,LSTPNT
	CAIGE	TAC,TLBLK			;POINTER IN MACRO?
	SKIPA	TAC,[POINT 7,MBLK+1,6]		;YES
	MOVE	TAC,[POINT 7,TLBLK+1,6]
	SKIPN	XPNDSW
	TLZ	TAC,7700
	MOVEM	TAC,LSTPNT			;RESET LSTPNT
	SKIPN	UNDLNS				;UNDERLINING?
	JRST	ERSCN				;NO
	SETZM	MBLK
	MOVE	TAC,[XWD MBLK,MBLK+1]
	BLT	TAC,LTEST-1;CLEAR BUFFER
	SETOM	LTEST2
	MOVE	TAC,[BYTE (7) 11]
	MOVEM	TAC,TLBLK+1
	JRST	ERSCN				;PRINT ERRORS

;ROUTINE TO OUTPUT TO LISTING FILE - AOBJN PNTR IN TAC
^LOUT:	PUSH	P,T				;SAVE
	PUSH	P,FS				;SAVE
LOUT0:	PUSH	P,TAC
	MOVE	FS,(TAC)
	ANDCMI	FS,1				;CLEAR UNUSED BIT 35
LOUT1:	MOVEI	T,0
	LSHC	T,7				;MOVE CHARACTER FROM FS TO T
LOUT1A:	SKIPL	TAC,CTAB(T)
	JRST	LOUTS				;MIGHT BE SPECIAL

IFE STANSW,<				;STANFORD AI PRINTER WINS
	CAIN	T,30			;AI version of underscore
	MOVEI	T,"."			;convert to period otherwise
>;STANSW

LOUT2:	AOS	TAC,CHRCNT
	CAML	TAC,CHRPL
	JRST	LOUTOV				;OVERFLEW LINE
LOUT3:	SOSG	LOB+2
NOTNX,<	OUTPUT	4,>
TNX,<	JRST	LOUT3A
LOUT30:	>;TNX
	IDPB	T,LOB+1
LOUT4:	JUMPN	FS,LOUT1
	POP	P,TAC
	AOBJN	TAC,LOUT0
	POP	P,FS
	POP	P,T
	POPJ	P,

TNX,<
LOUT3A:	TSVAC	<1,2,3>
	SKIPL	JFNTBL-2+4
	JRST	LOUT3C			;IF NOT PMAPPABLE FILE
	AOS	1,LOB			;UPDATE PAGE NUMBER
	HRL	1,JFNTBL-2+4		;JFN,,PAGE
	MOVE	2,[XWD 400000,LSTBFP]	
	HRLZI	3,140000		;READ/WRITE
	PMAP				;CREATE NEW PAGE
LOUT3B:	MOVEI	1,1000*5
	MOVEM	1,LOB+2			;SET COUNT
	MOVE	1,[POINT 7,LSTBF]
	MOVEM	1,LOB+1			;AND POINTER
	TRSTAC	<1,2,3>
	JRST	LOUT30

LOUT3C:	HRRZ	1,JFNTBL-2+4
	HRROI	2,LSTBF
	MOVNI	3,1000*5
	SKIPL	LOB+2		;SKIP IF FIRST BUFFER NOT YET READY
	SOUT
	JRST	LOUT3B
>;TNX

	
LOUTS:	TLNE	TAC,SCRF!CRFG		;need special handling?
	XCT	LOUTTB(TAC)		;THIS CHAR NEEDS WORRYING
IFE STANSW,<			;stanford AI printer will do anything
LOUTSX:	CAIGE	T,40		;INSTR GETS CLOBBERED FOR CREF OUTPUT!
	JUMPN	TAC,CTLCON		;convert ctl chars for output
>;IFE STANSW
	JUMPN	TAC,LOUT2			;JUST ORDINARY SPEC CHR?
	JRST	LOUT4				;FLUSH NULLS

IFE STANSW,<
CTLCON:	ADDI	T,100			;convert character to alpha form
	LSHC	T,-7			;put it back for next time
	MOVEI	T,"^"
	MOVE	TAC,CTAB(T)
	JRST	LOUT2
>;IFE STANSW
YESL:	SKIPN XPNDSW	;NOT EXPANDING NOW?
	POPJ P,		;YES
	TRNN MACUNF	;WAS A MACRO SEEN?
	JRST LARND	;NO
	PUSH P,N
	PUSH P,NA
	MOVE N,[POINT 7,MBLK]
	MOVE NA,[POINT 7,TLBLK]
LOOP1:	ILDB TAC,NA	;GET CHR FROM PRIMARY BUFFER
	JUMPE TAC,LNUL	;NULL?
	CAIN TAC,177	;DELETE?
	JRST LDEL	;YES
	CAIN TAC,11	;TAB?
	JRST LSPA	;YES
	CAIN TAC,15	;CR?
	JRST LCRE	;YES
	MOVEI TAC,40	;NONE OF THE ABOVE  (USE SPACE)
LSPA:	IDPB TAC,N	;DEPOSIT IN SECONDARY BUFFER
	JRST LOOP1
LDEL:	IBP N
	ILDB TAC,NA
	JRST LSPA
LNUL:	ILDB TAC,N	;GET OTHER CHR.
	JUMPE TAC,LOOP1	;BOTH NULL?
	CAIN TAC,177	;DELETE?
	JRST LOOP1	;YES
	CAIN TAC,11	;TAB?
	JRST OTAB	;YES
	CAIN TAC,15	;CR?
	JRST OCRE	;YES
	CAIN TAC,40	;SPACE?
	JRST OTAB	;YES
	MOVEI TAC,30	;UNDERLINE
OTAB:	DPB TAC,NA
	JRST LOOP1
LCRE:	IDPB TAC,N
OCRE:	DPB TAC,NA
	MOVEI TAC,
	IDPB TAC,N
	MOVEI TAC,12
	IDPB TAC,NA
LARND:	SKIPN CREFSW	;CREFING?
	JRST NOCREF	;NO
	MOVEI TAC,177	;DEPOSIT...
	IDPB TAC,CREFPT	;END...
	MOVEI TAC,101	;OF...
	IDPB TAC,CREFPT	;CREF
	PUSHJ P,CREFR	;DUMP THE INFO
NOCREF:	TRNN MACUNF
	JRST NOMAC
	MOVN TAC,N
	ADDI TAC,MBLK-2
	HRLI TAC,MBLK-1
	MOVSS TAC
	PUSHJ P,LOUT
	MOVN TAC,NA
	SKIPA
NOMAC:	MOVN TAC,LSTPNT	;FORM...
	ADDI TAC,LBLK-1	;COUNT
	HRLI TAC,LBLK
	TRZE BLOSW	;ANY BINARY
	JRST BYES	;YES
	ADDI TAC,5	;REDUCE COUNT
	PUSH P,[BYTE (7)11,11,11];TAB ACROSS
	POP P,LBLK+5
	HRLI TAC,LBLK+5	;SET ADDRESS
BYES:	MOVSS TAC	;SET UP CONTROL WORD FOR...
	PUSHJ P,LOUT	;LOUT
	SETZM	MBLK
	MOVE	TAC,[XWD MBLK,MBLK+1]
	BLT	TAC,LTEST-1;CLEAR BUFFERS
	SETOM	LTEST2
	MOVE	TAC,[BYTE (7) 11]
	MOVEM	TAC,TLBLK+1
	HRRZ	TAC,LSTPNT
	TRNN	MACUNF
	JRST	.+3
	POP	P,NA
	POP	P,N
	CAIL	TAC,TLBLK
	SKIPA	TAC,[POINT 7,TLBLK+1,6]
	SKIPA	TAC,[POINT 7,MBLK+1,6]
	TRZ	MACUNF				;CLEAR FLAG
	MOVEM	TAC,LSTPNT			;RESET LSTPNT
	SKIPE	XL2SW				;START XLIST NOW?
	JRST	[SETZM	XL2SW			;YES.
		TRZ	LDEV
		JRST	.+1]
;FALL OFF THE PAGE INTO ERSCN
ERSCN:	SKIPN	ERCNT			;ANY?
	POPJ	P,			;NONE
NOITS,<		SKIPL	ERCNT		;IS THIS REALLY PRINTX?
		HLLOS	 42 >		;NO. MARK THAT ERRORS HAVE HAPPENED
	SKIPN	LISTSW			;LIST DEVICE?
	SKIPN	TTYERR			;ERRORS ON TTY?
	JRST	ERS1			;SOMEONE WANTS ERROR MEXXAGES
	MOVE	TAC,[XWD -ERPLEN,ERPD-1]
	MOVEM	TAC,ERPNT		;NO ONE WANTS THESE ERROR MESSAGES
	SETZM	ERCNT
	POPJ	P,

ERS1:	PUSH	P,N			;SAVE
	PUSH	P,NA			;SAVE NA
	PUSH	P,T
	PUSH	P,FS
	MOVE	FS,LSTLAB+1		;GET BLOCK NAME
	PUSHJ	P,AFROM6		;CON TO ASCII
	MOVEM	T,LABPRT		;SAVE
	MOVE	N,FS			;SAVE LAST CHR
	MOVE	FS,LSTLAB		;GET LABEL NAME
	PUSHJ	P,AFROM6		;CON TO ASCII
	OR	N,[BYTE(7)0,40,"&",40]
	ROT	T,7
	DPB	T,[POINT 7,N,34]
	MOVEM	N,LABPRT+1		;DEPOSIT SECOND WORD
	ROT	FS,7
	DPB	FS,[POINT 7,T,34]
	MOVEM	T,LABPRT+2		;DEPOSIT THIRD WORD
	MOVE	N,PCNT	
	SUB	N,LSTLAB+4		;GET DEVIATION
	SETZM	LABPRT+3
	JUMPE	N,RCQ
	MOVE	T,[POINT 7,LABPRT+3]	;SET UP POINTER
	MOVEI	NA,"+"
	IDPB	NA,T			;DEPOSIT +
	PUSHJ	P,RCR			;CONVERT
	MOVEI	NA,0			;NULL TO END IT
	IDPB	NA,T
RCQ:	MOVEI	N,LABPRT
	SKIPL	ERCNT		;SKIP IF PRINTX.
	PUSHJ	P,ERLST
	POP	P,FS
	POP	P,T
	SKIPG	ERCNT		;PRINTX?
	JRST	ELOPX		;YES.  SKIP LOCATION STUFF
	MOVE	NA,ERPNT	;GET ERROR POINTER
ELOP:	POP	NA,N		;GET MESSAGE
	PUSHJ	P,ERLST		;LIST IT
	SOSLE	ERCNT		;ANY MORE?
	JRST	ELOP		;YES
	MOVEM	NA,ERPNT	;RESTORE
ELOPX:	POP	P,NA
	POP	P,N
	SKIPE	ERCNT		;IS THIS REALLY PRINTX?
	JRST	[SETZM ERCNT	;YES.
		POPJ P,]	;SO WE DON'T STOP
	SKIPN	ERSTSW		;SHOULD WE STOP?
	POPJ	P,		; NO

IFE EDITSW,<
TNX,<	TSVAC	<1> >
OUTSTR	[ASCIZ	/REPLY [CR] TO CONTINUE, [LF] TO CONTINUE AUTOMATICALLY
_/]
>
IFN EDITSW,<
OUTSTR	[ASCIZ	/REPLY 'E' - EDIT, [CR] - CONTINUE, [LF] - CONTINUE AUTOMATICALLY
_/]
>
NOTNX,<
	CLRBFI			;CLEAR TYPEAHEAD
	INCHRW	TAC		;WAIT FOR ACTI
	CLRBFI			;CLEAR TTY INPUT BUFFER
>;NOTNX
TNX,<
	MOVEI	1,100		;PRIMARY INPUT
	CFIBF
	PBIN
	MOVE	TAC,1
	MOVEI	1,100
	CFIBF
	TRSTAC	<1>
>;TNX

IFN EDITSW <
	CAIE	TAC,"e"
	CAIN	TAC,"E"
	JRST	EDGO
>
	CAIN	TAC,12		;TURN OFF ERSTSW?
	SETZM	ERSTSW		;YES
	POPJ	P,

IFN EDITSW,<
EDGO:	OUTSTR	TTCRLF
	MOVE 14,FNAM		;GET FILENAME
	HLLZ 13,FNAM+1		;GET EXTENSION
	MOVE 11,SAVPPN		;GET PPN
	MOVE 16,PGNM		;GET PAGE NUMBER

	SKIPN 15,TLBLK		;DOES IT HAVE LINE NUMBERS?
	SKIPA 2,[SIXBIT /TECO/] ;NO, FIRST WE'LL ASSUME TECO
IFE TYMSW,<
IFE CMUSW,<	SKIPA 2,[SIXBIT /SOS/]	;YES, USE SOS>
IFN CMUSW,<	SKIPA 2,[SIXBIT /LINED/]>>	;CMU STILL CALLS IT LINED (SIGH)
IFN TYMSW,<	SKIPA 2,[SIXBIT /EDIT10/]>	;(SIGH)
	MOVE 15,INLINE		;NO LINE NUMBERS, GET COUNT INSTEAD
IFN STANSW,<	SKIPE TVFILE
		MOVSI 2,'E  '	>
	MOVEM	2,EDITOR
	MOVE	[1,,RUNBLK]
	JSR	DELRPG
IFN TYMSW,<MOVEI 17,525252	;UNUSUAL AS FLAG TO EDIT10>
	RUN
	HALT	.-1		;IN CASE IT LOSES

RUNBLK:	SIXBIT /SYS/
EDITOR:	BLOCK 5		>;IFN EDITSW

LABPRT:	BLOCK 6
RCR:	IDIVI N,10
	JUMPE N,.+4
	HRLM NA,(P)
	PUSHJ P,RCR
	HLRZ NA,(P)
	ORI NA,60
	IDPB NA,T
	POPJ P,

^ERLST:	SETZM SW1
NOITS,<	HLLOS 42>	;MARK THAT ERRORS HAVE HAPPENED
	PUSH P,T
	PUSH P,FS	
	PUSH P,O
ELOP2:	HRROI TAC,(N)
	SKIPE LISTSW	;LIST DEVICE?
	PUSHJ P,LOUT	;YES
	MOVEI O,5
	MOVE FS,(N)	;GET FIRST WORD
ELOP1:	MOVEI T,
	LSHC T,7	;GET CHR.
	JUMPE T,EDON	;DONE?
	SKIPN TTYERR	;NO, TTY ERR LIST?
	OUTCHR T
	SOJG O,ELOP1	;MORE THIS WORD?
	AOJA N,ELOP2	;NO, GET NEXT WORD
SW1:	0

EDON:	SKIPE	SW1
	JRST	EDON1
	SETOM	SW1
	MOVEI	N,CRLF
	JRST	ELOP2

EDON1:	POP P,O
	POP P,FS
	POP P,T
	POPJ P,
;CREF6, CREF7, CREF66

COMMENT $
Here's what you didn't want to know about CREF:
CREF6 sends ASCII characters for a symbol's address in FAIL's core image.
	CREF6 1,				;symbol reference
	CREF6 1,  followed by '002 in file	;symbol definition
	CREF6 10, followed by CREF 0,		;combine symbol chains at BEND
	CREF6 5,				;Macro reference, opdef reference
	CREF6 6,  				;Macro definition, opdef definition
	
these give a symbol name to what was formerly known only by number
	CREF66 11,				;flush symbol, litlabs, globals
	CREF66 13,				;flush macro, opdefs

These are for sending ascii of the symbol name.
	CREF7 3,				;opcode reference
	CREF7 5,				;macro pseudo-op (IFs,IOWD) ref
	CREF7 15,				;BEGIN block name
	CREF7 16,				;BEND block name
$


^CREFPT:0				;BYTE POINTER INTO CREFTB
^CREFTB:BYTE (7)177,102			;ACCUMULATE CREF DATA
	BLOCK 100

;CREF6 AC,ADDR
;EMITS TO CREF:   '177 AC 6 <ASCII CHARACTERS FOR THE OCTAL VALUE OF ADDR>
;IF AC=0 THEN:   6 <ASCII CHARACTERS FOR THE OCTAL VALUE OF ADDR>

^UCREF6:SKIPN	LISTSW			;LISTING?
	POPJ	P,			;NO
	LDB	TAC,[POINT 4,40,12]	;NO SIZE CHECK IF 0
	JUMPE	TAC,OENT		;AND NO IDPB CREFPT EITHER
	HRRZ	TAC,CREFPT		;GET THE POINTER ADRESS
	CAIGE	TAC,CREFTB+70		;SEE IF WE ARE ALMOST AT THE END
	JRST	NOCDM			;PLENTY OF ROOM. GO ON.
	MOVEI	TAC,177
	IDPB	TAC,CREFPT
	MOVEI	TAC,104			;'177 D MEANS EAT DATA
	IDPB	TAC,CREFPT		;GIVE IT A JUST EAT OP
	PUSHJ	P,CREFR			;AND DUMP
NOCDM:	LDB	TAC,[POINT 4,40,12]	;GET TYPE
	IDPB	TAC,CREFPT		;DEPOSIT
OENT:	HRRZ	TAC,40			;GET SIXBIT
	PUSH	P,L			;SAVE L
	MOVEI	L,6			;INIT SIZE
	IDPB	L,CREFPT		;DEPOSIT SIZE
	PUSH	P,T			;SAVE T
CLOOP1:	LDB	T,[POINT 3,TAC,20]	;GET CHR.
	ADDI	T,"0"
	IDPB	T,CREFPT		;DEPOSIT CHR.
	LSH	TAC,3			;SHIFT
	SOJG	L,CLOOP1		;DONE?
CRFRT:	POP	P,T			;YES, RESTORE
	POP	P,L
	POPJ	P,



;CREF7 AC,ADDR
;EMITS '177 AC N <N CHARACTERS OF ASCII FOR THE SYMBOL NAME POINTED TO BY ADDR>

^UCREF7:SKIPN	LISTSW
	POPJ	P,
	HRRZ	TAC,CREFPT		;GET THE POINTER ADRESS
	CAIGE	TAC,CREFTB+70		;SEE IF WE ARE ALMOST AT THE END
	JRST	NOCDM7			;NO, GO ON
	MOVEI	TAC,177
	IDPB	TAC,CREFPT
	MOVEI	TAC,104
	IDPB	TAC,CREFPT		;GIVE IT A JUST EAT OP  (RUBOUT D)
	PUSHJ	P,CREFR			;AND DUMP
NOCDM7:	LDB	TAC,[POINT 4,40,12]
	IDPB	TAC,CREFPT
	JRST	UCRF67

;CREF66 AC,ADDR  DOES BOTH CREF6 AC,ADDR AND CREF7 AC,ADDR

^UCRF66:SKIPN	LISTSW			;LISTING?
	POPJ	P,			;NO
	PUSHJ	P,UCREF6
UCRF67:	MOVE	TAC,@40			;NOW GET THE SIXBIT
	PUSH	P,L
	MOVEI	L,5
	TLNE	TAC,770000		;JUSTIFY
	AOJA	L,LADJ
	LSH	TAC,6
	SOJG	L,.-3
	MOVEI	L,1
LADJ:	IDPB	L,CREFPT
	PUSH	P,T
CLOOP2:	LDB	T,[POINT 6,TAC,5]
	ADDI	T,40
	IDPB	T,CREFPT
	LSH	TAC,6
	SOJG	L,CLOOP2
	JRST	CRFRT

;FORCE CREF INFO TO LISTING.
CREFR:	MOVEI	TAC,0			;PUT OUT THE CREF INFO
	REPEAT	5,<IDPB TAC,CREFPT>
	PUSHJ	P,LSTCHK
	SKIPG	LNCNT
	PUSHJ	P,LOUTH1		;OUTPUT HEADING IF NEEDED (BEFORE CREF JUNK)
	MOVN	TAC,CREFPT		;- LAST ADDRESS
	ADDI	TAC,CREFTB		;+ FIRST ADDRESS = -WORD COUNT
	HRLI	TAC,CREFTB		;ADDRESS,,-WC
	MOVS	TAC,TAC			;-WC,,ADDRESS FOR LOUT
	PUSH	P,CHRCNT
	PUSH	P,LNCNT
	HLLZM	TAC,CHRCNT		;SET COUNTS TO PREVENT
	HRRZM	TAC,LNCNT		;OVERFLOW DETECTION

IFE STANSW,<	PUSH	P,LOUTSX	;SAVE INSTRUCTION
		PUSH	P,[CAIA]
		POP	P,LOUTSX	;CLOBBER INSTR >;NOT SU AI

	PUSHJ	P,LOUT			;PUT OUT CREF

IFE STANSW,<	POP	P,LOUTSX	;RESTORE INSTR >;NOT SU Ai

	POP	P,LNCNT			;RESTORE COUNTS
	POP	P,CHRCNT
	MOVE	TAC,[POINT 7,CREFTB,13]
	MOVEM	TAC,CREFPT		;REINITIALIZE BYTE POINTER FOR LATER DEPOSIT
	POPJ	P,
	BEND
BEGIN ENDS  SUBTTL END, PRGEND, BEND, BEGIN

;SUBROUTINE FOR MOST OF END, PRGEND

PRDEC:	IDIVI	T,=10
	HRLM	FS,(P)
	SKIPE	T
	PUSHJ	P,PRDEC
	HLRZ	T,(P)
	ADDI	T,"0"
	ROT	T,-7
	MOVEM	T,LBLK
	HRROI	TAC,LBLK
MSGOUT:	SKIPN	RPGSW
	OUTSTR	(TAC)
	TRNE	LDEV
	PUSHJ	P,LOUT
	POPJ	P,

DEFINE PRDCON(X)
<	PUSHJ	P,PRDEC
	HRROI	TAC,[ASCIZ/X/]
	PUSHJ	P,MSGOUT
>

DEFINE TWODIG(X)
<	CAIL	T,=10
	JRST	.+3
	HRROI	TAC,[ASCIZ/0/]
	PUSHJ	P,MSGOUT
	PRDCON	(<X>)
>

DEFINE THRDIG(X)
<	CAIL	T,=100
	JRST	.+3
	HRROI	TAC,[ASCIZ/0/]
	PUSHJ	P,MSGOUT
	TWODIG	(<X>)
>

^GTCPTM:	
TNX,<	MOVEI	1,400000
	RUNTM
	MOVEM	1,CPUTM
>;TNX
NOTNX,<
NOITS,<	MOVEI	1,0
	RUNTIM
	MOVEM	1,CPUTM
>;NOITS
>;NOTNX
	POPJ	P,

CPUTM:	BLOCK	2

DOEND:	MOVE	N,OPCNT+1	;LOCATION COUNTER FLAGS
	TLNE	N,INCF		;ARE WE IN AN UNTERMINATED LITERAL?
	JRST	[SUB P,[1,,1]	;YES. FIX STACK AND MAKE A LOSE MESSAGE
		JRST PSLIT]
	PUSHJ	P,VAR		;OUTPUT THE VARIABLES
	PUSH	P,0		;SAVE FLAGS
	TRZ	LDEV		;STOP LISTING: I DON'T WANT TO SEE THESE.  REG
	PUSHJ	P,LITOUT	;PUT OUT LITERALS
	POP	P,N		;RESTORE FLAG REGISTER
	ANDI	N,LDEV		;MASK OFF ALL BUT THIS
	TDO	0,N		;RESTORE LISTING IF IT WAS ON BEFORE.
	HRRZ	N,BLOCK
	CAIE	N,1		;AT OUTER LEVEL?
	ERROR	[ASCIZ/NOT ENOUGH "BEND" PSEUDO-OPS./]
	TRO	NOFXF
	SETZM	EN1+1
	SETZM	EN1+2
	PUSHJ	P,MEVAL		;GET ADDRESS
	TLNE	ESPF		;SPECIAL CHR?
	JRST	SPC		;YES
	TLNE	UNDF		;DEFINED?
	ERROR	[ASCIZ/UNDEFINED ADDRESS -- END/]
	MOVEM	N,EN1+2		;DEPOSIT STARTING ADDRESS
	ANDI	NA,1		;FORM RELOCATION
	ROT	NA,-2		;RELOCATION
	MOVEM	NA,EN1+1	;AND DEPOSIT
	POUT	3,EN1		;PUT OUT THE STARTING ADDRESS NOW
	JRST	EZERF
SPC:	TLNN	N,CRFG		;CR?
	ERROR	[ASCIZ/UNREC SPEC CHR -- END/]
EZERF:	PUSHJ	P,EBEND		;OUTPUT THIS BLOCK'S SYMBOLS. SPECIAL BEND FOR UNIV.
	PUSHJ	P,BFFRC		;FORCE OUT BINARY AND FIXUPS
	MOVEI	O,HASH-1	;INIT COUNT
ELOOP2:	SKIPN	PN,SYMTAB(O)	;GET START OF CHAIN
	JRST	NONTE		;NONE
ELOOP1:	SKIPE	CREFSW
	CREF66	11,(PN)
	MOVE	N,2(PN)		;GET FLAGS
	TLNE	N,EXTF		;EXTERNAL?
	JRST	EEXT		;YES
	TLNE	N,DEFFL		;DEFINED?
	JRST	EUND		;NO
	TLNE	N,INTF		;INTERNAL?
	JRST	EINT		;YES
				;REMAINDER ARE DOUBLE UP-ARROWED.
ELOOP3:				; ^^SYMS, INTERNALS, & EXTERNALS.
	MOVE	N,@US.S
	EXCH	N,1(PN)		;STORE FREE STG POINTER IN THIS NODE
	MOVEM	PN,@US.S	;STORE NODE ADDRESS IN FS POINTER
	SKIPE	PN,N		;SHUFFLE REGISTERS
	JRST	ELOOP1		;THERE ARE MORE ON THIS CHAIN
	JRST	NONTE		;NONE LEFT.

ECON:	SKIPE	PN,1(PN)	;GET NEXT
	JRST	ELOOP1
NONTE:	SOJGE	O,ELOOP2	;NO MORE, GET NEXT CHAIN
	PUSHJ	P,SBFRC		;FORCE OUT SYMBOLS
	SKIPN	SEG
	JRST	NBK		;NO UPPER SEGMENT
	MOVE	N,HICNT		;YES GET HIGH BREAK
	MOVE	NA,LOCNT	;GET LOW BREAK
	MOVEM	NA,WRD
	MOVSI	T,240000	;BOTH RELOC
	JRST	ENDOUT

NBK:	MOVE	N,LOCNT		;GET PROGRAM BREAK
	MOVEM	N,WRD
	MOVE	NA,ABSCNT	;AND ABS PROG BREAK
	CAIG	NA,140
	MOVEI	NA,		;ONLY SET IF PAST 140
	MOVSI	T,200000	;ONLY FIRST IS RELOC
ENDOUT:	MOVEM	T,EN2+1		;RELOCATION
	MOVEM	N,EN2+2		;IF SEG THEN <HICNT> ELSE <LOWCNT>
	MOVEM	NA,EN2+3	;IF SEG THEN <LOCNT> ELSE <ABSCNT>
	POUT	4,EN2		;OUTPUT IT
	MOVE	N,EN1+2
	MOVE	NA,EN1+1
	ROT	NA,2
	MOVEM	N,WRD
	MOVEM	NA,WRD+1
	PUSHJ	P,LBLOUT	;LIST STARTING ADDRESS
	PUSHJ	P,SCNTIL	;GET TO LF AND FORCE LISTING
	SETOM	XPNDSW
	PUSHJ	P,LSTFRC	;FORCE LISTING
	SKIPG	EN2+2		;LOW OR HIGH SET?
	JRST	ENDOT1		;NO.
	SKIPE	SEG		;SEGMENT
	SKIPA	TAC,[-HIMLNG,,HIMES]	;YES. USE HIGH BREAK
	MOVE	TAC,[-PRMLNG,,PRMES]	;ELSE PROGRAM BREAK
	PUSHJ	P,MSGOUT
	MOVS	FS,EN2+2	;GET THE BINARY ADDRESS
	MOVE	TAC,EN2+1
	ROT	TAC,2
	ANDI	TAC,3
	PUSHJ	P,OCON
	MOVEM	T,LBLK
	MOVEM	FS,LBLK+1
	MOVE	TAC,[-2,,LBLK]
	PUSHJ	P,MSGOUT
	HRROI	TAC,TTCRLF
	PUSHJ	P,MSGOUT
	PUSHJ	P,LSTFRC	;NOW REALLY FORCE LISTING
ENDOT1:	SKIPG	EN2+3		;ABS OR LOW SET?
	JRST	ENDOT2		;NO
	SKIPE	SEG		;SEGMENT
	SKIPA	TAC,[-LOMLNG,,LOMES]	;YES. LOW BREAK
	MOVE	TAC,[-ABMLNG,,ABMES]	;NO.  ABS BREAK
	PUSHJ	P,MSGOUT
	MOVS	FS,EN2+3	;GET THE BINARY
	MOVE	TAC,EN2+1
	ROT	TAC,4
	ANDI	TAC,3
	PUSHJ	P,OCON
	MOVEM	T,LBLK
	MOVEM	FS,LBLK+1
	MOVE	TAC,[-2,,LBLK]
	PUSHJ	P,MSGOUT
	HRROI	TAC,TTCRLF
	PUSHJ	P,MSGOUT
	PUSHJ	P,LSTFRC	;FORCE WHAT WE HAVE SO FAR
ENDOT2:	PUSH	P,CPUTM
	PUSHJ	P,GTCPTM	;GET CPU TIME
	POP	P,T		;GET OLD CPU TIME
	SUB	T,CPUTM		;LESS NEW CPU = -CPU ELAPSED TIME
	MOVNM	T,CPUTM+1	;STORE CPU ELAPSED TIME
	MOVE	TAC,[-CPTMSL,,CPTMSG]
	PUSHJ	P,MSGOUT
	MOVE	T,CPUTM+1
	IDIVI	T,=1000		;MILLISECONDS INTO FS
	PUSH	P,FS
	IDIVI	T,=60
	PUSH	P,FS		;SECONDS
	IDIVI	T,=60	
	PUSH	P,FS		;MINUTES.  HOURS IN T
	JUMPE	T,NOHRS		;JUMP IF NO HOURS TO PRINT
	PRDCON	(<:>)		;PRINT HOURS:
	MOVE	T,(P)		;GET MINUTES
	CAIL	T,=10		;NEED EXTRA DIGITS?
	JRST	NOHRS		;No.
	HRROI	TAC,[ASCIZ/0/]
	PUSHJ	P,MSGOUT
NOHRS:	POP	P,T
	PRDCON	(<:>)		;PRINT MINUTES:
	POP	P,T
	TWODIG	(<.>)		;SECONDS.
	POP	P,T
	THRDIG	(< >)		;MILLISECONDS
	HRROI	TAC,TTCRLF
	PUSHJ	P,MSGOUT
	JRST	LSTFRC


HIMES:	ASCII	/HIGH SEGMENT BREAK	/
HIMLNG__.-HIMES
	0
LOMES:	ASCII	/LOW SEGMENT BREAK	/
LOMLNG__.-LOMES
	0
PRMES:	ASCII	/PROGRAM BREAK	/
PRMLNG__.-PRMES
	0
ABMES:	ASCII	/ABSOLUTE BREAK	/
ABMLNG__.-ABMES
	0
CPTMSG:	ASCII	/ELAPSED CPU TIME /
CPTMSL==.-CPTMSG
	0
;	END	HANDLE INTERNALS, EXTERNALS, UNDEFINEDS
EINT:	MOVE	FS,(PN)		;GET SIXBIT
	PUSHJ	P,R5CON		;CON TO R5
	TLO	FS,40000	;MARK AS INTERNAL
	MOVE	N,2(PN)
ITS,<	TLNE	N,SUPBIT!ANONF	>;ITS
NOITS,<	TLNE	N,SUPBIT	>;NOITS  DON'T PASS ON SUPPRESSED SYMS. 
	JRST	ELOOP3
	TLNE	N,DBLF
	TLO	FS,SNB		;THESE CAN BE HALF-KILLED, TOO
	MOVEM	FS,IOU+2	;DEPOSIT
	MOVE	L,3(PN)		;GET VALUE
	MOVEM	L,IOU+3		;DEPOSIT
	MOVE	L,4(PN)		;GET RELOC
	DPB	L,[POINT 1,IOU+1,3]	;DEPOSIT
	POUT	4,IOU		;OUTPUT IT
	JRST	ELOOP3		;EMIT TO UNIV. CONTINUE SCAN FOR SYMBOLS

IOU:	XWD 2,2
	BLOCK 3

EUND:	MOVE	FS,(PN)		;GET SIXBIT
	PUSHJ	P,AFROM6	;CON TO ASCII
	MOVEM	T,EUOUT		;DEPOSIT
	OR	FS,[BYTE (7)0,11,"U","N","D"]
	MOVEM	FS,EUOUT+1	;DEPOSIT
	SKIPE	FS,3(PN)	;GET FIXUP POINTER
	SKIPA	TAC,4(FS)	;GET RELOC
	SKIPA	TAC,[0]		;NO RELOC(NO FIXUP)
	MOVE	FS,3(FS)	;GET FIXUP VALUE
	MOVSS	FS
	PUSHJ	P,OCON		;CON TO OCTAL ASCII
	MOVEM	T,EUOUT+3	;DEPOSIT
	MOVEM	FS,EUOUT+4	;...
	MOVEI	N,EUOUT
	PUSHJ	P,ERLST		;LIST
	JRST	ECON

EEXT:	MOVEI	N,1		;IN CASE THIS IS BEING KEPT AS A UNIVERSAL, REG 9/75
	IORB	N,2(PN)		;SET A BLOCK BIT SO SUBSEQUENT USERS WILL SEE IT.
	MOVE	FS,2(PN)	;GET FLAGS.
	SKIPN	3(PN)		;IS THERE A FIXUP POINTER?
	TLNN	FS,SUPBIT	;NO. IS THIS SUPPRESSED?
	JRST	EEXT1		;FIXUP POINTER, OR NOT SUPPRESSED
	SKIPN	4(PN)		;SUPPRESSED AND NO FIXUPS. ANY POLISH FIXUPS?
	JRST	ELOOP3		;NO REFERENCES AND THIS IS SUPRRESSED. OMIT SYMBOL.
EEXT1:	MOVE	FS,(PN)		;GET SIXBIT
	PUSHJ	P,R5CON		;CON TO R5
	TLO	FS,600000	;MARK AS EXT
	MOVEM	FS,IOU+2	;DEPOSIT
	SKIPN	N,3(PN)		;GET FIXUP POINTER
	JRST	[SETZM IOU+1	;ISSUE NULL REQUEST
		SETZM IOU+3	;TO ABS 0
		POUT 4,IOU
		JRST ECONN]	;OUTPUT IT. SCAN MORE SYMBOLS
EXCON:	SKIPE	NA,(N)		;GET DEVIATION
	JRST	POLEX		;NOT 0. NEED TO USE POLISH
	MOVE	TAC,2(N)	;GET FLAGS
	TRNE	TAC,3		;LEFT HALF OR FULL?
	JRST	POLEX		;YES - USE POLISH
	MOVE	TAC,3(N)	;GET VALUE
	MOVEM	TAC,IOU+3	;DEPOSIT
	MOVE	TAC,4(N)	;RELOC
	DPB	TAC,[POINT 1,IOU+1,3]	;DEPOSIT
	POUT	4,IOU		;OUTPUT
	SKIPE	N,1(N)		;IS THERE MORE?
	JRST	EXCON		;YES. DO IT.
ECONN:	SKIPN	N,4(PN)		;ANY POLFIXES?
	JRST	ECONN1		;NO.
ECLOP:	SOSG	1(N)		;LAST SYM?
	JRST	LAST		;YES
	MOVSS	N
	SKIPE	N,2(N)		;GET NEXT
	JRST	ECLOP		;MORE
ECONN1:	SETZM	3(PN)		;IN CASE OF UNIVERSALS, FLUSH OLD FIXUPS.
	SETZM	4(PN)
	JRST	ELOOP3
;	PROCESS EXTERNALS - CONTINUED

LAST:	MOVEI	FS,5(N)		;SET UP POINTER
	PUSH	P,O
	PUSHJ	P,REDUC		;REDUCE POLISH
	POP	P,O
	PUSHJ	P,BFRC		;FORCE OUT BIN
	MOVEI	FS,5(N)		;SET UP POINTER
	MOVS	NA,N		;GET NEXT
	MOVE	NA,2(NA)
	PUSHJ	P,POLOUT	;PUT OUT POLISH
	SKIPN	N,NA		;ANY MORE?
	JRST	ECON		;NO
	JRST	ECLOP		;YES

EXPOL:	11,,5
	0
	3,,2
	0
	1,,0
	0
	0

POLEX:	MOVE	NA,N
	MOVE	FS,(PN)		;GET SIXBIT
	PUSHJ	P,R5CON		;CON TO RADIX50
	TLO	FS,40000
	MOVEM	FS,EXPOL+3	;DEPOSIT
	MOVE	FS,(NA)		;GET DEVIATION
	HRLM	FS,EXPOL+5	;DEPOSIT
	HLRM	FS,EXPOL+4	;...
	MOVE	FS,2(NA)	;GET FLAGS
	ANDI	FS,3
	SETCA	FS,		;FORM STORE OP
	HRRM	FS,EXPOL+5	;DEPOSIT
	MOVE	FS,3(NA)	;GET FIXUP LOC.
	HRLM	FS,EXPOL+6	;DEPOSIT
	MOVE	FS,4(NA)	;GET RELOC
	DPB	FS,[POINT 1,EXPOL+1,8]	;DEP.
	POUT	7,EXPOL		;OUTPUT IT
	SKIPE	N,1(NA)		;GET NEXT
	JRST	EXCON		;MORE
	JRST	ECONN		;NO MORE
;	END AND PRGEND
^%END:	PUSHJ P,DOEND

NOTNX,<
^FEND:	CLOSE 1,
^FEND1:	RELEAS 4,
	RELEAS 2,

NOITS,<		MOVE	N,RELFIL+4	;DEVICE NAME WHERE REL FILE IS GOING
		DEVCHR	N,		;GET DEVICE CHARACTERISTICS WORD
		TRNE	BDEV		;SKIP IF THERE'S NO BINARY ANYWAY
		TLNN	N,200000	;DVDSK?
		JRST	FEND2		;NO BINARY, OR NOT DISK. AVOID RENAME.
		CLOSE	3,		;DSKSER SCREWS FILE IF RENAME BEFORE CLOSE
IFE TYMSW,<
FEND0:		DATE	NA,		;GET DATE
		TIMER	N,		;GET TIME IN JIFFIES
		DATE	T,
		CAME	T,NA
		JRST	FEND0		;AVOID BEING SCREWED AT MIDNIGHT!
		IDIVI	N,=3600		;MINUTES IN N.
		HRRM	T,RELFIL+1			;SET DATE
		LDB	NA,[POINT 3,T,23]		;GET HIGH PART OF DATE
		DPB	NA,[POINT 3,RELFIL+1,20]	;STUFF IT
		DPB	N,[POINT 11,T,23]		;STORE TIME
		TLO	T,600				;SET MODE TO 14
IFN STANSW,<	TLO	T,400000			;SET DUMP NEVER >
		MOVEM	T,RELFIL+2
		SETZM	RELFIL+3
		RENAME	3,RELFIL	;ADJUST DATE & TIME TO END OF ASSEMBLY
		JFCL			;	(LESS RPG LOSSAGE)>

FEND2: >;NOITS
		RELEAS	3,
		JRST	STRT1
>;NOTNX

TNX,<
^FEND:
^FEND1:	JSR	CLSSRC
	TRNE	LDEV
	JSR	CLSLST
	TRNE	BDEV
	JSR	CLSBIN
	JRST	STRT1

;ROUTINES TO CLOSE VARIOUS FILES.  SOME CARE IS NEEDED, ESPECIALLY IF WE
;	PMAPPED THE FILE IN THE FIRST PLACE.
^CLSSRC: 0
	TSVAC	<1,2,3>
	SKIPL	1,JFNTBL
	JRST	CLSSR1			;IF NOT PMAPPABLE
	SETO	1,
	MOVE	2,[XWD 400000,SRCBFP]
	SETZ	3,
	PMAP				;OUT OF CORE
	MOVE	1,JFNTBL
CLSSR1:	HRRZS	1,1
	TLO	1,400000		;DO NOT RELEASE JFN!!! (ERROR HANDLING...)
	CLOSF
	JFCL				;I HOPE WE DON'T LAND HERE
	TRSTAC	<1,2,3>
	JRST	@CLSSRC

^CLSBIN: 0
	TSVAC	<1,2,3>
	SKIPG	ODB+2			;WAS ANYTHING EVER WRITTEN?
	JRST	CLSBI1			;NO.  JUST CLOSE THE FILE.
	SKIPL	1,JFNTBL-2+3		;GET JFN. SKIP IF PMAPABLE
	JRST	CLSBI3			;NOT PMAPPABLE
	SETO	1,			;REMOVE FILE PAGE FROM CORE.
	MOVE	2,[XWD 400000,BINBFP]
	SETZ	3,
	PMAP				;OUT OF CORE
	MOVE	3,ODB			;CURRENT PAGE NUMBER
	AOJ	3,			;PLUS 1 = PAGE COUNT
	LSH	3,=9			;TOTAL NUMBER OF BYTES IF FULL
	SUB	3,ODB+2			;MINUS NUM REMAINING
	AOJ	3,			;PLUS ONE BECAUSE COUNT IS OFF
	SETO	2,			;SET ALL BITS IN FDB WORD
	HRR	1,JFNTBL-2+3		;
	HRLI	1,12			;FDBSIZ,,JFN
	CHFDB				;SET EOF WORD
CLSBI1:	HRRZ	1,JFNTBL-2+3		;JFN
	CLOSF				;CLOSE AND RELEASE JFN
	JFCL				;NO ERRORS I HOPE
	SETZM	JFNTBL-2+3
	TRSTAC	<1,2,3>
	JRST	@CLSBIN

CLSBI3:	MOVE	3,ODB+2			;BYTE COUNTER (# REMAINING)
	SUBI	3,1001			;3=-<NUMBER OF BYTES TO DUMP>
	HRRZ	1,JFNTBL-2+3
	HRROI	2,BINBF
	SOUT				;DUMP BUFFER
	JRST	CLSBI1

^CLSLST: 0
	TSVAC	<1,2,3>
	SKIPG	LOB+2			;ANYTHING EVER WRITTEN?
	JRST	CLSLS1			;NO.  NOTHING TO FORCE OUT
	SKIPL	1,JFNTBL-2+4		;GET JFN.  SKIP IF PMAPPED
	JRST	CLSLS3			;NOT PMAPPABLE
	SETO	1,			;FORCE CURRENT PAGE FROM CORE
	MOVE	2,[XWD 400000,LSTBFP]
	SETZ	3,
	PMAP				;OUT OF CORE
	MOVE	3,LOB			;LAST PAGE NUMBER OF FILE
	AOJ	3,			;PLUS 1 IS PAGE COUNT
	IMULI	3,1000*5		;TOTAL NUMBER OF BYTES IF FULL
	SUB	3,LOB+2			;MINUS NUM REMAINING
	AOJ	3,			;ADD ONE SINCE COUNT IS OFF
	SETO	2,			;SET ENTIRE WORD OF FILE SIZE
	HRR	1,JFNTBL-2+4
	HRLI	1,12			;FDBSIZ,,JFN
	CHFDB				;SET EOF
CLSLS1:	HRRZ	1,JFNTBL-2+4
	CLOSF
	JFCL
	SETZM	JFNTBL-2+4
	TRSTAC	<1,2,3>
	JRST	@CLSLST

CLSLS3:	MOVE	3,ODB+2			;GET # OF BYTES REMAINING
	SUBI	3,1000*5+1		;3=-<NUMBER OF BYTES IN BUFFER>
	HRRZ	1,JFNTBL-2+4
	HRROI	2,LSTBF
	SOUT				;DUMP BUFFER
	JRST	CLSLS1
>;TNX

EUOUT:	BLOCK 2
	ASCII /EF  	/
	BLOCK 2

EN1:	XWD 7,1
	0
	0

EN2:	5,,2
	200000,,
	0
	0

;PRGEND -- DOES END STUFF & RESTARTS PAST I/O INITIALIZATION
^%PRGEN:PUSHJ	P,DOEND			;SIMULATE END
	HRROI	TAC,[BYTE (7)14]
	TRNE LDEV
	PUSHJ P,LOUT	;DO PAGE HEADING IF NECC
	JRST STRT2
;ROUTINE TO PUT OUT SYMBOLS IN REASONABLE FASHION.
;CALL IS WITH:
;	FS		RADIX 50 FOR SYMBOL.
;	NA		VALUE
;	L		IF NON-ZERO, RELOCATED.

BDOUT:	XWD 2,22
	0		;RELOCATION INFORMATION
	BLOCK	22	;ROOM FOR MANY MANY SYMBOLS.....

BNPT:	ASCII /       	/
	BLOCK 3
	ASCII /    	/

SBOUT:
	PUSH	P,O	;NEED AN AC.
	AOS	BDOUT
	AOS	O,BDOUT
	MOVEM	FS,BDOUT(O)	;NAME.
	MOVEM	NA,BDOUT+1(O)	;VALUE
	TRZ	L,12
	TRZE	L,4		;CHANGE RELOCATION BITS.
	TRO	L,2
	IDPB	L,BYTPT		;STORE SAME.
	CAME	O,[XWD 2,22]	;DONE?
	JRST	STSQM		;DONE THIS SOON.
	PUSH	P,SBRRT		;RETURN FROM SBFRC TO STSYM
SBFRC:	PUSH	P,TAC
	PUSH	P,BC
	MOVEI	BC,BDOUT
	HRRZ	TAC,BDOUT	;COUNT
	TRNN	TAC,-1
	JRST	SBDON
	MOVNS	TAC		;- COUNT.
	HRLI	BC,-2(TAC)	;NEW COUNT.
	PUSHJ	P,GBOUT		;WRITE IT OUT.
SBDON:	POP	P,BC
	POP	P,TAC
SBRRT:	POPJ	P,STSYM		;(RETURN ADDRESS FOR FALL THRU CALL)
^SBINI:	PUSH	P,O		;HERE TO INITIALIZE SYMBOL TABLE OUTPUT
STSYM:	HLLZS	BDOUT		;RESTART COUNT.
	MOVE	O,[POINT 4,BDOUT+1]
	MOVEM	O,BYTPT		;RESTART BYTE POINTER.
STSQM:	POP	P,O
	POPJ	P,

BYTPT:	0
BEGIN BEND

^EBEND:	SKIPN	UNIVSW		;CALLED FROM DOEND.  SET UP FOR UNIVERSAL
	JRST	BEND		;NOTHING SPECIAL
	SETZM	U.OPC		;CLEAR POINTERS TO CHAINS OF SYMBOLS.
	SETZM	U.MAC
	SETZM	U.SYM
	MOVEI	O,U.MAC		;FOR UNIVERSALS, WE DON'T GIVE THINGS
	MOVEM	O,US.M		;  AWAY TO FREE STORAGE, BUT WE MAKE OUR
	MOVEI	O,U.OPC		;  OWN LISTS INSTEAD.
	MOVEM	O,US.O
	MOVEI	O,U.SYM
	MOVEM	O,US.S
	MOVE	O,[HLLM FS,1(N)]
	MOVEM	O,OLOPX#	;HACK TO FIXUP OPCODES
	MOVSI	O,(<JFCL>)	;SET MLOPX INSTRUCTION FOR GIVING BACK MACROS.
NOTNX,<	JRST	BEND.1	>
TNX,<	PUSHJ 	P,BEND.1	;PERFORM USUAL FUNCTIONS OF BEND
		MOVSI	NA,-HASH	;CHASE THRU OPCODE TABLE AND EMIT JSYS'S
EBEND1:		SKIPN	N,OPCDS(NA)
		JRST	EBEND4		;EMPTY CHAIN
		PUSH	P,NA
EBEND2:		SKIPLE	FS,1(N)		;SKIP IF PSEUDO-OP (OR SOME MACHINE OPS)
		TLNN	FS,20		;NOT PSEUDO. SKIP IF OPDEF.
		JRST	EBEND3
		PUSH	P,N
		MOVE	FS,(N)		;GET SYMBOL NAME
		SKIPE	CREFSW
		CREF66	13,(N)		;EMIT TO CREF
		PUSHJ	P,R5CON
		POP	P,N
		TLO	FS,100000
		MOVE	NA,3(N)		;GET VALUE
		MOVE	L,4(N)
		PUSHJ	P,SBOUT		;EMIT SYMBOL
EBEND3:		HRRZ	N,1(N)
		JUMPN	N,EBEND2
		POP	P,NA
EBEND4:		AOBJN	NA,EBEND1
		POPJ	P,>


^^BEND:	MOVEI	O,FSTPNT		;(SEE EBEND FOR WHAT HAPPENS TO UNIVERSALS)
	MOVEM	O,US.S			;ADDRESS OF "FREE STORAGE LIST" FOR SYMBOLS
	MOVEM	O,US.M			;   FOR MACROS
	MOVEM	O,US.O			;   FOR OPCODES
	MOVSI	O,(<JFCL>)
	MOVEM	O,OLOPX	
	MOVE	O,[PUSHJ P,MACRET]
BEND.1:	MOVEM	O,MLOPX#		;SET INSTRUCTION FOR RETURNING MACRO SPACE
	MOVE	NA,BLOCK
	SUBI	NA,1		;FORM WORD WITH ALL...
	MOVEM	NA,OBLK		;HIGHER LEVEL BITS ON
	MOVE	NA,BLOCK
	LSH	NA,-1		;FORM WORD WITH NEXT...
	MOVEM	NA,BLOCKN	;BIT ON
	MOVE	NA,BLOCK	;GET BLOCK...
	FAD	NA,[0]		;NUMBER
	LDB	NA,[POINT 8,NA,8]
	MOVE	FS,BNAM-347(NA)	;GET NEXT BLOCK NAME UP
	CAILE	NA,346		;AVOID MISTAKE AT END 
	MOVEM	FS,LSTLAB+3	;DEP FOR ERROR PRINT
	MOVE	FS,BNAM-346(NA)	;GET BLOCK NAME
	PUSHJ	P,R5CON		;CON TO R5
	TLO	FS,140000
	SUBI	NA,345
	PUSH	P,L
	SETZM	L		;NO RELOCATION.
	PUSHJ	P,SBOUT		;OUTPUT SYMBOL.
	POP	P,L
	MOVE	FS,BNAM-1(NA)	;GET NAME
	MOVEM	FS,NMBLK	;SAVE THE NAME
	SKIPE	CREFSW		;CREF?
	CREF7	16,FS		;YES
	PUSHJ	P,AFROM6	;CON TO ASCII
	MOVEM	T,BNPT+2	;DEPOSIT
	ORI	FS,20000+22
	MOVEM	FS,BNPT+3
	IDIVI	NA,12		;CONVERT LEVEL TO...
	ORI	PN,60		;DECIMAL...
	SKIPN	NA		;...
	SUBI	NA,20
	ADDI	NA,60		;...
	DPB	PN,[POINT 7,BNPT+4,13]	;AND..
	DPB	NA,[POINT 7,BNPT+4,6]	;DEPOSIT
	MOVE	NA,MTBPNT	;SET UP...
	MOVEM	NA,SPNT		;FOR PSYM
	MOVEM	NA,SSPNT	;...
	SETZM	SCOUNT		;...
	SETOM	MERCNT		;INIT MULT...
	MOVEI	NA,MERSTR	;DEF. LAB...
	MOVEM	NA,MERPNT	;MESSAGE AREA
;HERE WE CHASE THRU THE SYMBOLS AND PASS THE LOCAL ONES TO THE LOADER
	SKIPN	XPUNGS			;ARE WE EXPUNGING SYMBOLS?
	SKIPA	O,[PUSHJ P,SBOUT]	;NO. REPAIR INSTRUCTIONS BELOW.
	MOVSI	O,(<JFCL>)		;YES. NO-OP INSTRUCTIONS BELOW.
	MOVEM	O,IXPUNG#		;SET INSTR. TO BE XCT'D

	MOVEI	NA,HASH		;INITIAL SYMTAB COUNTER
LOOP1:	MOVEM	NA,NASAV	;SAVE
	MOVEI	NA,SYMTAB-1(NA)	;GET FIRST OF CHAIN
	SKIPN	O,(NA)
	JRST	NONC		;NONE
LOOP2:	MOVE	N,2(O)		;GET FLAGS
	TDNN	N,BLOCK		;THIS BLOCK?
	JRST	NOTHS		;NO. SKIP TO THE NEXT SYMBOL
	TLNE	N,UDSF		;IS THIS A DEFINED-UNDEFINED?
	JRST	LITLAB		;YES, SPECIAL CODE FOR ALL OF IT
	TLNE	N,DEFFL		;DEFINED?
	JRST	NODEF		;NO
	TLNE	N,DAF!GLOBF	;IS IT GLOBAL OR DOWN ARROW?
	JRST	DGLOB		;YES
CONT:	SKIPE	SYMOUT		;SYMBOL TABLE LISTING?
	JRST	[TLNN N,SUPBIT	;YES. BUT IS THIS SUPPRESSED?
		PUSHJ	P,PSYM	;NOT SUPPRESSED.  LIST THIS.
		JRST .+1]
	TLNE	N,INTF		;INTERNAL?
	JRST	UPAR1		;YES.  DEFER EMISSION 'TIL LATER
	TLNE	N,UPARF		;UPARROW?
	SKIPN	BLOCKN		;AND NOT AT OUTER LEVEL
	SKIPA
	JRST	UPAR1		;THEN DO NOT PUT OUT DEF
	MOVE	FS,(O)		;GET SIXBIT
	SKIPE	CREFSW
	CREF66	11,(O)
	PUSHJ	P,R5CON		;CON TO R5
	TLO	FS,100000	;BITS
	MOVE	N,2(O)		;GET FLAGS
	TLNE	N,DBLF		;__?
	TLO	FS,SNB		;YES -SET BIT TO SUPPRESS THE SYMBOL
	PUSH	P,NA
	MOVE	NA,3(O)		;GET VALUE
	MOVE	L,4(O)		;GET RELOC
ITS,<	TLNE	N,ANONF		;DON'T PUT IT OUT IF ANONYMOUS
	JRST	CONT1>
	TLNN	N,SUPBIT	;SKIP IF WE SHOULD SUPPRESS THIS SYMBOL.
	XCT	IXPUNG		;PUSHJ P,SBOUT, OR JFCL IF XPUNGS IS SET!
CONT1:	POP	P,NA
	TLNE	N,UPARF		;EMIT THIS LATER (WHY??)
	JRST	UPAR1		;(SEE ELOOP3)
DEL:	MOVE	T,@US.S		;GET FREE STRG PNTR. (FSTPNT, UNLESS UNIVERSALS)
	EXCH	T,1(O)		;PUT THIS BACK ON FREE STRG.
	MOVEM	O,@US.S		;...
DEL2:	MOVEM	T,(NA)		;& REMOVE FROM CHAIN
	SKIPE	O,T		;ANY MORE?
	JRST	LOOP2		;YES
NONC:	SOSLE	NA,NASAV	;GET NEXT SYMTAB CHAIN
	JRST	LOOP1

;HERE WE CHASE THRU THE OPCODE TABLE AND EMIT USER'S OPDEFS TO THE LOADER.
LDON:	PUSH	P,B
	PUSH	P,C
	MOVEI	NA,HASH		;PREPARE TO CUT BACK OPDEFS.
	MOVE	T,BLOCK		;TEST WORD
	MOVSI	FS,20		;@ BIT - SIGNIFIES OPDEF
OLOP1:	SKIPN	N,OPCDS-1(NA)	;GET FIRST CHAIN
	JRST	NONT		;NONE
OLOP:	TDNE	FS,1(N)		;ORDINARY OP?
	SKIPGE	1(N)		;NO. MAYBE A PSEUDO-OP?
	JRST	ENDF		;YES. STOP HERE. (MACHINE OPS AND CALLI'S LEFT)
	TDNN	T,2(N)		;THIS BLOCK?
	JRST	ENDF		;NO, QUIT (GET THIS LATER)
	PUSH	P,N		;SAVE POINTER
	MOVE	FS,(N)		;GET OPDEF NAME
	SKIPE	CREFSW
	CREF66	13,(N)
	PUSHJ	P,R5CON		;TO RADIX50 FOR DDT
	POP	P,N
	TLO	FS,100000	;SET AS LOCAL
	PUSH	P,NA		;SAVE IT.
	PUSH	P,L
	MOVE	NA,3(N)		;GET VALUE
	MOVE	L,2(N)		;GET FLAGS

NOITS,<		TLNE	L,SUPBIT	;SUPPRESSED? 	>;NOITS
ITS,<		TLNE	L,ANONF!SUPBIT	;SUPPRESSED OR ANONYMOUS? >;ITS
	JRST	OLOP2			;YES. DON'T EMIT TO LOADER

	MOVE	L,4(N)		;GET VALUE
	XCT	IXPUNG		;PUSHJ P,SBOUT, OR IF XPUNGES IS SET, JFCL
OLOP2:	POP	P,L
	POP	P,NA
OLOP3:	MOVSI	FS,20		;REPAIR FS.
	MOVE	O,@US.O		;ADD THIS OPCODE TO FREE STORAGE, OR TO UNIVERSALS
	EXCH	O,1(N)
	MOVEM	N,@US.O		;PUT BACK IN FREE STRG
	XCT	OLOPX		;JFCL, OR HLLM FS,1(N), IF UNIVERSAL
	HRRZ	N,O		;GET NEXT
	JUMPN	N,OLOP		;ANY MORE?
ENDF:	MOVEM	N,OPCDS-1(NA)
NONT:	SOJG	NA,OLOP1	;CONTINUE WITH NEXT CHAIN
	SETZM	XPUNGS		;NO LONGER EXPUNGING
	PUSHJ	P,SBFRC		;FORCE THE SYMBOLS OUT NOW
	PUSHJ	P,SBINI		;REINITIALIZE SYMBOL OUTPUT

;AND HERE WE CHASE THRU THE MACROS, EMITTING THEIR NAMES TO CREF, RECLAIMING SPACE
	MOVEI	NA,HASH		;PREPARE TO CUT BACK MACROS
MLOP1:	SKIPN	N,MACRT-1(NA)	;GET BASE OF CHAIN
	JRST	MLOP4		;CHAIN IS EMPTY
MLOP2:	TDNN	T,2(N)		;MACRO BELONGS TO THIS BLOCK?
	JRST	MLOP3		;NO. NOTHING LEFT TO DO ON THIS CHAIN
	SKIPE	CREFSW
	CREF66	13,(N)
	MOVE	C,4(N)		;GET START
	HLRZ	B,(C)		;GET LENGTH
	ADD	B,C		;GET END
	XCT	MLOPX		;GIVE BACK MACRO SPACE. (PUSHJ P,MACRET, OR JFCL)
	MOVE	O,@US.M		;PUT BACK ON FREE STRG. (OR GIVE TO UNIVERSAL)
	EXCH	O,1(N)		;STOR FS ADDRESS IN THIS BLOCK. ADDRESS OF NEXT IN O
	MOVEM	N,@US.M		;STORE ADDRESS OF THIS BLOCK IN FS HEADER
	SKIPE	N,O		;LINK TO NEXT.
	JRST	MLOP2		;LOOP IF THERE'S MORE TO DO.
MLOP3:	MOVEM	N,MACRT-1(NA)	;STORE NEW LINK TO MACRO LIST
MLOP4:	SOJG	NA,MLOP1	;GET NEXT CHAIN

	MOVE	N,BLOCK		;FORM NEXT-OUTER BLOCK BITS
	LSH	N,-1		;BLOCK...
	MOVEM	N,BLOCK	
	MOVN	N,N		;TWOS COMPLEMENT TO FORM DBLCK
	HRLI	N,DAF
	MOVEM	N,DBLCK		;DBLCK
	SKIPE	SYMOUT		;SYMBOL LISTING?
	PUSHJ	P,PSYMGO	;YES
	TRAN	BNPT		;LIST BLOCK NAME
	POP	P,C
	POP	P,B
	POPJ	P,
;HERE FOR INTERNALS, OR UP-ARROWED SYMS.  MOVE SYMBOL OUT ONE BLOCK
UPAR1:	MOVE L,(O)	;GET SIXBIT OF CURRENT SYMBOL
	SKIPN PN,1(O)	;ANY MORE?
	JRST UPAR
	MOVE T,O
UPAR1A:	CAMN L,(PN)	;LOOK FOR ANOTHER SYMBOL WITH THE SAME NAME AS THIS.
	JRST UNFD	;HERE WE HAVE ANOTHER ONE WITH THE SAME NAME.
	MOVE T,PN
	SKIPN PN,1(PN)
	JRST UPAR
	JRST UPAR1A	;PN POINTS TO SYMBOL. T= ADDR OF CELL THAT POINTS AT PN

UNFD:	MOVEM T,SVLNK	;SAVE LINK (THIS IS NEEDED TO DELINK SYMBOL.
	MOVE T,2(PN)	;GET FLAGS
	TDNN T,BLOCKN	;NEXT BLOCK?
	JRST UPAR	;NO.  WE JUST GO MOVE THIS OUT ONE BLOCK
	TLNN T,UDSF	;OR IF DEFINED-UNDEFINE
	TLZN T,DEFFL	;DEFINED?
	JRST MERR	;YES
	TLNE N,DBLUPF
	TRZA N,-1	;DON'T CLEAR ^ FLAG IF ^^
	TDZ N,[XWD UPARF,-1]
	OR T,N		;TRANSFER BITS
	TLZE	T,EXTF		;IF OUTER BLOCK SYMBOL WAS EXTERNAL, 
	TLO	T,INTF		; IT BECOMES INTERNAL
	TLNE	T,UDSF
	JRST	[MOVEM T,2(O)
		MOVE T,SVLNK	;ELIM UPPER BLOCK
		MOVE N,FSTPNT	;GET SECOND BLOCK ONTO FREE STORAGE
		EXCH N,1(PN)
		MOVEM N,1(T)
		MOVEM PN,FSTPNT
		EXCH PN,O	;EXCHANGE SO FIXUP COMBINE DONE RIGHT
		JRST UPNOD1]	;AND AWAY WE GO
	MOVEM T,2(PN)	;DEPOSIT
	EXCH PN,O
	SKIPE N,3(O)	;FIXUPS?
	PUSHJ P,GFIX	;YES
	SKIPE N,4(O)	;POL-FIXES?
	PUSHJ P,PFIX	;YES
	EXCH PN,O
	SKIPN CREFSW
	JRST .+3
	CREF6 10,(O)	;COMBINE TWO CHAINS
	CREF6 0,(PN)
	HRLI N,3(O)	;DEFINE..
	HRRI N,3(PN)	;IT ...
	BLT N,4(PN)	;ABOVE
	JRST DEL	;AND DELETE IT BELOW
MERER:	ASCII /MULTIPLY DEFINED BY ^  
/				;PRECISELY A MULTIPLE OF 5 CHARS.
MERSTR:	BLOCK 57
MEREND:	BLOCK 4
MERCNT:	0
MERPNT:	0

MERR:	AOSN	MERCNT		;ANY YET?
	ERROR	MERER		;NO, THIS IS FIRST
	MOVE	FS,MERPNT
	CAIL	FS,MEREND	;IS TABLE TOO FULL?
	JRST	MERR1		;YES, ADD ENDING MESSAGE.
	MOVE	FS,(PN)		;NO, GET SIXBIT
	PUSHJ	P,AFROM6	;CON TO ASCII
	MOVEM	T,@MERPNT	;DEPOSIT
	AOS	MERPNT		;INCREMENT
	OR	FS,[BYTE(7)0,40,40,15,12]
	MOVEM	FS,@MERPNT	;DEPOSIT
	AOS	MERPNT		;INCREMENT
	SETZM	@MERPNT		;MAKE SURE IT GETS STOPPED.
	JRST	DEL

MERR1:	MOVE	T,[ASCII/MORE /]
	MOVEM	T,(FS)
	MOVE	T,CRLF
	MOVEM	T,1(FS)
	JRST	DEL

UPAR:	HRRES	N		;GET BLOCK BIT
	LSH	N,-1		;SHIFT
	HLL	N,2(O)		;GET FLAGS
	TLNN	N,DBLUPF	;NOT IF DOUBLE UP ARROW.
	TLZ	N,UPARF		;CLEAR UPARROW BIT
	MOVEM	N,2(O)		;REDEPOSIT
NOTHS:	MOVEI	NA,1(O)		;PASS THIS ONE...
	SKIPE	O,1(O)		;AND LEAVE...
	JRST	LOOP2		;ALONE
	JRST	NONC		;NO MORE THIS CHAIN

DGLOB:	TDNN	N,OBLK		;ANY OTHER BLOCK BITS ON?
	JRST	CONT		;NO
GLB1:	TLNN	N,DAF		;DOWN-ARROW?
	TDZ	N,BLOCK		;NO, GLOBAL, TURN OFF THIS BIT
	MOVEM	N,2(O)		;DEPOSIT
	JRST	NOTHS
;HERE WE'RE LEAVING A BLOCK, AND AN UDEFINED SYMBOL HAS BEEN REFERENCED
NODEF:	MOVE	L,(O)		;GET SIXBIT
	SKIPN	PN,1(O)		;ANY MORE?
	JRST	UPAR		;NO.  THERE IS NO OTHER DEFINITION OF THIS SYMBOL
	SRC1	(L,PN,NFND,JRST UPAR)
NFND:	MOVE	T,2(PN)		;GET FLAGS
	TDNN	T,BLOCKN	;NEXT BLOCK UP?
	JRST	UPAR		;NO. WE MOVE THIS SYMBOL ONE BLOCK OUT
	TLNE	T,DEFFL		;DEFINED?
	JRST	UPNOD		;NO.  MOVE IT OUT, MERGING WITH OTHER FIXUPS
	TLNE	T,UDSF		;UNDEFINED - DEFINED SYMBOL
	JRST	MERR		;YES (I DON'T UNDERSTAND HOW THIS CAN HAPPEN - REG)
	SKIPN	CREFSW		;SYMBOL HAS BEEN DEFINED IN OUTER BLOCK.
	JRST	.+3
	CREF6	10,(O)
	CREF6	0,(PN)
	SKIPE	N,3(O)		;ANY FIXUPS?
	PUSHJ	P,GFIX		;YES, PUT OUT
	SKIPE	N,4(O)		;ANY POLFIXES?
	PUSHJ	P,PFIX		;YES, DO
	JRST	DEL		;NOW, FLUSH THE SYMBOL DEFINITION

;HERE THE SYMBOL IS UNDEFINED IN THE NEXT-OUTER BLOCK.  MERGE FIXUPS
UPNOD:	MOVE	L,2(O)		;GET FLAGS
	AND	L,[XWD EXTF!INTF!VARF!UDSF,0]
	ORM	L,2(PN)		;DEPOSIT CERTAIN FLAGS
UPNOD1:	SKIPN	CREFSW		;MERGE O-SYMBOL FROM INNER WITH PN-SYMBOL FROM OUTER
	JRST	.+3
	CREF6	10,(O)
	CREF6	0,(PN)
	SKIPN	L,3(O)		;ANY FIXUPS
	JRST	AHD		;NO. DO POLISH FIXUPS
	MOVE	T,3(PN)		;SAVE FIXUPS FROM OUTER BLOCK SYMBOLS
	MOVEM	L,3(PN)		;STORE INNER BLOCK FIXUPS IN OUTER BLOCK SYMBOL
ALOP:	SKIPN	FS,1(L)		;FIND THE END OF THE INNER BLOCK FIXUPS.
	JRST	EFND		;GOT IT  1(L) IS THE END OF THE INNER FIXUP LIST
	MOVE	L,FS		;LINK ON
	JRST	ALOP

EFND:	MOVEM	T,1(L)		;APPEND OUTER BLOCK FIXUP LIST TO THE END OF FIXLIST
AHD:	SKIPN	L,4(O)		;REPEAT THE ABOVE FOR POLFIXES
	JRST	PFND1
	MOVE	T,4(PN)
	MOVEM	L,4(PN)
	MOVSS	L
PLOP:	MOVEM	PN,(L)		;EXCEPT LINK IS THE LEFT HALF OF THIRD WORD
	SKIPN	FS,2(L)		;AND WE STORE THE NEW SYMBLOCK (PN) IN EACH POLFIX
	JRST	PFND
	MOVS	L,FS
	JRST	PLOP

PFND:	MOVEM	T,2(L)		;OTHER
PFND1:	MOVE	T,2(PN)		;MORE FLAGS
	CAME	O,FSTPNT	;THIS WILL BE TRUE ONLY IF WE CAME FROM ^UDSF (UNFD)
	JRST	DEL
	EXCH	PN,O
	JRST	NOTHS		;SKIP DELETING THIS

OBLK:	0
NASAV:	0
BLOCKN:	0
NMBLK:	0
SVLNK:	0
LITLAB:	TLNE N,DAF!GLOBF	;BOY ARE THESE A PAIN
	JRST LITGLB
	SKIPE SYMOUT
	PUSHJ P,PSYM
	TLNE N,INTF!UPARF	;BUT THESE ARE WORSE
	JRST UPAR1		;BECAUSE OF THE PAIN THEY CAUSE HERE
LITCNT:	MOVE FS,(O)	;GET SIXBIT
	SKIPE CREFSW
	CREF66 11,(O)
	PUSHJ P,R5CON
	TLO FS,100000	;SET TO LOCAL
	MOVSI N,SYMFIX	;SAY WE NEED SYMBOL TABLE FIXUP
	IORB N,2(O)	;GET FLAGS
	TLNE N,DBLF
	TLO FS,SNB	;SET DELETE FLAG (HALF KILLED)
	PUSH	P,L
	PUSH	P,NA
	SETZB	L,NA
	PUSHJ	P,SBOUT
	POP	P,NA
	POP	P,L
	MOVE T,NMBLK
	EXCH T,1(O)	;PUT BLOCK NAME IN
	JRST DEL2	;GO FINISH THE DELETE

LITGLB:	TDNN N,OBLK
	JRST LITCNT
	JRST GLB1
;SYMBOL TABLE LISTING.  PSYM, PSYMGO

SNBN__377777

;ENTER HERE TO INCLUDE ONE SYMBOL IN SYMBOL TABLE LISTING.  POINTER TO SYM IN O
PSYM:	TRNN	LDEV		;LIST DEV?
	POPJ	P,		;NO
	HRRZ	T,SPNT		;DESTINATION FOR BLT
	HRLI	T,2(O)		;SOURCE FOR BLT
	MOVEI	L,3		;INCREMENT SPNT FOR NEXT SYMBOL
	ADDB	L,SPNT
LEG	SETZM	-1(L)		;ADDRESS CHECK THE BLT AND EXPAND CORE IF NEEDED
	BLT	T,-1(L)		;SAVE VALUES
	SKIPA	T,(O)		;GET SIXBIT
	LSH	T,6
	TLNN	T,770000	;LEFT ADJUST SIXBIT
	JRST	.-2
	TLC	T,SNB		;INVERT SIGN FOR COMPARE
	MOVEM	T,-3(L)		;DEPOSIT
	AOS	SCOUNT		;COUNT ONE MORE SYMBOL SEEN
	POPJ	P,

;HERE TO SORT THE SYMBOLS AND OUTPUT THEM.  (ANOTHER LOSING N-SQUARED SORT)
PSYMGO:	SKIPN	SCOUNT		;ANY SYMBOLS TO LIST?
	POPJ	P,		;NO
	PUSHJ	P,LSTCHK
	MOVEI	TAC,CRLF
	PUSHJ	P,LOUT
SLOOP2:	HRLOI	FS,SNBN		;INIT - LARGEST POSSIBLE NUMBER
	MOVE	NA,SCOUNT	;GET COUNT
	MOVE	PN,SSPNT	;GET START OF SYMBOLS
SLOOP1:	CAMG	FS,(PN)		;COMPARE
	JRST	SPT1		;NEW ONE LARGER
	MOVE	N,PN		;SAVE POINTER
	MOVE	FS,(PN)		;GET NEW SIXBIT
SPT1:	ADDI	PN,3		;GO TO NEXT
	SOJG	NA,SLOOP1	;LOOP
	CAMN	FS,[SNBN,,-1]	;DONE?
	JRST	[MOVEI TAC,CRLF	;YES. RETURN
		JRST LOUT]
	HRLOI	NA,SNBN		;REMOVE...
	MOVEM	NA,(N)		;THIS ONE
	TLC	FS,SNB		;REINVERT SIGN
	PUSHJ	P,AFROM6	;CON TO ASCII
	MOVEM	T,SOUTX		;DEPOSIT
	TLO	FS,220		;PUT IN TAB
	MOVEM	FS,SOUTX+1	;DEPOSIT
	MOVS	FS,1(N)		;GET VALUE...
	MOVE	TAC,2(N)	;& RELOC
	SETZM	SOUTX+2
	MOVEI	T,22		;ANOTHER TAB
	MOVEM	T,SOUTX+3
	TRNN	FS,-1		;LEFT HALF =0?
	JRST	SPT2		;YES
	MOVSS	FS		;GET LEFT HALF
	LSH	TAC,-2		;& RELOC
	PUSHJ	P,OCON		;CON TO OCTAL ASCII
	MOVEM	T,SOUTX+2	;DEPOSIT
	MOVEM	FS,SOUTX+3	;...
	MOVS	FS,1(N)		;GET RIGHT HALF
	MOVE	TAC,2(N)	;& RELOC
SPT2:	PUSHJ	P,OCON		;CONVERT
	MOVEM	T,SOUTX+4	;DEPOSIT
	MOVEM	FS,SOUTX+5	;...
	MOVE	TAC,[XWD -7,SOUTX]
	PUSHJ	P,LOUT		;OUTPUT IT
	JRST	SLOOP2

SOUTX:	BLOCK 6
	BYTE (7)15,12

;AFROM6:  CONVERTS 6-BIT TO ASCII.  CALL WITH 6-BIT IN FS.
;	RETURNS ASCII IN T & FS.

^^AFROM6:
	MOVEI T,0
ALE1:	LSHC T,6	;GET CHR.
	TRCE T,40	;CON TO ASCII
	TRO T,100	;...
	LSH T,1		;LEAVE ROOM
	TLNN T,700000	;5 CHRS?
	JRST ALE1	;NO
	LSH FS,-1	;ADJUST FINAL CHR.
	TLCE FS,200000	;CON TO ...
	TLO FS,SNB	;ASCII
	POPJ P,

SCOUNT:	0
SPNT:	0
SSPNT:	0
	BEND	BEND
	BEND	ENDS
;	BEGIN AND BEND
%BEG:	MOVE N,BLOCK	;GET BLOCK...
	TRNE N,600000	;LEGAL BEGIN?
	ERROR[ASCIZ/BLOCKS NESTED TOO DEEP/]
	LSH N,1		;SHIFT
	MOVEM N,BLOCK	;RESTORE
	MOVNS N		;FORM DBLK (MASK FOR ALL LOWER BLOCKS)
	HRLI N,DAF	;...
	MOVEM N,DBLCK	;...
	AOS %BCUR	;INCREMENT COUNT OF BEGINS
	PUSHJ P,SCAN	;GET NAME, IF ANY
	TLNE IFLG	;IDENT?
	JRST %BPT	;YES
	MOVE L,['A.000'];GET BASIC
	MOVE FS,%BCUR	;GET CURRENT NUM
	DPB FS,[POINT 3,L,35]
	LSH FS,-3
	DPB FS,[POINT 3,L,29]
	LSH FS,-3
	DPB FS,[POINT 3,L,23]
%BPT:	MOVEM L,LSTLAB+3 ;DEPOSIT FOR ERROR MESSAGE PRINTER
	MOVE T,BLOCK
	FAD T,[0]
	LDB T,[POINT 8,T,8];GET NUM
	MOVEM L,BNAM-346(T);DEPOSIT NAME
	SKIPE CREFSW	;CREF?
	CREF7 15,L	;YES
	MOVE FS,L	;GET NAME
	MOVE NA,T
	PUSHJ P,AFROM6	;CON TO ASCII
	MOVEM T,%BQ+2	;DEPOSIT
	ORI FS,20022	;...
	MOVEM FS,%BQ+3	;...
	SUBI NA,345	;GET LEVEL NUMBER
	IDIVI NA,12	;CON TO...
	SKIPN NA		;DECIMAL...
	SUBI NA,20	;...
	ADDI NA,60	;...
	ADDI PN,60	;...
	DPB NA,[POINT 7,%BQ+4,6]
	DPB PN,[POINT 7,%BQ+4,13]
	TRAN %BQ		;LIST BLOCK NAME & LEVEL
	JRST NSPCFN

%BCUR:	0
%BQ:	ASCII /       	/
	BLOCK 3
	ASCII /    	/

%BEND:	MOVE T,BLOCK
	SOJLE T,BERR	;BARF IF ALREADY OUTER BLOCK
	PUSHJ P,SCAN	;GET OPTIONAL BLOCK NAME
	TLNN IFLG
	JRST BENDNA
	MOVE T,BLOCK
	FSC T,32
	ROT T,9
	CAME L,BNAM(T)
	ERROR [ASCIZ /BLOCK NAME MISMATCH/]
BENDNA:	PUSH P,N
	PUSHJ P,BEND
	POP P,N
	JRST NSPCFN

BERR:	ERROR [ASCIZ /TOO MANY BENDS/]
	JRST NSPCFN
BEGIN	LITOUT  SUBTTL	LITOUT	OUTPUT LITERALS, VARIABLES

^LITOUT:
	MOVSI	O,-HASH
LITLP0:	SKIPN	NA,LITPNT(O)		;ANYTHING TO DO HERE?
	JRST	LITLP1			;NO.
	PUSH	P,O			;SAVE INDEX TO LITPNT
IFE DWPSW,<	PUSHJ	P,LITSRT >	;SORT LITERALS.  IDENTICAL ONES ARE MERGED
LOP2:	MOVE	O,1(NA)			;GET NEXT LITERAL
	HLRZ	L,2(NA)			;ANY LABELS?
	JUMPE	L,NOLBS			;NO
	PUSH	P,O
	PUSH	P,NA
	MOVE	O,L
PT1:	MOVE	PN,4(O)			;GET POINTER TO SYMBOL TABLE ENTRY
	MOVE	N,PCNT			;GET VALUE
	MOVE	NA,PCNT+1
	ADD	N,3(O)			;ADD COUNT
	PUSHJ	P,LVDEF			;DEFINE IT
	MOVE	N,FSTPNT
	SKIPE	(O)			;CHECK FOR $. KLUDGE
	JRST	LLOK			;NOPE
	MOVEM	N,1(PN)			;RETURN "SYM" TO FS
	MOVEI	N,(PN)
LLOK:	EXCH	N,1(O)			;NOW RET LITLAB BLK
	MOVEM	O,FSTPNT
	SKIPE	O,N
	JRST	PT1
	POP	P,NA			;RESTORE
	POP	P,O
NOLBS:	MOVEI	PN,PCNT-3		;SET UP "VALUE" POINTER FOR GFIX
	SKIPE	N,3(NA)			;GET FIXUP POINTER
	PUSHJ	P,GFIX			;PUT OUT FIXUPS
	SKIPE	N,4(NA)
	PUSHJ	P,PFIX
	MOVE	N,FSTPNT		;GET FREE STRG
	MOVEM	N,1(NA)			;PUT THIS BACK ON FREE STRG
	MOVEM	NA,FSTPNT		;...
	HRRZ	L,2(NA)			;GET VALUES
LOP1:	SKIPN	4(L)			;ANYTHING HERE?
	JRST	LPT3			;NO
	HRLI	PN,3(L)			;GET POINTER TO VALUE
	HRRI	PN,WRD
	BLT	PN,WRD+1		;PUT IN WRD
	PUSHJ	P,BLOUT			;LIST VALUE
	OUTP	3(L)			;OUTPUT VALUE
	SKIPN	N,(L)			;REVERSE FIXUP?
	JRST	LPT1			;NO
	JUMPGE	N,.+3			;POLISH FIXUP?
	PUSHJ	P,POLHAN		;YES, HANDLE
	JRST	LPT1
	HRRI	TAC,3(N)
	HRLI	TAC,OPCNT
	BLT	TAC,4(N)		;SET FIXUP WHICH POINTS HERE
					;   TO POINT TO CORE
LPT1:	SKIPN	N,2(L)			;REVERSE FIXUP, LEFT HALF?
	JRST	LPT2			;NO
	JUMPGE	N,.+3
	PUSHJ	P,POLHAN
	JRST	LPT2
	HRRI	TAC,3(N)	
	HRLI	TAC,OPCNT
	BLT	TAC,4(N)		;SET THIS ONE
LPT2:	AOS	OPCNT			;INCREMENT
	MOVE	N,OPCNT
	CAMGE	N,BRK
	JRST	.+5
	CAMGE	N,HICNT
	JRST	.+5
	MOVEM	N,HICNT
	JRST	.+3
	CAML	N,@CURBRK
	MOVEM	N,@CURBRK
	AOS	PCNT			;...
LPT3:	MOVE	N,FSTPNT
	EXCH	N,1(L)			;PUT THIS BACK...
	MOVEM	L,FSTPNT		;IN FREE STRG.
	SKIPE	L,N			;ANY MORE
	JRST	LOP1			;YES
	SKIPE	NA,O			;GET NEXT LITERAL, MORE?
	JRST	LOP2			;THERE ARE MORE
	POP	P,O			;RESTORE INDEX TO LITPNT
	SETZM	LITPNT(O)		;CLEAR CHAIN
LITLP1:	AOBJN	O,LITLP0
	POPJ	P,

POLHAN:	MOVE	TAC,OPCNT		;GET PLACE WHERE THIS IS...
	MOVEM	TAC,2(N)		;GOING & MAKE POLFIX...
	MOVE	TAC,OPCNT+1		;POINT THERE
	MOVEM	TAC,3(N)
	SKIPLE	1(N)			;NO UNDEF SYMS LEFT?
	POPJ	P,			;SOME LEFT
	MOVEI	FS,5(N)			;SET UP POINTER
	PUSH	P,O			;SAVE
	PUSH	P,L
	PUSHJ	P,REDUC			;REDUCE THE POLISH
	PUSHJ	P,BFRC			;FORCE OUT BINARY
	MOVEI	FS,5(N)			;SET UP POINTER
	PUSHJ	P,POLOUT		;PUT OUT POLFIX
	POP	P,L
	POP	P,O
	POPJ	P,
;SORT THE LITERALS.  DO CONTANT'S OPTIMIZATION.
LITSRT:	JUMPE	NA,CPOPJ		;NO WORK FOR NO LIST
	SKIPN	FS,1(NA)		;GET LINK TO NEXT
	POPJ	P,			;NO NEXT. - A ONE-ELMENT LIST IS SORTED.
;NA AND FS WILL BE NEARLY-EQUAL LENGTH LISTS
	MOVE	O,FS			;TAIL OF THE FS LIST
	MOVE	L,NA			;TAIL OF THE NA LIST
LITSR1:	MOVE	N,1(O)			;GET LINK-OUT OF FS LIST
	MOVEM	N,1(L)			;STORE AS LINK-OUT IN NA LIST
	SKIPN	L,N			;ADVANCE NA-TAIL
	JRST	LITSR2			;NO NEXT
	MOVE	N,1(L)			;GET LINK-OUT OF NA-LIST
	MOVEM	N,1(O)			;STORE AS LINK-OUT OF FS-LIST
	SKIPE	O,N			;ADVANCE FS-TAIL
	JRST	LITSR1			;MAKE LISTS OF ALTERNATE ELEMENTS.
LITSR2:	PUSH	P,FS			;SAVE FS-LIST
	PUSHJ	P,LITSRT		;SORT THE NA-LIST (RECUR UNTIL DONE)
	EXCH	NA,(P)			;EXCH SORTED LIST WITH FS-LIST
	PUSHJ	P,LITSRT		;AND SORT FS-LIST
	POP	P,FS			;(FS AND NA ARE INTERCHANGED, BUT WHO CARES)
;FS AND NA NOW (ASSUME) POINT TO SORTED LISTS.  MERGE THEM INTO ONE LIST.
	MOVEI	L,O-1			;MERGE LIST HEAD IN O
	JUMPE	NA,LITSR4		;NO MERGE IF NA IS EMPTY. ADD FS TO OUT-LIST
	EXCH	NA,FS			;SWAP THEM (WHO CARES?)
	JUMPE	NA,LITSR4		;NO MERGE IF NA IS EMPTY. ADD FS TO OUT-LIST
LITSR3:	PUSHJ	P,LCOMP			;COMPARE CAR(FS) AND CAR(NA).
					;  RETURN SMALLEST IN NA
	MOVEM	NA,1(L)			;NA<FS. ADD CAR(NA) TO OUT-LIST
	MOVEI	L,(NA)			;ADVANCE END OF OUT-LIST.
	SKIPE	NA,1(NA)		;FORM CDR(NA)
	JRST	LITSR3			;CONTINUE THE MERGE
LITSR4:	MOVEM	FS,1(L)			;STORE OTHER LIST IN THE OUT-LIST
	MOVE	NA,O			;GET THE ADDRESS OF THE LIST-HEAD
	POPJ	P,			;RETURN, POINTER TO SORTED LIST IN NA


;LCOMP - COMPARE CAR(NA) AND CAR(FS).

;EXIT ROUTINES...
;CALLED BY CAME TAC,...  JSP T,NOSAME.  TAC CONTAINS NA-DATA.
NOSAME:	CAML	TAC,@-2(T)		;DO THE COMPARE AGAIN. SKIP IF NA<FS
	EXCH	NA,FS			;MAKE NA<FS
	POPJ	P,

;HERE IF THEY'RE NOT THE SAME, BUT CAN'T DECIDE SORTING-ORDER. COMPARE ADDRESSES
NOSAM1:	CAML	NA,FS			;USE LITERAL'S ADDRESS TO RESOVE AMBIGUITY
	EXCH	NA,FS			;MAKE NA<FS
	POPJ	P,

LCOMP:	MOVE	TAC,(NA)		;COMPARE LITERALS AT NA AND FS.
	CAME	TAC,(FS)		;ARE COUNTS THE SAME?
	JSP	T,NOSAME		;NO
	MOVE	T,TAC			;REMEMBER WORD COUNT
	MOVE	N,2(NA)			;SET UP POINTERS TO THE VALUE CHAINS
	MOVE	PN,2(FS)
LCOMP1:	MOVE	TAC,3(N)		;COMPARE VALUE WORDS...
	CAME	TAC,3(PN)
	JSP	T,NOSAME		;DIFFERENT
	MOVE	TAC,4(N)		;COMPARE FLAGS...
	CAME	TAC,4(PN)
	JSP	T,NOSAME		;DIFFERENT
	SKIPN	(N)
	SKIPE	(PN)
	JRST	NOSAM1			;UNDEFINED.
	SKIPN	2(N)
	SKIPE	2(PN)
	JRST	NOSAM1			;UNDEFINED.
	MOVE	N,1(N)			;ADVANCE VALUE POINTERS TO NEXT
	MOVE	PN,1(PN)		;   VALUE CELLS
	SOJG	T,LCOMP1		;JUMP UNLESS DONE.
;HERE THE TWO LITERALS ARE THE SAME, AND WE FLUSH ONE OF THEM
SAME:	SKIPN	PN,3(FS)		;GET FIXUPS FOR THIS ONE. -ELIMINATE CAR(FS)
	JRST	NOTN1			;NONE.
	MOVE	T,3(NA)			;GET FIXUPS FOR OTHER
	MOVEM	PN,3(NA)		;STORE OTHER-FIXUPS IN THIS ONE
	JUMPE	T,NOTN1			;IF THERE ARE NO  "THIS-FIXUPS", WE'RE DONE
LOOP2:	SKIPN	N,1(PN)			;SEEK END OF THE OTHER-LIST
	JRST	EFND			;FOUND IT.
	MOVE	PN,N			;LINK ON
	JRST	LOOP2
EFND:	MOVEM	T,1(PN)			;HEAD OF THIS-LIST INTO TAIL OF OTHER-LIST

NOTN1:	SKIPN	PN,4(FS)		;SAME AS ABOVE FOR POLFIXES.
	JRST	NOTN2			;NONE.
	MOVE	T,4(NA)	
	MOVEM	PN,4(NA)
	JUMPE	T,NOTN2
LPQ2:	SKIPN	N,1(PN)			;SEEK END OF THE OTHER-LIST
	JRST	Q2FND			;FOUND IT.
	MOVE	PN,N			;LINK ON
	JRST	LPQ2
Q2FND:	MOVEM	T,1(PN)			;HEAD OF THIS-LIST INTO TAIL OF OTHER-LIST

NOTN2:	HLRZ	PN,2(FS)		;SAME AS ABOVE FOR LABELS
	JUMPE	PN,NOTN3		;NONE.
	HLRZ	T,2(NA)	
	HRLM	PN,2(NA)
	JUMPE	T,NOTN3
LPQ3:	SKIPN	N,1(PN)			;SEEK END OF THE OTHER-LIST
	JRST	Q3FND			;FOUND IT.
	MOVE	PN,N			;LINK ON
	JRST	LPQ3
Q3FND:	MOVEM	T,1(PN)			;HEAD OF THIS-LIST INTO TAIL OF OTHER-LIST

NOTN3:	MOVE	N,FS			;REMEMBER ADDRESS OF CAR(FS)
	MOVE	FS,1(FS)		;FS_CDR(FS)

	MOVE	T,FSTPNT
	MOVEM	T,1(N)			;POINT LITERAL HEADER AT FS.
	HRRZ	T,2(N)			;GET POINTER TO VALUE LIST
	MOVEM	T,FSTPNT		;ADD VALUE-LIST TO FS.
LOOP4:	SKIPN	TAC,1(T)		;SEEK END OF VALUE-LIST
	JRST	VFND			;END FOUND
	MOVE	T,TAC
	JRST	LOOP4
VFND:	MOVEM	N,1(T)			;STORE LITERAL-HEADER AT END OF LIST
	POPJ	P,			;NA CONTAINS POINTER TO SMALLEST.
;	VAR AND %VAR

^%VAR:	MOVE	N,OPCNT+1		;VAR PSEUDO-OP
	TLNE	N,INCF
	JRST	PSLIT
	PUSH	P,[SPCFN]		;SET RETURN ADDRESS.  FALL INTO VAR

^VAR:	PUSHJ	P,BFRC			;FORCE OUT BINARY
	MOVE	NA,PCNT+1		;GET READY
LOOP.1:	SKIPN	TAC,VARLST
	POPJ	P,			;NONE THERE
	MOVE	PN,FSTPNT		;PUT BACK ON FREE STORAGE
	EXCH	PN,1(TAC)
	MOVEM	PN,VARLST		;KEEP VARLST UP TO DATE
	MOVEM	TAC,FSTPNT
	MOVE	PN,(TAC)		;SYMBOL NAME
	AOS	N,2(TAC)		;NUMBER OF WORDS NEEDED
					;(WAS STORED AS ONE TOO SMALL)
	ADDM	N,OPCNT
	EXCH	N,PCNT
	ADDM	N,PCNT
	PUSHJ	P,LVDEF			;DEFINE VARIABLE HERE (N = LOCATION)
	MOVE	N,OPCNT
	CAMGE	N,BRK
	JRST	LOOP.2
	CAML	N,HICNT
	MOVEM	N,HICNT
	JRST	LOOP.1

LOOP.2:	CAML	N,@CURBRK
	MOVEM	N,@CURBRK
	JRST	LOOP.1


BEND
BEGIN ORG  SUBTTL ORG, LOC, RELOC, USE, AND SET

^%ORG:	MOVE NA,OPCNT+1
	TLNE NA,INCF
	JRST PSLIT
	MOVEM N,SV	;SAVE VALUE
	PUSHJ P,BFFRC	;FORCE OUT BINARY AND FIXUPS
	TRO NOFXF
	PUSHJ P,MEVAL	;GET VALUE
	TLNE UNDF	;DEFINED?
	JRST OERR	;NO
	TLNE ESPF	;SPC. CHR?
	JRST SCR	;YES
	MOVE T,[XWD PCNT,PCSAV]
	BLT T,PCSAV+3	;SAVE OLD LOC.
	SKIPN SV	;IS IT LOC?
	MOVEI NA,	;YES
	SKIPGE SV	;IS IT RELOC?
	MOVEI NA,1	;YES
ORG2:	ANDI N,777777	;LEAVE US NOT GET CONFUSED
	XOR NA,PCNT+1	;SET
	TRNE NA,1	;CHANGING RELOCATION?
	JRST ORG4
ORG5:	SUB N,PCNT
	ADDM N,PCNT
	ADDB N,OPCNT
ORG3:	MOVEI T,(N)
ORG3A:	MOVE NA,OPCNT+1
	TRNN NA,1
	SKIPA NA,[ABSCNT]
	MOVEI NA,LOCNT
	MOVEM NA,CURBRK
	CAMGE T,BRK	;HIGH SEG?
	JRST .+5	;NO,LOW
	CAMGE T,HICNT	;YES,IS OPCNTHICNT
	JRST .+5	;NO
	MOVEM T,HICNT	;YES, INCREMENT HIGH
	JRST .+3
	CAML T,@CURBRK	;IS OPCNTLOCNT?
	MOVEM T,@CURBRK	;YES, INCREMENT LOW
	TLNE ESPF
	JRST NSPCFN
	JRST SPCFN

ORG4:	XORB NA,PCNT+1	;STORE RELOC, GET BACK ORIGINAL VALUE
	MOVEM NA,DPCNT+1;AND STORE HERE ALSO
	XOR NA,OPCNT+1	;TEST THIS ONE
	XORM NA,OPCNT+1	;AND STORE IT
	TRNE NA,1
	JRST ORG5
			;SORRY, PCNT AND OPCNT HAVE DIFFERENT RELOCATION
	ERROR[ASCIZ/INDETERMINATE PHASE DUE TO RELOC, WILL DEPHASE/]
	MOVE NA,PCNT+1
	MOVEM NA,OPCNT+1
	MOVEM N,PCNT
	MOVEM N,OPCNT
	JRST ORG3

SCR:	MOVE T,[XWD PCNT,PCSAV+4]	;SWAP (EXCHANGE) PCNT WITH PCSAV
	MOVE O,[XWD PCSAV,PCNT]
	MOVE NA,[XWD PCSAV+4,PCSAV]
	BLT T,PCSAV+7
	BLT O,PCNT+3
	BLT NA,PCSAV+3
	MOVE NA,PCNT+1
	MOVEM NA,DPCNT+1
	HRRZ T,OPCNT
	JRST ORG3A

SV:	0
PCSAV:	BLOCK 10
OERR:	ERROR[ASCIZ/UNDEFINED FIELD -- ORG/]
	JRST SPCFN
BEGIN USE
^^%USE:	MOVE N,OPCNT+1
	TLNE N,INCF
	JRST PSLIT
	PUSHJ P,BFFRC	;FORCE OUT BINARY AND FIXUPS
	TLNE B,SPCLF	;SPCL CHR NEXT?
	JRST SPCL	;YES
	PUSHJ P,SCAN	;GET IDENT
	TLNN IFLG	;IDENT?
	JRST ERR	;NO
	MOVE N,CURNT	;GET CURRENT POINTER
	MOVSI O,PCNT
	HRRI O,2(N)	;RESET...
	BLT O,4(N)	;...
	MOVE O,OPCNT+1	;CURRENT...
	HRLM O,3(N)	;ONE...
	SKIPN N,NULN+1	;GET CHAIN POINTER
	JRST NON
LOOP1:	CAMN L,(N)	;THIS ONE?
	JRST FND	;YES
	SKIPE N,1(N)	;NO, GET NEXT, ANY?
	JRST LOOP1
NON:	GFST NA,FSTPNT	;GET FREE STRG
	MOVE N,NULN+1	;GET POINTER
	EXCH N,1(NA)	;INSERT NEW ONE
	MOVEM N,FSTPNT
	MOVEM NA,NULN+1
	MOVEM L,(NA)	;DEPOSIT SIXBIT
	MOVEM NA,CURNT	;THIS ONE NOW CURRENT
	JRST SPCFN
SPCL:	MOVE N,CURNT	;GET CURRENT
	MOVSI O,PCNT	;AND RESET
	HRRI O,2(N)
	BLT O,4(N)
	MOVE O,OPCNT+1
	HRLM O,3(N)
	MOVEI N,NULN
FND:	MOVSI O,2(N)	;GET SOURCE
	HRRI O,PCNT	;GET DEST.
	MOVEM N,CURNT	;THIS ONE NOW CURRENT
	BLT O,PCNT+2	;BLT IN...
	HLR O,PCNT+1	;...
	HRRZM O,OPCNT+1	;;;
	TRNN O,1
	SKIPA O,[ABSCNT]
	MOVEI O,LOCNT
	MOVEM O,CURBRK
	HRRZS PCNT+1	;...
	MOVE O,PCNT+1
	MOVEM O,DPCNT+1
	JRST SPCFN
^NULN:	BLOCK 5
^CURNT:	0
^SNULN:	0
	0
	0
	1(1)
	0
	NULN
ERR:	ERROR[ASCIZ/ILL. FORMAT -- USE/]
	JRST SPCFN	;RETURN
	BEND



^NULN_NULN
^SNULN_SNULN
BEGIN SET
^^%SET:	MOVE N,OPCNT+1
	TLNE N,INCF
	JRST PSLIT
	TLNE B,SPCLF	;SPC CHR NEXT
	JRST SPCL	;YES ITS FOR NULL
	PUSHJ P,SCAN	;GET IDENT
	TLNN IFLG	;IDENT?
	JRST ERR	;NO
	SKIPN N,NULN+1	;GET LIST, ANY?
	JRST NON	;NO
LOOP1:	CAMN L,(N)	;THIS ONE?
	JRST FND	;YES
	SKIPE N,1(N)	
	JRST LOOP1
NON:	GFST N,FSTPNT	;GET FREE STRG
	MOVE NA,NULN+1
	EXCH NA,1(N)	;PUT ON LIST
	MOVEM NA,FSTPNT
	MOVEM N,NULN+1
	MOVEM L,(N)	;DEPOSIT SIXBIT
FND:	PUSH P,N
	TRNE B,COMF	;,?
	PUSHJ P,SCAN	;YES, SKIP
	TDO [XWD OPFLG,NOFXF]
	PUSHJ P,MEVAL	;EVALUATE EXPRESSION
	POP P,T		;GET POINTER
	TLNE UNDF!ESPF	;DEFINED?
	JRST ERR	;NO
	CAMN T,CURNT	;CURRENT ONE?
	JRST ORG2	;YES
	HRRZM N,2(T)	;DEPOSIT VALUE...
	HRRZM N,4(T)	;...
	MOVEM NA,3(T)	;DEPOSIT RELOC
	HRLM NA,3(T)	;...
	JRST SPCFN
SPCL:	MOVEI N,NULN
	JRST FND
ERR:	ERROR[ASCIZ/ILL. FORMAT -- SET/]
	JRST SPCFN
BEND

BEND
BEGIN MAC 	SUBTTL MACROS, FOR, REPEAT, IF'S	;DEFINE

DERR1:	ERROR	[ASCIZ/NOT IDENT AFTER DEFINE/]
	JRST	SPCFN

^%DEF:	SKIPA	FS,BLOCK	;USE CURRENT BLOCK FOR NORMAL DEFINE
^%GDEF:	MOVEI	FS,1		;USE OUTER BLOCK FOR GDEFINE
	HRRZM	FS,GDEFBK#	;SAVE BLOCK NUMBER
	PUSHJ	P,SCAN		;GET NAME OF MACRO
	TLNN	IFLG		;IDENT?
	JRST	DERR1		;NO
DEF0:	MOVE	T,L		;GET SIXBIT
	IDIVI	T,HASH		;HASH
	MOVMS	FS
	MOVEI	T,MACRT-1(FS)	;T=OLD POINTER
DEF1:	SKIPN	O,1(T)		;LOOK FOR PREVIOUS DEFINITION OF THIS MACRO
	JRST	DEF2		;NONE THERE.
	CAMN	L,(O)
	JRST	REDEF
	SKIPN	T,1(O)		;NOW, O = OLD POINTER
	JRST	DEF2		;NONE THERE.
	CAME	L,(T)
	JRST	DEF1		;NOW, T = OLD POINTER AGAIN
REDEFX:	EXCH	T,O		;SHUFFLE AC'S.  O _ CURRENT BLOCK, T _ PREVIOUS
REDEF:	HRRZ	N,2(O)		;GET BLOCK BITS OF OLD DEFINITION
	CAME	N,GDEFBK	;SAME AS THIS BLOCK (REDEFINTION)?
	JRST	REDEF1		;NOT AN ORDINARY REDEFINITION.
	PUSHJ	P,REDEF0
	JRST	DEF3

REDEF0:	PUSH	P,B		;REDEFINITION - FLUSH OLD TEXT & RE-USE SYM BLK
	PUSH	P,C
	MOVE	C,4(O)
	HLRZ	B,(C)
	ADDI	B,(C)
	PUSHJ	P,MACRET
	POP	P,C
	POP	P,B
	POPJ	P,

REDEF1:	JUMPE	N,DEF2		;JUMP IF REDEFINING A PREDFINED MACRO. INSERT NEW.
	MOVE	N,GDEFBK	;GET BLOCK FOR THIS DEFINITION
	CAIE	N,1		;IS THIS A GLOBAL DEFINITION?
	JRST	DEF2		;NO, JUST A NEW, LOCAL DEFINITION.  INSERT NEW.
	HRRZ	N,2(O)
	CAME	N,BLOCK		;SKIP IF OLD DEFINITION IS IN CURRENT BLOCK
	ERROR	[ASCIZ/NON-LOCAL MACRO REDEFINED BY INNER BLOCK GDEFINE/]
	PUSHJ	P,REDEF0	;FLUSH OLD DEFINITION.
	MOVE	N,FSTPNT	;GIVE BACK TO FREE STORAGE AND DELINK
	EXCH	N,1(O)		;GET LINK OUT OF THIS BLOCK
	MOVEM	N,1(T)		;STORE IN PREVIOUS BLOCK (DELINKS)
	MOVEM	O,FSTPNT
	JRST	DEF0		;FLUSH ANY OTHER INTERMEDIATE-LEVEL DEFINITIONS.

DEF2:	GFST	O,FSTPNT	;GET FREE STORAGE.  INSERT DEFINITION.
	MOVEI	T,MACRT-1(FS)	;GET CHAIN ADDRESS
DEF2A:	SKIPE	N,1(T)		;END OF THE CHAIN?
	SKIPN	2(N)		;NO.  SKIP UNLESS PREDEFINED MACRO.
	JRST	DEF2B		;INSERT AFTER (T)
	HRRZ	FS,2(N)
	CAMG	FS,GDEFBK	;SKIP IF THIS BLOCK IS TOO DEEPLY NESTED FOR US.
	JRST	DEF2B		;INSERT AFTER (T)
	MOVEI	T,(N)
	JRST	DEF2A

DEF2B:	MOVE	N,1(T)		;GET LINK OUT
	EXCH	N,1(O)		;STORE LINK OUT INTO NEW BLOCK
	MOVEM	N,FSTPNT	;STEAL BLOCK (O) FROM FSTPNT
	MOVEM	O,1(T)		;STORE NEW LINK OUT (INSERTS O AFTER T)
	MOVEM	L,(O)		;DEPOSIT SIXBIT
	MOVE	N,GDEFBK	;GET BLOCK BITS.
	MOVEM	N,2(O)		;DEPOSIT BLOCK BIT
DEF3:	SKIPE	XCRFSW		;CREF?
	CREF6	6,(O)		;YES
	MOVE	FS,MTBPNT	;GET POINTER TO FREE MACRO AREA
	MOVEM	FS,4(O)		;DEPOSIT POINTER
	MOVEI	T,		;ZERO ARG COUNT
	TDNE	B,[CRFG,,LBCF]	;CR OR { NEXT?
	JRST	NOCAT		;YES, NO CONCAT
	TRNE	B,LFPF		;(NEXT?
	JRST	NOCAT		;YES, NO CONCAT
	TRNN	B,RBCF		;} ?
	JRST	DEF3A		;NO.  IT'S A LEGAL CONCATENATION CHR.
	ERROR	[ASCIZ/ILLEGAL CONCATENATION CHR/]
	JRST	NOCAT
;DEFINE CONTINUED.  STORE CONCATENATION CHR. GET ARGS, MACRO BODY.

DEF3A:	PUSH	P,C		;SAVE CONCAT CHR.
	TLZA	SFL		;SKIP CONCAT CHR. SKIP ONE INSTRUCTION TOO.
NOCAT:	PUSH	P,[200]		;NO CONCAT CHR.
	PUSHJ	P,SCAN		;GET TO THE (
	TLNN	SCFL		;SPC. CHR?
	JRST	.-2		;NO
	TRNN	N,LFPF!LBCF	;( OR { ?
	JRST	.-4		;NO
	TRNE	N,LBCF		;{ ?
	JRST	NOARG		;YES, NO ARGS
	TRNE	B,RTPF		;) NEXT?
	JRST	AEND		;YES
ALOP:	PUSHJ	P,SCAN		;GET ARG
	TLNN	IFLG		;IDENT?
	ERROR	[ASCIZ/ARGUMENT NOT IDENT/]
LEG	MOVEM	L,(FS)		;DEPOSIT ARG
	ADDI	FS,1		;INCREMNT STRG PNTR.
CLOP:	TRNN	B,COMF		;, NEXT?
	JRST	.+3		;NO
	TLZ	SFL		;YES, SKIP THE ,
	AOJA	T,ALOP
	TRNE	B,RTPF		;) NEXT?
	AOJA	T,AEND		;YES
	PUSHJ	P,SCAN		;GET NEXT
	JRST	CLOP

AEND:	PUSHJ	P,SCAN		;GET TO THE {
	TLNN	SCFL		;SPC CHR?
	JRST	.-2		;NO
	TRNN	N,LBCF		;{ ?
	JRST	.-4		;NO
NOARG:	POP	P,NA		;GET CONCAT CHR.
	CAIN	NA,200		;ANY?
	JRST	NOCTA		;NO
	PUSH	P,CTAB(NA)	;SAVE OLD BITS
	MOVSI	N,SPCLF!SPFL	;GET NEW BITS
	MOVEM	N,CTAB(NA)	;DEPOSIT
NOCTA:	PUSH	P,NA		;SAVE CHR
	MOVE	N,FS		;POINT TO PLACE TEXT...
	HRLI	N,700		;SHOULD GO
	MOVE	NA,MTBPNT	;ARG POINTER
	PUSHJ	P,TXTIN		;GET TEXT IN
	MOVEI	L,177
LEG	IDPB	L,N		;DEPOSIT END...
	MOVEI	L,3		;OF MACRO...
LEG	IDPB	L,N		;INDICATION
	MOVEM	T,3(O)		;DEPOSIT ARG COUNT
	MOVEM	O,(FS)		;DEPOSIT REVERSE POINTER
	MOVEI	L,1(N)		;GET END
	SUB	L,FS		;FORM LENGTH
	HRLM	L,(FS)		;DEPOSIT
	JUMPE	T,BNOA		;NO ARGS?
	MOVS	TAC,FS		;PREPARE TO MOVE UP
	HRR	TAC,MTBPNT	;...
	SUBI	N,(T)
	BLT	TAC,(N)
BNOA:	ADDI	N,1
	HRRZM	N,MTBPNT	;ADVANCE POINTER
	POP	P,N		;GET CONCAT CHR.
	CAIE	N,200		;NO CONCAT?
	POP	P,CTAB(N)	;RESTORE BITS
	JRST	SPCFN
;TXTIN:	CALL, TO READ TEXT INTO CORE, WITH PLACE IT IS TO GO
	;IN N,  ARG POINTER IN NA,  ARG COUNT IT T,  CONCAT
		;CHR. ON TOP OF STACK.   USES PN,TAC,L

^TXTIN:	SETZM	BCNT		;INIT { } COUNT

;IN CASE OF ACCIDENTS, WE REMEMBER SOME THINGS HERE
	SKIPN	PN,TLBLK
	HRRO	PN,INLINE
	MOVEM	PN,TXTIL
	MOVE	PN,PGNM
	MOVEM	PN,TXTIPG
NOTNX,<	MOVE	PN,[FILNM,,TXTIFL]
	BLT	PN,TXTIFL+4		>;NOTNX
TNX,<
	MOVE	PN,JFNTBL
	MOVEM	PN,TXTIFL	;SAVE INPUT JFN
>;TNX

	JRST	NLOOP

NLOOP1: LEG	IDPB	C,N
NLOOP:	PUSHJ	P,SCAN1		;GET CHR.
	JUMPGE	B,SPCCHR	;SPC. CHR?
	TLNE	B,NMFLG		;NUM?
	JRST	SNUMS		;YES
	MOVEM	N,NSTO
LEG	IDPB	C,N
	MOVEI	PN,(B)		;GET SIXBIT
ILOOP:	PUSHJ	P,SCAN1		;GET CHR.
	JUMPGE	B,ISPC		;SPC CHR?
LEG	IDPB	C,N		;NO, DEPOSIT
	TLNE	PN,770000	;6 CHRS?
	JRST	ILOOP		;YES
	LSH	PN,6
	ORI	PN,(B)		;INSERT
	JRST	ILOOP

ISPC:	JUMPE	T,SPCCHR	;NO ARGS?
	MOVE	TAC,T		;GET COUNT
	MOVE	L,NA		;GET POINTER
ALOOP:	CAMN	PN,(L)		;IS THIS IDENT WE SCANNED AN ARG?
	JRST	YUP		;YUP
	ADDI	L,1
	SOJG	TAC,ALOOP	;LOOP MATCHING THIS ID TO ANY FORMAL ARG
SPCCHR:	CAMN	C,-1(P)		;CONCAT CHR?
	JRST	NLOOP		;YES
	TRNE	B,LBCF		;{ ?
	AOS	BCNT		;YES, COUNT
	TRNE	B,RBCF		;} ?
	SOSL	BCNT		;YES,COUNT
	JRST	NLOOP1		;RETURN
	SETZM	TXTIPG
	POPJ	P,		;RETURN


YUP:	MOVEI	PN,177		;DEPOSIT ARG POINTER...
	MOVE	N,NSTO		;GET POINTER
LEG	IDPB	PN,N		;...
	MOVEI	PN,1		;...
LEG	IDPB	PN,N		;...
	MOVE	L,T		;FORM ARG NUMBER...
	SUB	L,TAC		;...
LEG	IDPB	L,N		;AND DEPOSIT
	JRST	SPCCHR

SNUMS:	LEG	IDPB C,N	;DEPOSIT
	PUSHJ	P,SCAN1		;GET CHR.
	JUMPL	B,SNUMS		;NOT SPC CHR?
	JRST	SPCCHR		;SPCCHR
NSTO:	0
BCNT:	0
BEGIN ARGIN
;ARGIN:	CALL TO READ IN ARGS.  USES NEXT FREE SPACES
	;	IN CONTIGUOUS AREA. USES N,PN,TAC,NA
	;	# OF ARGS SHOULD BE IN N

^^ARGIN:
	HRRZ NA,MTBPNT	;GET FREE AREA
	PUSH P,NA	;SAVE ON PDL (RECURSIVE)
	ADD NA,N		;ADD # OF ARGS
	HRLI NA,440700	;MAKE INTO POINTER
	PUSHJ P,SCAN1	;GET NEXT CHR.
	TRNN B,LFPF	;(?
	JRST CRMOD	;NO - ARGUMENT LIST IS NOT IN PARENS
LOOP2:	PUSHJ P,SCAN1	;YES,PASS IT
LEG	MOVEM NA,@(P)	;DEPOSIT POINTER TO FIRST ARG
	TRNE B,BSLF	;BACKSLASH? \ ()?
	PUSHJ P,BKHAN	;YES. HANDLE IT. (ALWAYS SKIPS!)
	PUSHJ P,SARGIN	;GET ARG
	TRNN B,RBCF	;}?
	TLNN B,CRFG!RBRF	;DID IT STOP ON CR?
	JRST .+3	;NO
	PUSHJ P,SARCON	;YES, CONTINUE
	JRST .-3
	MOVEI TAC,177	;DEPOSIT...
LEG	IDPB TAC,NA	;END...
	MOVEI TAC,2	;OF ARG...
LEG	IDPB TAC,NA	;INDICATION
	ADDI NA,1	
	HRLI NA,440700	;NEXT AREA
LOOP1:	TRNE B,COMF	;,?
	JRST GNXT1	;YES
	TRNE B,RTPF	;)?
	JRST GTERM1	;YES
	PUSHJ P,SCAN1	;NO, IT MUST BE }
	JRST LOOP1
GNXT1:	SOJLE N,GALL1	;NO MORE ALLOWED?
	AOS (P)		;YES, MORE , ADVANCE POINTER
	JRST LOOP2
CRMOD:			;ARGUMENTS NOT IN PARENS
LEG	MOVEM NA,@(P)	;DEPOSIT POINTER
	TRNE B,BSLF	;BACKSLASH \ ()?
	PUSHJ P,BKHAN	;YES. HANDLE IT. (ALWAYS SKIPS!)
	PUSHJ P,SARGIN	;GET ARG
	TRNN B,RTPF	;)?
	JRST .+3	;NO
	PUSHJ P,SARCON	;YES, CONTINUE
	JRST .-3
	MOVEI TAC,177	;DEPOSIT...
LEG	IDPB TAC,NA	;END...
	MOVEI TAC,2	;OF ARG...
LEG	IDPB TAC,NA	;INDICATION
	ADDI NA,1	
	HRLI NA,440700	
LOOP3:	TRNE B,COMF	;,?
	JRST GNXT2	;YES
	TLNE B,CRFG!RBRF	;CR?
	JRST GTERM2	;YES
	PUSHJ P,SCAN1	;MUST BE }
	JRST LOOP3

GNXT2:	SOJLE N,GALL2	;NO MORE ALLOWED?
	AOS (P)	;YES, MORE
	PUSHJ P,SCAN1
	JRST CRMOD

GTERM1:	SETZB B,C	;PASS THE ) (RETURNING NOTHING)
GTERM2:	SOJLE N,GL	;GOTTEM ALL
	MOVEI TAC,177	;NO, DEPOSIT
LEG	IDPB TAC,NA	;A NULL...
	MOVEI TAC,2	;ARG...
LEG	IDPB TAC,NA	;...
	HRLI NA,440700
LOOP4:	AOS (P)	;INCREMNT POINTER
LEG	MOVEM NA,@(P)	;DEPOSIT
	SOJG N,LOOP4	
	ADDI NA,1
GL:	SUB P,[1,,1]	;FLUSH PNTR FROM PDL
	POPJ P,

;HERE WHEN WE HAVE ALL THE ARGS WE NEED.
GALL1:	PUSHJ P,SCAN1	;GET CHR.   (ARGS ARE IN PARENS. SCAN TO CLOSE PAREN)
	TRNN B,RTPF	;)?
	JRST GALL1	;NO
GALL2:	SUB P,[1,,1]	;FLUSH PNTR.
	JRST SCAN1	;EAT THE ) OR , AND RETURN
;	HANDLE BACKSLASH ARGUMENTS

;WARNING! This code knows everything about it's environment all the way back
;to what the caller of ARGIN pushed on the stack.  Modifiers beware!!

BKHAN:	ANDI	NA,-1		;RIGHT SIDE ONLY
	MOVEM	NA,MTBPNT	;UPDATE IN CASE MEVAL NEEDS IT FOR MACRO HACKING
	MOVEI	TAC,1(P)	;SOURCE=0, DESTINATION = PDL
	BLT	TAC,7(P)	;SAVE AC'S (0-6)
	ADD	P,[7,,7]	;ADJUST STACK
	TRO	NOFXF		;NO FIXUPS FROM MEVAL
	PUSHJ	P,MEVAL		;GET VALUE
	TLNN	UNDF!ESPF
	TRNE	NA,17
	TDZA	N,N		;UNDEFINED. SET VALUE TO ZERO AND SKIP TO LOSE MSG
	JRST	.+2		;VALUE IS OK. AVOID LOSE MESSAGE
	ERROR	[ASCIZ /UNDEFINED \ ARGUMENT/]
	EXCH	N,B		;SAVE NUMBER IN B, CHARACTER FLAGS IN N
	EXCH	C,NA-6(P)	;EXCHANGE CHAR WITH OLD MTBPNT POINTER.
	HRRZS	MTBPNT		;MAKE SURE MTBPNT IS RIGHT SIDE ONLY
BKHAN0:	CAME	C,MTBPNT	;HAVE WE BEEN SCREWED BY MEVAL?
	JRST	BKHAN1		;YES.  NOW LETS GO FIX IT.
	HRLI	C,440700	;MAKE ARG PNTR UP TO DATE
	MOVEM	C,@-7-1(P)	;MAKE SURE ARG PNTR IS UP TO DATE
	PUSHJ	P,BKSLSH	;CON TO ASCII
	MOVE	B,N		;CHARACTER FLAGS GO BACK TO B
	EXCH	C,NA-6(P)	;RESTORE CHAR, PUT BACK NEW PNTR
	SUB	P,[7,,7]
	MOVSI	TAC,2(P)
	HRRI	TAC,1
	BLT	TAC,6		;RESTORE AC'S
	MOVE	TAC,1(P)
	TDZ	REFLAG
	AND	TAC,REFLAG
	OR	TAC		;RESTORE FLAGS
	TLZ	SFL		;SKIP THE , OR ) OR WHATEVER
	AOS	(P)		;ALWAYS SKIP RETURN
	POPJ	P,

;THE FOLLOWING KLUDGE FIXES A HORRIBLE BUG IN STORAGE MANAGEMENT
;C CONTAINS FIRST LOC TO NOT MOVE.
BKHSVC:	0
BKHSVN:	0
BKHSVB:	0

;I ADDED THIS CODE TO NOTICE IF FREE STORAGE GOT USED BY CALL TO MEVAL
;IF SO, WE HAVE TO MOVE THE ARGUMENTS ACCUMULATED BY ARGIN - REG

BKHAN1:	MOVEM	N,BKHSVN
	MOVEM	C,BKHSVC	;SAVE TOP ADDRESS FOR MACRET
	HRRZS	NA,-12(P)	;MAKE CERTAIN THAT THIS IS RIGHT SIDE ONLY!
	MOVEM	NA,BKHSVB	;SAVE BOTTOM FOR MACRET
	HRLZ	NA,-12(P)	;SOURCE = CALLER'S OLD MTBPNT
	HRR	NA,MTBPNT	;DESTINATION = CURRENT MTBPNT
	ADD	C,MTBPNT
	SUB	C,-12(P)	;THIS IS THE ENDING ADDRESS OF BLT
LEG	SETZM	-1(C)
	BLT	NA,-1(C)	;MOVE ARGUMENT LIST TO A NEW HOME
				;C= FIRST FREE LOCATION.
	HRRZ	NA,MTBPNT
	SUB	NA,-12(P)	;CALC OFFSET
	ADDM	NA,-12(P)	;FIX CALLER'S MTBPNT
	ADDM	NA,-10(P)	;FIX ARGUMENT POINTER
	HRRZ	N,-10(P)	;GET ARGUMENT POINTER
	ADDM	NA,(N)		;FIX ONE ARGUMENT
	CAMLE	N,MTBPNT	;DONE FIRST ARG YET?
	SOJA	N,.-2		;NO. LOOP
	HRRZM	C,MTBPNT	;SET NEW MTBPNT
	EXCH	C,BKHSVC	;GET TOP ADDRESS OF BLOCK
	PUSH	P,B
	MOVE	B,BKHSVB
	EXCH	C,B		;LOW ADDRESS IN C,  HIGH ADDRESS IN B
	PUSHJ	P,MACRET
	POP	P,B
	MOVE	C,BKHSVC	;GET NEW OLD MTBPNT
	MOVE	N,BKHSVN	;RESTORE CHARACTER FLAGS TO N
	JRST	BKHAN0		;RETURN. C SETUP. CHECK AGAIN BECAUSE
				;SOMETIMES MACRET SCREWS UP MTBPNT!
BEND ARGIN
;SARGIN:	CALL TO READ IN A SINGLE ARGUMENT. POINTER FOR
		;DEPOSIT SHOULD BE IN NA.
;	STARTS WITH CURRENT CHR. & TERMINATES ON , OR CR OR ) OR > OR ].
;	USES TAC .  IF FIRST IS { , TERMS ON }

^SARGIN:PUSH	P,TAC
	SKIPN	TAC,TLBLK
	HRRO	TAC,INLINE
	MOVEM	TAC,SARLN		;SAVE FOR FATAL EOF TYPEOUT
	MOVEM	TAC,SARLIN
	MOVE	TAC,PGNM
	MOVEM	TAC,SARGPG
	MOVEM	TAC,SARPG
NOTNX,<	MOVE	TAC,[FILNM,,SARFIL]
	BLT	TAC,SARFIL+4		>;NOTNX
TNX,<
	MOVE	TAC,JFNTBL
	MOVEM	TAC,SARFIL		;SAVE INPUT JFN
>;TNX
	POP	P,TAC
	SETZM	TABMFG#			;SET AFTER WE'VE SEEN CRUD
	TRNE	B,LBCF				;{ ?
	JRST	BROK				;YES
	SKIPE	TABMSW				;NEW TAB IN ARGUMENT HACK?
	JRST	RLOOP1				;YES.  WE HAVE TO WORK HARDER
SLOOP:	TRZ	B,RBCF
	TDNE	B,[XWD RBRF!CRFG,RTPF!COMF]	;, OR CR OR ) OR > OR ]?
	JRST	BFND				;YES
SARCO:	LEG	IDPB C,NA			;NO, DEPOSIT
	PUSHJ	P,SCAN1				;GET NEXT
	JRST	SLOOP

RLOOP3:	LEG	IDPB C,NA			;NO, DEPOSIT
	TLNN	B,SPFL				;SPACE OR TAB?
	MOVEM	NA,TABMFG			;NO.  REMEMBER LAST SIGNIFICANT CHR
RLOOP4:	PUSHJ	P,SCAN1				;GET NEXT
RLOOP1:	SKIPN	TABMFG				;SEEN ANYTHING YET?
	TLNN	B,SPFL				;NO. BLANK OR TAB?
	TRZA	B,RBCF				;SEEN SOMETHING, OR NOT BLANK
	JRST	RLOOP4				;IGNORE LEADING BLANKS
	TDNN	B,[XWD RBRF!CRFG,RTPF!COMF]	;, OR CR OR ) OR > OR ]?
	JRST	RLOOP3				;NO. CONTINUE
	SKIPE	TABMFG
	EXCH	NA,TABMFG			;LOAD NA FROM TABMFG
	SETZM	SARGPG
	POPJ	P,


BROK:	SETZM	SARTAC		;HERE WHEN FIRST CHARACTER OF ARG IS {
	JRST	BLOOP

BLOOP1:	LEG	IDPB	C,NA	;DEPOSIT CHR.
BLOOP:	PUSHJ	P,SCAN1		;GET CHR.
	TRNE	B,LBCF		;{ ?
	AOS	SARTAC		;YES
	TRNE	B,RBCF		;} ?
	SOSL	SARTAC		;YES
	JRST	BLOOP1		;NOT AT THE END YET
	TLZ	B,RBRF		;CLEAR END OF LINE
BFND:	SETZM	SARGPG
	POPJ	P,


SARTAC:	0
SARLIN:	0
SARPG:	0

^SARCON:PUSH	P,SARLIN
	POP	P,SARLN
	PUSH	P,SARPG
	POP	P,SARGPG
	SKIPN	TABMSW		;SPECIAL TAB HANDLING?
	JRST	SARCO		;NO.
	SKIPE	TABMFG		;WAS THERE AN OLD NA STORE HERE AT EXIT?
	EXCH	NA,TABMFG	;YES. WELL, PUT IT BACK!
	JRST	RLOOP3		;YES.  PICKUP IN THE RIGHT LOOP
;ROUTINE TO RETURN MACRO TABLE SPACE
;CALLED WITH	B: (HIGHEST ADDRESS OF THIS BLOCK)+1
;		C: LOWEST ADDRESS OF THIS BLOCK

^MACRET:CAME B,MTBPNT		;IS THIS JUST BELOW MTBPNT?
	JRST MACR2		;NO SUCH LUCK.
	MOVEM C,MTBPNT		;YES.  JUST BACK UP MTBPNT TO INCLUDE THIS
	CAME C,LGARB		;DOES THIS ABUT GARBAGE AREA?
	POPJ P,			;NOPE.  ALL DONE NOW.
	MOVE B,GARBAG		;ABUTS GARBAGE AREA: BACK UP MTBPNT SOME MORE
	MOVE C,2(B)		;GET LOW ADDRESS OF THIS BLOCK
	MOVEM C,MTBPNT		;IS NEW MTBPNT

	MOVE C,FSTPNT		;RETURN GARBAGE PNTR (REMOVE FROM GARBAGE,
	EXCH C,1(B)		;ADD TO FSTPNT
	MOVEM C,GARBAG
	MOVEM B,FSTPNT

	JUMPE C,.+2		;SO, IS THERE ANY GARBAGE LEFT?
	MOVE C,3(C)		;YES. GET HIGH ADDRESS IN GARBAGE
	MOVEM C,LGARB		;SET UP NEW "LAST GARBAGE" PNTR
	POPJ P,

;NOT AT END - INSERT IN ORDERED LIST, COMBINING WITH OLD ENTRIES IF POSSIBLE
MACR2:	PUSH M,T
	PUSH M,N
MACR2A:	SKIPA N,[-1,,GARBAG-1]
MACR3:	MOVEI N,(T)
	SKIPN T,1(N)		;ANYTHING LEFT ON THE LIST?
	JRST MACRE		;NO. WE RAN OFF THE END
	CAMG B,3(T)		;ARE WE ABOVE THE NEXT GUY?
	JRST MACR3		;NO. GO DOWN.
	CAMN C,3(T)		;HERE WE HAVE PROPER POSITION
	JRST MACRL		;LOW END OF US MATCHES HIGH END OF OLD
MACRE:	JUMPL N,.+3		;JUMP IF THIS IS HIGHEST GARBAGE
	CAMN B,2(N)		;HIGH END MATCHES OLD?
	JRST MACRH		;YES. SEE US COMBINE TWO BLOCKS
	EXCH N,FSTPNT		;NEITHER MATCHES - CREATE NEW ENTRY
	JUMPE N,MACRLZ		;JUMP IF NO FS
	EXCH T,1(N)		;GOBBLE THE FS BLOCK
	EXCH T,FSTPNT
	MOVEM N,1(T)		;
	SETZM (N)		;ZERO SIZE FOR UPCOMING "COMBINE"
	JUMPGE T,.+2
	MOVEM B,LGARB		;UPDATE END ADR IF HIGHEST POS
	MOVEM B,3(N)
MACRH:	MOVEM C,2(N)
	SUBI B,(C)
	ADDM B,(N)
MACRX:	POP M,N
	POP M,T
	POPJ P,
MACRL:	JUMPL N,[MOVEM B,LGARBJRST .+3]	;UPDATE LGARB, AVOID TEST IF AT END
	CAMN B,2(N)
	JRST MACRB	;BOTH ENDS MATCH - WE HAVE CLOSED A HOLE!
	MOVEM B,3(T)
MACRL2:	SUBI B,(C)
	ADDM B,(T)
	JRST MACRX

MACRB:	MOVE C,2(T)	;COMBINE ALL 3 PIECES INTO ONE, RETURN ONE OLD PNTR BLK
	MOVEM C,2(N)
	EXCH N,FSTPNT
	EXCH N,1(T)
	EXCH T,FSTPNT
	MOVEM N,1(T)
	JRST MACRL2

;HERE IF NO FS FOR PNTR
	N,		;ARG FOR NOFSL
MACRLZ:	JSR NOFSL	;THIS MAY CHANGE LIST, SO ...
	MOVEM N,FSTPNT	;PUT BACK FS
	JRST MACR2A	;AND START SCAN OVER

^GARBAG:0
^LGARB:	0

^LGET:	0
	PUSHJ P,SCAN1	;GET CHR.
	TRNN B,LBCF	;{ ?
	JRST .-2	;NO
	JRST @LGET	;YES
;REPEAT - %REP, REP

	DEFINE MACEX (AC)
<	LDB	AC,[POINT 6,LSTPNT,11]
	HRL	AC,INMCSW
	PUSH	M,AC
	PUSH	M,INPNTP
	PUSH	M,INPNT
	MOVE	AC,INPNTP
	CAIN	AC,INPNT
	HRRZM	M,INPNTP
	MOVEI	AC,
	SKIPN	NOEXP
	JRST	.+4
	IBP	LSTPNT
	DPB	AC,[POINT 6,LSTPNT,11]
	SETZM	XPNDSW
	SETZM	INMCSW
>

^%REP:	TRO NOFXF	;GENERATE NO FIXUPS
	PUSHJ P,MEVAL	;EVALUATE EXPR.
	TRNN NA,17
	TLNE UNDF!ESPF	;DEFINED & NOT SPC. CHR?
	JRST REPER	;NO
	JUMPL N,REPER	;NEG. COUNT?
	SETOM REPSW	;SET REPEAT SWITCH (PUT CR LF AT END)
	PUSHJ P,REP	;GO DO
	TRZ NOFXF
	JRST ASSMBL	;PROCEED

	PUSHJ P,SCAN1	;GET NEXT
^REP:	TRNN B,LBCF	;{ ?
	JRST REP-1	;NO
	TLZ SFL
LBFN:	JUMPE N,REP0	;REPEAT 0?
	CAIN N,1	;REPEAT 1?
	JRST REP1	;YES
	MOVE NA,MTBPNT	;MAKE READ-IN POINTER
	HRLI NA,440700	;...
	PUSHJ P,SARGIN	;READ IN
	SKIPN REPSW	;REPEAT?
	JRST NOREP	;NO
	MOVEI TAC,15	;YES, INSERT CR LF
LEG	IDPB TAC,NA
	MOVEI TAC,12
LEG	IDPB TAC,NA
NOREP:	MOVEI TAC,177	;DEPOSIT...
LEG	IDPB TAC,NA	;END...
	MOVEI TAC,4	;OF REPEAT...
LEG	IDPB TAC,NA	;...
	PUSH M,AHED	;PUSH LINE NUMBET TEST
	MOVSI TAC,(<SKIPA>)
	MOVEM TAC,AHED	;INHIBIT...
	MOVEM TAC,LOOP6	;LINE NUMBER SKIPPING
	MACEX (TAC)
	HRRZI NA,1(NA)	;INCREMENT & ZERO LEFT
	PUSH M,NA	;SAVE NEW MTBPNT
	PUSH M,N	;SAVE COUNT
	PUSH M,MTBPNT	;SAVE OLD MTBPNT (POINTS TO STRT)
	MOVEM NA,MTBPNT	;RESET MTBPNT
	MOVE NA,(M)	;GET POINTER
	HRLI NA,440700
	MOVEM NA,INPNT	;POINT TO STRT

	DEFINE MACUND (ZORCHL)
<	SKIPN NOEXP
	SKIPN UNDLNS
	ZORCHL
	HRRZ TAC,LSTPNT
	CAIL TAC,TLBLK
	SUBI TAC,TLBLK-MBLK
	HRRM TAC,LSTPNT
	TRO MACUNF>

	MACUND (<POPJ P,>)
	POPJ P,
REP0:	SKIPN	TAC,TLBLK		;REPEAT 0
	HRRO	TAC,INLINE
	MOVEM	TAC,REPPG
	MOVE	TAC,PGNM
	MOVEM	TAC,REP0PG
NOTNX,<	MOVE	TAC,[FILNM,,REPFIL]
	BLT	TAC,REPFIL+4		>;NOTNX
TNX,<	MOVE	TAC,JFNTBL
	MOVEM	TAC,REPFIL		;SAVE INPUT JFN
>;TNX
	PUSHJ	P,SLURP			;EAT ALL THE TEXT
	SETZM	REP0PG
	POPJ	P,

REP1:	SKIPN	TAC,RTFLST		;GET POINTER
	SETZM	BROKCT			;ZERO COUNT IF AT OUTSIDE LEVEL
	GFST	NA,FSTPNT
	HRRZM	NA,RTFLST		;GET FREE STRG.
	EXCH	TAC,1(NA)
	MOVEM	TAC,FSTPNT
	MOVE	TAC,BROKCT		;GET COUNT
	MOVEM	TAC,@RTFLST		;DEPOSIT
	POPJ	P,

REPER:	ERROR	[ASCIZ/REPEAT -- ILLEGAL EXPRESSION FOR COUNT/]
	JRST	SPCFN

;BKSLSH:	CALL, WITH BYTE POINTER IN C & NUM IN B.
;	PUTS ASCII FOR NUM (IN CURRENT RADIX) AT PLACE POINTED TO BY C.
^BKSLSH:JUMPE B,BKZER	;HANDLE ZERO SPECIALLY
	MOVEM C,BKPNT	;DEPOSIT BYTE POINTER
	PUSH P,N	;SAVE N
	MOVEI N,1	;
	XCT SRAD	;GET RADIX
	MOVEM N,BKRAD	;SAVE
	POP P,N		;RESTORE N
	JUMPL B,BKNEG	;NEG?
NLOPN:	PUSHJ P,BKCON	;DO IT
	MOVE C,BKPNT	;RESTORE POINTER
	POPJ P,		;LEAVE
BKNEG:	MOVEI C,"-"	;GET - SIGN
LEG	IDPB C,BKPNT
	MOVMS B
	JRST NLOPN
BKRAD:	0
BKPNT:	0
BKCON:	IDIV B,BKRAD	;DIVIDE BY RADIX
	JUMPE B,BZER	;ZERO?
	HRLM C,(P)	;NO, SAVE REMAINDER
	PUSHJ P,BKCON	;CONVERT REST OF NUM
	HLRZ C,(P)	;GET REMAINDER BACK
BZER:	ORI C,60	;CON TO ASCII
LEG	IDPB C,BKPNT	;PUT OUT
	POPJ P,		;LEAVE
BKZER:	MOVEI B,"0"	;HANDLE ZERO...
LEG	IDPB B,C	;AS A SPECIAL...
	POPJ P,		;CASE
;	FOR STATEMENT

FER1A:	ERROR	[ASCIZ/NO IDENT AFTER FOR/]
	JRST	SPCFN

FERR2:	ERROR	[ASCIZ/NO IDENT FOR SECOND ARG -- FOR/]
	JRST	SPCFN

FERR3:	ERROR	[ASCIZ/NUMBER AFTER ARGS -- FOR/]
	JRST	SPCFN

FERR5:	ERROR	[ASCIZ /ILLEGAL CONCATENATION CHR -- FOR/]
	JRST	SPCFN


^%FOR:	MOVE	O,MTBPNT	;FREE STG POINTER
	PUSHJ	P,SCAN		;GET FIRST ARG
	MOVEI	FS,200		;ASSUME NO CONCAT CHR.
	TLNE	IFLG		;IDENT?
	JRST	F1RT		;YES. THERE IS NO CONCAT. CHR.
	TLNE	SCFL		;LOOKING FOR CONCAT. CHR.  SPC CHR?
	TRNN	N,ATF		;YES. IS IT @?
	JRST	FER1A		;NO TO EITHER OF THE ABOVE.  LOSE
	MOVE	FS,C		;YES, GET CONCAT CHR.
	TRNE	B,RBCF		;IS IT A > OR A }
	JRST	FERR5		;YES.  ILLEGAL
	TLZ	SFL		;SKIP CHR.
	PUSHJ	P,SCAN		;GET NEXT
	TLNN	IFLG		;IDENT?
	JRST	FER1A		;NO.  LOSE
F1RT:				;FS=CONCATENATION CHR, L=FIRST ARGUMENT
LEG	MOVEM	L,(O)		;SAVE
LEG	SETZM	1(O)		;MAKE SURE THIS CELL EXISTS, (WE MAY NOT USE IT)
	MOVEI	T,1		;ARG COUNT
	TRNN	B,COMF		;COMMA NEXT?
	JRST	NOSEC		;NO. THERE'S NO SECOND ARGUMENT
	TLZ	SFL		;SKIP THE COMMA
	PUSHJ	P,SCAN		;GET NEXT
	TLNN	IFLG		;IDENT?
	JRST	FERR2		;NO
	MOVEM	L,1(O)		;SAVE.  1(O) IS NOT AN MPV BECAUSE WE CHECKED ABOVE.
	MOVEI	T,2		;ARG COUNT
NOSEC:	PUSHJ	P,SCAN		;GET NEXT
	TLNE	IFLG		;IDENT?
	JRST	ICHK		;YES - CHECK FOR "IN" OR "E"
	TLNN	SCFL		;SPC. CHR?
	JRST	FERR3		;NO.  LOSE
	TRNE	N,LACF		;_?
	JRST	LFOR		;YES - ARITHMETIC FOR
	TRNE	N,EPSF		;EPSILON?
	JRST	EFOR		;YES 
	TRNE	N,INF		;?
	JRST	INFOR		;YES
FERR6:	ERROR	[ASCIZ/UNREC IDENT OR UNREC CHR. AFTER ARGS -- FOR/]
	JRST	SPCFN

ICHK:	CAIN	L,'IN'		;IN?
	JRST	INFOR		;YES
	CAIE	L,'E'		;E?
	JRST	FERR6		;NO.  LOSE
	JRST	EFOR		;YES
;	SETUP ARITHMETIC FOR

OSAV:	BLOCK 2
CONSAV:	0
FSVV:	0
TSVV:	0

FERR4B:	POP	P,N
FERR4A:	POP	P,N
FERR4:	ERROR	[ASCIZ/UNDEFINED ARG -- FOR/]
	JRST	SPCFN

LFOR:	MOVEM	FSVV		;SAVE FLAGS
	TRO	NOFXF		;NO FIXUPS
	MOVEM	T,TSVV		;SAVE ARG COUNT
	MOVEM	FS,CONSAV	;SAVE CONCAT CHR.
	MOVE	T,(O)		;SAVE...
	MOVEM	T,OSAV		;ARGS
	MOVE	T,1(O)	
	MOVEM	T,OSAV+1
	PUSHJ	P,MEVAL		;GET VALUE
	TRNN	NA,17
	TLNE	UNDF!ESPF	;DEFINED?
	JRST	FERR4		;NO
	PUSH	P,N		;SAVE
	TLZ	SFL	
	PUSHJ 	P,MEVAL		;GET VALUE
	TRNN	NA,17
	TLNE	UNDF!ESPF	;DEFINE?
	JRST	FERR4A		;NO
	PUSH	P,N		;SAVE
	MOVEI	N,1		;ASSUME NO THIRD ARGUMENT.  DEFAULT VALUE IS 1
	TRNN	B,COMF		;, NEXT?
	JRST	NOTHRD		;NO.  NO THIRD ARGUMENT
	TLZ	SFL
	PUSHJ	P,MEVAL		;GET VALUE
	TRNN	NA,17
	TLNE	UNDF!ESPF	;DEFINED?
	JRST	FERR4B		;NO
NOTHRD:	MOVE	T,TSVV		;GET ARG COUNT
	MOVE	O,FSVV		;GET OLD FLAGS
	TDZ	REFLAG
	AND	O,REFLAG
	OR	T		;RESTORE FLAGS
	MOVE	O,MTBPNT	;GET FREE STG POINTER
	MOVE	NA,OSAV		;REDEPOSIT ARGS
LEG	MOVEM	NA,(O)		;THIS IS DONE IN CASE MEVAL CHANGED MTBPNT
	MOVE	NA,OSAV+1
LEG	MOVEM	NA,1(O)
	MOVE	NA,(P)		;GET TERMINATION VALUE
	JUMPL	N,LFOR1		;JUMP IF INCREMENT IS NEGATIVE
	CAML	NA,-1(P)	;ZERO TIMES?
	JRST	LFOR2		;NO
	JRST	NOTIM		;YES

LFOR1:	CAMLE	NA,-1(P)	;ZERO TIMES?
	JRST	NOTIM		;YES
LFOR2:	PUSH	P,N		;SAVE N
	MOVEI	N,2(O)		;MAKE POINTER
	HRLI	N,440700	;...
	MOVE	FS,CONSAV
	CAIN	FS,200		;IS THERE A CONCAT CHR?
	JRST	FLOP1		;NO
	PUSH	P,CTAB(FS)	;SAVE BITS
	MOVSI	NA,SPFL!SPCLF	;GET NEW BITS
	MOVEM	NA,CTAB(FS)
FLOP1:	PUSH	P,FS		;SAVE CONCAT CHR.
	MOVE	NA,O		;ARG POINTER
	JSR	LGET		;GET TO THE {
	PUSHJ	P,TXTIN		;GET TEXT OF FOR-BODY.
	PUSH	M,AHED		;SAVE LINE NUM SKIP
	MOVSI	FS,(<SKIPA>)
	MOVEM	FS,AHED
	MOVEM	FS,LOOP6	;INHIBIT LINE NUM SKIP
	MACEX	(FS)
	EDEPO	(L,N,5)		;DEPOSIT END OF FOR
	HRRZI	N,6(N)		;INCREMENT
	PUSH	M,N		;SAVE
	POP	P,FS		;GET CONCAT CHR
	CAIE	FS,200		;ANY?
	POP	P,CTAB(FS)	;YES, RESTORE BITS
	PUSH	M,(P)		;SAVE INCREMENT
	PUSH	M,-1(P)		;SAVE TERM NUM
	PUSH	M,-2(P)		;SAVE STARTING #
	PUSH	M,O		;SAVE STARTING ADDRS -2
	MOVEI	FS,-5(N)	;GET ARG POINTER
	PUSH	M,FS		;SAVE
	SUB	P,[3(3)]
	MOVEM	N,MTBPNT	;RESET MTBPNT
	MOVEI	C,-3(N)	
	HRLI	C,440700
LEG	MOVEM	C,-5(N)		;DEPOSIT ARG ...
LEG	MOVEM	C,-4(N)		;POINTERS
	MOVE	B,-2(M)		;GET NUMBER
	PUSHJ	P,BKSLSH	;CONVERT TO ASCII
	EDEPO	(TAC,C,2)	;DEPOSIT END OF ARG
	ADD	O,[XWD 440700,2]
	MOVEM	O,INPNT		;DEPOSIT
	MACUND (JRST ASSMBL)
	JRST	ASSMBL		;GO, MAN

;ASSEMBLE THE FOR-BODY ZERO TIMES.
NOTIM:	SUB	P,[2(2)]	;CLEAR STACK
	MOVEI	N,0		;REPEAT 0
	PUSHJ	P,REP
	JRST	ASSMBL
;	SETUP "IN" FOR
INFOR:	PUSHJ	P,SCAN		;GET TO THE (
	TLNN	SCFL		;SPCL CHR?
	JRST	.-2		;NO
	TRNN	N,LFPF		;(?
	JRST	.-4		;NO
	PUSHJ	P,SCAN1		;GET NEXT CHR.
	MOVEI	NA,5(O)		;GET POINTER FOR ARGS
	HRLI	NA,440700	;...
LEG	MOVEM	NA,3(O)		;DEPOSIT SECOND ARG POINTER
INLOP2:	TRNE	B,LBCF		;{?
LEG	IDPB	C,NA		;YES, DEPOSIT IT
	PUSHJ	P,SARGIN	;GET FIRST ARG.
INLOP1:	TRNE	B,RTPF		;TERM BY )?
	JRST	RTERM		;YES
	TRNE	B,COMF		;TERM BY COMMA?
	JRST	MYCON		;YES
	PUSHJ	P,SARCON	;NO, CONTINUE
	JRST	INLOP1

MYCON:
LEG	IDPB	C,NA
	PUSHJ	P,SCAN1
	TRNE	B,LBCF		;{?
LEG	IDPB	C,NA		;YES, DEPOSIT
	PUSHJ	P,SARGIN
	JRST	INLOP1

RTERM:	EDEPO	(N,NA,2)	;DEPOSIT END OF ARG
	CAIN	FS,200		;ANY CONCAT CHR?
	JRST	IFLOP		;NO
	PUSH	P,CTAB(FS)	;SAVE BITS
	MOVSI	N,SPFL!SPCLF	;MAKE NEW BITS
	MOVEM	N,CTAB(FS)
IFLOP:	MOVEI	N,4(O)		;GET...
	HRLI	N,440700	;FIRST ARG...
	MOVEM	N,2(O)		;POINTER
	MOVEI	N,1(NA)		;MAKE TEXT...
	HRLI	N,440700	;POINTER
	PUSH	P,FS		;SAVE CONCAT CHR.
	MOVE	FS,N		;& SAVE
	JSR	LGET		;GET TO THE {
	MOVE	NA,O		;SET ARG POINTER
	PUSHJ	P,TXTIN		;GET TEXT IN
	PUSH	M,AHED		;SAVE LINE NUM TEST
	MACEX	(L)
	MOVSI	L,(<SKIPA>)
	MOVEM	L,AHED		;INIHIBIT LINE NUM...
	MOVEM	L,LOOP6		;SKIPPING
	EDEPO	(L,N,6)		;DEPOSIT END OF FOR-IN
	HRRZI	N,1(N)		;FORM NEW MTBPNT
	PUSH	M,N		;SAVE
	PUSH	M,MTBPNT	;SAVE OLD
	MOVEM	N,MTBPNT
	PUSH	M,FS		;SAVE STRT OF TEXT
	MOVEI	N,2(O)		;GET ARG POINTER
	PUSH	M,N		;SAVE
	POP	P,FS		;GET CONCAT
	CAIE	FS,200		;ANY?
	POP	P,CTAB(FS)	;YES, RESTORE
	PUSHJ	P,IFORSH	;SET UP ARGS
	MACUND	JRST ASSMBL
	JRST	ASSMBL
^IFORSH:MOVE	B,(M)		;GET ARG POINTER
	MOVE	C,1(B)		;GET SECOND ARG POINTER
	PUSH	P,N		;SAVE N
	MOVE	B,(B)		;GET FIRST ARG POINTER
	ILDB	TAC,C		;GET CHR.
	SKIPGE	N,CTAB(TAC)	;GET BITS
	JRST	ILOPI2	
	TLNE	N,SCRF		;CHECK FOR SPECIAL ({ AND < AND > AND })
	XCT	IFORT(N)
	TRNE	N,LBCF		;{?
	JRST	LBRK		;YES
ILOPI1:	TRNE	N,COMF		;,?
	JRST	COMTOM		;YES
	TLNE	N,DLETF		;DELETE?
	JRST	DELTOM		;YES
ILOPI2:	IDPB	TAC,B		;DEPOSIT
	ILDB	TAC,C		;GET NEXT
	SKIPL	N,CTAB(TAC)	;GET BITS
	JRST	ILOPI1
	JRST	ILOPI2

IFORT:	FOR I_0,7 <JFCL
>
	HRRI	N,LBCF!TP2F	;< OR {
	HRRI	N,RBCF!TP2F	;> OR }

DELTOM:	MOVE	C,(M)		;GET ARG POINTER
	MOVEM	B,1(C)		;DEPOSIT SECOND ARG POINTER
	EDEPO	(TAC,B,2)
	JRST	FINIT

COMTOM:	EDEPO	(N,B,2)
	MOVE	N,(M)		;GET ARG POINTER
	MOVEM	C,1(N)		;DEPOSIT SECOND ARG POINTER
FINIT:	POP	P,N		;RESTORE
	MOVE	B,-1(M)		;GET START
	MOVEM	B,INPNT		;DEPOSIT
	JRST	LSTCHK

LBRK:	SETZM	IFOCNT		;ZERO {} COUNT
	SKIPA
LILO1:	IDPB	TAC,B
	ILDB	TAC,C		;GET CHR.
	SKIPGE	N,CTAB(TAC)	;GET BITS
	JRST	LILO1		;NOT SPC CHR.
	TLNE	N,SCRF
	XCT	IFORT(N)
	TRNE	N,LBCF		;{?
	AOS	IFOCNT		;YES
	TRNE	N,RBCF		;}?
	SOSL	IFOCNT		;YES, DONE?
	JRST	LILO1		;NO
LILO2:	ILDB	TAC,C		;GET NEXT
	SKIPGE	N,CTAB(TAC)	;GET BITS
	JRST	LILO2	
	TRNE	N,COMF		;,?
	JRST	COMTOM		;YES
	TLNE	N,DLETF		;DELETE?
	JRST	DELTOM		;YES
	JRST	LILO2		;NO
IFOCNT:	0
EFOR:	JSR	LGET		;GET TO THE {
	MOVEI	NA,5(O)		;SET UP POINTER...
	HRLI	NA,440700	;TO READ IN ARG...
LEG	MOVEM	NA,3(O)		;DEPOSIT
	PUSHJ	P,SARGIN	;GET ARG.
	EDEPO	(TAC,NA,2)	;DEPOSIT END OF ARG
	MOVEI	TAC,4(O)	;FORM FIRST ARG...
	HRLI	TAC,440700	;POINTER
	MOVEM	TAC,2(O)	;DEPOSIT
	JSR	LGET		;GET TO THE {
	MOVEI	N,1(NA)		;FORM TEXT POINTER
	HRLI	N,440700	;...
	PUSH	P,N		;SAVE
	CAIN	FS,200		;ANY CONCAT CHR?
	JRST	EFLOP		;NO
	PUSH	P,CTAB(FS)	;SAVE BITS
	MOVSI	NA,SPFL!SPCLF	;MAKE...
	MOVEM	NA,CTAB(FS)	;NEW BITS
EFLOP:	PUSH	P,FS		;PUSH CONCAT CHR.
	MOVE	NA,O		;ARG POINTER
	PUSHJ	P,TXTIN		;READ IN BODY OF TEXT
	EDEPO	(L,N,7)		;DEPOSIT END OF FOR
	PUSH	M,AHED		;SAVE LINE NUM SKIPPING
	MACEX	(L)
	MOVSI	L,(<SKIPA>)
	MOVEM	L,AHED
	MOVEM	L,LOOP6
	POP	P,L		;GET CONCAT
	CAIE	L,200		;ANY?
	POP	P,CTAB(L)	;YES, RESTORE BITS
	MOVEI	N,1(N)		;FORM NEW MTBPNT
	PUSH	M,N		;SAVE
	MOVEM	N,MTBPNT	;DEPOSIT
	MOVE	N,2(O)		;GET FIRST ARG POINTER
	IBP	N
	EDEPO	(TAC,N,2)	;DEPOSIT END OF ARG
	POP	P,L		;GET START OF TEXT
	PUSH	M,L		;SAVE
	MOVEI	L,2(O)		;GET ARG POINTER
	PUSH	M,L		;SAVE
	PUSHJ	P,EFORSH	;SET UP FIRST
	MACUND	(JRST ASSMBL)
	JRST	ASSMBL
BEND MAC		;LEGTAB

LEGTAB:	FOR @! X_0,LEGNUM-1{,%$L!X
}
LEGCNT__LEGNUM			;DEFINE LEGAL LOCATIONS FOR MPV
SUBTTL	TENEX/IMSSS SPECIAL CODE

TNX,<

UOUTST:	PUSH	P,1
	HRRO	1,40
	PSOUT
	POP	P,1
	POPJ	P,

UOUTCH:	PUSH	P,1
	HRRZ	1,@40
	PBOUT
	POP	P,1
	POPJ	P,

NOT20,<IFE PSTISW,<

BEGIN PSTIN
PPP__14				;LOCAL STACK POINTER
PSSLEN__20			;LOCAL STACK SIZE
PSTACK: BLOCK PSSLEN		;LOCAL STACK

SCPOPJ:	POPJ	PPP,

^^PSTACS:	BLOCK	20		;STORAGE FOR FAIL ACS

;THIS FLAG IS NOT CURRENTLY USED, BUT CAN IN PRINCIPLE BE USED TO RESTORE
;ACS ON, FOR EXAMPLE, A REENTER AFTER ^C...TMW
^^PSTFLG:	0		;NON-ZERO IF IN SIMULATION
				;-1 SAYS RESTORE 17 ONLY
				;0,,-1 SAYS RESTORE ALL ACS


;string input jsys (pstin) simulation - courtesy IMSSS
;modified lines of code are flagged by ***

;arguments:	1. string pointer
;		2. max. no of characters
;		3. lh = flags bit 0: break on ctrls (exc. editing)
;			 bits 10-17: timing in seconds for whole	
;			 	     line (no timing if zero)
;		   rh = bits 18-26:  special char to break on
;			bits 27-35:  second special char to break on
;		4. lh = no. of characters to skip on startup
;		        if b2 of 3 set.
;		   rh = break table address if b0 of 3 set.
;		5. optional string pointer if b1 of 3 set.

;table to control editing features

ctrtab:	byte	(9)400,401,202,203
	byte	(9)204,205,206,207
NOT20,<		byte	(9)210,011,405,213
		byte	(9)214,215,216,217 >;NO TOPS20
T20,<		BYTE	(9)210,011,212,213
		BYTE	(9)214,015,216,217 >;TOPS20
	byte	(9)220,221,404,223
	byte	(9)224,225,026,402
	byte	(9)403,231,232,233
	byte	(9)234,235,236,215

xxx==40
repeat 27,<
	byte	(9)xxx,xxx+1,xxx+2,xxx+3
	xxx=xxx+4   >

	byte	(9)174,375,375,401


ctrtae==.-ctrtab
; string input routine
; enter here via JSR .PSTIN

;*** open
^^.pstin:	0
	MOVEM	17,PSTACS+17
	SETOM	PSTFLG		;ONLY 17 SHOULD BE RESTORED
	HRRZI	17,PSTACS
	BLT	17,PSTACS+16	;SAVE FAIL ACS
	HRRZM	17,PSTFLG	;NOW ALL MAY BE RESTORED
	MOVE	PPP,[XWD -PSSLEN,PSTACK-1]
;*** close
	setz	15,0		;used for rfmod on backspace
	MOVEI	1,100
	RFMOD
	PUSH	PPP,2		;SAVE MODES
	TRO	2,17B23		;BREAK ON EVERYTHING
	SFMOD
	rfcoc
	push	PPP,2
	push	PPP,3
	tlz	2,140000	;ctrl a
	tlz	3,600360	;ctrl r,w,x
	trz	3,600000	;altmod
	sfcoc
	TIME
	push	PPP,1		; -1(PPP) time
	setz	7,0		;flag register
IFN IMSSSW,<
	gjinf			;THIS IS THE WRONG THING TO DO YOU KNOW...
	movei	1,400000(4)
	gttyp
	andi	2,37		;test for imlac
	cain	2,12
	tlo	7,(1b16)	;imlac
	cain	2,11
	tlo	7,(1b15)	;OR TEC 
>;END OF IMSSS
	move	5,PSTACS+1	;***
	hrlzi	1, 440700
	jumpg	5, psin0
	caml	5, [777777000000]
	hllm	1, PSTACS+1	;***
psin0:	move	4, PSTACS+1	;*** string ptr
IFN KAFLG,<TLZ 4,20>
IFN KIFLG,<TLZ 4,37>
	move	5,4		; starting pointer
	move	6,PSTACS+3	;*** get flags
	move	16,PSTACS+2	;*** get byte count
	tlnn	6,(1b2)		;skip bytes
	jrst	psin1		; no
	move	10,5
	move	11,PSTACS+4	;***
	hlrz	11,11		; get byte count
	jumple	11,psin1
	sub	16,11		; update byte count left
	PUSHJ	PPP,bpplus	; add to byte pointer
	move	4,11
psin1:	skipg	16		; get total count
	tlo	7,(1b0)		; set break
psin2:	tlne	7,(1b0)		; break
	jrst	psend
IFN IMSSSW,<
	tlnn	6,777		; timing
	jrst	[ pbin
		  jrst psin22 ]
	PUSHJ	PPP,pstim	;check time
psin25:	jrst	[ movei 1,222
		  jrst psin24 ]
	pbtin
	cain	1,22
	jrst	psin25
>;END OF IMSSS
IFE IMSSSW,< PBIN>
psin22:	ldb	2,[point 7,6,26]
	ldb	3,[point 7,6,35]
	caie	2,(1)
	cain	3,(1)
	tlo 	7,(1b0)		; break
	idivi	1,4
	tlnn	6,(1b0)		;break table specified
	jrst	[ move 3,ctrtab(1)
		  jrst psin23 ]
	move	3,PSTACS+4	;***
	addi	1,(3)
	move	3,(1)		;***
psin23:	xct	psinb(2)
	trze	1,400
	jrst	psin4		;special handling
psin24:	PUSHJ	PPP,pscha
	jrst 	psin2		;loop

psin4:	cail	1,psedl
	setz	1,0
	xct	psedr(1)
	jrst	psin2		;loop

psinb:	ldb	1,[point 9,3,8]
	ldb	1,[point 9,3,17]
	ldb	1,[point 9,3,26]
	ldb	1,[point 9,3,35]

psedr:	jfcl	0		;noop
	PUSHJ	PPP,psdel	;delete charachter
	PUSHJ	PPP,psbaw	;delete word
	PUSHJ	PPP,psbal	;delete line
	PUSHJ	PPP,psret	;retype line
	PUSHJ	PPP,pslf	;special linefeed handling
psedl==.-psedr
;bpPlus, dbp, countB

bp1==10
bp2==11
cnt==11
tmp1==12
tmp2==13


;	Add to byte pointer
;	-------------------
; Accepts:
;	BP1:	Byte pointer
;	CNT:	Byte count, must be at least -500000 (octal), and
;			may not cause  BP1  to wrap around memory
; Returns:
;	BP1:	unchanged
;	CNT:	Updated byte pointer such that "LDB" will work (at
;		  least one "IBP" has been performed on the pointer)	
;	CNT+1:	lost

bpPlus:
;=====
	addi	cnt, 500004	; Add 100001 (full) words to make the 
				;   count positive.  Assures non-
				;   negative remainder in division.
				;   One byte discrepency for initial IBP.
	idivi	cnt, 5		; Divide it to full words
				;   and left-over bytes (in  CNT+1)
	subi	cnt, 100001	; Remove the added words
	add	cnt, bp1	; CNT  becomes the new pointer
	ibp	     cnt	; Add left-over byte
	sojge	cnt+1, .-1	; All left-over bytes done?
	popj	PPP,		;  Yes



;	Decrement byte pointer
;	----------------------
; Accepts:
;	BP1:	Byte pointer
; Returns:
;	BP1:	The byte pointer decremented by one byte

dbp:
;==
	add	bp1, [xwd 70000,0]	; Put back one byte
	tlne	bp1, 400000		; Owerflow to previous word?
	 sub	bp1, [xwd 430000,1]	 ;  Yes, account for it
	popj	PPP,


;	Count bytes between two byte pointers
;	-------------------------------------
; Accepts:
;	BP1:	First (from) byte pointer
;	BP2:	Second (to) byte pointer
; Returns:
;	BP1:	unchanged
;	BP2:	Byte count from  BP1  to  BP2
;	TMP1:	lost
;	TMP2:	lost

countB:
;=====
	ldb	tmp1, [point 6,bp1,5]	; Bits to the right of byte 1
	ldb	tmp2, [point 6,bp2,5]	; Bits to the right of byte 2
	subi	tmp1, (tmp2)		; Bit difference
	idivi	tmp1, 7			; Within-word byte difference

	subi	bp2, (bp1)
	hrre	bp2, bp2	; Full word difference
	imuli	bp2, 5		; Convert it to byte difference
	add	bp2, tmp1	; Add count derived form within-word bytes
	popj	PPP,
;pscha, psdel, psbaw

pscha:	tlze	7,(1b1)		;rubout in progress
	jrst	[ push PPP,1
		  movei 1,"]" 
		  tlnn 7,(1B15+1b16) ; imlac OR TEC
		  pbout
		   pop PPP,1
		  PUSHJ PPP,psrmod
		  tlnn 7,(1B15+1b16)
		  pbout
		  tlnn 7,(1b16)		;to correct prob of
		  caie 1, 215		;cr terminating delete
		   jrst .+1		;no prob on imlac
		  movei 1, 12		;must have lf to get off
		  pbout			;same line as delete
		  movei 1, 215		;since only cr was sent
		  jrst .+1 ]		;fixed 8-2-73 /ron
IFN KAFLG,<TLZ 4,20>
IFN KIFLG,<TLZ 4,37>
	idpb 1,4		;***
	sosle 	16
	trne	1,200		;break charachter
	tlo	7,(1b0)		;yes
	POPJ	PPP,

psdel:	move	10,5
	move	11,4
	PUSHJ	PPP,countb	;how many left
	jumpe	11,psbal	;none left-line delete
	PUSHJ	PPP,psmod	;set no echo
	movei	1,"["
	tlnn	7,(1b1+1B15+1b16)
	pbout
	tlo	7,(1b1)		;set rubout in progress
	aos	16
IFN KAFLG,<TLZ 4,20>
IFN KIFLG,<TLZ 4,37>
	ldb 1,4			;*** get byte
	cain	1,12
	jrst	psdel2		;special handling for lf
	tlne	7,(1B15+1b16)	;imlac OR TEC
	 JRST	[PUSHJ	PPP,PSDELC	;;;MOVei 1,177
		  JFCL		;ILLEGAL OR LINE EMPTY
		 JRST	PSDEL1]
	pbout
psdel1:	move 	10,4
	PUSHJ	PPP,dbp		;decr. byte pointer
	move	4,10
	POPJ	PPP,

psdel2:	hrroi	1,[asciz /^^
/]
	psout
	jrst	psdel1

psbaw:	trz	7,1		;backspace word
	move	10,5
	move	11,4
	PUSHJ	PPP,countb	;how many bytes left
	jumpe	11,psbal
	tlne	7,(1B15+1b16)	;imlac OR TEC
	jrst	psbaw1
	hrroi	1,[asciz /__ /]
	psout
psbaw1:	IFN KAFLG,<TLZ 4,20>
	IFN KIFLG,<TLZ 4,37>
	ldb 1,4			;***
	cain	1,12		;line feed is special
	jrst	psbaw3
	caie	1,40		;space
	cain	1,11		;tab
	jrst	[ trnn 7,1
		  jrst .+2
		  POPJ PPP,]
	tro 	7,1		;set char. found flag
;;;	movei	1,177
;;;	tlne	7,(1b16)	;imlac
;;;	pbout
	TLNN	7, (1B15+1B16)	;IMLAC OR TEC
	 JRST	PSBAW2
	PUSHJ	PPP,PSDELC	;DO DELETE
	 JFCL			;DON'T WORRY IF EMPTY
	
psbaw2:	aos	16		;incr. byte count
	move	10,4
	PUSHJ	PPP,dbp		;decr. byte pointer
	move	4,10
	move	10,5
	move	11,4
	PUSHJ	PPP,countb
	jumpn	11,psbaw1	;not done yet
	POPJ	PPP,

psbaw3:	trne	7,1		;already char. found
	POPJ	PPP,		;yes, all done
	hrroi	1,[asciz /^^
/]
	psout
	jrst	psbaw2

pslf:	movei 	1,15
	pbout			;send line feed
	movei 	1,12
	jrst	pscha

psmod:	tlne	7,(1b1+1B15+1b16)
	POPJ	PPP,		;not for imlac or if in rubout mode
	movei	1,100
	rfmod
	move	15,2		;save in ac15
	trz	2,3b25		;reset echo mode
	sfmod
	POPJ	PPP,

psrmod:	skipn	2,15		;echo mode saved
	POPJ	PPP,		;no
	push 	PPP,1
	movei	1,100
	sfmod
	setz	15,0		;reset flag
	pop	PPP,1
	POPJ	PPP,

IFE IMSSSW,<PSDELC: POPJ PPP,>
IFN IMSSSW,<
PSDELC:	MOVEI	1, 101		;PRIMARY OUTPUT
	DELCH
	 JFCL			;*** + 1 - NOT TTY - SHOULDN'T GET HERE
	 POPJ	PPP,		;+ 2 - EMPTY LINE, NO SKIP
 	 JRST	[AOS	(PPP)	;+ 3 -- SKIP IF DONE OK
		 POPJ	 PPP,]
	JFCL  			;*** + 4 - IF NOT DISPLAY 
	POPJ	PPP,		;A LOZER
>;END OF IMSSS
psbal:	move 	4,PSTACS+1	;*** del line
	move	5,4
	move	16,PSTACS+2     ;***
psbal1:	movei 	1,"#"
	pbout
	pbout
	movei	1,37
	pbout
	tlz	7,(1b1)		;reset rubout mode
	PUSHJ	PPP,psrmod	;reset echo mode
	tlnn	6,(1b1)		;optioanal string
	POPJ	PPP,		;no
	move	2,PSTACS+5	;***
	jumpg	2,psbal2
	caml	2,[ 777777000000 ]
	hrli	2, 440700
psbal2:	IFN KAFLG,<TLZ 2,20>
	IFN KIFLG,<TLZ 2,37>
	ildb 1,2		;***
	jumpe	1,Scpopj	;*** to POPJ PPP,
	pbout
	jrst	psbal2		;keep looping

psret:	PUSHJ	PPP,psbal1	;clean up at end of line
	move	10,5
	move	11,4
	PUSHJ	PPP,countb	;count bytes left
	move	2,5
psret1:	sojl	11,Scpopj	;*** to popj PPP, - no more
IFN KAFLG,<TLZ 2,20>
IFN KIFLG,<TLZ 2,37>
	ildb 1,2		;***
	cain	1,12		;line feed
	movei	1,37		; make eol
	pbout
	jrst 	psret1

psend:	movem	4,PSTACS+1	;***
	movem	16,PSTACS+2	;***
	pop	PPP,1		;time
	pop 	PPP,3
	pop	PPP,2
	movei	1,100
	sfcoc			;reset tty modes
	pop	PPP,2
	sfmod
;*** open
	HRLZI	17,PSTACS	;restore FAIL ACS
	BLT	17,17
	SETZM	PSTFLG		;FLAG OUT SAFELY
	JRST	@.PSTIN
;*** close

IFN IMSSSW,<
pstim:	ldb	3, [point 8, 6, 17]		; do timing
	TIME
	sub	1, -1(PPP)
	lsh	1, -^d10	; conv to seconds
	sub	3, 1
	jumple	3, pstim1
	aos	(PPP)		; double skip
	move	1,3		; return time lept
pstim1:	POPJ	PPP,
>;END OF IMSSS

BEND PSTIN

>;END IFE PSTISW  >;NOT20

>;END TNX

	END	STRT