/OPERATING SYSTEM FOR ROGALGOL

/INCLUDES BINARY LOADING
/AND LOADING OF FIELD FOR CODE FROM 13600
/TO USE NEW FORMAT FLOATING POINT NUMBERS
/ADDRESSES OF NEW FPP ROUTINES
SINE=5200
LN=5460
COS=5252
FLEXP=5257
ARCTAN=5400
SQROOT=6600
DOFIX=5040
FLOAT=5752
FONE=5346
FGET=5600
FPUT=5663
FADD=5627
FSUB=5734
FMUL=5636
FDIV=5700
FNEG=7560
FINPUT=7000
FOUTP=7200
DOFADD=6000
DOFMUL=6623
DOFDIV=6200 /THESE THREE ASSUME OPERAND IS ALREADY PLACED
PSDMUY=6336
PSDDVI=6714 /INTEGER MULT AND DIV NOW PART OF ARITHMETIC ROUTINES
CHAR=57
DSWIT=60

FIELD 0

*175;	203; 0; INIT	/SO 16K CAN USE F0 FOR HANDLERS
	CDF CIF 10; JMS I .+1; 1200
	/PROG STARTS CDF CIF 10; JMP I 177

FIELD 1

/SHORT ROUTINES TO HOLE IN FPP
*5000
FNDLVL,	0	/SET T1 TO POINT AT LEVEL IN AC
	CIA; DCA T2; TAD 22; DCA T1
FNDL1,	TAD I T1; TAD T2; SNA CLA; JMP I FNDLVL
	CLA CLL CML RTL; TAD T1; DCA T1
	TAD I T1; DCA T1; JMP FNDL1

CHIN,	NPOP; DCA DEV; JMS I .+2; JMP I SNEXT; INDEV
XAND,	POP; DCA T1; NPOP; AND T1; JMP I SNEXT
TEM,	0; 0; 0	/NOT THE ONE USED BY FPP

*1
T1,	0
T2,	0
T3,	0
T4,	0
T5,	0
LAC,	0	/ USED BY LOADER
ERROR=JMS I . ; ERR

/21 IS BASE OF WORKING STACK ACTIVE IN CURRENT LEVEL
/22 POINTS AT START OF CURRENT LEVEL
NFSPAD=23	/ADDRESS OF NEXT FREE VARIABLE SPACE
ABAS=24
SW1=25
WORD=26
PC=10
EKOSW=30
DEV=31
SP=32
TSP=27
FLAC=44

*33
SUDOMQ,	0
NPOP=JMS I .; XNPOP
PNEXT,	PNEX
SNEXT,	SNEX
NEXT,	NEX
*62
AKBCHK,	KBCHK
VADR=JMS I .; XVADR
NEXT6=JMS I .; XNEXT6
STAK=JMS I .; XSTAK
UNSTAK=JMS I .; XUNSTA
ISTAK=JMS I .; XISTA
IUNSTAK=JMS I .; XIUNST
XOUT,	OUTDEV
POP=JMS I .; XIPOP
FPOP=JMS I .; XPOP
FOPOP=JMS I .; XOPOP
FPUSH=JMS I .; XPUSH
PARAM=JMS I .; XPARAM
XIND,	INDEV


*100
NEX; ARR; FORMAT; RFP; PUT; STRING; PRINT; CHIN; CHOUT /CODES 0-8
J; EX; EN; GET; ADD; IGET; IPUT /CODES 9-15
SET; NEG; POW; MUL; DIV; SUB; EZ; GZ; LZ /CODES 16-24
ANYGET; ANYPUT; STFUN; JNT; PNEX; NOT; XAND; OR; EQUIV /CODES 25-33
FORST; IOC; EP; GP; GG; SFORM; SKIP; ISIGN; SETH /CODES 34-42
FIX; FLS1; FCONS; FLNEG; SETLAB; SWITCH; RPOW; FLMPY	 /CODES 43-50
FLS2; FLDIV; FLADD; FLSUB; PFORM; FSIGN; JF; ENF /CODES 51-58
EPF; FSTR; SVS; GFORM; STOP	/CODES 59-63

