
/   ############         #########         #########
/   ############         #########         #########
/   ###         ###   ###         ###   ###         ###
/   ###         ###   ###         ###   ###         ###
/   ###         ###   ###         ###   ###
/   ###         ###   ###         ###   ###
/   ############      ###############      #########
/   ############      ###############      #########
/   ###               ###         ###               ###
/   ###               ###         ###               ###
/   ###               ###         ###   ###         ###
/   ###               ###         ###   ###         ###
/   ###               ###         ###      #########
/   ###               ###         ###      #########
/
/
/      #########         #########      ###
/      #########         #########      ###
/   ###         ###   ###         ###   ###
/   ###         ###   ###         ###   ###
/   ###               ###         ###   ###
/   ###               ###         ###   ###
/   ###               ###############   ###
/   ###               ###############   ###
/   ###               ###         ###   ###
/   ###               ###         ###   ###
/   ###         ###   ###         ###   ###
/   ###         ###   ###         ###   ###
/      #########      ###         ###   ###############
/      #########      ###         ###   ###############
/
/
/                        #########
/                        #########
/                     ###         ###
/                     ###         ###
/                     ###
/                     ###
/      #########         #########         FROM  N.WIRTH
/      #########         #########         ETH - ZUERICH
/                                 ###
/                                 ###
/                     ###         ###
/                     ###         ###
/                        #########
/                        #########
/
/
/IMPLEMENTED ON A PDP-8/E COMPUTER WITH 28K-WORDS OF MEMORY
/BY
/PROF. HEINZ STEGBAUER
/HTL-MOEDLING, IN 1979

EJECT P  A  S  C  A  L  -  S
VERSION=2

/C O R E   L A Y O U T :



/FIELD 0  0000 - 5777	INTERPRETER
/	  6000 - 6777	FILE- AND DEVICE BUFFERS
/	  7000 - 7577	COMPILER (INSYMBOL, NEXTCH)
/	  7600 - 7777	OS/8 - RESIDENT PART

/FIELD 1  0000 - 7577	INTERMEDIATE CODE
/	  7600 - 7777	OS/8 - RESIDENT PART

/FIELD 2  0000 - 3777	SYMBOL-TABLE
/	  4000 - XXXX	STRING-TABLE
/	  XXXX - 6377	CONSTANT-TABLE
/	  6400 - 7377	ARRAY-TABLE
/	  7400 - 7777	BLOCK-TABLE



/AT COMPILETIME:

/FIELD 3  0000 - 3777	NAMES OF SYMBOL-TABLE
/	  4000 - 7177	FSYS, SET-CONSTANTS, LISTS AND
/			TABLES, ERROR ROUTINES

/FIELD 4  0000 - 6377	COMPILER
/	  6400 - 7777	AUXILIARY ROUTINES

/FIELD 5  0000 - 7777	STACK FOR COMPILER OPERATION

/FIELD 6  0000 - 7777	LONG ERROR MESSAGES



/AT RUNTIME:

/FIELD 3  0000 - 7777	/S T A C K  (4K WORDS OF 48 BITS)
/FIELD 4  0000 - 7777
/FIELD 5  0000 - 7777
/FIELD 6  0000 - 7777


CODEFIELD=10
TABLEFIELD=20
NAMEFIELD=30
SETFIELD=30
COMPFIELD=40
PUSHFIELD=50
ERRFIELD=60
STACKFIELD=30
/S T R U C T U R E   O F    T A B L E S :

/SYMBOL-TABLE (4 WORDS PER ENTRY, MAX. 512 ENTRIES)
/------------

TAB=0000

LINK=TAB	/WORD 0, BITS 0-11
OBJ=TAB+1	/WORD 1, BITS 0-5
TYP=TAB+1	/WORD 1, BITS 6-11
REF=TAB+2	/WORD 2, BITS 0-5
NORMAL=TAB+2	/WORD 2, BIT 6
LEV=TAB+2	/WORD 2, BITS 7-11
ADR=TAB+3	/WORD 3, BITS 0-11


/STRING-TABLE (ARRAY[0:N] OF CHAR, 6 BITS/CHAR,FROM 4000 UPWARDS)
/------------


/CONSTANT-TABLE (4 WORDS PER ENTRY, FROM 6400 DOWNWARDS)
/--------------


/ARRAY-TABLE (8 WORDS PER ENTRY, MAX. 64 ENTRIES)
/-----------

ATAB=6400

/		/WORD 0  UNUSED!
INXTYP=ATAB+1	/WORD 1
ELTYP=ATAB+2	/WORD 2
ELREF=ATAB+3	/WORD 3
LOW=ATAB+4	/WORD 4
HIGH=ATAB+5	/WORD 5
ELSIZE=ATAB+6	/WORD 6
SIZE=ATAB+7	/WORD 7


/BLOCK-TABLE (4 WORDS PER ENTRY, MAX. 64 ENTRIES)
/-----------

BTAB=7400

LAST=BTAB	/WORD 0
LASTPAR=BTAB+1	/WORD 1
PSIZE=BTAB+2	/WORD 2
VSIZE=BTAB+3	/WORD 3
/A S S E M B L E R   D E F I N I T I O N S:

L0001=CLA CLL IAC
L0002=CLA STL RTL
L0003=CLA STL IAC RAL
L0004=CLA CLL IAC RTL
L0006=CLA STL IAC RTL
L0100=CLA CLL IAC BSW
L2000=CLA STL RTR
L4000=CLA STL RAR
L7777=CLA CLL CMA
L7776=CLA CLL CMA RAL
L7775=CLA CLL CMA RTL
L3777=CLA CLL CMA RAR
L5777=CLA CLL CMA RTR
/A R I T H M E T I C   D E F I N I T I O N S:


/MEMORY REFERENCED INSTRUCTIONS:

FIXMRI GET=0000
FIXMRI ADD=1000
FIXMRI SUB=2000
FIXMRI MUL=3000
FIXMRI DIV=4000
FIXMRI MOD=5000		/ALSO:  JMP=5000
FIXMRI PUT=6000



/OPERATE CLASS INSTRUCTIONS:

NORM=7200		/REAL
READREAL=7201
WRITEREAL=7202
TRUNC=7203
ROUND=7206
RSQUARE=7205

ZERO=7204		/BOTH TYPES
ABSVAL=7000
NEGATE=7004
WRITELINE=7006

READINTEGER=7001	/INTEGER
WRITEINTEGER=7002
FLOAT=7003
ISQUARE=7005



/SKIP - INSTRUCTIONS:

SKIP=SKP
SKEQ=SZA
SKNE=SNA
SKLT=SMA
SKLE=SMA SZA
SKGT=SPA SNA
SKGE=SPA



AAAAAA=JMS I 44		/ENTER MACRO MODE
EEEEEE=0000		/RETURN TO PDP8 MODE

INT=0177
REAL=7777
/C O M P I L E R   D E F I N I T I O N S:
DECIMAL
/S Y M B O L S:

INTCON=0
REALCON=1
CHARCON=2
STRING=3
NOTSY=4
PLUS=5
MINUS=6
TIMES=7
IDIVSY=8
RDIVSY=9
IMODSY=10
ANDSY=11
ORSY=12
EQL=13
NEQ=14
GTR=15
GEQ=16
LSS=17
LEQ=18
LPARENT=19
RPARENT=20
LBRACK=21
RBRACK=22
COMMA=23
SEMICOLON=24
PERIOD=25
COLON=26
BECOMES=27
CONSTSY=28
TYPESY=29
VARSY=30
FUNCTIONSY=31
PROCEDURESY=32
ARRAYSY=33
RECRDSY=34
PROGRAMSY=35
IDENT=36
BEGINSY=37
IFSYM=38
CASESY=39
REPTSY=40
WHILSY=41
FORSY=42
ENDSY=43
ELSESY=44
UNTILSY=45
OFSY=46
DOSY=47
TOSY=48
DOWNTOSY=49
THENSY=50

/O B J E C T S:

KONSTANT=0
VARIABLE=1
TYPE1=2
PROZEDURE=3
FUNKTION=4





/T Y P E S:

NOTYP=0
INTS=1
REALS=2
BOOLS=3
CHARS=4
ARRAY=5
RECORD=6





/P R O C E D U R E S:

BLOCK=0
STATEMENT=1
ASSIGNMENT=2
COMPOUNDSTATEMENT=3
IFSTATEMENT=4
CASESTATEMENT=5
REPEATSTATEMENT=6
WHILESTATEMENT=7
FORSTATEMENT=8
STANDPROC=9
SELECTOR=10
CALL=11
STANDFCT=12
FACTOR=13
TERM=14
SIMPLEEXPRESSION=15
EXPRESSION=16
CONDECLARE=17
TYPDECLARE=18
VARDECLARE=19
PRODECLARE=20
CONSTANT=21
ARRAYTYP=22
TYPE=23
PARAMETERLIST=24
ONECASE=25


/P R O G R A M   P A R A M E T E R S:

TMAX=512	/MAX. NUMBER OF IDENTIFIERS
AMAX=64		/MAX. NUMBER OF ARRAYS
BMAX=64		/MAX. NUMBER OF BLOCKS (PROCEDURES+RECORDS)
CMAX=1980	/MAX. SIZE OF INTERMEDIATE CODE
CSMAX=30	/MAX. NUMBER OF CASES
LMAX=16		/MAX. NUMBER OF LEVELS
LLNG=80		/MAX. LENGTH OF INPUT LINE
ALNG=8		/NO. OF SIGNIFICANT CHAR'S IN IDENTIFIERS

OCTAL
	FIELD 0
/P A G E   Z E R O :

	*4
