--- /dev/null
+/OS8 BASIC COMPILER, V5
+/
+/
+/
+/
+/
+/
+/
+//
+/
+/
+/
+/
+/COPYRIGHT (C) 1972, 1973, 1974, 1975
+/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
+/
+/
+/
+/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
+/SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
+/SION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE, OR ANT OTHER
+/COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
+/TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
+/AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
+/SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
+/
+/
+/THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
+/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
+/EQUIPMRNT COROPATION.
+/
+/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
+/SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
+/
+/
+/
+/
+/
+/
+\f/DEC-S8-LBASA-B-LA
+/
+/COPYRIGHT C 1972, 1973, 1974
+/
+/DIGITAL EQUIPMENT CORPORATION
+/MAYNARD,MASSACHUSETTS 01754
+/
+/AUGUST 19, 1972
+/
+/HANK MAURER, 1972
+/SHAWN SPILMAN, 1973
+/
+/
+/ASSEMBLE AND LOAD AS FOLLOWS:
+/
+/ .R PAL8
+/ *BCOMP,BCOMP<BCOMP.03
+/ .R ABSLDR
+/ *BCOMP$
+/ .SA SYS BCOMP;7000
+/
+/NOTE DIFFERENCES FROM VERSION 1 AS FOLLOWS:
+/
+/ .R SRCCOM
+/ *LPT:<BCOMP.01,BCOMP.03
+/ *
+/
+/
+ VERSON=5 /VERSION LOCATED IN CORE AT TAG "VERLOC"
+ /LEFT HALF OF VERLOC = 60+VERSON
+ /RIGHT HALF OF VERLOC = PATCH LEVEL (01=A)
+
+/
+/CORRECTION & ADDITION MADE FOR V4 J.K. 1975
+/
+/ ./V FOR VERSION NUMBER
+/ . ABILITY TO INPUT FROM PTR
+/ .CORRECT TEST FOR BATCH RUNNIG
+/ .IGNORE MORE THAN 10 SIGNIFICANT DIGITS
+/ OF NUMERIC CONSTANTS
+/JR 30-APR-77 UPDATE VERSION
+\f *5
+TEMP3, 0
+XABORT, ABORT /ADDR OF ABORT ROUTINE
+ 0
+X10, INFO-5 /AUTO INDEX REGISTERS
+X11, NAMLST-1
+X12, INFO-5
+X13, BOSINFO-1
+OSTACK, STACKO-1 /OPERAND STACK POINTER
+STACK, STACKA-1 /GENERAL STACK POINTER
+NEXT, FREE-1 /NEXT FREE LOCATION
+CHRPTR, 0 /INPUT BUFFER POINTER
+NCHARS, 0 /SIZE OF INPUT LINE
+TEMP, -4
+TEMP2, 0
+DECPT, 0 /SET 1 IF .
+NDIGIT, 0 /NUM DIGITS RIGHT OF .
+EXPON, 0 /EXPONENT FOR NUM CONV
+TYPE, 0 /TYPE OF CURRENT OPERAND
+SYMBOL, 0 /SYMBOL NUMBER OF CUR. OPERAND
+LEFT, 0 /LEFT SIDE SWITCH
+OLDOP, 0 /OLD OPERATOR
+NEWOP, 0 /NEW OPERATOR
+TMPCNT, 0 /TEMP COUNTER
+TMPLVL, 3 /TEMP LEVEL
+STMPCT, 0 /TEMP COUNT (STRINGS)
+STMPLV, 1 /TEMP LEVEL (STRINGS)
+STPTR, 0 /POINTER TO S.T. ENTRY
+VARCNT, -401 /NUMBER OF POSSIBLE NUMERIC
+ /VARIABLES, LITERALS, AND TEMPS
+SVCNT, -401 /SAME FOR STRING VARS
+ACNT, -41 /ARRAY COUNTER
+SACNT, -41 /STRING ARRAY COUNTER
+LOCTRH, 0 /HIGH ORDER LOCATION COUNTER
+LOCTRL, 0 /LOW ORDER " "
+BLOCK, 0 /START BLOCK OF TEMP FILE
+HIFLD, 0 /HIGHEST CORE FIELD
+BRTS, 0 /START OF BRTS.SV
+DLSIZE, 0 /NEG. SIZE OF DATA LIST
+ABORTX, 0 /START OF EDITOR
+LINEH, 0 /LINE NUMBER (HIGH)
+LINEL, 0 /LINE NUMBER (LOW)
+MODE, 0 /INTERPRETER MODE
+TYPE1, 0 /TYPE AFTER JMS GETA1
+SYMBL1, 0 /SYM # AFTER JMS GETA1
+OLDSTK, 0 /STACK SAVER FOR DEF
+ARGCNT, 0 /ARG COUNTER FOR DEF
+PCRLF, /CR SWITCH FOR PRINT STMT
+DACNT, /ARG COUNT FOR UDEF STMT
+FORJMP, /FOR LOOP JUMP INSTR
+NOSN, /STMT NUMBER PRESENT SWITCH
+COLON, /: SWITCH FOR GETFN ROUTINE
+JAROND, 0 /END OF DEF ADDR GOES HERE (INDIRECTLY)
+IFNREG, 0 /CONTENTS OF IFN REG
+SSREG1, 0 /EXECUTION TIME CONTENTS
+SSREG2, 0 /OF THE SS REGISTORS
+STKLVL, STACKA-1 /STACK BASE LEVEL
+FINDEX, 0 /FOR LOOP INDEX
+SETFLD, 0 /FIELD CHANGE RTNE FOR LUKUP2
+LUFLD, CDF 10 /FIELD OF ENTRY FOR LUKUP2
+ JMP I SETFLD
+QERMSG, ERMSG /SUBROUTINE POINTERS
+QLODSN, LODSN
+QCHKWD, CHKWD
+QMODSET,MODSET
+QSNUM, SNUM
+QOUTWRD,OUTWRD
+QSAVECP,SAVECP
+QGETC, GETC
+QGETCWB,GETCWB
+QRESTCP,RESTCP
+QEXPR, EXPR
+QOUTOPR,OUTOPR
+QNEWLIN,NEWLIN
+QREMARK,REMARK
+QGETA1, GETA1
+QLOADSS,LOADSS
+QCHECKC,CHECKC
+QGETNAM,GETNAM
+QCOMARP,COMARP
+QLOOKUP,LOOKUP
+QLUKUP2,LUKUP2
+QLOAD, LOAD
+QPUSH, PUSH
+QPOP, POP
+QPUSHO, PUSHO
+QSAVAC, SAVAC
+QBACK1, BACK1
+QNUMBER,NUMBER
+QSTRING,STRING
+QLETTER,LETTER
+QDIGIT, DIGIT
+QNOREGS,NOREGS
+Q400, 400
+NAME1, /VARIABLE OR FUNCT NAME
+WORD1, 0 /3 WORD LITERAL BUFFER
+NAME2,
+WORD2, 0
+NAME3,
+WORD3, 0
+ACO, 0 /FAC OVERFLOW WD
+OP1, 0 /4 WORD ARG FOR "NUMBER"
+OP2, 0
+OP3, 0
+OPO, 0
+NUMDIG, -13
+SIGDIG, 0
+\f INFO= 7604 /INFORMATION AREA
+/INFO STARTING BLOCK +1 OF BASIC.SV
+/INFO+1 STARTING BLOCK +1 OF BCOMP.SV
+/INFO+2 STARTING BLOCK +1 OF BLOAD.SV
+/INFO+3 STARTING BLOCK +1 OF BRTS.SV
+/INFO+4 STARTING BLOCK +1 OF BASIC.AF
+/INFO+5 STARTING BLOCK +1 OF BASIC.SF
+/INFO+6 STARTING BLOCK +1 OF BASIC.FF
+/INFO+7 STARTING BLOCK +1 OF BASIC.UF
+/INFO+10 STARTING BLOCK OF BASIC.TM
+/INFO+11 SIZE IN BLOCKS OF BASIC.TM
+/INFO+12 INPUT HANDLER ENTRY ADDRESS
+/INFO+13 SIZE AND DEVICE NUMBER OF INPUT FILE
+/INFO+14 STARTING BLOCK OF INPUT FILE
+/INFO+15 THROUGH
+/INFO+20 NAME OF WORKSPACE
+/
+/
+ BOSINFO= 7774 /BOS PARAMETER AREA
+ EDTSIZ= 2100 /SIZE OF BASIC.SV
+ EDTBGN= 3212 /RESTART FOR EDITOR
+ ERMSG2= 1712 /POST PROCESSOR ERROR SWITCH
+ EOST= 7570 /UPPER LIMIT FOR SYMBOL TABLE
+ INDEVH= 4600 /INPUT DEVICE HANDLER
+ LINE= 7000 /LINE BUFFER
+ LINMAX= 121 /MAXIMUM BASIC STMT
+ STACKA= 7120 /MAIN STACK
+ STAKSZ= 60 /SIZE OF MAIN STACK
+ /OPERAND STACK DEFINED IN-LINE
+ STRLIM= 120 /MAXIMUM STRING SIZE
+ INBUF= 7200 /INPUT BUFFER
+/
+/
+/FIELD ONE STUFF
+/
+/
+ OUBUF= 0 /OUTPUT BUFFER
+ VARST= 400 /VARIABLE SYMBOL TABLE
+ SVARST= VARST+436/STRING VAR SYMBOL TABLE
+ ARAYST= SVARST+1074/ARRAY SYMBOL TABLE
+ SARYST= ARAYST+200/STRING ARRAY SYMBOL TABLE
+ SNUMS= SARYST+200/STMT NUMBER BUCKETS
+ TEMPS= SNUMS+24 /NUMERIC TEMP BUCKET
+ STEMPS= TEMPS+2 /STRING TEMP BUCKET
+ LITRL= STEMPS+2 /NUMERIC LITERAL BUCKET
+ SLITRL= LITRL+2 /STRING LITERAL BUCKET
+ DATLST= SLITRL+2 /DATA LIST
+ FUNCTN= DATLST+2 /FUNCTION LIST
+ FREE= FUNCTN+2 /START OF FREE CORE
+\f/ INTERPRETER OPCODES
+/
+/ MEMORY REFERENCE SET
+ FADD= 0000
+ FSUB= 0400
+ FMPY= 1000
+ FDIV= 1400
+ FLDA= 2000
+ FSTA= 2400
+ FISUB= 3000
+ FIDIV= 3400
+ LSS1= 4000
+ LSS2= 4400
+ JEOF= 5400
+ LOADSN= 6000
+/
+/ JOC CLASS
+ JSUB= 5000
+ JUMP= 5001
+ JGE= 5002
+ JNE= 5003
+ JGT= 5004
+ JLT= 5005
+ JEQ= 5006
+ JLE= 5007
+ JFOR= 5010
+/
+/ ARRAY CLASS
+ AISUB= 6400
+ AFADD= 6440
+ AFSUB= 6500
+ AFMPY= 6540
+ AFDIV= 6600
+ AFLDA= 6640
+ AFSTA= 6700
+ AIDIV= 6740
+/
+/ STRING CLASS
+ SCON= FADD
+ SCOMP= FSUB
+ SREAD= FMPY
+ SLOAD= FLDA
+ SSTORE= FSTA
+ SACON= AISUB
+ SACOMP= AFADD
+ SAREAD= AFSUB
+ SALOAD= AFLDA
+ SASTOR= AFSTA
+/
+/ OPERATE CLASS
+ SETJF= 7401
+ RNDO= 7421
+ STOP= 7441
+ SRDL= 7461
+ CHN= 7414
+ NRDL= 7521
+ CLOSEF= 7434
+ OPENAV= 7474
+ OPENAF= 7454
+ OPENNV= 7534
+ OPENNF= 7514
+ CLRFN= 7501
+ FILENO= 7402
+ FNEG= 7403
+ RET= 7404
+ REST= 7405
+ LSS1AC= 7406
+ LSS2AC= 7407
+ FESC= 7410
+ READ= 7411
+ WRITE= 7412
+ SWRITE= 7413
+ SMODE= 7561
+ NMODE= 7541
+ FUNC1= 7416
+ FUNC2= 7417
+ FUNC3= 7400
+ FUNC4= 7415
+ USE= 7540
+\f/ ASSEMBLE LINE
+ *STRLIM%2+1+WORD1 /ORG PAST BIGGEST STRING LIT
+NEWLIN, JMS I QGETC /ANY CHARS LEFT ?
+ JMP REMARK /NO, LINE ENDED OK
+ JMS I QERMSG /EXTRA CHARACTERS
+ 3003
+REMARK, DCA NOSN /CLEAR STMT NUMBER SWITCH
+ TAD TMPLVL /RESET TEMP LEVELS
+ DCA TMPCNT /FOR NUMERIC
+ TAD STMPLV /AND STRING
+ DCA STMPCT /TEMPORARIES
+ TAD (STACKO-1
+ DCA OSTACK /RESET STACK POINTERS
+ TAD STKLVL /(CHANGED BY FOR LOOPS)
+ DCA STACK
+ TAD (LINE-1 /GET THE NEXT LINE
+ DCA X10
+ TAD (-LINMAX/MAX SIZE
+ DCA TEMP3
+GETLIN, JMS ICHAR /GET NEXT CHAR
+ JMP GOTCR /CR
+ DCA I X10 /PUT INTO LINE BUFFER
+ ISZ TEMP3 /BUMP MAX COUNTER
+ JMP GETLIN
+ JMP GOTCR
+ERLTL, JMS I QERMSG /LINE TOO LONG
+ 1424
+ JMS ICHAR /SKIP REST OF LINE
+ JMP NOSNUM+3
+ CLA
+ JMP .-3
+GOTCR, TAD X10 /COMPUTE SIZE
+ CMA
+ TAD (LINE-1 /OF LINE
+ DCA NCHARS
+ TAD (LINE-1 /SETUP LINE POINTER
+ DCA CHRPTR
+/ TAD LOCTRL /PUT LOCATION COUNTER
+/ 7421 /INTO MQ
+ CLA CLL CML RAR /ALLOW DEFINITION
+ JMS I QSNUM /GET THE STATEMENT NUMBER
+ JMP NOSNUM /NO STMT NUMBER ON THIS LINE
+ ISZ NOSN /SET STMT NUMBER PRESENT
+ JMS I QMODSET /IN N MODE AT ALL LABELS
+ JMS I QNOREGS /FORGET REG CONTENTS
+ TAD WORD1 /SAVE NEW LINE NUMBER
+ DCA LINEH
+ TAD WORD2
+ DCA LINEL
+ JMS SETFLD /GET TO FIELD OF ENTRY
+ TAD I TEMP2 /GET DEFINED/REFNCED BITS
+ TAD LOCTRH /ADD IN HIGH ORDER LOCATION CTR
+ DCA I TEMP2 /PUT IT AWAY
+ ISZ TEMP2
+ TAD LOCTRL /NOW PUT IN LOW ORDER LOCATION
+ DCA I TEMP2
+ CDF
+NOSNUM, TAD TEMP3
+ SNA CLA
+ JMP ERLTL
+ JMS KBDCHK /CHECK FOR ^C OR ^O
+ TAD (KEYWRD-1
+ DCA X10 /SET UP FOR KEYWORD SEARCH
+ JMS I QSAVECP /SAVE CHAR POS
+KWLOOP, TAD I X10 /GET NEXT CHAR OF KEYWORD
+ SMA
+ JMP GOTKW /OK, THIS IS THE KW
+ DCA TEMP
+ JMS I QGETC /GET NEXT CHAR FROM STMT
+ JMP NOGOOD /THIS ISN'T IT
+ TAD TEMP /IS THIS CHAR OK ?
+ SNA CLA
+ JMP KWLOOP /YES, CONTINUE LOOKING
+NOGOOD, JMS I QRESTCP /BACK TO START OF STMT
+ TAD I X10 /SKIP OVER REST OF KEYWORD
+ SPA CLA
+ JMP .-2
+ TAD I X10 /IS THIS END OF LIST ?
+ SZA
+ JMP KWLOOP+3/NO, KEEP LOOKING
+ JMP LET /TREAT AS LET STMT
+GOTKW, DCA TEMP /SAVE ADDR OF ROUTINE
+ JMP I TEMP /GO PROCESS THE STMT
+\f/ LET STATEMENT PROCESSOR
+LET, JMS I QLODSN /LOAD THE STMT NUMBER
+ CLL CML RAR /COMPILE LEFT SIDE
+ JMS I QEXPR /GET EXPRESSION
+ JMP REMARK
+ JMS I QCHECKC /LOOK FOR =
+ -75
+ JMP BADLET /BAD IF MISSING
+ JMS I QEXPR /GET RIGHT SIDE
+ JMP REMARK
+ CLA CMA /GET TYPE OF
+ TAD OSTACK /RIGHT SIDE
+ DCA TEMP /OF EQUAL SIGN
+ TAD I TEMP /SO THAT WE GENERATE
+ SPA CLA
+ CLL CMA RAL /THE CORRECT STORE
+ TAD (ASSIGN-1
+ JMS I QOUTOPR /GENERATE STORE
+ JMP NEWLIN
+BADLET, JMS I QERMSG /BAD LET STMT
+ 1423
+ JMP REMARK
+END, TAD (STOP /OUTPUT STOP OPCODE
+ JMS I QOUTWRD
+ JMS OUDUMP /DUMP BUFFER
+ JMS I (7607 /READ IN POST PROCESSOR
+ 1300 /ELEVEN PAGES
+POSTX, 400 /FROM 400
+LDRBLK, 0 /FROM THIS BLOCK
+ IFNZRO LDRBLK-357 <__FIX BLOAD__>
+ JMP I XABORT
+ TAD I QERMSG /SET POST PROCESSOR ERROR SWITCH
+ DCA ERMSG2
+ JMP I POSTX /START IT UP
+\f/ RESTORE, PRINT, AND INPUT PROCESSORS
+ PAGE
+INPUT, JMS I QLODSN /OUTPUT STMT NUM
+ JMS GETFN /LOOK FOR #<FILE NUM EXPR>:
+INPUTL, CLL CML RAR /PROCESS INPUT STMT
+ JMS I QEXPR /GET EXPR
+ JMP I QREMARK
+ JMS I QGETA1 /GET TOP OF STACK
+ TAD TYPE1 /LOOK AT THE TYPE
+ SPA CLA
+ JMP RSTRNG /READ STRING
+ JMS I QMODSET /SET MODE
+ CLL CML RTR /IS IT DIMENSIONED ?
+ AND TYPE1
+ SZA CLA
+ JMP I (DIMREAD/YES
+ TAD (READ /OUTPUT READ COMMAND
+ JMS I QOUTWRD
+ TAD (FSTA /USE SCALAR STORE
+FININP, TAD SYMBL1 /PLUS SYMBOL NUMBER
+ JMS I QOUTWRD /OUTPUT INSTR
+ JMS I QCHECKC /LOOK FOR ,
+ -54
+ JMP I QNEWLIN /END OF INPUT
+ JMP INPUTL /YES, LOOP
+RSTRNG, CLL CML RAR /SET MODE
+ JMS I QMODSET /TO STRING
+ CLL CML RTR /SUBSCRIPTED ?
+ AND TYPE1
+ SNA CLA
+ JMP .+3 /NO
+ JMS I QLOADSS /LOAD SS REG
+ TAD (SAREAD-SREAD
+ TAD (SREAD /STRING READ
+ JMP FININP /USE SOME COMMON CODE
+PRINT, JMS I QLODSN /OUTPUT STMT NUM
+ JMS GETFN /GET FILE NUMBER
+ DCA I QEXPR /USE ENTRY AS SWITCH
+PRINTL, DCA PCRLF /CLEAR THE FLAG
+ JMS I QGETC /LOOK FOR A CHAR
+ JMP PRTEND /NONE LEFT, END PRINT
+ TAD (-73 /; ?
+ SNA
+ JMP NOCR /YES, DON'T SPACE OUTPUT
+ TAD (73-54 /, ?
+ SZA CLA
+ JMP TABPNT /LOOK FOR TAB OR PNT
+ TAD (FUNC3+20
+ JMS I QOUTWRD /OUTPUT FUNC3+20 (COMMA)
+NOCR, DCA I QEXPR /CLEAR THE SWITCH
+ CLA IAC /SET NO CRLF FLAG
+ JMP PRINTL
+TABPNT, TAD I QEXPR /WAS LAST THING AN EXPR ?
+ SZA CLA
+ JMP I QNEWLIN /YES, CAN'T HAVE TWO IN A ROW
+ JMS I QBACK1 /PUT THAT CHAR BACK
+ JMS I QSAVECP /SAVE CHAR POS
+ JMS I QCHKWD /LOOK FOR "TAB("
+ WTAB
+ JMP TRYPNT /NO TAB
+ TAD (FUNC3+100
+PFCALL, DCA PRFUN /SAVE PRINT FUNCTION
+ JMS I QEXPR /GET ARG
+ JMP I QREMARK
+ JMS I QLOAD /LOAD ARG
+ TAD TYPE1 /MUST BE NUMERIC
+ SMA CLA
+ JMP .+4 /OK, IT IS
+BADPF, JMS I QERMSG /PRINT ERROR
+ 0622 /BAD FUNCTION REFERENCE
+ JMP I QREMARK
+ JMS I QCHECKC /LOOK FOR )
+ -51
+ JMP BADPF /BAD FUN REFERENCE
+ TAD PRFUN /OUTPUT FUNCTION CALL
+ JMP PUT1
+TRYPNT, JMS I QRESTCP /RESTORE CHAR POS
+ JMS I QCHKWD /LOOK FOR PNT(
+ WPNT
+ JMP PEXP /NO
+ TAD (FUNC3+120
+ JMP PFCALL /GO DO FUN CALL
+PEXP, JMS I QRESTCP /RESTORE CHAR POS
+ JMS I QEXPR /GET EXPR TO BE PRINTED
+ JMP I QREMARK
+ JMS I QLOAD /PUT THING INTO FAC (OR SAC)
+ CLL CML RAR
+ AND TYPE1 /GET TYPE BIT
+ CLL RTL /INTO AC 11
+ TAD (WRITE /SWRITE=WRITE+1
+PUT1, JMS I QOUTWRD
+ JMP PRINTL
+PRTEND, TAD PCRLF /DID PRINT END WITH
+ SZA CLA /, OR ;
+ JMP I QNEWLIN /YES, NO CR LF
+ TAD (FUNC3+40
+PUT2, JMS I QOUTWRD /CALL TO CRLF ROUTINE
+ JMP I QNEWLIN /END OF PRINT
+RESTOR, JMS I QLODSN /OUTPUT LOAD STMT NUMBER
+ CLA IAC /NO COLON NEEDED
+ JMS GETFN /LOAD FILE REG
+ TAD (REST /OUTPUT RESTORE OP
+ JMP PUT2
+PRFUN,
+LODSN, 0 /OUTPUT STMT NUMBER INTO CODE
+ TAD NOSN /ANY STMT NUMBER ?
+ SNA CLA
+ JMP I LODSN /NO, JUST RETURN
+ TAD WORD1 /NOW OUTPUT "LOAD STMT NUM REG"
+ TAD (LOADSN
+ JMS I QOUTWRD
+ TAD WORD2
+ JMS I QOUTWRD
+ JMP I LODSN
+
+XADD, FADD;AFADD
+\f/ DIM PROCESSOR
+ PAGE
+DIM, JMS I QGETNAM /GET VAR NAME
+ JMP DIMERR
+ TAD TYPE /CHECK TYPE
+ RTL /MOVE BITS TO BE TESTED
+ SMA CLA /IF FUNC BIT SET THEN ERROR
+ SNL /IF DIM BIT NOT SET THEN ERROR
+ JMP DIMERR /NO DIMENSIONS
+ JMS SMLNUM /GET DIMENSION
+ TAD EXPON /SAVE IT
+ DCA DIM1
+ JMS I QCOMARP /, OR ) ??
+ JMP DIMERR /NEITHER IS BAD
+ JMP TWODIM /, THERE'S ANOTHER DIMENSION
+ JMS CHKSDM /CHECK SIZE IF STRING
+ JMP CHKDIM /NUMERIC VECTOR, CHECK PREV REF
+ CLL CML RAR /THIS WAS A STRING SIZE DIM
+ DCA TYPE /PERFORM THE SPECIAL CASE
+ JMS I QLOOKUP
+ CDF 10 /OF NOT CHECKING PREVIOUS REFS
+ JMP FINDIM
+TWODIM, JMS SMLNUM /GET SECOND
+ JMS I QCHECKC /LOOK FOR )
+ -51
+ JMP DIMERR
+ JMS CHKSDM /CHECK SIZE IF STRING ARRAY
+ TAD (7000 /NUMERIC ARRAY
+CHKDIM, TAD (7000 /GET NUMBER OF DIMS
+ DCA TEMP
+ JMS I QLOOKUP /FIND ST ENTRY
+ CDF 10
+ TAD I STPTR /LOOK AT DIM BITS
+ AND (7000 /PREVIOUSLY REFERENCED ?
+ SNA
+ JMP UNREFD /NO
+ SMA /IF MINUS, CAUSE ERROR
+ TAD TEMP /COMPARE NUMBER
+ SZA CLA
+ JMP DIMERR /NUMBER OF DIMS DON'T MATCH
+ DCA TEMP /ZERO TEMP
+UNREFD, CLL CML RAR /PUT IN DIMENSIONED BIT
+ TAD TEMP /AND NUMBER OF DIMENSIONS
+ CIA /NEGATE WHOLE MESS (4000=-4000)
+ TAD I STPTR /TOGETHER WITH SYM NUMBER
+ DCA I STPTR
+ ISZ STPTR
+ TAD DIM1 /NOW FIRST DIMENSION (IF 2)
+ DCA I STPTR
+FINDIM, ISZ STPTR
+ TAD EXPON /NOW SECOND (IF 2, OTHERWISE FIRST)
+ DCA I STPTR
+ CDF
+ JMS I QCHECKC /LOOK FOR ,
+ -54
+ JMP I QNEWLIN /NONE, ASSUME END OF DIM
+ JMP DIM /GET NEXT ELEMENT
+CHKSDM, 0 /CHECK SIZE OF STRINGS
+ TAD TYPE /WAS THIS A STRING DIM ?
+ SMA CLA
+ JMP I CHKSDM /NO, RETURN IMMEDIATE
+ ISZ CHKSDM /YES, SKIP ON RETURN
+ TAD EXPON /SIZE MUST BE < 73
+ CLL
+ TAD (-STRLIM-1
+ SNL CLA
+ JMP I CHKSDM /OK, SIZE < 73
+DIMERR, JMS I QERMSG /GIVE ERROR
+ 0411
+ JMP I QREMARK /ABORT STMT
+\f/ NEXT PROCESSOR
+NEXTX, JMS I QGETNAM /GET INDEX VARIABLE
+ JMP BADNXT
+ JMS I QLOOKUP
+ TAD TYPE /MUST BE NUMERIC
+ SPA CLA
+ JMP BADNXT /IT ISN'T
+ JMS I QMODSET /N MODE
+NEXTL, TAD (-STACKA-3
+ TAD STACK /ANY FOR'S LEFT ?
+ SPA CLA /(OK IF STACKA ABOVE 4000)
+ JMP BADNXT /NO
+ JMS I QPOP /GET LABEL ADDR
+ DCA TEMP
+ JMS I QPOP /GET LABEL FIELD
+ DCA LUPFLD
+ JMS I QPOP /GET STEP VAR
+ TAD XLOAD /LOAD IT
+ JMS I QOUTWRD
+ JMS I (PSETJF /PATCH!
+ TAD FINDEX /ADD IT TO STEP (FADD=0)
+ JMS I QOUTWRD
+ TAD LUPFLD /CREATE JUMP TO LOOP
+ AND (70
+ CLL RTL
+ TAD (JUMP
+ JMS I QOUTWRD
+ CLL CMA RAL /GET LABEL DEFINITION ADDR
+ TAD TEMP
+ JMS I QOUTWRD /OUTPUT IT AS LOW PART OF JUMP
+DIM1,
+LUPFLD, HLT
+ CLL CML RAR /SET LABEL DEFINED BIT
+ TAD LOCTRH /DEFINE END OF LOOP LABEL
+ DCA I TEMP
+ ISZ TEMP
+ TAD LOCTRL
+ DCA I TEMP
+ CDF
+ TAD STACK /BACK OFF STACK LEVEL
+ DCA STKLVL
+ JMS I QNOREGS /FORGET REGS
+ TAD SYMBOL /IS THIS THE RIGHT NEXT ?
+ CIA
+ TAD FINDEX
+ SNA CLA
+ JMP I QNEWLIN /YES, FINISHED
+BADNXT, JMS I QERMSG /NEXT WITHOUT FOR
+ 1606
+ JMP I QREMARK
+UMOPR, 40;1;UMRTNE-1
+XLOAD, FLDA;AFLDA
+\f/ UDEF PROCESSOR (DEFINE USER FUNCTION)
+ PAGE
+UDEF, ISZ NFUNS /ROOM FOR ANOTHER FUN ?
+ JMS I QLETTER /GET FIRST LETTER
+ JMP DEFBAD /ERROR IN DEFINE
+ CLL RTL /PUT INTO HIGH ORDER
+ RTL
+ RTL
+ DCA NAME1 /SAVE CHAR 1
+ JMS I QLETTER /GET SECOND LETTER
+ JMP DEFBAD /ERROR
+ TAD NAME1 /COMBINE THE TWO CHARS
+ CIA
+ DCA I FUNPTR /SAVE IN FUN TABLE
+ ISZ FUNPTR
+ JMS I QLETTER /GET THIRD LETTER
+ JMP DEFBAD
+ CIA /SAVE NEG OF THIRD LETTER
+ DCA I FUNPTR
+ ISZ FUNPTR /BUMP POINTER
+ TAD M5 /NUMERIC ARG COUNT
+ DCA TEMP / (MAX OF 4 ARGS)
+ CLL CMA RTL /STRING ARG COUNT
+ DCA TEMP2 / (MAX OF 2 ARGS)
+ JMS I QCHECKC /IS IT A STRING FUN ?
+ -44
+ SKP CLA
+ CLL CML RAR /YES, SET TYPE OF FUNCTION
+ DCA TYPE1
+ JMS I QCHECKC /LOOK FOR (
+ -50
+ JMP DEFBAD /ERROR IF MISSING
+DALOOP, JMS I QGETNAM /GET AN ARG
+ JMP DEFBAD
+ TAD TYPE /LOOK AT ITS TYPE
+ CLL RAL /SHIFT TYPE BIT INTO LINK
+ SZA CLA
+ JMP DEFBAD /OTHER BITS MUST BE OFF
+ SZL
+ JMP STRARG /STRING ARG
+ TAD TEMP /GET ARG NUMBER
+ ISZ TEMP /INCREMENT IT
+ JMP DAPUSH /GO SAVE IT
+DEFBAD, JMS I QERMSG /BAD USER DEF
+ 2504
+ JMP I QREMARK
+STRARG, TAD TEMP2 /GET ARG NUMBER
+ ISZ TEMP2 /AND INCREMENT IT
+ JMP DAPUSH+1
+ JMP DEFBAD /TOO MANY STRING ARGS
+DAPUSH, TAD Q2 /ADJUST ARG NUMBER
+ TAD Q2 /ADD 4 FOR NUM, 2 FOR STRING
+ SPA
+ CLA CLL CML RTR /FIRST ARG STAYS IN AC
+ TAD TYPE /ADD IN TYPE BIT
+ JMS I QPUSH /SAVE IT ON STACK
+ JMS I QCOMARP /LOOK FOR , OR )
+ JMP DEFBAD /ERROR IF NEITHER
+ JMP DALOOP /, GET NEXT ARG
+ TAD TEMP2 /GET TOTAL NUMBER OF ARGS
+ TAD TEMP
+ TAD Q10 /ADJUST COUNT
+ CIA /NEGATED
+ DCA DACNT
+ TAD I FUNPTR /GET FUNCTION CODE
+ ISZ FUNPTR /BUMP POINTER
+ DCA WORD1 /MAKE IT THE SEARCH OBJECT
+ JMS I XSTCHEK /MAKE SURE THERE'S ROOM
+ EOST-10
+ JMS I QLUKUP2 /ENTER NEW FUNCTION
+ FUNCTN
+ -1
+ TAD DACNT /PUT IN ARG COUNT
+ JMS SETFLD /(FIRST SET THE FIELD)
+ DCA I NEXT
+DAPUT, CDF
+ JMS I QPOP /GET ARG TYPE (LAST TO FIRST)
+ JMS SETFLD /SET THE FIELD
+ DCA I NEXT /SAVE IT
+ ISZ DACNT /ANY MORE ?
+ JMP DAPUT /YES
+ TAD TYPE1 /PUT IN TYPE OF FUNCTION
+ DCA I NEXT
+ CDF
+ JMS I QCHECKC /LOOK FOR A COMMA
+ -54
+ JMP I QNEWLIN /NO COMMA, END OF LINE
+ JMP UDEF /GET NEXT DEFINITION
+XSTCHEK,STCHEK
+FUNPTR, ENDFNS
+Q2, 2 /THESE FOUR WORDS
+M5, -5 /PREVENT ERRONEOUS "SAVES"
+Q10, 10 /BY THE ROUTINE SAVAC
+NFUNS, -21 /WHEN THE OP STACK IS EMPTY
+STACKO, /OPERAND STACK
+ STOKSZ=UDEF+200-STACKO
+\f/ DEF PROCESSOR
+ PAGE
+DEF, JMS I QNOREGS /FORGET REGS
+ JMS I QGETNAM /GET FUN NAME
+ JMP BADDEF /NO GOOD
+ TAD TYPE /SAVE ITS TYPE
+ DCA TEMP2
+ DCA ARGCNT /ZERO ARG COUNT
+ TAD TYPE /TYPE MUST BE 3000 OR 7000
+ RTL /MOVE BITS TO BE TESTED
+ SPA CLA /FUN BIT OFF IS AN ERROR
+ SNL /DIM BIT OFF IS AN ERROR
+ JMP BADDEF
+ JMS I QMODSET /ENTER N MODE
+ TAD SYMBOL /SAVE FUNCTION NAME
+ DCA FUNNAM
+ARGLUP, JMS I QGETNAM /GET ARG NAME
+ JMP BADDEF
+ CLL CMA RAR /LOOK AT TYPE
+ AND TYPE
+ SZA CLA
+ JMP BADDEF /ARG WAS AN ARRAY OR FUNC
+ JMS I QLOOKUP /ENTER INTO S.T.
+ TAD STPTR /SAVE ST ADDRESS
+ JMS I QPUSH
+ TAD SYMBOL /AND SYMBOL NUMBER
+ JMS I QPUSH
+ TAD TYPE /AND ARG TYPE
+ JMS I QPUSH
+ ISZ ARGCNT /BUMP ARG COUNT
+ JMS I QCOMARP /LOOK FOR , OR )
+ JMP BADDEF
+ JMP ARGLUP /, GET NEXT ARG
+ TAD FUNNAM /ENTER FUNCTION
+ DCA WORD1
+ TAD ARGCNT /FIRST GET ENOUGH ROOM
+ CIA
+ TAD (EOST-3
+ DCA FUNNAM
+ JMS STCHEK /CHECK IT
+FUNNAM, 0
+ JMS I QLUKUP2 /LOOK UP FUNCTION
+ FUNCTN
+ -1
+ JMP OKFUN /OK, NOT MULTIPLY DEFINED
+BADDEF, JMS I QERMSG /BAD DEFINE
+ 0405
+ JMP I QREMARK
+OKFUN, TAD NEXT /SAVE "NEXT"
+ DCA X12
+ TAD NEXT /INCREMENT NEXT BY
+ TAD ARGCNT /NUMBER OF ARGS
+ TAD (4 /PLUS 4
+ DCA NEXT
+ JMS SETFLD /GET ROOM FOR LABEL
+ CLL CML RAR /FOR JUMP AROUND
+ DCA I NEXT /SET DEFINED BIT
+ TAD NEXT /SAVE ADDR
+ DCA JAROND /FOR LATER
+ ISZ NEXT
+ CDF
+ TAD LUFLD /SAVE FIELD OF FUN BLOCK
+ DCA FUNFLD
+ TAD LUFLD /ALSO FIELD OF LABEL
+ DCA JARFLD
+ TAD LUFLD /GET FIELD
+ AND (70 /ISOLATE BITS
+ CLL RTL /INTO JUMP INSTR
+ TAD (JUMP
+ JMS I QOUTWRD /OUTPUT IT
+ TAD JAROND /OUTPUT LOW PART
+ JMS I QOUTWRD /OF JUMP ADDR
+ TAD STACK /SAVE STACK
+ DCA OLDSTK
+ TAD ARGCNT /GET COUNT
+ CMA
+ DCA TEMP
+ TAD ARGCNT /TWICE
+ CIA
+ DCA ARGCNT
+ TAD ARGCNT /STORE COUNT FIRST
+ JMP FUNFLD
+CHGARG, CDF
+ JMS I QPOP /GET ARG TYPE
+ DCA TYPE
+ TAD TYPE
+ JMS GENTMP /GENERATE A TEMPORARY
+SWTARG, JMS I QPOP /PURGE SYMBOL NUMBER
+ CLA
+ JMS I QPOP /GET ST ADDR OF
+ DCA STPTR /OF DUMMY ARG
+ CDF 10
+ TAD SYMBOL /PUT IN TEMP SYMBOL NUMBER
+ DCA I STPTR /TO FAKE EXPR
+ TAD TYPE /CREATE ARG DESCRIPTOR
+ TAD SYMBOL /FOR FUNC BLOCK
+FUNFLD, HLT
+ DCA I X12 /AND PUT IT INTO F.B.
+ ISZ TEMP /MORE ARGS?
+ JMP CHGARG /YUP
+ CLL CML RAR
+ AND TEMP2 /SAVE TYPE OF FUNCTION
+ DCA I X12
+ CLL CML RAR /SET DEFINED BIT
+ TAD LOCTRH /AND LOCATION COUNTER
+ DCA I X12 /AT START OF FUNCTION
+ TAD LOCTRL
+ DCA I X12
+ CDF
+ TAD STACK /SAVE BOTTOM OF STACK
+ DCA X13
+ TAD OLDSTK /RESTORE TO TOP
+ DCA STACK
+ JMS I QCHECKC /FIND =
+ -75
+ JMP BADDEF
+ JMS I QEXPR /COMPILE FUNCTION
+ JMP I QREMARK
+ JMS I QLOAD /GET IT INTO AC
+ TAD X13 /RESTORE STACK
+ DCA STACK /TO BOTTOM
+ JMP RESARG /FINISH DEF
+\f/ DEF PROCESSOR (FINALE)
+ PAGE
+RESARG, TAD I X13 /GET ST ADDR
+ DCA STPTR
+ TAD I X13 /PUT BACK CORRECT SYM #
+ CDF 10
+ DCA I STPTR
+ CDF
+ ISZ X13 /SKIP OTHER STUFF
+ ISZ ARGCNT
+ JMP RESARG /RESTORE NEXT
+ TAD (RET /OUTPUT RETURN CODE
+ JMS I QOUTWRD
+JARFLD, HLT
+ CLL CML RAR /SET LABEL DEFINED BIT
+ TAD LOCTRH /STICK IN ADDR
+ DCA I JAROND /OF END OF FUNCT
+ ISZ JAROND /PLUS ONE
+ TAD LOCTRL /STORE LOW ADDR
+ DCA I JAROND
+ CDF
+ TAD TMPCNT /SAVE NEW TEMP LEVELS
+ DCA TMPLVL
+ TAD STMPCT
+ DCA STMPLV
+ JMS I QNOREGS /FORGET REGS
+ JMP I QNEWLIN /END OF DEF
+\f/ DATA STATEMENT PROCESSOR
+DATA, JMS I QNUMBER /LOOK FOR NUMBER
+ JMP DSTRNG /MUST BE A STRING
+ JMS DENTRY /MAKE AN ENTRY
+ -3 /3 WORDS LONG
+MORDAT, JMS I QCHECKC /LOOK FOR ,
+ -54
+ JMP I QNEWLIN /END OF DATA
+ JMP DATA /DO NEXT ELEMENT
+DSTRNG, JMS I QSTRING /LOOK FOR STRING
+ JMP I QNEWLIN /BAD
+ TAD WORD1 /COMPUTE SIZE
+ IAC
+ CLL CML CMA RAR
+ DCA DSSIZE /INCLUDING CHAR COUNT
+ TAD WORD1 /NEGATE COUNT
+ CIA
+ DCA WORD1
+ JMS DENTRY /CREATE ENTRY
+DSSIZE, 0
+ JMP MORDAT /GO DO MORE
+DENTRY, 0 /MAKE AN ENTRY IN DATA LIST
+ TAD I DENTRY /GET SIZE
+ DCA TEMP
+ ISZ DENTRY
+ TAD TEMP /INCREMENT SIZE COUNT
+ TAD DLSIZE
+ DCA DLSIZE
+ TAD (EOST /HOW MUCH DO WE NEED ?
+ TAD TEMP
+ DCA .+2
+ JMS STCHEK /ASK FOR IT
+ 0
+ TAD FREFLD /GET FIELD OF FREE SPACE
+ DCA LUFLD /SAVE IT IN SETFLD SUBROUTINE
+DATFLD, CDF 10
+ TAD NEXT /HOOK IN NEW ENTRY
+ IAC
+ DCA I DATPTR
+PATCH3, ISZ DATPTR /POINTER THEN FIELD
+ TAD LUFLD
+ DCA I DATPTR
+ JMS SETFLD
+ TAD TEMP /SAVE SIZE OF ENTRY
+ DCA I NEXT
+ TAD (WORD1-1/MAKE READY TO MOVE
+ DCA X10
+DELOOP, CDF
+ TAD I X10 /GET WORD
+ JMS SETFLD
+ DCA I NEXT /SAVE IT
+ ISZ TEMP /MORE ?
+ JMP DELOOP
+ DCA I NEXT /SAVE ROOM FOR POINTER&CDF
+ TAD NEXT /THIS IS NOW LAST ENTRY
+ DCA DATPTR
+PATCH4, TAD LUFLD
+ DCA DATFLD /AND THIS IS ITS FIELD
+ DCA I NEXT
+ CDF
+ JMP I DENTRY
+DATPTR, DATLST
+\f/ READ PROCESSOR
+READX, JMS I QLODSN /OUTPUT STMT NUMBER
+ CLL CML RAR /GET VAR TO READ
+ JMS I QEXPR /SAME AS LEFT SIDE OF LET
+ JMP I QREMARK
+ JMS I QGETA1 /GET VAR INFO FROM STACK
+ TAD TYPE1 /SET MODE
+ JMS I QMODSET
+ TAD TYPE1 /WHAT TYPE ?
+ SPA CLA
+ TAD (SRDL-NRDL
+ TAD (NRDL /STRING OR NUMERIC
+ JMS I QOUTWRD
+ CLL CML RTR /SUBSCRIPTS ?
+ AND TYPE1
+ SNA CLA
+ JMP .+3 /NO
+ JMS I QLOADSS /YES, LOAD SS REGS
+ TAD (AFSTA-FSTA
+ TAD (FSTA /ARRAY OR SCALAR STORE
+ TAD SYMBL1
+ JMS I QOUTWRD
+ JMS I QCHECKC /ANY MORE ?
+ -54 /CHECK FOR COMMA
+ JMP I QNEWLIN /NO
+ JMP READX+1 /YUP
+AMPSND, 40;1;AMPRTN-1;4000;SCONTS;SCONTS
+SCONTS, FADD;AISUB
+\f/ FOR PROCESSOR
+ PAGE
+FOR, JMS I QLODSN /OUTPUT STMT NUMBER
+ JMS I QGETNAM /GET INDEX VARIABLE
+ JMP BADFOR /BAD
+ TAD TYPE /MUST BE NUMBER
+ SZA CLA
+ JMP BADFOR /ITS NOT
+ JMS I QLOOKUP /ST SEARCH
+ TAD SYMBOL /SAVE INDEX VAR
+ DCA FINDEX /FOR LATER
+ JMS I QCHECKC /FIND =
+ -75
+ JMP BADFOR
+ TAD CHRPTR /SAVE CHAR POSITION
+ DCA FORCP /IN A SPECIAL PLACE
+ TAD NCHARS
+ DCA FORNC
+ SKP
+FINDTO, JMS I QRESTCP /RESTORE CHAR POS
+ JMS I QGETC /SKIP A CHAR
+ JMP BADFOR
+ CLA
+ JMS I QSAVECP /SAVE THIS POSITION
+ JMS I QCHKWD /LOOK FOR "TO"
+ WTO
+ JMP FINDTO /KEEP GOING
+ JMS FSUB2 /LOAD LIMIT AND SAVE IN TEMP
+ DCA FLIMIT /SAVE LIMIT VAR
+ JMS I QCHKWD /LOOK FOR "STEP"
+ WSTEP
+ JMP STEP1 /USE 1.0 FOR THE STEP
+ JMS FSUB2 /LOAD STEP AND SAVE IN TEMP
+ DCA FSTEP /SAVE STEP VAR
+ TAD (SETJF /OUTPUT SETJF
+ JMS I QOUTWRD
+ TAD (JFOR /STEP IS VARIABLE, USE JFOR
+SAVEJF, DCA FORJMP /SAVE CORRECT JUMP
+ JMS I QGETC /ANY MORE CHARS ?
+ SKP
+ JMP BADFOR /YES, ERROR
+ TAD FORNC /RESTORE CHAR POSITION
+ DCA NCHARS /FROM SPECIAL PLACE
+ TAD FORCP
+ DCA CHRPTR
+ JMS FSUB1 /COMPILE INITIAL VALUE INTO FAC
+ JMS STCHEK /CHECK FOR ROOM
+ EOST
+ TAD FREFLD /SAVE FIELD OF LABELS
+ DCA FORFLD
+FORFLD, HLT
+ CLL CML RAR /SET LABEL DEFINED BIT
+ TAD LOCTRH /DEFINE THE LOOP LABEL
+ DCA I NEXT
+ TAD LOCTRL
+ DCA I NEXT
+ CLL CML RAR /SET LABEL DEFINED BIT
+ DCA I NEXT /FOR END OF LOOP LABEL
+ CDF
+ TAD FLIMIT /TEST FOR DONE
+ TAD XSUB /BY SUBTRACTING THE LIMIT
+ JMS I QOUTWRD
+ TAD FORFLD /OUTPUT JUMP TO DONE
+ AND (70
+ CLL RTL /SHIFT FIELD BITS
+ TAD FORJMP /USE PROPER JUMP INS
+ JMS I QOUTWRD
+ TAD NEXT /OUTPUT LOW PART OF JMP
+ JMS I QOUTWRD
+ TAD FLIMIT /FADD FLIMIT (FADD=0)
+ JMS I QOUTWRD
+ TAD FINDEX /FSTA INDEX
+ TAD (FSTA
+ JMS I QOUTWRD
+ TAD FINDEX /PUT STUFF ONTO STACK
+ JMS I QPUSH
+ TAD FSTEP
+ JMS I QPUSH
+ TAD FORFLD
+ JMS I QPUSH
+ TAD NEXT
+ JMS I QPUSH
+ ISZ NEXT /BUMP NEXT AGAIN
+ TAD TMPCNT /RESERVE THESE TEMPS
+ DCA TMPLVL
+ JMS I QNOREGS /FORGET REGISTORS
+ TAD STACK /SET NEW STACK LEVEL
+ DCA STKLVL
+ JMP I QREMARK
+STEP1, TAD (3 /1.0 IS SLOT #3
+ DCA FSTEP
+ TAD (JGT /USE JGT
+ JMP SAVEJF /GO DO THE REST
+FLIMIT, 0 /FOR LOOP UPPER LIMIT
+FSTEP, 0 /FOR LOOP STEP
+FORNC, 0 /FOR STMT CHAR POSITION
+FORCP, 0
+WTHEN, -124;-110;-105;-116
+XSUB, FSUB;AFSUB
+\f/ USE PROCESSOR
+USEX, TAD (USE /OUTPUT USE OPERATOR
+ JMS I QOUTWRD
+ JMS I QGETNAM /GET ARRAY NAME
+ JMP USEERR /ERROR
+ TAD TYPE /CHECK TYPE
+ SMA CLA /(MUST BE NUMERIC)
+ JMP .+3 /IT WAS
+USEERR, JMS I QERMSG /ERROR IN USE STMT
+ 2525
+ CLL CML RTR /SET DIM BIT
+ DCA TYPE
+ JMS I QLOOKUP /LOOKUP SYMBOL
+ TAD SYMBOL /OUTPUT ARRAY NUMBER
+ JMS I QOUTWRD
+ JMP I QREMARK
+\f/ IF AND IFEND PROCESSORS
+ PAGE
+IF, JMS I QLODSN /OUTPUT STMT NUMBER
+ JMS I QEXPR /GET LEFT EXPRESSION
+ JMP I QREMARK
+ JMS I QGETC /GET RELATIONAL OPERATOR
+ JMP BADIF /ERROR IF NONE
+ CLL RTL
+ RTL /MOVE TO LEFT HALF
+ RTL
+ DCA TEMP /AND SAVE IT
+ JMS I QGETC /GET 2 CHAR RELATIONALS
+ JMP BADIF
+ TAD TEMP /COMBINE THE 2
+ DCA TEMP2
+ TAD (IFOPS-1/SETUP POINTER
+ DCA X10
+IFLUP1, TAD I X10 /GET JUMP OPCODE
+ SNA
+ JMP IFLUP2-1/NOT A 2 CHAR RELATIONAL
+ DCA RELOPR /SAVE IT
+ TAD I X10 /COMPARE CHARS
+ TAD TEMP2
+ SZA CLA
+ JMP IFLUP1 /NOT THIS OOE
+GOTREL, JMS I QEXPR /GET RIGHT HALF
+ JMP I QREMARK
+ CLA CMA /GET TYPE OF RIGHT SIDE
+ TAD OSTACK
+ DCA TEMP
+ TAD I TEMP
+ SPA CLA
+ JMP STRCMP /STRING, DO STRING COMPARE
+ TAD (MINUS /NUMERIC, DO A SUBTRACT
+ JMS I QOUTOPR
+NUMCMP, JMS I QSAVECP /SAVE CHAR POSITION
+ JMS I QCHKWD /LOOK FOR "THEN"
+ WTHEN
+ JMP NOTHEN /NOT THEN
+GETIFN, JMS I QSNUM /GET STATEMENT NUMBER
+ JMP BADGO2
+ TAD TEMP /OUTPUT JUMP
+ TAD RELOPR
+ JMS I QOUTWRD
+ TAD TEMP2 /TWO WORDS
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+NOTHEN, JMS I QRESTCP /BACKUP CHAR POS
+ JMS I QCHKWD /LOOK FOR "GOTO"
+ WGOTO
+ SKP
+ JMP GETIFN /OK, GO GET STMT NUMBER
+BADIF, JMS I QERMSG /BAD IF STMT
+ 1106
+ JMP I QREMARK
+STRCMP, TAD (SCOMPR-1
+ JMS I QOUTOPR /OUTPUT STRING COMPARE
+ JMS I QMODSET /BACK TO N MODE
+ JMP NUMCMP /REST IS LIKE NUMERIC COMPARES
+ JMS I QBACK1 /PUT BACK NON OPERATOR
+IFLUP2, TAD I X10 /GET CONDITIONAL JUMP
+ SNA
+ JMP BADIF /RELATIONAL INCORRECT
+ DCA RELOPR
+ TAD I X10 /COMPARE OPERATORS
+ TAD TEMP
+ SNA CLA
+ JMP GOTREL /GOTIT
+ JMP IFLUP2
+IFEND, JMS I QLODSN /OUTPUT STMT NUMBER
+ CLA IAC /(NO COLON)
+ JMS GETFN /GET FILE NUMBER
+ TAD (JEOF /SETUP CORRECT JUMP
+ DCA RELOPR
+ JMP NUMCMP /GO FIND "THEN" OR "GOTO"
+RELOPR,
+GETFN, 0 /GET FILE NUMBER
+ DCA COLON /SAVE COLON SWITCH
+ JMS I QCHECKC /LOOK FOR #
+ -43
+ JMP TTYFIL /NONE, MUST BE TTY
+ JMS I QEXPR /GET FILE EXPR
+ JMP I QREMARK /ERROR
+ TAD COLON /DO WE NEED A COLON ?
+ SZA CLA
+ JMP .+4 /NO, SKIP THIS TEST
+ JMS I QCHECKC /YES, LOOK FOR IT
+ -72
+ JMP BADFN /NOT THERE, BAD
+ JMS I QLOAD /LOAD IT
+ TAD TYPE1 /TYPE MUST BE NUMERIC
+ SPA CLA
+BADFN, JMS I QERMSG /NOPE, IT ISN'T
+ 0616
+ CLA IAC /SET IFNREG TO "NOT TTY"
+ DCA IFNREG /SAVE NEW IFNREG
+ TAD (FILENO /OUTPUT SET IFN COMMAND
+ JMS I QOUTWRD
+ JMP I GETFN
+TTYFIL, TAD IFNREG /IS IFNREG 0 ?
+ SNA CLA
+ JMP I GETFN /IF YES, QUIT
+ TAD (CLRFN /OTHERWISE ZERO AC
+ JMS I QOUTWRD
+ DCA IFNREG /SET IFNREG TO TTY
+ JMP I GETFN /RETURN
+\f/ GOTO AND GOSUB
+GOTO, JMS I QSNUM /GET NUMBER
+ JMP BADGO2
+ JMS I QMODSET /ALL GOTO'S IN NMODE
+ CLA IAC /JUMP=JSUB+1
+ JMP .+5
+GOSUB, JMS I QLODSN /OUTPUT STMT NUM LOAD
+ JMS I QSNUM /GET NUMBER
+ JMP BADGO2
+ JMS I QMODSET /ALL GOTO'S IN NMODE
+ TAD (JSUB /GET GOSUB OPCODE
+ TAD TEMP /PLUS ADDRESS
+ JMS I QOUTWRD /OUTPUT IT
+ TAD TEMP2 /BOTH WORDS
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+BADGO2, JMS I QERMSG /BAD GOTO OR GOSUB
+ 1615 /NUMBER MISSING
+ JMP I QREMARK
+\f/ TABLE SEARCH FOR LITERALS, STMT NUMBERS, TEMPS, ETC.
+ PAGE
+LUKUP2, 0
+ TAD I LUKUP2 /GET THE BUCKET START
+ DCA OLDN3 /SAVE IT AS THE PREVIOUS ENTRY
+ ISZ LUKUP2
+ TAD I LUKUP2 /GET THE ENTRY SIZE
+ ISZ LUKUP2
+ DCA N3SIZE
+ TAD (6211 /PRIME THE FIELD SETTER
+ DCA LUFLD
+ JMS SETFLD /NOW SET THE FIELD
+LOOK2, TAD I OLDN3 /GET ADDR OF NEXT ENTRY
+ DCA NEWN3 /SAVE IT
+PATCH1, ISZ OLDN3 /GET TO FIELD OF NEW ENTRY
+ TAD I OLDN3 /GET INTO AC
+ DCA NEWFLD /AND SAVE IT
+ TAD NEWN3
+ SNA
+ JMP HOOKIN /IF 0 ITS END OF LIST
+PATCH5, IAC
+ DCA X10 /START OF VALUE INFO
+ TAD (WORD1-1/SETUP POINTER TO VALUE
+ DCA X11
+ TAD N3SIZE /AND TEMP OF ENTRY SIZE
+ DCA LTEMP
+CHKVAL, CDF
+ TAD I X11
+ CIA CLL /COMPARE THIS WORD
+NEWFLD, CDF 10 /FIELD OF NEW ENTRY
+ TAD I X10
+ SZA CLA
+ JMP NOTSAM /NOT THIS ONE
+ ISZ LTEMP /INCR SIZE COUNT
+ JMP CHKVAL /MORE STUFF
+ TAD I X10 /GET SYMBOL NUMBER
+L6201, CDF
+ DCA SYMBOL
+ TAD NEWFLD /MAKE ENTRY ADDRESSABLE
+ DCA LUFLD /THROUGH SETFLD
+ ISZ LUKUP2 /BUMP RETURN
+ JMP I LUKUP2
+NOTSAM, SZL
+ JMP HOOKIN /NEW SYMBOL < CURRENT
+ TAD NEWN3 /GO TO NEXT ENTRY
+ DCA OLDN3 /(MOVE POINTER)
+ TAD NEWFLD /(AND FIELD)
+ DCA LUFLD
+ JMP LOOK2
+HOOKIN, CLL CMA RAL /HOW MANY WORDS NEEDED ?
+ TAD N3SIZE
+ TAD (EOST
+ DCA .+2
+ JMS STCHEK /MAKE SURE
+ 0 /WE GOT ENOUGH
+ TAD NEWN3 /HOOK IN NEW ENTRY
+FREFLD, CDF 10 /CHANGE TO FREE FIELD
+ DCA I NEXT
+PATCH2, TAD NEWFLD /HOOK IN FIELD
+ DCA I NEXT
+ JMS SETFLD /BACK TO FIELD OF OLD
+ TAD FREFLD /PUT FIELD OF NEW
+ DCA I OLDN3
+ CLA CMA /BACK UP OLDN3
+ TAD OLDN3 /SO THAT IT POINTS TO POINTER
+ DCA OLDN3
+ CLA CMA
+ TAD NEXT /PUT POINTER TO NEW ENTRY
+ DCA I OLDN3 /INTO OLD
+ TAD FREFLD /SAVE ENTRY FIELD
+ DCA LUFLD /FOR POSSIBLE POST PROCESSING
+ TAD (WORD1-1/PREPARE TO STICK IN THE VALUE
+ DCA X11
+ENTERV, CDF
+ TAD I X11 /MOVE IN THE VALUE
+FFLD2, CDF 10
+ DCA I NEXT
+ ISZ N3SIZE /INCR SIZE COUNT
+ JMP ENTERV
+ CDF
+ JMP I LUKUP2
+STCHEK, 0 /CHECK FOR ENOUGH ROOM
+ TAD NEXT /CHECK FOR OVERFLOW
+ CIA CLL
+ CDF
+ TAD I STCHEK /THIS IS LIMIT
+ ISZ STCHEK
+ SZL CLA
+ JMP I STCHEK
+ TAD FREFLD /BUMP FREE FIELD
+ TAD (10
+ DCA FREFLD
+ TAD FREFLD /PUT IN TWO PLACES
+ DCA FFLD2
+ DCA NEXT /START POINTER AT 0
+ ISZ NFLDS /GONE TOO FAR ?
+ JMP I STCHEK /NO
+STOVER, JMS I QERMSG /S.T. FULL
+ 2324
+ JMP I XABORT /ABORT COMPILATION
+OLDN3, 0 /ADDR OF PREVIOUS ENTRY
+NEWN3, 0 /ADDR OF NEW ENTRY
+LTEMP, 0
+NFLDS, 0 /- COUNT OF AVAILABLE FIELDS
+N3SIZE, /SIZE OF ENTRY
+KBDCHK, 0 /CHECK FOR ^C OR ^O
+ KSF
+ JMP I KBDCHK /NO CHAR
+ KRB
+ AND (177 /REMOVE PARITY BIT
+ TAD (-3 /^C ??
+ SNA
+ JMP I XABORT /YES, EXIT TO OS8
+ TAD (3-17 /^O ??
+ SZA CLA
+ JMP I KBDCHK /NO, RETURN
+ DCA TTX+1 /NOP TTY OUTPUT ROUTINE
+ JMP I KBDCHK
+/
+WSTEP, -123;-124;-105;-120;0
+\f/ SYMBOL TABLE LOOKUP
+ PAGE
+LOOKUP, 0 /LOOK UP SYMBOL
+ TAD NAME1 /GET NAME1*11+NAME2
+ CLL RTL
+ TAD NAME1
+ CLL RAL
+ TAD NAME1
+ TAD NAME2
+ DCA NAME1 /THIS IS IT
+ TAD TYPE /WHAT KIND SYMBOL ?
+ CLL RTL /MOVE TYPE BITS
+ RTL /INTO AC 9,10,11
+ TAD JTABLE
+ DCA .+1
+VCPTR, 0 /GO THERE
+JTABLE, JMP I .+1
+ LUVAR
+ LURETN
+ LUARAY
+ LURETN
+ LUSTRG
+ LURETN
+ LUSARY
+ LURETN
+LUVAR, TAD (VARCNT /POINTER TO VAR COUNT
+ DCA VCPTR
+ TAD (VARST-13
+DOLU, TAD NAME1
+ DCA STPTR /ST POINTER
+ CDF 10 /THATS WHERE ST IS
+ TAD I STPTR /IS THIS VAR DEFINED YET ?
+ SMA
+ JMP GOTSYM /YES
+ TAD (4401 /GET 401 INTO AC
+CHEKST, CDF
+ TAD I VCPTR /PLUS VAR COUNT
+ CDF 10
+ DCA SYMBOL /THATS THE NEW SYMBOL NUMBER
+ TAD SYMBOL /PUT SYMBOL NUMBER
+ DCA I STPTR /INTO S.T. ENTRY
+ CDF
+ ISZ I VCPTR /BUMP SYMBOL NUMBER
+LURETN, JMP I LOOKUP
+ JMP STOVER /S.T. OVERFLOW
+GOTSYM, DCA SYMBOL /PUT NUMBER INTO SYMBOL
+ CDF
+ JMP I LOOKUP
+LUSTRG, TAD (SVCNT /POINTER TO STRING VAR COUNT
+ DCA VCPTR
+ TAD (SVARST-26
+ TAD NAME1 /TWO WORDS PER ENTRY
+ JMP DOLU
+LUARAY, TAD (ACNT /ARRAY VAR COUNT
+ DCA VCPTR
+ TAD (ARAYST /ARRAY SYMBOL TABLE
+ DCA STPTR
+ CDF 10
+FINDA, TAD I STPTR /SEARCH TABLE
+ SNA
+ JMP NEWARY /NEW ENTRY
+ CIA
+ TAD NAME1 /IS THIS IT ?
+ ISZ STPTR
+ SNA CLA
+ JMP GOTARY /YES
+ ISZ STPTR
+ ISZ STPTR
+ ISZ STPTR /GO TO NEXT ENTRY
+ JMP FINDA
+GOTARY, TAD (37 /GET NUMBER
+ AND I STPTR
+ DCA SYMBOL /INTO SYMBOL
+ CDF
+ JMP I LOOKUP
+NEWARY, TAD NAME1 /PUT IN NEW ENTRY
+ DCA I STPTR
+ ISZ STPTR
+ TAD (41 /PUT IN NUMBER
+ JMP CHEKST /GO DO THE REST
+LUSARY, TAD (SACNT /STRING ARRAY COUNT
+ DCA VCPTR
+ TAD (SARYST /USE STRING ARRAY TABLE
+ JMP FINDA-2 /GO DO SEARCH
+\f/ FILE AND CLOSE PROCESSORS
+FILE, JMS I QLODSN /OUTPUT STMT NUMBER
+ TAD (FOPENS /POINTER TO FILE OPENS
+ DCA FILESW
+ JMS I QCHECKC /LOOK FOR "V"
+ -126
+ SKP /NOT V
+ ISZ FILESW /YUP, INCR FILESW
+ JMS I QCHECKC /LOOK FOR "N"
+ -116
+ JMP .+3
+ ISZ FILESW /INCR FILESW BY TWO IF "N"
+ ISZ FILESW
+ JMS GETFN /GET FILE NUMBER
+ JMS I QEXPR /GET DEVICE/FILE DESCRIPTOR
+ JMP I QREMARK
+ JMS I QLOAD /LOAD INTO SAC
+ TAD TYPE1 /TYPE MUST BE STRING
+ SPA CLA
+ JMP .+3 /IT WERE
+ JMS I QERMSG /IT WEREN'T
+ 0616
+ TAD I FILESW /GET CORRECT OPEN
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+FOPENS, OPENAF;OPENAV;OPENNF;OPENNV
+FILESW, 0
+PLUS, 40;0;XADD;XADD
+\f/ EXPRESSION ANALYZER
+ PAGE
+EXPR, 0 /POLISHIZE EXPRESSION
+ DCA TEMP /SAVE LEFT
+ TAD LEFT /SO WE CAN PUSH OLD VALUE
+ JMS I QPUSH /OF IT
+ TAD TEMP /NOW SET NEW VALUE
+ DCA LEFT /OF THAT SWITCH
+ TAD EXPR
+ JMS I QPUSH /SAVE RETURN ADDR
+ JMS I QPUSH /MARK STACK
+ TAD LEFT /IS THIS LEFT SIDE ?
+ SPA CLA
+ JMP OPRAND+1/YES, NO UNARY MINUS
+UNOPR, JMS I QGETC /LOOK FOR UNARY OPERATOR
+ JMP MISARG /THERE HAS TO BE AN OPERAND
+ TAD (-53 /UNARY+(NOP)
+ SNA
+ JMP UNOPR
+ TAD (53-55 /UNARY -
+ SZA
+ JMP NOTMIN /NOT UNARY MINUS
+ TAD (UMOPR /PUSH UNARY MINUS
+ JMS I QPUSH
+ JMP UNOPR
+NOTMIN, TAD (55-50 /LOOK FOR (
+ SZA CLA
+ JMP OPRAND /NOT A SUB EXPRESSION
+ JMS I QEXPR /COMPILE SUB EXPRESSION
+ JMP BADEXP /BAD SUB EXPRESSION
+ JMS I QCHECKC /LOOK FOR )
+ -51
+ SKP /ERROR
+ JMP OPR8R /GOTIT
+ JMS I QERMSG /PARENTHESIS MIS MATCH
+ 1520
+ JMP BADEXP
+OPRAND, JMS I QBACK1 /PUT BACK NON UNARY OP
+ JMS I QGETNAM /LOOK FOR VARIABLE REF
+ JMP NOTVAR /NOPE.
+ JMS I QLOOKUP /SYMBOL TABLE SEARCH
+ TAD SYMBOL /SAVE SYMBOL NUMBER
+ DCA TEMP2 /BECAUSE SAVAC MIGHT KILL IT
+ JMS I QSAVAC /GENERATE FSTA (MAYBE)
+ -3
+ TAD TYPE /WAS THIS A FUNCTION OR ARRAY ?
+ AND (3000
+ SZA
+ JMP FUNSS /YES, GO PROCESS IT
+ TAD TYPE /MAKE OPERAND STACK ENTRY
+ JMS I QPUSHO
+ TAD TEMP2 /FIRST TYPE THEN SYMBOL #
+ JMS I QPUSHO
+OPR8R, TAD LEFT /LEFT SIDE ?
+ SMA CLA /YES, NO OPERATORS LEGAL
+ JMS I QGETC /LOOK FOR OPERATOR
+ JMP ENDEXP /END OF EXPR
+ TAD (-52 /** IS SPECIAL CASE
+ SZA
+ JMP NOSTAR /NOT *
+ JMS I QGETC /LOOK FOR SECOND *
+ JMP NOSTAR
+ TAD (-52
+ SNA CLA
+ TAD (136-52 /** -> ^
+ SNA
+ JMS I QBACK1 /PUT IT BACK
+NOSTAR, TAD (52 /RESTORE CHAR
+ DCA TEMP
+ TAD (OPR8RS-1
+ DCA X10 /PTR TO LIST
+OPRLUP, TAD I X10 /GET OPERATOR PTR
+ SNA
+ JMP ENDEXP-3/END OF LIST
+ DCA NEWOP /SAVE IT IN CASE
+ TAD I X10 /COMPARE
+ TAD TEMP
+ SZA CLA
+ JMP OPRLUP /KEEP LOOKING
+GOTOPR, JMS I QPOP /GET STACK TOP
+ SNA
+ JMP PUSH2 /EMPTY
+ DCA OLDOP
+ TAD I OLDOP /COMPARE PREC.
+ CIA
+ TAD I NEWOP /NEW-OLD
+ SPA SNA CLA
+ JMP OUTOLD /OLD>NEW
+ TAD OLDOP
+PUSH2, JMS I QPUSH /OLD < NEW
+ TAD NEWOP /GO PUSH BOTH
+ JMS I QPUSH
+ JMP UNOPR /GO LOOK FOR NEXT OPERAND
+OUTOLD, TAD OLDOP /OUTPUT CODE FOR OLD OPR8R
+ JMS I QOUTOPR
+ JMP GOTOPR /LOOK AT NEXT TOP OF STACK
+ JMS I QBACK1 /PUT BACK NON OPERATOR
+ SKP
+ JMS I QOUTOPR /OUTPUT OPERATOR
+ENDEXP, JMS I QPOP /LOOK FOR STACK MARK
+ SZA
+ JMP ENDEXP-1/NOT THIS
+ JMS I QPOP /GET RETURN ADDR
+ IAC
+ DCA TEMP
+ JMS I QPOP /GET LEFT SIDE SWITCH
+ DCA LEFT
+ JMP I TEMP /RETURN
+MISARG, JMS I QERMSG /MISSING OPERAND
+ 1517
+ JMP BADEXP
+MINUS, 40;0;XISUB;XSUB
+SLASH, 50;0;XIDIV;XDIV
+\f/ EXPRESSION ANALYZER (HANDLE SUBSCRIPTS)
+ PAGE
+FUNSS, AND (1000 /IS IT FUN CALL ?
+ SNA CLA
+ JMP .+3 /NO
+ JMS I QSAVAC /YES, SAVE AC
+ -1
+ TAD TYPE /SAVE TYPE
+ JMS I QPUSH
+ TAD TEMP2 /AND SYMBOL NUMBER
+ JMS I QPUSH
+ TAD STPTR /AND SYMBOL TABLE PTR
+ JMS I QPUSH
+ SKP
+SSLOOP, JMS I QPOP /GET ARG/SS COUNT
+ IAC
+ JMS I QPUSH /INCREMENT IT
+ JMS I QEXPR /GET NEXT ARG/SS
+ JMP BADFSS
+ JMS I QGETA1 /IS THIS ARG(SS) AN ARRAY REF ?
+ CLL CML RTR
+ AND TYPE1 /CHECK THE TYPE
+ SNA CLA
+ JMP NOTSSD /NOT AN ARRAY REFERENCE
+ JMS I QLOADSS /LOAD THE SS REGS
+ JMS I QSAVAC /SAVE AC IF NEEDED
+ -1
+ TAD TYPE1 /SET THE MODE
+ JMS I QMODSET
+ TAD (AFLDA /LOAD THIS ARG/SS
+ TAD SYMBL1
+ JMS I QOUTWRD
+ TAD Q400 /SET THE IN-AC BIT
+ TAD MODE /WE JUST CALLED MODSET
+ DCA I OSTACK /CHANGE THIS STACK ENTRY
+ SKP
+NOTSSD, ISZ OSTACK /FIX UP OSTACK
+ ISZ OSTACK
+ JMS I QCOMARP /LOOK FOR , OR )
+ JMP BADFSS /NEITHER IS BAD
+ JMP SSLOOP /, MEANS MORE ARGS/SS
+ JMS I QPOP /GET # OF ARG/SS
+ DCA TEMP /GET ARG/SS COUNT
+ JMS I QPOP /RESTORE S.T. ADDR
+ DCA STPTR
+ JMS I QPOP
+ DCA SYMBOL /GET BACK THE SYMBOL #
+ JMS I QPOP
+ DCA TYPE /GET BACK THE TYPE
+ TAD TYPE /IS IT AN ARRAY OR FUN REF ?
+ AND (1000
+ SZA CLA
+ JMP DOCALL /FUNCTION REFERENCE
+ TAD TEMP /MOVE SS COUNT
+ CLL RTR /INTO THE CORRECT
+ RTR /FIELD
+ DCA TEMP2 /AND SAVE IT
+ CDF 10
+ TAD I STPTR /ANY PREV REFERENCE ?
+ AND (3000
+ SZA
+ JMP NOTNEW /YES, GO CHECK NUMBERS
+ TAD TEMP2 /IF NONE, PUT IN NUMBER
+ TAD I STPTR
+ DCA I STPTR
+ JMP NDOK /THATS ALL
+NOTNEW, CIA /COMPARE NUMBER OF SS
+ TAD TEMP2 /WITH ANY PREVIOUS
+ SZA CLA
+ JMP BADFSS+3/THEY DON'T MATCH
+NDOK, CDF
+ TAD TYPE /PUT TYPE
+ TAD TEMP /AND DIM COUNT
+ONSTAK, JMS I QPUSHO /ONTO ARGUMENT STACK
+ TAD SYMBOL
+ JMS I QPUSHO /AND SYMBOL NUMBER
+ JMS I QSAVAC /SAVE FIRST SS IF LEFT IN AC
+ -5
+ JMP OPR8R /GO GET AN OPERATOR
+BADFSS, TAD (-4 /PURGE STACK JUNK
+ TAD STACK
+ DCA STACK
+ JMS I QERMSG /PUT ERROR MESSAGE
+ 2323
+BADEXP, JMS I QPOP /LOOK FOR STACK MARK
+ SZA CLA
+ JMP BADEXP /NOT YET
+ JMS I QPOP /RETURN ADDR
+ DCA TEMP
+ JMS I QPOP /SS LOAD SWITCH
+ DCA LEFT
+ JMP I TEMP /TAKE ERROR EXIT
+WTAB, -124;-101;-102;-50
+NOTVAR, TAD LEFT /LEFT SIDE ?
+ SPA CLA
+ JMP MISARG /YES, NO LITERALS LEGAL
+ JMS I QNUMBER /LOOK FOR LITERAL
+ JMP NOTNUM /NOT A NUMBER
+ JMS I QLUKUP2 /SEARCH LITERAL TABLE
+ LITRL
+ -3
+ JMS NEWVAR /IF NEW, GIVE IT NUMBER
+ JMP ONSTAK /GO PUT IT ONTO THE STACK
+NOTNUM, JMS I QSTRING /LOOK FOR STRING LITERAL
+ JMP MISARG /NO, MISSING ARG
+ TAD WORD1 /GET -NUMBER WORDS - 1
+ IAC
+ CLL CML CMA RAR
+ DCA .+3 /FOR LOOKUP
+ JMS I QLUKUP2 /LOOK UP LITERAL
+ SLITRL
+ 0
+ JMS NWSVAR /IF NEW, GIVE IT NUMBER
+ CLL CML RAR /SET TYPE BIT FOR STRING
+ JMP ONSTAK /PUT INFO ONTO STACK
+
+UPAROW, 60;1;EXPRTN-1
+\f/ EXPRESSION ANALYZER (HANDLE FUNCTION CALLS)
+ PAGE
+DOCALL, TAD LEFT /IS THIS LEFT SIDE ?
+ SMA CLA /IF YES, FUN ILLEGAL
+ JMS OUTCAL /GENERATE CALL
+ SKP /SKIP IF ERROR
+ JMP OPR8R /GO LOOK FOR OPERATOR
+ JMS I QERMSG /BAD FUNCTION REFERENCE
+ 0622
+ JMP BADEXP
+OUTCAL, 0 /GENERATE FUN CALL; TYPE,
+ /SYMBOL AND TEMP ARE INPUTS
+ TAD SYMBOL /SAVE FUNCTION NUMBER AROUND SAVAC
+ DCA FUNNUM
+ JMS I QSAVAC /SAVE SECOND FROM TOP
+ -3
+ TAD FUNNUM /SETUP FOR FINDING FUNCTION
+ DCA WORD1 /INFO BLOCK
+ JMS I QLUKUP2 /ON THE FUNCTION LIST
+ FUNCTN
+ -1
+ JMP I OUTCAL /UNDEFINED FUNCTION
+ TAD SYMBOL /CHECK NUMBER OF ARGS
+ TAD TEMP
+ SZA CLA
+ JMP I OUTCAL
+MOVARG, JMS I QLOAD /GET TOP OF STACK INTO AC
+ JMS SETFLD /GET FIELD OF FORMAL-PARAMS
+ TAD I X10 /GET FIRST ONE
+ CDF
+ DCA TEMP
+ CLL CML RAR /COMPARE TYPE OF ARG
+ AND TYPE1 /WITH THAT OF FORMAL PARAMETER
+ TAD TEMP
+ SPA CLA /THEY MUST MATCH
+ JMP I OUTCAL /(THEY DON'T)
+ CLL CML RTR /SHOULD WE LEAVE IT IN THE AC ?
+ AND TEMP
+ SZA CLA
+ JMP OKINAC /YES, SAVES AN INSTRUCTION
+ TAD TYPE1 /SET MODE
+ JMS I QMODSET /APPROPRIATELY
+ CLL CMA RAR /3777
+ AND TEMP /GET SYM NUMBER
+ TAD (FSTA /STORE VALUE IN FORM PARAM
+ JMS I QOUTWRD
+OKINAC, ISZ SYMBOL /MORE ARGS ?
+ JMP MOVARG
+ JMS SETFLD
+ TAD I X10 /GET TYPE OF FUNCTION
+ DCA TYPE1 /(ITS RESULT THAT IS)
+ CDF
+ TAD TYPE /IS TYPE OF FUNCTION
+ TAD TYPE1 /SAME AS TYPE OF CALL
+ SPA CLA
+ JMP I OUTCAL /NO, ERROR
+ JMS I QMODSET /ALL CALLS IN N MODE
+ TAD WORD1 /CHECK FOR USER FUNCTION
+ SMA
+ JMP CALLUF /YES, DO SPECIAL CALL
+FINCAL, ISZ OUTCAL /FIX RETURN
+ JMS I QOUTWRD /OUTPUT CODE
+ TAD Q400 /SET TOP OF STACK
+ TAD TYPE1
+ DCA I OSTACK /TO AC
+ DCA I OSTACK /SYMBOL NUMBER IS MEANINGLESS
+ CLL CML RAR
+ AND TYPE1 /INTERPRETER MODE SAME
+ DCA MODE /AS FUNCTION TYPE
+ JMP I OUTCAL /ON RETURN
+CALLUF, JMS I QNOREGS /FORGET REGS ON USER FUNC
+ TAD LUFLD /OUTPUT JSUB
+ AND (70 /WITH POINTER TO
+ CLL RTL /DOUBLE WORD
+ TAD (JSUB /VALUE OF LOCATION
+ JMS I QOUTWRD /COUNTER FOR THE
+ TAD X10 /START OF THE
+ IAC /USER "DEF"INED FUNC
+ JMP FINCAL
+FSUB1, 0 /FOR SUBROUTINE #1
+ JMS I QEXPR /GET AN EXPRESSION
+ JMP BADFOR
+ JMS I QLOAD /LOAD VALUE
+ TAD TYPE1 /MUST BE NUMERIC
+ SMA CLA
+ JMP I FSUB1 /OK
+BADFOR, JMS I QERMSG /BAD FOR LOOP PARAMETERS
+ 0620
+ JMP I QREMARK
+FSUB2, 0 /FOR SUBROUTINE #2
+ JMS FSUB1 /GET EXPR AND LOAD IT
+ JMS GENTMP /MAKE A TEMP FOR IT
+ TAD SYMBOL /STORE EXPR IN TEMP
+ TAD (FSTA
+ JMS I QOUTWRD
+ TAD SYMBOL /RETURN SLOT #
+ JMP I FSUB2
+FUNNUM,
+NOREGS, 0 /FORGET REGISTORS
+ CLA IAC /FILE NUMBER REG
+ DCA IFNREG
+/ CMA /SUBSCRIPT REG #1
+/ DCA SSREG1
+/ CMA /SUBSCRIPT REG #2
+/ DCA SSREG2
+ JMP I NOREGS
+CLOSE, JMS I QLODSN /OUTPUT STMT NUMBER
+ CLA IAC /NO COLON NEEDED AFTER FILE NUM
+ JMS GETFN /GET FILE NUM
+ TAD (CLOSEF /OUTPUT CLOSE
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+PSETJF, 0
+ TAD (SETJF
+ JMS I QOUTWRD
+ JMS I QPOP /GET INDEX VAR
+ DCA FINDEX
+ JMP I PSETJF
+DIMREAD,JMS I QLOADSS /PATCH TO INPUT PROC. SET UP SS REG
+ TAD (READ /OUTPUT INSTR
+ JMS I QOUTWRD
+ TAD (AFSTA
+ JMP I (FININP /RESUME IN LINE
+\f/ CODE GENERATOR
+ PAGE
+OUTOPR, 0 /OUTPUT CODE FOR OPERATOR
+ DCA X10 /SAVE POINTER TO SKELETON
+ TAD I X10 /GET CONTROL WORD
+ SMA SZA
+ JMP SPCIAL /TREAT AS SPECIAL CASE
+ DCA TYPE /ITS THE TYPE ALLOWANCE
+ TAD (XLOAD /GET SKEL ADDRS
+ DCA CASEMM /FOR THE THREE CASES
+ TAD I X10
+ DCA CASEMA
+ TAD I X10
+ DCA CASEAM
+ TAD TYPE /ENTER CORRECT MODE
+ JMS I QMODSET
+ CLL CMA RAL /GET THE SECOND OPERAND
+ TAD OSTACK
+ DCA OSTACK
+ TAD OSTACK
+ DCA X10 /BY BACKING UP THE STACK
+ TAD I X10 /TYPE
+ DCA TYPE2
+ TAD I X10
+ DCA SYMBL2 /SYMBOL NUMBER
+ TAD TYPE2
+ AND (3
+ DCA TEMP /SS COUNT
+ TAD TYPE2 /LOOK AT OPERAND 2
+ AND Q400
+ SZA CLA
+ JMP MAC /MUST BE CASE M,AC
+ CLL CML RTR /ITS IN MEMORY, IS IT SS'D
+ AND TYPE2
+ SNA CLA
+ JMP A2OK /NO, ITS SCALAR
+ JMS I QLOADSS /LOAD NECESSARY SS REGS
+ ISZ CASEMM /FIXUP THE SKELETON POINTERS
+ ISZ CASEAM
+A2OK, JMS GETA1 /GET STUF FOR ARG1
+ TAD TYPE1 /LOOK AT IT
+ AND Q400
+ SZA CLA
+ JMP ACM /ITS CASE AC,M
+MM, TAD I CASEMM /ITS CASE M,M LOAD OPERAND 2
+ TAD SYMBL2
+ JMS I QOUTWRD
+ SKP
+MAC, JMS GETA1 /GET STUF FRO ARG1
+ CLL CML RTR /IS IT SS'D ?
+ AND TYPE1
+ SNA CLA
+ JMP A1OK /NO, ITS SCALAR
+ JMS I QLOADSS /LOAD THE SS REGS
+ ISZ CASEMA /BUMP SKELETON ADDR
+A1OK, TAD I CASEMA /GET CORRECT INSTRUCTION
+ TAD SYMBL1 /PLUS SYMBOL NUMBER
+TYPCHK, JMS I QOUTWRD /OUTPUT IT
+ CLL CML RAR /TYPES OF OPERANDS MUST MATCH
+ AND TYPE1
+ TAD TYPE2
+ SPA CLA
+ JMP MIXED /THEY DON'T
+ TAD TYPE /TYPE OF OPERATOR
+ TAD TYPE1 /MUST MATCH
+ SPA CLA /THAT OF OPERANDS
+ JMP MIXED /THEY DON'T
+ TAD Q400 /GENERATE STACK ENTRY
+ TAD TYPE
+ DCA I OSTACK
+ DCA I OSTACK /THIS IS SAFE
+ JMP I OUTOPR
+ACM, TAD I CASEAM /ITS CASE AC,M
+ TAD SYMBL2 /GEN OPERATION FOR OPERAND 2
+ JMP TYPCHK /GO FINISH IT UP
+MIXED, JMS I QERMSG /MIXED TYPES
+ 1524
+ JMP I OUTOPR
+SPCIAL, TAD I X10 /GET ADDR OF SPECIAL RTNE
+ DCA TEMP /(PLUS 1 FROM THE TYPE WORD)
+ JMP I TEMP /HANDLE SPECIAL CASE
+GETA1, 0 /GET STUFF FOR ARG 1
+ CLL CMA RAL /BACK UP STACK
+ TAD OSTACK
+ DCA OSTACK
+ TAD OSTACK
+ DCA X11
+ TAD I X11 /GET TYPE1
+ DCA TYPE1
+ TAD I X11 /GET SYMBL1
+ DCA SYMBL1
+ TAD TYPE1 /GET SS COUNT
+ AND (3
+ DCA TEMP
+ JMP I GETA1
+UMRTNE, JMS I QSAVAC /SAVE CURRENT AC IF NEEDED
+ -3
+ JMS I QLOAD /GET ARG IN AC
+ DCA TYPE /TYPE MUST BE NUMERIC
+ DCA TYPE2
+ TAD (FNEG /DO NEGATE
+ JMP TYPCHK
+EXPRTN, DCA TYPE /SET FUNC TYPE
+ CLL CML RTL /SET NUMBER OF ARGS
+ DCA TEMP
+ TAD (FUNC1+60
+ DCA SYMBOL /EXP2
+ JMS OUTCAL /OUTPUT FUNCTION CALL
+ JMP MIXED /ERROR
+ JMP I OUTOPR /DONE
+CASEMA, 0
+CASEMM, 0
+CASEAM, 0
+TYPE2, 0
+SYMBL2, 0
+RETURN, JMS I QLODSN /OUTPUT STMT NUM LOAD
+ JMS I QMODSET /ALWAYS RETURN IN N MODE
+ TAD (RET-RNDO
+RANDOM, TAD (RNDO-STOP
+STOPX, TAD (STOP /RETURN, RANDOMIZE, OR STOP
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+\f/ LETTER AND DIGIT SCANNERS
+ PAGE
+LETTER, 0 /SKIP ON LETTER
+ JMS I QGETC
+ JMP I LETTER /NO LETTER
+ TAD (-133 /MUST BE .LT. 133
+ SMA
+ JMP NOLETR
+ TAD (133-100/MUST BE .GT. 100
+ SPA
+ JMP NOLETR
+ AND (77 /RESTORE 6 BITS
+ ISZ LETTER /BUMP RETURN ADDR
+ JMP I LETTER
+NOLETR, JMS I QBACK1 /PUT CHAR BACK
+ JMP I LETTER
+DIGIT, 0 /SKIP ON DIGIT
+ JMS I QGETC
+ JMP I DIGIT /NO DIGIT
+ TAD (-72 /MUST BE .LT. 72
+O7100, CLL /(USED AS LITERAL BY "TTY")
+ TAD (72-60 /MUST BE .GE. 60
+ SNL
+ JMP NODIGT /NOPE
+ ISZ DIGIT /RETURN DIGIT MINUS 60
+ JMP I DIGIT
+NODIGT, JMS I QBACK1 /PUT IT BACK
+ JMP I DIGIT
+\f/ STATEMENT NUMBER GETTER
+SNUM, 0 /GET A STATEMENT NUMBER
+ DCA TEMP /SAVE DEFINED SWITCH
+ JMS I QDIGIT /GET FIRST DIGIT
+ JMP I SNUM /NO STATEMENT NUMBER
+ DCA WORD2 /THIS WILL BE THE BUCKET
+ TAD WORD2
+ CLL RAL /TWO WORDS PER BUCKET
+ TAD (SNUMS
+ DCA BUCKET
+ ISZ SNUM /OK, ITS A STMT NUMBER
+ TAD (-4 /FIVE DIGITS MAX
+ DCA TEMP2
+ DCA WORD1 /CLEAR TOP WORD
+SNLOOP, JMS I QDIGIT /GET NEXT DIGIT
+ JMP GOTSN /END OF NUMBER
+ DCA WORD3 /SAVE IT
+ TAD (-4 /SET SHIFT COUNT
+ DCA ACO
+SHIFT, TAD WORD2 /SHIFT LEFT ONE BIT
+ CLL RAL
+ DCA WORD2
+ TAD WORD1
+ RAL
+ DCA WORD1
+ ISZ ACO /BUMP SHIFT COUNTER
+ JMP SHIFT
+ TAD WORD2 /PUT IN NEW DIGIT
+ TAD WORD3
+ DCA WORD2
+ ISZ TEMP2 /BUMP DIGIT COUNT
+ JMP SNLOOP
+GOTSN, JMS I QLUKUP2 /FIND STMT NUMBER
+BUCKET, 0
+ -2
+ JMP NEWSN /ITS A NEW STMT NUM
+ CLL CML RAR /CHECK FOR MULTIPLY DEFINED
+ AND SYMBOL
+ AND TEMP
+ SZA CLA
+ JMP MDLABL /YES, IT IS
+ TAD X10 /GET ADDR OF LABEL VALUE
+ DCA TEMP2
+ JMS SETFLD /GET TO FIELD OF ENTRY
+ TAD TEMP /OR IN THESE BITS
+ TAD SYMBOL
+ DCA I TEMP2
+FINSN, CDF
+ TAD LUFLD /GET FIELD BITS
+ AND (70
+ CLL RTL
+ DCA TEMP /INTO A CONVIENIENT
+ JMP I SNUM /PLACE
+NEWSN, JMS SETFLD /GET FIELD
+ TAD TEMP /PUT IN BITS
+ DCA I NEXT
+ TAD NEXT /SAVE N3 ADDR
+ DCA TEMP2
+ DCA I NEXT /1 EXTRA WORD
+ JMP FINSN
+MDLABL, JMS I QERMSG /MULTIPLY DEFINED
+ 1504 /LABEL
+ JMP I SNUM
+TTY, 0 /CONVERT TO ASCII AND PRINT
+ AND (77 /SIX BITS ONLY
+ TAD (-40 /WHAT SIDE OF FORTY ?
+ SPA
+ TAD O7100 /LOW SIDE
+ TAD (240 /HIGH SIDE
+ JMS TTX /PRINT CHAR
+ JMP I TTY /RETURN
+TTX, 0 /PRINT CHAR ON TTY
+ SKP /(CONTROL O ZEROES THIS WORD)
+ JMP .+4 /(THUS KILLING ERROR REPORTING)
+ TSF
+ JMP .-1
+ TLS
+ CLA
+ JMP I TTX
+\f/ CHAIN PROCESSOR
+CHAIN, JMS I QLODSN /OUTPUT STMT NUMBER
+ JMS I QEXPR /GET CHAIN STRING
+ JMP I QREMARK
+ JMS I QLOAD /INTO SAC
+ TAD TYPE1 /TYPE MUST BE STRING
+ SMA CLA
+ JMS I QERMSG /IT WASN'T
+ 0616 /(OK IF ERROR CODE IS NOP)
+ TAD (CHN /OUTPUT CHAIN OPCODE
+ JMS I QOUTWRD
+ JMP I QNEWLIN
+XISUB, FISUB;AISUB
+\f/ SEVERAL SHORT UTILITY ROUTINES
+ PAGE
+BACK1, 0 /BACK UP ONE CHAR
+ CLA CMA
+ TAD NCHARS
+ DCA NCHARS
+ CLA CMA
+ TAD CHRPTR
+ DCA CHRPTR
+ JMP I BACK1
+GETCWB, 0 /GET A CHARACTER (PRESERVE BLANKS)
+ ISZ NCHARS
+ JMP .+4
+ CLA CMA
+ DCA NCHARS /RESET NCHARS
+ JMP I GETCWB
+ ISZ GETCWB
+ TAD I CHRPTR /GET THE CHAR
+ JMP I GETCWB
+SAVECP, 0 /SAVE CHAR POSITION
+ TAD NCHARS
+ DCA NCSAVE
+ TAD CHRPTR
+ DCA CPSAVE
+ JMP I SAVECP
+RESTCP, 0 /RESTORE CHAR POS
+ TAD CPSAVE
+ DCA CHRPTR
+ TAD NCSAVE
+ DCA NCHARS
+ JMP I RESTCP
+GETC, 0 /GET A CHARACTER (IGNORING BLANKS)
+ ISZ NCHARS
+ JMP .+4
+ CLA CMA
+ DCA NCHARS
+ JMP I GETC
+ TAD I CHRPTR
+ TAD (-40 /IS IT A BLANK
+ SNA
+ JMP GETC+1 /YES IGNORE IT
+ TAD (40 /FIX CHAR
+ ISZ GETC
+ JMP I GETC
+POP, 0 /GET TOP OF STACK
+ TAD STACK
+ DCA PUSH
+ CLA CMA
+ TAD STACK
+ DCA STACK /DECREMENT STACK POINTER
+ TAD I PUSH
+ JMP I POP
+PUSH, 0 /PUT AC ONTO STACK
+ DCA I STACK /STORE
+ TAD (-STACKA-STAKSZ+1
+ TAD STACK /CHECK FOR OVERFLOW
+ SPA CLA
+ JMP I PUSH /OK, RETURN
+STKOVR, JMS I QERMSG
+ 2004
+ JMP I XABORT /ABORT COMPILATION
+PUSHO, 0 /PUSH OPERAND STACK
+ DCA I OSTACK /PUSHIT
+ TAD (-STACKO-STOKSZ+1
+ TAD OSTACK /CHECK FOR STACK OVERFLOW
+ SPA CLA
+ JMP I PUSHO
+ JMP STKOVR /TOO FULL
+COMARP, 0 /SKIP ON COMA OR RITE PAREN
+ JMS I QGETC /GET CHAR
+ JMP I COMARP
+ TAD (-51
+ SNA
+ ISZ COMARP /RITE PAREN, SKIP 2
+ SZA
+ TAD (51-54 /CHECK FOR ,
+ SNA
+ ISZ COMARP /, SKIP 1
+ SZA CLA
+ JMS I QBACK1 /NEITHER PUT BACK
+ JMP I COMARP
+LOAD, 0 /LOAD SAC OR FAC
+ JMS I QGETA1 /GET TOP OF STACK
+ TAD TYPE1 /SET MODE
+ JMS I QMODSET
+ TAD TYPE1 /IS IT IN THE AC?
+ AND Q400
+ SZA CLA
+ JMP I LOAD /YUP
+ CLL CML RTR /SUBSCRIPTED ?
+ AND TYPE1
+ SNA CLA
+ JMP .+3 /NO
+ JMS I QLOADSS /FILL SS REGS
+ TAD (AFLDA-FLDA
+ TAD (FLDA /ARRAY OR SCALAR LOAD
+ TAD SYMBL1 /PLUS SYMBOL NUMBER
+ JMS I QOUTWRD
+ JMP I LOAD
+IFOPS, JNE;-7476 /<>
+ JNE;-7674 /><
+ JGE;-7576 /=>
+ JGE;-7675 />=
+ JLE;-7574 /=<
+ JLE;-7475 /<=
+ 0
+ JEQ;-7500 /=
+ JGT;-7600 />
+ JLT;-7400 /<
+ 0
+NCSAVE, 0
+CPSAVE, 0
+\f/ TEMP GENERATORS AND AC SAVING ROUTINES
+ PAGE
+GENTMP, 0 /GENERATE A TEMP
+ SZA CLA
+ JMP STRTMP /ITS A STRING TEMP
+ TAD TMPCNT
+ ISZ TMPCNT /BUMP COUNT
+ DCA NAME1
+ JMS I QLUKUP2 /LOOK UP THIS TEMP
+ TEMPS
+ -1
+ JMS NEWVAR /NEW ONE ON ME
+ JMP I GENTMP
+STRTMP, TAD STMPCT
+ ISZ STMPCT /BUMP COUNT
+ DCA NAME1
+ JMS I QLUKUP2 /LOOK UP THIS TEMP
+ STEMPS
+ -1
+ JMS NWSVAR /NEW STRING TEMP
+ JMP I GENTMP
+NEWVAR, 0 /MAKE SYM NUM FOR VAR
+ TAD VARCNT /PUT SYM NUM
+ TAD (401
+ DCA SYMBOL /INTO SYMBOL
+ TAD SYMBOL /AND INTO ST ENTRY
+ JMS SETFLD
+ DCA I NEXT
+ CDF
+ ISZ VARCNT /BUMP COUNT
+ JMP I NEWVAR /RETURN WITH SYM NUM
+ JMP STOVER /S.T. OVERFLOW
+NWSVAR, 0 /MAKE SYM NUM FOR VAR$
+ TAD SVCNT /PUT SYM NUM
+ TAD (401
+ DCA SYMBOL
+ TAD SYMBOL /INTO SYMBOL AND
+ JMS SETFLD
+ DCA I NEXT /S.T. ENTRY
+ CDF
+ ISZ SVCNT /OVERFLOW ?
+ JMP I NWSVAR /NO, WE'RE OK
+ JMP STOVER
+SAVAC, 0 /SAVE FAC (OR SAC) IF NECESSARY
+ TAD I SAVAC /GET ENTRY POINTER
+ TAD OSTACK
+ ISZ SAVAC
+ DCA SVTEMP /ADDR OF TYPE WORD
+ TAD I SVTEMP /LOOK AT IT
+ AND Q400
+ SNA CLA
+ JMP I SAVAC /NOT IN AC
+ CLL CML RAR /SAVE STRING BIT ONLY
+ AND I SVTEMP /OF TYPE WORD
+ DCA I SVTEMP
+ TAD I SVTEMP
+ JMS GENTMP /GENERATE TEMP
+ TAD I SVTEMP
+ JMS I QMODSET /SET MODE
+ TAD XSTOR
+ TAD SYMBOL /GENERATE STORE
+ JMS I QOUTWRD
+ TAD SYMBOL /RETURN S.T. NUMBER
+ ISZ SVTEMP /MOVE TO SYMBOL NUM WORD
+ DCA I SVTEMP /SAVE THE TEMP NUM THERE
+ JMP I SAVAC /RETURN WITH SAVE MADE
+SVTEMP, 0
+XSTOR, FSTA;AFSTA
+\f/ SUBSCRIPT REGISTER LOADING ROUTINE
+LOADSS, 0 /LOAD SS REGS
+ CLL CMA RAL /LOOK AT NUMBER OF SS
+ TAD TEMP
+ SNA CLA
+ JMP LODSS2 /2 SS
+ SNL
+ JMP TOOMNY /MORE THAN 2
+ JMS SSLOAD /LOAD SS REG 1
+ JMP I LOADSS
+LODSS2, CLA IAC
+ JMS SSLOAD /LOAD SS REG 2
+ JMS SSLOAD /NOW SS REG 1
+ JMP I LOADSS
+SSTYPE,
+TOOMNY, JMS I QERMSG /SUBSCRIPTING ERROR
+ 2323
+ JMP I LOADSS
+SSLOAD, 0 /LOAD A SS REG FROM TOP OF STACK
+ DCA TEMP2 /SS REG 1 OR 2 SWITCH
+ CLL CMA RAL /BACK UP ONE ENTRY
+ TAD OSTACK /ON THE OPERAND STACK
+ DCA OSTACK
+ TAD OSTACK
+ DCA X11 /USE X11 TO GET STUFF
+ TAD I X11 /GET TYPE WORD
+ SPA
+ JMP SSTYPE /SS MUST BE A NUMBER
+ AND Q400 /GET AC BIT
+ SZA CLA
+ JMP SSINAC /ITS IN THE AC
+ TAD TEMP2
+ SZA CLA
+ TAD (LSS2-LSS1
+ TAD (LSS1 /LOAD REG 1 OR 2 ??
+ TAD I X11 /ANYHOW, THIS IS THE SOURCE
+ JMS I QOUTWRD /OUTPUT THE CODE
+ JMP I SSLOAD
+SSINAC, TAD TEMP2
+ TAD (LSS1AC /NOTE: LSS2AC=LSS1AC+1
+ JMS I QOUTWRD /SO OUTPUT ONE OF THEM
+ JMP I SSLOAD
+/
+XSCOMP, SCOMP;SACOMP
+XDIV, FDIV;AFDIV
+/
+PATCH6, 0
+ ISZ SIGDIG
+ JMP I PATCH6
+ CMA
+ DCA SIGDIG
+ JMP CONVLP
+/
+STAR, 50;0;XMUL;XMUL
+\f/ NUMERIC CONVERSION ROUTINE (PART ONE)
+ PAGE
+NUMBER, 0 /GENERAL NUMBER CONVERSION ROUTINE
+ DCA DECPT /ZERO DECIMAL POINT SWITCH
+ DCA WORD1 /ZERO FAC
+ DCA WORD2
+ DCA WORD3
+ DCA ACO
+ DCA SIGN /CLEAR SIGN SWITCH
+ TAD NUMDIG
+ DCA SIGDIG
+ JMS I QGETC /GET A CHAR
+ JMP I NUMBER /NO CHAR IS NO NUMBER
+ JMS CHKSGN /CHECK FOR SIGN
+SIGN, 0 /THIS SWITCH GETS SET
+ DCA NDIGIT /ZERO DIGIT COUNT
+CONVLP, JMS I QDIGIT /GET A DIGIT
+ JMP TRYDEC /IS THERE A DECIMAL POINT ?
+ DCA NXTDGT /SAVE THE DIGIT
+ JMS PATCH6
+ ISZ NDIGIT /INCR NUMBER OF DIGITS
+ TAD WORD2 /PREPARE TO MULT BY 10
+ DCA OP2
+ TAD WORD3
+ DCA OP3
+ TAD ACO
+ DCA OPO
+ JMS I (AL1 /DOUBLE FAC
+ JMS I (AL1 /DOUBLE AGAIN
+ JMS I (OADD /TIMES FIVE
+ JMS I (AL1 /ONE MORE DOUBLING IS TIMES 10
+ DCA OP2
+ DCA OP3 /PUT NEWEST DIGIT INTO OPERAND
+ TAD NXTDGT
+ DCA OPO
+ JMS I (OADD /ADD IN NEWEST DIGIT
+ JMP CONVLP
+TRYDEC, TAD DECPT /DECIMAL ALREADY ?
+ SZA CLA
+ JMP TRYE2 /YES, LOOK FOR EXPONENT
+ JMS I QGETC /LOOK FOR .
+ JMP DIGTST /SEE IF THERE WAS ANYTHING
+ TAD (-56
+ SZA CLA
+ JMP TRYE1 /TRY FOR E
+ ISZ DECPT /SET DECIMAL POINT SW
+ JMP CONVLP-1/LOOP FOR OTHER DIGITS
+TRYE1, JMS I QBACK1 /PUT BACK NON .
+DIGTST, TAD NDIGIT /ANY DIGITS YET ?
+ SNA CLA
+ JMP I NUMBER /NO, NO NUMBER
+TRYE2, JMS I QGETC /LOOK FOR E
+ JMP NOEXP+1 /GO HANDLE EXPONENT
+ TAD WSTEP+2 /USE PART OF "STEP" LITERAL
+ SZA CLA
+ JMP NOEXP /NO EXPONENT
+GETEXP, DCA ESIGN /ZERO EXPONENT SIGN SWITCH
+ JMS I QGETC /GET A CHAR
+ JMP NOEXP /TREAT AS NO EXPONENT
+ JMS CHKSGN /IS IT A SIGN
+FPRTNE,
+ESIGN, 0 /THIS IS THE SWITCH TO SET
+ JMS SMLNUM /GO GET THE EXPONENT
+FIXEXP, TAD ESIGN /CHECK EXPONENT SIGN
+ SNA CLA
+ JMP NOEXP+2
+ TAD EXPON /COMPLEMENT EXPONENT
+ CIA
+ SKP
+NOEXP, JMS I QBACK1 /PUT BACK NON E
+ DCA EXPON /ZERO EXPONENT
+ TAD (43 /NORMALIZE THE NUMBER
+ DCA WORD1
+ JMS I (ANORM
+ TAD DECPT /WAS THERE A DECIMAL POINT ?
+ SZA CLA
+ TAD NDIGIT /HOW MANY DIGITS TO THE RIGHT ?
+ CIA
+ TAD EXPON /SUBTRACT THAT NUMBER FROM EXP
+ SMA
+ JMP POSEXP /EXPONENT IS POSITIVE
+ CIA
+ DCA EXPON /ONLY NEED ABS VALUE
+ TAD (FPDIV /DO DIVIDES
+ JMP .+3
+POSEXP, DCA EXPON
+ TAD (FPMUL /DO MULTIPLIES
+ DCA FPRTNE /MULTIPLY/DIVIDE ROUTINE
+ TAD (PETABL-1
+ DCA X11 /POWERS OF TEN TABLE
+EXPMUL, TAD EXPON /LOOK AT THE EXPONENT
+ SNA
+ JMP DOSIGN /IF 0 ITS THRU
+ CLL RAR
+ DCA EXPON /PUT LOWEST BIT INTO LINK
+ SNL
+ JMP SKPEXP /THIS ONE DOESN'T COUNT
+ TAD I X11 /MOVE FACTOR INTO OPERAND
+ DCA OP1
+ TAD I X11
+ DCA OP2
+ TAD I X11
+ DCA OP3
+ TAD I X11
+ DCA OPO
+ JMS I FPRTNE /MULTIPLY OR DIVIDE BY THIS FACTOR
+ JMP EXPMUL /CHECK NEXT BIT
+SKPEXP, TAD X11 /SKIP OVER THIS FACTOR
+ TAD (4
+ JMP EXPMUL-1
+DOSIGN, TAD SIGN /CHECK THE SIGN
+ SZA CLA
+ JMS I (NEGFAC /NEGATE IF NEGATIVE
+ ISZ NUMBER /BUMP RETURN
+ JMP I NUMBER /RETURN
+NXTDGT, 0
+\f
+/INPUT DEVICE HANDLER
+ *INDEVH
+ 0
+\f/INITIALIZATION CODE FOR RUN CASE
+ PAGE
+RUNNED, CIF 10 /COME HERE IF .R BCOMP
+ JMS I (200 /CALL COMMAND DECODER
+ 5
+ 0201 /ASSUMED EXTENSION "BA"
+ CDF 10
+ TAD I (7644 /TEST FOR /V
+ CDF
+ AND (4
+ SZA CLA
+ JMS VERNUM
+ TAD (INFO-1
+ DCA X10
+ CDF 10
+ TAD 7617
+ CDF
+ SNA CLA /NULL INPUT?
+ JMP RUNNED /YES: NAUGHTY
+ TAD 7777
+ CLL RAL /BATCH RUNNING
+ SPA CLA
+ JMP SAVBOS /YES
+ CDF 10
+ JMP FINDSV-2
+SAVBOS, TAD (INFO-5
+ DCA X10
+ TAD 7777
+ AND (70
+ TAD CDFZRO
+ DCA .+1 /CDF TO BATCH FIELD
+ CDF 10
+ TAD I BOSCTR
+ CDF 10
+ DCA I X10 /SAVE BOS WRDS IN INFO AREA
+ ISZ BOSCTR
+ JMP .-5
+ DCA I X10 /ZERO EDITOR BLOCK NUMBER
+ CDF
+FINDSV, TAD I X11 /LOOKUP SOME SAVE FILES
+ SNA
+ JMP LUBUF /GO LOOK FOR BASIC.UF
+ DCA XXXXSV /SAVE POINTER TO NAME
+ CLA IAC /THEY'RE ON SYS
+ CIF 10
+ JMS I (200
+ 2
+XXXXSV, 0
+ 0
+ JMP NG /ERROR
+ TAD XXXXSV /GET STARTING BLOCK
+ IAC /PLUS 1
+ CDF 10
+ DCA I X10 /INTO INFO AREA
+CDFZRO, CDF
+ JMP FINDSV /LOOP
+LUBUF, CLA IAC
+ CIF 10
+ JMS I (200 /LOOKUP BASIC.UF
+ 2
+ BUFN /(USER DEFINED FUNCTIONS)
+ 0
+ JMP .+3 /OK IF NOT THERE
+ TAD .-3 /GET STARTING BLOCK +1
+ IAC
+ CDF 10
+ DCA I X10 /INTO INFO BLOCK
+STRT3, CDF
+ CLA IAC /ENTER TEMPORARY FILE
+ CIF 10
+ JMS I (200
+ 3
+TMPBLK, TMPFIL
+ 0
+ JMP NG
+ TAD TMPBLK /SAVE START OF TEMP FILE
+ DCA OUBLOK
+ TAD TMPBLK /IN A COUPLE PLACES
+ DCA BLOCK
+ TAD TMPBLK+1/ALSO THE SIZE
+ DCA OUSIZE
+ JMP GETDEV /GO FETCH DEVICE HANDLER
+BOSCTR, 7774
+VERNUM, 0
+ TAD (VTEXT
+ DCA TEMP
+ TAD (-5
+ DCA TEMP2
+ TLS
+MOREV, TAD I TEMP
+ CLL RTR
+ RTR
+ RTR
+ JMS TTY
+ TAD I TEMP
+ JMS TTY
+ ISZ TEMP
+ ISZ TEMP2
+ JMP MOREV
+ TAD (215
+ JMS TTX
+ TAD (212
+ JMS TTX
+ TSF /WAIT FOR TTY TO GET DONE
+ JMP .-1 /BEFORE RETURNING
+ JMP I VERNUM
+/
+VTEXT, TEXT /BCOMP V/
+ *.-1
+VERLOC, VERSON^100+6001
+ 0
+\f/ NUMERIC CONVERSION ROUTINE (PART TWO)
+ PAGE
+FPMUL, 0 /FLOATING MULTIPLY ROUTINE
+ TAD WORD1 /COMPUTE NEW EXPONENT
+ TAD OP1
+ DCA OP1
+ TAD WORD2 /SAVE AC MANTISSA
+ DCA TW2
+ TAD WORD3
+ DCA TW3
+ TAD (-30 /SET ITERATION COUNTER
+ DCA ITRCNT
+ DCA WORD2 /ZERO FAC MANTISSA
+ DCA WORD3
+ DCA ACO
+MULLUP, JMS I (AR1 /SHIFT FAC RIGHT ONE
+ TAD TW2 /SHIFT MULTIPLIER RIGHT
+ CLL RAR
+ DCA TW2
+ TAD TW3
+ RAR
+ DCA TW3
+ SZL
+ JMS OADD /ADD IF LINK IS ONE
+ ISZ ITRCNT /BUMP COUNT
+ JMP MULLUP /LOOP
+ TAD OP1 /PUT IN CORRECT EXPONENT
+ DCA WORD1
+ JMS ANORM /NORMALIZE THE RESULT
+ JMP I FPMUL
+D2,
+TW2, 0
+D3,
+TW3, 0
+NFCNT,
+ANORM, 0 /NORMALIZE FAC
+ TAD WORD2 /IS MANTISSA 0 ?
+ SNA
+ TAD WORD3
+ SNA
+ TAD ACO
+ SNA CLA
+ JMP ZEXP /YES, ZERO EXPONENT
+NORMLP, CLA CLL CML RTR /IS HIGH ORDER MANTISSA = 6000
+ TAD WORD2
+ SZA
+ JMP NO6000 /NO, SKIP THIS CRAP
+ TAD WORD3 /YES, IS THE REST 0 ?
+ SNA
+ TAD ACO
+ SZA CLA /SKIP IF 600000 ... 0000
+NO6000, SPA CLA
+ JMP I ANORM /NORM IS DONE WHEN BITS DIFFER
+ JMS I (AL1 /SHIFT LEFT ONE
+ CLA CMA /DECREMENT EXPONENT
+ TAD WORD1
+ DCA WORD1
+ JMP NORMLP /LOOP
+ZEXP, DCA WORD1
+ JMP I ANORM
+NEGFAC, 0 /NEGATE FAC
+ TAD (ACO /GET POINTER TO OPERAND
+ DCA NFPTR
+ CLL CMA RTL /THREE WORD NEGATE
+ DCA NFCNT
+ CLL
+NFLOOP, RAL
+ TAD I NFPTR /GET NEXT WORD
+ CLL CML CIA
+ DCA I NFPTR /RESTORE AFTER COMPLEMENTING
+ CML CLA CMA /LINK GETS COMPLEMENTED ONCE HERE
+ TAD NFPTR /AND ONCE AGAIN HERE
+ DCA NFPTR /RESTORE DECREMENTED POINTER
+ ISZ NFCNT
+ JMP NFLOOP
+ JMP I NEGFAC
+NFPTR, 0
+FPDIV, 0
+ JMS I (AR1 /UNNORMALIZE AC BY ONE
+ TAD OP1 /COMPUTE FINAL EXPONENT
+ CIA
+ TAD WORD1
+ DCA OP1 /AND SAVE IT
+ TAD (-30 /SET ITERATION COUNTER
+ DCA ITRCNT
+ TAD WORD2
+ RAL /INITIALIZE LINK
+FPDVLP, CLA RAR /COMPARE SIGNS
+ TAD OP2
+ SPA CLA
+ JMP .+3
+ TAD (OPO-ACO/NEGATE OPERAND
+ JMS NEGFAC
+ JMS OADD /ADD OPERAND AND FAC
+ TAD D3
+ RAL
+ DCA D3
+ TAD D2
+ RAL
+ DCA D2
+ JMS I (AL1 /LEFT SHIFT FAC ONE
+ ISZ ITRCNT /TEST ITERATION COUNT
+ JMP FPDVLP
+ TAD OP1 /PUT QUOTIENT INTO FAC
+ DCA WORD1
+ TAD D2
+ DCA WORD2
+ TAD D3
+ DCA WORD3
+ DCA ACO
+ JMS ANORM /NORMALIZE
+ JMP I FPDIV
+OADD, 0 /ADD OPERAND TO FAC
+ CLL
+ TAD OPO
+ TAD ACO
+ DCA ACO
+ RAL
+ TAD OP3
+ TAD WORD3
+ DCA WORD3
+ RAL
+ TAD OP2
+ TAD WORD2
+ DCA WORD2
+ JMP I OADD
+ITRCNT, 0
+\f/ NUMERIC CONVERSION ROUTINE (FINALE)
+ PAGE
+SMLNUM, 0 /INPUT A NUMBER <= 4095
+EXPLUP, DCA EXPON /ZERO THE EXPONENT
+ JMS I QDIGIT /GET THE NEXT DIGIT
+ JMP I SMLNUM /NUMBER DONE
+ DCA OPO /SAVE THE DIGIT
+ TAD EXPON /MULT BY 10
+ CLL RAL
+ CLL RAL
+ TAD EXPON
+ CLL RAL
+ TAD OPO /ADD IN DIGIT
+ JMP EXPLUP /STORE BACK INTO EXPONENT
+AR1, 0 /SHIFT FAC RIGHT 1 BIT
+ TAD WORD2
+ CLL RAR
+ DCA WORD2
+ TAD WORD3
+ RAR
+ DCA WORD3
+ TAD ACO
+ RAR
+ DCA ACO
+ ISZ WORD1
+ JMP I AR1
+ JMP I AR1
+AL1, 0 /SHIFT FAC LEFT ONE
+ TAD ACO
+ CLL RAL
+ DCA ACO
+ TAD WORD3
+ RAL
+ DCA WORD3
+ TAD WORD2
+ RAL
+ DCA WORD2
+ JMP I AL1
+CHKSGN, 0 /CHECK FOR SIGN
+ TAD (-55 /IS IT - ?
+ SNA
+ ISZ I CHKSGN /YES, SET SWITCH
+ SZA
+ TAD (55-53 /IS IT + ?
+ SZA CLA
+ JMS I QBACK1 /RETURN CHAR OTHERWISE
+ JMP I CHKSGN
+\f/ STRING LITERAL SCANNER
+STRING, 0 /LOOK FOR A STRING
+ JMS I QCHECKC /LOOK FOR "
+M42, -42
+ JMP I STRING /NONE MEANS NO STRING
+ ISZ STRING
+ DCA WORD1 /ZERO CHAR COUNT
+ TAD (WORD2 /SETUP POINTER
+ DCA TEMP
+ TAD (-STRLIM%2 /AND MAX SIZE
+ DCA TEMP2
+SLOOP, JMS GCS /GET HIGH ORDER CHAR
+ JMP I STRING /END OF STRING
+ CLL RTL
+ RTL
+ RTL
+ DCA I TEMP /PUT INTO UPPER HALF OF WORD
+ JMS GCS /GET LOWER CHAR
+ JMP PUT40 /FILL LAST WORD WITH BLANK
+ TAD I TEMP /COMBINE THEM
+ DCA I TEMP
+ ISZ TEMP /BUMP POINTER
+ ISZ TEMP2 /TOO BIG YET ?
+ JMP SLOOP /NO, LOOP
+ JMS I QGETC /MAX SIZE STRING, MUST FIND "
+ JMP STRGER /BAD STRING LITERAL
+ TAD M42
+ SNA CLA
+ JMP I STRING /OK
+STRGER, JMS I QERMSG /STRING ERROR
+ 2123
+ JMP I STRING
+PUT40, TAD I TEMP /GET LAST WORD
+ TAD (40 /PUT BLANK IN LOW CHAR
+ DCA I TEMP /STORE NEW WORD
+ JMP I STRING /RETURN
+GCS, 0 /GET A CHAR FOR STRING
+ JMS I QGETCWB /GET A CHAR (INCLUDE BLANKS)
+ JMP STRGER /BAD
+ TAD M42 /IS IT "
+ SZA
+ JMP NOTQOT /NO
+ JMS I QGETCWB /IS IT ""
+ JMP I GCS /NO, THAT WAS IT
+ TAD M42 /LOOK FOR SECOND "
+ SNA CLA
+ JMP NOTQOT /"" BECOMES "
+ JMS I QBACK1 /PUT IT BACK
+ JMP I GCS /LITERAL IS DONE
+NOTQOT, TAD (42 /RECREATE CHAR
+ AND (77 /ELIMINATE EXTRA BITS
+ ISZ WORD1 /BUMP STRING COUNT
+ ISZ GCS /FIX RETURN
+ JMP I GCS
+MODSET, 0 /SET INTERPRETER MODE
+ TAD MODE /SUM OF DESIRED AND CURRENT
+ SMA CLA
+ JMP I MODSET /THEY WERE THE SAME
+ TAD MODE /OTHERWISE SWITCH MODES
+ SZA CLA
+ TAD (NMODE-SMODE
+ TAD (SMODE /ENTER NMODE OR MAYBE SMODE
+ JMS I QOUTWRD
+ CLL CML RAR
+ TAD MODE /CHANGE THE SWITCH
+ DCA MODE
+ JMP I MODSET /AND RETURN
+XIDIV, FIDIV;AIDIV
+WPNT, -120;-116;-124;-50;0
+\f/ VARIABLE OR FUNCTION REFERENCE SCANNER
+ PAGE
+GETNAM, 0 /LOOK FOR VARIABLE OR FUNCT REFNCE
+ DCA TYPE /ZERO TYPE
+ JMS I QLETTER /MUST START WITH LETTER
+ JMP I GETNAM /NO NAME
+ DCA NAME1
+ JMS I QDIGIT /<LETTER><DIGIT> ?
+ JMP TRYFUN /NO, LOOK FOR FUN REF
+ IAC /INCREMENT DIGIT
+LFDOLR, DCA NAME2 /STORE AS NAME2
+ JMS I QGETC /LOOK FOR $ (STRING)
+ JMP GOTNAM+2/NOT THERE
+ TAD (-44
+ SZA
+ JMP NOSTRG /NO $ MEANS NO STRING
+ CLL CML RAR /SET STRING BIT
+ TAD TYPE
+ DCA TYPE
+ JMS I QGETC /LOOK FOR ( (ARRAY)
+ JMP GOTNAM+2/NAME FINI
+ TAD (-44 /PRIME THE CHAR
+NOSTRG, TAD (44-50 /LOOK FOR ( (ARRAY)
+ SNA CLA
+ CLL CML RTR /YES, SET ARRAY BIT
+ SNA
+ JMS I QBACK1 /NO, BACKUP 1 CHAR
+GOTNAM, TAD TYPE /MODIFY TYPE
+ DCA TYPE
+ ISZ GETNAM /BUMP RETURN
+ JMP I GETNAM
+TRYFUN, JMS I QSAVECP /SAVE CHAR POSITION
+ TAD NAME1 /MOVE FIRST CHAR OVER
+ CLL RTL
+ RTL
+ RTL
+ DCA NAME2
+ JMS I QLETTER /LOOK FOR SECOND LETTER
+ JMP LFDOLR /NONE THERE, LOOK FOR $
+ TAD NAME2 /COMBINE WITH FIRST LETTER
+ DCA NAME2
+ JMS I QLETTER /LOOK FOR THIRD LETTER
+ JMP NOFNAM /NOT A FUNCTION NAME
+ DCA NAME3 /PUT INTO NAME
+ TAD NAME2 /IS IT A USER FUNCT ?
+ TAD (-616 /FN
+ SNA CLA
+ JMP USRFUN /YES
+ TAD (FUNS-1 /NO, CHECK VALIDITY OF NAME
+ DCA X10
+FUNSRC, TAD I X10 /GET NEXT FUN NAME
+ SNA
+ JMP NOFNAM /END OF LIST, INVALID NAME
+ TAD NAME2 /COMPARE FIRST 2 CHARS
+ SZA CLA
+ JMP NOMATC /THEY DON'T MATCH
+ TAD I X10 /COMPARE 3RD CHAR
+ TAD NAME3
+ SZA CLA
+ JMP NOMATC+1/DON'T MATCH
+ TAD I X10 /GET FUNCTION CODE
+FUNOK, DCA SYMBOL /SAVE IT AS SYMBOL VALU
+ TAD (1000 /SET FUNCTION BIT
+ DCA TYPE
+ JMP LFDOLR /LOOK FOR Q$] Q(]
+NOMATC, ISZ X10 /SKIP THIRD CHAR
+ ISZ X10 /SKIP FUNCTION NUMBER
+ JMP FUNSRC /KEEP LOOKING
+NOFNAM, JMS I QRESTCP /RESTORE CHAR POS
+ JMP LFDOLR /LOOK FOR Q$] Q(]
+USRFUN, TAD NAME3 /GENERATE FUN NUMBER
+ JMP FUNOK
+\f/ ERROR MESSAGE REPORTER
+ERMSG, 0 /PRINT ERROR MESSAGE
+ CLA
+ CDF
+ TAD I ERMSG /GET CODE
+ CLL RTR /PRINT FIRST CHAR
+ RTR
+ RTR
+ JMS TTY
+ TAD I ERMSG /PRINT SECOND CHAR
+ JMS TTY
+ ISZ ERMSG /FIX RETURN ADDR
+ TAD SPACE /PRINT SPACE
+ JMS TTY
+ DCA TTY /USE TTY AS A SWITCH
+ TAD LINEH /PRINT HIGH ORDER
+ JMS PSN
+ TAD LINEL /THEN LOW ORDER
+ JMS PSN /(LINE NUMBER NATCH !)
+ TAD (215 /PRINT CARRIAGE RETURN
+ JMS TTX
+ TAD (212 /PRINT LINE FEED
+ JMS TTX
+ JMP I ERMSG /RETURN
+PSN, 0 /PRINT 3 DIGITS DECIMAL
+ DCA WORD2
+ CLL CMA RTL /-3
+ DCA TEMP
+PRNTSN, TAD WORD2 /GET NEXT DIGIT
+ CLL RTL /INTO THE LOW ORDER
+ RTL /THREE BITS AND THE LINK
+ DCA WORD2 /SAVE SHIFTED NUMBER
+ TAD WORD2 /NOW DO LAST SHIFT
+ RAL
+ AND (17 /ONLY FOUR BITS
+SPACE, SZA
+ JMP NOZERO /NOT A ZERO
+ TAD TTY /ANY DIGITS YET ?
+ SNA CLA
+ JMP LEAD0 /NO, ITS A LEADING ZERO
+NOZERO, TAD (60 /MAKE IT ASCII
+ JMS TTY /PRINT DIGIT
+LEAD0, ISZ TEMP /BUMP COUNT
+ JMP PRNTSN /MORE DIGIT(S)
+ JMP I PSN
+XMUL, FMPY;AFMPY
+\f/ EXPONENT TABLE
+ PAGE
+PETABL, 0004;2400;0000;0000
+ 0007;3100;0000;0000
+ 0016;2342;0000;0000
+ 0033;2765;7020;0000
+ 0066;2160;6744;6770
+ 0153;2356;1326;6501
+ 0325;3023;6017;5120
+ 0652;2235;6443;7114
+ 1523;2523;7565;7735
+ 3245;3430;6320;2565
+\f/ OPERATOR TABLE
+OPR8RS, PLUS;-53
+ MINUS;-55
+ STAR;-52
+ SLASH;-57
+ UPAROW;-136
+ AMPSND;-46
+ 0
+SASIGN, 4000;XSTOR
+ASSIGN, 0;XSTOR
+\f/ FUNCTION NAME TABLE (INTERNAL FUNCTIONS)
+FUNS, -0102;-23;FUNC3
+ -0123;-03;FUNC2
+ -0124;-16;FUNC1
+ -0310;-22;FUNC2+20
+ -0317;-23;FUNC1+20
+ -0401;-24;FUNC2+40
+ -0530;-20;FUNC1+40
+ -1116;-24;FUNC1+100
+ -1405;-16;FUNC2+60
+ -1417;-07;FUNC1+120
+ -2017;-23;FUNC2+100
+ -2216;-04;FUNC1+200
+ -2305;-07;FUNC2+120
+ -2307;-16;FUNC1+140
+ -2311;-16;FUNC1+160
+ -2321;-22;FUNC1+220
+ -2324;-22;FUNC2+140
+ -2601;-14;FUNC2+160
+ -2422;-03;FUNC2+220
+ENDFNS, 0;0;FUNC4 /SPACE FOR NEW FUNCTIONS
+ 0;0;FUNC4+20
+ 0;0;FUNC4+40
+ 0;0;FUNC4+60
+ 0;0;FUNC4+100
+ 0;0;FUNC4+120
+ 0;0;FUNC4+140
+ 0;0;FUNC4+160
+ 0;0;FUNC4+200
+ 0;0;FUNC4+220
+ 0;0;FUNC4+240
+ 0;0;FUNC4+260
+ 0;0;FUNC4+300
+ 0;0;FUNC4+320
+ 0;0;FUNC4+340
+ 0;0;FUNC4+360 /SIXTEEN OF THEM
+ 0
+\f/ KEYWORD LIST
+KEYWRD, -114;-105;-124;LET
+ -111;-106;-105;-116;-104;IFEND
+ -111;-106;IF
+ -106;-117;-122;FOR
+ -116;-105;-130;-124;NEXTX
+WGOTO, -107;-117
+WTO, -124;-117;GOTO
+ -107;-117;-123;-125;-102;GOSUB
+ -111;-116;-120;-125;-124;INPUT
+ -120;-122;-111;-116;-124;PRINT
+ -104;-111;-115;DIM
+ -104;-101;-124;-101;DATA
+ -104;-105;-106;DEF
+ -106;-111;-114;-105;FILE
+ -122;-105;-101;-104;READX
+ -122;-105;-115;REMARK
+ -122;-105;-123;-124;-117;-122;-105;RESTOR
+ -122;-105;-124;-125;-122;-116;RETURN
+ -123;-124;-117;-120;STOPX
+ -122;-101;-116;-104;-117;-115;-111;-132;-105;RANDOM
+ -103;-114;-117;-123;-105;CLOSE
+ -103;-110;-101;-111;-116;CHAIN
+ -125;-104;-105;-106;UDEF
+ -125;-123;-105;USEX
+ -105;-116;-104;END
+ 0
+\f/ OS-8 OUTPUT ROUTINE
+OWTEMP, 0
+OUPTR, OUBUF
+OCOUNT, -401
+OUTWRD, 0 /OUTPUT ROUTINE
+ DCA OWTEMP /SAVE WORD
+ ISZ LOCTRL /INCREMENT PSEUDO CODE
+ SKP /LOCATION COUNTER
+ ISZ LOCTRH /BOTH HALVES
+ NOP /IT'LL NEVER HAPPEN
+ ISZ OCOUNT /TEST FOR BUFFER FULL
+ JMP NOWRIT /STILL SOME ROOM
+ JMS OUDUMP /DUMP THE BUFFER
+ TAD OUBLOK-1/RESET BUFFER PARAMETERS
+ DCA OUPTR
+ TAD (-400
+ DCA OCOUNT
+NOWRIT, TAD OWTEMP /PUT WORD
+ CDF 10
+ DCA I OUPTR /INTO BUFFER
+ CDF
+ ISZ OUPTR /MOVE POINTER
+ JMP I OUTWRD
+OUDUMP, 0 /DUMP OUT BUFFER
+ JMS I (7607 /CALL OUTPUT HANDLER
+ 4210
+ OUBUF
+OUBLOK, 0
+ JMP OUERR
+ ISZ OUBLOK /INCREMENT BLOCK NUMBER
+ ISZ OUSIZE /CHECK FOR HOLE FULL
+ JMP I OUDUMP
+OUERR, JMS I QERMSG /OUTPUT FILE ERROR
+ 1706
+ JMP I XABORT /ABORT COMPILATION
+ODEVH, 0
+OUSIZE, 0
+AMPRTN, JMS LOD1ST /LOAD OP1$
+ AMPSND+2 /CONC OP2$
+SCRTN, JMS LOD1ST /LOAD OP1$
+ SCOMPR+1 /COMP OP2$
+LOD1ST, 0 /HANDLE ONE WAY INSTRUCTIONS
+ JMS I QSAVAC /STORE 2ND ARG IF IN SAC
+ -1
+ CLA CMA /GET TYPE OF 2ND ARG
+ TAD OSTACK
+ DCA TEMP
+ CLL CML RTR /IS IT SUBSCRIPTED ?
+ AND I TEMP
+ SNA CLA
+ JMP SKIP2 /NO, ENTRY IS ONLY 2 WORDS
+ TAD I TEMP /GET NUMBER OF DIMS
+ AND SCOMPR /LITERAL 3
+ CLL RAL /DOUBLE IT
+ CIA
+SKIP2, TAD (-2 /FIND SIZE OF 2ND ARG
+ DCA OP2SIZ /AND SAVE IT
+ TAD OSTACK /BACK UP STACK
+ TAD OP2SIZ
+ DCA OSTACK
+ TAD OSTACK /AND SAVE THIS ADDR
+ DCA X12
+ JMS I QLOAD /LOAD ARG 1
+ CLL CML RAR /GET TYPE BIT
+ AND TYPE1 /PUT BACK ARG1
+ TAD Q400
+ DCA I OSTACK
+ DCA I OSTACK
+ TAD I X12 /PUT BACK ARG 2
+ DCA I OSTACK
+ ISZ OP2SIZ
+ JMP .-3
+ TAD I LOD1ST /GET OPERATOR FINISH
+ JMP OUTOPR+1/GO FINISH CODE
+OP2SIZ, 0 /SACRED COUNT WORD
+CHECKC, 0 /CHAR CHECKER
+ JMS I QGETC /GET A CHARACTER
+ JMP .+6 /FAILED
+ TAD I CHECKC /COMPARE
+ SNA
+ ISZ CHECKC /MATCHES, SKIP TWO
+ SZA CLA
+ JMS I QBACK1 /NO MATCH, REPLACE
+ ISZ CHECKC /ALWAYS SKIP AT LEAST 1
+ JMP I CHECKC
+SCOMPR, 3;SCRTN-3;4000;XSCOMP;XSCOMP
+\f/ OS-8 FILE INPUT ROUTINE
+ PAGE
+ICHAR, 0 /READ CHAR FROM INPUT FILE
+ ISZ INJMP /BUMP THREE WAY UNPACK SWITCH
+ ISZ INCHCT
+INJMPP, JMP INJMP
+ TAD INEOF /LAST READ YEILD END OF FILE ?
+ SZA CLA
+ JMP ENDFIL /YES
+INGBUF, TAD INCTR /BUMP RECORD COUNTER
+ CLL IAC
+ SNL
+ DCA INCTR /RESTORE IF IT HASN'T OVERFLOWED
+ SZL
+ ISZ INEOF /SET END OF FILE SWITCH
+ JMS I INHNDL /DO THE READ
+ 0200 /ONE BLOCK TO FIELD 0
+INBUFP, INBUF
+INREC, 0
+ JMP INERR /HANDLER ERROR
+INBREC, ISZ INREC /BUMP RECORD NUMBER
+ TAD (-601 /SET CHAR COUNT
+ DCA INCHCT
+ TAD INJMPP /RESET THREE WAY JUMP SWITCH
+ DCA INJMP
+ TAD INBUFP /RESET BUFFER POINTER
+ DCA INPTR
+ JMP ICHAR+1 /GO AGAIN
+INERR, SMA CLA
+ JMP INBREC
+ENDFIL, JMS I QERMSG /INPUT FILE ERROR
+ 1505
+ABORT, TAD (4207 /RESTORE ^C LOCZTIONS
+ DCA 7600
+ TAD (6213
+ DCA 7605
+ CDF 10
+ TAD INFO /GET START OF BASIC.SV
+ CDF
+ SNA
+ JMP 7605 /T'WERE RUNNED
+ DCA EDTBLK /SAVE MAGICAL BLOCK NUMBER
+ JMS 7607 /USE SYS HANDLER
+ EDTSIZ /TO READ IN THIS MUCH
+ 0 /INTO ZERO
+EDTBLK, 0 /FROM HERE
+ HLT /HALT IF BAD READ
+ JMP EDTBGN /GO RESTART EDITOR
+INJMP, HLT /3 WAY CHAR UNPACK JUMP
+ JMP ICHAR1
+ JMP ICHAR2
+ICHAR3, TAD INJMPP /RESET JUMP SWITCH
+ DCA INJMP
+ TAD I INPTR
+ AND (7400 /COMBINE THE HIGH ORDER BITS
+ CLL RTR /OF THE TWO WORDS
+ RTR
+ TAD INTMP /TO FORM THE THIRD CHAR
+ RTR
+ RTR
+ ISZ INPTR /BUMP WORD POINTER
+ JMP ICHAR1+1/DO SOME COMMON STUFF
+ICHAR2, TAD I INPTR /SAVE THE HIGH ORDER BITS
+ AND (7400
+ DCA INTMP /FOR THE THIRD CHAR
+ ISZ INPTR /GO TO THE SECOND WORD
+ICHAR1, TAD I INPTR /GET THE LOW 7 BITS
+ AND (177 /AND I MEAN ONLY 7 !!
+ SNA /IGNOR LEADER-TRAILER
+ JMP ICHAR+1
+ TAD (-134 /CHECK FOR \ (STMT SEPARATOR)
+ SNA
+ JMP I ICHAR /TREAT LIKE CR
+ TAD (134-32 /IS IT ^Z (END OF FILE)
+ SNA
+ JMP ENDFIL /YES, ITS END OF FILE
+ TAD (32-12
+ SNA
+ JMP ICHAR+1 /IGNORE LINE FEEDS
+ IAC /TABS -> BLANKS
+ SNA
+ TAD (40-11
+ TAD (11-15
+ SNA
+ JMP I ICHAR /RETURN ON CARRIAGE RETURN
+ IAC
+ SNA
+ JMP ICHAR+1 /IGNORE FORM FEEDS
+ TAD (14 /FIX CHAR
+ ISZ ICHAR
+ JMP I ICHAR /RETURN TO THE CALLING WORLD
+INTMP, 0
+INEOF, 0
+INCHCT, -1
+INHNDL, 0 /ENTRY ADDR GOES HERE
+INCTR, 0
+INPTR, 0
+CHKWD, 0 /WORD CHECKER
+ TAD I CHKWD /GET POINTER
+ ISZ CHKWD
+ DCA CWTEMP /SAVE POINTER
+WDLOOP, TAD I CWTEMP /GET NEXT CHAR
+ SMA
+ ISZ CHKWD /IF NON NEG, FIX RETURN
+ SPA CLA
+ JMS I QGETC /GET CHAR
+ JMP I CHKWD /RETURN
+ TAD I CWTEMP /COMPARE
+ ISZ CWTEMP /INCR POINTER
+ SNA CLA
+ JMP WDLOOP /MORE
+ JMP I CHKWD /FAILED
+CWTEMP, 0
+\f/ INITIALIZATION CODE
+ *LINE
+START, JMP RUNNED /DO LOOKUPS, AND FIND TEMPFILE
+CHAINED,CDF 10
+ TAD I (7644 /WAS IT A CHAIN FROM BRTS ?
+ CDF
+ AND (100
+ SNA CLA
+ JMP CHEDIT /NO, FROM THE EDITOR
+ CIF 10 /CHAIN FROM BRTS, RESET
+ JMS I (200 /TO FORGET DSK: HANDLER
+ 13
+ JMP STRT3 /NOW GO OPEN TEMP FILE
+CHEDIT, TAD (INFO+7 /PICK UP SOME STUFF
+ DCA X10
+ CDF 10 /FROM THE INFO BLOCK
+ TAD I X10 /START OF TEMP FILE
+ SNA
+ JMP I (RUNNED+4 /MUST BE CHAIN FROM CCL
+ DCA BLOCK
+ TAD I X10 /SIZE OF HOLE
+ CDF
+ DCA OUSIZE
+ TAD BLOCK
+ DCA OUBLOK
+ CDF 10
+ TAD I X10 /ENTRY ADDR OF HANDLER
+ CDF
+ DCA INHNDL
+ JMP STRT2
+GETDEV, CDF 10
+ TAD 7617 /GET DEVICE NUM FOR INPUT FILE
+ CDF
+ CIF 10
+ JMS I (200 /GO FETCH THE DEVICE
+ 1
+ INDEVH+1 /2 PAGE HANDLER IS OK
+ JMP NG /ERROR
+ TAD .-2 /GET HANDLER ADDRESS
+ DCA INHNDL /SAVE IT
+ CIF 10
+ JMS I (200 /RESET SYSTEM TABLES
+ 13 /DELETING TENTATIVE FILES
+STRT2, CDF 10
+ TAD 7617 /SET UP INPUT FILE PARAMS
+ CDF
+ AND (7760 /GET SIZE
+ TAD (17
+ CLL CML RTR
+ RTR
+ DCA INCTR
+ CDF 10
+ TAD 7620 /GET BLOCK NUMBER
+ CDF
+ DCA INREC
+ CDF 10
+ TAD INFO+3 /GET START OF BRTS.SV (+1)
+ DCA BRTS
+ TAD INFO /GET START OF BASIC.SV (+1)
+ DCA ABORTX /BOTH FOR BLOAD
+ TAD INFO+2 /GET START OF BLOAD.SV
+ CDF
+ DCA LDRBLK /FOR CHAIN TO BLOAD
+ TLS /SET TTY FLAG
+ ISZ WASTE
+ JMP .-1
+ ISZ TIME
+ JMP .-1
+INITST, TAD (VARST-1/INITIALIZE ST AREA
+ DCA X12
+ TAD (-436-436-436
+ DCA X11 /SIZE OF NUM AND STRING TABLES
+ CDF 10
+ CLL CML RAR /SET TO 4000
+ DCA I X12
+ ISZ X11
+ JMP .-3
+ TAD (-440 /NOW ARRAY TABLES
+ DCA X11 /AND BUCKETS
+ DCA I X12
+ ISZ X11 /SET THEM TO ZERO
+ JMP .-2
+ CDF
+ TAD JABORT /MODIFY ^C LOCATIONS
+ DCA 7600
+ TAD JABORT
+ DCA 7605
+ JMP CORE /GET CORE SIZE
+NG, TLS
+ JMS I QERMSG /SUPER ERROR
+ 2331
+ TSF
+ JMP .-1
+JABORT, JMP I XABORT /ABORT COMPILATION
+WASTE, 0
+TIME, 200
+\f *INBUF
+CORE, TAD 7777 /MODIFIED CORE SIZE ROUTINE FROM
+ AND (70
+ SNA
+ JMP COR0
+ CLL RAR
+ RTR
+ IAC
+ DCA CORSIZ
+ JMP COREX /OS8 SOFTWARE SUPPORT MANUAL
+COR0, CDF
+ TAD CORSIZ
+ RTL
+ RAL
+ AND COR70
+ TAD COREX
+ DCA .+1
+COR1, CDF
+ TAD I CORLOC
+COR2, NOP
+ DCA COR1
+ TAD COR2
+ DCA I CORLOC
+COR70, 70
+ TAD I CORLOC
+CORX, 7400
+ TAD CORX
+ TAD CORV
+ SZA CLA
+ JMP COREX
+ TAD COR1
+ DCA I CORLOC
+ ISZ CORSIZ
+ JMP COR0
+COREX, CDF
+ CLA CMA /HI FIELD IS #FIELDS-1
+ TAD CORSIZ
+ DCA HIFLD
+ TAD HIFLD
+ CIA
+ DCA NFLDS
+ CMA /HOW MANY FIELDS ?
+ TAD HIFLD /MUST THIS BASIC USE ?
+ SZA CLA /(SOUNDS LIKE A LINE BY DYLAN)
+ JMP GENER
+ TAD (PATCH1+3&177+5200
+ DCA PATCH1 /ONLY 8K, DON'T USE CDF'S
+ TAD (PATCH2+11&177+5200
+ DCA PATCH2
+ TAD (PATCH3+4&177+5200
+ DCA PATCH3
+ TAD (PATCH4+3&177+5200
+ DCA PATCH4
+ TAD (7000
+ DCA PATCH5
+GENER, JMS GENTMP /GENERATE TEMP 0
+ JMS GENTMP /GENERATE TEMP 1
+ JMS GENTMP /GENERATE TEMP 2
+ CLA IAC /GENERATE STRING TEMP 0
+ JMS GENTMP
+ CLA IAC
+ DCA WORD1 /GENERATE LITERAL 1.0
+ CLL CML RTR
+ DCA WORD2
+ JMS I QLUKUP2 /ENTER INTO ST
+ LITRL
+ -3
+ JMS NEWVAR
+ TAD (FNINIT /SET UP FUNCTIONS
+ DCA FDPTR
+FDLOOP, TAD (WORD1-1
+ DCA X12
+ TAD I FDPTR /GET FIRST WORD
+ ISZ FDPTR
+ SNA
+ JMP I QREMARK /DONE, START COMPILER
+ DCA I X12 /SAVE IN WORD1
+ CLL CMA RTL /GET LOOKUP COUNT
+ TAD I FDPTR
+ DCA FUNSIZ
+ TAD FUNSIZ /GET SIZE OF MOVE
+ IAC
+ DCA TEMP
+ TAD I FDPTR /GET A WORD
+ ISZ FDPTR
+ DCA I X12 /PUT INTO WORDN
+ ISZ TEMP
+ JMP .-4
+ JMS I QLUKUP2 /ENTER INTO S.T.
+ FUNCTN
+FUNSIZ, 0
+ JMP FDLOOP /LOOP
+FDPTR, 0
+CORLOC, CORX
+CORV, 1400
+CORSIZ, 1
+NAMLST, BCOMPN /SAVE FILE NAME-POINTER LIST
+ BLOADN
+ BRTSN
+ BAFN
+ BSFN
+ BFFN
+ 0
+\f PAGE
+FNINIT, FUNC3;-1;2000;0 /ABS
+ FUNC1;-1;2000;0 /ATN
+ FUNC2;-1;6000;0 /ASC
+ FUNC1+20;-1;2000;0 /COS
+ FUNC2+20;-1;2000;4000 /CHR
+ FUNC1+40;-1;2000;0 /EXP
+ FUNC2+40;-1;2000;4000 /DAT
+ FUNC1+220;-1;2000;0 /SQR
+ FUNC1+60;-2;0;2000;0 /EXP2
+ FUNC2+60;-1;6000;0 /LEN
+ FUNC1+100;-1;2000;0 /INT
+ FUNC2+100;-3;2000;4000;6000;0 /POS
+ FUNC1+120;-1;2000;0 /LOG
+ FUNC2+120;-3;0;2000;6000;4000 /SEG
+ FUNC1+140;-1;2000;0 /SGN
+ FUNC2+140;-1;2000;4000 /STR
+ FUNC1+160;-1;2000;0 /SIN
+ FUNC2+160;-1;6000;0 /VAL
+ FUNC1+200;-1;2000;0 /RND
+ FUNC2+220;-1;2000;0 /TRC
+ 0
+BASICN, FILENAME BASIC.SV /FILE NAMES
+BCOMPN, FILENAME BCOMP.SV /FOR LOOKUPS
+BLOADN, FILENAME BLOAD.SV
+BRTSN, FILENAME BRTS.SV
+BAFN, FILENAME BASIC.AF
+BSFN, FILENAME BASIC.SF
+BFFN, FILENAME BASIC.FF
+BUFN, FILENAME BASIC.UF
+TMPFIL, FILENAME BASIC.TM
+ $
+\f\f
projects / pdp8.git / blobdiff