File: BCOMP.03 of Tape: OS8/OS8-V3/dec-s8-uextb-a-ua1
(Source file text)
/OS8 BASIC COMPILER, V3
/
/
/
/
/
/
/
/
/
/COPYRIGHT (C) 1974 BY DIGITAL EQUIPMENT CORPORATION
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
/CORPORATION. DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/FOR ANY ERRORS THAT MAY APPEAR IN THIS MANUAL.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
/
/DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
/OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
/DIGITAL.
/
/
/
/
/
/
/
/
/
/
/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=300
*6
XABORT, ABORT /ADDR OF ABORT ROUTINE
VERS, VERSON /VERSION NUMBER
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
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=1700 /SIZE OF BASIC.SV
EDTBGN=3012 /RESTART FOR EDITOR
ERMSG2=1712 /POST PROCESSOR ERROR SWITCH
EOST=7570 /UPPER LIMIT FOR SYMBOL TABLE
INDEVH=4400 /INPUT DEVICE HANDLER
LINE=7000 /LINE BUFFER
LINMAX=120 /MAXIMUM BASIC STMT
STACKA=7120 /MAIN STACK
STAKSZ=60 /SIZE OF MAIN STACK
/OPERAND STACK DEFINED IN-LINE
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
/ 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
/ ASSEMBLE LINE
*WORD1+45 /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 TEMP
GETLIN, JMS ICHAR /GET NEXT CHAR
JMP GOTCR /CR
DCA I X10 /PUT INTO LINE BUFFER
ISZ TEMP /BUMP MAX COUNTER
JMP GETLIN
JMS I QERMSG /LINE TOO LONG
1424
JMS ICHAR /SKIP REST OF LINE
JMP GOTCR
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, 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
/ 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
1200 /TEN PAGES
POSTX, 400 /FROM 400
LDRBLK, 0 /FROM THIS BLOCK
JMP I XABORT
TAD I QERMSG /SET POST PROCESSOR ERROR SWITCH
DCA ERMSG2
JMP I POSTX /START IT UP
STAR, 50;0;XMUL;XMUL
UPAROW, 60;1;EXPRTN-1
/ 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
/ 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 (-111
SNL CLA
JMP I CHKSDM /OK, SIZE < 73
DIMERR, JMS I QERMSG /GIVE ERROR
0411
JMP I QREMARK /ABORT STMT
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/ 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
/INPUT DEVICE HANDLER
*INDEVH
0
/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"
TAD (INFO-5
DCA X10
CDF 10
TAD 7620
CDF
SNA CLA /NULL INPUT?
JMP RUNNED /YES: NAUGHTY
TAD 7777
AND (70
SNA /V3 BATCH RUNNING?
TAD (10 /NO HARM TRYING
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
/ 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
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
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
WSTEP, -123;-124;-105;-120
XADD, FADD;AFADD
/ 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
/ 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
/ 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 (-44 /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
/ 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
/ 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
/ 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
/ OPERATOR TABLE
OPR8RS, PLUS;-53
MINUS;-55
STAR;-52
SLASH;-57
UPAROW;-136
AMPSND;-46
0
SASIGN, 4000;XSTOR
ASSIGN, 0;XSTOR
/ 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
/ 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
/ 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
/ 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, CLA
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 !!
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
XSCOMP, SCOMP;SACOMP
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
XDIV, FDIV;AFDIV
/ 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
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
*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
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
$