EOF,	0		/END OF FILE SWITCH (BOOLEAN)
EOLN,	1		/END OF LINE SWITCH ( - " - )
CC,	0		/CHARACTER-COUNTER
ERRSW,	0		/ERROR IN LINE SWITCH

	*10
XR10,	0		/ONE AUTOINDEX REGISTER

	*20
PC,	0	/P R O G R A M - C O U N T E R

		/I N S T R U C T I O N - R E G I S T E R
IRF,	0		/OP-CODE
IRX,	0		/LEVEL
IRY,	0		/ADDRESS OR VALUE

		/S T A C K - P O I N T E R S
B,	0		/BASE INDEX
T,	0		/STACK POINTER (SIMPLE INDEX)
T3,	0		/= 4*T + 3  (ADDRESS OF WORD 3)
T3T,	0		/T3 FOR ROUTINE 'TOSTACK'
LOOK,	240		/NEXT CHARACTER (LOOK AHEAD)

/----------- PAGE 0 LOC'S OF ARITHMETIC PACKAGE ----------------
	*32
BCD,	0		/BINARY CODED DECIMAL DIGIT
CHAR,	240		/CURRENT CHARACTER
M,	22		/OUTPUT FORMAT PARAMETERS
N,	0		/(DEFAULT VALUES: M=18, N=0)

ACX,	0	/ A C - R E G I S T E R
ACS,	0
AC0,	0
AC1,	0
AC2,	0
AC3,	0

	INTERPC		/POINTER TO MACRO-INTERPRETER

MQ1,	0	/ M Q - R E G I S T E R
MQ2,	0
MQ3,	0

OP0,	0	/ O P - R E G I S T E R
OP1,	0
OP2,	0
OP3,	0
OPX,	0
OPS,	0
MIN4,	-4		/-4 (COUNTING WORDS)
MIN44,	-44		/-36 (COUNTING BITS)
OS8,	7600

H1,	0	/4 GENERAL TEMPORARIES
H2,	0
H3,	0
H4,	0

/NEW INSTRUCTIONS USED ALSO BY ARITHMETIC PACKAGE:

HALVE=JMS I .		/AC:=AC DIV 2	(SHIFT RIGHT)
	RACR
DOUBLE=JMS I .		/AC:=2*AC	(SHIFT LEFT)
	RACL
CLEAR=JMS I .		/AC := 0
	CLAC
LOAD=CLEAR		/AC := CONTENTS OF ACCUMULATOR (12 BIT INT.)

READC=JMS I .		/GET NEXT CHAR FROM INPUT DEVICE
PTREAD,	XNEXTCH		/XREAD AT RUNTIME
PRINTC=JMS I .		/SEND CHAR TO OUTPUT DEVICE
PTPRINT,XPRINT
ZPRINT,	XPRINT			/CONSTANT POINTER TO XPRINT
CRLF=JMS I .
	XCRLF
SNALF=JMS I .		/SKIP ON NOT ALFABETIC CHAR. (LETTER)
	XSNALF
SKDIG=JMS I .		/SKIP ON DIGIT
	XSKDIG
BREAK=JMS I .		/CHECK FOR CTRL-C
	XBREAK
HALT=JMS I .		/RUN-TIME ERROR HANDLING
PTHALT,	ERR21		/XHALT AT RUNTIME
/---------------------------------------------------------------


/MACRO INSTRUCTIONS USED BY INTERPRETER:

	*100
ERROR=JMS I .		/NON FATAL COMPILER ERRORS
	ZERROR
FATAL=JMS I .		/FATAL COMPILER ERRORS
	ZFATAL
OFTAB=JMS I .		/GET INFO FROM SYMBOL-TABLE
	ZOFTAB
OFATAB=JMS I .		/GET INFO FROM ARRAY-TABLE
	ZOFATAB
OFBTAB=JMS I .		/GET INFO FROM BLOCK-TABLE
	ZOFTAB
OFDISPLAY=JMS I .	/GET INFO FROM DISPLAY
	ZOFDISP
TODISPLAY=JMS I .	/PUT INFO INTO DISPLAY
	ZTODISP
GETCONST=JMS I .	/GET CONSTANT
	ZOFCONST
CONTINUE=JMP I .
	ILOOP
BUMP=JMS I .		/MOVE STACK POINTER
	XBUMP

SDF=JMS .		/CHANGE TO TOP OF STACK - DATA FIELD
	0
XSDF,	CDF	/VARIABLE!
	JMP I .-2

POPONE=JMS I .		/POP ONE WORD (WORD 3 INTO AC)
	XPOPONE
POPVAL=JMS I .		/POP FOUR WORDS
	XPOPVAL
POPNUM=JMS I .		/POP NUMBER (=POP 4 WORDS AND UNPACK)
	XPOPNUM
PUSHONE=JMS I .		/PUSH ONE WORD
	XPUSHONE
PUSHVAL=JMS I .		/PUSH FOUR WORDS
	XPUSHVAL
PUSHNUM=JMS I .		/PUSH NUMBER (= PACK + PUSHVAL
	XPUSHNUM
TOSTACK=JMS I .		/INSERT ONE WORD INTO STACK[T3T]
	XTOSTACK
OFCODE=JMS I .		/GET INTERMEDIATE INSTRUCTION
	XOFCODE

/LOCATIONS USED BY I/O-FILE HANDLING:

IBUFFER=6000	/INPUT FILE BUFFER
OBUFFER=7000	/OUTPUT FILE BUFFER
IDEVBUF=6400	/PAGE OF INPUT DEVICE HANDLER
ODEVBUF=6600	/PAGE OF OUTPUT DEVICE HANDLER

IDEVH,	0		/ENTRY POINT OF INPUT DEVICE HANDLER
ODEVH,	0		/ENTRY POINT OF OUTPUT DEVICE HANDLER
NAME,	ZBLOCK 4	/NAME OF OUTPUT FILE
DEVNO,	0		/OUTPUT DEVICE NUMBER
LEMPTY,	0		/ -LENGTH OF EMPTY
MBLOCKS,0		/COUNTING WRITTEN BLOCKS
OBP,	OBUFFER		/BUFFER POINTER (SEE PUTC)
OC3,	-3		/3-CHARACTER SWITCH (SEE PUTC)

I37,	DCA CHAR	/HALT PROGRAM - CLOSE OUTPUT FILE
	TAD [232	/WRITE EOF-MARK
	PRINTC		/FILL REST OF BUFFER WITH ZEROES
	TAD [OBUFFER
	CIA
	TAD OBP
	SZA CLA
	JMP .-5
	L7777		/COMPUTE ACTUAL LENGTH
	TAD LEMPTY	/OF OUTPUT FILE
	CIA
	TAD MBLOCKS
	DCA ALOF
	CIF 10
	TAD DEVNO
	JMS I [7700	/CALL USR TO CLOSE OUTPUT FILE
	4
	NAME
ALOF,	0
ERRORD,	HALT
	JMP I OS8	/RETURN TO KEYBOARD MONITOR
/INSTRUCTION DECODER AND DISPATCH ROUTINE

	*200
ISTART,	CLA CLL		/STARTING ADDRESS
	DCA EOF
	L0001
	DCA EOLN
	TAD [240
	DCA CHAR
	TAD [240
	DCA LOOK
	CLEAR
	DCA T		/INITIALIZE THE STACK:
	BUMP
	PUSHVAL		/S[1].I := 0
	BUMP
	PUSHVAL		/S[2].I := 0
	BUMP
	PUSHVAL		/S[3].I := 0
	BUMP
	L0001
	OFBTAB;LAST
	DCA H4
	TAD H4
	PUSHONE		/S[4].I := BTAB[1].LAST
	DCA B		/B := 0
	L0001
	DCA IRX
	TODISPLAY	/DISPLAY[1] := 0
	L0002
	OFBTAB;VSIZE
	TAD MIN2
	DCA T
	BUMP		/T := BTAB[2].VSIZE - 1
	TAD H4
	OFTAB;ADR
	DCA PC		/PC := TAB[ S[4].I ].ADR

ILOOP,	BREAK
	CLL		/GET CURRENT INSTRUCTION
	TAD PC
	OFCODE
	MQL
	MQA
	BSW
	AND [77
	DCA IRF
	MQA
	AND [77
	DCA IRX
	STL
	TAD PC
	OFCODE
	DCA IRY
	ISZ PC		/PC := PC + 1

	TAD JUMP
	TAD IRF
	DCA .+1
	HLT		/JUMP TO INSTRUCTION ROUTINE
JUMP,	JMP I ILIST
MIN2,	-2
/INSTRUCTIONS OF STACK COMPUTER - ADDRESS TABLE:

ILIST,	I00	/LOAD ADDRESS
	I01	/LOAD VALUE
	I02	/LOAD INDIRECT
	I03	/UPDATE DISPLAY
	ZBLOCK 4	/CODES 4 - 7 UNUSED!
	I08	/CALL STANDERD FUNCTION
	I09	/OFFSET
	I10	/JUMP
	I11	/CONDITIONAL JUMP
	I12	/SWITCH CASE
	ILOOP		/CODE 13 USED INTERNALLY!
	I14	/FOR1UP
	I15	/FOR2UP
	I16	/FOR1DOWN
	I17	/FOR2DOWN
	I18	/MARK STACK
	I19	/CALL
	I20	/INDEX1
	I21	/INDEX
	I22	/LOAD BLOCK
	I23	/COPY BLOCK
	I24	/LITERAL
	I25	/LOAD CONSTANT
	I26	/FLOAT
	I27	/READ
	I28	/WRITE STRING
	I29	/WRITE1 (DEFAULT FIELD WIDTH)
	I30	/WRITE2 ( :M )
	I31	/WRITE3 ( :M :N )
	I32	/EXIT PROCEDURE
	I33	/EXIT FUNCTION
	I34	/LOAD ABSOLUTE
	I35	/LOGICAL NOT
	I36	/NEGATE
PTI37,	7600	/HALT (BECOMES  I37  IF FILE I/O!)
	I38	/STORE
	ZBLOCK 11	/CODES 39 - 47 UNUSED!
	I48	/ARITHMETIC OPERATIONS
	I49	/COMPARE INTEGERS
	I50	/COMPARE REALS
	I51	/LOGICAL OR
	I52	/LOGICAL AND
	ZBLOCK 10	/CODES 53 - 60 UNUSED!
	I61	/ASCII
	I62	/READLN
	I63	/WRITELN

/INSTRUCTIONS OF STACK COMPUTER (A)

I00,	BUMP		/LOAD ADDRESS
	OFDISPLAY
	TAD IRY
	PUSHONE
	CONTINUE

I01,	BUMP		/LOAD VALUE
	OFDISPLAY
	TAD IRY
	POPVAL
	PUSHVAL
	CONTINUE

I02,	BUMP		/LOAD INDIRECT
	OFDISPLAY
	TAD IRY
	POPONE
	POPVAL
	PUSHVAL
	CONTINUE

I03,	TAD IRX		/UPDATE DISPLAY
	CIA
	TAD IRY
	DCA H1
	TAD B
	DCA H3
UPDIS,	TAD H3
	TODISPLAY
	L7777
	TAD IRX
	DCA IRX
	L0002
	TAD H3
	POPONE
	DCA H3
	ISZ H1
	JMP UPDIS
	CONTINUE

I08,	TAD IRY		/CALL STANDARD FUNCTION
	TAD (JMS I STDFUNCT
	DCA .+2
	POPNUM
STFJMS,	JMS .		/ J M S  TO REQUESTED FUNCTION
	PUSHNUM
	CONTINUE

STDFUNCT,XABS	/0
	XABS	/1
	XISQU	/2
	XRSQU	/3
	XODD	/4
	XCHR	/5
	STFJMS	/6
	XSUCC	/7
	XPRED	/8
	XROUND	/9
	RTRUNC	/10
	XSIN	/11
	XCOS	/12
	XEXP	/13
	XLOG	/14
	XSQRT	/15
	XATN	/16
	XEOF	/17
	XEOLN	/18
	XRAND	/19

I09,	POPONE		/OFFSET
	TAD IRY
	PUSHONE
	CONTINUE

I10,	TAD IRY		/JUMP
	DCA PC
	CONTINUE

I11,	POPONE		/CONDITIONAL JUMP
	CLL RAR
	TAD IRY
	SNL
	DCA PC
	L7777
	BUMP
	CONTINUE

I12,	POPVAL		/SWITCH CASE
	L4000
	AND AC1
	CLL RAL
	TAD AC3
	SZL
	CIA
	DCA H1
	L7777
	BUMP
SCASE,	CLL
	TAD IRY
	OFCODE
	TAD (-1500	/-1300
	SZA CLA
ERRORC,	HALT		/C A S E   E R R O R !
	STL
	TAD IRY
	OFCODE
	CIA
	TAD H1
	SNA CLA
	JMP .+4
	ISZ IRY
	ISZ IRY		/(INCREMENTS, DOESN'T SKIP!)
	JMP SCASE
	IAC STL
	TAD IRY
	OFCODE
	DCA PC
	CONTINUE

/I13 ... INTERNAL CODE (MARKS CASE SWITCH LIST)


XEOF,	0
	TAD EOF
	JMP .+3
XEOLN,	0
	TAD EOLN
	LOAD
	BUMP
	JMP STFJMS+1

XSUCC,	0
	L0001
	JMP XCHR+1
XPRED,	0
	L7777
	JMP XCHR+1
XCHR,	0
	TAD AC3
	AND [77
	LOAD
	JMP STFJMS+1

	PAGE
/INSTRUCTIONS OF STACK COMPUTER (B+C)

I14,	TAD UPSKIP	/FOR1UP
	SKP
I16,	TAD DOSKIP	/FOR1DOWN
	DCA FORUD1
	L7777		/COMMON ROUTINE:
	TAD T
	POPNUM
	AAAAAAAAAAAAAAAA
	PUT INT&FORH1
	EEEEEEEEEEEEEEEE
	POPNUM
	AAAAAAAAAAAAAAAA
	SUB INT&FORH1
FORUD1,	SKGE		/OR  SKLE
	JMP FOR1EX
	GET INT&FORH1
	EEEEEEEEEEEEEEEE
	L7776
	TAD T
	POPONE
	PUSHNUM
	CONTINUE

FOR1EX,	EEEEEEEEEEEEEEEE
	TAD IRY
	DCA PC
	L7775
	BUMP
	CONTINUE

/NOTE THE STACK SITUATION:
/
/	S[ T ] ... FINAL VALUE
/	S[T-1] ... INITIAL VALUE
/	S[T-2] ... ADDRESS OF CONTROL VARIABLE

I15,	TAD UPADD	/FOR2UP
	DCA FORUD2
	TAD UPSKIP
	JMP .+4
I17,	TAD DOSUB	/FOR2DOWN
	DCA FORUD2
	TAD DOSKIP
	DCA FORUD3
	L7776		/COMMON ROUTINE:
	TAD T
	POPONE
	DCA H2
	TAD H2
	POPNUM
	AAAAAAAAAAAAAAAA
FORUD2,	ADD INT&ONE	/OR  SUB INT&ONE
	PUT INT&FORH1
	EEEEEEEEEEEEEEEE
	POPNUM
	AAAAAAAAAAAAAAAA
	SUB INT&FORH1
FORUD3,	SKGE		/OR  SKLE
	JMP FOR2EX
	GET INT&FORH1
	EEEEEEEEEEEEEEEE
	TAD H2
	PUSHNUM
	TAD IRY
	DCA PC
	CONTINUE

FOR2EX,	EEEEEEEEEEEEEEEE
	L7775
	BUMP
	CONTINUE

UPSKIP,	SKGE
DOSKIP,	SKLE
UPADD,	ADD INT&ONE
DOSUB,	SUB INT&ONE

ONE,	0;0;0;1
FORH1,	ZBLOCK 4
MINUS1,	-1
BYTE,	77
LEVBITS,17

I18,	L0004		/MARK STACK
	BUMP
	TAD IRY
	OFTAB;REF
	BSW
	AND BYTE
	OFTAB;VSIZE
	TAD MINUS1
	PUSHONE
	BUMP
	TAD IRY
	PUSHONE
	CONTINUE

I19,	TAD IRY		/CALL
	CIA
	TAD T
	DCA H1
	L0004
	TAD H1
	POPONE
	DCA H2
	TAD H2
	OFTAB;LEV
	AND LEVBITS
	DCA H3
	L0001
	TAD H3
	DCA IRX
	TAD H1
	TODISPLAY
	L0003
	TAD H1
	POPONE
	TAD H1
	DCA H4
	L0001
	TAD H1
	DCA T3T
	TAD PC
	TOSTACK
	ISZ T3T
	TAD H3
	DCA IRX
	OFDISPLAY
	TOSTACK
	ISZ T3T
	TAD B
	TOSTACK
/-------------------- FALL THROUGH PAGE BOUNDARY -------------
	CLEAR
	TAD T
	CMA CLL
	TAD H4
	SNL CLA
	JMP .+4
	BUMP
	PUSHVAL
	JMP .-7
	TAD H1
	DCA B
	TAD H2
	OFTAB;ADR
	DCA PC
	CONTINUE

I20,	TAD (NOP	/INDEX1
	SKP
I21,	TAD (JMS MULTY	/INDEX
	DCA INDEX1
	TAD IRY		/COMMON ROUTINE:
	OFATAB;HIGH
	CMA
	DCA H1
	TAD IRY
	OFATAB;LOW
	TAD H1
	CIA
	DCA H2
	POPVAL
	L4000
	AND AC1
	CLL RAL
	TAD AC3
	SZL
	CIA
	TAD H1
	CLL
	TAD H2
	DCA RELADR
	SNL
ERRORB,	HALT		/INDEX OUT OF BOUNDS!
INDEX1,	NOP		/OR  JMS MULTY
	L7777
	BUMP
	POPONE
	TAD RELADR
	PUSHONE
	CONTINUE

RELADR=H4

MULTY,	0
	TAD IRY
	OFATAB;ELSIZE
	CLL RAR
	MQL
	TAD (-14	/-12 (BITS)
	DCA H3
MBIT,	SNL
	JMP .+3
	CLL
	TAD RELADR
	RAR
	SWP
	RAR
	SWP
	ISZ H3
	JMP MBIT
	SWP
	DCA RELADR
	JMP I MULTY

I22,	POPONE		/LOAD BLOCK
	DCA H1
	L7777
	BUMP
	TAD IRY
	CMA
	DCA H2
	JMP .+6
	BUMP
	TAD H1
	POPVAL
	PUSHVAL
	ISZ H1
	ISZ H2
	JMP .-6
	CONTINUE

I23,	L7777		/COPY BLOCK
	TAD T
	POPONE
	DCA H1
	POPONE
	DCA H2
	TAD IRY
	CMA
	DCA H3
	JMP .+7
	TAD H2
	POPVAL
	TAD H1
	PUSHVAL
	ISZ H1
	ISZ H2
	ISZ H3
	JMP .-7
	L7776
	BUMP
	CONTINUE

I24,	BUMP		/LITERAL (ADDRESSES ONLY!)
	TAD IRY
	LOAD
	PUSHVAL
	CONTINUE

I25,	BUMP		/LOAD CONSTANT
	TAD IRY
	GETCONSTANT
	PUSHVAL
	CONTINUE
I61,	POPONE		/WRITE SPECIAL ASCII
	PRINTC
	L7777
	BUMP
	CONTINUE


	PAGE
/INSTRUCTIONS OF STACK COMPUTER (D)

I26,	TAD IRY		/FLOAT
	CIA
	TAD T
	DCA H1
	TAD H1
	POPNUM
	JMS IFLOAT
	TAD H1
	PUSHNUM
	CONTINUE

I27,	TAD (JMS I READX-1	/READ
	TAD IRY
	DCA .+1
	JMS I READX
	POPONE
	PUSHNUM
	JMP EXI27

READX,	IINP
	RINP
	NOP
	CINP

I28,	POPONE		/WRITE STRING
	DCA M
	L7777
	BUMP
	POPONE
	CIA
	DCA N
	TAD IRY
	CDF TABLEFIELD
	JMS WSTRING
	JMP EXI27

I29,	TAD (TAD DFW-1	/WRITE (STANDARD FIELD WIDTH)
	TAD IRY
	DCA .+1
	TAD DFW
	DCA M
	JMP WRGO

I30,	POPONE		/WRITE (SPECIFIED FIELD WIDTH)
	DCA M
	L7777
	BUMP
WRGO,	POPNUM
	L7777
	BUMP
	DCA N
	TAD (JMS I WRITEX-1
	TAD IRY
	DCA .+1
	JMS I WRITEX
	CONTINUE

WRITEX,	IOUT
	ROUT
	BOUT
	COUT

DFW,	12
	22
	12
	1

I31,	POPONE		/WRITE ( X :M :N )
	DCA N
	L7777
	BUMP
	POPONE
	DCA M
	L7777
	BUMP
	POPNUM
	JMS I WRITEX+1	/REAL ONLY!
EXI27,	L7777
	BUMP
	CONTINUE
I32,	L7776		/EXIT PROCEDURE
	SKP
I33,	L7777		/EXIT FUNCTION
	TAD B
	DCA T
	BUMP
	L0001
	TAD B
	POPONE
	DCA PC
	L0003
	TAD B
	POPONE
	DCA B
	CONTINUE

I34,	POPONE		/LOAD (ABSOLUTE)
	POPVAL
	PUSHVAL
	CONTINUE

I35,	POPONE		/LOGICAL NOT
	CLL RAR
	CML
	RAL
	PUSHONE
	CONTINUE

I36,	POPNUM		/NEGATE
	JMS XNEG
	PUSHNUM
	CONTINUE

I38,	POPVAL		/STORE
	L7777
	BUMP
	POPONE
	PUSHVAL
	L7777
	BUMP
	CONTINUE

/I39 - I47   U N U S E D !


/B O O L E A N   O U T P U T

BOUT,	0
	TAD AC3
	TAD (-5
	DCA N
	TAD AC3
	SNA CLA
	L0004
	TAD (TRUEFALSE^2
	JMS WSTRING
	JMP I BOUT

	PAGE
/INSTRUCTIONS OF STACK COMPUTER (E)

I48,	POPNUM		/ARITHMETIC:
	JMS ENTR		/INTEGER:
	L7777			/ +    48,1
	BUMP			/ -    48,2
	POPNUM			/ *    48,3
	TAD (MRITABL		/ DIV  48,4
	TAD IRY			/ MOD  48,5
	DCA H1
	TAD I H1		/REAL:
	DCA H1			/ +    48,10
	JMS I H1		/ -    48,11
	PUSHNUM			/ *    48,12
	CONTINUE		/ /    48,13

I49,	TAD (ISUB-RSUB	/COMPARE (INTEGER)
I50,	TAD (RSUB	/COMPARE (REAL)
	DCA H1			/ =    50,7440
	POPNUM			/ <>   50,7450
	JMS ENTR		/ <    50,7500
	L7777			/ <=   50,7540
	BUMP			/ >    50,7550
	POPNUM			/ >=   50,7510
	JMS I H1	/SUBTRACT
	TAD IRY
	JMS BOOL
	LOAD
	PUSHVAL
	CONTINUE

I51,	POPONE		/LOGICAL OR
	DCA H1
	L7777
	BUMP
	SDF
	TAD H1
	CMA
	AND I T3
	TAD H1
	DCA I T3
	CDF
	CONTINUE

I52,	POPONE		/LOGICAL AND
	DCA H1
	L7777
	BUMP
	SDF
	TAD H1
	AND I T3
	DCA I T3
	CDF
	CONTINUE

/I53 - I61   U N U S E D !

	READC
I62,	TAD EOLN	/READLN
	SNA CLA
	JMP .-3
	READC
	CONTINUE

I63,	CRLF		/WRITELN
	CONTINUE
/AUXILIARY ROUTINES FOR 'WRITE STRING' AND 'BOOLEAN OUTPUT'

WSTRING,0
	DCA H1
	RDF
	TAD CCDF0
	DCA STRFLD
CCDF0,	CDF 0
	TAD M
	SNA
	JMP NCHAR
	TAD N		/M-N
	SPA SNA
	JMP PARTLY
	CIA
	DCA H2
	TAD [240
	PRINTC
	ISZ H2
	JMP .-3
	JMP NCHAR
PARTLY,	CIA		/ N-M
	TAD N		/-N
	DCA N		/= -M
NCHAR,	TAD H1
	STL RAR		/STRING TABLE STARTS AT 4000!
	DCA H2
STRFLD,	CDF TABLEFIELD
	TAD I H2
	CDF 0
	SNL
	BSW
	JMS ASCII
	ISZ H1
	ISZ N
	JMP NCHAR
	JMP I WSTRING

ASCII,	0
	AND [77
	TAD [240
	AND [77
	TAD [240
	PRINTC
	JMP I ASCII
/C H A R A C T E R   I N P U T   AND   O U T P U T


CINP,	0
	READC
	TAD CHAR
	AND [77
	LOAD
	JMP I CINP

COUT,	0
	TAD M
	SPA SNA
	L0001
	CIA
	DCA H2
	JMP .+3
	TAD [240
	PRINTC
	ISZ H2
	JMP .-3
	TAD AC3
	JMS ASCII
	JMP I COUT

	PAGE
/STACK INSTRUCTIONS

XBUMP,	0
	SNA		/IF (AC)=0
	L0001		/THEN T:=T+1
	CLL		/ELSE T:=T+(AC)
	SPA
	CML
	TAD T
	DCA T
	SZL
ERRORA,	HALT		/S T A C K   O V E R F L O W !
	TAD T
	CLL RAR
	BSW
	AND (70
	TAD (CDF STACKFIELD
	DCA XSDF	/SETUP CHANGE TO STACK FIELD INSTR.
	TAD T		/AND BUILD
	STL RAL
	STL RAL
	DCA T3		/ADDRESS OF TOP ENTRY (LS WORD)
	JMP I XBUMP

ST3,
ADDRESS,0		/COMPUTE FULL ADDRESS
	MQL		/OF STACK LOCATION
	MQA		/AND CHANGE DATA FIELD
	CLL RAR
	BSW
	AND (70
	TAD (CDF STACKFIELD
	DCA STCDF
	MQA
	STL RAL
	STL RAL
STCDF,	CDF STACKFIELD
	JMP I ADDRESS

PACK,	0		/PACK REAL OR INTEGER NUMBER
	TAD ACX		/INTO AC0-4 (FOR PUSHING)
	DCA AC0
	TAD ACS
	TAD AC1
	DCA AC1
	JMP I PACK

UNPACK,	0		/UNPACK POPPED NUMBER
	L4000		/(EXTRACT SIGN, EXPONENT)
	AND AC1
	DCA ACS
	L3777
	AND AC1
	DCA AC1
	TAD AC0
	DCA ACX
	DCA AC0
	JMP I UNPACK

XPOPONE,0
	SNA
	JMP TOPONE
	JMS ADDRESS
	DCA ST3
	TAD I ST3
	CDF
	JMP I XPOPONE
TOPONE,	SDF
	TAD I T3
	CDF
	JMP I XPOPONE

XPUSHONE,0
	SDF
	DCA I T3
	CDF
	JMP I XPUSHONE

XPOPVAL,0
	SNA
	JMP TOPVAL
	JMS ADDRESS
	TAD MIN4
	DCA XR10
	TAD I XR10
	DCA AC0
	TAD I XR10
	DCA AC1
	TAD I XR10
	DCA AC2
	TAD I XR10
	DCA AC3
	CDF
	JMP I XPOPVAL
TOPVAL,	TAD T3
	SDF
	JMP XPOPVAL+4

XPUSHVAL,0
	SNA
	JMP ONTOP
	JMS ADDRESS
	TAD MIN4
	DCA XR10
	TAD AC0
	DCA I XR10
	TAD AC1
	DCA I XR10
	TAD AC2
	DCA I XR10
	TAD AC3
	DCA I XR10
	CDF
	JMP I XPUSHVAL
ONTOP,	TAD T3
	SDF
	JMP XPUSHVAL+4

XPOPNUM,0
	JMS XPOPVAL
	JMS UNPACK
	JMP I XPOPNUM

XPUSHNUM,0
	MQL
	JMS PACK
	MQA
	JMS XPUSHVAL
	JMP I XPUSHNUM

XTOSTACK,0
	DCA PACK		/TEMP. SAVE VALUE
	TAD T3T
	JMS ADDRESS
	DCA ST3
	TAD PACK
	DCA I ST3
	CDF
	JMP I XTOSTACK

	PAGE
/TABLE INSTRUCTIONS

ZOFTAB,			/ AC :=  TAB[ AC ].REF
ZOFBTAB,0		/ AC := BTAB[ AC ].REF
	CLL RTL
	TAD I ZOFTAB	/SELECTOR FOLLOWS CALL
	DCA LOC
	ISZ ZOFTAB
	CDF TABLEFIELD
	TAD I LOC
	CDF
	JMP I ZOFTAB

ZOFATAB,0		/ AC := ATAB[ AC ].REF
	CLL RAL
	CLL RTL
	TAD I ZOFATAB	/SELECTOR FOLLOWS CALL
	DCA LOC
	ISZ ZOFATAB
	CDF TABLEFIELD
	TAD I LOC
	CDF
	JMP I ZOFATAB

ZOFDISP,0		/ AC := DISPLAY[ IRX ]
	TAD (DISPLAY
	TAD IRX
	DCA LOC
	TAD I LOC
	JMP I ZOFDISP

ZTODISP,0		/ DISPLAY[ IRX ] := AC
	MQL
	TAD (DISPLAY
	TAD IRX
	DCA LOC
	MQA
	DCA I LOC
	JMP I ZTODISP

XOFCODE,0		/ AC := CODE[ AC.LINK ]
	RAL		/LINK=0 ... 1ST WORD
	DCA LOC		/LINK=1 ... 2ND WORD
	CDF CODEFIELD
	TAD I LOC
	CDF
	JMP I XOFCODE

LOC,	0		/ADDRESS OF TABLE LOCATION

ZOFCONST,0		/ENTER WITH ADDRESS-1 IN AC
	DCA XR10
	CDF TABLEFIELD
	TAD I XR10
	DCA AC0
	TAD I XR10
	DCA AC1
	TAD I XR10
	DCA AC2
	TAD I XR10
	DCA AC3
	CDF
	JMP I ZOFCONST
/PREDEFINED   R A N D O M  - NUMBER GENERATOR

XRAND,	0
	TAD DISMOV	/DISABLE INTEGER-
	DCA INTMOV	/MULTIPLY-OVERFLOW
	AAAAAAAAAAAAAAAA
	GET INT&RN
	MUL INT&ALFA	/MOD 2^35 !
	PUT INT&RN
	NORM		/0 < RANDOM: REAL < 1
	EEEEEEEEEEEEEEEE
	TAD ENAMOV	/REENABLE
	DCA INTMOV
	BUMP
	JMP I XRAND

DISMOV,	DCA AC0
ENAMOV,	JMSSNAC

RN,	0000;3777;7777;7775	/2^35 - 3  (INTEGER)
ALFA,	0000;0000;0100;0003	/2^18 + 3  (INTEGER)


XODD,	0
	L0001
	AND AC3
	LOAD
	JMP I XODD


XSKDIG,	0	/SKIP ON DIGIT
	TAD CHAR
	TAD (-"9-1
	CLL
	TAD ("9+1-"0
	DCA BCD
	SZL CLA
	ISZ XSKDIG
	JMP I XSKDIG

XPRINT,	0		/INTERNAL PRINTER HANDLER
	SNA
	TAD CHAR
	TLS
	TSF
	JMP .-1
	TAD [-215
	SZA CLA
	JMP I XPRINT
	TAD [212
	JMP XPRINT+3

SPRINT,	0		/SILENT PRINTER
	CLA CLL
	JMP I SPRINT

XCRLF,	0		/CARRIAGE RETURN & LINE FEED
	TAD [215
	PRINTC
	JMP I XCRLF

XBREAK,	0		/CHECK  ^C  AND ABORT
	KSF
	JMP I XBREAK
	CLA
	KRS
	AND [177
	TAD (-3
	SZA CLA
	JMP I XBREAK
	JMP I OS8

	PAGE
/ A R I T H M E T I C   P A C K A G E

INTERPC,0000		/PROGRAM COUNTER FOR MACRO-INSTRUCTIONS
CPAGE,	7600
	SZA CLA
NEXTINSTR, ISZ INTERPC	/POINT TO NEXT INSTRUCTION
	TAD I INTERPC	/GET CODE
	SNA		/IF CODE=0000
	JMP I INTERPC	/THEN RETURN TO PDP8-MODE
	CLL RTL		/ELSE SHIFT CODE NXXX
	RTL
	AND (7		/TO EXTRACT OPERATION CODE N
	DCA OPCODE
	TAD I INTERPC	/GET CODE AGAIN,
	AND (177	/MASK OUT REL.ADDRESS (OR FUNCTION CODE)
	MQL
	TAD CPAGE
C200,	AND INTERPC	/CURRENT PAGE BITS
	MQA		/+ RELATIVE ADDRESS
	DCA OPADDR	/= ABS. ADDRESS OF OPERAND (IF MRI)
	SNL		/IF D\I-BIT SET
	JMP .+3
	TAD I OPADDR	/THEN DO INDIRECT ADDRESSING
	DCA OPADDR
	TAD OPCODE
	TAD (-7
	SNA CLA		/IF CODE=7XXX
	JMP OPRTYP	/THEN OPERATE CLASS INSTRUCTION
MRITYP,	TAD I OPADDR	/ELSE MEMORY REFERENCED INSTR.:
	DCA OPX		/LOAD AND UNPACK OPERAND
	ISZ OPADDR	/INTO OP-REGISTER
	L4000
	AND I OPADDR
	DCA OPS
	L3777
	AND I OPADDR
	DCA OP1
	ISZ OPADDR
	TAD I OPADDR
	DCA OP2
	ISZ OPADDR
	TAD I OPADDR
	DCA OP3
	TAD I INTERPC	/GET INSTRUCTION CODE AGAIN,
	AND C200	/CHECK INTEGER\REAL-BIT
	SZA CLA		/AND BUILD A
	TAD (7
	TAD OPCODE
	TAD (JMS I MRITABL
	DCA .+1
OPCODE,	JMS .		/ J M S   TO THE REQUESTED ROUTINE
	JMP NEXTINSTR
OPADDR,	0

/TABLE OF INTEGER ARITHMETIC ROUTINES:
MRITABL,OGET
	IADD
	ISUB
	IMUL
	IDIV
	IMOD
	OPUT

/TABLE OF REAL ARITHMETIC ROUTINES:
	OGET
	RADD
	RSUB
	RMUL
	RDIV
	OJUMP
	OPUT

OPRTYP,	TAD I INTERPC	/DECODE OPERATE INSTRUCTION
	SNL		/BIT3 IS IN LINK (COMPLEMENTED!)
	JMP SKIPTYP	/SKIP INSTR. CODES ARE 74XX, 75XX
	BSW		/OPERATE INSTR. CODES ARE:
	RTR		/7000 - 7006  (INTEGER)
	CLA MQA		/7200 - 7206  (REAL)
	AND (7		/EXTENDED FUNCTIONS:  70X7
	RAL
	TAD (JMS I OPRTABL
	DCA .+3
	TAD INTERPC	/SAVE PC, SINCE OPR'S MAY CAUSE
	DCA SAVEPC	/RECURSIVE CALL OF INTERPRETER (1 LEVEL)
OPRJMS,	JMS .		/ J M S   TO APPROPRIATE ROUTINE
	TAD SAVEPC	/RESTORE PC
	DCA INTERPC
	JMP NEXTINSTR
SAVEPC,	0

NOOP=OPCODE

/TABLE OF OPERATE CLASS INSTRUCTIONS:
OPRTABL,XABS;	RNORM
	IINP;	RINP
	IOUT;	ROUT
	IFLOAT;	RTRUNC
	XNEG;	CLAC
	XISQU;	XRSQU
	XCRLF;	XROUND
	NOOP		/LINK TO FUNCTION DISPATCH ROUTINE
IFDEF FUNCTS <
	*.-1
	FUNCTS		/ENABLED ONLY IF FUNCTION PACKAGE PRESENT
>

SKIPTYP,JMS BOOL	/ALL SKIP INSTR. (INT & REAL) DONE HERE
	ISZ INTERPC	/(SEE ROUTINE 'BOOL' FOR COMMENTS)
	JMP NEXTINSTR-1

OJUMP,	0		/JUMP (WITHIN MACRO CODE!!!)
	L7775
	TAD OPADDR
	DCA INTERPC
	JMP NEXTINSTR+1

OPUT,	0		/STORE CONTENTS OF AC-REGISTER
	L0004		/AT SPECIFIED MEMORY ADDRESS
	CIA		/-4 (OPADDR WAS MOVED AT MRITYP)
	TAD OPADDR
	DCA XR10
	TAD ACX
	DCA I XR10
	TAD ACS
	TAD AC1
	DCA I XR10
	TAD AC2
	DCA I XR10
	TAD AC3
	DCA I XR10
	JMP I OPUT

	PAGE
/R E A L   N U M B E R   I N P U T
/
/ACCEPTS A DECIMAL NUMBER IN ANY FORMAT,
/CONVERTS IT TO INTERNAL BYNARY FLOATING POINT NOTATION
/AND LEAVES IT IN THE AC-REGISTER.
/LEADING BLANKS ARE IGNORED; THE FIRST
/NON ACCEPTABLE CHARACTER TERMINATES THE NUMBER.

DC=MQ2		/DIGIT COUNTER
OC=MQ3		/DIGIT EXCESS COUNTER
DP,	0	/DECIMAL POINT POSITION

RINP,	RETNUM	/RETURN ADDR. SINCE COMPILER ENTERS AT 'FRACTN'
	SKP CLA
	READC		/PASS OVER LEADING BLANKS
	TAD CHAR
	TAD (-240
	SNA CLA
	JMP .-4
	JMS PMXXX	/PROCESS  + - I N T E G E R  PART
	TAD OC		/COUNT LOOSEN DIGITS (IF THE INTERNAL
	CIA		/REPRESENTATION EXCEEDS 35 BITS,
	DCA DC		/FURTHER DIGITS ARE IGNORED, BUT
	TAD CHAR	/THEIR CONTRIBUTION TO MAGNITUDE
	TAD (-".	/MUST BE CONSIDERED!)
	SZA CLA		/IF INTEGER FOLLOWED BY DECIMAL POINT
	JMP .+3
	READC
FRACTN,	JMS BCONV	/THEN PROCESS  F R A C T I O N  PART
	TAD DC		/COUNT DIGITS AFTER DEC. POINT
	CIA
	DCA DP		/TO REMEMBER POSITION OF DEC. POINT
	JMS IFLOAT	/NORMALIZE THE NUMBER
	TAD CHAR
	TAD (-"E
	SZA CLA		/IF NEXT CHARACTER IS "E"
	JMP ADJUST
	AAAAAAAAAAAAAAAA
	PUT NUMBUF	/THEN STORE NUMBER TEMPORARELY
	EEEEEEEEEEEEEEEE
	READC
	JMS PMXXX	/AND PROCESS  S C A L E - F A C T O R
	TAD ACS
	CLL RAL
	TAD AC3		/GET IT FROM LOW ORDER WORD OF AC
	SZL		/IF NEGATIVE SIGN
	CIA		/THEN USE 2'S COMPLEMENT
	TAD DP		/ADD IT TO CURRENT POS. OF DEC. POINT
	DCA DP
	AAAAAAAAAAAAAAAA
	GET NUMBUF	/RECALL STORED MANTISSA
	EEEEEEEEEEEEEEEE
ADJUST,	TAD DP		/NOW CONVERT DEC. FLOATING POINT TO
	JMS SUP1	/TO BINARY FLOATING POINT NOTATION
	JMP I RINP


PMXXX,	0		/SIGNED INTEGER INPUT & CONVERSION
	CLEAR
	DCA DC
	DCA OC
	TAD CHAR
	TAD (-"+
	SNA
	JMP .+6
	CLL RTR
	SZA CLA
	JMP .+4
	L4000
	DCA ACS
	READC
	JMS BCONV
	JMP I PMXXX

BCONV,	0		/UNSIGNED DIGIT STRING INPUT & CONVERSION
	SKDIG
	JMP I BCONV
	TAD AC0
	SZA CLA
	JMP OVER
	CLL
	JMS MUL10
	TAD BCD
	DCA OP3
	DCA OP2
	DCA OP1
	JMS BADD
	ISZ DC
	SKP
OVER,	ISZ OC
	READC
	JMP BCONV+1
/F L O A T   AND   T R U N C   ROUTINES


DISPLC=.
IFLOAT,	0		/COMPENSATE
	TAD (43		/35 BITS DISPLACEMENT OF BINARY POINT
	DCA ACX		/WITH EXPONENT
	JMS RNORM	/AND NORMALIZE
	JMP I IFLOAT

RTRUNC,	0
	CLA CLL
	TAD ACX
	SPA SNA		/IF ABS(AC)<1 OR AC=0
	JMP LESS0	/THEN TRUNC(AC):=0
	TAD MIN44
	DCA DISPLC	/-(DISPLACEMENT OF BINARY POINT + 1)
	SZL CLA		/IF ABS(AC)>MAXINT
	JMP ERROR2	  /THEN  O V E R F L O W
	SKP
	HALVE		  /ELSE ALIGN MANTISSA
	ISZ DISPLC
	JMP .-2
	DCA ACX		/EXP=0 FOR INTEGERS
	JMP I RTRUNC
LESS0,	CLA
	CLEAR
	JMP I RTRUNC

XROUND,	0
	L2000
	DCA OP1
	DCA OP2
	DCA OP3
	DCA OPX		/X>=0:
	TAD ACS		/ROUND(X) = TRUNC(X+0.5)
	DCA OPS		/X<0:
	JMS RADD	/ROUND(X) = TRUNC(X-0.5)
	JMS RTRUNC
	JMP I XROUND

	PAGE
/R E A L   N U M B E R   O U T P U T
/
/PRINTS FLOATING POINT NUMBER X (CONTENTS OF AC-REGISTER)
/IN THE FORMAT SPECIFIED BY THE PARAMETERS  M,N  (PAGE 0)
/PERFORMS LIKE THE PASCAL-STATEMENT
/		W R I T E ( X  :M  :N )


/M		/MINIMUM FIELD WIDTH
/N		/FRACTION LENGTH
S=MQ1		/-NUMBER OF LEADING BLANKS
P=MQ2		/-NUMBER OF DIGITS PRECEDING THE DEC. POINT
F=MQ3		/-NUMBER OF DIGITS FOLLOWING THE DEC. POINT


ROUT,	0
	JMS FLCONV	/BINARY TO DECIMAL FLOATING POINT
	JMS EXBCD	/EXTRACT BCD-DIGITS OF MANTISSA
	TAD N
	SPA SNA		/WHICH FORMAT REQUESTED?
	JMP FLOPNT
FIXPNT,	CIA		/ -99999.99999
	DCA F		/F:=-N
	TAD DEXP
	SPA		/IF DEXP>0
	CLA		   /THEN P:=-(DEXP+1)
	CMA		   /ELSE P:=-1
	DCA P
	L7776		/S:=-(M-N-P-2)
	TAD F
	TAD P
	TAD M
	CIA
	DCA S
	TAD S
	SMA CLA		/IF S>=0 THEN USE FLOATING POINT FORMAT
	JMP FLOPNT	/(NUMBER TOO LARGE FOR FIXED POINT!)
	L0002
	TAD N		/ROUNDUP WITH (N+DEXP+1)TH DIGIT
	TAD DEXP
	SPA SNA		/IF NOT WITHIN THE 11 DIGITS, THEN
	JMP .+3
	TAD (-13	/ROUNDUP WITH 11TH DIGIT
	SMA
	CLA
	TAD (13
	JMS UROUND
	JMP FIXPNT+2	/ROUNDED MANTISSA = 10, CHECK WIDTH!
	TAD DEXP	/BEGINNING AT DIGIT POS. NUMBUF+DEXP
	SMA		/OR NUMBUF IF NUMBER >= 1
	CLA
	JMS XOUT	/DO THE FIXED POINT OUTPUT
	JMP I ROUT


FLOPNT,	L7777		/ -9.999999999E+999
	DCA P		/P:=-1
	TAD M
	TAD (-12
	SPA
	CLA
	TAD (12
	DCA M		/IF M<10 THEN M:=10
	TAD (-11
	DCA F		/F:=-9
	TAD M		/S:=-(M-17)
	TAD (-21
	CIA
	DCA S
	TAD S
	SPA CLA		/IF S>=0 THEN
	JMP .+7
	L7777		/S:=-1
	DCA S		/F:=-(M-9)
	TAD M
	TAD (-11
	CIA
	DCA F
	L7776
	TAD F
	CIA
	JMS UROUND	/ROUNDUP WITH (-F+1)TH DIGIT
STFW,	0022		/NOP (CARRY DOESN'T HARM!)
	JMS XOUT	/OUTPUT THE MANTISSA
	TAD ("E
	PRINTC		/E
	TAD DEXP
	SPA CLA
	L0002
	TAD ("+
	PRINTC		/+ OR -
	TAD DEXP
	SPA
	CIA		/MAKE DEXP POSITIVE
	JMS LDAC	/LOAD IT IN AC-REGISTER (AS INTEGER)
	L0003
	DCA M		/SETUP A FIELD WIDTH OF 3,
	TAD ("0-240	/CHANGE LEADING BLANKS TO ZEROES
	JMS IOUT	/AND USE INTEGER OUTPUT ROUTINE
	TAD STFW	/TO PRINT THE CHARACTERISTIC.
	DCA M		/THEN RESET STANDARD FIELD WIDTH
	JMP I ROUT




/BUFFER FOR BCD-DIGITS:
	0		/IMPORTANT! (SEE ROUNDING)
NUMBUF,	ZBLOCK 13



TEN,	0004	/REAL CONSTANT OF 10.0
	2400
	0000
	0000

OPTEN,	7775	/REAL CONSTANT OF 0.1 (CURRENTLY NOT USED!)
	3146
	3146
	3146

LDAC,
CLAC,	0		/LOAD OR CLEAR AC-REGISTER
	DCA AC3
	DCA AC2
	DCA AC1
	DCA AC0
	DCA ACS
	DCA ACX
	JMP I CLAC

	PAGE
/REAL NUMBER OUTPUT - AUXILIARY ROUTINES

XDPOS=XR10	/AUTOINDEXING DIGITS
/DPOS=EXBCD	/SIMPLE POINTER TO DIGITS
/DIG0=DOUT	/NUMBUF-1 OR NUMBUF-2 (FIRST DIGIT OF MANTISSA)
DEXP=BCD	/DECIMAL CHARACTERISTIC OF X
DCNT=.		/DIGIT COUNTER

FLCONV,	0		/CONVERT X*2^ACX ---> Z*10^DEXP,
	DCA DEXP	/WITH 1<=Z<10:
	TAD AC1
	SNA CLA		/IF NUMBER=0 THEN NO CONVERSION NECESSARY!
	JMP I FLCONV
	JMS SUP2	/DO SUPER CONVERSION
FLCLP,	TAD DEXP
	DCA DEXP
	TAD ACX
	SPA SNA		/NOTE INTERNAL BINARY NOTATION:
	JMP SMALL
	TAD (-4		/ 1 ..... 0.1000B+1
	SPA		/10 ..... 0.1010B+4
	JMP .+5
	SZA CLA
	JMP LARGE
	TAD AC1		/HIGH ORDER WORD FOR 10
	TAD (-2400	/IS 2400 OCTAL!
	SPA CLA
	JMP I FLCONV
LARGE,	AAAAAAAAAAAAAAAA
	DIV TEN		/:10   (OR 'MUL OPTEN'   *0.1)
	EEEEEEEEEEEEEEEE
	L0001
	JMP FLCLP
SMALL,	AAAAAAAAAAAAAAAA
	MUL TEN		/*10
	EEEEEEEEEEEEEEEE
	L7777
	JMP FLCLP

DPOS=.
EXBCD,	0		/EXTRACT BCD-DIGITS OF MANTISSA
	TAD ACX
	CMA
	DCA DCNT
	STL		/(MIGHT CORRECT ILL 11TH DEC. DIGIT!)
	DOUBLE		/SHIFT OUT FIRST DIGIT
	ISZ DCNT
	JMP .-3
	TAD (NUMBUF-1
	DCA XDPOS
	TAD (-12	/10 DIGITS REMAINING
	DCA DCNT
	DCA I (NUMBUF-1	/LEADING 0 FOR ROUNDING CARRY
	SKP
	JMS MUL10
	TAD AC0
	DCA I XDPOS
	DCA AC0
	ISZ DCNT
	JMP .-5
	TAD (NUMBUF-1	/POINT TO FIRST DIGIT
	DCA DIG0
	JMP I EXBCD

UROUND,	0		/ROUNDUP. ENTRY WITH DIGIT NO.
	TAD DIG0	/WHERE TO START ROUNDING
	DCA DPOS	/IN HARDWARE AC
	TAD (5
CARRY,	TAD (-12
	TAD I DPOS
	SPA CLA
	JMP OVR10
	DCA I DPOS
	L7777
	TAD DPOS
	DCA DPOS
	ISZ I DPOS
	JMP CARRY
OVR10,	TAD DIG0
	CIA
	TAD DPOS
	SZA CLA		/CARRY TO A NEW FIRST DIGIT?
	JMP SKIPEX	/NO
	L7777
	TAD DIG0
	DCA DIG0
	ISZ DEXP
	JMP I UROUND	/MANTISSA=10 EXIT
SKIPEX,	ISZ UROUND	/NORMAL EXIT
	JMP I UROUND

XOUT,	0		/OUTPUT. ENTRY WITH DIGIT NO.
	TAD DIG0	/WHERE TO START PRINTING
	DCA XDPOS	/IN HARDWARE AC
	TAD (240
	PRINTC		/  -(S) BLANKS
	ISZ S
	JMP .-3
	TAD ACS
	SPA CLA
	TAD ("--240
	TAD (240
	PRINTC		/  THE SIGN (- OR BLANK)
	JMS DOUT	/  -(P) DIGITS (OR ZERO)
	ISZ P
	JMP .-2
	TAD (".		/  THE DECIMAL POINT
	PRINTC
	JMS DOUT	/  -(F) DIGITS (OR ZEROES)
	ISZ F
	JMP .-2
	JMP I XOUT

DIG0=.
DOUT,	0		/IF XDPOS POINTS INTO BUFFER
	TAD XDPOS	/THEN PRINT THE DIGIT
	TAD (-NUMBUF-12	/ELSE PRINT A ZERO
	CLL
	TAD (14
	CLA
	TAD I XDPOS
	SNL
	CLA
	TAD ("0
	PRINTC
	JMP I DOUT

	PAGE
/R E A L   A R I T H M E T I C
/
/RADD:		AC:=AC+OP
/RSUB:		AC:=AC-OP
/RMUL:		AC:=AC*OP
/RDIV:		AC:=AC/OP
/
/RNORM:		NORMALIZE AC TO STANDARD FLOATING POINT FORMAT


RADD,	0
	TAD OP1
	SNA CLA		/IF OP=0 THEN DON'T WASTE TIME!
	JMP I RADD
	TAD AC1
	SNA CLA		/IF AC=0 THEN SIMPLY ADD!
	JMP OPMAX
	TAD ACX		/COMPARE MAGNITUDE OF OPERANDS
	CIA		/AND STORE NEGATIVE DIFFERENCE
	TAD OPX
	SMA
	JMP OPMAX
	DCA RDIV	/TO USE AS SHIFT COUNTER
ACMAX,	TAD OP1		/1/ ABS(AC)>ABS(OP) ---> SHIFT OP RIGHT
	CLL RAR
	DCA OP1
	TAD OP2
	RAR
	DCA OP2
	TAD OP3
	RAR
	DCA OP3
	ISZ RDIV
	JMP ACMAX
	JMP SETSGN
OPMAX,	CMA		/2/ ABS(OP)>=ABS(AC)
	DCA RDIV
	TAD OPX		/RESULT IS OF MAGNITUDE OF OP
	DCA ACX
	SKP
	HALVE		/SHIFT AC RIGHT
	ISZ RDIV
	JMP .-2
SETSGN,	JMS OADD	/MANTISSAS NOW ALIGNED! - ADD.
	JMS RNORM	/NORMALIZE RESULT
	JMP I RADD

RSUB,	0
	JMS OSUB	/OP:=-OP
	JMS RADD	/AC:=AC+(-OP)
	JMP I RSUB
OSUB,	0
	L4000
	TAD OPS
	DCA OPS
	JMP I OSUB

RMUL,	0
	TAD OP1
	SNA CLA
	JMS CLAC
	TAD AC1
	SNA CLA		/IF OP=0 OR AC=0
	JMP I RMUL	/THEN DON'T WASTE TIME!
	DCA MQ1
	DCA MQ2		/CLEAR MQ-REGISTER (FOR 'BMUL')
	DCA MQ3
	TAD OPS		/SETUP SIGN OF PRODUCT
	TAD ACS
	DCA ACS
	L7777
	TAD OPX		/COMPUTE EXPONENT OF PRODUCT
	TAD ACX
	DCA ACX
	L0001
	JMS BMUL	/MULTIPLY MANTISSAS
	JMS RNORM
	JMP I RMUL

RDIV,	0
	TAD OP1
	SNA CLA
ERROR0,	HALT		/D I V I S I O N  BY  Z E R O !
	DCA MQ1
	DCA MQ2		/CLEAR MQ-REGISTER (FOR 'BDIV')
	DCA MQ3
	TAD OPS		/SETUP SIGN OF QUOTIENT
	TAD ACS
	DCA ACS
	TAD OPX		/COMPUTE EXPONENT OF QUOTIENT
	CIA
	TAD ACX
	DCA ACX
	JMS BDIV	/DIVIDE MANTISSAS
	JMS RNORM
	JMP I RDIV

RNORM,	0
	CLA CLL
TOOBIG,	TAD AC1
	AND (4000	/(NO 'L4000' BECAUSE OF LINK!)
	TAD AC0
	SNA CLA		/WHILE MANTISSA TOO BIG (>=1)
	JMP ROUNDUP
	HALVE		     /HALVE IT (SHIFT RIGHT)
	ISZ ACX		     /AND CORRECT THE EXPONENT (+1)
	NOP
	JMP TOOBIG
ROUNDUP,SZL		/IF A BINARY 1 WAS SHIFTED OUT
	ISZ AC3		/THEN ROUND MANTISSA
	JMP NULLAC
	ISZ AC2
	JMP NULLAC
	ISZ AC1		/(CAN'T SKIP!)
	JMP RNORM+1
NULLAC,	JMS SNAC	/CHECK FOR NULL MANTISSA
	JMP ISNULL
TOOSMALL,L2000
	AND AC1
	SZA CLA		/WHILE MANTISSA TOO SMALL (<0.5)
	JMP ISNULL+1
	DOUBLE		     /DOUBLE IT (SHIFT LEFT)
	L7777		     /AND CORRECT THE EXPONENT (-1)
	TAD ACX
	DCA ACX
	JMP TOOSMALL
ISNULL,	JMS CLAC
	L2000		/CHECK FOR OVER- OR UNDERFLOW
	TAD ACX
	SMA CLA
	JMP I RNORM	/OKAY!
	TAD ACX
	SPA CLA
ERROR1,	HALT		/U N D E R F L O W !
ERROR2,	HALT		/O V E R F L O W !

	PAGE
/I N T E G E R   I N P U T  AND  O U T P U T
/
/

/M		/MINIMUM FIELD WITH
DI,	0	/-NUMBER OF DIGITS TO PRINT
SI,	0	/-NUMBER OF LEADING BLANKS
LDBLANK,240	/OR OTHER LEADING CHARACTER
NEGATIV,0	/IF NUMBER NEGATIVE THEN -1 ELSE 0

IINP,	0
	SKP CLA
	READC		/IGNORE LEADING BLANKS
	TAD CHAR
	TAD (-240
	SNA CLA
	JMP .-4
	JMS PMXXX	/INPUT +-0123456789 AND CONVERT TO BINARY
	JMS INORM	/CHECK OVERFLOW (MAXINT=34359738367)
	JMP I IINP

PTD=IINP

IOUT,	0
	TAD [240	/KLUDGE! CHOOSE THE LEADING CHARACTER
	DCA LDBLANK	/WITH A TAD (XXX-240 BEFORE CALLING IOUT
	TAD ACS
	SPA CLA
	L7777
	DCA NEGATIV
	TAD (NUMBUF+12
	DCA PTD		/POINT TO RIGHTMOST POS. OF BUFFER
	DCA I PTD	/STORE A 0 CASE NUMBER=0
DECONV,	JMS SNAC
	JMP OFORM
	L7777
	TAD PTD		/DECREMENT POINTER
	DCA PTD
	AAAAAAAAAAAAAAAA
	DIV INT&IO	/AC:=AC DIV 10
	EEEEEEEEEEEEEEEE
	TAD MQ3
	CLL RAR		/GET REST OF ABOVE DIVISION
	JMP DECONV-1	/AND STORE AS BCD-DIGIT
OFORM,	TAD (-NUMBUF-12
	TAD PTD
	SMA
	L7777		/AT LEAST ONE DIGIT TO PRINT (THINK OF 0)
	DCA DI		/DI:=-NUMBER OF DIGITS
	TAD NEGATIV	/TAKE ACCOUNT OF EV. - SIGN
	TAD M
	TAD DI
	SPA		/IF FIELD WIDTH < NO. OF DIGITS
	CLA		   /THEN SI:=-1
	CMA		   /ELSE SI:=-(FIELD WIDTH - DIGITS) - 1
	DCA SI
	JMP .+3
LDCHAR,	TAD LDBLANK
	PRINTC		/LEADING BLANKS
	ISZ SI
	JMP LDCHAR
EVMINS,	ISZ NEGATIV
	JMP ODIGS
	TAD ("-
	PRINTC		/MINUS SIGN (IF ANY)
ODIGS,	TAD I PTD
	ISZ PTD
	TAD ("0
	PRINTC		/DIGIT STRING
	ISZ DI
	JMP ODIGS
	JMP I IOUT

INORM,	0		/INTEGER CLEARING HOUSE ROUTINE
	L4000
	AND AC1
	TAD AC0
	SZA CLA		/IF AC0<>0 OR AC1>3777 THEN
	JMP ERROR2	/O V E R F L O W
	JMS SNAC
	DCA ACS		/DON'T FORGET THE -0 PROBLEM!
	JMP I INORM

IO,	0000	/INTEGER CONSTANT OF 10
	0000
	0000
	0012
/VARIOUS SECONDARY ROUTINES:

XABS,	0		/AC:=ABS(AC)
	DCA ACS
	JMP I XABS

XNEG,	0		/AC:=-AC (REAL AND INTEGER)
	L4000
	TAD ACS
	DCA ACS
	JMS INORM	/BUT NOT AC:=-0 !
	JMP I XNEG

OGET,	0		/COPY CONTENTS OF
	DCA AC0		/OP-REGISTER INTO AC-REGISTER
	TAD OP1		/(AC0 IS CLEARED!)
	DCA AC1
	TAD OP2
	DCA AC2
	TAD OP3
	DCA AC3
	TAD OPS
	DCA ACS
	TAD OPX
	DCA ACX
	JMP I OGET

ENTR,	0		/COPY CONTENTS OF
	TAD AC1		/AC-REGISTER INTO OP-REGISTER
	DCA OP1		/(AC0 UNCHANGED!)
	TAD AC2
	DCA OP2
	TAD AC3
	DCA OP3
	TAD ACS
	DCA OPS
	TAD ACX
	DCA OPX
	JMP I ENTR

BOOL,	0		/ENTER WITH SKIP-INSTRUCTION
	DCA OSKIP	/IN HARDWARE AC
	JMS SNAC
	SKP
	L0001
	TAD ACS
OSKIP,	0000
	SKP CLA
	L0001
	JMP I BOOL	/EXIT WITH HARDWARE AC=1 IF TRUE (SKIP)
			/OR		    AC=0 IF FALSE 

	PAGE
/I N T E G E R   A R I T H M E T I C
/
/IADD:		AC:=AC+OP
/ISUB:		AC:=AC-OP
/IMUL:		AC:=AC*OP
/IDIV:		AC:=AC DIV OP
/IMOD:		AC:=AC MOD OP


IADD,	0
	JMS OADD
	JMS INORM
	JMP I IADD
OADD,	0
	TAD ACS
	TAD OPS
	SNA CLA		/IF BOTH OPERANDS HAVE THE SAME SIGN
	JMP SAMESGN	/THEN SIMPLY ADD THEM
	JMS CMOP	/ELSE COMPLEMENT ONE OF THEM (OP)
	JMS BADD	/AND ADD
	TAD AC1		/BUT TAKE CARE:
	SMA CLA		/IF RESULT POSITIVE (IN 2'S COMPLEMENT)
	JMP .+4		/THEN OKAY
	JMS CMAC	/ELSE COMPLEMENT AC
	TAD OPS		/AND USE SIGN OF OP
	DCA ACS
	DCA AC0		/NO OVERFLOW IN THIS CASE!
	JMP I OADD
SAMESGN,JMS BADD
	JMP I OADD

ISUB,	0
	JMS OSUB	/OP:=-OP
	JMS IADD	/AC:=AC+(-OP)
	JMP I ISUB

IMUL,	0
	JMS SNOP	/IF OP=0
	CLEAR		/THEN PRODUCT IS 0
	DCA MQ1
	DCA MQ2		/CLEAR MQ-REGISTER (BMUL NEEDS THAT!)
	DCA MQ3
	TAD OPS		/SETUP SIGN OF PRODUCT
	TAD ACS
	DCA ACS
	JMS BMUL	/MULTIPLY
INTMOV,	JMS SNAC	/IF HIGH ORDER WORDS OF PRODUCT <>0
	SKP
	JMP ERROR2	/THEN  O V E R F L O W !
	JMS SWAP	/GET LOW ORDER PART INTO AC
	HALVE		/(BMUL GIVES 2*PRODUCT!)
	JMS INORM
	JMP I IMUL


MODSGN=IMUL

IDIV,	0
	JMS SNOP
	JMP I [ERROR0	/D I V I S I O N  BY  Z E R O !
	DOUBLE
	JMS SWAP	/PUT 2*DIVIDEND INTO MQ-REGISTER
	DCA AC1		/AND CLEAR AC (SEE BDIV INSTRUCTIONS)
	DCA AC2
	DCA AC3
	TAD OPS		/SETUP SIGN OF QUOTIENT
	TAD ACS
	DCA ACS
	TAD ACS		/PATCH:  SERVES
	DCA MODSGN	/FOR MOD-FUNCTION
	JMS BDIV	/DIVIDE
	JMS INORM
	JMP I IDIV

IMOD,	0
	JMS IDIV	/DIVIDE OP INTO AC
	JMS SWAP	/GET 2*REST FROM MQ-REGISTER
	HALVE		/AND HALVE IT (SEE BDIV INSTR.)
	TAD MODSGN
	SPA CLA		/IF REST NOT NEGATIVE
	JMS SNAC
	JMP MODOK	/THEN OKAY
	JMS BADD	/ELSE ADD OP TO MAKE IT POSITIVE
	JMS CMAC	/MORE PRECISELY: AC:=-(AC-OP)
MODOK,	DCA ACS		/SIGN IS +
	DCA AC0
	JMP I IMOD
/FOUR SECONDARY ROUTINES:

SNAC,	0	/SKIP ON NONZERO AC
	TAD AC3
	SNA
	TAD AC2
	SNA
	TAD AC1
	SZA CLA
	ISZ SNAC
	JMP I SNAC

SNOP,	0	/SKIP ON NONZERO OP
	TAD OP3
	SNA
	TAD OP2
	SNA
	TAD OP1
	SZA CLA
	ISZ SNOP
	JMP I SNOP

CMAC,	0	/2'S COMPLEMENT OF AC
	CLA CLL
	TAD AC3
	CIA
	DCA AC3
	TAD AC2
	CMA
	SZL
	IAC CLL
	DCA AC2
	TAD AC1
	CMA
	SZL
	IAC CLL
	DCA AC1
	JMP I CMAC

CMOP,	0	/2'S COMPLEMENT OF OP
	CLA CLL
	TAD OP3
	CIA
	DCA OP3
	TAD OP2
	CMA
	SZL
	IAC CLL
	DCA OP2
	TAD OP1
	CMA
	SZL
	IAC CLL
	DCA OP1
	JMP I CMOP

JMSSNAC=JMS SNAC

	PAGE


/B I N A R Y   A D D I T I O N
/
/AC0!AC1!AC2!AC3 := AC1!AC2!AC3 +  OP1!OP2!OP3

TEMP3=.

BADD,	0
	CLA CLL
	TAD AC3
	TAD OP3
	DCA AC3
	RAL
	TAD AC2
	TAD OP2
	DCA AC2
	RAL
	TAD AC1
	TAD OP1
	DCA AC1
	RAL
	TAD AC0
	DCA AC0
	JMP I BADD




/B I N A R Y   M U L T I P L I C A T I O N
/
/OP=FACTOR
/FLOATING POINT: AC=FACTOR, MQ=0;    AC=PRODUCT (HIGH ORDER)
/INTEGER:        AC=FACTOR, MQ=0;    MQ=2*PRODUCT (LOW ORDER)

BMUL,	0
	TAD MIN44	/-36
	DCA BDIV
	JMS SWAP
MULLP,	JMS RACR
	TAD MQ1
	RAR
	DCA MQ1
	TAD MQ2
	RAR
	DCA MQ2
	TAD MQ3
	RAR
	DCA MQ3
	SZL
	JMS BADD
	ISZ BDIV
	JMP MULLP
	JMP I BMUL
/B I N A R Y   D I V I S I O N
/
/OP=DIVISOR
/FLOATING POINT: AC=DIVIDEND, MQ=0;     AC=QUOTIENT
/INTEGER:        AC=0, MQ=2*DIVIDEND;   AC=QUOTIENT, MQ=2*REST

BDIV,	0
	TAD MIN44	/-36
	DCA BMUL
	JMS CMOP
DIVLP,	CLL		/COMPARE AC AND OP
	TAD AC3
	TAD OP3
	DCA TEMP3	/SAVE DIFFERENCE
	RAL
	TAD AC2
	TAD OP2
	DCA TEMP2
	RAL
	TAD AC1
	TAD OP1
	SNL		/AC > OP?
	JMP .+6
	DCA AC1		/YES, SETUP DIFFERENCE
	TAD TEMP2
	DCA AC2
	TAD TEMP3
	DCA AC3
	CLA
	TAD MQ3		/SHIFT IN NEW BIT OF QUOTIENT
	RAL		/AND DOUBLE DIVIDEND
	DCA MQ3
	TAD MQ2
	RAL
	DCA MQ2
	TAD MQ1
	RAL
	DCA MQ1
	JMS RACL
	ISZ BMUL
	JMP DIVLP
	JMS SWAP
	JMP I BDIV
/OTHER BINARY OPERATIONS:



MUL2,
RACL,	0		/SHIFT AC ONE BIT LEFT (=DOUBLE)
	TAD AC3		/TAKE CARE OF LINK CALLING RACL!!!
	RAL
	DCA AC3
	TAD AC2
	RAL
	DCA AC2
	TAD AC1
	RAL
	DCA AC1
	TAD AC0
	RAL
	DCA AC0
	JMP I RACL


	TEMP2=.

MUL10,	0		/AC TIMES 10
	JMS ENTR	/LINK MUST BE 0 ON ENTRY!!!
	JMS MUL2
	JMS MUL2
	JMS BADD
	JMS MUL2
	JMP I MUL10




RACR,	0		/SHIFT AC ONE BIT RIGHT (=HALVE)
	TAD AC0
	CLL RAR
	DCA AC0
	TAD AC1
	RAR
	DCA AC1
	TAD AC2
	RAR
	DCA AC2
	TAD AC3
	RAR
	DCA AC3
	JMP I RACR








SWAP,	0		/SWAP AC- AND MQ-REGISTER
	TAD AC1
	MQL
	TAD MQ1
	DCA AC1
	TAD AC2
	SWP
	DCA MQ1
	TAD MQ2
	DCA AC2
	TAD AC3
	SWP
	DCA MQ2
	TAD MQ3
	DCA AC3
	MQA
	DCA MQ3
	JMP I SWAP

	PAGE
/ A R I T H M E T I C   P A C K A G E
/OPTION:
/ S U P E R   C O N V E R S I O N   O V E R L A Y


/POWERS OF TEN TABLE:

P1E1,	0004;2400;0000;0000	/ 1.0E+001
	0007;3100;0000;0000	/ 1.0E+002
	0016;2342;0000;0000	/ 1.0E+004
	0033;2765;7020;0000	/ 1.0E+008
	0066;2160;6744;6770	/ 1.0E+016
	0153;2356;1326;6501	/ 1.0E+032
	0325;3023;6017;5120	/ 1.0E+064
	0652;2235;6443;7114	/ 1.0E+128
P1E256,	1523;2523;7565;7735	/ 1.0E+256
	3245;3430;6320;2565	/ 1.0E+512  (SERVES AS A GUARD)

P1E2N,	0		/POINTER INTO TABLE
DECP,	0		/DECIMAL CHARACTERISTIC
/DEXP=BCD		/ --- " --- (SEE 'FLCONV')

SUP1,	0		/INPUT CONVERSION (OVERLAYS 'ADJUST')
	SPA		/IF DECIMAL CHARACTERISTIC >= 0
	JMP .+4
	DCA DECP	  /THEN STORE AS IT IS
	TAD (MUL P1E1	       /AND SETUP FOR MULTIPLY
	JMP .+4		       /WITH POWERS OF 10
	CIA
	DCA DECP	  /ELSE MAKE IT POSITIVE
	TAD (DIV P1E1	       /AND SETUP FOR DIVIDE
	DCA MD1E2N	       /BY POWERS OF 10
ADJLP,	TAD DECP
	SNA		/WHILE DECP<>0 DO:
	JMP I SUP1
	CLL RAR		/DECP:=DECP DIV 2
	DCA DECP
	SNL		/IF DECP WAS ODD
	JMP .+4
	AAAAAAAAAAAAAAAA
MD1E2N,	MUL .		/THEN MULTIPLY WITH (DIVIDE BY) 1.0E+2N
	EEEEEEEEEEEEEEEE
	L0004
	TAD MD1E2N	/POINT TO NEXT POWER OF TEN
	DCA MD1E2N
	JMP ADJLP


SUP2,	0		/OUTPUT CONVERSION (OVERLAYS 'FLCONV')
	AAAAAAAAAAAAAAAA
	PUT XAC		/SAVE NUMBER IN AC
	EEEEEEEEEEEEEEEE
	TAD XAC		/GET BINARY EXPONENT
	SPA		/(2'S COMPLEMENT!)
	CIA		/AND LOAD IT AS POSITIVE INTEGER
	LOAD		/INTO AC-REGISTER
	AAAAAAAAAAAAAAAA/NOTE: LG(2) IS APPROXIMATED BY 1233/4096
	MUL INT&O1233	/*1233
	EEEEEEEEEEEEEEEE
	L4000
	AND XAC
	CLL RAL
	TAD AC2		/DIV 4096
	SZL		/IF XAC<0
	CMA		   /THEN DEXP := -XAC*1233 DIV 4096  -  1
	DCA DEXP	   /ELSE DEXP :=  XAC*1233 DIV 4096
	AAAAAAAAAAAAAAAA
	GET XAC		/RESTORE NUMBER
	EEEEEEEEEEEEEEEE
	TAD DEXP
	CIA
	JMS SUP1	/DO CONVERSION TO DECIMAL FLOATING POINT
	JMP I SUP2

XAC,	ZBLOCK 4
O1233,	0000;0000;0000;2321	/1233 (INTEGER)


TRUEFALSE, TEXT /TRUEFALSE/


XISQU,	0		/AC := AC^2 (INTEGER)
	JMS ENTR
	JMS IMUL
	JMP I XISQU

XRSQU,	0		/AC := AC^2 (REAL)
	JMS ENTR
	JMS RMUL
	JMP I XRSQU

	PAGE

/**********************
/ S Q U A R E   R O O T
/
/ AC := SQRT(AC)
/**********************


XSQRT,	0
	TAD ACS
	SPA CLA
ERROR3,	HALT		/SQUARE ROOT OF  N E G A T I V E  NUMBER!
	TAD AC1
	SNA CLA
	JMP I XSQRT	/DON'T WASTE TIME FOR SQRT(0)!
	L0001
	TAD ACX		/TRANSFORM ARGUMENT TO THE FORM
	SPA SZL		/ 2^(2*N) * F  WITH  0.25 <= F < 1
	CML
	RAR
	DCA ROOTX	/SAVE N
	SNL		/IF ODD(EXPONENT)
	L7777		   /THEN ACX:=-1    (0.25 <= F < 0.5)
	DCA ACX		   /ELSE ACX:= 0    (0.5  <= F <  1 )
	AAAAAAAAAAAAAAAA
	PUT SQARG	/SAVE F
	EEEEEEEEEEEEEEEE
	TAD ACX		/COMPUTE INITIAL VALUE X0 FOR NEWTON:
	DCA OPOINT5	/X0:=F + 0.25	(0.25 <= F < 0.5)
	L7777		/X0:=F/2 + 0.5	(0.5  <= F <  1 )
	DCA ACX
	AAAAAAAAAAAAAAAA
	ADD OPOINT5
	EEEEEEEEEEEEEEEE
	L7775		/3 ITERATION LOOPS GUARANTEE
	DCA NEWTON	/FULL PRECISION! (MAX. ERROR: 8.0E-13)
SQLOOP,	AAAAAAAAAAAAAAAA
	PUT X123
	GET SQARG
	DIV X123
	ADD X123	/X[I+1] := (F/X[I] + X[I])/2
	EEEEEEEEEEEEEEEE
	L7777		/HALVE BY ACX:=ACX - 1
	TAD ACX
	DCA ACX
	ISZ NEWTON	/IF DONE 3 LOOPS
	JMP SQLOOP
	TAD ROOTX	/THEN INSERT EXPONENT N OF ROOT
	TAD ACX
	DCA ACX
	JMP I XSQRT

NEWTON=.	/LOOP COUNTER
OPOINT5,0000	/CONSTANT OF 0.5 OR 0.25 (EXPONENT WORD
	2000	/SET AT EXECUTION TIME)
	0000
	0000
SQARG,	0	/REDUCED ARGUMENT F
	0
	0
	0
X123,	0	/TEMPORARY FOR APPROXIMATE VALUE
	0
	0
	0
ROOTX,	0	/TEMPORARY FOR ROOT EXPONENT N

/**********************************
/ N A T U R A L   L O G A R I T H M
/
/ AC := LN(AC)
/**********************************


/TABLE OF CONSTANTS:

A0,	0001	/1.84375
	3540
	0000
	0000

LNA0,	0000	/0.611801541106
	2344
	7603
	2325

A1,	0001	/1.65625
	3240
	0000
	0000

LNA1,	0000	/0.504556010752
	2011
	2512
	4551

A2,	0001	/1.5
	3000
	0000
	0000

LNA2,	7777	/0.405465108108
	3174
	6217
	5457

A3,	0001	/1.375
	2600
	0000
	0000

LNA3,	7777	/0.318453731119
	2430
	3057
	0207

A4,	0001	/1.25
	2400
	0000
	0000

LNA4,	7776	/0.223143551314
	3443
	7737
	0746

A5,	0001	/1.1875
	2300
	0000
	0000

LNA5,	7776	/0.171850256927
	2577
	6301
	6051

A6,	0001	/1.09375
	2140
	0000
	0000

LNA6,	7775	/0.0896121586897
	2674
	1512
	1271

A7,	0001	/1.03125
	2040
	0000
	0000

LNA7,	7773	/0.0307716586668
	3740
	5154
	1636


	PAGE

XLOG,	0
	TAD ACS
	TAD AC1
	SPA SNA CLA
ERROR4,	HALT		/LOGARITHM OF ZERO OR NEGATIVE NUMBER!
	AAAAAAAAAAAAAAAA
	PUT LNARG	/SAVE ARGUMENT  X = 2^N * F
	EEEEEEEEEEEEEEEE
	DCA LNARG	/REDUCE TO FRACTION PART (0.5 <= F < 1)
	CLL
	TAD ACX		/GET N  (IN TWO'S COMPLEMENT!)
	SPA
	CIA STL
	JMS LDAC	/LOAD IT AS INTEGER
	RAR
	DCA ACS
	AAAAAAAAAAAAAAAA
	FLOAT		/CONVERT TO REAL
	MUL LN2		/TIMES LN(2)
	PUT LNTEMP	/AND SAVE IT
	EEEEEEEEEEEEEEEE
LNLOOP,	TAD LNARG+1	/FOR FURTHER REDUCTION OF THE ARGUMENT
	AND BIT234	/SELECT THE APPROPRIATE MULTIPLIERS A(K)
	CLL RTR		/AND THEIR LOGARITHMS FROM  A TABLE,
	RTR		/ACCORDING TO THE RANGE OF  F.
	TAD (A0
	DCA PTAK
	L0004
	TAD PTAK
	DCA PTLNAK
	AAAAAAAAAAAAAAAA
	GET LNTEMP
	SUB I PTLNAK	/SUBTRACT LN( A(K) ) TO COMPENSATE
	PUT LNTEMP
	GET I PTAK	/THE MULTIPLICATION WITH A(K)
	MUL LNARG	/F' = A(K)* .... *F
	PUT LNARG
	EEEEEEEEEEEEEEEE
	TAD ACX
	SNA CLA
	JMP LNLOOP	/IT IS GUARANTEED, THAT AFTER NO MORE
	AAAAAAAAAAAAAAAA/THAN  T H R E E E  MULTIPLICATIONS
	SUB ONEPT0	/F' FITS IN THE RANGE
	PUT LNARG	/    0 <= F'-1 < 2^(-5)
	MUL LTC6	/NOW COMPUTE LN(F') VIA TAYLOR SERIES
	ADD LTC5
	MUL LNARG
	ADD LTC4
	MUL LNARG
	ADD LTC3
	MUL LNARG
	ADD LTC2
	MUL LNARG
	ADD ONEPT0
	MUL LNARG
	ADD LNTEMP	/LN(X) = N*LN(2) - LN(A(K)) ... + LN(F')
	EEEEEEEEEEEEEEEE
	JMP I XLOG

BIT234,	1600		/MASK TO EXTRACT BITS 00XXX0000000
PTAK,	A0		/POINTER INTO TABLE
PTLNAK,	LNA0		/  --- " ---

LNARG,	0	/ARGUMENT REGISTER
	0
	0
	0

LNTEMP,	0	/TEMPORARY
	0
	0
	0

LN2,	0000	/0.69314718
	2613
	4413
	7676

LTC6,	7776	/  -1/6
	6525
	2525
	2525

LTC5,	7776	/   1/5
	3146
	3146
	3146

LTC4,	7777	/  -1/4
	6000
	0000
	0000

LTC3,	7777	/   1/3
	2525
	2525
	2525

LTC2,	0000	/  -1/2
	6000
	0000
	0000

/****************************************
/ E X P O N E N T I A L   F U N C T I O N
/
/ AC := EXP(AC)
/****************************************


ONEPT0,
EX0B8,	0001	/ 2^(0/8) = 1
	2000
	0000
	0000

EX1B8,	0001	/ 2^(1/8)
	2134
	5340
	7437

EX2B8,	0001	/ 2^(2/8)
	2301
	5770
	1214

EX3B8,	0001	/ 2^(3/8)
	2457
	7553
	2515

EX4B8,	0001	/ 2^(4/8)
	2650
	1171
	4637

EX5B8,	0001	/ 2^(5/8)
	3053
	1625
	0212

EX6B8,	0001	/ 2^(6/8)
	3272
	1176
	3126

EX7B8,	0001	/ 2^(7/8)
	3526
	0143
	3476


	PAGE



XEXP,	0
	DCA TWO2N
	TAD (ONEPT0
	DCA TWO2M8
	AAAAAAAAAAAAAAAA
	SKNE
	JMP EXP0	/EXP(0)=1
	MUL LOG2E	/X*LB(2) .... EXP(X) =  2^(X*LB(2))
	PUT EXTEMP
	TRUNC		/SPLIT PRODUCT INTO
	PUT INT&TWO2N-3	/INTEGER PART  N
	FLOAT
	SUB EXTEMP	/AND FRACTION  F  (0 <= F < 1)
	NEGATE
	SKLT
	JMP .+7
	ADD ONEPT0
	EEEEEEEEEEEEEEEE
	TAD TWO2N
	CMA
	DCA TWO2N
	AAAAAAAAAAAAAAAA
	SKNE
	JMP EXP0
	EEEEEEEEEEEEEEEE
	L0003
	TAD ACX
	SPA SNA		/IF  F>=1/8 THEN SPLIT F INTO
	JMP APPROX
	CMA CLL		/ M/8 + R  (0 < M < 8,  0 <= R < 1/8)
	DCA EXREST
	DOUBLE
	ISZ EXREST
	JMP .-2
	TAD AC0
	CLL RTL
	TAD (ONEPT0
	DCA TWO2M8	/POINT TO 2^(M/8) IN TABLE
	DCA AC0
	TAD (-4
	DCA ACX
	JMS RNORM	/NORMALIZE
APPROX,	AAAAAAAAAAAAAAAA/COMPUTE 2^R BY A CONTINUED FRACTION
	SKNE
	JMP EXP0
	PUT EXREST
	GET EXD3
	DIV EXREST
	ADD EXREST
	PUT EXTEMP
	GET EXC3
	DIV EXTEMP
	SUB EXREST
	ADD EXB3
	PUT EXTEMP
	GET EXA3
	DIV EXTEMP
	SUB ONEPT0
	SKIP
EXP0,	GET ONEPT0
	MUL I TWO2M8	/MULTIPLY WITH 2^(M/8)
	EEEEEEEEEEEEEEEE
	TAD ACX
	TAD TWO2N	/INSERT 2^N
	DCA ACX
	JMS RNORM	/CHECK FOR OVERFLOW
	JMP I XEXP	/EXP(X) = 2^N * 2^(M/8) * 2^R

TWO2M8,	0		/POINTER TO TABLE

EXTEMP,	0	/ARGUMENT AND TEMPORARY
	0
	0
	0

EXREST,	0	/TEMPORARY REGISTER
	0
	0
	0
TWO2N,	0000	/HOLDS N  (MUST BE HERE!!!)

LOG2E,	0001	/1.442695040889
	2705
	2435
	4512

EXA3,	0006	/34.624680981335
	2123
	7726
	1367

EXB3,	0005	/17.312340490668
	2123
	7726
	1367

EXC3,	0007	/-104.068449050280
	7201
	0605
	7007

EXD3,	0005	/20.813689810056
	2464
	0467
	7155

/****************************
/ S I N E   AND   C O S I N E
/
/ AC := SIN(AC)
/ AC := COS(AC) = SIN(AC+PI/2)
/****************************


XCOS,	0
	AAAAAAAAAAAAAAAA
	ADD PIS2
	EEEEEEEEEEEEEEEE
	JMS XSIN
	JMP I XCOS

OPT5,	0000	/0.5
	2000
	0000
	0000

PIS2,	0001	/ PI/2
	3110
	3755
	2421

PI,	0002	/ PI
	3110
	3755
	2421

COS2,	0003	/-PI^2/2!
	6357
	2363
	1157

SIN3,	0003	/-PI^3/3!
	6452
	7363
	4611

	PAGE

COS4,	0003	/ PI^4/4!
	2017
	0174
	1006

SIN5,	0002	/ PI^5/5!
	2431
	5361
	4734

COS6,	0001	/-PI^6/6!
	6527
	2361
	7617

SIN7,	0000	/-PI^7/7!
	6313
	2263
	1630

COS8,	7776	/ PI^8/8!
	3607
	6501
	5044

SIN9,	7775	/ PI^9/9!
	2501
	7015
	1040

COS10,	7773	/-PI^10/10!
	7233
	2174
	5210

SCARG=EXTEMP	/ARGUMENT REGISTER


XSIN,	0
	TAD ACS		/SIN(-X) = -SIN(X), THUS
	DCA SCS		/SAVE SIGN
	DCA ACS		/AND MAKE ARGUMENT POSITIVE
	AAAAAAAAAAAAAAAA/NOW REDUCE ARGUMENT:
	DIV PI		/  X/PI = N + F   (0 <= F < 1)
	PUT SCARG	/SIN(X) = (-1)^N * SIN(PI*F)
	TRUNC
	EEEEEEEEEEEEEEEE
	L0001
	AND AC3		/IF ODD(N) THEN CHANGE SIGN
	CLL RTR
	TAD SCS
	DCA SCS
	AAAAAAAAAAAAAAAA
	FLOAT
	SUB SCARG	/-F
	SKNE
	JMP SCRET
	EEEEEEEEEEEEEEEE
	TAD ACX
	SZA CLA		/IF  F>=0.5 THEN
	JMP .+4
	AAAAAAAAAAAAAAAA
	ADD ONEPT0	/F := 1 - F
	EEEEEEEEEEEEEEEE/ SIN(PI*F) = SIN(PI*(1-F))
	DCA ACS		/NOW ARG. REDUCED TO  0 <= F <= 0.5
	L0002
	TAD ACX
	SPA CLA		/IF  F<0.125
	JMP TAYSIN	/THEN USE SINE-SERIES
	AAAAAAAAAAAAAAAA/ELSE SIN(PI*F) = COS(PI*(0.5-F))
	SUB OPT5
	EEEEEEEEEEEEEEEE
	DCA ACS		/F := 0.5 - F
	L0002
	TAD ACX
	SPA CLA		/IF  F<0.125
	JMP TAYCOS-1	/THEN USE COSINE-SERIES DIRECTLY
	L7777		/ELSE  COS(PI*F) = 2 * COS(PI*F/2)^2 - 1
	TAD ACX
	DCA ACX		/F := F/2    (1/16 <= F <= 3/16)
	L7777
	DCA HFLAG	/SET HALVE ARGUMENT FLAG
TAYCOS,	AAAAAAAAAAAAAAAA
	PUT SCARG
	MUL SCARG
	PUT FQU		/SQUARE ARG.
	MUL COS10
	ADD COS8
	MUL FQU
	ADD COS6
	MUL FQU
	ADD COS4
	MUL FQU
	ADD COS2
	MUL FQU
	ADD ONEPT0
	EEEEEEEEEEEEEEEE
	ISZ HFLAG	/WAS F>=0.125?
	JMP SCRET+1
	AAAAAAAAAAAAAAAA/YES
	PUT FQU
	MUL FQU		/ (COS^2 -
	SUB OPT5	/	 - 0.5)
	EEEEEEEEEEEEEEEE
	ISZ ACX		/ *2
HFLAG,	NOP
	JMP SCRET+1
TAYSIN,	AAAAAAAAAAAAAAAA
	PUT SCARG
	MUL SCARG
	PUT FQU
	MUL SIN9
	ADD SIN7
	MUL FQU
	ADD SIN5
	MUL FQU
	ADD SIN3
	MUL FQU
	ADD PI
	MUL SCARG
SCRET,	EEEEEEEEEEEEEEEE
	TAD AC1
	SZA CLA
	TAD SCS		/INSERT SIGN  (AVOID  -0 !)
	DCA ACS
	JMP I XSIN

SCS,	0	/SIGN OF RESULT

FQU,	0	/TEMPORARY FOR SQUARES ARG.
	0
	0
	0

	PAGE

/********************
/ A R C T A N G E N T
/
/ AC := ARCTAN(AC)
/********************



XATN,	0
	TAD ACX
	TAD (14
	SPA CLA		/IF ARGUMENT VERY SMALL ( < 2^(-12) )
	JMP I XATN	/THEN ARCTAN(X)=X
	TAD ACS
	DCA ATNS	/SAVE SIGN ... ARCTAN(-X) = -ARCTAN(X)
	DCA ACS		/AND MAKE ARGUMENT POSITIVE
	AAAAAAAAAAAAAAAA
	PUT ATARG
	EEEEEEEEEEEEEEEE
	TAD ACX
	SPA SNA CLA	/IF  X>=1
	JMP .+7
	AAAAAAAAAAAAAAAA
	GET ONEPT0	/THEN  X := 1/X
	DIV ATARG	/ARCTAN(X) = PI/2 - ARCTAN(1/X)
	PUT ATARG
	EEEEEEEEEEEEEEEE/NOW ARGUMENT REDUCED TO  0 < X <= 1
	L7777
	DCA GT1FLAG	/FLAG ARGUMENT > 1
	TAD ACX
	SPA CLA		/IF X>=0.5 THEN USE ADD.THEOREM:
	JMP ATN05
	ISZ ATARG	/2*X
ADDFLAG,NOP
	AAAAAAAAAAAAAAAA/ARCTAN(X) = ARCTAN(0.5) + ARCTAN( ... )
	ADD TWOPT0	/X := (2*X-1)/(X+2)
	PUT EXTEMP
	GET ATARG
	SUB ONEPT0
	DIV EXTEMP
	PUT ATARG	/ARGUMENT RANGE NOW  0 < X < 0.5
	EEEEEEEEEEEEEEEE
	L7777
ATN05,	DCA ADDFLAG
	AAAAAAAAAAAAAAAA/COMPUTE ARCTAN(X) BY CONTINUED FRACTION
	MUL ATARG
	PUT FQU
	ADD ATB3
	PUT EXTEMP
	GET ATA3
	DIV EXTEMP
	ADD ATB2
	ADD FQU
	PUT EXTEMP
	GET ATA2
	DIV EXTEMP
	ADD ATB1
	ADD FQU
	PUT EXTEMP
	GET ATA1
	DIV EXTEMP
	ADD ATB0
	ADD FQU
	PUT EXTEMP
	GET ATA0
	MUL ATARG
	DIV EXTEMP
	EEEEEEEEEEEEEEEE
	ISZ ADDFLAG	/CORRECT RESULT IF NECESSARY
	JMP .+4
	AAAAAAAAAAAAAAAA
	ADD ATN0P5
	EEEEEEEEEEEEEEEE
	ISZ GT1FLAG	/WAS X>1 ?
	JMP .+6
	L4000		/YES
	DCA ACS		/ -ARCTAN(X)
	AAAAAAAAAAAAAAAA
	ADD PIS2	/ +PI/2
	EEEEEEEEEEEEEEEE
	TAD ATNS
	DCA ACS		/INSERT SIGN
	JMP I XATN
ATNS,	0	/TEMPORARY FOR SIGN
GT1FLAG,0

ATARG,	0	/ARGUMENT REGISTER
	0
	0
	0
ATA0,	0004	/12.37469388
	3057
	7537
	4017

ATA1,	0007	/-80.34270560
	6405
	3673
	4343

ATA2,	0001	/-1.191447224
	6304
	0253
	6665

ATA3,	7775	/-0.078335428
	6403
	3451
	4461

ATB0,	0005	/26.27277525
	3221
	3522
	3121

ATB1,	0003	/6.36441688
	3135
	1757
	0565

ATB2,	0002	/2.104518952
	2065
	4070
	1015

ATB3,	0001	/1.258464113
	2410
	5255
	0370

ATN0P5,	7777	/ARCTAN(0.5)
	3553
	0634
	0530

TWOPT0,	0002	/2.0
	2000
	0000
	0000

	PAGE
/I N P U T - O U T P U T  ROUTINES FOR STANDARD FILES

GETC,	0
	CLA CLL
	TAD LOOK
	DCA CHAR
	ISZ IC3
	JMP G12
G3,	L7775
	DCA IC3
	L7776
	TAD IBP
	DCA IBP
	TAD I IBP
	ISZ IBP
K377,	AND (7400	/FIRST LITERAL ON THIS PAGE ---> 0377
	CLL RTL
	RTL
	DCA CHECK
	TAD I IBP
	AND (7400
	TAD CHECK
	RTL
	RTL
	RAL
	JMP GEXIT
G12,	TAD IBP
	AND K377
	SZA CLA
	JMP GEXIT-1
	TAD (IBUFFER
	DCA IBP
	JMS I IDEVH
	0200
	IBUFFER
IBLOCK,	0
	JMP RDERR
	ISZ IBLOCK
	L7776
	DCA IC3
	TAD I IBP
GEXIT,	ISZ IBP
	JMS CHECK
	JMP GETC+4
	JMP I GETC
RDERR,	SMA CLA
	JMP GEXIT-3
FATAL0,	FATAL		/FATAL READ ERROR!

IC3,	-3
IBP,	IBUFFER

PUTC,	0
	SNA
	TAD CHAR
	DCA CHECK
	TAD CHECK
	ISZ OC3
	JMP PUT12
	DCA CC
	L7776
	TAD OBP
	DCA OBP
	JMS PUT3L
	JMS PUT3R
	L7775
	DCA OC3
	TAD OBP
	AND K377
	SZA CLA
	JMP PUXIT
	ISZ MBLOCKS
	SKP
	JMP ERRORD
	JMS I ODEVH
	4200
	OBUFFER
OBLOCK,	0
	JMP ERRORD
	ISZ OBLOCK
	TAD [OBUFFER
	DCA OBP
	JMP PUXIT
PUT12,	AND K377
	DCA I OBP
	ISZ OBP
PUXIT,	TAD CHECK
	TAD [-215
	SZA CLA
	JMP I PUTC
	TAD [212
	JMP PUTC+1

PUT3L,
PUT3R,	0
	TAD CC
	CLL RTL
	RTL
	DCA CC
	TAD CC
	AND (7400
	TAD I OBP
	DCA I OBP
	ISZ OBP
	JMP I PUT3R

/OC3,	0		/ON PAGE 0!
/OBP,	0		/  - " -
CHECK,	0
	AND [177
	SNA
	JMP I CHECK
	TAD (-15
	SNA
	JMP CR
	TAD (15-32
	SNA
	JMP CR-2
	TAD (-6
	CLL
	TAD [240
	DCA LOOK
CHEXIT,	DCA EOLN
	SNL
	ISZ CHECK
	JMP I CHECK

	L0001		/END OF FILE
	DCA EOF
CR,	TAD [240	/END OF LINE
	DCA LOOK
	L0001		/LINK=0!
	JMP CHEXIT

	PAGE
/THE ORGANIZATION OF THE FOLLOWING PAGES OF FIELD 0
/DEMANDS SOME EXPLANATION:



/	AT COMPILE TIME		/	AT RUNTIME		/
/				/				/
/06000--------------------------/-------------------------------/
/	STARTUP CODE, THEN	/				/
/				/	I N P U T		/
/06200- I N P U T (SOURCE) -----/-----			   -----/
/	F I L E   B U F F E R   /	F I L E   B U F F E R	/
/				/				/
/06400--------------------------/-------------------------------/
/				/	INPUT			/
/	I N P U T (SOURCE)	/	  DEVICE HANDLER	/
/06600-    		   -----/-------------------------------/
/	D E V I C E		/	OUTPUT			/
/	H A N D L E R		/	  DEVICE HANDLER	/
/07000--------------------------/-------------------------------/
/				/				/
/	COMPILER PROCEDURES:	/	O U T P U T		/
/07200-----		   -----/-----			   -----/
/	I N S Y M B O L		/	F I L E   B U F F E R	/
/				/				/
/07400-----   AND	   -----/-------------------------------/
/				/	RUNTIME ERRORS		/
/	N E X T C H		/				/
/-------------------------------/-------------------------------/



/AT COMPILATION TIME FOUR PAGES OF FIELD 6 ARE USED AS FOLLOWS:

/66400--- TEMPORARY STORAGE OF INPUT DEVICE HANDLER
/
/66600--- TEMPORARY STORAGE OF OUTPUT DEVICE HANDLER
/
/67400--- RUNTIME ERRORS
/
/67600--- INITIALIZATION OF RUNTIME SYSTEM



/DURING INITIALIZATION OF THE RUNTIME SYSTEM
/THE FIRST THREE PAGES ARE SWAPPED INTO THEIR PLACE IN FIELD 0!
/#############################################################/
/#############################################################/
/#####                                                   #####/
/#####             S     T     A     R     T             #####/
/#####                                                   #####/
/#############################################################/
/#############################################################/



/IMPORTANT POINTS OF PROGRAM FLOW:


/S T A R T	(06000)		/STARTING ADDRESS OF ENTIRE SYSTEM,
				/PROCESS I/O-SPECIFICATIONS

/M A I N	(40200)		/START OF COMPILER PROGRAM


/E X P L A I N	(60200)		/COMPILATION REPORT


/I N I T	(67600)		/INITIALIZATION OF RUNTIME SYSTEM


/I S T A R T	(00200)		/START OF INTERPRETER




/ONCE ONLY CODE!!!

USR=200

	*IBUFFER
START,	CLA CLL		/S T A R T I N G   A D D R E S S
	CIF 10
	JMS I [7700	/LOCK USR IN MEMORY
	10
	TAD (1000	/RESET JOB STATUS WORD
	DCA I (7746
CD,	CIF 10
	JMS I (USR	/CALL THE COMMAND DECODER
	5
	2023		/ASSUMED INPUT EXTENSION:  .PS
	JMS HEADER
	CDF 10
	TAD I (7600
	SNA		/OUTPUT FILE SPECIFIED?
	JMP NOOUT
	DCA DEVNO	/YES, SAVE DEVICE NUMBER
	TAD (7600
	DCA XR10
	TAD I XR10	/TRANSFER THE FILENAME
	DCA NAME
	TAD I XR10
	DCA NAME+1
	TAD I XR10
	DCA NAME+2
	TAD I XR10
	DCA NAME+3
	CDF 0
	CIF 10
	TAD DEVNO
	JMS I (USR	/FETCH OUTPUT DEVICE HANDLER
	1
OHEP,	ODEVBUF		/1 PAGE ONLY!
	JMP CDERR
	CIF 10
	TAD DEVNO
	JMS I (USR	/OPEN OUTPUT FILE
	3
SBNO,	NAME
LEMP,	0
	JMP CDERR
	TAD OHEP	/GET ENTRY POINT
	DCA ODEVH
	TAD SBNO	/GET STARTING BLOCK NUMBER
	DCA I (OBLOCK
	TAD LEMP	/GET LENGTH OF EMPTY
	DCA LEMPTY
	TAD LEMPTY
	SZA
	TAD (-1		/SETUP BLOCK COUNTER
	DCA MBLOCKS	/(=0 IF NOT A FILE DEVICE)
	SKP
NOOUT,	ISZ IHEP	/ALLOW 2-PAGE INPUT HANDLER
			/IF NO OUTPUT FILE SPECIFIED!
	CDF 10
	TAD I (7621
	SNA		/INPUT FILE SPECIFIED?
	JMP NOINP	/NO, USE INTERN KEYBOARD HANDLER!
	CDF 0
	CIF 10
	JMS I (USR	/FETCH INPUT DEVICE HANDLER
	1
IHEP,	IDEVBUF
	JMP CDERR
	CDF 10
	TAD I (7622	/GET STARTING BLOCK NUMBER
	CDF 60
	DCA I (IIBLOCK
	TAD IHEP	/GET ENTRY POINT
	DCA I (IIDEVH
NOINP,	CDF 0		/SAVE DEVICE HANDLERS
	TAD I F0T6	/IN FIELD 6 TO MAKE ROOM
	CDF 60		/FOR HANDLER OF SOURCE FILE
	DCA I F0T6
	ISZ F0T6
	ISZ C400
	JMP .-6
	CDF 10
	TAD I (7617
	SNA		/SOURCE FILE SPECIFIED?
	JMP CDERR
	CDF 0
	CIF 10
	JMS I (USR	/FETCH HANDLER OF SOURCE FILE
	1
SHEP,	IDEVBUF+1
	JMP CDERR
	TAD SHEP	/GET ENTRY POINT
	DCA IDEVH
	CDF 10
	TAD I (7620
	CDF 0
	DCA I (IBLOCK
	JMP STARTC

F0T6,	IDEVBUF
C400,	-400

	PAGE
STARTC,	CDF 10		/CHECK  /S - OPTION
	TAD I (7644
	CDF 0
	AND (40
	SNA CLA
	JMP .+3
	TAD (SPRINT
	DCA PTPRINT
	CDF CIF COMPFIELD
	JMP I (MAIN	/START COMPILER

CDERR,	CLA CLL
	CDF CIF 0
	CRLF
	TAD I CTEXT
	SNA
	JMP .+7
	BSW
	JMS ASCII
	TAD I CTEXT
	JMS ASCII
	ISZ CTEXT
	JMP CDERR+3
	CRLF
	JMP I (7605
CTEXT,	.+1
TEXT /DATEIANGABEN FEHLERHAFT BZW. UNVOLLSTAENDIG (EV. AUCH SYSTEMFEHLER)!/
	0

	PAGE
/K E Y B O A R D   I N P U T   H A N D L E R

	*IDEVBUF
XREAD,	0
	CLA CLL
	TAD LOOK
	DCA CHAR
	TAD EOLN
	SZA CLA
	JMP XLINE
REXIT,	TAD I BP
	ISZ BP
	JMS CHECK
	JMP .-3
	JMP I XREAD
ERASE,	TAD [215
	JMS I ZPRINT
XLINE,	TAD (IBUFFER
	DCA BP
	TAD ("?
	JMS I ZPRINT
	TAD [240
	JMS I ZPRINT
XCHAR,	JMS KEYBOARD
	DCA I BP
	TAD I BP
	TAD (-377
	SNA CLA		/ 'RUBOUT'?
	JMP RUBOUT
	TAD I BP
	TAD (-203
	SNA		/ 'CTRL-C'?
	JMP I OS8
	TAD (203-212
	SNA		/ 'LINE FEED'?
	JMP REPLAY
	TAD (212-215
	SNA		/ 'RETURN'?
	JMP RETURN
	TAD (215-225
	SNA		/ 'CTRL-U'?
	JMP ERASE
	TAD (225-232
	SNA		/ 'CTRL-Z'?
	JMP EOFILE
	TAD (232-240
	SPA CLA
	JMP XCHAR
	TAD I BP
	JMS I ZPRINT
	ISZ BP
	JMP XCHAR

RUBOUT,	TAD ("\
	JMS I ZPRINT
	TAD BP
	TAD (-IBUFFER
	SNA CLA
	JMP YCHAR
	L7777
	TAD BP
	DCA BP
	TAD I BP
	JMS I ZPRINT
YCHAR,	JMS KEYBOARD
	DCA I BP
	TAD I BP
	TAD (-377
	SNA CLA
	JMP RUBOUT+2
	TAD ("\
	JMS I ZPRINT
	JMP XCHAR+2

REPLAY,	TAD BP
	TAD (-IBUFFER
	SNA
	JMP XCHAR
	CIA
	DCA RC
	TAD (IBUFFER
	DCA BP
	TAD [215
	JMS I ZPRINT
	TAD ("?
	JMS I ZPRINT
	TAD [240
	JMS I ZPRINT
	TAD I BP
	JMS I ZPRINT
	ISZ BP
	ISZ RC
	JMP .-4
	JMP XCHAR

EOFILE,	TAD [240
	JMS I ZPRINT
	TAD ("E
	JMS I ZPRINT
	TAD ("O
	JMS I ZPRINT
	TAD ("F
	JMS I ZPRINT
RETURN,	TAD [215
	JMS I ZPRINT
	TAD (IBUFFER
	DCA BP
	JMP REXIT

KEYBOARD,0
	KSF
	JMP .-1
	KRB
	AND [177
	SNA
	JMP KEYBOARD+1
	TAD (200
	JMP I KEYBOARD

BP,	IBUFFER
RC=KEYBOARD

	PAGE
/H E A D E R   L I N E

	*ODEVBUF
HEADER,	0		/ONCE ONLY CODE!
	CDF 10
	TAD I (7666	/GET DATE WORD FROM MONITOR
	CDF 0
	SNA
	JMP WHEAD-1
	MQL
	TAD (HDATE
	DCA XR10
	MQA		/YEAR
	AND (7
	TAD (116	/78
	JMS YYMMDD
	MQA		/MONTH
	BSW
	RTR
	AND (17
	JMS YYMMDD
	MQA		/DAY
	RTR
	RAR
	AND (37
	JMS YYMMDD
	SKP
	DCA HDATE
WHEAD,	TAD (PASCAL-1
	DCA XR10
	TAD I XR10
	SNA
WHEND,	JMP .+3		/BECOMES:  JMP WHEXIT
	PRINTC
	JMP .-4
	TAD H240
	PRINTC
	ISZ BLANKS
	JMP .-3
	TAD (JMP WHEXIT
	DCA WHEND
	JMP WHEAD+2
WHEXIT,	CRLF
	CRLF
	JMP I HEADER

YYMMDD,	0
	DCA DAT01
	DCA DAT10
	JMP .+3
	DCA DAT01
	ISZ DAT10
	TAD DAT01
	TAD (-12
	SMA
	JMP .-5
	CLA
	ISZ XR10
	TAD DAT10
	TAD H260
	DCA I XR10
	TAD DAT01
	TAD H260
	DCA I XR10
	JMP I YYMMDD

H215=.
PASCAL,	215;"P;240;"A;240;"S;240;"C;240;"A;240;"L
	240;"-;240;"S;240;240;240
	"C;"O;"M;"P;"I;"L;"E;"R
H240,	240
	"V
H260,	"0
	VERSION+"0
	0000
HTLMOE,	"H;"T;"L;"-;"M;"O;"E;"D;"L;"I;"N;"G
HDATE,	",	/BECOMES:  0000 IF NO DATE SPECIFIED
	240
	0000	/YEAR
	0000
	"-
	0000	/MONTH
	0000
	"-
DAT10,	0000	/DAY
DAT01,	0000
BLANKS,	-30	/BECOMES  0000

	PAGE
/BEGIN OF COMPILER PROGRAM:   T H E   S C A N N E R

NEXTCH=READC

SY0=H1		/FIELD 0  REPRESENTATIVE OF 'SY'
KSY=H2
SPS=H3
K=H4
INTORINP=PC

	*7000
INSY0,	SKP CLA
	NEXTCH
	TAD CHAR
	TAD [-240
	SNA CLA
	JMP .-4
	SNALF
	JMP WSYMBOL
	SKDIG
	JMP SPSYM
NUMBER,	TAD (FRACTN
	DCA INTORINP
	DCA SY0		/0=INTCON
	JMS IINP
	TAD CHAR
	TAD (-".
	SZA CLA
	JMP ECHAR
	NEXTCH
	TAD CHAR
	TAD (-".
	SNA CLA
	JMP RETNUM-2
REALGO,	L0001
	DCA SY0		/1=REALCON
	TAD OC
	CIA
	DCA DC
	JMP I INTORINP
ECHAR,	ISZ INTORINP
	TAD CHAR
	TAD (-"E
	SNA CLA
	JMP REALGO
	JMP RETNUM
	TAD (":
	DCA CHAR
RETNUM,	JMS PACK
	TAD (NUM-1
RETID,	DCA XR10
	CDF COMPFIELD
	TAD AC0
	DCA I XR10
	TAD AC1
	DCA I XR10
	TAD AC2
	DCA I XR10
	TAD AC3
	DCA I XR10
RETSYM,	TAD SY0
	CDF CIF COMPFIELD
	JMP I (EXSY3
WSYMBOL,DCA K		/USE AC FOR ID IN FIELD 0
	CLEAR
AZ09,	TAD K
	TAD (-ALNG
	SMA CLA
	JMP .+4
	L0100		/=2*AC0, LINK=0
	JMS CPACK
	ISZ K
	NEXTCH
	SKDIG
	SNALF
	JMP AZ09
	L0001		/BUILD HASH-CODE
	TAD AC0
	BSW
	RTL
	CLA
	TAD AC0
	BSW
	TAD AC1
	AND [77
	RAL
	MQL		/IN MQ
	MQA
	TAD (KSYTABLE
	DCA KSY
	MQA
	CLL RTL
	TAD (HASHTABLE-1
	DCA XR10
	CDF NAMEFIELD
	TAD I XR10
	CIA
	TAD AC0
	SZA CLA
	JMP XIDENT
	TAD I XR10
	CIA
	TAD AC1
	SZA CLA
	JMP XIDENT
	TAD I XR10
	CIA
	TAD AC2
	SZA CLA
	JMP XIDENT
	TAD I XR10
	CIA
	TAD AC3
	SZA CLA
	JMP XIDENT
	TAD I KSY
	JMP RETSYM+1
XIDENT,	TAD (IDENT
	DCA SY0
	TAD (ID-1
	JMP RETID

	PAGE
SPSYM,	TAD CHAR
	TAD (CHARTABLE-240
	DCA SPS
	CDF NAMEFIELD
	TAD I SPS
	CDF 0
	SNA
	JMP ILLCHAR
	SPA
	JMP DBLCHAR
RETSPS,	DCA SY0
	NEXTCH
	TAD SY0
RETSNGL,CDF CIF COMPFIELD
	JMP I (EXSY3
ILLCHAR,ERROR;30	/24
	JMP I (INSY0+1
DBLCHAR,DCA .+3
	NEXTCH
	TAD CHAR
	HLT		/JMP X

JMPCOL=JMP .
CCOL,	TAD (-"=
	SZA CLA
	JMP .+3
	TAD (BECOMES
	JMP RETSPS
	TAD (COLON
	JMP RETSNGL

JMPLSS=JMP .
CLSS,	TAD (-"=
	SNA
	JMP .+6
	TAD ("=-">
	SNA CLA
	JMP .+4
	TAD (LSS
	JMP RETSNGL
	L0004		/LEQ=NEQ+4
	TAD (NEQ
	JMP RETSPS

JMPGTR=JMP .
CGTR,	TAD (-"=
	SNA CLA
	JMP .+3
	TAD (GTR
	JMP RETSNGL
	TAD (GEQ
	JMP RETSPS

JMPPER=JMP .
CPER,	TAD (-".
	SNA CLA
	JMP .+3
	TAD (PERIOD
	JMP RETSNGL
	TAD (COLON
	JMP RETSPS

JMPLPAR=JMP .
CLPAR,	TAD (-"*
	SNA CLA
	JMP .+3
	TAD (LPARENT
	JMP RETSNGL
	NEXTCH
	TAD CHAR
	TAD (-"*
	SZA CLA
	JMP .-4
	NEXTCH
	TAD CHAR
	TAD (-")
	SZA CLA
	JMP .-10
	JMP I (INSY0+1


JMPAPOS=JMP I .
	CAPOS


CPACK,	0
	TAD K
	RAR
	DCA CPP
	TAD CHAR
	AND [77
	SZL
	JMP .+3
	BSW
	JMP .+5
	MQL
	TAD I CPP
	AND [7700
	MQA
	DCA I CPP
	CDF 0
	JMP I CPACK
CPP,	0


XSNALF,	0
	TAD CHAR
	TAD (-"Z-1
	CLL
	TAD ("Z+1-"A
	SNL CLA
	ISZ XSNALF
	JMP I XSNALF

	PAGE
DISPLAY=7400

/--------  D I S P L A Y  --------/

/DISPLAY,ZBLOCK 20	/AT RUNTIME ONLY

/---------------------------------/


CAPOS,	AND [77
	LOAD
	DCA K
	SKP
LBL2,	NEXTCH
	TAD CHAR
	TAD (-""
	SZA CLA
	JMP .+6
	NEXTCH
	TAD CHAR
	TAD (-""
	SZA CLA
	JMP LBL3
	STL
	CDF COMPFIELD
	TAD I (SX
	CDF TABLEFIELD
	JMS CPACK
	ISZ K
	TAD EOLN
	SNA CLA
	JMP LBL2
	DCA K
LBL3,	L0002		/2=CHARCON
	DCA SY0
	L7777
	TAD K
	SNA
	JMP RETNUM
	SPA CLA
	JMP ERR38
	ISZ SY0		/3=STRING
	CDF COMPFIELD
	TAD I (SX
	LOAD
	TAD K
	DCA I (SLENG
	TAD I (SX
	TAD K
	DCA I (SX
	TAD I (SX
	STL RAR
	CIA
	TAD I (C
	SPA CLA
FATAL7,	FATAL
	JMP RETNUM
ERR38,	ERROR;46	/38
	JMP .+3
ERR21,	ERROR;25	/21
	CLEAR
	JMP RETNUM


ZERROR,	0
	CLA CLL
	TAD I ZERROR
	CIF SETFIELD
	JMS I (F3ERROR
	JMP I ZERROR

ZFATAL,	0
	TAD ZFATAL
	CDF CIF SETFIELD
	JMP I (F3FATAL
XNEXTCH,0
	BREAK
	ISZ LL
	JMP NCH
	TAD ERRSW
	SNA CLA
	JMP NLN
	TAD (ERRLINE-1
	DCA XR10
	CDF SETFIELD
	TAD I XR10
	CDF 0
	TAD [240
	PRINTC
	ISZ ERRSW
	JMP .-6
	CRLF
NLN,	TAD EOF
	SZA CLA
FATAL9,	FATAL		/PROGRAM INCOMPLETE!
	DCA CC
	TAD (5
	DCA M
	CDF COMPFIELD
	TAD I (LC
	CDF 0
	LOAD
	JMS IOUT
	PRINTC		/CHAR = 240 !
	PRINTC
NCH,	ISZ CC
	TAD EOLN
	SNA CLA
	JMP .+6
	CRLF
	L7777
	DCA LL
	JMS GETC
	JMP I XNEXTCH
	JMS GETC
	PRINTC
	JMP I XNEXTCH
LL,	0

	PAGE
	FIELD 2

	*TAB

/ENTRIES FOR PREDEFINED SYMBOLS:

-1;	VARIABLE^100+NOTYP;	0040;	0
0;	KONSTANT^100+BOOLS;	0040;	0
1;	KONSTANT^100+BOOLS;	0040;	1
2;	TYPE1^100+REALS;	0040;	1
3;	TYPE1^100+CHARS;	0040;	1
4;	TYPE1^100+BOOLS;	0040;	1
5;	TYPE1^100+INTS;		0040;	1
6;	FUNKTION^100+REALS;	0040;	0
7;	FUNKTION^100+REALS;	0040;	2
10;	FUNKTION^100+BOOLS;	0040;	4
11;	FUNKTION^100+CHARS;	0040;	5
12;	FUNKTION^100+INTS;	0040;	6
13;	FUNKTION^100+CHARS;	0040;	7
14;	FUNKTION^100+CHARS;	0040;	10
15;	FUNKTION^100+INTS;	0040;	11
16;	FUNKTION^100+INTS;	0040;	12
17;	FUNKTION^100+REALS;	0040;	13
20;	FUNKTION^100+REALS;	0040;	14
21;	FUNKTION^100+REALS;	0040;	15
22;	FUNKTION^100+REALS;	0040;	16
23;	FUNKTION^100+REALS;	0040;	17
24;	FUNKTION^100+REALS;	0040;	20
25;	FUNKTION^100+BOOLS;	0040;	21
26;	FUNKTION^100+BOOLS;	0040;	22
27;	PROZEDURE^100+NOTYP;	0040;	1
30;	PROZEDURE^100+NOTYP;	0040;	2
31;	PROZEDURE^100+NOTYP;	0040;	3
32;	PROZEDURE^100+NOTYP;	0040;	4
33;	PROZEDURE^100+NOTYP;	0040;	5
34;	PROZEDURE^100+NOTYP;	0040;	6
35;	FUNKTION^100+REALS;	0040;	23
36;	PROZEDURE^100+NOTYP;	0040;	0
	FIELD 3

/N A M E S   OF   S Y M B O L - T A B L E

/THE FOLLOWING NAMES ARE PREDEFINED:
	*0
TEXT /@@@@@@@@/
	*.-1
TEXT /FALSE@@@/
	*.-1
TEXT /TRUE@@@@/
	*.-1
TEXT /REAL@@@@/
	*.-1
TEXT /CHAR@@@@/
	*.-1
TEXT /BOOLEAN@/
	*.-1
TEXT /INTEGER@/
	*.-1
TEXT /ABS@@@@@/
	*.-1
TEXT /SQR@@@@@/
	*.-1
TEXT /ODD@@@@@/
	*.-1
TEXT /CHR@@@@@/
	*.-1
TEXT /ORD@@@@@/
	*.-1
TEXT /SUCC@@@@/
	*.-1
TEXT /PRED@@@@/
	*.-1
TEXT /ROUND@@@/
	*.-1
TEXT /TRUNC@@@/
	*.-1
TEXT /SIN@@@@@/
	*.-1
TEXT /COS@@@@@/
	*.-1
TEXT /EXP@@@@@/
	*.-1
TEXT /LN@@@@@@/
	*.-1
TEXT /SQRT@@@@/
	*.-1
TEXT /ARCTAN@@/
	*.-1
TEXT /EOF@@@@@/
	*.-1
TEXT /EOLN@@@@/
	*.-1
TEXT /READ@@@@/
	*.-1
TEXT /READLN@@/
	*.-1
TEXT /WRITE@@@/
	*.-1
TEXT /WRITELN@/
	*.-1
TEXT /HALT@@@@/
	*.-1
TEXT /ASCII@@@/
	*.-1
TEXT /RANDOM@@/
	*.-1
TEXT /@@@@@@@@/
/F S Y S   AND   S E T - C O N S T A N T S

        *4000
/----------------
FSYS,   ZBLOCK 5        / M U S T   BE AT 4000!!!
/----------------

S1US2,  ZBLOCK 5

SET0,   0;0;0;0;0
SET1,
CONBGS, 7140;0000;0000;4000;0000
SET2,
TYPBGS, 0000;0000;0006;4000;0000
SET3,
BLOBGS, 0000;0000;0370;2000;0000
SET4,
FACBGS, 7200;0020;0000;4000;0000
SET5,
STATBGS,0000;0000;0000;3740;0000
SET6,   0000;0001;1000;0000;0000
SET7,   0000;0000;0370;6000;0000
SET8,   0140;0000;0000;0000;0000
SET9,   0000;0012;1000;0002;0000
SET10,  0000;0013;0000;0002;0000
SET11,  0000;0001;4000;4020;0000
SET12,  0000;0000;4000;4020;0000
SET13,  0000;0000;0040;4000;0000
SET14,  0000;0010;0000;0000;0000
SET15,  0000;0010;4000;0000;0000
SET16,  0000;0001;0000;4000;0000
SET17,  0000;0000;5000;0000;0000
SET18,  0000;0000;0000;4000;0000
SET19,  0000;0001;4000;4000;0000
SET20,  0000;0000;4000;0000;0000
SET21,  0000;0003;0000;0000;0000
SET22,  0000;0024;2000;0000;0000
SET23,  0000;0011;1000;0000;0000
SET24,  0000;0011;0000;0000;0000
SET25,  7000;0000;0000;0000;0000
SET26,  0037;0000;0000;0000;0000
SET27,  0140;4000;0000;0000;0000
SET28,  0000;3740;0000;0000;0000
SET29,  0000;2000;0400;0000;0000
SET30,  0000;0000;4000;0020;0000
SET31,  0000;0000;4000;3740;0000
SET32,  0000;0000;0000;0001;1000
SET33,  0000;0000;0000;0010;0000
SET34,  0000;0001;1000;0002;0000
SET35,  0000;0000;4000;0004;0000
SET36,  0000;0000;0000;0001;0000
SET37,  0000;0000;0400;0001;6000
SET38,  0000;0000;0000;0001;6000
SET39,  0000;0000;0000;0000;6000
SET40,  0000;0000;0000;7740;0000
SET41,  0000;0020;5000;0000;0000
SET42,  0000;0000;0030;0000;0000
SET43,  0000;0000;0000;2000;0000
SET44,  0000;0000;0370;3740;0000
SET45,  0000;0000;2000;0000;0000
SET46,	0000;0001;4000;4000;0000
/WORD- AND BIT-POSITION TABLE USED BY SET-ROUTINES:

SETTABL,0;4000
	0;2000
	0;1000
	0;0400
	0;0200
	0;0100
	0;0040
	0;0020
	0;0010
	0;0004
	0;0002
	0;0001

	1;4000
	1;2000
	1;1000
	1;0400
	1;0200
	1;0100
	1;0040
	1;0020
	1;0010
	1;0004
	1;0002
	1;0001

	2;4000
	2;2000
	2;1000
	2;0400
	2;0200
	2;0100
	2;0040
	2;0020
	2;0010
	2;0004
	2;0002
	2;0001

	3;4000
	3;2000
	3;1000
	3;0400
	3;0200
	3;0100
	3;0040
	3;0020
	3;0010
	3;0004
	3;0002
	3;0001

	4;4000
	4;2000
	4;1000
	4;0400
	4;0200
	4;0100
	4;0040
	4;0020
	4;0010
	4;0004
	4;0002
	4;0001
/H A S H - T A B L E   OF   K E Y W O R D S

HASHTABLE=.

DECIMAL		/ADDRESSES SPECIFIED IN DECIMAL!

	ZBLOCK 128^4	/CLEAR UNUSED LOCATIONS!

KSYTABLE=.	/REMEMBER END OF HASHTABLE

	*2^4+HASHTABLE
TEXT /AND/
	*5^4+HASHTABLE
TEXT /ARRAY/
	*8^4+HASHTABLE
TEXT /DIV/
	*9^4+HASHTABLE
TEXT /DO/
	*10^4+HASHTABLE
TEXT /END/
	*13^4+HASHTABLE
TEXT /FOR/
	*16^4+HASHTABLE
TEXT /CASE/
	*18^4+HASHTABLE
TEXT /IF/
	*19^4+HASHTABLE
TEXT /FUNCTION/
	*20^4+HASHTABLE
TEXT /ELSE/
	*22^4+HASHTABLE
TEXT /BEGIN/
	*27^4+HASHTABLE
TEXT /MOD/
	*29^4+HASHTABLE
TEXT /NOT/
	*30^4+HASHTABLE
TEXT /OF/
	*31^4+HASHTABLE
TEXT /OR/
	*37^4+HASHTABLE
TEXT /DOWNTO/
	*39^4+HASHTABLE
TEXT /PROCEDUR/
	*41^4+HASHTABLE
TEXT /TO/
	*44^4+HASHTABLE
TEXT /VAR/
	*45^4+HASHTABLE
TEXT /CONST/
	*46^4+HASHTABLE
TEXT /REPEAT/
	*47^4+HASHTABLE
TEXT /PROGRAM/
	*51^4+HASHTABLE
TEXT /TYPE/
	*60^4+HASHTABLE
TEXT /UNTIL/
	*66^4+HASHTABLE
TEXT /RECORD/
	*68^4+HASHTABLE
TEXT /THEN/
	*70^4+HASHTABLE
TEXT /WHILE/
/S Y M B O L - V A L U E S   OF   K E Y W O R D S

	*KSYTABLE
	ZBLOCK 128	/FOR SAFETY!
PUSHTABLE=.		/REMEMBER END OF KSYTABLE

	*2+KSYTABLE
ANDSY
	*5+KSYTABLE
ARRAYSY
	*8+KSYTABLE
IDIVSY
	*9+KSYTABLE
DOSY
	*10+KSYTABLE
ENDSY
	*13+KSYTABLE
FORSY
	*16+KSYTABLE
CASESY
	*18+KSYTABLE
IFSYM
	*19+KSYTABLE
FUNCTIONSY
	*20+KSYTABLE
ELSESY
	*22+KSYTABLE
BEGINSY
	*27+KSYTABLE
IMODSY
	*29+KSYTABLE
NOTSY
	*30+KSYTABLE
OFSY
	*31+KSYTABLE
ORSY
	*37+KSYTABLE
DOWNTOSY
	*39+KSYTABLE
PROCEDURESY
	*41+KSYTABLE
TOSY
	*44+KSYTABLE
VARSY
	*45+KSYTABLE
CONSTSY
	*46+KSYTABLE
REPTSY
	*47+KSYTABLE
PROGRAMSY
	*51+KSYTABLE
TYPESY
	*60+KSYTABLE
UNTILSY
	*66+KSYTABLE
RECRDSY
	*68+KSYTABLE
THENSY
	*70+KSYTABLE
WHILSY


OCTAL
/P U S H T A B L E

/CONTAINS THE NECESSARY INFORMATIONS (USED BY PUSHJUMP AND POPJUMP)
/TO CALL THE COMPILER PROCEDURES RECURSIVELY, 
/TO SAVE THE LOCAL VARIABLES, TO PASS EVENTUAL PARAMETERS
/AND RETURN CONTROL TO MAINLINE.
/
/FOR EACH PROCEDURE THERE IS ONE ENTRY OF 4 WORDS:
/WORD 1:	ADDRESS OF FIRST LOCAL VARIABLE (= 1ST PARAMETER) - 1
/WORD 2:	- NUMBER OF LOCAL VAR'S (LOCATIONS) TO SAVE
/WORD 3:	NUMBER OF PARAMETERS ( + FSYS  IF 1ST ONE IS A SET)
/				     ( + 100*NO. OF VAR-PARAMETERS)
/WORD 4:	STARTING ADDRESS OF PROCEDURE

	*PUSHTABLE

/BLOCK
	ISFUN-1;	-5;	FSYS+2;	XBLOCK
/STATEMENT
	0;		0;	FSYS;	XSTATEMENT
/ASSIGNMENT
	LV-1;		-6;	2;	XASSIGNMENT
/COMPOUNDSTATEMENT
	0;		0;	0;	XCOMPOUND
/IFSTATEMENT
	IXTYP-1;	-4;	0;	XIFSTATEMENT
/CASESTATEMENT
	CASETAB-1;	-137;	0;	XCASESTATEMENT
/REPEATSTATEMENT
	RXTYP-1;	-3;	0;	XREPEAT
/WHILESTATEMENT
	WXTYP-1;	-4;	0;	XWHILE
/FORSTATEMENT
	FXTYP-1;	-6;	0;	XFORSTATEMENT
/STANDPROC
	PRCN-1;		-5;	1;	XSTPROC
/SELECTOR
	SELVAR-1;	-5;	FSYS+200+1;	XSELECT
/CALL
	CALI-1;		-5;	FSYS+1;	XCALL
/STANDFCT
	FCTN-1;		-2;	1;	XSTFUN
/FACTOR
	FACVAR-1;	-3;	FSYS+200+1;	XFACTOR
/TERM
	TRMXTYP-1;	-4;	FSYS+1;	XTERM
/SIMPLEEXPRESSION
	SIMXTYP-1;	-4;	FSYS+1;	XSIMPLE
/EXPRESSION
	EXPRVAR-1;	-6;	FSYS+200+1;	XEXPRESSION
/CONDECLARE
	CONREC-1;	0;	0;	XCONDECL
/TYPDECLARE
	DECTP-1;	0;	0;	XTYPDECL
/VARDECLARE
	VARTP-1;	0;	0;	XVARDECL
/PRODECLARE
	PROFUN-1;	-1;	0;	XPRODECL
/CONSTANT
	CCON-1;		0;	FSYS+1;	XCONSTANT
/ARRAYTYP
	ARRVAR-1;	-6;	200+1;	XARRAYTYP
/TYPE
	TYPVAR-1;	-12;	FSYS+300+1;	XTYPE
/PARAMETERLIST
	PARTP-1;	0;	0;	XPARAM
/ONECASE
	0;		0;	0;	XONECASE
/TABLE OF   S P E C I A L   S Y M B O L S
/
/ONE ENTRY FOR EACH ASCII CHARACTER:
/   =0 ... FOR ILLEGAL CHAR'S
/   >0 ... (=SYMBOL VALUE) FOR SINGLE SPECIAL CHAR'S
/   <0 ... (=JMP TO ROUTINE) FOR DOUBLE CHAR'S, COMMENTS OR STRINGS

CHARTABLE=.

/SPACE  !  "  #  $  %  &  '  (  )  *  +  ,  -  .  /
0
0
JMPAPOS
NEQ
0
0
ANDSY
0
JMPLPAR
RPARENT
TIMES
PLUS
COMMA
MINUS
JMPPER
RDIVSY

ZBLOCK "9-"0+1		/DIGITS ARE PROCESSED SEPARATELY!

/:  ;  <  =  >  ?  @
JMPCOL
SEMICOLON
JMPLSS
EQL
JMPGTR
0
0

ZBLOCK "Z-"A+1		/LETTERS ARE PROCESSED SEPARATELY!

/[  \  ]  ^  _
LBRACK
0
RBRACK
0
0
/C O M P I L E R   E R R O R S   (NOT FATAL)

/ERROR LINE BUFFER:

ERRLINE,"#-240;	"#-240;	"#-240;	"#-240;	"#-240;	0; 0
	ZBLOCK LLNG


	PAGE

/ERROR ROUTINE:

ERRNO,	0	/ERROR NUMBER
ERRN01,	0	/ERROR NUMBER - UNITS
ERRN10,	0	/ERROR NUMBER - TENS
ERRPOS,	0	/POSITION OF ERROR
ERRP,	0
ERRC,	0
/ERRSW,	0	/IN FIELD 0
/ERRSUM,0	/IN FIELD 6

F3ERROR,0
	DCA ERRNO
	RDF
	TAD (CDF CIF
	DCA ERRCDI
	CDF 0
	TAD I (CC
	TAD (ERRLINE+5
	DCA ERRPOS
	TAD I (ERRSW
	CDF SETFIELD
	SZA CLA
	JMP ERRENT
	TAD (ERRLINE+5
	DCA ERRP
	TAD (-LLNG
	DCA ERRC
	ISZ ERRP
	DCA I ERRP
	ISZ ERRC
	JMP .-3
ERRENT,	TAD ERRNO
	DCA ERRN01
	DCA ERRN10
	JMP .+3
	DCA ERRN01
	ISZ ERRN10
	TAD ERRN01
	TAD (-12	/-10
	SMA
	JMP .-5
	CLA
	TAD I ERRPOS
	SZA CLA
	JMP ERREXIT	/NO ROOM!
	TAD ("#-240
	DCA I ERRPOS
	ISZ ERRPOS
	TAD ERRN10
	SNA
	JMP .+4
	TAD ("0-240
	DCA I ERRPOS
	ISZ ERRPOS
	TAD ERRN01
	TAD ("0-240
	DCA I ERRPOS
	TAD ERRPOS
	TAD (-ERRLINE
	CMA
	CDF 0
	DCA I (ERRSW
ERREXIT,CDF ERRFIELD
	ISZ I ERRNO	/REMEMBER THIS ERROR
	ISZ I (ERRSUM	/COUNT ERRORS
ERRCDI,	CDF CIF 0
	JMP I F3ERROR

	PAGE
/C O M P I L E R   E R R O R S   (FATAL)

FATADR,	0
FATPOS,	0

F3FATAL,DCA FATADR
	TAD FHEAD
	DCA FTEXT
	JMS FCRLF
	JMS FCRLF
	JMS FMESG
	TAD FLIST
	DCA FATPOS
	ISZ FATPOS
	TAD I FATPOS
	TAD FATADR
	SZA CLA
	JMP .-4
	TAD FATPOS
	TAD FMFL
	DCA FATPOS
	TAD I FATPOS
	DCA FTEXT
	JMS FMESG
	JMS FCRLF
	CDF CIF ERRFIELD
	JMP I .+1
	FXPLAIN

FPRINT,	0
	TLS
	TSF
	JMP .-1
	CLA CLL
	JMP I FPRINT

FCRLF,	0
	TAD F215
	JMS FPRINT
	TAD F212
	JMS FPRINT
	JMP I FCRLF

FMESG,	0
	TAD I FTEXT
	BSW
	JMS FASCII
	TAD I FTEXT
	JMS FASCII
	ISZ FTEXT
	JMP FMESG+1

FASCII,	0
	AND F77
	SNA
	JMP I FMESG
	TAD F240
	AND F77
	TAD F240
	JMS FPRINT
	JMP I FASCII

FTEXT,	0

FLIST,	FATLIST-1
FMFL,	FATMESG-FATLIST
FHEAD,	FNN
F215,	215
F212,	212
F240,	240
F77,	77

FATLIST,-FATAL0-1
	-FATAL1-1
	-FATAL2-1
	-FATAL3-1
	-FATAL4-1
	-FATAL5-1
	-FATAL6-1
	-FATAL7-1
	-FATAL8-1
	-FATAL9-1
	-FATALC-1

FATMESG,F00
	F01
	F02
	F03
	F04
	F05
	F06
	F07
	F08
	F09
	F0C

FNN,	TEXT /KOMPILATION ABGEBROCHEN - /

F00,	TEXT /MAGNETBAND-LESEFEHLER!/
F01,	TEXT /ZU VIELE NAMEN!/
F02,	TEXT /ZU VIELE PROZEDUREN UND\ODER RECORDS!/
F03,	TEXT /ZU VIELE KONSTANTE!/
F04,	TEXT /ZU VIELE ARRAYS!/
F05,	TEXT /ZU VIELE UNTERPROGRAMMEBENEN!/
F06,	TEXT /PROGRAMM ZU GROSS!/
F07,	TEXT /ZU VIEL TEXT!/
F08,	TEXT /PROGRAMM ZU KOMPLEX!/
F09,	TEXT /PROGRAMM UNVOLLSTAENDIG!/
F0C,	TEXT /ZU VIELE CASE-MARKEN!/

	PAGE
	FIELD 4

/P A G E   Z E R O

/LOC'S  1 - 7  USED FOR TEMPORARY STORAGE!
	*7
L,	0
	*10
/XR10,			/AUTOINDEX REGISTER (SEE FIELD 0!)
	0
XR11,	0		/   --- " ---
XR12,	0

	*20
LC,	0	/L O C A T I O N   C O U N T E R
TEMP,	0
		/I N S T R U C T I O N - R E G I S T E R
/IRX,
	0		/LEVEL
/IRY,
	0		/ADDRESS OR VALUE

		/I N D I C E S   T O   T A B L E S
/B,			/BLOCK TABLE
	0001
/T,			/SYMBOL TABLE
	0037
A,			/ARRAY TABLE
	0
C,			/CONSTANT TABLE
	ATAB-1
SX,			/STRING TABLE
	0
J,	0		/TEMPORARY FOR T
JA,	0		/TEMPORARY FOR A
JB,	0		/TEMPORARY FOR B

LO,	0		/LOW BOUND OF ARRAY
HI,	0		/HIGH BOUND OF ARRAY
SLENG,	0		/LENGTH OF STRING

SY,	0	/C U R R E N T   S Y M B O L

ID,	0;0;0;0 /C U R R E N T   I D E N T I F I E R
NUM,	0;0;0;0 /C O N S T A N T   N U M B E R

	*50	/U N P A C K E D   E N T R Y  OF SYMBOL TABLE
LINK0,	0
OBJ0,	0
TYP0,	0
REF0,	0
NORM0,	0
LEV0,	0
ADR0,	0

JW,	0	/ADDRESS OF ENTRY (REMEMBERED FOR 'WITHEND')

	*50	/U N P A C K E D   E N T R Y  OF ARRAY TABLE
INXTP0,	0
ELTYP0,	0
ELREF0,	0
LOW0,	0
HIGH0,	0
ELSIZ0,	0
SIZE0,	0

JAW,	0	/ADDRESS OF ENTRY (REMEMBERED FOR 'WITHAEND')

		/LOCAL VAR'S OF PROCEDURE   B L O C K
ISFUN,	0
LEVEL,	0
DX,	0
PRT,	0
PRB,	0

		/LOCAL VAR'S OF PROCEDURE   F A C T O R
FACVAR,	0
FACXTYP,0
FACXREF,0

		/LOCAL VAR'S OF PROCEDURE   C A L L
CALI,	0
CALXTYP,0
CALXREF,0
CALASTP,0
CALCP,	0

		/LOCAL VAR'S OF  P U S H J U M P  AND  P O P J U M P
LOCAL,	0
LENGTH,	0
PARAM,	0

/M A C R O   I N S T R U C T I O N S   USED BY COMPILER

	*100
/ERROR=JMS I .		/PARALLEL DEFINED WITH FIELD 0!
	XERROR
/FATAL=JMS I .		/ -"-
	XFATAL
/OFTAB=JMS I .		/ -"-
	XOFTAB
/OFATAB=JMS I .		/ -"-
	XOFATAB
/OFBTAB=JMS I .		/ -"-
	XOFBTAB
/OFDISPLAY=JMS I .	/ -"-
	XOFDISP
/TODISPLAY=JMS I .	/ -"-
	XTODISP
/GETCONSTANT=JMS I .	/ -"-
	XOFCONST
TOTAB=JMS I .		/PUT INFO INTO SYMBOL TABLE
	XTOTAB
TOATAB=JMS I .		/PUT INFO INTO ARRAY TABLE
	XTOATAB
TOBTAB=JMS I .		/PUT INFO INTO BLOCK TABLE
	XTOBTAB
WITHTABDO=JMS I .	/GET AND UNPACK ENTRY OF SYMBOL TABLE
	XWITHTAB
ENDWITH=JMS I .		/PACK AND STORE ENTRY OF SYMBOL TABLE
	XENDWITH
WITHATABDO=JMS I .	/GET AND UNPACK ENTRY OF ARRAY TABLE
	XWITHATAB
ENDAWITH=JMS I .	/PACK AND STORE ENTRY OF ARRAY TABLE
	XENDAWITH
TOCODE=JMS I .		/INSERT ADDRESS INTO CODE[LC].IRY
	XTOCODE
EMIT=JMS I .		/OUTPUT INSTRUCTION OF INTERMEDIATE CODE
	XEMIT
ENTER=JMS I .		/ENTER ITEM INTO SYMBOL TABLE
	XENTER
ENTERVARIABLE=JMS I .	/ENTER VARIABLE INTO SYMBOL TABLE
	XENTVAR
ENTERARRAY=JMS I .	/INTO ARRAY TABLE
	XENTARR
ENTERBLOCK=JMS I .	/INTO BLOCK TABLE
	XENTBLO
ENTERCONSTANT=JMS I .	/INTO CONSTANT TABLE
	XENTCON
SIGNEDINTEGER=JMS I .	/MAKE SIGNED 12-BIT INTEGER OF (NUM)
	XSGNINT
TEST=JMS I .		/CHECK AND SKIP TO LEGAL FOLLOW SYMBOL
	XTEST
TESTSEMICOLON=JMS I .
	XTSTSEM
SKIP=JMS I .		/SKIP TO LEGAL FOLLOW SYMBOL
	XSKIP
SKIPIFSYIN=JMS I .	/SKIP NEXT INSTR. IF SY IN SETX
	INSET
UNION=JMS I .		/SET UNION
	XUNION
IFSY=JMS I .		/IF SY=SYMBOL THEN NEXT INSTR. ELSE SKIP
	XIFSY
IFSYNOT=JMS I .		/IF SY<>SYMBOL THEN NEXT INSTR. ELSE SKIP
	XIFSYNOT
LOCATE=JMS I .		/LOCATE IDENTIFIER IN SYMBOL TABLE
	XLOCATE
PUSHJUMP=JMS I .	/RECURSIVE PROCEDURE CALL
	XPUSHJUMP
POPJUMP=JMS I .		/RETURN FROM PROCEDURE
	XPOPJUMP
RESULTTYPE=JMS I .
	XRESULT
INSYMBOL=JMS I .	/SCANNER
	XINSYMBOL

		/LOCAL VAR'S OF PROCEDURE   T Y P E
TYPVAR,	0
TP,	0
RF,	0
SZ,	0
ELTP,	0
ELRF,	0
ELSZ,	0
OFFSET,	0
TT0,	0
TT1,	0

		/LOCAL VAR'S OF PROCEDURE   W H I L E - STATEMENT
WXTYP,	0
WXREF,	0
WLC1,	0
WLC2,	0
/M A I N   P R O G R A M  OF COMPILER

	*200
MAIN,	INSYMBOL
	IFSYNOT;PROGRAMSY;JMP MAIN3
	INSYMBOL
	IFSYNOT;IDENT;JMP MAIN2
	INSYMBOL
	IFSY;LPARENT;JMP .+4
	ERROR;11	/9
	JMP ENDOFH
IOFILES,INSYMBOL
	IFSY;IDENT;JMP .+4
	ERROR;2		/2
	SKP
	INSYMBOL
	IFSY;COMMA;JMP IOFILES
ENDOFH,	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
MAINBL,	TAD (BTAB+3
	DCA XR10
	CDF TABLEFIELD
	TAD T
	DCA I XR10
	L0001
	DCA I XR10
	DCA I XR10
	DCA I XR10
	CDF COMPFIELD
	PUSHJUMP;BLOCK
	SET44
	0	/FALSE
	1

	IFSYNOT;PERIOD;ERROR;26		/22
	EMIT;45		/(37)
	CDF CIF ERRFIELD
	JMP I (EXPLAIN	/DO THE COMPILATION REPORT

MAIN2,	ERROR;2		/2
	JMP MAINBL

MAIN3,	ERROR;3		/3
	JMP MAINBL
/EXTENSION OF  P U S H J U M P  AND  P O P J U M P  ROUTINES

VARIN,	0
	TAD PARAM
	AND (700
	SNA
	JMP I VARIN
	BSW
	CIA
	DCA LENGTH
	ISZ LOCAL
	L7777
	TAD I LOCAL
	DCA XR11
	TAD I XR11
	DCA I XR10
	ISZ LENGTH
	JMP .-3
	JMP I VARIN

VARTM,	0
	DCA VARVAR
	TAD PARAM
	AND (700
	SNA
	JMP I VARTM
	BSW
	CIA
	DCA VARIN
	TAD VARIN
	DCA VARVAR
	TAD LOCAL
	DCA XR10
	L7777
	TAD I XR10
	DCA XR11
	DCA XR12	/USE LOC'S  1 - 7  FOR TEMP. STORAGE
	TAD I XR10
	DCA I XR12
	ISZ VARIN
	JMP .-3
	JMP I VARTM

VAREX,	0
	TAD VARVAR
	SNA CLA
	JMP I VAREX
	DCA XR10
	TAD I XR10
	DCA I XR11
	ISZ VARVAR
	JMP .-3
	JMP I VAREX

VARVAR,	0

	PAGE
/PROCEDURE	C O N S T A N T
/		---------------
/
/CALL:		PUSHJUMP;CONSTANT
/		SETX
/		C	/ADDRESS
/
/LOCAL VAR'S:	FSYS
		CCON,	0
		SIGN,	0

XCONSTANT, DCA I CCON
	TAD CCON
	DCA XR10
	DCA I XR10
	DCA I XR10
	DCA I XR10
	DCA I XR10
	TEST;CONBGS;FSYS;62	/50
	SKIPIFSYIN;CONBGS
	JMP CON6
	IFSYNOT;CHARCON;JMP .+4
	L0004		/4=CHARS
	DCA I CCON
	JMP CON4
	DCA SIGN	/+
	SKIPIFSYIN;SET8
	JMP CON1
	IFSY;MINUS;L4000
	DCA SIGN
	INSYMBOL
CON1,	IFSYNOT;IDENT;JMP CON2
	LOCATE
	SNA
	JMP CON5-1
	DCA J
	OFTAB;OBJ
	MQL
	MQA
	BSW
	AND [77
	TAD (-KONSTANT
	SNA CLA
	JMP .+4
	ERROR;31	/25
	JMP CON5-1
	MQA
	AND [77
	DCA I CCON
	OFTAB;ADR
	DCA NUM+3
	DCA NUM+2
	DCA NUM+1
	DCA NUM
	L7776		/2=REALS
	TAD I CCON
	SZA
	IAC		/1=INTS
	SZA CLA
	JMP CON3
	TAD NUM+3
	GETCONSTANT
	JMP CON3
CON2,	IFSY;INTCON;JMP CON3-2
	IFSY;REALCON;JMP CON3-3
	SKIP;FSYS;62	/50
	JMP CON5

	L0001
	IAC
	DCA I CCON
CON3,	TAD SIGN
	TAD NUM+1
	DCA NUM+1
CON4,	TAD CCON
	DCA XR10
	TAD NUM
	DCA I XR10
	TAD NUM+1
	DCA I XR10
	TAD NUM+2
	DCA I XR10
	TAD NUM+3
	DCA I XR10

	INSYMBOL
CON5,	TEST;FSYS;SET0;6	/6
CON6,	POPJUMP;CONSTANT

	PAGE
/PROCEDURE	A R R A Y T Y P
/		---------------
/
/CALL:		PUSHJUMP;ARRAYTYP
/		REF	/ADDRESS
/		SIZE	/ADDRESS
/
/LOCAL VAR'S:
		ARRVAR,	0
		AREF,	0
		ARSZ,	0
		ALTP,	0
		ALRF,	0
		ALSZ,	0

		LOWB,	ZBLOCK 5
		HIGHB,	ZBLOCK 5
		MULT=HIGHB

XARRAYTYP,
	PUSHJUMP;CONSTANT
	FSYS+SET9
	LOWB
	L7776		/2=REALS
	TAD LOWB
	SZA CLA
	JMP ARR1
	ERROR;33	/27
	L0001		/1=INTS
	DCA LOWB
	DCA LOWB+1
	DCA LOWB+2
	DCA LOWB+3
	DCA LOWB+4
ARR1,	IFSY;COLON;JMP .+4
	ERROR;15	/13
	SKP
	INSYMBOL
	PUSHJUMP;CONSTANT
	FSYS+SET10
	HIGHB
	TAD HIGHB
	CIA
	TAD LOWB
	SNA CLA
	JMP ARR2
	ERROR;33	/27
	TAD LOWB+1
	DCA HIGHB+1
	TAD LOWB+2
	DCA HIGHB+2
	TAD LOWB+3
	DCA HIGHB+3
	TAD LOWB+4
	DCA HIGHB+4
ARR2,	SIGNEDINTEGER;LOWB
	DCA LO
	SIGNEDINTEGER;HIGHB
	DCA HI
	TAD LOWB
	ENTERARRAY
	TAD A
	DCA AREF
	IFSYNOT;COMMA;JMP ARR3
	INSYMBOL
	TAD [ARRAY
	DCA ALTP
	PUSHJUMP;ARRAYTYP
	ALRF
	/ALSZ
	JMP ARR4
ARR3,	IFSY;RBRACK;JMP .+5
	ERROR;14	/12
	IFSY;RPARENT;INSYMBOL
	IFSY;OFSY;JMP .+4
	ERROR;10	/8
	SKP
	INSYMBOL
	PUSHJUMP;TYPE
	FSYS
	ALTP
	/ALRF
	/ALSZ
ARR4,	TAD AREF
	DCA JA
	WITHATABDO
	TAD LOW0
	CIA
	TAD HIGH0
	IAC
	DCA TEMP
	TAD ALSZ
	CIA
	DCA MULT
	TAD TEMP
	ISZ MULT
	JMP .-2
	DCA ARSZ
	TAD ARSZ
	DCA SIZE0
	TAD ALTP
	DCA ELTYP0
	TAD ALRF
	DCA ELREF0
	TAD ALSZ
	DCA ELSIZ0
	ENDAWITH
	POPJUMP;ARRAYTYP

	PAGE
/PROCEDURE	T Y P E
/		-------
/
/CALL:		PUSHJUMP;TYPE
/		SETX
/		TYP	/ADDRESS
/		REF	/ --"--
/		SIZE	/ --"--
/
/LOCAL VAR'S (ON PAGE ZERO!):
/		FSYS
/		TYPVAR,	0
/		TP,	0
/		RF,	0
/		SZ,	0
/		ELTP,	0
/		ELRF,	0
/		ELSZ,	0
/		OFFSET,	0
/		TT0,	0
/		TT1,	0

XTYPE,	DCA TP		/0=NOTYP
	DCA RF
	DCA SZ
	TEST;TYPBGS;FSYS;12	/10
	SKIPIFSYIN;TYPBGS
	POPJUMP;TYPE
	IFSYNOT;IDENT;JMP TYP1
	LOCATE
	SNA
	JMP TYP1-2
	DCA J
	WITHTABDO
	TAD OBJ0
	TAD [-TYPE1
	SNA CLA
	JMP .+4
	ERROR;35	/29
	JMP TYP1-2
	TAD TYP0
	DCA TP
	TAD REF0
	DCA RF
	TAD ADR0
	DCA SZ
	TAD TYP0
	SNA CLA
	ERROR;36	/30
	INSYMBOL
	JMP TYP7
TYP1,	IFSYNOT;ARRAYSY;JMP TYP2
	INSYMBOL
	IFSY;LBRACK;JMP .+5
	ERROR;13	/11
	IFSY;LPARENT;INSYMBOL
	TAD [ARRAY
	DCA TP
	PUSHJUMP;ARRAYTYP
	RF
	/SZ
	JMP TYP7
TYP2,	INSYMBOL
	ENTERBLOCK
	L0006		/6=RECORD
	DCA TP
	TAD B
	DCA RF
	TAD LEVEL
	TAD [-LMAX
	SNA CLA
FATAL5,	FATAL
	ISZ LEVEL
	TAD B
	TODISPLAY
	DCA OFFSET
TYP3,	SKIPIFSYIN;SET46;JMP TYP6
	IFSYNOT;IDENT;JMP TYP5
	TAD T
	DCA TT0
	SKP
	INSYMBOL
	ENTERVARIABLE
	IFSY;COMMA;JMP .-4
	IFSY;COLON;JMP .+4
	ERROR;5		/5
	SKP
	INSYMBOL
	TAD T
	DCA TT1
	PUSHJUMP;TYPE
	FSYS+SET11
	ELTP
	/ELRF
	/ELSZ
TYP4,	TAD TT0
	CIA
	TAD TT1
	SPA SNA CLA
	JMP TYP5
	ISZ TT0
	TAD TT0
	WITHTABDO
	TAD ELTP
	DCA TYP0
	TAD ELRF
	DCA REF0
	TAD [40
	DCA NORM0
	TAD OFFSET
	DCA ADR0
	TAD OFFSET
	TAD ELSZ
	DCA OFFSET
	ENDWITH
	JMP TYP4

	PAGE

TYP5,	IFSY;ENDSY;JMP TYP6
	IFSY;SEMICOLON;JMP .+5
	ERROR;16	/14
	IFSY;COMMA;INSYMBOL
	TEST;SET12;FSYS;6	/6
	JMP TYP3
TYP6,	TAD RF
	DCA JB
	TAD OFFSET
	TOBTAB;VSIZE
	TAD OFFSET
	DCA SZ
	TOBTAB;PSIZE
	INSYMBOL
	L7777
	TAD LEVEL
	DCA LEVEL
TYP7,	TEST;FSYS;SET0;6	/6
	POPJUMP;TYPE
/PROCEDURE	C O N D E C L
/		-------------
/
/CALL:		PUSHJUMP;CONDECL	/NO ARG'S!
/
/LOCAL VAR'S:
		CONREC,	ZBLOCK 5

XCONDECL, INSYMBOL
	TEST;SET18;BLOBGS;2	/2
CDEC1,	IFSYNOT;IDENT;POPJUMP;CONDECL
	ENTER;KONSTANT
	INSYMBOL
	IFSY;EQL;JMP .+5
	ERROR;20	/16
	IFSY;BECOMES;INSYMBOL
	PUSHJUMP;CONSTANT
	FSYS+SET19
	CONREC

	TAD T
	WITHTABDO
	TAD CONREC	/TYP
	DCA TYP0
	DCA REF0
	L7776
	TAD CONREC
	SZA
	IAC
	SZA CLA
	JMP .+4
	ENTERCONSTANT;CONREC
	SKP
	TAD CONREC+4
	DCA ADR0
	ENDWITH
	TESTSEMICOLON
	JMP CDEC1
/PROCEDURE	T Y P D E C L
/		-------------
/
/CALL:		PUSHJUMP;TYPDECL	/NO ARG'S!
/
/LOCAL VAR'S:
		DECTP,	0
		DECRF,	0
		DECSZ,	0
		DT1,	0

XTYPDECL, INSYMBOL
	TEST;SET18;BLOBGS;2	/2
TDEC1,	IFSYNOT;IDENT;POPJUMP;TYPDECL
	ENTER;TYPE1
	TAD T
	DCA DT1
	INSYMBOL
	IFSY;EQL;JMP .+5
	ERROR;20	/16
	IFSY;BECOMES;INSYMBOL
	PUSHJUMP;TYPE
	FSYS+SET19
	DECTP
	/DECRF
	/DECSZ

	TAD DT1
	WITHTABDO
	TAD DECTP
	DCA TYP0
	TAD DECRF
	DCA REF0
	TAD DECSZ
	DCA ADR0
	ENDWITH
	TESTSEMICOLON
	JMP TDEC1

	PAGE
/PROCEDURE	P A R A M E T E R L I S T
/		-------------------------
/
/CALL:		PUSHJUMP;PARAMETERLIST		/NO ARG'S!
/
/LOCAL VAR'S:
		PARTP,	0
		PARRF,	0
		PARSZ,	0
		PT0,	0
		VALPAR,	0

XPARAM,	INSYMBOL
	DCA PARTP
	DCA PARRF
	DCA PARSZ
	TEST;SET13;FSYS+SET14;7		/7
PAR1,	SKIPIFSYIN;SET13
	JMP PAR5
	IFSYNOT;VARSY;JMP .+3
	INSYMBOL
	SKP
	TAD [40
	DCA VALPAR
	TAD T
	DCA PT0
	ENTERVARIABLE
	IFSYNOT;COMMA;JMP .+4
	INSYMBOL
	ENTERVARIABLE
	JMP .-5
	IFSY;COLON;JMP .+4
	ERROR;5		/5
	JMP PAR3
	INSYMBOL
	IFSY;IDENT;JMP .+4
	ERROR;2		/2
	JMP PAR2
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP PAR2
	WITHTABDO
	TAD OBJ0
	TAD [-TYPE1
	SNA CLA
	JMP .+4
	ERROR;35	/29
	JMP PAR2
	TAD TYP0
	DCA PARTP
	TAD REF0
	DCA PARRF
	TAD VALPAR
	SZA CLA
	JMP .+3
	L0001
	SKP
	TAD ADR0
	DCA PARSZ
PAR2,	TEST;SET15;FSYS+SET16;16	/14
PAR3,	TAD PT0
	CIA
	TAD T
	SPA SNA CLA
	JMP PAR4
	ISZ PT0
	TAD PT0
	WITHTABDO
	TAD PARTP
	DCA TYP0
	TAD PARRF
	DCA REF0
	TAD VALPAR
	DCA NORM0
	TAD DX
	DCA ADR0
	TAD LEVEL
	DCA LEV0
	ENDWITH
	TAD DX
	TAD PARSZ
	DCA DX
	JMP PAR3
PAR4,	IFSY;RPARENT;JMP PAR6
	IFSY;SEMICOLON;JMP .+5
	ERROR;16	/14
	IFSY;COMMA;INSYMBOL
	TEST;SET13;FSYS+SET14;6		/6
	JMP PAR1
PAR5,	IFSY;RPARENT;JMP PAR6
	ERROR;4		/4
	JMP .+6
PAR6,	INSYMBOL
	TEST;SET17;FSYS;6	/6
	POPJUMP;PARAMETERLIST

	PAGE
/PROCEDURE	V A R D E C L
/		-------------
/
/CALL:		PUSHJUMP;VARDECL		/NO ARG'S!
/
/LOCAL VAR'S:
		VARTP,	0
		VARRF,	0
		VARSZ,	0
		VT0,	0
		VT1,	0

XVARDECL, INSYMBOL
	IFSYNOT;IDENT;POPJUMP;VARDECL
	TAD T
	DCA VT0
	ENTERVARIABLE
	IFSYNOT;COMMA;JMP .+4
	INSYMBOL
	ENTERVARIABLE
	JMP .-5
	IFSY;COLON;JMP .+4
	ERROR;5		/5
	SKP
	INSYMBOL
	TAD T
	DCA VT1
	PUSHJUMP;TYPE
	FSYS+SET19
	VARTP
	/VARRF
	/VARSZ

VAR1,	TAD VT0
	CIA
	TAD VT1
	SPA SNA CLA
	JMP VAR2
	ISZ VT0
	TAD VT0
	WITHTABDO
	TAD VARTP
	DCA TYP0
	TAD VARRF
	DCA REF0
	TAD LEVEL
	DCA LEV0
	TAD DX
	DCA ADR0
	TAD [40
	DCA NORM0
	ENDWITH
	TAD VARSZ
	TAD DX
	DCA DX
	JMP VAR1
VAR2,	TESTSEMICOLON
	JMP XVARDECL+1
/PROCEDURE	P R O D E C L
/		-------------
/
/CALL:		PUSHJUMP;PRODECL		/NO ARG'S!
/
/LOCAL VAR'S:	PROFUN,	0	/SEE BELOW!

XPRODECL, IFSY;FUNCTIONSY;L0001
	DCA PROFUN
	INSYMBOL
	IFSY;IDENT;JMP .+7
	ERROR;2		/2
	DCA ID
	DCA ID+1
	DCA ID+2
	DCA ID+3
	TAD (PROZEDURE
	TAD PROFUN
	DCA .+2
	ENTER;00	/FUNCTION OR PROCEDURE
	TAD T
	DCA J
	OFTAB;NORMAL
	AND (7737
	TAD [40
	TOTAB;NORMAL
	INSYMBOL
	L0001
	TAD LEVEL
	DCA .+5
	PUSHJUMP;BLOCK
	FSYS+SET20
PROFUN,	0
	0

	IFSY;SEMICOLON;JMP .+4
	ERROR;16	/14
	SKP
	INSYMBOL
	TAD [40
	TAD PROFUN
	DCA .+2
	EMIT;00		/*** (32) OR (33) ***/
	POPJUMP;PRODECL

	PAGE
/PROCEDURE	S E L E C T O R
/		---------------
/
/CALL:		PUSHJUMP;SELECTOR
/		SETX
/		V	/ADDRESS
/
/LOCAL VAR'S:	FSYS
		SELVAR,	0
		SELVTYP,0
		SELVREF,0
		SELXTYP,0
		SELXREF,0

XSELECT, IFSYNOT;PERIOD;JMP SEL2
	INSYMBOL	/FIELD SELECTOR
	IFSY;IDENT;JMP .+4
	ERROR;2		/2
	JMP SEL5
	TAD SELVTYP
	TAD [-RECORD
	SNA CLA
	JMP .+4
	ERROR;37	/31
	JMP SEL1
	TAD SELVREF
	OFBTAB;LAST
	DCA J
	JMS ENTID
	JMS CHKID
	JMP .+5
	OFTAB;LINK
	DCA J
	JMP .-5
	TAD J
	SNA CLA
	ERROR;0		/0
	WITHTABDO
	TAD TYP0
	DCA SELVTYP
	TAD REF0
	DCA SELVREF
	TAD ADR0
	SNA
	JMP SEL1
	DCA IRY
	EMIT;11		/*** (9) ***/
SEL1,	INSYMBOL
	JMP SEL5
SEL2,	IFSYNOT;LBRACK;ERROR;13		/11
SEL3,	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET21
	SELXTYP

	TAD SELVTYP
	TAD [-ARRAY
	SNA CLA
	JMP .+4
	ERROR;34	/28
	JMP SEL4
	TAD SELVREF	/ARRAY INDEX
	DCA JA
	OFATAB;INXTYP
	CIA
	TAD SELXTYP
	SNA CLA
	JMP .+4
	ERROR;32	/26
	JMP SEL6
	TAD JA
	DCA IRY
	OFATAB;ELSIZE
	CLL RAR		/1 SCOMPARES!
	SZA CLA
	L0001
	TAD (24
	DCA .+2
	EMIT;00		/*** (20) OR (21) ***/
SEL6,	OFATAB;ELTYP
	DCA SELVTYP
	OFATAB;ELREF
	DCA SELVREF
SEL4,	IFSY;COMMA;JMP SEL3
	IFSY;RBRACK;JMP .+5
	ERROR;14	/12
	IFSY;RPARENT;INSYMBOL
SEL5,	SKIPIFSYIN;SET22
	SKP
	JMP XSELECT
	TEST;FSYS;SET0;6	/6
	POPJUMP;SELECTOR

	PAGE
/FUNCTION	R E S U L T T Y P E
/		-------------------
/
/CALL:		TAD XTYP
/		MQL
/		TAD YTYP
/		RESULTTYPE
/
/RETURNS RESULTTYPE IN ACCUMULATOR

XRESULT,0
	SZA
	SWP
	SNA
	JMP I XRESULT
	TAD [-2		/HERE: XTYP<>0 AND YTYP<>0, XTYP IN AC
	SMA SZA
	JMP RES33
	SWP		/YTYP IN AC
	TAD [-2
	SMA SZA
	JMP RES33
	SNA		/HERE ONLY INTS OR REALS, YTYP IN AC
	JMP .+5		/(7777 ... INTS, 0000 ... REALS)
	SWP
	SZA CLA
	JMP RES1	/INTS - INTS
	JMP .+5		/REALS - INTS
	SWP
	SNA CLA
	JMP .+5		/REALS - REALS
	L0001		/INTS - REALS
	DCA IRY
	EMIT;32		/*** (26,0) OR (26,1) ***/
	IAC
RES1,	IAC
	JMP I XRESULT
RES33,	CLA CLL
	ERROR;41	/33
	JMP I XRESULT
/PROCEDURE	C A L L
/		-------
/
/CALL:		PUSHJUMP;CALL
/		SETX
/		I	/VALUE
/
/LOCAL VAR'S (ON PAGE ZERO!):
/		FSYS
/		CALI,	0
/		CALXTYP,0
/		CALXREF,0
/		CALASTP,0
/		CALCP,	0

XCALL,	TAD CALI
	DCA IRY
	EMIT;22		/*** (18,I) ***/
	TAD CALI
	OFTAB;REF
	BSW
	AND [77
	OFBTAB;LASTPAR
	DCA CALASTP
	TAD CALI
	DCA CALCP
	IFSYNOT;LPARENT;JMP CAL5
CAL1,	INSYMBOL
	TAD CALASTP
	CIA
	TAD CALCP
	SMA CLA
	JMP CAL4-2
	ISZ CALCP
	TAD CALCP
	OFTAB;NORMAL
	AND [40
	SNA CLA
	JMP CAL3
	PUSHJUMP;EXPRESSION	/VALUE PARAMETER
	FSYS+SET23
	CALXTYP

	TAD CALCP
	OFTAB;TYP
	AND [77
	DCA TEMP
	TAD TEMP
	CIA
	TAD CALXTYP
	SZA CLA
	JMP CAL2
	TAD CALCP
	OFTAB;REF
	BSW
	AND [77
	CIA
	TAD CALXREF
	SZA CLA
	JMP CAL36
	TAD CALXTYP
	TAD [-ARRAY
	SZA
	JMP .+5
	TAD CALXREF
	OFATAB;SIZE
	JMP .+7
	CLL RAR		/6=RECORD
	SZA CLA
	JMP CAL4
	TAD CALXREF
	OFBTAB;VSIZE
	DCA IRY
	EMIT;26		/*** (22,SIZE) ***/
	JMP CAL4
CAL2,	L7777		/1=INTS
	TAD CALXTYP
	SZA CLA
	JMP .+10
	L7776		/2=REALS
	TAD TEMP
	SZA CLA
	JMP .+4
	EMIT;32		/*** (26,0) ***/
	JMP CAL4
	TAD CALXTYP
	SZA CLA
	JMP CAL36
	JMP CAL4

	PAGE

CAL3,	IFSY;IDENT;JMP .+4	/VARIABLE PARAMETER
	ERROR;2		/2
	JMP CAL4
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP CAL4
	WITHTABDO
	L7777		/1=VARIABLE
	TAD OBJ0
	SZA CLA
	ERROR;45	/37
	TAD TYP0
	DCA CALXTYP
	TAD REF0
	DCA CALXREF
	TAD LEV0
	DCA IRX
	TAD ADR0
	DCA IRY
	TAD NORM0
	SNA CLA
	IAC
	DCA .+2
	EMIT;00		/*** (0,LEV,ADR) OR (1,LEV,ADR) ***/
	SKIPIFSYIN;SET22
	JMP .+5
	PUSHJUMP;SELECTOR
	FSYS+SET23
	CALXTYP

	TAD CALCP
	OFTAB;TYP
	AND [77
	CIA
	TAD CALXTYP
	SZA CLA
	JMP CAL36
	TAD CALCP
	OFTAB;REF
	BSW
	AND [77
	CIA
	TAD CALXREF
	SZA CLA
CAL36,	ERROR;44	/36
	JMP CAL4
	ERROR;47	/39
CAL4,	TEST;SET24;FSYS;6	/6
	IFSY;COMMA;JMP CAL1
	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
CAL5,	TAD CALASTP
	CIA
	TAD CALCP
	SPA CLA
	ERROR;47	/39
	TAD CALI
	OFTAB;REF
	DCA TEMP
	TAD TEMP
	BSW
	AND [77
	OFTAB;PSIZE
	TAD (-1
	DCA IRY
	EMIT;23		/*** (19,PSIZE-1) ***/
	TAD TEMP
	AND [17
	CIA
	TAD LEVEL
	SPA SNA CLA
	JMP CAL6
	TAD LEVEL
	DCA IRX		/SWAPPED CONTENTS OF IRX AND IRY HERE!
	TAD TEMP	/(SEE INTERPRETER AT I03)
	AND [17
	DCA IRY
	EMIT;3		/*** (3,LEV1,LEV2) ***/
CAL6,	POPJUMP;CALL

	PAGE
/PROCEDURE	S T A N D F C T
/		---------------
/
/CALL:		PUSHJUMP;STANDFCT
/		N	/VALUE
/
/LOCAL VAR'S:
		FCTN,	0	/NUMBER OF STANDARD FUNCTION
		FCTJ,	0

XSTFUN,	TAD FCTN
	TAD (-20	/-16
	SMA SZA CLA
	JMP STF17
	IFSY;LPARENT;JMP .+4
	ERROR;11	/9
	SKP
	INSYMBOL
	TAD J		/J IS SET IN FACTOR
	DCA FCTJ
	PUSHJUMP;EXPRESSION
	FSYS+SET14
	FACXTYP

	TAD FCTJ
	DCA J
	L7776
	TAD FCTN
	SMA SZA CLA
	JMP STF1
			/FCTN: 0,2
	L0004		/4=FUNKTION
	BSW		/(MUST INSERT OBJ
	TAD FACXTYP	/ALONG WITH TYP!)
	TOTAB;TYP
	L7776		/2=REALS
	TAD FACXTYP
	SNA CLA
	ISZ FCTN
	JMP STF2
STF1,	TAD FCTN
	TAD (-10
	SPA SNA CLA
	JMP STF2	/FCTN: 4,5,6,7,8
	L7777		/FCTN: 9,10,11, ... ,16
	TAD FACXTYP	/1=INTS
	SNA CLA
	EMIT;32		/*** (26,0) ***/
STF2,	TAD (TSET
	TAD FCTN
	DCA TEMP
	TAD FACXTYP
	STL RAL
	TAD (SETTABLE
	DCA ARGXTYP
	TAD I TEMP
	CDF SETFIELD
	AND I ARGXTYP
	CDF COMPFIELD
	SNA CLA
	JMP STF3
	TAD FCTN
	DCA IRY
	EMIT;10		/*** (8,N) ***/
	JMP .+5
STF3,	TAD FACXTYP
	SZA CLA
	ERROR;60	/48
	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
STF4,	OFTAB;TYP	/(J STILL OKAY!?)
	AND [77
	DCA FACXTYP
	POPJUMP;STANDFCT

STF17,	TAD FCTN
	DCA IRY
	EMIT;10		/*** (8,17) OR (8,18) OR (8,19) ***/
	JMP STF4


/TABLE OF LEGAL ARGUMENT TYPES:
TSET,	3000	/0
	3000
	3000	/2
	3000
	2000	/4
	2000	/5
	2600	/6
	0200	/7
	0200	/8
	3000	/9
	3000
	3000
	3000
	3000
	3000
	3000
	3000	/16

ARGXTYP,0

	PAGE
/PROCEDURE	F A C T O R
/		-----------
/
/CALL:		PUSHJUMP;FACTOR
/		SETX
/		X	/ADDRESS
/
/LOCAL VAR'S (ON PAGE ZERO!):
/		FSYS
/		FACVAR,	0
/		FACXTYP,0
/		FACXREF,0

XFACTOR,DCA FACXTYP	/0=NOTYP
	DCA FACXREF
	TEST;FACBGS;FSYS;72	/58
FAC1,	SKIPIFSYIN;FACBGS
	POPJUMP;FACTOR
	IFSYNOT;IDENT;JMP FAC2
	LOCATE
	DCA J
	INSYMBOL
	WITHTABDO
	TAD OBJ0
	TAD (JMP I FACTABL
	DCA .+1
	HLT

FACTABL,FKON
	FVAR
	FTYP
	FPRO
	FFUN

FKON,	TAD TYP0
	DCA FACXTYP
	DCA FACXREF
	TAD ADR0
	DCA IRY
	L7777		/1=INTS
	TAD TYP0
	CLL RAR		/2=REALS
	SNA CLA
	IAC
	TAD (30
	DCA .+2
	EMIT;00		/*** (24,ADR) OR (25,ADR) ***/
	JMP FAC3

FVAR,	TAD TYP0
	DCA FACXTYP
	TAD REF0
	DCA FACXREF
	TAD LEV0
	DCA IRX
	TAD ADR0
	DCA IRY
	SKIPIFSYIN;SET22
	JMP FVAR1
	TAD NORM0
	SNA CLA
	IAC
	DCA .+2
	EMIT;00		/*** (0,LEV,ADR) OR (1,LEV,ADR) ***/
	PUSHJUMP;SELECTOR
	FSYS
	FACXTYP

	TAD FACXTYP
	TAD [-4		/STANTYPS = NOTYP(0) ... CHAR(4)
	SPA SNA CLA
	EMIT;42		/*** (34) ***/
	JMP FAC3
FVAR1,	DCA .+11	/F=0
	TAD FACXTYP
	TAD [-4
	SPA SNA CLA
	ISZ .+5		/F:=F+1  (IN STANTYPS!)
	TAD NORM0
	SNA CLA
	ISZ .+2		/F:=F+1
	EMIT;00		/*** (F,LEV,ADR) ***/
	JMP FAC3

FTYP,
FPRO,	ERROR;54	/44
	JMP FAC3

FFUN,	TAD TYP0
	DCA FACXTYP
	TAD LEV0
	SNA CLA
	JMP STFUN
	TAD J
	DCA .+4
	PUSHJUMP;CALL
	FSYS
	0
	JMP FAC3
STFUN,	TAD ADR0
	DCA .+3
	PUSHJUMP;STANDFCT
	0
	JMP FAC3

	PAGE

FAC2,	SKIPIFSYIN;SET25
	JMP FAC23
	L7776		/2=CHARCON
	TAD SY
	SNA CLA
	JMP FAC21
	L0001
	TAD SY
	DCA FACXTYP	/INTS OR REALS
	ENTERCONSTANT;NUM-1
	DCA IRY
	EMIT;31		/*** (25,C) ***/
	JMP FAC22
FAC21,	L0004		/4=CHARS
	DCA FACXTYP
	TAD NUM+3
	DCA IRY
	EMIT;30		/*** (24,NUM) ***/
FAC22,	DCA FACXREF
	INSYMBOL
	JMP FAC3
FAC23,	IFSYNOT;LPARENT;JMP FAC24
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET14
	FACXTYP

	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	JMP FAC3
	INSYMBOL
	JMP FAC3
FAC24,	IFSYNOT;NOTSY;JMP FAC3
	INSYMBOL
	PUSHJUMP;FACTOR
	FSYS
	FACXTYP

	L7775	/3=BOOLS
	TAD FACXTYP
	SZA CLA
	JMP .+4
	EMIT;43		/*** (35) ***/
	JMP FAC3
	TAD FACXTYP
	SZA CLA
	ERROR;40	/32
FAC3,	TEST;FSYS;FACBGS;6	/6
	JMP FAC1

	PAGE
/PROCEDURE	T E R M
/		-------
/
/CALL:		PUSHJUMP;TERM
/		SETX
/		X	/ADDRESS
/
/LOCAL VAR'S:	FSYS
		TRMXTYP,0
		TRMYTYP,0
		TRMYREF,0
		TRMOP,	0

XTERM,	TAD TRMXTYP
	DCA .+4
	PUSHJUMP;FACTOR
	FSYS+SET26
	0

TRM1,	SKIPIFSYIN;SET26
	POPJUMP;TERM
	TAD SY
	DCA TRMOP
	INSYMBOL
	PUSHJUMP;FACTOR
	FSYS+SET26
	TRMYTYP

	TAD TRMOP
	TAD (JMP I OPTABL-TIMES
	DCA .+1
	HLT

OPTABL,	XTIMES
	XIDIV
	XRDIV
	XIMOD
	XAND

XTIMES,	TAD I TRMXTYP
	MQL
	TAD TRMYTYP
	RESULTTYPE
	DCA I TRMXTYP
	TAD I TRMXTYP
	SNA
	JMP TRM1	/NOTYP
	TAD (-1
	SZA CLA
	TAD (12-3	/REALS
	TAD (3		/INTS
	DCA IRY
	EMIT;60		/*** (48,3) OR (48,12) ***/
	JMP TRM1

XRDIV,	L0001
	DCA IRY
	L7777		/1=INTS
	TAD I TRMXTYP
	SZA CLA
	JMP .+5
	EMIT;32		/*** (26,1) ***/
	L0002		/2=REALS
	DCA I TRMXTYP
	DCA IRY
	L7777		/1=INTS
	TAD TRMYTYP
	SZA CLA
	JMP .+5
	EMIT;32		/*** (26,0) ***/
	L0002		/2=REALS
	DCA TRMYTYP
	L7776		/2=REALS
	TAD I TRMXTYP
	SZA CLA
	JMP XNOTYP-1
	L7776
	TAD TRMYTYP
	SZA CLA
	JMP XNOTYP-1
	TAD (13
	DCA IRY
	EMIT;60		/*** (48,13) ***/
	JMP TRM1

XIDIV,
XIMOD,	L7777		/1=INTS
	TAD I TRMXTYP
	SZA CLA
	JMP XNOTYP-2
	L7777
	TAD TRMYTYP
	SZA CLA
	JMP XNOTYP-2
	TAD TRMOP
	CLL RAR
	DCA IRY
	EMIT;60		/*** (48,4) OR (48,5) ***/
	JMP TRM1

XAND,	L7775		/3=BOOLS
	TAD I TRMXTYP
	SZA CLA
	JMP XNOTYP
	L7775
	TAD TRMYTYP
	SZA CLA
	JMP XNOTYP
	EMIT;64		/*** (52) ***/
	JMP TRM1

	CLA IAC
	IAC
XNOTYP,	TAD [40
	DCA ERRTYP
	TAD I TRMXTYP
	SZA CLA
	TAD TRMYTYP
	SZA CLA
	ERROR
ERRTYP,	00		/32, 33 OR 34
	DCA I TRMXTYP	/0=NOTYP
	JMP TRM1

	PAGE
/PROCEDURE	S I M P L E E X P R E S S I O N
/		-------------------------------
/
/CALL:		PUSHJUMP;SIMPLEEXPRESSION
/		SETX
/		X	/ADDRESS
/
/LOCAL VAR'S:	FSYS
		SIMXTYP,0
		SIMYTYP,0
		SIMYREF,0
		SIMOP,	0

XSIMPLE,SKIPIFSYIN;SET8
	JMP SIM1
	TAD SY
	DCA SIMOP
	INSYMBOL
	TAD SIMXTYP
	DCA .+4
	PUSHJUMP;TERM
	FSYS+SET8
	0

	L7776		/2=REALS
	TAD I SIMXTYP
	SPA SNA CLA
	JMP .+4
	ERROR;41	/33
	JMP SIM2
	TAD SIMOP
	TAD (-MINUS
	SNA CLA
	EMIT;44		/*** (36) ***/
	JMP SIM2
SIM1,	TAD SIMXTYP
	DCA .+4
	PUSHJUMP;TERM
	FSYS+SET27
	0

SIM2,	SKIPIFSYIN;SET27
	POPJUMP;SIMPLEEXPRESSION
	TAD SY
	DCA SIMOP
	INSYMBOL
	PUSHJUMP;TERM
	FSYS+SET27
	SIMYTYP

	TAD SIMOP
	TAD (-ORSY
	SZA CLA
	JMP SIM3
	L7775		/3=BOOLS
	TAD I SIMXTYP
	SZA CLA
	JMP NOTBOOL
	L7775
	TAD SIMYTYP
	SZA CLA
	JMP NOTBOOL
	EMIT;63		/*** (51) ***/
	JMP SIM2
NOTBOOL,TAD I SIMXTYP
	SZA CLA
	TAD SIMYTYP
	SZA CLA
	ERROR;40	/32
	DCA I SIMXTYP	/0=NOTYP
	JMP SIM2
SIM3,	TAD I SIMXTYP
	MQL
	TAD SIMYTYP
	RESULTTYPE
	DCA I SIMXTYP
	TAD I SIMXTYP
	SNA
	JMP SIM2
	CLL RAR		/NOW: 0...INTS, 1...REALS!
	SZA CLA
	TAD (7
	TAD [-4
	TAD SIMOP	/+ ... 5, - ... 6
	DCA IRY
	EMIT;60	/*** (48,1) OR (48,2) OR (48,10) OR (48,11) ***/
	JMP SIM2

	PAGE
/PROCEDURE	E X P R E S S I O N
/		-------------------
/
/CALL:		PUSHJUMP;EXPRESSION
/		SETX
/		X	/ADDRESS
/
/LOCAL VAR'S:	FSYS
		EXPRVAR,0
		XTYP,	0
		XREF,	0
		YTYP,	0
		YREF,	0
		OP,	0

XEXPRESSION,
	PUSHJUMP;SIMPLEEXPRESSION
	FSYS+SET28
	XTYP

	SKIPIFSYIN;SET28
	POPJUMP;EXPRESSION
	TAD SY
	DCA OP
	INSYMBOL
	PUSHJUMP;SIMPLEEXPRESSION
	FSYS
	YTYP

	L7776		/2=REALS
	TAD XTYP
	SNA
	JMP EXPR1
	TAD [-2		/2+2=4=CHARS
	SMA SZA CLA
	JMP EXPR1
	TAD XTYP
	CIA
	TAD YTYP
	SNA CLA
	JMP IEXPR
EXPR1,	L0001
	DCA IRY
	L7777	/1=INTS
	TAD XTYP
	SZA CLA
	JMP .+5
	EMIT;32		/*** (26,1) ***/
	L0002		/2=REALS
	DCA XTYP
	DCA IRY
	L7777		/1=INTS
	TAD YTYP
	SZA CLA
	JMP .+5
	EMIT;32		/*** (26,0) ***/
	L0002		/2=REALS
	DCA YTYP
	L7776		/2=REALS
	TAD XTYP
	SZA CLA
	JMP ILLTYP
	L7776
	TAD YTYP
	SZA CLA
	JMP ILLTYP
REXPR,	L0001
IEXPR,	TAD (61
	DCA I61R62
	TAD OP
	TAD (TAD RELTABL-EQL
	DCA .+1
	0000		/TAD RELTABL (MODIFIED INSTR.!)
	DCA IRY
	EMIT
I61R62,	00		/*** (49,OP) OR (50,OP) ***/
EXPR3,	L0003		/3=BOOLS
	DCA XTYP
	POPJUMP;EXPRESSION

ILLTYP,	ERROR;43	/35
	JMP EXPR3

RELTABL,SZA
	SNA
	SPA SNA
	SPA
	SMA
	SMA SZA

	PAGE
/PROCEDURE	A S S I G N M E N T
/		-------------------
/
/CALL:		PUSHJUMP;ASSIGNMENT
/		LEV	/VALUE
/		ADR	/- " -
/
/LOCAL VAR'S:
		LV,	0
		AD,	0
		AXTYP,	0
		AXREF,	0
		AYTYP,	0
		AYREF,	0

XASSIGNMENT,
	OFTAB;TYP	/J IS SET IN STATEMENT
	AND [77
	DCA AXTYP
	OFTAB;REF
	BSW
	AND [77
	DCA AXREF
	TAD LV
	DCA IRX
	TAD AD
	DCA IRY
	OFTAB;NORMAL
	AND [40
	SNA CLA
	IAC
	DCA .+2
	EMIT;00		/*** (0,LV,AD) OR (1,LV,AD) ***/
	SKIPIFSYIN;SET22
	JMP .+5
	PUSHJUMP;SELECTOR
	FSYS+SET29
	AXTYP

	IFSY;BECOMES;JMP .+5
	ERROR;63	/51
	IFSY;EQL;INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS
	AYTYP

	TAD AXTYP
	CIA
	TAD AYTYP
	SZA CLA
	JMP ASS1
	TAD AXTYP
	TAD [-ARRAY
	SPA CLA
	JMP ASS2-2
	TAD AXREF	/ARRAY- OR RECORD-VARIABLE
	CIA
	TAD AYREF
	SZA CLA
	JMP ASSERR
	TAD AXTYP
	TAD [-ARRAY
	SZA CLA
	JMP .+5
	TAD AXREF	/ARRAY
	OFATAB;SIZE
	JMP .+4
	TAD AXREF	/RECORD
	OFBTAB;VSIZE
	DCA IRY
	EMIT;27		/*** (23,SIZE) ***/
	JMP ASS2
ASS1,	L7776		/2=REALS
	TAD AXTYP
	SZA CLA
	JMP ASS3
	L7777		/1=INTS
	TAD AYTYP
	SZA CLA
	JMP ASS3
	EMIT;32		/*** (26,0) ***/
	EMIT;46		/*** (38) ***/
ASS2,	POPJUMP;ASSIGNMENT

ASS3,	TAD AXTYP
	SZA CLA
	TAD AYTYP
	SZA CLA
ASSERR,	ERROR;56	/46
	JMP ASS2
/PROCEDURE	C O M P O U N D S T A T E M E N T
/		---------------------------------
/
/CALL:		PUSHJUMP;COMPOUNDSTATEMENT	/NO ARG'S!
/
/NO LOCAL VAR'S!

XCOMPOUNDSTATEMENT,
	INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS+SET30

	SKIPIFSYIN;SET31
	JMP CMP1
	IFSY;SEMICOLON;JMP XCOMPOUNDSTATEMENT
	ERROR;16	/14
	JMP XCOMPOUNDSTATEMENT+1
CMP1,	IFSY;ENDSY;JMP .+4
	ERROR;71	/57
	SKP
	INSYMBOL
	POPJUMP;COMPOUNDSTATEMENT

	PAGE
/PROCEDURE	C A S E L A B E L
/		-----------------
/
/CALL:		JMS CASELABEL		/NOT RECURSIVE!
/
/LOCAL VAR'S:
		LAB,	ZBLOCK 5

CASELABEL, 0
	PUSHJUMP;CONSTANT
	FSYS+SET6
	LAB

	TAD LAB
	CIA
	TAD I CCXTYP
	SZA CLA
	JMP LABERR
	TAD I CCI
	DCA XR11
	TAD XR11
	TAD CLIMIT
	SNA CLA
FATALC,	FATAL		/TOO MUCH CASE-LABELS!
	SIGNEDINTEGER;LAB
	DCA TEMP
	TAD TEMP
	DCA I XR11
	TAD LC
	DCA I XR11
	TAD XR11
	DCA I CCI
	TAD CTABM1
	DCA XR11
	TAD I XR11
	ISZ XR11
	CIA
	TAD TEMP
	SZA CLA
	JMP .-5
	TAD XR11
	CIA
	TAD I CCI
	SZA CLA
	ERROR;1		/1
	JMP I CASELABEL
LABERR,	ERROR;57	/47
	JMP I CASELABEL
CCI,	CI
CCXTYP,	CXTYP
CLIMIT,	-2^CSMAX-CASETAB+1
CTABM1,	CASETAB-1
/PROCEDURE	C A S E S T A T E M E N T
/		-------------------------
/
/CALL:		PUSHJUMP;CASESTATEMENT		/NO ARG'S!
/
/LOCAL VAR'S:
		CASETAB, ZBLOCK CSMAX^2
		EXITTAB, ZBLOCK CSMAX
		CXTYP,	0
		CXREF,	0
		CLC1,	0
		CI,	0
		CJ,	0

XCASESTATEMENT, INSYMBOL
	TAD (CASETAB-1
	DCA CI
	TAD (EXITTAB-1
	DCA CJ
	PUSHJUMP;EXPRESSION
	FSYS+SET34
	CXTYP

	L7776		/2=REALS
	TAD CXTYP
	SNA
	JMP .+3
	TAD [-2		/2+2=4=CHARS (LAST STANTYP)
	SMA SZA CLA
	ERROR;27	/23
	TAD LC
	DCA CLC1
	EMIT;14		/*** (12) ***/
	IFSY;OFSY;JMP CAS1
	ERROR;10	/8
	SKP
CAS1,	INSYMBOL
	PUSHJUMP;ONECASE
	IFSY;SEMICOLON;JMP CAS1
	TAD CLC1
	TOCODE
	TAD (CASETAB-1
	DCA XR11
CAS2,	TAD XR11
	CIA
	TAD CI
	SNA CLA
	JMP CAS3
	TAD I XR11
	DCA IRY
	EMIT;15		/*** (13) ***/
	JMP CAS2
CAS3,	EMIT;12		/*** (10) ***/
	TAD (EXITTAB-1
	DCA XR11
CAS4,	TAD XR11
	CIA
	TAD CJ
	SNA CLA
	JMP CAS5
	TAD I XR11
	TOCODE
	JMP CAS4
CAS5,	IFSY;ENDSY;JMP .+4
	ERROR;71	/57
	SKP
	INSYMBOL
	POPJUMP;CASESTATEMENT
/PROCEDURE	O N E C A S E
/		-------------
/
/CALL:		PUSHJUMP;ONECASE	/NO ARG'S!
/
/NO LOCAL VAR'S! (USES SOME VAR'S OF 'CASESTATEMENT')

XONECASE, SKIPIFSYIN;CONBGS
	JMP ONE2
	SKP
ONE1,	INSYMBOL
	JMS CASELABEL
	IFSY;COMMA;JMP ONE1
	IFSY;COLON;JMP .+4
	ERROR;5		/5
	SKP
	INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS+SET30

	ISZ CJ
	TAD LC
	DCA I CJ
	EMIT;12		/*** (10) ***/
ONE2,	POPJUMP;ONECASE

	PAGE
/PROCEDURE	I F S T A T E M E N T
/		---------------------
/
/CALL:		PUSHJUMP;IFSTATEMENT		/NO ARG'S!
/
/LOCAL VAR'S:
		IXTYP,	0
		IXREF,	0
		ILC1,	0
		ILC2,	0

XIFSTATEMENT,
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET32
	IXTYP

	TAD IXTYP
	SNA
	JMP .+5
	TAD [-BOOLS
	SZA CLA
	ERROR;21	/17
	TAD LC
	DCA ILC1
	EMIT;13		/*** (11) ***/
	IFSY;THENSY;JMP .+5
	ERROR;64	/52
	IFSY;DOSY;INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS+SET33

	IFSYNOT;ELSESY;JMP IF1
	INSYMBOL
	TAD LC
	DCA ILC2
	EMIT;12		/*** (10) ***/
	TAD ILC1
	TOCODE		/*** CODE[ILC1] := LC ***/
	PUSHJUMP;STATEMENT
	FSYS

	TAD ILC2
	TOCODE		/*** CODE[ILC2] := LC ***/
	POPJUMP;IFSTATEMENT
IF1,	TAD ILC1
	JMP .-4		/*** CODE[ILC1] := LC ***/
/PROCEDURE	R E P E A T S T A T E M E N T
/		-----------------------------
/
/CALL:		PUSHJUMP;REPEATSTATEMENT	/NO ARG'S!
/
/LOCAL VAR'S:
		RXTYP,	0
		RXREF,	0
		RLC1,	0

XREPEAT,TAD LC
	DCA RLC1
	INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS+SET35

	SKIPIFSYIN;SET31
	JMP REP1
	IFSY;SEMICOLON;JMP XREPEAT+2
	ERROR;16	/14
	JMP XREPEAT+3
REP1,	IFSYNOT;UNTILSY;JMP REPERR
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS
	RXTYP

	TAD RXTYP
	SNA
	JMP .+5
	TAD [-BOOLS
	SZA CLA
	ERROR;21	/17
	TAD RLC1
	DCA IRY
	EMIT;13		/*** (11,RLC1) ***/
	JMP .+3
REPERR,	ERROR;65	/53
	POPJUMP;REPEATSTATEMENT
/PROCEDURE	W H I L E S T A T E M E N T
/		---------------------------
/
/CALL:		PUSHJUMP;WHILESTATEMENT		/NO ARG'S!
/
/LOCAL VAR'S (ON PAGE ZERO!):
/		WXTYP,	0
/		WXREF,	0
/		WLC1,	0
/		WLC2,	0

XWHILESTATEMENT,
	INSYMBOL
	TAD LC
	DCA WLC1
	PUSHJUMP;EXPRESSION
	FSYS+SET36
	WXTYP

	TAD WXTYP
	SNA
	JMP .+5
	TAD [-BOOLS
	SZA CLA
	ERROR;21	/17
	TAD LC
	DCA WLC2
	EMIT;13		/*** (11) ***/
	IFSY;DOSY;JMP .+4
	ERROR;66	/54
	SKP
	INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS

	TAD WLC1
	DCA IRY
	EMIT;12		/*** (10,WLC1) ***/
	TAD WLC2
	TOCODE		/*** CODE[WLC2] := LC ***/
	POPJUMP;WHILESTATEMENT

	PAGE
/PROCEDURE	F O R S T A T E M E N T
/		-----------------------
/
/CALL:		PUSHJUMP;FORSTATEMENT		/NO ARG'S!
/
/LOCAL VAR'S:
		FXTYP,	0
		FXREF,	0
		CVT,	0
		FLC1,	0
		FLC2,	0
		FF,	0

XFORSTATEMENT,
	INSYMBOL
	IFSYNOT;IDENT;JMP FOR2
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP FOR1+2
	WITHTABDO
	L7777		/1=VARIABLE
	TAD OBJ0
	SZA CLA
	JMP FOR1
	TAD TYP0
	DCA CVT
	TAD LEV0
	DCA IRX
	TAD ADR0
	DCA IRY
	EMIT;0		/*** (0,LEV,ADR) ***/
	L7776		/2=REALS
	TAD CVT
	SNA
	JMP .+3
	TAD [-2		/2+2=4=CHARS (LAST STANTYP)
	SMA SZA CLA
	ERROR;22	/18
	JMP FOR3
FOR1,	ERROR;45	/37
	L0001		/1=INTS
	DCA CVT
	JMP FOR3
FOR2,	SKIP;FSYS+SET37;2	/2
FOR3,	IFSYNOT;BECOMES;JMP FOR4
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET38
	FXTYP

	TAD FXTYP
	CIA
	TAD CVT
	SZA CLA
	ERROR;23	/19
	JMP FOR5
FOR4,	SKIP;FSYS+SET38;63	/51
FOR5,	TAD (16		/14
	DCA FF
	SKIPIFSYIN;SET39
	JMP FOR6
	IFSY;DOWNTOSY;L0002
	TAD (16
	DCA FF
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET36
	FXTYP

	TAD FXTYP
	CIA
	TAD CVT
	SZA CLA
	ERROR;23	/19
	JMP FOR7
FOR6,	SKIP;FSYS+SET36;67	/55
FOR7,	TAD LC
	DCA FLC1
	TAD FF
	DCA .+2
	EMIT;00		/*** (14) OR (16) ***/
	IFSY;DOSY;JMP .+4
	ERROR;66	/54
	SKP
	INSYMBOL
	TAD LC
	DCA FLC2
	PUSHJUMP;STATEMENT
	FSYS

	TAD FLC2
	DCA IRY
	L0001
	TAD FF
	DCA .+2
	EMIT;00		/*** (15,FLC2) OR (17,FLC2) ***/
	TAD FLC1
	TOCODE		/*** CODE[FLC1] := LC ***/
	POPJUMP;FORSTATEMENT

	PAGE
/PROCEDURE	S T A N D P R O C
/		-----------------
/
/CALL:		PUSHJUMP;STANDPROC
/		I	/VALUE
/
/LOCAL VAR'S:
		PRCN,	0
		SPXTYP,	0
		SPXREF,	0
		SPYTYP,	0
		SPYREF,	0

XSTPROC,TAD PRCN
	TAD (JMP I STPRTAB-1
	DCA .+1
	HLT

STPRTAB,SPREAD
	SPREAD
	SPWRITE
	SPWRITE
	SPHALT
	SPASCII

SPREAD,	IFSYNOT;LPARENT;JMP SPR3
SPR1,	INSYMBOL
	IFSY;IDENT;JMP .+4
	ERROR;2		/2
	JMP SPR2
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP SPR2
	WITHTABDO
	L7777		/1=VARIABLE
	TAD OBJ0
	SNA CLA
	JMP .+4
	ERROR;45	/37
	JMP SPR2
	TAD TYP0
	DCA SPXTYP
	TAD REF0
	DCA SPXREF
	TAD LEV0
	DCA IRX
	TAD ADR0
	DCA IRY
	TAD NORM0
	SNA CLA
	IAC
	DCA .+2
	EMIT;00		/*** (0,LEV,ADR) OR (1,LEV,ADR) ***/
	SKIPIFSYIN;SET22
	JMP .+5
	PUSHJUMP;SELECTOR
	FSYS+SET24
	SPXTYP

	L7775		/3=BOOLS
	TAD SPXTYP
	SNA
	JMP SPR2-2
	TAD (-1		/4=CHARS (LAST STANTYP)
	SMA SZA CLA
	JMP SPR2-2
	TAD SPXTYP
	DCA IRY
	EMIT;33		/*** (27,TYP) ***/
	JMP SPR2
	ERROR;50	/40
SPR2,	TEST;SET24;FSYS;6	/6
	IFSY;COMMA;JMP SPR1
	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
SPR3,	L7776		/-2
	TAD PRCN
	SNA CLA
	EMIT;76		/*** (62) ***/
	POPJUMP;STANDPROC
SPASCII,IFSYNOT;LPARENT;JMP SPASC2
SPASC1,	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET24
	SPXTYP

	L7777		/1=INTS
	TAD SPXTYP
	SZA CLA
	ERROR;53	/43
	EMIT;75		/*** (61) ***/
	IFSY;COMMA;JMP SPASC1
	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
SPASC2,	POPJUMP;STANDPROC


SPHALT,	EMIT;45		/*** (37) ***/
	POPJUMP;STANDPROC

	PAGE
SPWRITE,IFSYNOT;LPARENT;JMP SPW5
SPW1,	INSYMBOL
	IFSYNOT;STRING;JMP SPW2
	TAD SLENG
	DCA IRY
	EMIT;30		/*** (24,SLENG) ***/
	TAD NUM+3
	DCA STRNUM
	INSYMBOL
	IFSYNOT;COLON;JMP SPW1A
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET24
	SPYTYP

	L7777		/1=INTS
	TAD SPYTYP
	SZA CLA
	ERROR;53	/43
	JMP .+3
SPW1A,	EMIT;30		/*** (24,0) ***/
	TAD STRNUM
	DCA IRY
	EMIT;34		/*** (28,NUM) ***/
	JMP SPW4
STRNUM,	0

SPW2,	PUSHJUMP;EXPRESSION
	FSYS+SET23
	SPXTYP

	TAD SPXTYP
	TAD [-CHARS
	SMA SZA CLA
	ERROR;51	/41
	IFSYNOT;COLON;JMP SPW3+1
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET23
	SPYTYP

	L7777	/1=INTS
	TAD SPYTYP
	SZA CLA
	ERROR;53	/43
	IFSYNOT;COLON;JMP SPW3
	L7776		/2=REALS
	TAD SPXTYP
	SZA CLA
	ERROR;52	/42
	INSYMBOL
	PUSHJUMP;EXPRESSION
	FSYS+SET24
	SPYTYP

	L7777	/1=INTS
	TAD SPYTYP
	SZA CLA
	ERROR;53	/43
	EMIT;37		/*** (31) ***/
	JMP SPW4
SPW3,	L0001
	TAD (35
	DCA .+4
	TAD SPXTYP
	DCA IRY
	EMIT;00		/*** (29,TYP) OR (30,TYP) ***/
SPW4,	IFSY;COMMA;JMP SPW1
	IFSY;RPARENT;JMP .+4
	ERROR;4		/4
	SKP
	INSYMBOL
SPW5,	TAD PRCN
	TAD [-4
	SNA CLA
	EMIT;77		/*** (63) ***/
	POPJUMP;STANDPROC

	PAGE
/PROCEDURE	S T A T E M E N T
/		-----------------
/
/CALL:		PUSHJUMP;STATEMENT
/		SETX
/
/NO LOCAL VAR'S!
XSTATEMENT,
	SKIPIFSYIN;SET40
	JMP STAT2
	IFSYNOT;IDENT;JMP STAT1
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP STAT2
	WITHTABDO
	TAD OBJ0
	TAD  JMPOBJ
	DCA .+1
	HLT

OBJTABL,IDCON
	IDVAR
	IDTYP
	IDPRO
	IDFUN

JMPOBJ,	JMP I OBJTABL

IDCON,
IDTYP,	ERROR;55	/45
	JMP STAT2

IDVAR,	TAD LEV0
	DCA .+5
	TAD ADR0
	DCA .+4
	PUSHJUMP;ASSIGNMENT
	0
	0
	JMP STAT2

IDPRO,	TAD LEV0
	SNA CLA
	JMP IDPRO1
	TAD J
	DCA .+4
	PUSHJUMP;CALL
	FSYS
	0
	JMP STAT2

IDPRO1,	TAD ADR0
	DCA .+3
	PUSHJUMP;STANDPROC
	0
	JMP STAT2

IDFUN,	OFDISPLAY
	CIA
	TAD REF0
	SZA CLA
	JMP IDTYP
	L0001
	TAD LEV0
	DCA .+3
	PUSHJUMP;ASSIGNMENT
	0
	0000	/ALWAYS 0!
	JMP STAT2

STAT1,	TAD SY
	TAD STATNO
	DCA .+2
	PUSHJUMP;00
STAT2,	TEST;FSYS;SET0;16	/14
	POPJUMP;STATEMENT

STATNO,	COMPOUNDSTATEMENT-BEGINSY
/PROCEDURE	B L O C K
/		---------
/
/CALL:		PUSHJUMP;BLOCK
/		SETX
/		ISFUN	/VALUE
/		LEVEL	/VALUE
/
/LOCAL VAR'S (ON PAGE ZERO!):
/		FSYS
/		ISFUN,	0
/		LEVEL,	0
/		DX,	0
/		PRT,	0
/		PRB,	0

MAXLEV,	-LMAX		/CONSTANT
TOFAT5,	FATAL5
C0005,	5
BLK1,	BLO1
BLK2,	BLO2
BLK2M2,	BLO2-2

XBLOCK,	TAD C0005
	DCA DX
	TAD T
	DCA PRT
	TAD LEVEL
	TAD MAXLEV
	SMA SZA CLA
	JMP I TOFAT5	/TOO MUCH LEVELS!
	TEST;SET41;FSYS;7	/7
	ENTERBLOCK
	TAD B
	TODISPLAY
	TAD B
	DCA PRB
	TAD PRT
	WITHTABDO
	DCA TYP0	/0=NOTYP
	TAD PRB
	DCA REF0
	ENDWITH
	IFSY;LPARENT;PUSHJUMP;PARAMETERLIST
	TAD PRB
	DCA JB
	TAD T
	TOBTAB;LASTPAR
	TAD DX
	TOBTAB;PSIZE
	TAD ISFUN
	SNA CLA
	JMP I BLK2
	IFSYNOT;COLON;JMP I BLK2M2
	INSYMBOL
	IFSYNOT;IDENT;JMP I BLK1
	LOCATE
	DCA J
	INSYMBOL
	TAD J
	SNA CLA
	JMP BLO2
	OFTAB;OBJ
	BSW
	AND [77
	TAD [-2		/2=TYPE1
	SNA CLA
	JMP .+4
	ERROR;35	/29
	JMP BLO2
	OFTAB;TYP
	AND [77
	DCA TEMP
	TAD TEMP
	TAD [-4
	SPA SNA CLA
	JMP .+4
	ERROR;17	/15
	JMP BLO2
	TAD PRT
	DCA J
	L0003	/3=PROZEDURE
	TAD ISFUN
	BSW
	TAD TEMP
	TOTAB;TYP
	JMP BLO2
BLO1,	SKIP;FSYS+SET20;2	/2
	JMP BLO2
	ERROR;5		/5
BLO2,	IFSY;SEMICOLON;JMP .+4
	ERROR;16	/14
	SKP
	INSYMBOL
BLO3,	IFSY;CONSTSY;PUSHJUMP;CONDECL
	IFSY;TYPESY;PUSHJUMP;TYPDECL
	IFSY;VARSY;PUSHJUMP;VARDECL
	TAD PRB
	DCA JB
	TAD DX
	TOBTAB;VSIZE
BLO4,	SKIPIFSYIN;SET42
	JMP .+4
	PUSHJUMP;PRODECL
	JMP BLO4
	TEST;SET43;SET44;70	/56
	SKIPIFSYIN;STATBGS
	JMP BLO3
	TAD PRT
	DCA J
	TAD LC
	TOTAB;ADR
BLO5,	INSYMBOL
	PUSHJUMP;STATEMENT
	FSYS+SET30
	SKIPIFSYIN;SET31
	JMP BLO6
	IFSY;SEMICOLON;JMP BLO5
	ERROR;16	/14
	JMP BLO5+1
BLO6,	IFSY;ENDSY;JMP .+4
	ERROR;71	/57
	SKP
	INSYMBOL
	TEST;FSYS+SET45;SET0;6		/6
	POPJUMP;BLOCK

	PAGE
/M A C R O - I N S T R U C T I O N S :


/P U S H J U M P	/RECURSIVE CALL OF COMPILER PROCEDURES
			/CALL:	PUSHJUMP;NAME
/P O P J U M P		/RETURN FROM PROCEDURE
			/CALL:	POPJUMP;NAME


/LOCAL,	0	/START OF LOCAL VARIABLES - 1
/LENGTH,	0	/ - NO. OF LOC'S TO PUSH (EXCL. FSYS)
/PARAM,	0	/NO. OF PARAMETERS + 4000 (IF 1ST ONE IS A SET)
PSTART,	0	/STARTING ADDRESS OF PROCEDURE

PPP,	0	/STACK POINTER (POINTS ALWAYS TO 1ST FREE LOC.)


CONTROL,0
	CLL RTL
	TAD (PUSHTABLE-1
	DCA XR10
	CDF SETFIELD
	TAD I XR10
	DCA LOCAL
	TAD I XR10
	DCA LENGTH
	TAD I XR10
	DCA PARAM
	TAD I XR10
	DCA PSTART
	CDF COMPFIELD
	JMP I CONTROL

PUSH,	0
	CDF PUSHFIELD
	DCA I PPP
	CDF COMPFIELD
	ISZ PPP
	JMP I PUSH
FATAL8,	FATAL		/PROGRAMM TOO COMPLEX ---> STACK FULL!

POP,	0
	L7777
	TAD PPP
	DCA PPP
	CDF PUSHFIELD
	TAD I PPP
	CDF COMPFIELD
	JMP I POP

XPUSHJ,	0
	TAD I XPUSHJ
	ISZ XPUSHJ
	JMS CONTROL
	TAD LENGTH
	SNA CLA
	JMP PUFSYS
	TAD LOCAL
	DCA XR10
	TAD I XR10
	JMS PUSH	/PUSH LOCAL VARIABLES (IF ANY)
	ISZ LENGTH
	JMP .-3
PUFSYS,	TAD PARAM
	SMA CLA
	JMP GETPAR
	L3777		/FSYS-1
	DCA XR10
	TAD [-5
	DCA LENGTH
	CDF SETFIELD
	TAD I XR10
	JMS PUSH	/PUSH FSYS (IF NECESSARY)
	ISZ LENGTH
	JMP .-4
GEFSYS,	L4000		/GET SET-ARGUMENT (IF PRESENT)
	DCA SETA
	TAD I XPUSHJ
	SPA
	DCA SETA	/<0:  FSYS  OR  SETX  ONLY
	TAD SETA	/>0:  FSYS+SETX
	DCA SETB
	ISZ XPUSHJ
	UNION
SETA,	FSYS
SETB,	SET0
	FSYS
GETPAR,	TAD PARAM	/GET PARAMETERS
	AND [77
	SNA
	JMP RECALL
	CIA
	DCA LENGTH
	TAD LOCAL
	DCA XR10
	TAD I XPUSHJ
	ISZ XPUSHJ
	DCA I XR10
	ISZ LENGTH
	JMP .-4
	JMS VARIN	/PASS VAR-PARAMETERS (IF ANY)
RECALL,	TAD XPUSHJ
	JMS PUSH	/PUSH RETURN ADDRESS
	JMP I PSTART	/AND   J U M P  TO PROCEDURE

XPOPJUMP,0
	TAD I XPOPJUMP
	JMS CONTROL
	JMS POP		/GET RETURN ADDRESS
	DCA PSTART
	TAD PARAM
	SMA CLA
	JMP POVAR
	TAD (FSYS+4
	DCA PUSH	/(MIS)USE THIS FREE LOC.
	TAD [-5
	DCA CONTROL
	JMS POP		/POP FSYS (IF IT WAS PUSHED)
	CDF SETFIELD
	DCA I PUSH
	L7777
	TAD PUSH
	DCA PUSH
	ISZ CONTROL
	JMP .-7
	CDF COMPFIELD
POVAR,	JMS VARTM	/TEMP. STORE VAR-PARAMETERS
	TAD LENGTH
	SNA
	JMP I PSTART
	CIA
	TAD LOCAL
	DCA PUSH
	JMS POP		/POP LOCAL VARIABLES (IF ANY)
	DCA I PUSH
	L7777
	TAD PUSH
	DCA PUSH
	ISZ LENGTH
	JMP .-6
	JMS VAREX	/PASS VAR-PARAMETERS (IF ANY)
	JMP I PSTART	/R E T U R N

	PAGE
/M A C R O - I N S T R U C T I O N S :


/O F D I S P L A Y	/AC := DISPLAY[LEVEL]

/T O D I S P L A Y	/DISPLAY[LEVEL] := AC

/O F T A B		/AC := TAB[AC].SEL, IF AC=0 GET TAB[J].SEL

/T O T A B		/TAB[J].SEL := AC

/O F A T A B		/AC := ATAB[AC].SEL, IF AC=0 GET ATAB[JA].SEL

/T O A T A B		/ATAB[JA].SEL := AC

/O F B T A B		/AC := BTAB[AC].SEL, IF AC=0 GET BTAB[JB].SEL

/T O B T A B		/BTAB[JB].SEL := AC

/W I T H T A B D O	/GET AND UNPACK  TAB[AC]  OR  TAB[J]

/E N D W I T H		/PACK AND STORE UNPACKED ENTRY OF TAB

XOFDISP,0
	TAD (DISPLAY
	TAD LEVEL
	DCA QQ
	TAD I QQ
	JMP I XOFDISP

XTODISP,0
	MQL
	TAD (DISPLAY
	TAD LEVEL
	DCA QQ
	MQA
	DCA I QQ
	JMP I XTODISP

XOFTAB,	0
	SNA
	TAD J
	CLL RTL
	TAD I XOFTAB
	DCA QQ
	ISZ XOFTAB
	CDF TABLEFIELD
	TAD I QQ
	CDF COMPFIELD
	JMP I XOFTAB

XTOTAB,	0
	MQL
	TAD J
	CLL RTL
	TAD I XTOTAB
	DCA QQ
	ISZ XTOTAB
	CDF TABLEFIELD
	MQA
	DCA I QQ
	CDF COMPFIELD
	JMP I XTOTAB

XOFATAB,0
	SNA
	TAD JA
	CLL RAL
	CLL RTL
	TAD I XOFATAB
	DCA QQ
	ISZ XOFATAB
	CDF TABLEFIELD
	TAD I QQ
	CDF COMPFIELD
	JMP I XOFATAB

QQ=.
XTOATAB,0
	MQL
	TAD XTOATAB
	DCA XTOTAB
	TAD JA
	CLL RAL
	JMP XTOTAB+3

XOFBTAB,0
	SNA
	TAD JB
	CLL RTL
	TAD I XOFBTAB
	DCA QQ
	ISZ XOFBTAB
	CDF TABLEFIELD
	TAD I QQ
	CDF COMPFIELD
	JMP I XOFBTAB

XTOBTAB,0
	MQL
	TAD XTOBTAB
	DCA XTOTAB
	TAD JB
	JMP XTOTAB+3

XWITHTAB,0
	SNA
	TAD J
	CLL RTL
	DCA JW		/SYMBOL TABLE STARTS AT 0000 !
	TAD JW
	DCA XR10
	CDF TABLEFIELD
	TAD I JW
	DCA LINK0
	TAD I XR10
	MQL
	MQA
	BSW
	AND [77
	DCA OBJ0
	MQA
	AND [77
	DCA TYP0
	TAD I XR10
	MQL
	MQA
	BSW
	AND [77
	DCA REF0
	MQA
	AND [40
	DCA NORM0
	MQA
	AND [17
	DCA LEV0
	TAD I XR10
	DCA ADR0
	CDF COMPFIELD
	JMP I XWITHTAB

XENDWITH,0
	TAD JW
	DCA XR10
	CDF TABLEFIELD
	TAD LINK0
	DCA I JW
	TAD OBJ0
	BSW
	TAD TYP0
	DCA I XR10
	TAD REF0
	BSW
	TAD NORM0
	TAD LEV0
	DCA I XR10
	TAD ADR0
	DCA I XR10
	CDF COMPFIELD
	JMP I XENDWITH

	PAGE
/M A C R O - I N S T R U C T I O N S :

/W I T H A T A B D O	/GET AND UNPACK  ATAB[JA]

/E N D A W I T H	/PACK AND STORE UNPACKED ENTRY OF ATAB

/E M I T		/EMIT INTERMEDIATE CODE (F,IRX,IRY)
			/CALL:	EMIT;F

/T O C O D E		/CODE[AC].IRY := LC

/E N T E R C O N S T A N T   /ENTER REAL OR INTEGER INTO CONSTANT TABLE
			/CALL:	ENTERCONSTANT;ADDRESS-1


XWITHATAB,0
	TAD JA
	CLL RAL
	CLL RTL
	TAD (ATAB
	DCA JAW
	TAD JAW
	DCA XR10
	TAD [-7
	DCA QR
	TAD (DCA INXTP0
	DCA .+3
	CDF TABLEFIELD
	TAD I XR10
	0000	/DCA INXTP0 (MODIFIED INSTR.!)
	ISZ .-1
	ISZ QR
	JMP .-4
	CDF COMPFIELD
	JMP I XWITHATAB

XENDAW,	0
	TAD JAW
	DCA XR10
	TAD [-7
	DCA QR
	TAD (TAD INXTP0
	DCA .+2
	CDF TABLEFIELD
	0000	/TAD INXTP0 (MODIFIED INSTR.!)
	DCA I XR10
	ISZ .-2
	ISZ QR
	JMP .-4
	CDF COMPFIELD
	JMP I XENDAW

XEMIT,	0
	TAD LC
	CLL RAL
	DCA XTOCODE
	TAD I XEMIT	/GET OP-CODE
	BSW
	TAD IRX
	CDF CODEFIELD
	DCA I XTOCODE
	ISZ XTOCODE
	TAD IRY
	DCA I XTOCODE
	CDF COMPFIELD
	ISZ LC
	TAD LC
	TAD (-CMAX
	SMA SZA CLA
FATAL6,	FATAL		/PROGRAM TOO LONG!
	DCA IRX
	DCA IRY
	JMP I XEMIT

QR=.
XTOCODE,0
	STL RAL
	DCA XEMIT
	CDF CODEFIELD
	TAD LC
	DCA I XEMIT
	CDF COMPFIELD
	JMP I XTOCODE

CENTRY=XWITHATAB
CTEMP=XENDAW
FOUR=XEMIT

XENTCON,0
	TAD I XENTCON
	DCA XR10
	ISZ XENTCON
	TAD C
	TAD [-4
	DCA CENTRY
	TAD SX
	STL RAR
	CIA
	TAD CENTRY
	SPA CLA
FATAL3,	FATAL		/TOO MUCH CONSTANTS!
	TAD [-4
	DCA FOUR
	TAD CENTRY
	DCA XR12
	TAD I XR10
	CDF TABLEFIELD
	DCA I XR12
	CDF COMPFIELD
	ISZ FOUR
	JMP .-5
	TAD CENTRY
	DCA CTEMP
	CDF TABLEFIELD
SEARCH,	L0004
	TAD CTEMP
	DCA CTEMP
	TAD CTEMP
	TAD (-ATAB+1
	SMA CLA
	JMP NOTFOUND
	TAD [-4
	DCA FOUR
	TAD CENTRY
	DCA XR10
	TAD CTEMP
	DCA XR12
	TAD I XR10
	CIA
	TAD I XR12
	SZA CLA
	JMP SEARCH
	ISZ FOUR
	JMP .-6
	TAD CTEMP	/FOUND
	JMP .+4
NOTFOUND,TAD CENTRY
	DCA C
	TAD CENTRY
	CDF COMPFIELD
	JMP I XENTCON

	PAGE
/M A C R O - I N S T R U C T I O N S :


/E N T E R		/ENTER OBJEJT INTO SYMBOL TABLE
			/CALL:	ENTER;OBJ

/E N T E R V A R I A B L E

/E N T E R B L O C K

/E N T E R A R R A Y

/S I G N E D I N T E G E R   /MAKE 12-BIT SIGNED INTEGER OF CONSTANT
			/CALL:	SIGNEDINTEGER;ADDRESS-1


XENTER,	0
	TAD T
	TAD (-TMAX
	SMA CLA
FATAL1,	FATAL		/SYMBOL TABLE FULL!
	JMS ENTID
	OFDISPLAY
	OFBTAB;LAST
	DCA J
	TAD J
	DCA L
	JMS CHKID
	JMP .+5
	OFTAB;LINK
	DCA J
	JMP .-5
	TAD J
	SNA CLA
	JMP .+4
	ERROR;1		/1
	JMP I XENTER
	ISZ T
	TAD T
	JMS ENTID
	TAD I XENTER
	MQL
	L3777
	TAD T
	STL RTL		/4*T - 1
	DCA XR10
	CDF TABLEFIELD
	TAD L		/LINK
	DCA I XR10
	MQA
	BSW		/OBJ, TYP (0=NOTYP)
	DCA I XR10
	TAD LEVEL	/REF=0, NORMAL=0, LEVEL
	DCA I XR10
	DCA I XR10	/ADR=0
	CDF COMPFIELD
	OFDISPLAY
	DCA JB
	TAD T
	TOBTAB;LAST
	JMP I XENTER

XENTVAR,0
	IFSY;IDENT;JMP .+4
	ERROR;2		/2
	JMP I XENTVAR
	ENTER;VARIABLE
	INSYMBOL
	JMP I XENTVAR

XENTBLO,0
	TAD B
	TAD (-BMAX
	SMA CLA
FATAL2,	FATAL		/TOO MUCH BLOCKS!
	ISZ B
	TAD B
	DCA JB
	TOBTAB;LAST
	TOBTAB;LASTPAR
	JMP I XENTBLO

ATP=XENTBLO
XENTARR,0
	DCA ATP
	TAD LO
	CIA
	TAD HI
	SPA CLA
	ERROR;33	/27
	TAD A
	TAD (-AMAX
	SMA CLA
FATAL4,	FATAL
	ISZ A
	TAD A
	DCA JA
	TAD ATP
	TOATAB;INXTYP
	TAD LO
	TOATAB;LOW
	TAD HI
	TOATAB;HIGH
	JMP I XENTARR

XSGNINT,0
	L0001		/LINK=0!
	TAD I XSGNINT
	ISZ XSGNINT
	DCA XR10
	TAD I XR10
	SZA
	TAD [4000	/LINK=1? ---> NEGATIVE
	SZA CLA
	JMP ERR49
	TAD I XR10
	SZA CLA
	JMP ERR49
	TAD I XR10
	SPA
	JMP ERR49
	SZL
	CIA
	JMP I XSGNINT
ERR49,	ERROR;61	/49
	JMP I XSGNINT

	PAGE
/--------  D I S P L A Y  --------/
/
	*7400
IFNZRO DISPLAY-. <PARALLEL DEFINED IN FIELD 0 AND FIELD 4 !!!>
	1		/DISPLAY[0] := 1
	ZBLOCK 17

/---------------------------------/


/M A C R O - I N S T R U C T I O N S :


/L O C A T E		/LOCATE IDENTIFIER IN SYMBOL TABLE
			/EXITS WITH TABLE INDEX IN AC

/E N T I D		/TAB[AC].NAME := ID

/C H K I D		/SKIP IF TAB[J].NAME <> ID

/G E T C O N S T A N T	/NUM := CTAB[AC]


XLOCATE,0
	TAD LEVEL
	DCA L
	JMS ENTID
NSCOPE,	TAD L
	TAD (TAD DISPLAY
	DCA .+1
	0000	/TAD DISPLAY (MODIFIED INSTR.!)
	OFBTAB;LAST
	DCA J
	JMS CHKID
	JMP .+5
	OFTAB;LINK
	DCA J
	JMP .-5
	L7777
	TAD L
	DCA L
	TAD J
	SZA
	JMP I XLOCATE
	TAD L
	SMA CLA
	JMP NSCOPE
	ERROR;0		0
	JMP I XLOCATE

ENTID,	0
	CLL RTL
	TAD (-1
	DCA XR10
	CDF NAMEFIELD
	TAD ID
	DCA I XR10
	TAD ID+1
	DCA I XR10
	TAD ID+2
	DCA I XR10
	TAD ID+3
	DCA I XR10
	CDF COMPFIELD
	JMP I ENTID

CHKID,	0
	TAD J
	CLL RTL
	TAD (-1
	DCA XR10
	CDF NAMEFIELD
	TAD I XR10
	CIA
	TAD ID
	SZA CLA
	JMP NOTEQL
	TAD I XR10
	CIA
	TAD ID+1
	SZA CLA
	JMP NOTEQL
	TAD I XR10
	CIA
	TAD ID+2
	SZA CLA
	JMP NOTEQL
	TAD I XR10
	CIA
	TAD ID+3
	SZA CLA
NOTEQL,	ISZ CHKID
	CDF COMPFIELD
	JMP I CHKID

XOFCONST,0
	DCA XR10
	CDF TABLEFIELD
	TAD I XR10
	DCA NUM
	TAD I XR10
	DCA NUM+1
	TAD I XR10
	DCA NUM+2
	TAD I XR10
	DCA NUM+3
	CDF COMPFIELD
	JMP I XOFCONST

XERROR,	0
	CLA CLL
	TAD I XERROR
	CIF SETFIELD
	JMS I (F3ERROR
	JMP I XERROR

XFATAL,	0
	TAD XFATAL
	CDF CIF SETFIELD
	JMP I (F3FATAL

XINSYMBOL,0
	CDF CIF 0
	JMP I (INSY0
EXSY3,	DCA SY
	JMP I XINSYMBOL

	PAGE
/M A C R O - I N S T R U C T I O N S :


/T E S T S E M I C O L O N

/S K I P		/CALL:	SKIP;SETX;N

/T E S T			/CALL:	TEST;SETX;SETY;N

/S K I P I F S Y I N		/CALL:	SKIPIFSYIN;SETX

/I F S Y			/CALL:	IFSY;SYMBOL

/I F S Y N O T			/CALL:	IFSYNOT;SYMBOL

/U N I O N			/CALL:	UNION;SET1;SET2;S1US2

XTSTSEM,0
	IFSY;SEMICOLON;JMP .+6
	ERROR;16	/14
	SKIPIFSYIN;SET6
	SKP
	INSYMBOL
	TEST;SET7;FSYS;6	/6
	JMP I XTSTSEM

XSKIP,	0
	TAD I XSKIP
	JMS FSYSUSETX
	DCA .+11
	ISZ XSKIP
	TAD I XSKIP
	DCA .+2
	ERROR;00	/N
	SKP
	INSYMBOL
	SKIPIFSYIN;00
	JMP .-3
	JMP I XSKIP

XTEST,	0
	TAD I XTEST
	JMS FSYSUSETX
	DCA .+3
	ISZ XTEST
	SKIPIFSYIN;00
	SKP
	JMP XTST1
	TAD .-3
	DCA S1
	TAD I XTEST
	JMS FSYSUSETX
	DCA S2
	ISZ XTEST
	UNION
S1,	0
S2,	0
	S1US2
	TAD I XTEST
	DCA .+3
	SKIP;S1US2;00		/N
XTST1,	ISZ XTEST
	JMP I XTEST

FSYSUSETX, 0
	SPA
	JMP I FSYSUSETX
	TAD [4000
	DCA .+3
	UNION
	FSYS
	0
	S1US2
	TAD .-1
	JMP I FSYSUSETX

INSET,	0
	TAD SY
	CLL RAL
	TAD (SETTABLE
	DCA S2
	TAD I INSET
	ISZ INSET
	CDF SETFIELD
	TAD I S2
	DCA S1		/ADDRESS OF RELATIVE SET WORD
	ISZ S2		/ADDRESS OF BIT POS. REL. TO SY
	TAD I S1
	AND I S2
	SZA CLA
	ISZ INSET
	CDF COMPFIELD
	JMP I INSET

XIFSY,	0
	TAD SY
	CIA
	TAD I XIFSY
	SZA CLA
	ISZ XIFSY
	ISZ XIFSY
	JMP I XIFSY

XIFSYNOT,0
	TAD SY
	CIA
	TAD I XIFSYNOT
	SNA CLA
	ISZ XIFSYNOT
	ISZ XIFSYNOT
	JMP I XIFSYNOT

XSA=XIFSY	/NORMAL LOC.
XSB=XR10	/AUTO INDEX
XSU=XR12	/  - " -
FIVE=XIFSYNOT

XUNION,	0
	TAD I XUNION
	DCA XSA
	ISZ XUNION
	L7777
	TAD I XUNION
	DCA XSB
	ISZ XUNION
	L7777
	TAD I XUNION
	DCA XSU
	ISZ XUNION
	TAD [-5
	DCA FIVE
	CDF SETFIELD
	TAD I XSA
	CMA
	AND I XSB
	TAD I XSA
	DCA I XSU
	ISZ XSA
	ISZ FIVE
	JMP .-7
	CDF COMPFIELD
	JMP I XUNION

	PAGE
/L O N G   E R R O R   M E S S A G E S

	FIELD 6
	*0

	ZBLOCK 73	/ERROR COUNTERS
	7777		/GUARD
ERRSUM,	0		/NUMBER OF DETECTED ERRORS

	*100		/ADDRESS LIST OF ERROR MESSAGES
	E00
	E01
	E02
	E03
	E04
	E05
	E06
	E07
	E08
	E09
	E10
	E11
	E12
	E13
	E14
	E15
	E16
	E17
	E18
	E19
	E20
	E21
	E22
	E23
	E24
	E25
	E26
	E27
	E28
	E29
	E30
	E31
	E32
	E33
	E34
	E35
	E36
	E37
	E38
	E39
	E40
	E41
	E42
	E43
	E44
	E45
	E46
	E47
	E48
	E49
	E50
	E51
	E52
	E53
	E54
	E55
	E56
	E57
	E58

	*200
EXPLAIN,CLA CLL
	TAD ERRSUM
	SNA CLA
	JMP EXCOMP
	JMS ECRLF
	JMS ECRLF
	TAD (EHEAD
	DCA ETEXT
	JMS EMESG
	JMS ECRLF
	JMS ECRLF
	DCA ENN
	SKP
ELINE,	ISZ ENN
	TAD I ENN
	SPA
	JMP EXOS8
	SNA CLA		/SKP CLA ---> PRINT ALL!
	JMP ELINE
	CLA IAC BSW	/L0100
	TAD ENN
	DCA ETEXT
	TAD I ETEXT
	DCA ETEXT
	JMS EMESG
	JMS ECRLF
	JMP ELINE

FXPLAIN,CLA CLL
	TAD ERRSUM
	SZA CLA
	JMP EXPLAIN+5
EXOS8,	CLA CLL
	JMS ECRLF
	CDF CIF 0
	JMP I (7605
ENN,	0

EXCOMP,	JMS ECRLF
	JMS ECRLF
	TAD (EOKAY
	DCA ETEXT
	JMS EMESG
	JMS ECRLF
	JMS ECRLF
	CDF CIF 60
	JMP I (INIT	/INITIALIZE RUNTIME SYSTEM

EPRINT,	0
	TLS
	TSF
	JMP .-1
	CLA CLL
	JMP I EPRINT

ECRLF,	0
	TAD (215
	JMS EPRINT
	TAD (212
	JMS EPRINT
	JMP I ECRLF

EMESG,	0
	TAD I ETEXT
	BSW
	JMS EASCII
	TAD I ETEXT
	JMS EASCII
	ISZ ETEXT
	JMP EMESG+1

EASCII,	0
	AND (77
	SNA
	JMP I EMESG
	TAD (240
	AND (77
	TAD (240
	JMS EPRINT
	JMP I EASCII
ETEXT,	0

EOKAY,	TEXT /KOMPILATION EINWANDFREI!/

EHEAD,	TEXT /ERKLAERUNG DER FEHLER:/

	PAGE

/L O N G   E R R O R   M E S S A G E S
/
/(MADE INVISIBLE BY 'XLIST' TO SAVE PAPER IN ASSEMBLY LISTING!)

XLIST

E00,TEXT / 0  DIESER NAME WURDE NICHT VEREINBART./
E01,TEXT / 1  NAME IM GUELTIGKEITSBEREICH MEHRFACH VEREINBART./
E02,TEXT / 2  NAME FEHLT!/
E03,TEXT / 3  JEDES PROGRAMM MUSS MIT DEM WORTSYMBOL 'PROGRAM' BEGINNE/
	*.-1
    TEXT /N./
E04,TEXT / 4  RUNDE RECHTSKLAMMER FEHLT (ECKIGE KLAMMER HIER FALSCH)./
E05,TEXT / 5  DOPPELPUNKT FEHLT. IN VEREINBARUNGEN FOLGT DEM : EIN TYP/
	*.-1
    TEXT /NAME./
E06,TEXT / 6  SYNTAXFEHLER! ANGEZEIGTES SYMBOL HIER NICHT KORREKT./
E07,TEXT / 7  LISTE DER FORMALPARAMETER FEHLERHAFT (NAME ODER WORTSYMB/
	*.-1
    TEXT /OL 'VAR')./
E08,TEXT / 8  DAS WORTSYMBOL 'OF' FEHLT./
E09,TEXT / 9  RUNDE LINKSKLAMMER FEHLT (ECKIGE KLAMMER HIER FALSCH)./
E10,TEXT /10  TYPVEREINBARUNG FEHLERHAFT (NAME, 'ARRAY' ODER 'RECORD')./
E11,TEXT /11  ECKIGE LINKSKLAMMER FEHLT (RUNDE KLAMMER HIER FALSCH)./
E12,TEXT /12  ECKIGE RECHTSKLAMMER FEHLT (RUNDE KLAMMER HIER FALSCH)./
E13,TEXT /13  SYMBOL .. FEHLT (LEERZEICHEN ZWISCHEN DEN PUNKTEN UNZULA/
	*.-1
    TEXT /ESSIG)./
E14,TEXT /14  STRICHPUNKT FEHLT!/
E15,TEXT /15  FUNKTIONSWERT KANN NUR VOM TYP INTEGER, REAL, BOOLEAN OD/
	*.-1
    TEXT /ER CHAR SEIN./
E16,TEXT /16  SYMBOL = FEHLT (IN VEREINBARUNGEN IST := UNZULAESSIG)./
E17,TEXT /17  NACH 'IF', 'WHILE' ODER 'UNTIL' MUSS EIN BOOL'SCHER AUSD/
	*.-1
    TEXT /RUCK STEHEN./
E18,TEXT /18  ZAEHLVARIABLE BEI 'FOR'-ANWEISUNG MUSS VOM TYP INTEGER, /
	*.-1
    TEXT /CHAR ODER BOOLEAN SEIN./
E19,TEXT /19  ANFANGSWERT, ENDWERT UND ZAEHLVARIABLE MUESSEN VOM GLEIC/
	*.-1
    TEXT /HEN TYP SEIN./
E20,TEXT /20  DER STANDARDNAME 'OUTPUT' MUSS IM PROGRAMMKOPF GESCHRIEB/
	*.-1
    TEXT /EN WERDEN./
E21,TEXT /21  ZAHL IST ZU GROSS! (MAXINT=34359738367, REALS ABS. KLEIN/
	*.-1
    TEXT /ER ALS 1.0E+308)/
E22,TEXT /22  PUNKT AM PROGRAMMENDE FEHLT! (WORTSYMBOLE 'BEGIN' UND 'E/
	*.-1
    TEXT /ND' NICHT PAARWEISE?)/
E23,TEXT /23  AUSDRUCK NACH 'CASE' MUSS VOM TYP INTEGER, CHAR ODER BOO/
	*.-1
    TEXT /LEAN SEIN./
E24,TEXT /24  ILLEGALES ZEICHEN!/
E25,TEXT /25  BEI KONSTANTENVEREINBARUNG MUSS NACH = EINE KONSTANTE OD/
	*.-1
    TEXT /. EIN KONST.NAME STEHEN./
E26,TEXT /26  DER AUSDRUCK FUER EINEN FELD-INDEX MUSS VOM VEREINBARTEN/
	*.-1
    TEXT / INDEX-TYP SEIN./
E27,TEXT /27  BEREICHSGRENZEN BEI FELDVEREINBARUNG FEHLERHAFT (UG<=OG?/
	*.-1
    TEXT / GLEICHER TYP?)/
E28,TEXT /28  JEDE INDIZIERTE VARIABLE MUSS ALS ARRAY VEREINBART WERDE/
	*.-1
    TEXT /N./
E29,TEXT /29  TYPNAME FEHLT (IN PARAMETERLISTEN SIND ALLG. TYPVEREINBA/
	*.-1
    TEXT /RUNGEN VERBOTEN)./
E30,TEXT /30  DIESER TYP WURDE NICHT VEREINBART./
E31,TEXT /31  JEDE VARIABLE MIT KOMPONENTEN-SELEKTOR MUSS ALS RECORD V/
	*.-1
    TEXT /EREINBART WERDEN./
E32,TEXT /32  'NOT', 'AND' UND 'OR' VERLANGEN OPERANDEN VOM TYP BOOLEA/
	*.-1
    TEXT /N./
E33,TEXT /33  TYP DIESES AUSDRUCKS UNBESTIMMT (GANZES ARRAY IN ARITHM./
	*.-1
    TEXT /OPERATIONEN UNZULAESSIG)./
E34,TEXT /34  'DIV' UND 'MOD' VERLANGEN OPERANDEN VOM TYP INTEGER./
E35,TEXT /35  TYPEN DER VERGLEICHSOPERANDEN UNVERTRAEGLICH./
E36,TEXT /36  AKTUAL- UND FORMALPARAMETER MUESSEN VOM GLEICHEN TYP SEI/
	*.-1
    TEXT /N./
E37,TEXT /37  VARIABLE ERFORDERLICH!/
E38,TEXT /38  EIN STRING MUSS MINDESTENS EIN ZEICHEN ENTHALTEN./
E39,TEXT /39  ANZAHL DER AKTUAL- UND FORMALPARAMETER MUSS UEBEREINSTIM/
	*.-1
    TEXT /MEN./
E40,TEXT /40  STANDARDPROZEDUR READ NUR FUER TYP INTEGER, REAL UND CHA/
	*.-1
    TEXT /R VORGESEHEN./
E41,TEXT /41  BEI WRITE SIND NUR DIE TYPEN INTEGER, REAL, BOOLEAN UND /
	*.-1
    TEXT /CHAR ZULAESSIG./
E42,TEXT /42  WRITE(X:M:N) IST NUR FUER WERTE VOM TYP REAL ZULAESSIG./
E43,TEXT /43  M UND N BEI WRITE(X:M:N) MUESSEN INTEGER-AUSDRUECKE SEIN./
E44,TEXT /44  TYP- ODER PROZEDURNAMEN SIND IN AUSDRUECKEN UNZULAESSIG./
E45,TEXT /45  EINE ANWEISUNG KANN NICHT MIT EINEM KONST-, TYP- ODER FU/
	*.-1
    TEXT /NKTIONSNAMEN BEGINNEN./
E46,TEXT /46  TYPUNVERTRAEGLICHKEIT BEI WERTZUWEISUNG./
E47,TEXT /47  'CASE'-MARKEN MUESSEN VOM GLEICHEN TYP WIE DER 'CASE'-AU/
	*.-1
    TEXT /SDRUCK SEIN./
E48,TEXT /48  TYP DES ARGUMENTS BEI DIESER STANDARDFUNKTION UNZULAESSI/
	*.-1
    TEXT /G./
E49,TEXT /49  ARRAY-INDIZES UND 'CASE'-MARKEN SIND AUF -2048 < X < 204/
	*.-1
    TEXT /8 BEGRENZT./
E50,TEXT /50  EINE KONSTANTE KANN NICHT MIT DEM BEZEICHNETEN SYMBOL BE/
	*.-1
    TEXT /GINNEN./
E51,TEXT /51  SYMBOL := FEHLT (LEERZEICHEN ZWISCHEN : UND = UNZULAESSI/
	*.-1
    TEXT /G)./
E52,TEXT /52  DAS WORTSYMBOL 'THEN' FEHLT./
E53,TEXT /53  DAS WORTSYMBOL 'UNTIL' FEHLT./
E54,TEXT /54  DAS WORTSYMBOL 'DO' FEHLT./
E55,TEXT /55  DAS WORTSYMBOL 'TO' ODER 'DOWNTO' FEHLT./
E56,TEXT /56  DAS WORTSYMBOL 'BEGIN' FEHLT./
E57,TEXT /57  DAS WORTSYMBOL 'END' FEHLT./
E58,TEXT /58  EIN FAKTOR MUSS MIT NAME, KONSTANTE, 'NOT' ODER LINKSKLA/
	*.-1
    TEXT /MMER BEGINNEN./

XLIST
/R U N T I M E   E R R O R S   (ALWAYS FATAL!)

	*DISPLAY
/--------  D I S P L A Y  --------/
	ZBLOCK 20
/---------------------------------/

XHALT,	0
	CLA CLL
	TAD ZPRINT
	DCA PTPRINT	/SWITCH TO TERMINAL OUTPUT!
	TAD (HLTLIST-1
	DCA HTEXT
	ISZ HTEXT
	TAD I HTEXT
	TAD XHALT
	SZA CLA
	JMP .-4
	ISZ HTEXT
	TAD I HTEXT
	DCA HTEXT
	CRLF
	CRLF
	JMS HMESG
	TAD (HLTAT
	DCA HTEXT
	JMS HMESG
	L0001
	DCA M
	L7777
	TAD PC
	LOAD
	JMS IOUT
	CRLF
	JMP I OS8

HMESG,	0
	TAD I HTEXT
	SNA
	JMP I HMESG
	BSW
	JMS ASCII
	TAD I HTEXT
	JMS ASCII
	ISZ HTEXT
	JMP HMESG+1
HTEXT,	0

HLTLIST,-ERROR0-1;	HLT0
	-ERROR1-1;	HLT1
	-ERROR2-1;	HLT2
	-ERROR3-1;	HLT3
	-ERROR4-1;	HLT4
	-ERRORA-1;	HLTA
	-ERRORB-1;	HLTB
	-ERRORC-1;	HLTC
	-ERRORD-1;	HLTD

HLT0,	TEXT /DIVISION BY 0 /
HLT1,	TEXT /UNDERFLOW /
HLT2,	TEXT /OVERFLOW/
HLT3,	TEXT /SQRT/
HLT4,	TEXT /LN/
HLTA,	TEXT /MEMORY FULL /
HLTB,	TEXT / INDEX/
HLTC,	TEXT /CASE/
HLTD,	TEXT /FILE/

HLTAT,	TEXT / ERROR AT /

	PAGE
/I N I T I A L I Z A T I O N  OF  R U N T I M E - S Y S T E M

INIT,	CLA CLL
	CDF 10
	TAD I (7621
	CDF 0
	SNA CLA		/IF INPUT FILE SPECIFIED
	JMP INITKB
	TAD IIDEVH		/THEN SETUP FILE INPUT
	DCA I (IDEVH
	TAD IIBLOCK
	DCA I (IBLOCK
	TAD (JMP ERRORD
	DCA I (FATAL0
	TAD (IBUFFER
	DCA I (IBP
	L7775
	DCA I (IC3
	TAD (GETC
	SKP
INITKB,	TAD (XREAD		/ELSE KEYBOARD INPUT
	DCA I (PTREAD
	CDF 10
	TAD I (7600
	CDF 0
	SNA CLA		/IF OUTPUT FILE SPECIFIED
	JMP INITPR
	TAD (I37		/THEN SETUP FILE OUTPUT
	DCA I (PTI37
	TAD (PUTC
	SKP
INITPR,	TAD (XPRINT		/ELSE USE PRINTER
	DCA I (PTPRINT
	TAD (XHALT
	DCA I (PTHALT	/ACTIVATE RUNTIME ERRORS
INITDH,	CDF 60		/TRANSFER DEVICE HANDLER(S)
	TAD I F6T0	/AND RUNTIME ERROR ROUTINE
	CDF 0		/TO THEIR PLACE IN FIELD 0
	DCA I F6T0
	ISZ F6T0
	ISZ C1200
	JMP .-6
INITST,	TAD (CDF CIF 0	/CHANGE STARTING ADDRESS
	DCA I (7744	/TO START OF INTERPRETER
	TAD (ISTART
	DCA I (7745
	DCA I (7746	/CORRECT JOB STATUS WORD
	CDF 10		/(MAKE IT RESTARTABLE)
	TAD I (7643
	AND (20		/CHECK  /H - OPTION
	CDF CIF 0
	SZA CLA
	JMP I (7600	/RETURN TO OS8 MONITOR
	JMP I (ISTART	/START INTERPRETER

IIDEVH,	0
IIBLOCK,0
F6T0,	IDEVBUF
C1200,	-1200

	PAGE
