/Commercial BASIC Compiler, EX / / / / / / / / / / / / /COPYRIGHT (C) 1972, 1973, 1974, 1975, 1978, 1979, 1982, 1983, 1984 /Digital Equipment Corporation, Maynard, Ma. / / / /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 any other /copies thereof, may not be 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 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 /Equipment Corporation. / /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 / / /ASSEMBLE AND LOAD AS FOLLOWS: / .PAL BCOMP/E/W / .LOAD BCOMP / .SA SYS BCOMP=2100 VERSON= "B /VERSION LOCATED IN CORE AT TAG "VERLOC" PATCH= "0 / /CORRECTION & ADDITION MADE FOR V4 1975 / / ./V FOR VERSION NUMBER / . ABILITY TO INPUT FROM PTR / .CORRECT TEST FOR BATCH RUNNIG / .IGNORE MORE THAN 10 SIGNIFICANT DIGITS / OF NUMERIC CONSTANTS / 30-APR-77 UPDATE VERSION / 4-Dec-77 Begin commercial Basic mods / 23-Jan-78 Re-layout core / 31-Jan-78 Add 7 bit ASCII support / 15-Feb-78 Add string arithmetic parsing / 22-Feb-78 Add PRINT USING / 3-Apr-78 Add direct access statements / 14-May-78 Put in fancy error messages, do misc clean ups / 15-May-78 Add ON-GOTO/GOSUB feature, fix DATA statement bug / 5-Mar-79 Install source fix for array concatenation, bump version / 8-AUG-81 Changes to allow multi-character variable names, / Longer source line / 01-JAN-82 ADDED EXIT, STORE, RECALL, AND HOOKS FOR GRAPHICS / COMMANDS. / 02-APR-82 MODIFIED KEY COMMAND FOR TWO VARIABLES / 07-APR-82 FIXED IF OPEN & IF END FOR CMB LINE COMMANDS / 19-APR-82 ADDED ON ERROR GOTO, RESUME, TRAP / 28-JAN-83 ADDED X$=CAL$("FILE.EX",#) / /V54 13-FEB-84 Added TDCHK conditional / / When a basic program is executed or compiled with a / slash B option (compile for batch) BCOMP will not allocate / more than 5 fields (24kw). The reason for this is that batch / requires 4k, and if the system has 32kw of memory field 7 is / allocated for the TD ROM option. The following conditional will / correct this restriction. TDCHK=0 / 0 = do not check for TD ROM option / 1 = check for TD ROM option / If system is a DECmate set to 0 *1 CIF 30 /Symbiosis interrupt linkage JMP .-1 *3 Q1000, 1000 /Often used literals QTYPCK, TYPCK TEMP3, 0 XABORT, ABORT /ADDR OF ABORT ROUTINE QGETFN, GETFN /GEt file number routine *10 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 THSFLD, /HIGHEST FIELD USDE BY S.T. PASSED TO BLOAD HERE LINEH, 0 /LINE NUMBER (HIGH) OUTFLG, /FLAG PASSED TO BLOAD NONZERO IF TEMP FILE WRITES DONE 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 DACNT, /ARG COUNT FOR UDEF STMT PCRLF, /CR SWITCH FOR PRINT STMT FORJMP, 0 /FOR LOOP JUMP INSTR NOSN, 0 /STMT NUMBER PRESENT SWITCH 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 Q70, 70 Q400, 400 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 QSTCHEK,STCHEK QGENTMP,GENTMP IFJMP, 0 /Gets pointer to IF jump over instruction / *** Warning: Locations starting here are used / For string literals and are overwritten / NAME1, /VARIABLE OR FUNCT NAME WORD1, 0 /3 WORD LITERAL BUFFER NAME2, WORD2, 0 NAME3, WORD3, 0 NAME4, /Fourth name word ACO, 0 /FAC OVERFLOW WD OP1, 0 /4 WORD ARG FOR "NUMBER" OP2, 0 OP3, 0 OPO, 0 NXTDGT, 0 TRLDIG, 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.OV /INFO+5 *UNUSED* /INFO+6 *UNUSED* /INFO+7 *UNUSED* /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 /OS/8 DEFINES BIPCCL= 7777 /BATCH IN PROGRESS/CORE SIZE WORD IN FIELD 0 JSW= 7746 /JOB STATUS WORD IN FIELD 0 CDOPT2= 7642 /HIGH ORDER CD = OPTION CDOPT3= 7643 /CD SWITCHES ABC DEF GHI JKL CDOPT4= 7644 /CD SWITCHES MNO PQR STU VWX CDOPT5= 7645 /CD SWITCHES YZ0 123 456 789 CDOPT6= 7646 /LOW ORDER CD = OPTION BOSINF= 7774 /BOS PARAMETER AREA /BASIC DEFINES EDTSIZ= 2400 /SIZE OF BASIC.SV EDTBGN= 0201 /RESTART FOR EDITOR BLDSZ0= 1500 /SIZE CONTROL WORD FOR BLOAD.SV ROOT EOST= 7570 /UPPER LIMIT FOR SYMBOL TABLE INDEVH= 5600 /INPUT DEVICE HANDLER LINMAX= 200 /MAXIMUM BASIC STMT (one page, length of line buffer) STAKSZ= 57 /SIZE OF MAIN and operand STACKS STRLIM= 205 /MAXIMUM STRING SIZE OUBUF= 400 /TEMP FILE OUTPUT BUFFER IN FIELD 1 INBUF= 1000 /SOURCE FILE INPUT BUFFER IN FIELD 1 BCERRO= 4 /OFFSET TO ERROR MESSAGE OVERLAY IN FIELD 1 TXTOFS= 5 /OFFSET TO ERROR MESSAGE TEXT OVERLAY FOR FIELD 1 F0OFFS= 11 /BLOCK OFFSET TO FIELD 0 FOR CHAIN FROM BASIC.SV OR BRTS AC4000= CLA STL RAR AC2000= CLA STL RTR AC7776= CLL STA RAL AC7775= CLL STA RTL /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 LOADSN= 6000 /JOC CLASS JSUB= 5000 JUMP= 5001 JGE= 5002 JNE= 5003 JGT= 5004 JLT= 5005 JEQ= 5006 JLE= 5007 JFOR= 5010 JFOPEN= 5011 JEOF= 5012 JXOPEN= 5013 JXEOF= 5014 /ARRAY CLASS AFADD= 6400 AFSUB= 6440 AFMPY= 6500 AFDIV= 6540 AFLDA= 6600 AFSTA= 6640 AISUB= 6700 AIDIV= 6740 /STRING CLASS SCON= FADD SCOMP= FSUB SREAD= FMPY SARITH= FDIV SLOAD= FLDA SSTORE= FSTA SACON= AFADD SACOMP= AFSUB SAREAD= AFMPY ASARITH=AFDIV SALOAD= AFLDA SASTOR= AFSTA /OPERATE CLASS SETJF= 7401 RNDO= 7421 STOP= 7554 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= FUNC3+320 LSS1AC= 7406 LSS2AC= 7407 / FESC= 7410 READ= 7411 WRITE= 7412 SWRITE= 7413 ONPFX= 7441 SMODE= 7561 NMODE= 7541 FUNC1= 7416 FUNC2= 7417 FUNC3= 7400 FUNC4= 7415 FUNC5= 7414 FUNC6= 7410 FUNC7= 7405 SNEG= FUNC2+240 PUINIT= FUNC3+160 PUEXEC= FUNC3+200 WSUB= FUNC6+020 DEFREC= FUNC6+100 LOCATE= FUNC6+040 WEOR= FUNC6+060 RSUB= FUNC6+000 RECSIZ= FUNC6+120 VALFUN= FUNC2+160 STRFUN= FUNC2+140 XEXIT= 7601 XSLEEP= FUNC4+200 XSTORE= FUNC7 XRECAL= FUNC7+020 XERROR= FUNC3+140 XRESUM= FUNC3+260 XOFERR= FUNC3+240 XRSUM0= FUNC3+340 XTRAP= FUNC4+300 /MAIN BCOMP ENTRY POINT *200 JMP I PRUNNED /RUN VIA .R COMMAND JMP I PCHAIN /RUN VIA USR CHAIN FROM CCL PRUNNED,RUNNED PCHAIN, CHAINED *STRLIM^2%3+1+WORD1 /ORIGIN PAST BIGGEST STRING LITERAL STACKA, ZBLOCK STAKSZ /Main stack STACKO, ZBLOCK STAKSZ /Operand stack /ASSEMBLE LINE NEWLIN, JMS I QGETC /ANY CHARS LEFT ? JMP REMARK /NO, LINE ENDED OK JMS I QERMSG /EXTRA CHARACTERS XCMSG REMARK, 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 DCA NOSN /CLEAR STMT NUMBER SWITCH TAD (LINE-1 /GET THE NEXT LINE DCA X10 TAD (-LINMAX/MAX SIZE DCA TEMP3 GETLIN, CIF CDF 10 JMS I (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 LTMSG FLUSH, CIF CDF 10 JMS I (ICHAR /SKIP REST OF LINE JMP NOSNUM+3 JMP FLUSH 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 TAD IFJMP /Is there a JUMP pending? SZA CLA JMS I (SETIFJ /Yes, set it up 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 CONTIN, CDF NOSNUM, TAD TEMP3 SNA CLA JMP ERLTL CDF 0 /In case DF=1 from FLUSH JMS I (KBDCHK /CHECK FOR ^C OR ^O TAD (KEYWRD-1 DCA X10 /SET UP FOR KEYWORD SEARCH JMS I QSAVECP /SAVE CHAR POS KWLOOP, JMS KWGCH /GET A KEYWORD CHAR FROM FIELD 1 SZL /LINK SET IF GOT DISPATCH ADDR JMP GOTKW /OK, THIS IS THE KW NEXTKW, 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 JMS KWGCH /SKIP OVER REST OF KEYWORD SNL CLA /SKP IF AT END JMP .-2 JMS KWGCH /Get char, ignore link SZA JMP NEXTKW /NO, KEEP LOOKING JMP I (LET /TREAT AS LET STMT GOTKW, DCA TEMP /SAVE ADDR OF ROUTINE JMP I TEMP /GO PROCESS THE STMT KWGCH, 0 CDF 10 TAD I X10 /PICK UP WORD CDF TAD (200 /SEE IF IN RANGE 7600 TO 7777 CLL TAD (7600 /SET LINK IF NO JMP I KWGCH /RETURN WITH THE WORD PAGE /DIM PROCESSOR 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 I (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 I (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 < STRLIM CLL TAD (-STRLIM-1 SNL CLA JMP I CHKSDM /OK, SIZE < STRLIM DIMERR, JMS I QERMSG /GIVE ERROR DIMSG 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 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 Q70 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 NFMSG JMP I QREMARK UMOPR, 40;1;UMRTNE-1 XLOAD, FLDA;AFLDA PAGE STORE, JMS I QLODSN /OUTPUT STATEMENT NUMBER JMS I QEXPR /GET STRING JMP I QREMARK JMS I QLOAD /LOAD IT INTO SAC TAD TYPE1 /MAKE SURE IT IS A STRING SMA CLA JMS I QERMSG /IF NOT TYPE AN ERROR FN2MSG CLA TAD (XSTORE /OUTPUT OPCODE JMS I QOUTWRD JMP I QNEWLIN RECALL, JMS I QLODSN /OUTPUT STATEMENT NUMBER JMS I QEXPR /GET STRING JMP I QREMARK JMS I QLOAD /LOAD IT INTO SAC TAD TYPE1 /MAKE SURE IT IS A STRING SMA CLA JMS I QERMSG /IF NOT TYPE AN ERROR FN2MSG CLA TAD (XRECAL /OUTPUT OPCODE JMS I QOUTWRD JMP I QNEWLIN ONERR, JMS I QLODSN JMS I QSAVECP JMS I QCHKWD WGOTO JMP I (ONSNTX JMS I QCHECKC /CHECK NEXT CHARACTER FOR A 0 -60 SKP /NOT ON ERROR GOTO 0 JMP OFFERR JMS I QRESTCP TAD (XERROR JMS I QOUTWRD JMP I (CONTIN OFFERR, TAD (XOFERR JMS I QOUTWRD JMP I QNEWLIN RESUME, JMS I QLODSN JMS I QSAVECP JMS I QCHECKC -60 SKP /FKIP IF NOT RESUME 0 JMP RSUME0 JMS I QRESTCP TAD (XRESUME JMS I QOUTWRD JMP I (GOTO RSUME0, TAD (XRSUM0 JMS I QOUTWRD JMP I QNEWLIN TRAP, JMS I QLODSN /OUTPUT LINE NUMBER JMS I QMODSET /GO INTO NUMERIC MODE JMS I QEXPR /GET EXPRESION JMP I QREMARK JMS I QLOAD /LOAD IT INTO FAC TAD TYPE1 /IS IT NUMERIC SMA CLA JMP .+3 /YES CONTINUE JMS I QERMSG /NO, SO GIVE AN ERROR REPORT FRMSG CLL CLA TAD (XTRAP /GET OPCODE JMS I QOUTWRD /AND SAVE IT JMP I QNEWLIN /GET NEXT COMMAND /Error message reporter /CALL+1 = relative address of message text in error overlay /Since all errors are fatal, the temp file output buffer is /used for the overlay and compilation is aborted after first pass ERMSG, 0 /PRINT ERROR MESSAGE CDF 10 CLA CLL IAC RTL /AC = 4 TAD I (INFO+1 /GET BASE BLOCK OF BCOMP.SV DCA ERRBK /STORE INLINE CDF JMS I (7607 /READ OFF SYS: 0210 /2 PAGES TO FIELD 1 OUBUF /INTO OUTPUT BUFFER ERRBK, 0 /FROM HERE HLT /CRASH ON I/O ERROR CIF CDF 10 /JMP TO ERROR MESSAGE PRINTER JMS I (XERMSG ISZ ERMSG JMP I ERMSG /RETURN TO CALLER WEND, -105;-116;-104;0 WGOSUB, -107;-117;-123;-125;-102;0 SASIGN, 4000;XSTOR ASSIGN, 0;XSTOR WOPEN, -117;-120;-105;-116;0 UPAROW, 60;1;EXPRTN-1 STAR, 50;0;XMUL;XMUL XDIV, FDIV;AFDIV PLUS, 40;0;XADD;XADD PAGE /DEF PROCESSOR DEF, JMS I QNOREGS /FORGET REGS JMS I (TSTSTK /Test for no FOR's CLA CLL /TSTSTK may return with non-zero AC 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 have function (1000) and DIM (2000) bits on 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 /Bad arg list CLL CMA RAR /LOOK AT TYPE AND TYPE /Clear String bit, leave ARRAY and FUNCTION bits 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 I QSTCHEK /CHECK IT FUNNAM, 0 JMS I QLUKUP2 /LOOK UP FUNCTION FUNCTN -1 JMP OKFUN /OK, NOT MULTIPLY DEFINED BADDEF, JMS I QERMSG /BAD DEFINE DEMSG JMP I QREMARK OKFUN, TAD NEXT /SAVE "NEXT" DCA X12 CLA CLL IAC RTL /AC = 4 TAD NEXT /INCREMENT NEXT BY TAD ARGCNT /NUMBER OF ARGS plus four DCA NEXT JMS I (GENJMP /Generate the jump DCA JAROND /Save NEXT for later TAD (JUMP /Jump around the DEF JMS I (OUTJMP /Output it TAD LUFLD /SAVE FIELD OF FUN BLOCK DCA FUNFLD TAD LUFLD /ALSO FIELD OF LABEL DCA I (JARFLD TAD STACK /SAVE STACK DCA OLDSTK TAD ARGCNT CMA DCA TEMP /Create neg. arg count (-1) TAD ARGCNT CIA DCA ARGCNT /Get neg. Arg. count TAD ARGCNT /STORE COUNT FIRST JMP FUNFLD CHGARG, CDF JMS I QPOP /GET ARG TYPE DCA TYPE TAD TYPE JMS I QGENTMP /GENERATE A TEMPORARY JMS I QPOP /PURGE SYMBOL NUMBER 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 OLDSTK /RESTORE TO TOP DCA STACK TAD STACK /SAVE BOTTOM OF STACK DCA STKLVL /So the arg descriptors will stay TAD TMPCNT /Get temp counts DCA TMPLVL TAD STMPCT DCA STMPLV JMS I QCHECKC /FIND = -75 JMP I QNEWLIN /None there, make multi-line DEF JMS I QEXPR /COMPILE FUNCTION JMP I QREMARK JMS I QLOAD /GET IT INTO AC FNEND, TAD I (JARFLD /Is there a DEF pending? SZA CLA JMP I (RESARG /FINISH DEF JMS I QERMSG /FNEND without DEF FNEMSG JMP I QREMARK PAGE /DEF PROCESSOR (FINALE) RESARG, TAD (STACKA-1/RESTORE STACK DCA STKLVL /TO BOTTOM TAD STKLVL /Restore stack bottom DCA X13 /Set it here RESLP, 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 /Any more args to do? JMP RESLP /RESTORE NEXT TAD (RET /OUTPUT RETURN CODE JMS I QOUTWRD JARFLD, 0 /Initially set no DEF pending 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 DCA JARFLD /Clear DEF memory CDF 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 CMA /NEGATE AND INCLUDE SIZE WORD 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 DLSIZE /Increment negative size count and test for overflow CIA STL CIA /Force limit test to succeed for first entry TAD TEMP SNL SZA /Link must transition on above add JMP DATAOK /JMP if ok JMS I QERMSG /else give error TDMSG JMP I (ABORT /We must abort on this error DATAOK, DCA DLSIZE TAD (EOST /HOW MUCH DO WE NEED ? TAD TEMP DCA .+2 JMS I QSTCHEK /ASK FOR IT 0 TAD I (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 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 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 PAGE /FOR PROCESSOR FOR, JMS I QLODSN /OUTPUT STMT NUMBER JMS I QGETNAM /GET INDEX VARIABLE JMP I (BADFOR /BAD TAD TYPE /MUST BE NUMBER SZA CLA JMP I (BADFOR /ITS NOT JMS I QLOOKUP /ST SEARCH TAD SYMBOL /SAVE INDEX VAR DCA FINDEX /FOR LATER JMS I QCHECKC /FIND = -75 JMP I (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 I (BADFOR CLA JMS I QSAVECP /SAVE THIS POSITION JMS I QCHKWD /LOOK FOR "TO" WTO JMP FINDTO /KEEP GOING JMS I (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 I (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 I (BADFOR /YES, ERROR TAD FORNC /RESTORE CHAR POSITION DCA NCHARS /FROM SPECIAL PLACE TAD FORCP DCA CHRPTR JMS I (FSUB1 /COMPILE INITIAL VALUE INTO FAC JMS I QSTCHEK /CHECK FOR ROOM EOST TAD I (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 Q70 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 PAGE /IF AND IFEND PROCESSORS IF, JMS I QLODSN /OUTPUT STMT NUMBER JMS I QSAVECP /Save start of statement JMS I QCHKWD /Look for 'END' WEND SKP /Not there, try OPEN JMP IFEND /Compile an IF END JMS I QRESTCP /Restore pointer JMS I QCHKWD /Look for OPEN WOPEN JMP IFSTMT /It's a normal IF. IFOPEN, TAD (JFOPEN-JEOF IFEND, TAD (JEOF /SETUP CORRECT JUMP DCA RELOPR CLL CLA IAC RAL TAD RELOPR DCA RELOPI JMS I QLODSN /OUTPUT STMT NUMBER CLA IAC /(NO COLON) JMS I (GETFN /GET FILE NUMBER JMP NUMCMP /GO FIND "THEN" OR "GOTO" /Compile a normal IF statement IFSTMT, JMS I QRESTCP /Restore char pointer AC7776 /Set two pass flag for relationals DCA IFFLAG JMS I QEXPR /GET LEFT EXPRESSION JMP I QREMARK TAD (IFOPS-1/SETUP POINTER DCA X10 /To operator table JMS I QGETC /GET RELATIONAL OPERATOR JMP BADIF /ERROR IF NONE BSW /Move to left half DCA TEMP /AND SAVE IT JMS I QGETC /GET 2 CHAR RELATIONALS JMP BADIF IFLUP2, TAD TEMP /COMBINE THE 2 DCA TEMP2 IFLUP, TAD I X10 /GET JUMP OPCODE SMA /Should start with a negative number JMP CKZRO /Check for end of list DCA RELOPR /Is a relational TAD I X10 /Get the inverse operator DCA RELOPI JMP IFLUP /Get the operator string now CKZRO, SNA /Skip if not end of list JMP IFLUP1 /It's the end TAD TEMP2 /Check operator SZA CLA JMP IFLUP /No match! 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 "GOTO" WGOTO JMP NOGOTO /Not GOTO, try for THEN JMS I QSNUM /GET STATEMENT NUMBER JMP I (BADGO2 GOTIFN, TAD TEMP /OUTPUT JUMP TAD RELOPR JMS I QOUTWRD TAD TEMP2 /TWO WORDS JMS I QOUTWRD JMP I QNEWLIN NOGOTO, JMS I QRESTCP /BACKUP CHAR POS JMS I QCHKWD /LOOK FOR "THEN" WTHEN JMP BADIF /Oops! No THEN or GOTO! JMS I QGETC /Is anything there JMP BADIF /No error JMS I QBACK1 /Yes, restore pointer JMS I QSNUM /See if there is a statement number SKP /No statement number - compile statement JMP GOTIFN /There is, use the normal operator / /Create a pseudo-label for the failed IF jump / TAD IFJMP /Is there one already? SZA CLA /No, gen a new one JMP USEOLD /Yes, use it JMS I QSTCHEK /Check for symbol table room EOST-2 /Need two words JMS I (GENJMP /Generate the jump DCA IFJMP /Save the pointer TAD I (FREFLD /Plus the label field DCA I (IFFLD USEOLD, TAD RELOPI /Get operator JMS I (OUTJMP /Generate the jump instruction JMP I (CONTIN /Continue to compile the statement IFLUP1, JMS I QBACK1 /Back up over the second char ISZ IFFLAG /See if done both two and one char conditionals JMP IFLUP2 /Look for just the first character BADIF, JMS I QERMSG /BAD IF STMT IFMSG 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 RELOPR, 0 /Relational operator opcode RELOPI, 0 /Inverse relational operator IFFLAG, 0 /Set to -2 at init /Test the stack depth for a DEF instruction TSTSTK, 0 TAD STACK /Get the stack pointer TAD (-STACKA+1 SZA CLA JMS I QERMSG /Error out NDMSG JMP I TSTSTK /But continue REMRK1, JMS I QLODSN JMP I QREMARK PAGE /TABLE SEARCH FOR LITERALS, STMT NUMBERS, TEMPS, ETC. 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 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 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 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 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 /CHECK FOR ENOUGH ROOM STCHEK, 0 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 STMSG 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 KBDXIT /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 KBDXIT /NO, RETURN DCA I (TTX+1 /NOP TTY OUTPUT ROUTINE KBDXIT, KCC JMP I KBDCHK WSTEP, -123;-124;-105;-120;0 PAGE /SYMBOL TABLE LOOKUP LOOKUP, 0 /LOOK UP SYMBOL TAD TYPE /WHAT KIND SYMBOL ? CLL RTL /MOVE TYPE BITS RAL /INTO AC 10,11, Function bit to link TAD JTABLE DCA VCPTR /Save in temp SZL /Skip if not a function JMP I LOOKUP JMS I (NAMSRC /Get symbol index VCPTR, 0 /GO THERE JTABLE, JMP I .+1 LUVAR LUARAY LUSTRG LUSARY LUVAR, TAD (VARCNT /POINTER TO VAR COUNT DCA VCPTR TAD (VARST-1 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 JMP I LOOKUP JMP I (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-2 TAD NAME1 /TWO WORDS PER ENTRY JMP DOLU LUARAY, TAD (ACNT /ARRAY VAR COUNT DCA VCPTR TAD (ARAYST-4/ARRAY SYMBOL TABLE FINDA, TAD NAME1 /Finish building pointer DCA STPTR CDF 10 TAD I STPTR SNA CLA JMP NEWARY /New array ISZ STPTR /Point to symbol word 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-4/USE STRING ARRAY TABLE JMP FINDA /FILE AND CLOSE PROCESSORS FILE, JMS I QLODSN /OUTPUT STATEMENT 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 I QGETFN /GET FILE NUMBER JMS I QEXPR /GET DEVICE/FILE DESCRIPTOR JMP I QREMARK JMS I QTYPCK /Check if string JMP .+3 /It was FNMBAD, JMS I QERMSG /IT WEREN'T FN2MSG TAD I FILESW /GET CORRECT OPEN FILCOM, JMS I QOUTWRD JMS I (GRSIZE /GO GET RECORD SIZE (IF ANY) JMP I QNEWLIN FOPENS, OPENAF;OPENAV;OPENNF;OPENNV FILESW, 0 TYPCK, 0 JMS I QLOAD /Load to the FAC TAD TYPE1 /Get type word SPA CLA /Skip if numeric JMP I TYPCK ISZ TYPCK JMP I TYPCK /And return 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 PAGE /EXPRESSION ANALYZER 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 I (BADEXP /BAD SUB EXPRESSION JMS I QCHECKC /LOOK FOR ) -51 SKP /ERROR JMP OPR8R /GOTIT JMS I QERMSG /PARENTHESIS MIS MATCH MPMSG JMP I (BADEXP OPRAND, JMS I QBACK1 /PUT BACK NON UNARY OP JMS I QGETNAM /LOOK FOR VARIABLE REF JMP I (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 I (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 MOMSG JMP I (BADEXP MINUS, 40;0;XISUB;XSUB SLASH, 50;0;XIDIV;XDIV PAGE /EXPRESSION ANALYZER (HANDLE SUBSCRIPTS) FUNSS, AND Q1000 /IS IT FUN CALL ? SNA CLA JMP NOTFUN /NO JMS I QSAVAC /YES, SAVE AC -1 TAD LEFT /Check if we are on the left side SPA CLA /Skip if not JMP I (FNTEST /See if it is a DEF value being returned NOTFUN, 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 Q1000 SZA CLA JMP I (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 I (OPR8R /GO GET AN OPERATOR BADFSS, TAD (-4 /PURGE STACK JUNK TAD STACK DCA STACK JMS I QERMSG /PUT ERROR MESSAGE SSMSG 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 I (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 I (NEWVAR /IF NEW, GIVE IT NUMBER JMP ONSTAK /GO PUT IT ONTO THE STACK NOTNUM, JMS I QSTRING /LOOK FOR STRING LITERAL JMP I (MISARG /NO, MISSING ARG /RETURN WITH NUMBER OF WORDS OF 3 FOR 2 DATA CMA /NEGATE AND INCLUDE SIZE WORD DCA .+3 /FOR LOOKUP JMS I QLUKUP2 /LOOK UP LITERAL SLITRL 0 JMS I (NWSVAR /IF NEW, GIVE IT NUMBER CLL CML RAR /SET TYPE BIT FOR STRING JMP ONSTAK /PUT INFO ONTO STACK PAGE /EXPRESSION ANALYZER (HANDLE FUNCTION CALLS) DOCALL, JMS OUTCAL /GENERATE CALL JMP I (OPR8R /GO LOOK FOR OPERATOR BADFNR, JMS I QERMSG /BAD FUNCTION REFERENCE FRMSG JMP I (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 FNERR /UNDEFINED FUNCTION TAD SYMBOL /CHECK NUMBER OF ARGS TAD TEMP SZA CLA JMP FNERR 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 FNERR /(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 FNERR /NO, ERROR JMS I QMODSET /ALL CALLS IN N MODE TAD WORD1 /CHECK FOR USER FUNCTION SMA JMP CALLUF /YES, DO SPECIAL CALL FINCAL, 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 Q70 /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 FNERR, ISZ OUTCAL JMP I OUTCAL /Take the error return FSUB1, 0 /FOR SUBROUTINE #1 JMS I QEXPR /GET AN EXPRESSION JMP BADFOR JMS I QTYPCK /Check if numeric SKP /Skip if not JMP I FSUB1 /OK BADFOR, JMS I QERMSG /BAD FOR LOOP PARAMETERS FPMSG JMP I QREMARK FSUB2, 0 /FOR SUBROUTINE #2 JMS FSUB1 /GET EXPR AND LOAD IT JMS I QGENTMP /MAKE A TEMP FOR IT TAD SYMBOL /STORE EXPR IN TEMP TAD (FSTA JMS I QOUTWRD TAD SYMBOL /RETURN SLOT # JMP I FSUB2 /FORGET REGISTERS FUNNUM, NOREGS, 0 CLA IAC /FILE NUMBER REG DCA IFNREG / CMA /SUBSCRIPT REG #1 / DCA SSREG1 / CMA /SUBSCRIPT REG #2 / DCA SSREG2 JMP I NOREGS ONSNTX, JMS I QERMSG /Report ON GOTO/GOSUB syntax error ONMSG JMP I QREMARK /Flush the statement /CLOSE STATEMENT CLOSE, JMS I QLODSN /OUTPUT STMT NUMBER CLOSLP, CLA IAC /NO COLON NEEDED AFTER FILE NUM JMS I QGETFN /GET FILE NUM TAD (CLOSEF /OUTPUT CLOSE JMS I QOUTWRD JMS I QCHECKC /See if another file number -54 JMP I QNEWLIN /Jmp if no JMP CLOSLP /Else do another CLOSE PSETJF, 0 TAD (SETJF JMS I QOUTWRD JMS I QPOP /GET INDEX VAR DCA FINDEX JMP I PSETJF /RESTORE statement RESTOR, JMS I QLODSN /Output load statement number CLA IAC /No colon needed JMS I QGETFN /Get file number TAD (REST /Output restore opcode JMS I QOUTWRD JMP I QNEWLIN /Done PAGE /CODE GENERATOR 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 I (GETA1 /GET STUF FOR ARG1 TAD TYPE1 /LOOK AT IT AND Q400 SZA CLA JMP ACM /ITS CASE AC,M TAD TYPE2 /FORCE CORRECT MODE IN CASE OF STRING ARITH JMS I QMODSET /(A USELESS MODSET MAY BE OUTPUT-UGH!) TAD I CASEMM /ITS CASE M,M LOAD OPERAND 2 TAD SYMBL2 JMS I QOUTWRD SKP MAC, JMS I (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 TYPE1 /SEE IF STRING OPERAND SMA CLA JMP A1NUM /JMP IF NUMERIC TO BYPASS STRING ARITH CONVERT JMS I (SARCVT /ELSE CONVERT OPCODE IF +,-,* OR / CASEMA, 0 SYMBL1 /POINTER TO SYMBOL NUMBER FOR OPERAND 1 A1NUM, TAD I CASEMA /GET CORRECT INSTRUCTION IF NUMERIC OR NOT STRING ARITH TAD SYMBL1 /PLUS SYMBOL NUMBER OUTIT, JMS I QOUTWRD /OUTPUT IT TYPCHK, 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 TYPE2 /SEE IF OPERAND 2 STRING SMA CLA JMP ACMNUM /NO, PROCESS NORMALLY JMS I (SARCVT /YES, DO STRING OPCODE CONVERT IF NECESSARY CASEAM, 0 /POINTER TO CODE SKELETON FOR AC,M CASE SYMBL2 /POINTER TO OPERAND 2 ADDR ACMNUM, TAD I CASEAM /ITS CASE AC,M TAD SYMBL2 /GEN OPERATION FOR OPERAND 2 JMP OUTIT /GO FINISH IT UP MIXED, JMS I QERMSG /MIXED TYPES MTMSG 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 UMRTNE, JMS I QSAVAC /SAVE CURRENT AC IF NEEDED -3 JMS I QTYPCK /Get and check argument SKP /Skip if string JMP NUMUMI /JMP IF NUMERIC UNARY MINUS CLA STL RAR /SET UP FOR STRING UNARY MINUS DCA TYPE TAD TYPE DCA TYPE2 TAD (SNEG /NOW OUTPUT STRING NEGATE JMP OUTIT NUMUMI, DCA TYPE /TYPE MUST BE NUMERIC DCA TYPE2 TAD (FNEG /DO NEGATE JMP OUTIT EXPRTN, DCA TYPE /SET FUNC TYPE CLL CML RTL /SET NUMBER OF ARGS DCA TEMP TAD (FUNC1+60 DCA SYMBOL /EXP2 JMS I (OUTCAL /OUTPUT FUNCTION CALL JMP I OUTOPR /DONE JMP MIXED /ERROR CASEMM, 0 TYPE2, 0 SYMBL2, 0 PAGE /LETTER AND DIGIT SCANNERS /SKIP ON LETTER LETTER, 0 JMS I QGETC JMP I LETTER /NO LETTER TAD (-133 /MUST BE .LT. 133 STL TAD (133-100 /MUST BE .GT. 100 SZA SNL ISZ LETTER /BUMP RETURN IF IN RANGE, AC=6 BIT CHAR SNA SZL JMS I QBACK1 /RESET SCAN PTR IF OUT OF RANGE JMP I LETTER /RETURN /SKIP ON DIGIT DIGIT, 0 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 SZL ISZ DIGIT /RETURN DIGIT MINUS 60 SNL 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 SNA /SKP IF NON LEADING ZERO JMP .-3 /ELSE IGNORE, (LINE NUMBER ZERO PROHIBITED) 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 Q70 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 MDMSG JMP I SNUM /CONVERT TO ASCII AND PRINT TTY, 0 TAD (240 AND (77 TAD (240 /EXPAND TO 7BIT JMS TTX /PRINT CHAR JMP I TTY /RETURN /PRINT CHAR ON TTY TTX, 0 SKP /(CONTROL O ZEROES THIS WORD) JMP .+4 /(THUS KILLING ERROR REPORTING) TLS TSF JMP .-1 CLA JMP I TTX /CHAIN PROCESSOR CHAIN, JMS I QLODSN /OUTPUT STMT NUMBER JMS I QEXPR /GET CHAIN STRING JMP I QREMARK JMS I QTYPCK /Get arg, check type JMP CARGOK /It was string JMS I QERMSG /IT WASN'T FN2MSG /(OK IF ERROR CODE IS NOP) CARGOK, TAD (CHN /OUTPUT CHAIN OPCODE JMS I QOUTWRD JMP I QNEWLIN XISUB, FISUB;AISUB WGOTO, -107;-117 WTO, -124;-117 0 PAGE /SEVERAL SHORT UTILITY ROUTINES /BACK UP 1 CHAR BACK1, 0 CLA CMA TAD NCHARS DCA NCHARS CLA CMA TAD CHRPTR DCA CHRPTR JMP I BACK1 /GET A CHAR PRESERVING BLANKS GETCWB, 0 ISZ NCHARS JMP .+4 CLA CMA DCA NCHARS /RESET NCHARS JMP I GETCWB ISZ GETCWB CDF 10 TAD I CHRPTR /GET THE CHAR CDF 0 JMP I GETCWB /SAVE CHAR POSITION SAVECP, 0 TAD NCHARS DCA NCSAVE TAD CHRPTR DCA CPSAVE JMP I SAVECP /RESTORE CHAR POSITION RESTCP, 0 TAD CPSAVE DCA CHRPTR TAD NCSAVE DCA NCHARS JMP I RESTCP /GET A CHARACTER IGNORING BLANKS AND TABS /CONVERTS LOWER CASE TO UPPER CASE GETC, 0 JMS GETCWB /Get a character JMP I GETC /None there TAD (-41 /IS IT ! SNA /SKP IF NO JMP GETCX /ELSE TREAT AS END OF LINE IAC /IS IT BLANK SZA /SKP IF BLANK TAD (40-11 /TRY TAB INSTEAD SNA JMP GETC+1 /YES IGNORE IT TAD (11-173 /NOW SEE IF LOWER CASE CLL TAD (32 SZL /SKP IF NOT LOWER CASE TAD (-40 /ELSE CONVERT TO UPPER CASE TAD (173-32 /NOW RESTORE CHARACTER ISZ GETC JMP I GETC GETCX, STA DCA NCHARS /End of the line JMP I GETC /GET TOP OF STACK POP, 0 CLA CLL /Clear any stack trash TAD STACK DCA PUSH CLA CMA TAD STACK DCA STACK /DECREMENT STACK POINTER TAD I PUSH JMP I POP /PUT AC ONTO STACK PUSH, 0 DCA I STACK /STORE TAD (-STACKA-STAKSZ+1 TAD STACK /CHECK FOR OVERFLOW SPA CLA JMP I PUSH /OK, RETURN STKOVR, JMS I QERMSG PDMSG JMP I XABORT /ABORT COMPILATION PUSHO, 0 /PUSH OPERAND STACK DCA I OSTACK /PUSHIT TAD (-STACKO-STAKSZ+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 WPNT, -120;-116;-124;-50;0 NCSAVE, 0 CPSAVE, 0 PAGE /TEMP GENERATORS AND AC SAVING ROUTINES 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 I (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 I (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 SSMSG 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 /MULTIPLY FAC BY 10. MPY10, 0 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 JMP I MPY10 /--RETURN-- XSCOMP, SCOMP;SACOMP PAGE /NUMERIC CONVERSION ROUTINE (PART ONE) NUMBER, 0 /GENERAL NUMBER CONVERSION ROUTINE DCA DECPT /ZERO DECIMAL POINT SWITCH DCA WORD1 /ZERO FAC DCA WORD2 DCA WORD3 DCA ACO DCA TRLDIG /CLEAR COUNT OF EXCESS DIGITS TO LEFT OF DP DCA SIGN /CLEAR SIGN SWITCH JMS I QGETC /GET A CHAR JMP I NUMBER /NO CHAR IS NO NUMBER JMS I (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 TAD WORD2 /SEE IF NEXT DIGIT WILL FIT IN REGISTER TAD (-304 /WILL FIT IF HIGH WORD LT 2048/10 = 204 SPA CLA /SKP IF NO FIT JMP DGFITS TAD DECPT /COUNT DIGIT IF DECIMAL POINT NOT SEEN YET SNA CLA ISZ TRLDIG JMP CONVLP /BUT IGNORE DIGIT OTHERWISE DGFITS, ISZ NDIGIT /INCR NUMBER OF DIGITS JMS I (MPY10 /MULT 35 BIT REGISTER BY 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 (-105 /COMPARE TO "E" SZA CLA JMP NOEXP /NO EXPONENT DCA ESIGN /ZERO EXPONENT SIGN SWITCH JMS I QGETC /GET A CHAR JMP NOEXP /TREAT AS NO EXPONENT JMS I (CHKSGN /IS IT A SIGN ESIGN, 0 /THIS IS THE SWITCH TO SET JMS I (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 TAD TRLDIG /ADD COUNT OF EXCESS DIGITS LEFT OF DP SMA JMP POSEXP /EXPONENT IS POSITIVE CIA DCA EXPON /ONLY NEED ABS VALUE TAD (FINV10-1 /DO INVERSE POWERS OF 10 JMP .+3 POSEXP, DCA EXPON TAD (F10-1 /USE POWERS OF TEN DCA X11 /POINT AT 4 WORD FLOATING POINT VALUES TAD (-6 /INITIAL EXPONENT SKP NEWEXP, STA /DROP DOWN TO UNITY POWER OF 10 DCA TEMP2 TAD I X11 /GET THE MULTIPLIER DCA OP1 TAD I X11 DCA OP2 TAD I X11 DCA OP3 TAD I X11 DCA OPO EXPMUL, TAD EXPON /SEE IF DECIMAL EXPONENT REDUCED TO ZERO SNA JMP DOSIGN /YES, ROUNDOFF AND SET SIGN TAD TEMP2 /NO, REDUCE IT SPA /SKP IF NOT NEAR ZERO YET JMP NEWEXP /ELSE REDUCE TO 1E1 OR 1E-1 DCA EXPON /UPDATE DECIMAL EXP JMS I (FPMUL /DO 36 BIT MULTIPLY AND NORMALIZE JMP EXPMUL /TRY AGAIN DOSIGN, JMS I (ROUND /NOW ROUND TO 23 BITS TAD SIGN /CHECK THE SIGN SZA CLA JMS I (NEGFAC /NEGATE IF NEGATIVE ISZ NUMBER /BUMP RETURN JMP I NUMBER /RETURN PAGE /NUMERIC CONVERSION ROUTINE (PART TWO) FPMUL, 0 /FLOATING MULTIPLY ROUTINE TAD WORD1 /COMPUTE NEW EXPONENT TAD OP1 DCA WD1SAV TAD WORD2 /SAVE AC MANTISSA DCA TW2 TAD WORD3 DCA TW3 TAD ACO DCA TWO TAD (-44 /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 TAD TWO RAR DCA TWO SZL JMS OADD /ADD IF LINK IS ONE ISZ ITRCNT /BUMP COUNT JMP MULLUP /LOOP TAD WD1SAV /PUT IN CORRECT EXPONENT DCA WORD1 JMS ANORM /NORMALIZE THE RESULT JMP I FPMUL WD1SAV, 0 TW2, 0 TW3, 0 TWO, 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 ROUND, 0 TAD ACO /SEE IF BIT 24 SET SMA CLA JMP RNDXIT /NO, EXIT ISZ WORD3 /PROPAGATE TO LOW WORD JMP RNDXIT ISZ WORD2 TAD WORD2 /SEE IF CARRY OUT OF NORMALIZE BIT SPA CLA JMS I (AR1 /YES, ADJUST RIGHT RNDXIT, DCA ACO /CLEAR OVERFLOW JMP I ROUND /--RETURN-- 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 F10, 24;3641;1000;0 /10^6 4;2400;0;0 /10^1 FINV10, -23;2061;5736;4055 /10^-6 -03;3146;3146;3146 /10^-1 PAGE /NUMERIC CONVERSION ROUTINE (FINALE) 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 JMS I QCHECKC /LOOK FOR " M42, -42 JMP I STRING /NONE MEANS NO STRING ISZ STRING DCA WORD1 /ZERO CHAR COUNT TAD (WORD2-1 /SETUP POINTER DCA TEMP TAD (-STRLIM%3 /AND MAX SIZE DCA TEMP2 SLOOP, JMS GCS /GET HIGH ORDER CHAR ISZ TEMP /TALLY ANOTHER WORD USED DCA I TEMP /STORE CHAR TAD TEMP /SAVE POINTER TO WORD 1 DCA STMP JMS GCS /GET ANOTHER CHAR ISZ TEMP /TALLY ANOTHER WORD DCA I TEMP /STORE LOW 7 BITS JMS GCS /GET ANOTHER CHAR DCA GCS /SAVE IT TAD GCS CLL RTL /SHIFT UP RTL AND (7400 /MASK TAD I STMP /ADD TO PREV WORD AND STORE DCA I STMP TAD GCS /GET LOW NIBBLE AND STORE CLL RTR RTR RAR AND (7400 TAD I TEMP DCA I TEMP ISZ TEMP2 /TEST BUFFER LIMIT JMP SLOOP /JMP IF MORE ROOM JMS I QGETC /MAX SIZE STRING MUST HAVE " TERMINATING JMP STRGER /ERROR TAD M42 /TEST IF " SNA CLA JMP STROUT /OK, RETURN STRGER, JMS I QERMSG /STRING ERROR QSMSG JMP I QREMARK /FLUSH REST OF STATEMENT STROUT, TAD TEMP /RETURN NUMBER OF WORDS REQUIRED FOR STRING TAD (-WORD2+1 JMP I STRING STMP, 0 /GET A CHAR FOR STRING GCS, 0 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 STROUT /NO, THAT WAS IT TAD M42 /LOOK FOR SECOND " SNA CLA JMP NOTQOT /"" BECOMES " JMS I QBACK1 /PUT IT BACK JMP STROUT /LITERAL IS DONE NOTQOT, TAD (42 /RECREATE CHAR ISZ WORD1 /BUMP STRING COUNT JMP I GCS XIDIV, FIDIV;AIDIV XMUL, FMPY;AFMPY XADD, FADD;AFADD SCOMPR, 3;SCRTN-3;4000;XSCOMP;XSCOMP PAGE /Look for variable name or function reference GETNAM, 0 DCA NAME1 /Initialize name storage to nulls DCA NAME2 DCA NAME3 DCA NAME4 TAD (NAM1 /Initialize the storage co-routine pointer DCA NAMCOR TAD (NAME1 /Set initial name storage pointer DCA NAMPTR DCA TYPE /Set initially null type JMS I QLETTER /The first character must be a letter JMP I GETNAM /Not a name NAMLP, JMS NAMSTO /Store the first character JMS I QGETCWB /Get the next character JMP FUNSRC /No more! TAD (-11 /Is it a TAB? SNA JMP FUNSRC /Yes, end of name TAD (11-40 /Check for space SNA JMP FUNSRC /Yes, end of name TAD (40-137 /Is it an underscore? SNA JMP UNSCOR /Yes, use it TAD (137-56 /Is it a period? SZA CLA /Skip if so, use it JMP CKLETR /No, check if it is a letter TAD (56-37 /Use a period UNSCOR, TAD (37 /Use an underscore JMP NAMLP /Store it CKLETR, JMS I QBACK1 /Back up over the letter again JMS I QLETTER /Is the next character a letter SKP /No, check for digit JMP NAMLP /Get the next JMS I QDIGIT /Is it a digit? JMP FUNSRC /No, must be end. Search functions TAD (60 /Restore the digit JMP NAMLP /And store it NAMPTR, 0 /Search for a function with this name FUNSRC, TAD NAME1 /Is the name a user function? (FNx) TAD (-616 /FN SNA CLA JMP USRFUN /Yes, check next for function TAD (FUNS-1 /Scan function name table DCA X10 CDF 10 /Field of keyword tables FUNLP, TAD I X10 /Get first two characters SNA JMP LFDOLR /End of function list, must be a name TAD NAME1 SZA CLA JMP NOMATC /No name match TAD I X10 /Check next two TAD NAME2 /Against two of name SZA CLA JMP NOMATC+1 /No match TAD I X10 /Get the function code FUNOK, DCA SYMBOL /Store the function type code TAD Q1000 /Set function type bit DCA TYPE JMP LFDOLR /Look for $ or (. NOMATC, ISZ X10 /Skip past third char ISZ X10 /Skip past function code JMP FUNLP /Try next function name USRFUN, JMS I (NAMSRC /Search for the name 6200 /In the function name table TAD NAME1 /Get the symbol number JMP FUNOK /Store it /Check for $ (string) or parenthesis (array) LFDOLR, CDF /Restore to compiler field ISZ GETNAM /Got a name OK JMS I QGETC /Get the next char JMP I GETNAM /No more characters in line TAD (-44 /Is it a $ ? SZA JMP NOSTRG /No, not a string CLL CML RAR /Set string flag TAD TYPE DCA TYPE JMS I QGETC /Get next char, to check for ( JMP I GETNAM /No more there TAD (-44 /Preset for test below NOSTRG, TAD (44-50 /Check for ( (array) SNA CLA CLL CML RTR /Yes, set array bit SNA JMS I QBACK1 /If not, back up to the char TAD TYPE /Perhaps set array bit DCA TYPE JMP I GETNAM /All done decoding name /Store name characters NAMSTO, 0 /Store name characters JMP I NAMCOR /Call the name coroutine NAMCOR, NAM1 JMP I NAMSTO /Return to caller NAM1, BSW /Put into high byte DCA I NAMPTR /Store in name array JMS NAMCOR /Return, setup next TAD I NAMPTR /Get high character too DCA I NAMPTR /Store them away ISZ NAMPTR /Point to next word JMS NAMCOR /Return, setup loop JMP NAM1 /To go to first /Test function reference for validity /If valid, load the result to the proper AC FNTEST, TAD I (JARFLD /Are we doing a DEF? SNA CLA JMP I (BADFNR /No, we lose. JMS I QCHECKC /Check for equals as next char -75 JMP I (BADFNR /Nope, bad reference JMS I QEXPR /Get the expression for the right side JMP I (BADFNR /Badness JMS I QLOAD /Load the expression to the FAC JMP I QNEWLIN /Done compiling PAGE /LET STATEMENT PROCESSOR LET, JMS I QGETC /SEE IF ANYTHING IN LINE JMP I QREMARK /IGNORE LINE IF NO JMS I QBACK1 /OK, PUT BACK CHARACTER JMS I QLODSN /LOAD THE STMT NUMBER CLL CML RAR /COMPILE LEFT SIDE JMS I QEXPR /GET EXPRESSION JMP I QREMARK JMS I QCHECKC /LOOK FOR = -75 JMP BADLET /BAD IF MISSING JMS I QEXPR /GET RIGHT SIDE JMP I QREMARK 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 I QNEWLIN BADLET, JMS I QERMSG /BAD LET STMT LSMSG JMP I QREMARK /INPUT statement INPUT, JMS I QLODSN /OUTPUT STMT NUM JMS I QGETFN /LOOK FOR #: INPUTL, JMS I QSAVECP /Save the character position JMS I QGETNAM /Do we start with a name? JMP CKSTR /No, check for a string JMS I QRESTCP /Back up to it JMS I QEXPR /Get the expression JMP I QREMARK /This should not happen! JMS I QGETA1 /Get the top of the stack TAD TYPE1 /Check if it is a function CLL RAL /String bit to link AND (1000 /Check if it is a function SZA CLA JMP PRTFN /'Print' this function SZL CLA /Skip if string bit is clear JMP RSTRNG /It's a string read JMS I QMODSET /Set AMODE CLL CML RTR /Check the dimension bit AND TYPE1 SZA CLA JMP DIMREAD /Yes, it's dimensioned TAD (READ /Output a READ command JMS I QOUTWRD TAD (FSTA /USE SCALAR STORE FININP, TAD SYMBL1 /PLUS SYMBOL NUMBER JMS I QOUTWRD /OUTPUT INSTR CKCOMA, JMS I QCHECKC /LOOK FOR , -54 JMP CKSEMI /None, check semicolon 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 DIMREA, JMS I QLOADSS TAD (READ JMS I QOUTWRD TAD (AFSTA JMP FININP CKSTR, JMS I QCHECKC /Check for a quote -42 /Quote character JMP I QREMARK /Nope, bad INPUT argument PRTFN, JMS I QRESTCP /Restore the character position JMS I QEXPR /Get the expression again ONTEMP, HLT /QEXPR must skip; the string or function is there. CLL CML RAR /Set SMODE JMS I QMODSET JMS I QLOAD /Get the thing TAD (SWRITE /Write a string function JMS I QOUTWRD /Output the command JMP CKCOMA /Look for comma or semicolon CKSEMI, JMS I QCHECKC /Check for semicolon -73 JMP I QNEWLIN /End of command line JMP INPUTL /Get another token /ON GOTO or GOSUB l1,l2,l3,... /This statement emits the expression followed by a prefix opcode /A list of GOTO or GOSUB opcode/address pairs follows for each /line number, terminated by a zero pair. Runtime scans this vector /for the branch addr. ONGO, JMS I QLODSN JMS I QMODSET /be sure interpreter is in NMODE JMS I QEXPR /Compile JMP I QREMARK /No expression JMS I QTYPCK /Check for numeric arg JMP I (ONSNTX /Jmp if no, syntax error TAD (ONPFX /Emit ON prefix opcode JMS I QOUTWRD JMS I QSAVECP /Save scan pointer JMS I QCHKWD /See if GOSUB WGOSUB SKP /Skp if no JMP ONGOSU /Jmp if yes JMS I QRESTCP /Reset scan pointer JMS I QCHKWD /See if GOTO WGOTO JMP I (ONSNTX /Jmp if neither IAC /JUMP = GOSUB+1 ONGOSUB,TAD (JSUB DCA ONTEMP /Save the branch opcode ONLUP, JMS I QSNUM /Get a line number JMP I (ONSNTX /Syntax error if none TAD TEMP /Make branch opcode TAD ONTEMP JMS I QOUTWRD /Emit it TAD TEMP2 /Emit the addr too JMS I QOUTWRD JMS I QCHECKC /See if , -54 SKP /No, finish off JMP ONLUP /Else get next line number JMS I QOUTWRD /Now mark end of vector JMP I QNEWLIN /Done PAGE /INPUT DEVICE HANDLER *INDEVH NAMLST, BCOMPN /SAVE FILE NAME-POINTER LIST BLOADN BRTSN BOVN 0 BASICN, FILENAME BASIC.SV /FILE NAMES BCOMPN, FILENAME BCOMP.SV /FOR LOOKUPS BLOADN, FILENAME BLOAD.SV BRTSN, FILENAME BRTS.SV BOVN, FILENAME BASIC.OV TMPFIL, FILENAME BASIC.TM VTEXT, 15;12;"B;"C;"O;"M;"P " ;"V;"e;"r;"s;"i;"o;"n;40 VERLOC, VERSON;PATCH;15;12;0 VERNUM, 0 TAD (VTEXT DCA TEMP TLS /Set printer flag MOREV, TAD I TEMP /Get a char SNA JMP VERWT /No more to do JMS I (TTX /Print it ISZ TEMP /Point to next JMP MOREV VERWT, NOP /NOP'D FOR VT278 NOP /NOP'D FOR VT278 JMP I VERNUM PAGE /INITIALIZATION CODE FOR RUN CASE RUNNED, CIF 10 /COME HERE IF .R BCOMP JMS I (200 /CALL COMMAND DECODER 5 0201 /ASSUMED EXTENSION "BA" RUNGO, CDF 10 TAD I (CDOPT4 /TEST FOR /V CDF AND (4 SZA CLA JMS I (VERNUM TAD (INFO-1 DCA X10 CDF 10 TAD I (7617 CDF SNA CLA /NULL INPUT? JMP RUNNED /YES: NAUGHTY TAD I (BIPCCL CLL RAL /BATCH RUNNING SPA CLA JMP SAVBOS /YES CDF 10 JMP ZEREDT /GO ZERO EDITOR BLOCK NUMBER SAVBOS, TAD (INFO-5 DCA X10 TAD I (BIPCCL AND Q70 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 ZEREDT, DCA I X10 /ZERO EDITOR BLOCK NUMBER CDF FINDSV, TAD I X11 /LOOKUP SOME SAVE FILES SNA JMP LUBUF /GO CREATE TEMP FILE DCA XXXXSV /SAVE POINTER TO NAME CLA IAC /THEY'RE ON SYS CIF 10 JMS I (200 2 XXXXSV, 0 0 JMP I (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 /REMOVED BASIC.UF LOOKUP CDF 10 DCA I X10 DCA I X10 /CLEAR UNUSED WORDS DCA I X10 STRT3, CDF CLA IAC /ENTER TEMPORARY FILE CIF 10 JMS I (200 3 TMPBLK, TMPFIL 0 JMP I (NG TAD TMPBLK /SAVE START OF TEMP FILE DCA I (OUBLOK TAD TMPBLK /IN A COUPLE PLACES DCA BLOCK TAD TMPBLK+1/ALSO THE SIZE DCA I (OUSIZE JMP I (GETDEV /GO FETCH DEVICE HANDLER BRTCHN, CIF 10 /DO A RESET ON CHAIN FROM BRTS JMS I (200 /TO FORGET ANY UNCLOSED FILES 13 /RESET JMP STRT3 /GO ENTER TEMPORARY FILE BOSCTR, 7774 PAGE /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 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 TAD I QERMSG /SEE IF ANY ERRORS SO FAR SZA CLA /SKP IF NONE JMP I OUDUMP /ELSE QUICKLY EXIT 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 OFMSG 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 I (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 I (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 /GOTO AND GOSUB AND EXIT EXIT, JMS I QLODSN /GET A LINE NUMBER TAD (XEXIT /GET OPCODE JMS I QOUTWRD /WRITE IT 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 NMMSG /NUMBER MISSING JMP I QREMARK /STRING ARITHMETIC PREFIX AND SUB-OPCODES SARTAB, -XADD-1;0 -XSUB-1;1 -XISUB-1;2 -XMUL-1;3 -XDIV-1;4 -XIDIV-1;5 0 /MARK END OF TABLE PAGE /WORD CHECKER CHKWD, 0 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 /END STATEMENT END, TAD (STOP /OUTPUT STOP OPCODE JMS I QOUTWRD TAD I (OUDUMP /SKP IF NO TEMP FILE WRITES WERE DONE SZA CLA JMS I (OUDUMP /DUMP BUFFER TAD I (OUDUMP /PASS FLAG TO BLOAD DCA OUTFLG TAD I (FREFLD /ALSO PASS HIGHEST S.T. CDF USED DCA THSFLD /'NEXT' CONTAINS THE HIGHEST ADDRESS TAD I QERMSG /SEE IF ANY PASS 1 ERRORS SZA CLA /SKP IF NONE JMP ABORT /ELSE ABORT COMPILATION /NECESSARY SINCE ERROR MESSAGE OVERLAY CLOBBERS OUBUF TAD STACK /Crock to fix stack for BLOAD TAD (7120-STACKA DCA STACK JMS I (7607 /READ IN POST PROCESSOR BLDSZ0 /THIS MUCH POSTX, 400 /FROM 400 LDRBLK, 0 /FROM THIS BLOCK JMP I XABORT / TAD I QERMSG /SET POST PROCESSOR ERROR SWITCH / DCA I (ERMSG2 JMP I POSTX /START IT UP /HANDLE END OF FILE ENDFIL, TAD TEMP3 /TEST IF FILE ENDED CLEANLY TAD (LINMAX SNA CLA /SKP IF EXTRA CHARS AT END OF FILE JMP END /ELSE ALLOW LACK OF END STATEMENT JMS I QERMSG /INPUT FILE ERROR MEMSG ABORT, TAD (4207 /RESTORE ^C LOCZTIONS DCA I (7600 TAD (6213 DCA I (7605 CDF 10 TAD I (INFO /GET START OF BASIC.SV CDF SNA JMP I (7605 /T'WERE RUNNED DCA EDTBLK /SAVE MAGICAL BLOCK NUMBER JMS I (7607 /USE SYS HANDLER EDTSIZ /TO READ IN THIS MUCH 0 /INTO ZERO EDTBLK, 0 /FROM HERE HLT /HALT IF BAD READ JMP I (EDTBGN /GO RESTART EDITOR /SET INTERPRETER MODE MODSET, 0 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 CLA CLL CML RAR TAD MODE /CHANGE THE SWITCH DCA MODE JMP I MODSET /AND RETURN /ROUTINE TO GET RECORD SIZE IN FILE STMT GRSIZE, 0 JMS I QCHECKC /SEE IF , -54 JMP I GRSIZE /NO, RETURN JMS I QEXPR /OK, GET EXPRESSION JMP I GRSIZE JMS I QTYPCK /Check for numeric arg JMS I QERMSG /ERROR IF NOT REMSG CLA CLL /Clear out the AC TAD (RECSIZ /EMIT RECSIZE OPCODE JMS I QOUTWRD JMP I GRSIZE /DONE /IF statement operator table / /Organized as Jump code for operator, Inverse jump code, chars for operator IFOPS, /First, the two-character operators JNE;JEQ;-7476;-7674 /<> JGE;JLT;-7576;-7675 /=> JLE;JGT;-7574;-7475 /=< 0 /Now, the one-character operators JEQ;JNE;-7500 /= JGT;JLE;-7600 /> JLT;JGE;-7400 /< 0 PAGE /ROUTINE TO CONVERT ARITHMETIC OPCODES TO /STRING ARITHMETIC PREFIX AND OPCODE /CALLED IF TYPE OF OPERAND IS STRING SARCVT, 0 TAD I SARCVT /PICK UP ADDR OF SKELETON IN CALL+1 ISZ SARCVT DCA SARCAS /STORE POINTER TO IT TAD I SARCVT /NOW GET POINTER TO SYMBOL ISZ SARCVT DCA SARSYM /SAVE IT TAD (SARTAB-2 /SEE IF SKELETON IS MEMBER OF +,-,*,/ SET DCA X10 SRCHL, ISZ X10 /SKIP OVER STRING SUB OPCODE TAD I X10 /GET SKELETON TO COMPARE TO SNA JMP I SARCVT /RETURN AND PROCESS NORMALLY IF END OF LIST TAD SARCAS /COMPARE TO SKELETON POINTER SNA JMP SARARY /IF EQUAL, ITS AN ARRAY OPCODE IAC /ELSE SEE IF ITS SCALAR SZA CLA /SKP IF YES JMP SRCHL /ELSE TRY AGAIN TAD (SARITH-ASARITH /OUTPUT SCALAR PREFIX OPCODE SARARY, TAD (ASARITH /OUTPUT ARRAY PREFIX TAD I SARSYM /ADD IN THE SYMBOL NUMBER DCA SARSYM /HOLD IT CLA STL RAR /NOW FORCE STRING MODE JMS I QMODSET TAD SARSYM /GET OPCODE AGAIN JMS I QOUTWRD /OUT IT TAD I X10 /NOW OUTPUT THE SUB OPCODE JMS I QOUTWRD CLA STL RAR /CONVERT TYPE OF OPCODE TO STRING NOW TAD TYPE DCA TYPE SZL /***CONSISTANCY TEST*** HLT /CRASH SYSTEM JMP I (TYPCHK /NOW TEST CONSISTANCY OF OPERAND TYPES SARCAS, 0 SARSYM, 0 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 /Symbol name table search routine /Returns index to symbol tables NAMSRC, 0 CLA IAC DCA INDEX /Init name index TAD TYPE /Point to the symbol table DCA X10 /Point to name table NAMDF, HLT /Field of name table TAD I TYPE /Get symbol count CMA DCA NAMCNT /Save search counter SEARCH, ISZ NAMCNT /Done table yet? SKP /Nope, search it. JMP NEW /Yes, create a new entry TAD I X10 /Get name word TAD NAME1 /Compare to first name SZA CLA JMP NM1 /No match TAD I X10 /Get next name word TAD NAME2 SZA CLA JMP NM2 /No match TAD I X10 TAD NAME3 SZA CLA JMP NM3 /No match TAD I X10 /Last name words TAD NAME4 SZA CLA JMP NEX /No match, try next SEXIT, TAD TYPE /Check symbol type CLL RTL /Array bit to link CLA TAD INDEX /Match! Return index SZL /Skip if not an array CLL RTL /If it is, multiply by four DCA WORD1 /In proper place CDF 0 /Restore data field JMP I NAMSRC NM1, ISZ X10 /Skip to next name NM2, ISZ X10 NM3, ISZ X10 NEX, ISZ INDEX /Use next name index JMP SEARCH /No, check next NEW, TAD NAME1 /Set the name CIA DCA I X10 /Store it's negative TAD NAME2 CIA DCA I X10 TAD NAME3 CIA DCA I X10 TAD NAME4 CIA DCA I X10 ISZ I TYPE /Increment the name count JMP SEXIT /Return the new index INDEX, 0 NAMCNT, 0 AMPSND, 40;1;AMPRTN-1;4000;SCONTS;SCONTS SCONTS, SCON;SACON PAGE /INITIALIZATION CODE CHAINED,TAD (INFO+7 /PICK UP SOME STUFF DCA X10 CDF 10 /FROM THE INFO BLOCK TAD I X10 /SEE IF START OF TEMP FILE HERE SNA /SKP IF HAVE TEMP FILE JMP I (RUNGO /ELSE MUST BE CHAIN FROM CCL DCA BLOCK TAD I X10 /SIZE OF HOLE CDF DCA I (OUSIZE TAD BLOCK DCA I (OUBLOK CDF 10 TAD I X10 /ENTRY ADDR OF HANDLER DCA HADDR /PASS HANDLER FROM EDITOR AS IF A FETCH JMP CLOBBER GETDEV, CDF 10 TAD I (7617 /GET DEVICE NUM FOR INPUT FILE CDF CIF 10 JMS I (200 /GO FETCH THE DEVICE 1 HADDR, INDEVH+1 /2 PAGE HANDLER IS OK JMP NG /ERROR CIF 10 JMS I (200 /RESET SYSTEM TABLES 13 /DELETING TENTATIVE FILES CDF 10 CLOBBER,TAD I IOAD1 /CLOBBER THE USR NOW DCA I IOAD2 ISZ IOAD1 ISZ IOAD2 ISZ IOCTR JMP CLOBBER TAD I (7617 /SET UP INPUT FILE PARAMS CDF AND (7760 /GET SIZE TAD (17 CLL CML RTR RTR CDF 10 /INPUT ROUTINE IS IN FIELD 1 DCA I (INCTR TAD HADDR DCA I (INHNDL /NOW PASS HANDLER ENTRY ADDR TAD I (7620 /GET BLOCK NUMBER DCA I (INREC TAD I (INFO+3 /GET START OF BRTS.SV (+1) DCA BRTS TAD I (INFO /GET START OF BASIC.SV (+1) DCA ABORTX /BOTH FOR BLOAD TAD I (INFO+2 /GET START OF BLOAD.SV CDF DCA I (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 INICDF, CDF TAD JABORT /MODIFY ^C LOCATIONS DCA I (7600 TAD JABORT DCA I (7605 JMS I (CORE /GET CORE SIZE CDF TAD HIFLD /Set symbol table field CLL RTL;RAL TAD INICDF DCA I (NAMDF /To the highest field in the machine TAD I (NAMDF /Set that field DCA .+1 HLT DCA I (0 /Init the Variable symbol table, DCA I (2000 /The array table, DCA I (4000 /The String table, DCA I (6000 /The String Array table, DCA I (6200 /And the function table CIF CDF 10 JMP I (MOVPAG /Move the code and start NG, TLS TSF JMP .-1 JMS I QERMSG /SUPER ERROR SYMSG JABORT, JMP I XABORT /ABORT COMPILATION IOAD1, 2000 /START OF FIELD 1 LOAD AREA JUST ABOVE USR IOAD2, 0000 /START OF ACTUAL EXECUTE AREA IOCTR, -2000 /8. PAGES PAGE /THIS PAGE GETS LOADED WITH THE RECORD I/O /STATEMENT PROCESSORS JUST PRIOR TO STARTUP CORE, 0 /Changed to subroutine TAD I (BIPCCL /MODIFIED CORE SIZE ROUTINE FROM AND Q70 SNA JMP COR0 CLL RAR RTR IAC DCA CORSIZ JMP COREX /OS8 SOFTWARE SUPPORT MANUAL COR0, CDF TAD CORSIZ RTL RAL AND Q70 TAD COR0 DCA .+1 FDPTR, COR1, HLT TAD I CORLOC COR2, NOP DCA COR1 TAD COR2 DCA I CORLOC CORSIZ, 1 TAD I CORLOC CORX, 7400 TAD CORX TAD CORV SZA CLA JMP COREX TAD COR1 DCA I CORLOC ISZ CORSIZ JMP COR0 COREX, CLA CMA /HI FIELD IS #FIELDS-1 TAD CORSIZ DCA HIFLD CDF 10 TAD I (CDOPT6 /SEE IF = OPTION PASSED AND (7 /LOOK AT LOW 3 BITS FOR FIELD SZA /SKP IF NONE JMP GOTLIM /ELSE GOT A CORE LIMIT SPEC TAD I (CDOPT3 /SEE IF /B PASSED RAL SMA CLA /SKP IF YES, REDUCE ONE FIELD TO PRESERVE BATCH JMP GOTLIM /ELSE NO CORE RESTRICTION IFZERO TDCHK < STA / Reduce 1 field to reserve space for batch TAD HIFLD > IFNZRO TDCHK < TAD HIFLD TAD (-7 /REDUCE 2 FIELDS IF 32 K, SINCE BATCH ONLY USES 6 SNA / FIELDS FOR ROM-TD8E COMPATIBILITY STA TAD (6 > GOTLIM, CDF CIA /NEGATE SZA /SKP IF ONLY 8K SYSTEM TAD HIFLD /CHECK DIFFERENCE SPA SNA /SKP IF ROOM TO KEEP BATCH JMP NOLIM /JMP IF NO ROOM OR INVALID = OPTION CIA /REDUCE CORE SIZE TAD HIFLD DCA HIFLD TAD Q400 /SAY BATCH IS PRESERVED DCA I (JSW NOLIM, STA /Subtract one from field count TAD HIFLD SNA CLA /Skip if not just 8K JMP MEMBAD /OOPS! Need at least 12K to run. TAD HIFLD CIA /Set symbol table counter IAC /To one less than then number of fields DCA I (NFLDS /8K OPTIMIZATION REMOVED GENER, JMS I QGENTMP /GENERATE TEMP 0 JMS I QGENTMP /GENERATE TEMP 1 JMS I QGENTMP /GENERATE TEMP 2 CLA IAC /GENERATE STRING TEMP 0 JMS I QGENTMP CLA IAC DCA WORD1 /GENERATE LITERAL 1.0 CLL CML RTR DCA WORD2 JMS I QLUKUP2 /ENTER INTO ST LITRL -3 JMS I (NEWVAR / TAD (FNINIT /SET UP FUNCTIONS IFNZRO FNINIT-400 <-ERROR-> TAD Q400 DCA FDPTR FDLOOP, TAD (WORD1-1 DCA X12 CDF 10 TAD I FDPTR /GET FIRST WORD CDF ISZ FDPTR SNA JMP I CORE /Return DCA I X12 /SAVE IN WORD1 CLL CMA RTL /GET LOOKUP COUNT CDF 10 TAD I FDPTR DCA FUNSIZ TAD FUNSIZ /GET SIZE OF MOVE IAC DCA TEMP FDLUP2, CDF 10 TAD I FDPTR /GET A WORD CDF ISZ FDPTR DCA I X12 /PUT INTO WORDN ISZ TEMP JMP FDLUP2 JMS I QLUKUP2 /ENTER INTO S.T. FUNCTN FUNSIZ, 0 JMP FDLOOP /LOOP MEMBAD, JMS I QERMSG MEMORY JMP I (ABORT CORLOC, CORX CORV, 1400 PAGE /PRINT STATEMENT PRINT, JMS I QLODSN /OUTPUT STMT NUM JMS I QGETFN /GET FILE NUMBER DCA USINGF /TENTATIVELY ASSUME NORMAL PRINT JMS I QSAVECP /SAVE SCAN POINTER JMS I QCHKWD /LOOK FOR "USING" WUSING JMP PRINTGO /NOT THERE, HANDLE NORMALLY ISZ USINGF /SET FLAG IF THERE JMS I QEXPR /OK, GET PATTERN EXPRESSION JMP PRTERR /ERROR IF NONE JMS I QTYPCK /Check for numeric arg SKP /If string JMP PRTERR /ERROR if numeric TAD (PUINIT /NOW OUTPUT PATTERN INIT OPCODE JMS I QOUTWRD JMS I QCHECKC /CHECK IF , IS DELIMITER -54 JMP PRTERR /ERROR IF NOT SKP /SKP INTO NORMAL PRINT ROUTINE NOW PRINTGO,JMS I QRESTCP /RESTORE SCAN POINTER IF NO "USING" 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 USINGF /TREAT AS ; IF PRINT USING MODE SZA CLA JMP NOCR 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 QTYPCK /Check if arg is numeric JMP BADPF /It's bad! 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) TAD USINGF /SEE IF PRINT USING SNA CLA JMP NORMPR /JMP IF NOT TAD TYPE1 /MUST BE STRING SMA CLA JMP PRTERR /ERROR IF NOT TAD (PUEXEC /OK, OUTPUT PRINT USING EXECUTE OPCODE JMS I QOUTWRD /OUTPUT IT /FALL INTO STRING WRITE OUTPUT CODE NORMPR, 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 JMS I QOUTWRD /CALL TO CRLF ROUTINE JMP I QNEWLIN /END OF PRINT PRTERR, JMS I QERMSG /ERROR IN PRINT USING SYNTAX PUMSG JMP I QREMARK BADPF, JMS I QERMSG /PRINT ERROR FRMSG /BAD FUNCTION REFERENCE JMP I QREMARK PRFUN, 0 WUSING, -125;-123;-111;-116;-107 /USINGF will be positive USINGF, 0 /OPERATOR TABLE OPR8RS, PLUS;-53 MINUS;-55 STAR;-52 SLASH;-57 UPAROW;-136 AMPSND;-46 0 PAGE FIELD 1 *2000 RELOC 0 /FUNCTION NAME TABLE (INTERNAL FUNCTIONS) /Alphabet table for function names XA="A&77;XB="B&77;XC="C&77;XD="D&77;XE="E&77;XF="F&77 XG="G&77;XH="H&77;XI="I&77;XJ="J&77;XK="K&77;XL="L&77 XM="M&77;XN="N&77;XO="O&77;XP="P&77;XQ="Q&77;XR="R&77 XS="S&77;XT="T&77;XU="U&77;XV="V&77;XW="W&77;XX="X&77 XY="Y&77;XZ="Z&77 FUNS, -XA^100-XB;-XS^100;FUNC3 /ABS(X) -XA^100-XS;-XC^100;FUNC2 /ASC -XA^100-XT;-XN^100;FUNC1 /ATN(X) -XC^100-XH;-XR^100;FUNC2+20 /CHR$(C) -XC^100-XO;-XS^100;FUNC1+20 /COS(X) -XD^100-XA;-XT^100;FUNC2+40 /DAT$(0) -XE^100-XX;-XP^100;FUNC1+40 /EXP(X) -XI^100-XN;-XT^100;FUNC1+100 /INT(X) -XL^100-XE;-XN^100;FUNC2+60 /LEN(X$) -XL^100-XO;-XG^100;FUNC1+120 /LOG(X) -XP^100-XO;-XS^100;FUNC2+100 /POS(X$,Y$,Z) -XR^100-XN;-XD^100;FUNC1+200 /RND(0) -XS^100-XE;-XG^100;FUNC2+120 /SEG$(A$,B,E) -XS^100-XG;-XN^100;FUNC1+140 /SGN(X) -XS^100-XI;-XN^100;FUNC1+160 /SIN(X) -XS^100-XQ;-XR^100;FUNC1+220 /SQR(X) -XT^100-XA;-XN^100;FUNC1+240 /TAN(X) -XS^100-XT;-XR^100;STRFUN /STR$(X) -XV^100-XA;-XL^100;VALFUN /VAL(S$) -XF^100-XI;-XX^100;FUNC2+200 /FIX$(X$) -XT^100-XR;-XC^100;FUNC2+220 /TRC(X) -XC^100-XU;-XR^100;FUNC3+220 /CUR$(V,H) -XC^100-XO;-XL^100;FUNC3+300 /COL(N) -XC^100-XC;-XL^100;FUNC5+160 /CCL(L$) -XP^100-XM;-XT^100;FUNC6+140 /PMT$(Q$) -XC^100-XA;-XP^100;FUNC2+260 /CAP$(L$) -XO^100-XC;-XT^100;FUNC2+300 /OCT(O$) -XB^100-XI;-XN^100;FUNC2+320 /BIN(B$) -XO^100-XC;-XS^100;FUNC2+340 /OCS$(O) -XE^100-XI;-XD^100;FUNC4 /EID$(X) EXTENDED FUNCTIONS -XL^100-XS;-XT^100;FUNC4+020 /LST$(0) -XS^100-XC;-XD^100;FUNC4+040 /SCD$(A$,X,Y) -XE^100-XI;-XL^100;FUNC4+060 /EIL$(X) -XS^100-XG;-XR^100;FUNC4+100 /SGR$(X) -XS^100-XF;-XM^100;FUNC4+120 /SFM$(X) -XL^100-XC;-XD^100;FUNC4+140 /LCD$(A$,X,Y) -XL^100-XG;-XD^100;FUNC4+160 /LGD$(A$,X,Y) -XS^100-XC;-XS^100;FUNC4+220 /SCS$(X) -XS^100-XS;-XI^100;FUNC4+240 /SSI$(X) -XE^100-XR;-XR^100;FUNC4+260 /ERR(X) -XE^100-XR;-XL^100;FUNC4+320 /ERL(X) -XK^100-XE;-XY^100;FUNC4+340 /KEY$(M) -XC^100-XA;-XL^100;FUNC7+040 /CAL$("FILE.EX",#) ENDFNS, 0;0;FUNC4+360 0 *222 /ORIGIN INTO INPUT ROUTINE NOW /OS-8 FILE INPUT ROUTINE ICHAR, 0 /READ CHAR FROM INPUT FILE ICHLP, CLA CLL ISZ INJMP /BUMP THREE WAY UNPACK SWITCH ISZ INCHCT INJMPP, JMP INJMP TAD INEOF /LAST READ YEILD END OF FILE ? SZA CLA JMP INERR /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 CIF JMS I INHNDL /DO THE READ 0210 /ONE BLOCK TO FIELD 1 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 ICHLP /GO AGAIN INERR, CLA CIF CDF JMP I (ENDFIL 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 /IGNORE LEADER-TRAILER JMP ICHLP TAD (-134 /CHECK FOR \ (STMT SEPARATOR) SNA JMP INBKSL /TREAT LIKE CR IF NOT BETWEEN QUOTES QTBKSL, TAD (134-32 /IS IT ^Z (END OF FILE) SNA JMP INERR /YES, ITS END OF FILE TAD (32-15 SNA JMP INEOL /RETURN IF CR CLL TAD (3 SZL /SKP IF NOT LF, VT OR FF JMP ICHLP /ELSE IGNORE TAD (12-42 /SEE IF QUOTE SNA ISZ QUOTCT /TALLY IT IF YES TAD (42 /FIX CHAR ISZ ICHAR ICHXIT, CIF 0 JMP I ICHAR /RETURN TO THE CALLING WORLD INBKSL, TAD QUOTCT /SEE IF BETWEEN QOUTES RAR SZL CLA /TREAT AS CR IF YES JMP QTBKSL /RETURN IT OTHERWISE INEOL, DCA QUOTCT /CLEAR THE COUNTER ON GENUINE CR JMP ICHXIT /RETURN INTMP, 0 INEOF, 0 INCHCT, -1 INHNDL, 0 /ENTRY ADDR GOES HERE INCTR, 0 INPTR, 0 QUOTCT, 0 /CODE TO RELOCATE RECORD I/O PROCESSOR DOWN MOVPAG, TAD I PAGPT1 CDF DCA I PAGPT2 CDF 10 ISZ PAGPT1 ISZ PAGPT2 ISZ PAGCNT JMP MOVPAG CIF CDF JMP I (REMARK /START THE COMPILER NOW!! PAGPT1, 600 PAGPT2, CHAINED PAGCNT, -400 PAGE /Function symbol table initialization data / /This table has entries with: / 1: BRTS pseudo code of the function / 2: Negative number of args / 3: TYPE codes for each argument plus temp level for arg / n: TYPE code for the value returned by the function / / TYPE Bits: / 4000 String / 2000 Value is in the AC / 1000 Function / / The low 8 bits (377 octal) are the symbol used to / get the argument / 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+240;-1;2000;0 /TAN 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 FUNC2+200;-1;6000;4000 /FIX$ FUNC1+200;-1;2000;0 /RND FUNC2+220;-1;2000;0 /TRC FUNC3+220;-2;0;2000;4000 /CUR$(V,H) FUNC3+300;-1;2000;0 /COL(N) FUNC5+160;-1;6000;0 /CCL(L$) FUNC6+140;-1;6000;4000 /PMT$(Q$) FUNC2+260;-1;6000;4000 /CAP$(L$) FUNC2+300;-1;6000;0 /OCT(O$) FUNC2+320;-1;6000;0 /BIN(B$) FUNC2+340;-1;2000;4000 /OCS$(O) FUNC4;-1;2000;4000 /EID$(X) FUNC7+040;-2;2000;6000;4000 /CAL$(F$,#) FUNC4+020;-1;2000;4000 /LST$(X) FUNC4+040;-3;0;2000;6000;4000 /SCD$(X$,Y,Z) FUNC4+060;-1;2000;4000 /EIL$(X) FUNC4+100;-1;2000;4000 /SGR$(X) FUNC4+120;-1;2000;4000 /SFM$(X) FUNC4+140;-3;0;2000;6000;4000 /LCD$(X$,Y,Z) FUNC4+160;-3;0;2000;6000;4000 /LGD$(X$,Y,Z) FUNC4+220;-1;2000;4000 /SCS$(X) FUNC4+240;-1;2000;4000 /SSI$(X) FUNC4+260;-1;2000;0 /ERR(X) FUNC4+320;-1;2000;0 /ERL(X) FUNC4+340;-2;0;2000;4000 /KEY$(M) /TABLE CROSSES PAGE BOUNDRY RELOC .-FNINIT-200+CHAINED /GET FILE NUMBER GETFN, 0 /Zero to end table 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 /SEE IF COLON REQUIRED SZA CLA /SKP IF YES JMP NCNEED /ELSE SKP THIS TEST JMS I QGETC /Get a char JMP BADFN /Error if none TAD (-72 /Test if : SZA TAD (72-54 /Test if , SZA CLA /SKP If either of above JMP BADFN /Else error NCNEED, JMS I QTYPCK /Check type, load it, skip if numeric BADFN, JMS I QERMSG /NOPE, IT ISN'T FNMSG TAD (FILENO /OUTPUT SET IFN COMMAND JMS I QOUTWRD CLA IAC /SET IFNREG TO "NOT TTY" CLRIFN, DCA IFNREG /SAVE NEW IFNREG 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 JMP CLRIFN /SET IFNREG TO TTY /Generate a JUMP around imbedded code /Used for IF and DEF GENJMP, 0 ISZ NEXT /Skip high order jump TAD I (FREFLD /GET FIELD AND Q70 /ISOLATE BITS CLL RTL /INTO JUMP INSTR DCA IFJW1 /Save word one TAD NEXT /OUTPUT LOW PART DCA IFJW2 /Save word 2 TAD NEXT /Return with NEXT ISZ NEXT /Skip low order jump location JMP I GENJMP /Done OUTJMP, 0 /Call with jump opcode TAD IFJW1 /Get word one JMS I QOUTWRD TAD IFJW2 /Get word two JMS I QOUTWRD /Done DCA NOSN /No statement number JMP I OUTJMP /Finished outputting the JUMP SETIFJ, 0 IFFLD, HLT /Set to label field by IF AC4000 /Set label defined bit TAD LOCTRH /Get high loc counter DCA I IFJMP ISZ IFJMP /Bump label pointer TAD LOCTRL DCA I IFJMP /Store low order pointer DCA IFJMP /Clear flag CDF 0 JMS I QMODSET /Set to NMODE after Jump JMP I SETIFJ /Return IFJW1= CHAINED /Use top of page for temps IFJW2= CHAINED+1 COLON= CHAINED+2 OPNSW= CHAINED+3 PAGE RELOC /IMAGE OF RECORD I/O PROCESSORS XGET, RELOC CORE /FITS IN HOLE IN FIELD 0 /GET STATEMENT GET, JMS RECCOM /DO COMMON CODE GETLUP, JMS I QCHECKC /SEE IF COMMA FOLLOWS -54 JMP I QNEWLIN /JMP OUT IF NOTHING ELSE STL RAR /SET LEFT SIDE SWITCH JMS I QEXPR /PARSE EXPRESSION JMP I QREMARK /IGNORE IT JMS I QGETA1 /GET TOP OF STACK TAD TYPE1 /LOOK AT TYPE BITS SPA CLA /SKP IF NUMERIC EXPRESSION JMP GSTRNG /ELSE GET STRING JMS I QMODSET /SET INTERPRETER MODE TO NUMERIC STL RTR /LOOK AT SUBSCRIPTED BIT AND TYPE1 SZA CLA /SKP IF SCALAR JMP DIMGET /ELSE DO DIMENSIONED TYPE TAD (RSUB /EMIT READ FIELD OPERATOR (INTO SAC) JMS I QOUTWRD TAD (VALFUN /NOW EMIT VAL(SAC) TO GET INTO FAC JMS I QOUTWRD TAD (FSTA /DO THE STORE NOW JMP FINGET DIMGET, JMS I QLOADSS /LOAD SUBSCRIPT REGISTERS TAD (RSUB /NOW DO THE READ FIELD OPERATION JMS I QOUTWRD TAD (VALFUN /CONVERT TO FAC JMS I QOUTWRD TAD (AFSTA /STORE INTO ARRAY JMP FINGET GSTRNG, TAD (RSUB /SEND OUT READ FIELD TO SAC JMS I QOUTWRD STL RAR JMS I QMODSET /SET TO STRING MODE STL RTR /LOOK AT DIMENSIONED BIT AND TYPE1 SNA CLA JMP .+3 /JMP AROUND IF SCALAR JMS I QLOADSS /ELSE LOAD SUBSCRIPTS TAD (SASTOR-SSTORE /CONVERT TO STRING ARRAY STORE TAD (SSTORE /OR SCALAR STRING STORE FINGET, TAD SYMBL1 /ADD TO SYMBOL JMS I QOUTWRD JMP GETLUP /LOOP FOR MORE /PUT STATEMENT PUT, JMS RECCOM /DO COMMON STUFF PUTRCL, JMS I QCHECKC /SEE IF COMMA FOLLOWS -54 JMP EOREC /END OF RECORD IF NO MORE JMS I QEXPR /GET EXPRESSION JMP EOREC /END OF REC IF NONE JMS I QTYPCK /Get arg, skip if numeric JMP NOCVT /ELSE JMP AROUND CONVERSION TAD (STRFUN /SEND OUT STR TO LOAD SAC FROM FAC JMS I QOUTWRD STL RAR /TELL OURSELVES WE'RE IN STRING MODE JMS I QMODSET NOCVT, TAD (WSUB /NOW DO WRITE FIELD OPERATION JMS I QOUTWRD JMP PUTRCL /ITERATE EOREC, TAD (WEOR /AT END,EMIT END OF RECORD OPCODE JMS I QOUTWRD JMP I QNEWLIN /DONE /HANDLE COMMON PORTION OF GET/PUT STATEMENTS RECCOM, 0 JMS I QLODSN /OUTPUT STATEMENT NUMBER JMS I QGETFN /GET #N: JMS I QEXPR /NOW GET RECORD NUMBER EXPRESSION JMP I QREMARK /FLUSH IF NOT THERE JMS I QTYPCK /Load and check for numeric JMS I QERMSG /PRINT ERROR IF STRING BRMSG /BAD RECORD NUMBER CLA CLL /Clear any random AC contents TAD (LOCATE /NOW EMIT LOCATE OPERATOR JMS I QOUTWRD JMP I RECCOM /RETURN WITH SCAN AT COMMA FOLLOWING RECORD NUMBER /DEFINE RECORD STATEMENT DEFINE, JMS I QLODSN /SEND OUT STATEMENT NUMBER JMS I QGETFN /GET #N: NEXT DEFINL, JMS I QEXPR /PARSE EXPRESSION JMP I QREMARK /END OF DEFINE JMS I QTYPCK /Check argument type JMS I QERMSG /IF STRING GIVE ERROR BDMSG /BAD DEFINE CLA CLL /Clear any random AC TAD (DEFREC /SEND OUT DEFINE FIELD OPCODE JMS I QOUTWRD JMS I QCHECKC /SEE IF ANOTHER FIELD FOLOWS -54 /, JMP I QNEWLIN /END IF NO COMMA JMP DEFINL /ELSE GET ANOTHER /RETURN, RANDOMIZE AND STOP STATEMENTS 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 SLEEP, JMS I QLODSN /OUTPUT A LINE NUMBER JMS I QMODSET /GO INTO NUMERIC MODE JMS I QEXPR /GET EXPRESION JMP I QREMARK JMS I QLOAD /LOAD IT INTO FAC TAD TYPE1 /IS IT NUMERIC SMA CLA JMP .+3 /YES, CONTINUE JMS I QERMSG /NO, SO GIVE AN ERROR REPORT FRMSG CLA CLL TAD (XSLEEP /GET OPCODE JMS I QOUTWRD /AND SAVE IT JMP I QNEWLIN /GET NEXT COMMAND PAGE RELOC 1200 JMP DORUN1 /JMP IF CHAINED TO BY EDITOR /CODE TO READ IN FIELD 0 OF COMPILER ON A CHAIN FROM BRTS /THIS CODE EXECUTES IN LOCATION *13200 TAD I (INFO+1 /ON ENTRY FROM RUNTIME CHAIN CODE, TAD F0BLK /ADD OFFSET TO FIELD 0 SECTION OF BCOMP TO DCA F0BLK /START OF BCOMP AND STORE INLINE CIF /CALL TO SYS: JMS I (7607 3700 /READ 31. PAGES INTO FIELD 0 0000 /STARTING AT *0 F0BLK, F0OFFS /CONTAINS OFFSET TO FIELD 0 ON ENTRY HLT /FATAL ERROR CIF CDF JMP I (BRTCHN /JMP TO CHAIN CODE NOW /ENTRY ADDR FOR CHAIN FROM EDITOR /SAVES INPUT HANDLER AND READS FIELD 0 OF BRTS, AND /RESTORES FIELD 0 OF HANDLER DORUN1, JMS XMOVE /FIRST SAVE HANDLER CDF /CDF OF SOURCE INDEVH /LOCATION IN FIELD 0 WHERE HANDLER IS STORED CDF 10 /CDF OF SAVE AREA 7200 /A SAFE SLOT IN FIELD 1 -400 /THIS MUCH TAD I (INFO+1 /GET START OF BCOMP TAD BCBLOK /OFFSET 8. PAGES FOR FIELD 0 STUFF DCA BCBLOK /STORE INLINE CIF /CALL SYS: TO READ IT IN JMS I (7607 3700 /ALL BUT ONE PAGE 0000 /STARTING HERE BCBLOK, F0OFFS /FROM HERE JMP WHUPS /SYSTEM ERROR JMS XMOVE /NOW SHIFT HANDLER BACK CDF 10 /FROM HERE 7200 CDF /TO HERE INDEVH -400 /2 PAGES CLA IAC JMS I (200 /ENTER THE TEMP FILE 3 TMPBK, TMPFL TMPSZ, 0 JMP WHUPS /SYSTEM ERROR JMS I (200 /NOW DO A RESET 13 TAD TMPBK /GET BLOCK NUMBER OF TMP FILE DCA I (INFO+10 /STORE IN INFORMATION AREA TAD TMPSZ /NOW GET SIZE OF TMP FILE DCA I (INFO+11 /ALSO STORE IN INFORMATION AREA TAD I (CDOPT4 /ZERO OUT ALL BUT /S SWITCH AND (40 DCA I (CDOPT4 TAD (40 /SET /G TO LOAD AND GO DCA I (CDOPT3 CIF CDF /JMP TO CHAINED CODE IN FIELD 0 NOW JMP I (CHAINED /ROUTINE TO MOVE CORE FROM ONE AREA TO ANOTHER XMOVE, 0 JMS GMOVE /GET SOURCE CDF DCA MFFLD JMS GMOVE /GET SOURCE PTR DCA MFPTR JMS GMOVE /GET DESTINATION CDF DCA MTFLD JMS GMOVE /GET DESTINATION PTR DCA MTPTR JMS GMOVE /GET -NUMBER OF WORDS TO MOVE DCA MCNT MFFLD, HLT TAD I MFPTR ISZ MFPTR MTFLD, HLT DCA I MTPTR ISZ MTPTR ISZ MCNT JMP MFFLD /ITERATE FOR ALL WORDS CDF 10 /RESET TO OUR DF JMP I XMOVE MFPTR, 0 MTPTR, 0 MCNT, GMOVE, 0 TAD I XMOVE ISZ XMOVE JMP I GMOVE TMPFL, FILENAME BASIC.TM /PRINT "SY" IF SYSTEM ERROR DURING INITIALIZATION WHUPS, TAD ("S JMS TTYO TAD ("Y JMS TTYO TAD (15 JMS TTYO TAD (12 JMS TTYO /BETTER THAN NOTHING... NOP /NOP'D FOR VT278 NOP /NOP'D FOR VT278 CIF CDF /NOW BACK TO OS/8 JMP I (7605 TTYO, 0 TLS TSF JMP .-1 CLA CLL JMP I TTYO PAGE ZBLOCK 1400-. /FILL OUT THE INPUT BUFFER /KEYWORD LIST KEYWRD, -114;-105;-124;LET -117;-116;-105;-122;-122;-117;-122;ONERR -106;-116;-105;-116;-104;FNEND -111;-106;IF -106;-117;-122;FOR -116;-105;-130;-124;NEXTX -107;-117;-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;-111;-116;-105;DEFINE -107;-105;-124;GET -120;-125;-124;PUT -104;-105;-106;DEF -106;-111;-114;-105;FILE -122;-105;-101;-104;READX -122;-105;-115;REMRK1 -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 -117;-116;ONGO -105;-116;-104;END -123;-114;-105;-105;-120;SLEEP -105;-130;-111;-124;EXIT -123;-124;-117;-122;-105;STORE -122;-105;-103;-101;-114;-114;RECALL -122;-105;-123;-125;-115;-105;RESUME -124;-122;-101;-120;TRAP 0 KEYEND=. IFNZRO KEYEND-1665 <__FIX BLOAD__> /FIELD ONE STUFF VARST= KEYEND /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 LINE= FUNCTN+2 /Line buffer FREE= LINE+LINMAX /START OF FREE CORE RELOC *4000 RELOC OUBUF *OUBUF+200 *OUBUF /ERROR MESSAGE OVERLAY /EXECUTES OUT OF TEMP FILE OUTPUT BUFFER /OUTPUT IS INHIBITED AFTER FIRST CALL TO QERMSG XERMSG, 0 JMS I (ESETUP /DO ONCE ONLY SETUP CIF JMS I (7607 /READ IN THE TEXT PAGE 0110 /ONE PAGE TO FIELD 1 TXTHOL /TO HERE ETXTOV, 0 /FROM HERE HLT TAD (77 /PRINT ? IN FRONT OF MESSAGE JMS SPCH JMS SCRIBE /PRINT THE MESSAGE EADDR, 0 JMS SCRIBE /PRINT "AT LINE NNNN" ATLINE TAD (12 /NOW RETURN CARRAIGE JMS SPCH TAD (15 JMS SPCH CIF CDF /RETURN TO CALLER JMP I XERMSG ATLINE, TEXT / AT ^LINE / *.-1 ATLNO, ZBLOCK 3 /BUFFER FOR LINE NUMBER /ROUTINE TO EXPAND AND PRINT FANCY ERROR MESSAGES /CALL+1 = ABSOLUTE ADDR OF MESSAGE IN FIELD 1 /MESSAGE TERMINATED BY NULL 6 BIT CHAR SCRIBE, 0 DCA MSGCNT /ZERO CHAR COUNT GOTCRT, JMS SGCH /GET AN UPPER CASE CHAR SPRTCH, JMS SPCH /PRINT IT SNXTCH, JMS SGCH /GET ANOTHER CHAR TAD (-136 /SEE IF ^ SNA JMP GOTCRT /JMP IF NEXT CHAR IS UPPER CASE TAD (136-133 /SEE IF [ SNA JMP GOTBRK /JMP IF NEXT WORD IS UPPER CASE CLL /SEE IF ALPHABETIC TAD (32 SZL /SKP IF NO TAD (40 /ELSE CONVERT TO LOWER CASE TAD (133-32 JMP SPRTCH /GO PRINT CHAR GOTBRK, JMS SGCH /GET NEXT CHAR TAD (-135 /SEE IF ] SNA JMP SNXTCH /JMP IF YES TAD (135 /ELSE FIX CHAR JMS SPCH /PRINT IT AS IS JMP GOTBRK SGCH, 0 TAD MSGCNT /GET CHAR COUNT ISZ MSGCNT CLL RAR /DIVIDE BY 2 TAD I SCRIBE /ADD TO MESSAGE BASE DCA MSGPTR /POINT AT WORD TAD I MSGPTR SZL /SKP IF LEFT BYTE JMP NOROT RTR RTR RTR NOROT, AND (77 /GET 6 BITS SNA JMP SOUT /EXIT IF NULL TAD (40 /DO UNPACK AND (77 TAD (40 JMP I SGCH /RETURN CHAR SOUT, ISZ SCRIBE /BUMP RETURN ADDR JMP I SCRIBE MSGCNT, 0 MSGPTR, 0 SPCH, 0 TLS TSF JMP .-1 CLA JMP I SPCH PAGE TXTHOL= . /SETUP ROUTINE FOR ERROR MESSAGE PRINTING ESETUP, 0 CDF TAD I (ERMSG /GET ADDR OF MESSAGE ADDR DCA EPTR TAD I EPTR /GET MESSAGE ADDR CDF 10 DCA I (EADDR /SAVE IT TAD I (EADDR /GET BLOCK OFFSET TO AC8-11 AND (7400 /ONLY BLOCK BITS CLL RTL RTL RAL TAD I (INFO+1 /ADD TO BASE OF BCOMP.SV TAD (TXTOFS /ADD BLOCK OFFSET OF TEXT DCA I (ETXTOV /STORE INLINE TAD I (EADDR /NOW MAKE MESSAGE ADDR ABSOLUTE AND (377 TAD (TXTHOL DCA I (EADDR /STORE IT TAD (ATLNO /SET POINTER TO LINE NUMBER BUFFER DCA LNPTR DCA I (ATLNO /CLEAR LEFT ZERO SUPRESSION FLAG CDF TAD I (LINEH /GET HIGH ORDER DIGITS JMS PSN /FORMAT THEM CDF TAD I (LINEL JMS PSN /FORMAT THEM TAD I (ATLNO /KLUDGE TO FORCE DIGIT OUT IF LINE ZERO SNA TAD (6000 /WAS ZERO, PUT DIGIT OUT DCA I (ATLNO JMP I ESETUP /RETURN EPTR, 0 /PUT STATEMENT NUMBER INTO "AT LINE" TEXT PSN, 0 CDF 10 DCA LNWORD /SAVE DIGITS AC7775 /DO 3 DIGITS DCA LNCNT LNLUP, TAD LNWORD /GET WORD RTL RTL /SHIFT LEFT 4 BITS DCA LNWORD TAD LNWORD /GET DIGIT RAL AND (17 SZA /SKP ZERO JMP NOZERO /ELSE OUTPUT IT TAD I (ATLNO /IS IT LEADING ZERO SNA CLA JMP LEAD0 /YES, FORGET IT NOZERO, TAD (60 /MAKE PRINTABLE DCA LNCHAR /SAVE IT TAD I LNPTR /GET WORD SZA /SKP IF LEFT CHAR JMP NOBSW TAD LNCHAR CLL RTL RTL RTL JMP NXTLCH /GO STORE IT NOBSW, TAD LNCHAR /ADD TO HI CHAR DCA I LNPTR ISZ LNPTR NXTLCH, DCA I LNPTR LEAD0, ISZ LNCNT JMP LNLUP /DO NEXT DIGIT JMP I PSN LNCNT, 0 LNCHAR, 0 LNWORD, 0 LNPTR, 0 PAGE RELOC RELOC 0 /ASSIGN RELATIVE ADDRESSES /BCOMP ERROR MESSAGES EPART1, XCMSG, TEXT /EXTRA ^CHARACTERS/ LTMSG, TEXT /LINE TOO LONG/ DIMSG, TEXT /D[IM S]TATEMENT ERROR/ NFMSG, TEXT /N[EXT] WITHOUT [FOR/ UDMSG, TEXT /BAD [UDEF] STATEMENT/ UUMSG, TEXT /ERROR IN [USE S]TATEMENT/ IFMSG, TEXT /BAD [IF S]TATEMENT/ FNMSG, TEXT /BAD ^FILE ^NUMBER/ STMSG, TEXT /SYMBOL ^TABLE ^OVERFLOW/ FN2MSG, TEXT /NUMERIC ^EXPRESSION IN ^FILENAME/ MOMSG, TEXT /MISSING ^OPERAND/ PAGE ZBLOCK 200 /Second page is not read in EPART2, SSMSG, TEXT /SUBSCRIPT ^ERROR/ FRMSG, TEXT /BAD ^FUNCTION ^REFERENCE/ FPMSG, TEXT /BAD [FOR] LOOP PARAMETERS/ MTMSG, TEXT /MIXED ^OPERATOR OR ^OPERAND TYPES/ MDMSG, TEXT /MULTIPLY ^DEFINED ^STATEMENT ^NUMBER/ PDMSG, TEXT /STACK ^OVERFLOW/ SS2MSG, TEXT /TOO MANY ^SUBSCRIPTS/ QSMSG, TEXT /ERROR IN ^QUOTED ^STRING/ LSMSG, TEXT /L[ET S]TATEMENT ^SYNTAX ^ERROR/ PAGE ZBLOCK 200 EPART3, OFMSG, TEXT /OUTPUT ^FILE ^ERROR/ NMMSG, TEXT /MISSING ^LINE ^NUMBER IN [GOTO] OR [GOSUB/ REMSG, TEXT /STRING IN ^RECORD ^SIZE ^EXPRESSION/ MEMSG, TEXT /MISSING [END S]TATEMENT/ SYMSG, TEXT /SYSTEM ^ERROR/ PUMSG, TEXT /BAD [PRINT USING S]YNTAX/ BDMSG, TEXT /STRING ^EXPRESSION IN [DEFINE S]TATEMENT/ MPMSG, TEXT /MISMATCHED ^PARENTHESIS/ PAGE ZBLOCK 200 EPART4, BRMSG, TEXT /STRING IN ^RECORD ^NUMBER ^EXPRESSION/ DEMSG, TEXT /SYNTAX ERROR IN USER [DEF]INED ^FUNCTION/ ONMSG, TEXT /O[N S]TATEMENT ^SYNTAX ^ERROR/ TDMSG, TEXT /D[ATA L]IST ^OVERFLOW/ NDMSG, TEXT \D[EF W]ITHIN A [FOR/NEXT L]OOP\ FNEMSG, TEXT /F[NEND S]TATEMENT WITHOUT [DEF/ OPMSG, TEXT /BAD [OPEN S]TATEMENT ^SYNTAX/ MEMORY, TEXT /NEED AT LEAST 12^K MEMORY/ RELOC $