File: BCOMP.PA of Tape: OS8/OS8-V3D/al-4760c-sa-os8-ext-2
(Source file text)
/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. / / / / / / /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 *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 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 / 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 *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 / 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 / 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 / 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 / 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 / WSTEP, -123;-124;-105;-120;0 / 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 UPAROW, 60;1;EXPRTN-1 / 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 / XSCOMP, SCOMP;SACOMP XDIV, FDIV;AFDIV / PATCH6, 0 ISZ SIGDIG JMP I PATCH6 CMA DCA SIGDIG JMP CONVLP / STAR, 50;0;XMUL;XMUL / 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 /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" 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 / 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 (-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 / 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, 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 / 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 *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 $