*200
XNEXT6,	0; ISZ SW1; JMP NEXWD
	TAD WORD; AND (77; JMP I XNEXT6
XCDF1,
NEXWD,	CDF; TAD I PC; CDF 10
	DCA WORD; CLA CMA; DCA SW1
	TAD WORD; RTR; RTR; RTR; AND (77; JMP I XNEXT6

SETH,	JMS XNEXT6
PNEX,	DCA I SP; JMS DECSP
NEX,	JMS XNEXT6; TAD (JMP I 100; DCA .+1; HLT

CHOUT,	POP; DCA T1; POP; DCA DEV
	TAD T1; JMS I XOUT; JMP NEX

XPOP,	0; TAD (FLAC; JMS XIUNST; JMP I XPOP
XOPOP,	0; TAD (TEM; JMS XIUNST; JMP I XOPOP
XPUSH,	0; TAD (FLAC; JMS XISTA; JMP I XPUSH

XSTAK,	0; TAD I XSTAK; ISZ XSTAK; JMS XISTA; JMP I XSTAK
XUNSTA,	0; TAD I XUNSTA; ISZ XUNSTA; JMS XIUNST; JMP I XUNSTA

XISTA,	0; TAD (-1; DCA 11; JMS DECSP; TAD SP; DCA 12
	TAD I 11; DCA I 12
	TAD I 11; DCA I 12
	TAD I 11; DCA I 12; JMP I XISTA

XIUNST,	0; TAD (-1; DCA 11
	ISZ SP; TAD I SP; DCA I 11
	ISZ SP; TAD I SP; DCA I 11
	ISZ SP; TAD I SP; DCA I 11; JMP I XIUNST

XVADR,	0; NEXT6; TAD (-1; DCA XSTAK; TAD XSTAK
	CLL RAL; TAD XSTAK; JMP I XVADR

GP,	VADR; TAD 20; IUNSTA; JMP NEX

FORMAT,	POP; DCA 60; POP; DCA 57; TAD 57
	DCA 56; FPOP; POP; DCA DEV; JMS FOUTP; JMP I NEXT

DECSP,	0; CLA CLL CMA RTL; TAD SP; DCA SP
	JMS TESTSP; JMP I DECSP

ABS,	0; CLA CLL CMA RAR; AND FLAC; DCA FLAC; JMP I ABS

LZ,	NPOP; SPA CLA; CMA
SNEX,	DCA I TSP; JMP NEX

DUM,	0; JMP I DUM

*400

DOSTR,	0; NEXT6; SNA; JMP I DOSTR
	TAD (-40; SPA; TAD (100; TAD (240
	JMS I XOUT; JMP DOSTR+1

STRING,	POP; DCA DEV; JMS DOSTR; JMP I NEXT


EP,	NEXT6
EN,	DCA FLAC+2	/PARAMETERS TO FLAC+2
	TAD PC; IAC; DCA T1	/RETURN ADDRESS TO T1
	CLA CMA; PARAM
EPX,	DCA PC	/PROCEDURE ADDRESS TO PC
	PARAM; DCA T3		/NEW FIXED SPACE TO T3
	CMA; TAD 23; DCA 11		/ADDRESS V1 NEW LEVEL
	NEXT6; DCA I 11		/V1/1=PROCEDURE NUMBER
	TAD T1; DCA I 11	/V1/2=RETURN ADDRESS
	TAD 22; DCA I 11	/V1/3=BASE LAST LEVEL
	TAD 21; DCA I 11	/V2/1=STACK BASE OF LAST LEVEL
	TAD 24; DCA I 11	/V2/2=ARRAY BASE LAST LEVEL
	TAD 23; DCA 22	/NEW V1=OLD FREE SPACE
	TAD T3; TAD 22; DCA 23	/NEW FREE SPACE=BASE+FIXED SPACE
	JMS TESTSP	/CHECK ENOUGH ROOM
	JMS ALEV0	/CREATE ARRAY LEVEL 0
	NEXT6; CIA; TAD FLAC+2
	SZA CLA;E1, ERROR	/CHECK NO. PARAMS ACTUAL=EXPECTED
	TAD FLAC+2; SNA; JMP ALDONE	/ENTER IF NONE
	CLL RAL; TAD FLAC+2	/LAST PARAMETER=PARMS+3
	TAD (6; TAD 22; DCA T2		/ADDRESS THEREOF
	TAD FLAC+2; CIA; DCA T3		/COUNT PARAMETERS
EP1,	POP; DCA T4; NEXT6; DCA T1	/GET ACTUAL & EXPECTED TYPE
TCHK,	TAD T1; CIA; TAD T4; SNA CLA; JMP OK	/OK IF SAME TYPE
	TAD T1; TAD T4; TAD (-3; SNA CLA; JMP CONV /CONVERT INT/REAL
	TAD T4; TAD (-24; SPA;E2, ERROR /FAIL ACTUAL NOT NAME
	DCA T4; POP; ISTAK; JMP TCHK /ELSE DEREF AND TRY AGAIN
CONV,	CMA; TAD T1; SZA CLA; JMP IEXPECT	/WHICH TYPE EXPECTED?
	POP; DCA FLAC; JMS FLOAT; JMP OK-1	/YES, SO FLOAT IT
IEXPEC,	FPOP; JMS XFIX; FPUSH
OK,	TAD T2; IUNSTAK; CLA CLL CMA RTL; TAD T2; DCA T2
	ISZ T3; JMP EP1	/TEST IF ALL DONE
ALDONE,	TAD SP; DCA 21; JMP I NEXT

TESTSP,	0; TAD 23; CIA CLL; TAD SP; SNL CLA;E3, ERROR
	KSF; JMP I TESTSP; JMS I AKBCHK; JMP I TESTSP

PAGE

*600

XEINT,	EINT
STSP,	4777	/JUST BELOW HOLE IN FPP
ALEV0,	0	/CREATE ARRAY LEVEL 0
	TAD 23; DCA ABAS	/STARTS AT FREE SPACE
	DCA I 23; ISZ 23; JMP I ALEV0	/SET ZERO LEVEL

J,	CLA CMA; PARAM; DCA PC; JMP I NEXT

INIT,	DCA SW1; TAD P201; DCA PC
	IAC; DCA EKOSW /TELETYPE ECHO
	TAD XEINT; DCA 20; DCA I 20	/VARAIBLES START AFTER INTERPRETER
	TAD 20; DCA 22	/LOCALS ALSO
	TAD 20
XCDF2,	CDF; TAD I (176; CDF 10; DCA 23	/NEXT FREE SPACE
	TAD STSP; DCA SP; JMS ALEV0
	TAD SP; DCA 21	/21 IS WORKING STACK BASE OF CURRENT LEVEL
ADEVIN,	RFC; TLS; PLS; KCC; JMP I NEXT
P201,	201

POW,	DCA PPOW; JMS FGET; FONE	/1.0 TO FLAC
	POP; DCA T1	/EXPONENT TO T1
	TAD T1; SNA; JMP EXFLT	/ZERO EXPONENT?
	SPA; ISZ PPOW	/PPOW 1 FOR NEGATIVE EXPONENTS
	SMA; CIA; DCA PCOUNT	/COUNT OPERATIONS
	TAD PPOW; TAD (JMS I PMUL; DCA POWINS
POW1,	TAD SP; IAC
POWINS,	HLT; NOP	/MULTIPLY OR DIVIDE FLAC BY MANTISSA
	ISZ PCOUNT; JMP POW1; JMP EXFLT
PMUL,	FMUL; FDIV
PPOW,	0
PCOUNT, 0

AAAMUL=.
MUL,	DCA T4; JMS SIGN1; DCA M1; JMS SIGN1
	DCA SUDOMQ; JMS PSDMUY
M1,	0; JMP SIGN2

AAADIV=.
DIV,	DCA T4; JMS SIGN1; DCA D1; JMS SIGN1
	DCA SUDOMQ; JMS PSDDVI
D1,	0
SIGN2,	CLA; TAD T4; RAR; CLA
	TAD SUDOMQ; SZL; CIA; JMP I PNEXT
SIGN1,	0; POP; SPA; ISZ T4; SPA; CIA; JMP I SIGN1

AAAOR=.
OR,	POP; SNA CLA; JMP I NEXT
	NPOP; CLA CMA; JMP I SNEXT

SET,	NEXT6; CLL RTL; RTL; RTL
	DCA T1; NEXT6; TAD T1; JMP I PNEXT

SETLAB,	PARAM; DCA FLAC+2; TAD 22; DCA FLAC+1
	FPUSH; JMP I NEXT

ADD,	POP; NPOP; JMP I SNEXT

GG,	VADR; TAD 20; ISTAK; JMP I NEXT

*1000

DIN,	0;E4, ERROR	/LOC 101 BECOMES CDF CIF
	JMS I .+2; JMP I DIN
ADIN0,	HLT	/1004 GETS ADDRESS OF DISC INPUT ROUTINE

OCTOUT,	0; RAL; DCA SUDOMQ; TAD (-4; DCA DIN
OCTO1,	TAD SUDOMQ; RAL; RTL; DCA SUDOMQ
	TAD SUDOMQ; AND (7; TAD (260; JMS TTO; CLA
	ISZ DIN; JMP OCTO1; JMP I OCTOUT

ATTIN=.
TTI,	0; TAD EKOSW; SZA CLA; JMP EKO
	JMS LSI; JMP I TTI
EKO,	JMS LSI; JMS TTO
	TAD XM215; SNA; JMP CR
CROUT,	TAD X215; JMP I TTI
CR,	TAD X212; JMS TTO; CLA; JMP CROUT
X215,	215
X212,	212
XM215,	-215

SKIP,	POP; DCA DEV; TAD X215; JMS I XOUT
	TAD X212; JMS I XOUT; JMP I NEXT

FORST,	POP; DCA FORAD	/ADDRESS OF VARIABLE
	FOPOP; FPOP	/FINAL TO TEM+, INCREMENT TO FLAC
	CMA; POP; SZA CLA; JMP INTFOR
	TAD FLAC; JMS FORST2
	JMS FADD
FORAD,	0 	/ADD VARIABLE TO INCREMENT
	TAD FORAD; JMS FPUT; NOP	/RESTORE IT
	JMS FSUB; TEM	/CURRENT-FINAL
	TAD FLAC	/GET SIGN OF CURRENT - FINAL
	SPA; CLA CMA	/ALLOW FOR 4000
FORCON,	ISZ T4; CIA	/CHANGE ITS SIGN IF INCREMENT POSITIVE
	SMA CLA; CMA; JMP I SNEXT /SET 'TRUE' FOR DO AGAIN
INTFOR,	TAD FLAC+2; JMS FORST2
	ISZ FORAD; ISZ FORAD	/ADJUST ADDRESS
	TAD FLAC+2; TAD I FORAD; DCA I FORAD	/DO INCREMENT
	TAD TEM+2; CIA; TAD I FORAD	/CURRENT - FINAL
	JMP FORCON	/CONTINUE AS FOR REAL

FORST2,	0	/SIGN OF INCREMENT TO T4, ZERO FLAC IF NO INCREMENTING
	SPA CLA; CMA; DCA T4	/T4=-1 FOR DECREMENT
	NPOP; SZA CLA; JMP I FORST2
	DCA FLAC; DCA FLAC+1; DCA FLAC+2
	JMP I FORST2	/NO INCREMENT IF S4=0

MESS,	0; CLA; TAD I MESS; ISZ MESS; SNA; JMP I MESS
	JMS TTO; JMP MESS+1

LUNST,	0	/TAKE OFF TOP VARIABLE LEVEL
	TAD 22; DCA 11	/SET TO GET V1/2
	TAD 22; DCA 23		/RESTORE FREE SPACE POINTER
	TAD I 11; DCA T1	/RETURN ADDRESS TO T1
	TAD I 11; DCA 22
	TAD I 11; DCA 21	/RESTORE WORKING STACK BASE
	TAD I 11; DCA 24; JMP I LUNST


PAGE

*1200

ERR,	0; CDF 10; JMS MESS; 277; 0
	TAD ERR; JMS OCTOUT
WAIT,	KCC; JMS MESS; 215; 212; 336; 0
	JMS KBCHK; JMP .-1

KBCHK,	0;
X7600,	7600; KSF; JMP I KBCHK
	KRS; TAD (-220; SNA; JMP I GOCP
	TAD (220-223; SNA; JMP WAIT
	IAC; SNA; JMP RESUM
	TAD (222-203; SZA CLA; JMP I KBCHK
	KCC; CDF CIF; JMP I X7600
RESUM,	KCC; JMP I NEXT

STOP=WAIT

JNT,	PARAM; DCA T1; POP; SZA CLA; JMP I NEXT
	CMA; TAD T1; DCA PC; JMP I NEXT

ISIGN,	POP; CIA; NPOP; SNA; JMP I SNEXT
	RAL; CLA IAC; SZL; CLA CMA; JMP I SNEXT

FIX,	JMS GETS1; JMS DOFIX; TAD FLAC; JMP I SNEXT

XFIX,	0; JMS DOFIX; TAD FLAC; DCA FLAC+2; JMP I XFIX

FLS1,	NPOP; DCA FLAC; JMS FLOAT; JMP EXFLT

FLS2,	FOPOP; POP; DCA FLAC; JMS FLOAT; FPUSH
	STAK; TEM; JMP I NEXT

RFP,	NPOP; DCA DEV; JMS FINPUT; TAD DSWIT; SNA CLA
	JMP RFP+2; JMP EXFLT

EQUIV,	POP; CIA; NPOP; SNA CLA; CMA; JMP I SNEXT
GOCP,	INIT

XNPOP,	0; DCA SIGN; TAD (3; TAD SP; DCA TSP
	TAD SIGN; TAD I TSP; JMP I XNPOP

SIGN,	0	/FLAC=SIGN(FLAC)
	TAD FLAC; SNA; JMP SZ
	RAL; CLA IAC; SZL; CLA CMA
SZ,	DCA FLAC+2; JMP I SIGN

XIPOP,	0; ISZ SP; ISZ SP; ISZ SP; TAD I SP; JMP I XIPOP

*1400

XINDLS,	INDLST
XOUTLS,	OUTLST
DLSIZE,	20

FCONS,	PARAM; DCA FLAC; PARAM; DCA FLAC+1
	PARAM; DCA FLAC+2; FPUSH; JMP I NEXT

FLNEG,	JMS FLNEGS; JMP I NEXT

FLNEGS,	0
	CLA IAC; TAD SP; DCA T1	/ADDRESS OF EXPONENT
	TAD I T1; SZA; TAD (4000; DCA I T1	/DONT NEGATE ZERO
	JMP I FLNEGS

FLDIV,	TAD XFLAD+2; JMP FLADD+1
FLMPY,	TAD XFLAD+1; JMP FLADD+1
FLSUB,	JMS FLNEGS
FLADD,	TAD XFLAD; JMS DOFP
EXFLT,	TAD SP; DCA 11	/STORE FLAC BACK IN S1
	TAD FLAC; DCA I 11
	TAD FLAC+1; DCA I 11
	TAD FLAC+2; DCA I 11; JMP I NEXT

DOFP,	0
	DCA T1	/ADDRESS OF ROUTINE
	ISZ SP; TAD I SP; DCA 40
	ISZ SP; TAD I SP; DCA 41
	ISZ SP; TAD I SP; DCA 42	/OPERAND WAS IN S1
	JMS GETS1; JMS I T1
	JMP I DOFP
XFLAD,	DOFADD; DOFMUL; DOFDIV

FSIGN,	JMS FLNEGS; TAD XFLAD; JMS DOFP	/SUBTRACT
	JMS SIGN; JMP EXFLT	/TAKE SIGN

STFUN,	JMS GETS1		/GET OPERAND
	NEXT6; TAD FUNLST; DCA .+1; 0; JMP EXFLT
FUNLST,	JMS I .-1
	SQROOT	/FUNCTION 2 IS SQRT
	SINE	/SIN
	COS	/COS
	ARCTAN	/ARCTAN
	FLEXP	/EXP
	LN	/LN
	SIGN	/FUNCTION 8
	XFIX
	ABS

RPOW,	FOPOP	/EXPONENT TO TEM
	JMS GETS1	/GET MANTISSA
	JMS I FUNLST+6; JMS FMUL; TEM /LN, *EXPONENT
	JMS I FUNLST+5; JMP EXFLT	/EXPONENTIAL

GETS1,	0	/GET S1 TO FLAC, LEAVE SP WHERE IT IS
	TAD SP; DCA 11
	TAD I 11; DCA FLAC
	TAD I 11; DCA FLAC+1
	TAD I 11; DCA FLAC+2
	TAD 11; DCA TSP; JMP I GETS1

INDEV,	0; CLA; DCA T5; TAD XINDLS; JMS CHKDEV; JMP I INDEV
OUTDEV,	0; DCA T5; TAD XOUTLS; JMS CHKDEV; CLA; JMP I OUTDEV

CHKDEV,	0; DCA T1; TAD DLSIZE; CLL CIA
	TAD DEV; SZL;E5, ERROR
	TAD DLSIZE; TAD T1; DCA T1	/ADDRESS OF ADDRESS
	TAD I T1; DCA T1; TAD T5
	JMS I T1; JMP I CHKDEV


PAGE
*1600

SUBSA,	0	/WORK OUT SUBSCRIPT ADDRESS
	JMS ABSVAD; TAD (2; DCA T1	/ADDRESS ARRAY VARIABLE
	CMA; TAD I T1; DCA 17	/ADDRESS DOPE VECTOR
	TAD I 17; CIA; DCA WRDS /=-1 IF ONE WORD
	TAD I 17; CIA; DCA T3	/COUNT SUBSCRIPTS
	NEXT6; TAD T3; SZA CLA;E6, ERROR	/CHECK NO. OF SUBSCRIPTS
	TAD I 17; CIA; POP; DCA T1 /1ST SUBS-LOWER BOUND
SUBSA3,	ISZ T3; SKP; JMP SUBSA1	/ANY MORE SUBSCRIPTS?
	TAD I 17; DCA SUDOMQ	/YES, GET MULTIPLIER FOR IT
	TAD I 17; CIA; POP; DCA SUBSA2 /NEXT SUBS-LOWER BOUND
	JMS PSDMUY
SUBSA2,	0; TAD SUDOMQ; TAD T1; DCA T1	/TIMES VECTOR, ADD TO ADDRESS
	JMP SUBSA3	/SEE IF THERES ANY MORE
SUBSA1,	TAD WRDS; CMA; SNA CLA; JMP SUBSA4	/IF 3 WORDS
	TAD T1; CLL RAL		/MULTIPLY ADDRESS BY 3
SUBSA4,	TAD T1; IAC; TAD 17; DCA T1	/ADD TO LOWEST ADDRESS
	ISZ WRDS; ISZ SUBSA; JMP I SUBSA	/EXIT 2 IF 2 WORDS
AAASA2=SUBSA2
AAASA3=SUBSA3

GET,	VADR; TAD 22; ISTAK; JMP I NEXT

XPARAM,	0; ISZ SW1; NOP
XCDF3,	CDF
	TAD I PC; CDF 10; JMP I XPARAM

WRDS=XPARAM
LSI,	0; KSF; JMP .-1; JMS I AKBCHK; KRB; JMP I LSI

SUB,	POP; CIA; NPOP; JMP I SNEXT

EX,	JMS LUNST; DCA SW1; TAD T1; DCA PC; JMP I NEXT

SVS,	NEXT6; CIA; DCA T4	/VARIABLE LEVEL REQUIRED
SVS1,	TAD I 22; TAD T4; SNA CLA; JMP SAS	/DO ARRAYS IF OK
	JMS LUNST; JMP SVS1	/ELSE TAKE OFF TOP AND TRY AGAIN

IGET,	JMS SUBSA
	CLA CLL CMA RAL	/SUBTRACT 2 IF INTEGER/BOOLEAN
	TAD T1; ISTAK; JMP I NEXT	/WILL STACK 2 JUNK WORDS

PFORM,	FPOP; POP; JMP IPUT+4	/STORE NAME PARAM
IPUT,	FPOP; JMS SUBSA; JMP IPUT1
	TAD T1; JMS FPUT; NOP; JMP I NEXT
IPUT1,	TAD FLAC+2; DCA I T1; JMP I NEXT

ANYPUT,	CMA
ANYGET,	DCA T3	/SET MARKER
	JMS ABSVAD
	ISZ T3; JMP ANYG; IUNSTAK; JMP I NEXT
GFORM,	POP	/GET NAME PARAMETER
ANYG,	ISTAK; JMP I NEXT

ABSVAD,	0	/WORK OUT ABSOLUTE VARIABLE ADDRESS
	NEXT6; JMS FNDLVL; VADR; TAD T1; JMP I ABSVAD

NOT,	NPOP; CMA; JMP I SNEXT

*2000

DOUT,	0;E7, ERROR	/LOC 2001 BECOMES CDF CIF
	JMS I .+2; JMP I DOUT
ADOUT0,	HLT	/2004 GETS ADDRESS OF DISK OUTPUT ROUTINE

SAS,	NEXT6; CIA; DCA T1	/REQUIRED ARRAY DEPTH
	TAD 21; DCA SP	/CLEAR WORKING STACK AT LABEL
SAS1,	TAD I ABAS; TAD T1; SNA CLA; JMP I NEXT /GOT IT?
	JMS AUNST; JMP SAS1

AUNST,	0; TAD ABAS; DCA 23	/REDUCE FREE SPACE POINTER
	ISZ ABAS; TAD I ABAS; DCA ABAS /RESTORE ARRAY BASE POINTER
	JMP I AUNST

PRINT,	POP; CLL; SPA; CIA CML; DCA SUDOMQ
	POP; DCA DEV; TAD (255; SZL; JMS I XOUT
	CLA; JMS PRIN; JMP I NEXT
PRIN,	0; STAK; PRIN	/SAVE RETURN ADDRESS
	TAD SUDOMQ; TAD (-12; SMA CLA; JMP GT10
	TAD SUDOMQ
LASTD,	TAD (260; JMS I XOUT
	FPOP; JMP I FLAC	/RETURN
GT10,	JMS PSDDVI; 12; DCA I SP; JMS DECSP; JMS PRIN
	POP; JMP LASTD

SWITCH,	POP; POP; DCA T1
XCDF4,	CDF; TAD I T1; CDF 10; JMP SETLAB+1

HSI,	0; JMS I AKBCHK; RSF; JMP .-2; RRB RFC; JMP I HSI
TTO,	0; TSF; JMP .-1; TLS; JMP I TTO
HSO,	0; PSF; JMP .-1; PLS; JMP I HSO

JF,	DCA SW1; FPOP; CMA; TAD FLAC+2; DCA PC
JF1,	TAD FLAC+1; CIA; TAD 22
	SNA CLA; JMP I NEXT; JMS LUNST; JMP JF1

EPF,	NEXT6
ENF,	DCA FLAC+2	/NUMBER OF PARAMS
	TAD PC; DCA T1; DCA SW1 /RETURN ADDRESS TO T1
	CMA; POP; JMP I .+1; EPX	/GET PROCEDURE ADDRESS

FSTR,	TAD PC; DCA T2; CMA; POP; DCA PC	/ADDRESS OF STRING
	POP; DCA DEV
	STAK; 25; DCA SW1	/SAVE PC ETC.
	JMS I XDOSTR; UNSTAK; 25
	TAD T2; DCA PC; JMP I NEXT
XDOSTR, DOSTR

SFORM,	JMS ABSVAD; JMP I PNEXT

PAGE

*2200

DODI,E8,	ERROR; JMS I ADI0; JMP I NEXT
NDECS,	0
ADI0,	ERR

NEG,	NPOP; CIA; JMP I SNEXT

GZ,	NPOP; SMA SZA CLA; CMA; JMP I SNEXT

PUT,	VADR; TAD 22; IUNSTAK; JMP I NEXT

ARR,	NEXT6; DCA T1	/DEPTH OF DECLARATION
	TAD I ABAS; CIA; TAD T1
	SNA CLA; JMP AR1	/SAME AS NOW?
	TAD T1; DCA I 23	/1ST WORD LEVEL NUMBER
	ISZ 23; TAD ABAS; DCA I 23 /2ND IS BASE OF LAST LEVEL
	CLA CMA; TAD 23; DCA ABAS /POINT AT NEW LEVEL
	ISZ 23	/NEW FREE SPACE POINTER
AR1,	NEXT6; CIA; DCA NDECS	/COUNT DECLARATIONS
	VADR; TAD (2; TAD 22
	DCA DECADR	/POINT AT IST ARRAY VARIABLE
	NEXT6; DCA ARNW	/GET NUMBER OF WORDS EACH ELEMENT
	TAD ARNW; DCA I NFSPAD /PUT IT IN DOPE VECTOR
	TAD NFSPAD; DCA I DECADR /ADDRESS VECTOR TO VARIABLE
	ISZ NFSPAD; NEXT6; DCA I NFSPAD	/NO. OF SUBSCRIPTS TO DV
	TAD I NFSPAD; ISZ NFSPAD; CIA; DCA SUBSC	/COUNT SUBSCRIPTS
	TAD SUBSC; DCA SUBSC1
	IAC; DCA ARNE	/1 ELEMENT FOR HOMOGENEOUS ALGORITHM
AR2,	POP; DCA T2; POP; DCA T3	/T2=UPPER, T3=LOWER BOUND
	TAD T3; CIA; TAD T2; IAC	/NO. OF ELEMENTS
	DCA SUDOMQ; JMS PSDMUY	/MULTIPLY BY PREVIOUS TOTAL
ARNE,	0; TAD SUDOMQ; DCA ARNE /TO GET NEW TOTAL
	TAD T3; DCA I NFSPAD; ISZ NFSPAD /LOWER BOUND TO VECTOR
	ISZ SUBSC; SKP; JMP LASTSS	/ANY MORE SUBSCRIPTS?
	TAD ARNE; DCA I NFSPAD	/YES, STORE NO. ELEMENTS IN VECTOR
	ISZ NFSPAD; JMP AR2 /AND DEAL WITH IT
LASTSS,	TAD ARNE; DCA SUDOMQ; JMS PSDMUY /INCREASE FREE SPACE POINT
ARNW,	0; TAD SUDOMQ; TAD NFSPAD; DCA NFSPAD /BY ARRAY SIZE
	JMS TESTSP	/ROOM FOR IT?
	ISZ NDECS; SKP; JMP I NEXT	/ANY MORE DECLARATIONS?
	TAD I DECADR; DCA T1	/POINT AT DOPE VECTOR
	TAD (3; TAD DECADR; DCA DECADR/NEXT VARIABLE
	TAD NFSPAD; DCA I DECADR	/STORE ADDRESS NEW VECTOR
	TAD SUBSC1; CLL RAL; TAD (-1; DCA SUBSC	/COUNT VECTOR SIZE
AR4,	TAD I T1; DCA I NFSPAD; ISZ T1; ISZ NFSPAD
	ISZ SUBSC; JMP AR4
	JMP LASTSS	/COPY DOPE VECTOR
DECADR=DSWIT
SUBSC=T4
SUBSC1=T5

IOC,	POP; SMA; JMP DODI
	IAC; SNA; RFC; IAC; DCA EKOSW; JMP I NEXT

EZ,	NPOP; SNA CLA; CMA; JMP I SNEXT

*2400

INDLST,	ERR; TTI; HSI; DIN; ERR; ERR; ERR; ERR
	ERR; ERR; ERR; ERR; ERR; ERR; ERR; ERR
OUTLST,	DUM; TTO; HSO; DOUT; ERR; ERR; ERR; ERR
	ERR; ERR; ERR; ERR; ERR; ERR; ERR; ERR

EINT=.


/LOAD ALGOL INTERPRETIVE CODE TAPES
/MAIN LIST FROM STACK START (600^) TO 3677
/FORWARD REF LIST FROM 3700 TO 3777

FIELD 0

*200
	CDF CIF 10; JMP I .+1; 4000

FIELD 1

CL=23
RESULT=24
VALUE=26
SVRES=27
SP1=10

*3600
FEELD,	CDF 0	/ FIELD FOR CODE - CAN BE PRESET
	7577	/ LAST LOC TO USE IF OTHER THAN FIELD 0
MFLD,	-6211	/ USED TO CHECK FILED TO LOAD. FIELD MUST
	/ BE ABOVE THIS. CAN BE PATCHED BY 12K OVERLAY !
LSTART,	0
	CLA CLL CML RAR; DCA GOCP
	TAD FEELD; AND K70; SNA	/ IGNORE CDF 0
	JMP ON; TAD (CDF; DCA FLD
	TAD FLD; TAD MFLD; SPA SNA CLA	/ CHECK IF FLD 0 OR 1
E9,	ERROR	/ IF SO FLAG ERROR
FLD,	CDF; TAD I CORCL	/ HERE WE CHECK FIELD EXISTS
C2,	NOP; DCA C1; TAD C2; DCA I CORCL
K70,	70; TAD I CORCL
CORX,	7400; TAD CORX; TAD CORV; SZA CLA
E10,	ERROR	/ TRIED TO LOAD NON-EXISTANT FIELD
	TAD C1; DCA I CORCL; CDF 10
	TAD INSET; DCA INSTR
	TAD (-7; DCA CNT; TAD FLD; ISZ INSTR
INSTR,	DCA I FLP; ISZ CNT
	JMP INSTR-2; TAD 3601
INSET,	DCA I FLP
ON,	CDF 10
	DCA SUM; JMS INDEV; SNA; JMP .-2
	TAD M200; SNA CLA; JMP BININ
	JMS FDIG; ISZ LSTART
M200,	7600; JMP I LSTART /SYMBOLIC
BININ,	JMS INDEV; TAD M200; SNA; JMP BININ
	TAD (200
BIN1,	DCA LAC	/SAVE LOOK AHEAD
NEXBIN,	TAD LAC; AND (300; TAD (-300; SZA CLA; JMP NOTFLD
	JMS INDEV; JMP BIN1	/IGNORE FIELD SETTINGS
NOTFLD,	TAD LAC; DCA MSBITS
	JMS INDEV; DCA LSBITS
	JMS INDEV; TAD M200; SNA; JMP BINEND
	TAD (200; DCA LAC	/SAVE LOOK AHEAD IF NOT LEADER
	TAD MSBITS; TAD LSBITS; TAD SUM; DCA SUM
	TAD MSBITS; CLL RTL; RTL; RTL; TAD LSBITS
	SZL; JMP ORIG
	JMS STORE; JMP NEXBIN
ORIG,	DCA CL; JMP NEXBIN
BINEND,	TAD MSBITS; CLL RTL; RTL; RTL; TAD LSBITS
	CIA; TAD SUM; SZA CLA;E11, ERROR;
	CMA; TAD CL; DCA CL
	JMP I LSTART
MSBITS,	0
CNT,
SUM,	0
C1,
LSBITS,	0
CORCL,	0
CORV,	1400
FLP,	4200; XCDF1; XCDF2; XCDF3; XCDF4
	XCDF5; XCDF6; XCDF7

*4000
LOAD,	TLS; KCC; JMS MESS
	215;212;"R;"O;"G;"A;"L;"G;"O;"L;"O;"A;"D;"E;"R
	240;"I;"N;"-;0
	JMS TTI; TAD (-260; DCA DEV; RFC
	CLA CLL CMA RTL; TAD DEV; SNA CLA; JMS DIX
IPSET,	JMS LODOPT	/ GO CHECK FIELD OPTS IF ANY
	JMS LSTART; JMP ENDBIN	/LOOK FOR BINARY OR SKIP TO DIGIT
	DCA .-2; DCA .-2	/ CLEAR RECALL OF BIN!
	TAD 600; TAD (-3677; DCA MLSIZE
	CMA; TAD 600; DCA SP1; TAD (-101; TAD MLSIZE; DCA ABAS
	DCA I SP1; ISZ ABAS; JMP .-2	/CLEAR LISTS
	TAD (202; DCA CL
LOOP,	CLA CMA; DCA SIGN
	JMS IN; JMS DIGTST; SKP; JMP CONST
	TAD (-"-; SNA; JMP NCONST
	TAD ("--";; SNA; JMP LOOP	/IGNORE MULTIPLE :
	TAD (";-"*; SNA; JMP END
	TAD ("*-"L; SNA; JMP LABEL
	TAD ("L-"F; SNA; JMP FCON;E12, ERROR
END,	CLA CMA; TAD CL
XCDF5,	CDF; DCA CL /ADDRESS OF FIXED SPACE
	TAD I CL; DCA I (176 /SAVE IT
	TAD CL; IAC; DCA I (175	/NEXT FREE SPACE
	TAD (JMP I 177; DCA I (201
	TAD XCDIF; DCA I (200
	TAD (INIT; DCA I (177
ENDBIN,	CDF 0; TAD (JMP I 177; DCA I (201
	TAD (INIT; DCA I (177
	TAD XCDIF; DCA I (200
XCDIF,	CDF CIF 10; JMP LEND

*4600
LODOPT,	0; JMP I LODOPT	/ PATCH HERE TO LOAD FIELD OPTIONS
	/ DONE BY SETTING FEELD TO REQUIRED FIELD
PINIT,	INIT	/ SOME USEFUL POINTERS
PWAIT,	WAIT
PGOCP,	GOCP
POCTOUT, OCTOUT
PMESS,	MESS
PFEELD,	FEELD	/ THIS IS WHERE REQUIRED FIELD IS STORED
LEND,	JMS I PMESS; 215;212;"E;"N;"D;"S;" ;0
	TAD PINIT; DCA I PGOCP; TAD CL; JMS I POCTOUT
	JMS I AKBCHK; TSF; JMP .-2
ALEND,	JMP I PWAIT	/MAY BE PATCHED TO DO ADDITIONAL THINGS
	/ SUCH AS CHECKING WHETHER TO START OR NOT.

*4200

MAXLOC,	7577	/GETS OVERLAID BY SYSTEMS DEVICE INTERFACES
LABEL,	JMS IN; JMS DIGTST;E13, ERROR
	DCA RESULT; JMS RCON; DCA CHAR; JMS CHKLNO	/LABEL NUMBER TO RESULT
	TAD CHAR; TAD (-",; SNA; JMP DECLAB
	TAD (",-"=; SNA; JMP DEFLAB
	TAD ("=-";; SZA;E14, ERROR
STLAB,	JMS LOOKUP; JMP NOTDECL	/STORE LABEL. DECLARED?
	JMS STORE; JMP LOOP	/YES STORE IT
NOTDEC,	JMS STORE; CMA; TAD CL	/STORE LAST ADDRESS USED IN PROG
	DCA I T5	/AND THIS ADDRESS IN MAIN TABLE
	TAD RESULT; JMS SFWD	/SEE IF ITS IN FORWARD LIST
	JMP LOOP	/FINISHED IF ALREADY THERE
	JMS SFWD; SKP;E15, ERROR	/ELSE LOOK FOR SLOT
	TAD RESULT; DCA I T1; JMP LOOP	/AND MAKE ENTRY
DECLAB,	TAD CL; DCA VALUE; JMP LABVAL	/VALUE IS CURRENT ADDRESS
DEFLAB,	TAD RESULT; DCA SVRES	/SAVE LABEL BEING DEFINED
	JMS IN; JMS DIGTST; JMP DEFL1	/ANOTHER LABEL?
	DCA RESULT; JMS RCON	/NO, READ CONSTANT
	CLA; TAD RESULT
DEFL2,	DCA VALUE; TAD SVRES; DCA RESULT	/RESTORE LABEL
	JMP LABVAL
DEFL1,	TAD PL; SZA CLA;E16, ERROR	/CHECK FOR L
	DCA RESULT; JMS RCON; JMS CHKLNO	/READ DEFINING LABEL
	JMS LOOKUP;E17, ERROR; JMP DEFL2	/CHECK DECLARED, VALUE IN AC
LABVAL,	JMS LOOKUP; SKP;E18, ERROR	/FAIL IF ALREADY DECLARED
	DCA T4; DCA I T1	/SAVE ADDRESS LAST USE, CLEAR FREF ENTRY
	TAD VALUE; DCA I T5	/PUT VALUE IN MAIN TABLE
DFR,	TAD T4; SNA CLA; JMP LOOP	/FREFS TO FILL IN?
XCDF6,	CDF; TAD I T4; DCA T3	/YES, SAVE LINK
	TAD VALUE; DCA I T4; CDF 10	/REPLACE BY VALUE
	TAD T3; DCA T4; JMP DFR	/CHECK IF ANY MORE
PL,	-"L

STORE,	0
XCDF7,	CDF; DCA I CL; CDF 10; ISZ CL
	TAD CL; CIA; TAD MAXLOC; SNA CLA;E19, ERROR; JMP I STORE

DIGTST, 0
	TAD (-260; SPA; JMP NOT1
	TAD (260-272; SMA; JMP NOT2
	TAD (272-260; ISZ DIGTST; JMP I DIGTST
NOT1,	TAD (260-272
NOT2,	TAD (272; JMP I DIGTST

FDIG,	0; JMS IN; JMS DIGTST; JMP .-2; JMP I FDIG

PAGE
*4400

RCON,	0
	JMS IN; JMS DIGTST; JMP I RCON
	DCA IN; TAD RESULT; CLL RTL; TAD RESULT
	CLL RAL; TAD IN; DCA RESULT; JMP RCON+1

IN,	0
	JMS INDEV; TAD PM215; SNA; TAD (";-215
	TAD PM212; SNA; JMP IN+1
	TAD PM240; SNA; JMP IN+1
	TAD PM377; SNA; JMP IN+1
	TAD PM211; SNA; JMP IN+1
	TAD P211; SNA; JMP IN+1; JMP I IN
PM215,	-215
PM212,	215-212
PM240,	212-240
PM377,	240-377
PM211,	377-211
P211,	211

SFWD,	0	/SEARCH FORWARD LIST, LABEL NO. IN AC
	CIA; DCA T2; TAD (-100; DCA T3
	TAD (3677; DCA T1
SFWD1,	ISZ T1; TAD I T1; TAD T2
	SNA CLA; JMP I SFWD	/EXIT 1 IF FOUND, T1^ENTRY
	ISZ T3; JMP SFWD1	/IF NOT CHECK IF EXHAUSTED
	ISZ SFWD; JMP I SFWD	/AND EXIT 2 IF SO

LOOKUP,	0	/LOOKUP LABEL NO. IN RESULT, AC=0
	TAD RESULT; TAD 600; DCA T5	/POINT AT MAIN ENTRY
	TAD RESULT; JMS SFWD; JMP INFWD	/SEARCH FORWARD LIST
	TAD I T5; SZA; ISZ LOOKUP	/EXIT 2 IF DECLARED
	JMP I LOOKUP	/ELSE EXIT 1, NO PREVIOUS USE
INFWD,	TAD I T5; JMP I LOOKUP	/ADDRESS OF PREVIOUS USE

FCON,	JMS FINPUT; TAD DSWIT; SNA CLA; JMP FCON
	TAD FLAC; JMS STORE; TAD FLAC+1; JMS STORE
	TAD FLAC+2; JMS STORE
FC1,	JMS IN; TAD (-";; SZA CLA; JMP FC1; JMP LOOP
NCONST,	DCA SIGN
CONST,	DCA RESULT; JMS RCON; CLA; TAD RESULT
	ISZ SIGN; CIA; JMS STORE; JMP LOOP

DIX,	0; TAD 2204; TAD (-ERR; SNA CLA;E20, ERROR /IS DIX0 THERE?
	TAD 2204; DCA T1; CDF CIF
	CLA IAC; JMS I T1	/ CALL TO OPEN FILE
	JMP I DIX

CHKLNO,	0; CLA; TAD RESULT; TAD MLSIZE; SZA SMA CLA;E21, ERROR
	JMP I CHKLNO

MLSIZE,	0
$