1 /OS8 BASIC COMPILER, V5
14 /COPYRIGHT (C) 1972, 1973, 1974, 1975
15 /DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
19 /THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
20 /SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
21 /SION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE, OR ANT OTHER
22 /COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
23 /TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
24 /AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
25 /SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
28 /THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
29 /NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
30 /EQUIPMRNT COROPATION.
32 /DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
33 /SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
42 /COPYRIGHT C 1972, 1973, 1974
44 /DIGITAL EQUIPMENT CORPORATION
45 /MAYNARD,MASSACHUSETTS 01754
53 /ASSEMBLE AND LOAD AS FOLLOWS:
56 / *BCOMP,BCOMP<BCOMP.03
61 /NOTE DIFFERENCES FROM VERSION 1 AS FOLLOWS:
64 / *LPT:<BCOMP.01,BCOMP.03
68 VERSON=5 /VERSION LOCATED IN CORE AT TAG "VERLOC"
69 /LEFT HALF OF VERLOC = 60+VERSON
70 /RIGHT HALF OF VERLOC = PATCH LEVEL (01=A)
73 /CORRECTION & ADDITION MADE FOR V4 J.K. 1975
75 / ./V FOR VERSION NUMBER
76 / . ABILITY TO INPUT FROM PTR
77 / .CORRECT TEST FOR BATCH RUNNIG
78 / .IGNORE MORE THAN 10 SIGNIFICANT DIGITS
79 / OF NUMERIC CONSTANTS
80 /JR 30-APR-77 UPDATE VERSION
83 XABORT, ABORT /ADDR OF ABORT ROUTINE
85 X10, INFO-5 /AUTO INDEX REGISTERS
89 OSTACK, STACKO-1 /OPERAND STACK POINTER
90 STACK, STACKA-1 /GENERAL STACK POINTER
91 NEXT, FREE-1 /NEXT FREE LOCATION
92 CHRPTR, 0 /INPUT BUFFER POINTER
93 NCHARS, 0 /SIZE OF INPUT LINE
97 NDIGIT, 0 /NUM DIGITS RIGHT OF .
98 EXPON, 0 /EXPONENT FOR NUM CONV
99 TYPE, 0 /TYPE OF CURRENT OPERAND
100 SYMBOL, 0 /SYMBOL NUMBER OF CUR. OPERAND
101 LEFT, 0 /LEFT SIDE SWITCH
102 OLDOP, 0 /OLD OPERATOR
103 NEWOP, 0 /NEW OPERATOR
104 TMPCNT, 0 /TEMP COUNTER
105 TMPLVL, 3 /TEMP LEVEL
106 STMPCT, 0 /TEMP COUNT (STRINGS)
107 STMPLV, 1 /TEMP LEVEL (STRINGS)
108 STPTR, 0 /POINTER TO S.T. ENTRY
109 VARCNT, -401 /NUMBER OF POSSIBLE NUMERIC
110 /VARIABLES, LITERALS, AND TEMPS
111 SVCNT, -401 /SAME FOR STRING VARS
112 ACNT, -41 /ARRAY COUNTER
113 SACNT, -41 /STRING ARRAY COUNTER
114 LOCTRH, 0 /HIGH ORDER LOCATION COUNTER
115 LOCTRL, 0 /LOW ORDER " "
116 BLOCK, 0 /START BLOCK OF TEMP FILE
117 HIFLD, 0 /HIGHEST CORE FIELD
118 BRTS, 0 /START OF BRTS.SV
119 DLSIZE, 0 /NEG. SIZE OF DATA LIST
120 ABORTX, 0 /START OF EDITOR
121 LINEH, 0 /LINE NUMBER (HIGH)
122 LINEL, 0 /LINE NUMBER (LOW)
123 MODE, 0 /INTERPRETER MODE
124 TYPE1, 0 /TYPE AFTER JMS GETA1
125 SYMBL1, 0 /SYM # AFTER JMS GETA1
126 OLDSTK, 0 /STACK SAVER FOR DEF
127 ARGCNT, 0 /ARG COUNTER FOR DEF
128 PCRLF, /CR SWITCH FOR PRINT STMT
129 DACNT, /ARG COUNT FOR UDEF STMT
130 FORJMP, /FOR LOOP JUMP INSTR
131 NOSN, /STMT NUMBER PRESENT SWITCH
132 COLON, /: SWITCH FOR GETFN ROUTINE
133 JAROND, 0 /END OF DEF ADDR GOES HERE (INDIRECTLY)
134 IFNREG, 0 /CONTENTS OF IFN REG
135 SSREG1, 0 /EXECUTION TIME CONTENTS
136 SSREG2, 0 /OF THE SS REGISTORS
137 STKLVL, STACKA-1 /STACK BASE LEVEL
138 FINDEX, 0 /FOR LOOP INDEX
139 SETFLD, 0 /FIELD CHANGE RTNE FOR LUKUP2
140 LUFLD, CDF 10 /FIELD OF ENTRY FOR LUKUP2
142 QERMSG, ERMSG /SUBROUTINE POINTERS
175 NAME1, /VARIABLE OR FUNCT NAME
176 WORD1, 0 /3 WORD LITERAL BUFFER
181 ACO, 0 /FAC OVERFLOW WD
182 OP1, 0 /4 WORD ARG FOR "NUMBER"
188 \f INFO= 7604 /INFORMATION AREA
189 /INFO STARTING BLOCK +1 OF BASIC.SV
190 /INFO+1 STARTING BLOCK +1 OF BCOMP.SV
191 /INFO+2 STARTING BLOCK +1 OF BLOAD.SV
192 /INFO+3 STARTING BLOCK +1 OF BRTS.SV
193 /INFO+4 STARTING BLOCK +1 OF BASIC.AF
194 /INFO+5 STARTING BLOCK +1 OF BASIC.SF
195 /INFO+6 STARTING BLOCK +1 OF BASIC.FF
196 /INFO+7 STARTING BLOCK +1 OF BASIC.UF
197 /INFO+10 STARTING BLOCK OF BASIC.TM
198 /INFO+11 SIZE IN BLOCKS OF BASIC.TM
199 /INFO+12 INPUT HANDLER ENTRY ADDRESS
200 /INFO+13 SIZE AND DEVICE NUMBER OF INPUT FILE
201 /INFO+14 STARTING BLOCK OF INPUT FILE
203 /INFO+20 NAME OF WORKSPACE
206 BOSINFO= 7774 /BOS PARAMETER AREA
207 EDTSIZ= 2100 /SIZE OF BASIC.SV
208 EDTBGN= 3212 /RESTART FOR EDITOR
209 ERMSG2= 1712 /POST PROCESSOR ERROR SWITCH
210 EOST= 7570 /UPPER LIMIT FOR SYMBOL TABLE
211 INDEVH= 4600 /INPUT DEVICE HANDLER
212 LINE= 7000 /LINE BUFFER
213 LINMAX= 121 /MAXIMUM BASIC STMT
214 STACKA= 7120 /MAIN STACK
215 STAKSZ= 60 /SIZE OF MAIN STACK
216 /OPERAND STACK DEFINED IN-LINE
217 STRLIM= 120 /MAXIMUM STRING SIZE
218 INBUF= 7200 /INPUT BUFFER
224 OUBUF= 0 /OUTPUT BUFFER
225 VARST= 400 /VARIABLE SYMBOL TABLE
226 SVARST= VARST+436/STRING VAR SYMBOL TABLE
227 ARAYST= SVARST+1074/ARRAY SYMBOL TABLE
228 SARYST= ARAYST+200/STRING ARRAY SYMBOL TABLE
229 SNUMS= SARYST+200/STMT NUMBER BUCKETS
230 TEMPS= SNUMS+24 /NUMERIC TEMP BUCKET
231 STEMPS= TEMPS+2 /STRING TEMP BUCKET
232 LITRL= STEMPS+2 /NUMERIC LITERAL BUCKET
233 SLITRL= LITRL+2 /STRING LITERAL BUCKET
234 DATLST= SLITRL+2 /DATA LIST
235 FUNCTN= DATLST+2 /FUNCTION LIST
236 FREE= FUNCTN+2 /START OF FREE CORE
237 \f/ INTERPRETER OPCODES
239 / MEMORY REFERENCE SET
317 *STRLIM%2+1+WORD1 /ORG PAST BIGGEST STRING LIT
318 NEWLIN, JMS I QGETC /ANY CHARS LEFT ?
319 JMP REMARK /NO, LINE ENDED OK
320 JMS I QERMSG /EXTRA CHARACTERS
322 REMARK, DCA NOSN /CLEAR STMT NUMBER SWITCH
323 TAD TMPLVL /RESET TEMP LEVELS
324 DCA TMPCNT /FOR NUMERIC
325 TAD STMPLV /AND STRING
326 DCA STMPCT /TEMPORARIES
328 DCA OSTACK /RESET STACK POINTERS
329 TAD STKLVL /(CHANGED BY FOR LOOPS)
331 TAD (LINE-1 /GET THE NEXT LINE
333 TAD (-LINMAX/MAX SIZE
335 GETLIN, JMS ICHAR /GET NEXT CHAR
337 DCA I X10 /PUT INTO LINE BUFFER
338 ISZ TEMP3 /BUMP MAX COUNTER
341 ERLTL, JMS I QERMSG /LINE TOO LONG
343 JMS ICHAR /SKIP REST OF LINE
347 GOTCR, TAD X10 /COMPUTE SIZE
351 TAD (LINE-1 /SETUP LINE POINTER
353 / TAD LOCTRL /PUT LOCATION COUNTER
355 CLA CLL CML RAR /ALLOW DEFINITION
356 JMS I QSNUM /GET THE STATEMENT NUMBER
357 JMP NOSNUM /NO STMT NUMBER ON THIS LINE
358 ISZ NOSN /SET STMT NUMBER PRESENT
359 JMS I QMODSET /IN N MODE AT ALL LABELS
360 JMS I QNOREGS /FORGET REG CONTENTS
361 TAD WORD1 /SAVE NEW LINE NUMBER
365 JMS SETFLD /GET TO FIELD OF ENTRY
366 TAD I TEMP2 /GET DEFINED/REFNCED BITS
367 TAD LOCTRH /ADD IN HIGH ORDER LOCATION CTR
368 DCA I TEMP2 /PUT IT AWAY
370 TAD LOCTRL /NOW PUT IN LOW ORDER LOCATION
376 JMS KBDCHK /CHECK FOR ^C OR ^O
378 DCA X10 /SET UP FOR KEYWORD SEARCH
379 JMS I QSAVECP /SAVE CHAR POS
380 KWLOOP, TAD I X10 /GET NEXT CHAR OF KEYWORD
382 JMP GOTKW /OK, THIS IS THE KW
384 JMS I QGETC /GET NEXT CHAR FROM STMT
385 JMP NOGOOD /THIS ISN'T IT
386 TAD TEMP /IS THIS CHAR OK ?
388 JMP KWLOOP /YES, CONTINUE LOOKING
389 NOGOOD, JMS I QRESTCP /BACK TO START OF STMT
390 TAD I X10 /SKIP OVER REST OF KEYWORD
393 TAD I X10 /IS THIS END OF LIST ?
395 JMP KWLOOP+3/NO, KEEP LOOKING
396 JMP LET /TREAT AS LET STMT
397 GOTKW, DCA TEMP /SAVE ADDR OF ROUTINE
398 JMP I TEMP /GO PROCESS THE STMT
399 \f/ LET STATEMENT PROCESSOR
400 LET, JMS I QLODSN /LOAD THE STMT NUMBER
401 CLL CML RAR /COMPILE LEFT SIDE
402 JMS I QEXPR /GET EXPRESSION
404 JMS I QCHECKC /LOOK FOR =
406 JMP BADLET /BAD IF MISSING
407 JMS I QEXPR /GET RIGHT SIDE
410 TAD OSTACK /RIGHT SIDE
411 DCA TEMP /OF EQUAL SIGN
412 TAD I TEMP /SO THAT WE GENERATE
414 CLL CMA RAL /THE CORRECT STORE
416 JMS I QOUTOPR /GENERATE STORE
418 BADLET, JMS I QERMSG /BAD LET STMT
421 END, TAD (STOP /OUTPUT STOP OPCODE
423 JMS OUDUMP /DUMP BUFFER
424 JMS I (7607 /READ IN POST PROCESSOR
427 LDRBLK, 0 /FROM THIS BLOCK
428 IFNZRO LDRBLK-357 <__FIX BLOAD__>
430 TAD I QERMSG /SET POST PROCESSOR ERROR SWITCH
432 JMP I POSTX /START IT UP
433 \f/ RESTORE, PRINT, AND INPUT PROCESSORS
435 INPUT, JMS I QLODSN /OUTPUT STMT NUM
436 JMS GETFN /LOOK FOR #<FILE NUM EXPR>:
437 INPUTL, CLL CML RAR /PROCESS INPUT STMT
438 JMS I QEXPR /GET EXPR
440 JMS I QGETA1 /GET TOP OF STACK
441 TAD TYPE1 /LOOK AT THE TYPE
443 JMP RSTRNG /READ STRING
444 JMS I QMODSET /SET MODE
445 CLL CML RTR /IS IT DIMENSIONED ?
449 TAD (READ /OUTPUT READ COMMAND
451 TAD (FSTA /USE SCALAR STORE
452 FININP, TAD SYMBL1 /PLUS SYMBOL NUMBER
453 JMS I QOUTWRD /OUTPUT INSTR
454 JMS I QCHECKC /LOOK FOR ,
456 JMP I QNEWLIN /END OF INPUT
457 JMP INPUTL /YES, LOOP
458 RSTRNG, CLL CML RAR /SET MODE
459 JMS I QMODSET /TO STRING
460 CLL CML RTR /SUBSCRIPTED ?
464 JMS I QLOADSS /LOAD SS REG
466 TAD (SREAD /STRING READ
467 JMP FININP /USE SOME COMMON CODE
468 PRINT, JMS I QLODSN /OUTPUT STMT NUM
469 JMS GETFN /GET FILE NUMBER
470 DCA I QEXPR /USE ENTRY AS SWITCH
471 PRINTL, DCA PCRLF /CLEAR THE FLAG
472 JMS I QGETC /LOOK FOR A CHAR
473 JMP PRTEND /NONE LEFT, END PRINT
476 JMP NOCR /YES, DON'T SPACE OUTPUT
479 JMP TABPNT /LOOK FOR TAB OR PNT
481 JMS I QOUTWRD /OUTPUT FUNC3+20 (COMMA)
482 NOCR, DCA I QEXPR /CLEAR THE SWITCH
483 CLA IAC /SET NO CRLF FLAG
485 TABPNT, TAD I QEXPR /WAS LAST THING AN EXPR ?
487 JMP I QNEWLIN /YES, CAN'T HAVE TWO IN A ROW
488 JMS I QBACK1 /PUT THAT CHAR BACK
489 JMS I QSAVECP /SAVE CHAR POS
490 JMS I QCHKWD /LOOK FOR "TAB("
494 PFCALL, DCA PRFUN /SAVE PRINT FUNCTION
497 JMS I QLOAD /LOAD ARG
498 TAD TYPE1 /MUST BE NUMERIC
501 BADPF, JMS I QERMSG /PRINT ERROR
502 0622 /BAD FUNCTION REFERENCE
504 JMS I QCHECKC /LOOK FOR )
506 JMP BADPF /BAD FUN REFERENCE
507 TAD PRFUN /OUTPUT FUNCTION CALL
509 TRYPNT, JMS I QRESTCP /RESTORE CHAR POS
510 JMS I QCHKWD /LOOK FOR PNT(
514 JMP PFCALL /GO DO FUN CALL
515 PEXP, JMS I QRESTCP /RESTORE CHAR POS
516 JMS I QEXPR /GET EXPR TO BE PRINTED
518 JMS I QLOAD /PUT THING INTO FAC (OR SAC)
520 AND TYPE1 /GET TYPE BIT
522 TAD (WRITE /SWRITE=WRITE+1
525 PRTEND, TAD PCRLF /DID PRINT END WITH
527 JMP I QNEWLIN /YES, NO CR LF
529 PUT2, JMS I QOUTWRD /CALL TO CRLF ROUTINE
530 JMP I QNEWLIN /END OF PRINT
531 RESTOR, JMS I QLODSN /OUTPUT LOAD STMT NUMBER
532 CLA IAC /NO COLON NEEDED
533 JMS GETFN /LOAD FILE REG
534 TAD (REST /OUTPUT RESTORE OP
537 LODSN, 0 /OUTPUT STMT NUMBER INTO CODE
538 TAD NOSN /ANY STMT NUMBER ?
540 JMP I LODSN /NO, JUST RETURN
541 TAD WORD1 /NOW OUTPUT "LOAD STMT NUM REG"
551 DIM, JMS I QGETNAM /GET VAR NAME
554 RTL /MOVE BITS TO BE TESTED
555 SMA CLA /IF FUNC BIT SET THEN ERROR
556 SNL /IF DIM BIT NOT SET THEN ERROR
557 JMP DIMERR /NO DIMENSIONS
558 JMS SMLNUM /GET DIMENSION
561 JMS I QCOMARP /, OR ) ??
562 JMP DIMERR /NEITHER IS BAD
563 JMP TWODIM /, THERE'S ANOTHER DIMENSION
564 JMS CHKSDM /CHECK SIZE IF STRING
565 JMP CHKDIM /NUMERIC VECTOR, CHECK PREV REF
566 CLL CML RAR /THIS WAS A STRING SIZE DIM
567 DCA TYPE /PERFORM THE SPECIAL CASE
569 CDF 10 /OF NOT CHECKING PREVIOUS REFS
571 TWODIM, JMS SMLNUM /GET SECOND
572 JMS I QCHECKC /LOOK FOR )
575 JMS CHKSDM /CHECK SIZE IF STRING ARRAY
576 TAD (7000 /NUMERIC ARRAY
577 CHKDIM, TAD (7000 /GET NUMBER OF DIMS
579 JMS I QLOOKUP /FIND ST ENTRY
581 TAD I STPTR /LOOK AT DIM BITS
582 AND (7000 /PREVIOUSLY REFERENCED ?
585 SMA /IF MINUS, CAUSE ERROR
586 TAD TEMP /COMPARE NUMBER
588 JMP DIMERR /NUMBER OF DIMS DON'T MATCH
590 UNREFD, CLL CML RAR /PUT IN DIMENSIONED BIT
591 TAD TEMP /AND NUMBER OF DIMENSIONS
592 CIA /NEGATE WHOLE MESS (4000=-4000)
593 TAD I STPTR /TOGETHER WITH SYM NUMBER
596 TAD DIM1 /NOW FIRST DIMENSION (IF 2)
599 TAD EXPON /NOW SECOND (IF 2, OTHERWISE FIRST)
602 JMS I QCHECKC /LOOK FOR ,
604 JMP I QNEWLIN /NONE, ASSUME END OF DIM
605 JMP DIM /GET NEXT ELEMENT
606 CHKSDM, 0 /CHECK SIZE OF STRINGS
607 TAD TYPE /WAS THIS A STRING DIM ?
609 JMP I CHKSDM /NO, RETURN IMMEDIATE
610 ISZ CHKSDM /YES, SKIP ON RETURN
611 TAD EXPON /SIZE MUST BE < 73
615 JMP I CHKSDM /OK, SIZE < 73
616 DIMERR, JMS I QERMSG /GIVE ERROR
618 JMP I QREMARK /ABORT STMT
620 NEXTX, JMS I QGETNAM /GET INDEX VARIABLE
623 TAD TYPE /MUST BE NUMERIC
626 JMS I QMODSET /N MODE
627 NEXTL, TAD (-STACKA-3
628 TAD STACK /ANY FOR'S LEFT ?
629 SPA CLA /(OK IF STACKA ABOVE 4000)
631 JMS I QPOP /GET LABEL ADDR
633 JMS I QPOP /GET LABEL FIELD
635 JMS I QPOP /GET STEP VAR
638 JMS I (PSETJF /PATCH!
639 TAD FINDEX /ADD IT TO STEP (FADD=0)
641 TAD LUPFLD /CREATE JUMP TO LOOP
646 CLL CMA RAL /GET LABEL DEFINITION ADDR
648 JMS I QOUTWRD /OUTPUT IT AS LOW PART OF JUMP
651 CLL CML RAR /SET LABEL DEFINED BIT
652 TAD LOCTRH /DEFINE END OF LOOP LABEL
658 TAD STACK /BACK OFF STACK LEVEL
660 JMS I QNOREGS /FORGET REGS
661 TAD SYMBOL /IS THIS THE RIGHT NEXT ?
665 JMP I QNEWLIN /YES, FINISHED
666 BADNXT, JMS I QERMSG /NEXT WITHOUT FOR
671 \f/ UDEF PROCESSOR (DEFINE USER FUNCTION)
673 UDEF, ISZ NFUNS /ROOM FOR ANOTHER FUN ?
674 JMS I QLETTER /GET FIRST LETTER
675 JMP DEFBAD /ERROR IN DEFINE
676 CLL RTL /PUT INTO HIGH ORDER
679 DCA NAME1 /SAVE CHAR 1
680 JMS I QLETTER /GET SECOND LETTER
682 TAD NAME1 /COMBINE THE TWO CHARS
684 DCA I FUNPTR /SAVE IN FUN TABLE
686 JMS I QLETTER /GET THIRD LETTER
688 CIA /SAVE NEG OF THIRD LETTER
690 ISZ FUNPTR /BUMP POINTER
691 TAD M5 /NUMERIC ARG COUNT
692 DCA TEMP / (MAX OF 4 ARGS)
693 CLL CMA RTL /STRING ARG COUNT
694 DCA TEMP2 / (MAX OF 2 ARGS)
695 JMS I QCHECKC /IS IT A STRING FUN ?
698 CLL CML RAR /YES, SET TYPE OF FUNCTION
700 JMS I QCHECKC /LOOK FOR (
702 JMP DEFBAD /ERROR IF MISSING
703 DALOOP, JMS I QGETNAM /GET AN ARG
705 TAD TYPE /LOOK AT ITS TYPE
706 CLL RAL /SHIFT TYPE BIT INTO LINK
708 JMP DEFBAD /OTHER BITS MUST BE OFF
710 JMP STRARG /STRING ARG
711 TAD TEMP /GET ARG NUMBER
712 ISZ TEMP /INCREMENT IT
713 JMP DAPUSH /GO SAVE IT
714 DEFBAD, JMS I QERMSG /BAD USER DEF
717 STRARG, TAD TEMP2 /GET ARG NUMBER
718 ISZ TEMP2 /AND INCREMENT IT
720 JMP DEFBAD /TOO MANY STRING ARGS
721 DAPUSH, TAD Q2 /ADJUST ARG NUMBER
722 TAD Q2 /ADD 4 FOR NUM, 2 FOR STRING
724 CLA CLL CML RTR /FIRST ARG STAYS IN AC
725 TAD TYPE /ADD IN TYPE BIT
726 JMS I QPUSH /SAVE IT ON STACK
727 JMS I QCOMARP /LOOK FOR , OR )
728 JMP DEFBAD /ERROR IF NEITHER
729 JMP DALOOP /, GET NEXT ARG
730 TAD TEMP2 /GET TOTAL NUMBER OF ARGS
732 TAD Q10 /ADJUST COUNT
735 TAD I FUNPTR /GET FUNCTION CODE
736 ISZ FUNPTR /BUMP POINTER
737 DCA WORD1 /MAKE IT THE SEARCH OBJECT
738 JMS I XSTCHEK /MAKE SURE THERE'S ROOM
740 JMS I QLUKUP2 /ENTER NEW FUNCTION
743 TAD DACNT /PUT IN ARG COUNT
744 JMS SETFLD /(FIRST SET THE FIELD)
747 JMS I QPOP /GET ARG TYPE (LAST TO FIRST)
748 JMS SETFLD /SET THE FIELD
750 ISZ DACNT /ANY MORE ?
752 TAD TYPE1 /PUT IN TYPE OF FUNCTION
755 JMS I QCHECKC /LOOK FOR A COMMA
757 JMP I QNEWLIN /NO COMMA, END OF LINE
758 JMP UDEF /GET NEXT DEFINITION
761 Q2, 2 /THESE FOUR WORDS
762 M5, -5 /PREVENT ERRONEOUS "SAVES"
763 Q10, 10 /BY THE ROUTINE SAVAC
764 NFUNS, -21 /WHEN THE OP STACK IS EMPTY
765 STACKO, /OPERAND STACK
766 STOKSZ=UDEF+200-STACKO
769 DEF, JMS I QNOREGS /FORGET REGS
770 JMS I QGETNAM /GET FUN NAME
772 TAD TYPE /SAVE ITS TYPE
774 DCA ARGCNT /ZERO ARG COUNT
775 TAD TYPE /TYPE MUST BE 3000 OR 7000
776 RTL /MOVE BITS TO BE TESTED
777 SPA CLA /FUN BIT OFF IS AN ERROR
778 SNL /DIM BIT OFF IS AN ERROR
780 JMS I QMODSET /ENTER N MODE
781 TAD SYMBOL /SAVE FUNCTION NAME
783 ARGLUP, JMS I QGETNAM /GET ARG NAME
785 CLL CMA RAR /LOOK AT TYPE
788 JMP BADDEF /ARG WAS AN ARRAY OR FUNC
789 JMS I QLOOKUP /ENTER INTO S.T.
790 TAD STPTR /SAVE ST ADDRESS
792 TAD SYMBOL /AND SYMBOL NUMBER
794 TAD TYPE /AND ARG TYPE
796 ISZ ARGCNT /BUMP ARG COUNT
797 JMS I QCOMARP /LOOK FOR , OR )
799 JMP ARGLUP /, GET NEXT ARG
800 TAD FUNNAM /ENTER FUNCTION
802 TAD ARGCNT /FIRST GET ENOUGH ROOM
808 JMS I QLUKUP2 /LOOK UP FUNCTION
811 JMP OKFUN /OK, NOT MULTIPLY DEFINED
812 BADDEF, JMS I QERMSG /BAD DEFINE
815 OKFUN, TAD NEXT /SAVE "NEXT"
817 TAD NEXT /INCREMENT NEXT BY
818 TAD ARGCNT /NUMBER OF ARGS
821 JMS SETFLD /GET ROOM FOR LABEL
822 CLL CML RAR /FOR JUMP AROUND
823 DCA I NEXT /SET DEFINED BIT
825 DCA JAROND /FOR LATER
828 TAD LUFLD /SAVE FIELD OF FUN BLOCK
830 TAD LUFLD /ALSO FIELD OF LABEL
833 AND (70 /ISOLATE BITS
834 CLL RTL /INTO JUMP INSTR
836 JMS I QOUTWRD /OUTPUT IT
837 TAD JAROND /OUTPUT LOW PART
838 JMS I QOUTWRD /OF JUMP ADDR
839 TAD STACK /SAVE STACK
841 TAD ARGCNT /GET COUNT
847 TAD ARGCNT /STORE COUNT FIRST
850 JMS I QPOP /GET ARG TYPE
853 JMS GENTMP /GENERATE A TEMPORARY
854 SWTARG, JMS I QPOP /PURGE SYMBOL NUMBER
856 JMS I QPOP /GET ST ADDR OF
857 DCA STPTR /OF DUMMY ARG
859 TAD SYMBOL /PUT IN TEMP SYMBOL NUMBER
860 DCA I STPTR /TO FAKE EXPR
861 TAD TYPE /CREATE ARG DESCRIPTOR
862 TAD SYMBOL /FOR FUNC BLOCK
864 DCA I X12 /AND PUT IT INTO F.B.
868 AND TEMP2 /SAVE TYPE OF FUNCTION
870 CLL CML RAR /SET DEFINED BIT
871 TAD LOCTRH /AND LOCATION COUNTER
872 DCA I X12 /AT START OF FUNCTION
876 TAD STACK /SAVE BOTTOM OF STACK
878 TAD OLDSTK /RESTORE TO TOP
880 JMS I QCHECKC /FIND =
883 JMS I QEXPR /COMPILE FUNCTION
885 JMS I QLOAD /GET IT INTO AC
886 TAD X13 /RESTORE STACK
888 JMP RESARG /FINISH DEF
889 \f/ DEF PROCESSOR (FINALE)
891 RESARG, TAD I X13 /GET ST ADDR
893 TAD I X13 /PUT BACK CORRECT SYM #
897 ISZ X13 /SKIP OTHER STUFF
899 JMP RESARG /RESTORE NEXT
900 TAD (RET /OUTPUT RETURN CODE
903 CLL CML RAR /SET LABEL DEFINED BIT
904 TAD LOCTRH /STICK IN ADDR
905 DCA I JAROND /OF END OF FUNCT
907 TAD LOCTRL /STORE LOW ADDR
910 TAD TMPCNT /SAVE NEW TEMP LEVELS
914 JMS I QNOREGS /FORGET REGS
915 JMP I QNEWLIN /END OF DEF
916 \f/ DATA STATEMENT PROCESSOR
917 DATA, JMS I QNUMBER /LOOK FOR NUMBER
918 JMP DSTRNG /MUST BE A STRING
919 JMS DENTRY /MAKE AN ENTRY
921 MORDAT, JMS I QCHECKC /LOOK FOR ,
923 JMP I QNEWLIN /END OF DATA
924 JMP DATA /DO NEXT ELEMENT
925 DSTRNG, JMS I QSTRING /LOOK FOR STRING
927 TAD WORD1 /COMPUTE SIZE
930 DCA DSSIZE /INCLUDING CHAR COUNT
931 TAD WORD1 /NEGATE COUNT
934 JMS DENTRY /CREATE ENTRY
936 JMP MORDAT /GO DO MORE
937 DENTRY, 0 /MAKE AN ENTRY IN DATA LIST
938 TAD I DENTRY /GET SIZE
941 TAD TEMP /INCREMENT SIZE COUNT
944 TAD (EOST /HOW MUCH DO WE NEED ?
947 JMS STCHEK /ASK FOR IT
949 TAD FREFLD /GET FIELD OF FREE SPACE
950 DCA LUFLD /SAVE IT IN SETFLD SUBROUTINE
952 TAD NEXT /HOOK IN NEW ENTRY
955 PATCH3, ISZ DATPTR /POINTER THEN FIELD
959 TAD TEMP /SAVE SIZE OF ENTRY
961 TAD (WORD1-1/MAKE READY TO MOVE
969 DCA I NEXT /SAVE ROOM FOR POINTER&CDF
970 TAD NEXT /THIS IS NOW LAST ENTRY
973 DCA DATFLD /AND THIS IS ITS FIELD
979 READX, JMS I QLODSN /OUTPUT STMT NUMBER
980 CLL CML RAR /GET VAR TO READ
981 JMS I QEXPR /SAME AS LEFT SIDE OF LET
983 JMS I QGETA1 /GET VAR INFO FROM STACK
986 TAD TYPE1 /WHAT TYPE ?
989 TAD (NRDL /STRING OR NUMERIC
991 CLL CML RTR /SUBSCRIPTS ?
995 JMS I QLOADSS /YES, LOAD SS REGS
997 TAD (FSTA /ARRAY OR SCALAR STORE
1000 JMS I QCHECKC /ANY MORE ?
1001 -54 /CHECK FOR COMMA
1004 AMPSND, 40;1;AMPRTN-1;4000;SCONTS;SCONTS
1008 FOR, JMS I QLODSN /OUTPUT STMT NUMBER
1009 JMS I QGETNAM /GET INDEX VARIABLE
1011 TAD TYPE /MUST BE NUMBER
1014 JMS I QLOOKUP /ST SEARCH
1015 TAD SYMBOL /SAVE INDEX VAR
1016 DCA FINDEX /FOR LATER
1017 JMS I QCHECKC /FIND =
1020 TAD CHRPTR /SAVE CHAR POSITION
1021 DCA FORCP /IN A SPECIAL PLACE
1025 FINDTO, JMS I QRESTCP /RESTORE CHAR POS
1026 JMS I QGETC /SKIP A CHAR
1029 JMS I QSAVECP /SAVE THIS POSITION
1030 JMS I QCHKWD /LOOK FOR "TO"
1032 JMP FINDTO /KEEP GOING
1033 JMS FSUB2 /LOAD LIMIT AND SAVE IN TEMP
1034 DCA FLIMIT /SAVE LIMIT VAR
1035 JMS I QCHKWD /LOOK FOR "STEP"
1037 JMP STEP1 /USE 1.0 FOR THE STEP
1038 JMS FSUB2 /LOAD STEP AND SAVE IN TEMP
1039 DCA FSTEP /SAVE STEP VAR
1040 TAD (SETJF /OUTPUT SETJF
1042 TAD (JFOR /STEP IS VARIABLE, USE JFOR
1043 SAVEJF, DCA FORJMP /SAVE CORRECT JUMP
1044 JMS I QGETC /ANY MORE CHARS ?
1046 JMP BADFOR /YES, ERROR
1047 TAD FORNC /RESTORE CHAR POSITION
1048 DCA NCHARS /FROM SPECIAL PLACE
1051 JMS FSUB1 /COMPILE INITIAL VALUE INTO FAC
1052 JMS STCHEK /CHECK FOR ROOM
1054 TAD FREFLD /SAVE FIELD OF LABELS
1057 CLL CML RAR /SET LABEL DEFINED BIT
1058 TAD LOCTRH /DEFINE THE LOOP LABEL
1062 CLL CML RAR /SET LABEL DEFINED BIT
1063 DCA I NEXT /FOR END OF LOOP LABEL
1065 TAD FLIMIT /TEST FOR DONE
1066 TAD XSUB /BY SUBTRACTING THE LIMIT
1068 TAD FORFLD /OUTPUT JUMP TO DONE
1070 CLL RTL /SHIFT FIELD BITS
1071 TAD FORJMP /USE PROPER JUMP INS
1073 TAD NEXT /OUTPUT LOW PART OF JMP
1075 TAD FLIMIT /FADD FLIMIT (FADD=0)
1077 TAD FINDEX /FSTA INDEX
1080 TAD FINDEX /PUT STUFF ONTO STACK
1088 ISZ NEXT /BUMP NEXT AGAIN
1089 TAD TMPCNT /RESERVE THESE TEMPS
1091 JMS I QNOREGS /FORGET REGISTORS
1092 TAD STACK /SET NEW STACK LEVEL
1095 STEP1, TAD (3 /1.0 IS SLOT #3
1098 JMP SAVEJF /GO DO THE REST
1099 FLIMIT, 0 /FOR LOOP UPPER LIMIT
1100 FSTEP, 0 /FOR LOOP STEP
1101 FORNC, 0 /FOR STMT CHAR POSITION
1103 WTHEN, -124;-110;-105;-116
1106 USEX, TAD (USE /OUTPUT USE OPERATOR
1108 JMS I QGETNAM /GET ARRAY NAME
1110 TAD TYPE /CHECK TYPE
1111 SMA CLA /(MUST BE NUMERIC)
1113 USEERR, JMS I QERMSG /ERROR IN USE STMT
1115 CLL CML RTR /SET DIM BIT
1117 JMS I QLOOKUP /LOOKUP SYMBOL
1118 TAD SYMBOL /OUTPUT ARRAY NUMBER
1121 \f/ IF AND IFEND PROCESSORS
1123 IF, JMS I QLODSN /OUTPUT STMT NUMBER
1124 JMS I QEXPR /GET LEFT EXPRESSION
1126 JMS I QGETC /GET RELATIONAL OPERATOR
1127 JMP BADIF /ERROR IF NONE
1129 RTL /MOVE TO LEFT HALF
1131 DCA TEMP /AND SAVE IT
1132 JMS I QGETC /GET 2 CHAR RELATIONALS
1134 TAD TEMP /COMBINE THE 2
1136 TAD (IFOPS-1/SETUP POINTER
1138 IFLUP1, TAD I X10 /GET JUMP OPCODE
1140 JMP IFLUP2-1/NOT A 2 CHAR RELATIONAL
1142 TAD I X10 /COMPARE CHARS
1145 JMP IFLUP1 /NOT THIS OOE
1146 GOTREL, JMS I QEXPR /GET RIGHT HALF
1148 CLA CMA /GET TYPE OF RIGHT SIDE
1153 JMP STRCMP /STRING, DO STRING COMPARE
1154 TAD (MINUS /NUMERIC, DO A SUBTRACT
1156 NUMCMP, JMS I QSAVECP /SAVE CHAR POSITION
1157 JMS I QCHKWD /LOOK FOR "THEN"
1159 JMP NOTHEN /NOT THEN
1160 GETIFN, JMS I QSNUM /GET STATEMENT NUMBER
1162 TAD TEMP /OUTPUT JUMP
1165 TAD TEMP2 /TWO WORDS
1168 NOTHEN, JMS I QRESTCP /BACKUP CHAR POS
1169 JMS I QCHKWD /LOOK FOR "GOTO"
1172 JMP GETIFN /OK, GO GET STMT NUMBER
1173 BADIF, JMS I QERMSG /BAD IF STMT
1176 STRCMP, TAD (SCOMPR-1
1177 JMS I QOUTOPR /OUTPUT STRING COMPARE
1178 JMS I QMODSET /BACK TO N MODE
1179 JMP NUMCMP /REST IS LIKE NUMERIC COMPARES
1180 JMS I QBACK1 /PUT BACK NON OPERATOR
1181 IFLUP2, TAD I X10 /GET CONDITIONAL JUMP
1183 JMP BADIF /RELATIONAL INCORRECT
1185 TAD I X10 /COMPARE OPERATORS
1190 IFEND, JMS I QLODSN /OUTPUT STMT NUMBER
1192 JMS GETFN /GET FILE NUMBER
1193 TAD (JEOF /SETUP CORRECT JUMP
1195 JMP NUMCMP /GO FIND "THEN" OR "GOTO"
1197 GETFN, 0 /GET FILE NUMBER
1198 DCA COLON /SAVE COLON SWITCH
1199 JMS I QCHECKC /LOOK FOR #
1201 JMP TTYFIL /NONE, MUST BE TTY
1202 JMS I QEXPR /GET FILE EXPR
1203 JMP I QREMARK /ERROR
1204 TAD COLON /DO WE NEED A COLON ?
1206 JMP .+4 /NO, SKIP THIS TEST
1207 JMS I QCHECKC /YES, LOOK FOR IT
1209 JMP BADFN /NOT THERE, BAD
1210 JMS I QLOAD /LOAD IT
1211 TAD TYPE1 /TYPE MUST BE NUMERIC
1213 BADFN, JMS I QERMSG /NOPE, IT ISN'T
1215 CLA IAC /SET IFNREG TO "NOT TTY"
1216 DCA IFNREG /SAVE NEW IFNREG
1217 TAD (FILENO /OUTPUT SET IFN COMMAND
1220 TTYFIL, TAD IFNREG /IS IFNREG 0 ?
1222 JMP I GETFN /IF YES, QUIT
1223 TAD (CLRFN /OTHERWISE ZERO AC
1225 DCA IFNREG /SET IFNREG TO TTY
1228 GOTO, JMS I QSNUM /GET NUMBER
1230 JMS I QMODSET /ALL GOTO'S IN NMODE
1231 CLA IAC /JUMP=JSUB+1
1233 GOSUB, JMS I QLODSN /OUTPUT STMT NUM LOAD
1234 JMS I QSNUM /GET NUMBER
1236 JMS I QMODSET /ALL GOTO'S IN NMODE
1237 TAD (JSUB /GET GOSUB OPCODE
1238 TAD TEMP /PLUS ADDRESS
1239 JMS I QOUTWRD /OUTPUT IT
1240 TAD TEMP2 /BOTH WORDS
1243 BADGO2, JMS I QERMSG /BAD GOTO OR GOSUB
1244 1615 /NUMBER MISSING
1246 \f/ TABLE SEARCH FOR LITERALS, STMT NUMBERS, TEMPS, ETC.
1249 TAD I LUKUP2 /GET THE BUCKET START
1250 DCA OLDN3 /SAVE IT AS THE PREVIOUS ENTRY
1252 TAD I LUKUP2 /GET THE ENTRY SIZE
1255 TAD (6211 /PRIME THE FIELD SETTER
1257 JMS SETFLD /NOW SET THE FIELD
1258 LOOK2, TAD I OLDN3 /GET ADDR OF NEXT ENTRY
1260 PATCH1, ISZ OLDN3 /GET TO FIELD OF NEW ENTRY
1261 TAD I OLDN3 /GET INTO AC
1262 DCA NEWFLD /AND SAVE IT
1265 JMP HOOKIN /IF 0 ITS END OF LIST
1267 DCA X10 /START OF VALUE INFO
1268 TAD (WORD1-1/SETUP POINTER TO VALUE
1270 TAD N3SIZE /AND TEMP OF ENTRY SIZE
1274 CIA CLL /COMPARE THIS WORD
1275 NEWFLD, CDF 10 /FIELD OF NEW ENTRY
1278 JMP NOTSAM /NOT THIS ONE
1279 ISZ LTEMP /INCR SIZE COUNT
1280 JMP CHKVAL /MORE STUFF
1281 TAD I X10 /GET SYMBOL NUMBER
1284 TAD NEWFLD /MAKE ENTRY ADDRESSABLE
1285 DCA LUFLD /THROUGH SETFLD
1286 ISZ LUKUP2 /BUMP RETURN
1289 JMP HOOKIN /NEW SYMBOL < CURRENT
1290 TAD NEWN3 /GO TO NEXT ENTRY
1291 DCA OLDN3 /(MOVE POINTER)
1292 TAD NEWFLD /(AND FIELD)
1295 HOOKIN, CLL CMA RAL /HOW MANY WORDS NEEDED ?
1299 JMS STCHEK /MAKE SURE
1301 TAD NEWN3 /HOOK IN NEW ENTRY
1302 FREFLD, CDF 10 /CHANGE TO FREE FIELD
1304 PATCH2, TAD NEWFLD /HOOK IN FIELD
1306 JMS SETFLD /BACK TO FIELD OF OLD
1307 TAD FREFLD /PUT FIELD OF NEW
1309 CLA CMA /BACK UP OLDN3
1310 TAD OLDN3 /SO THAT IT POINTS TO POINTER
1313 TAD NEXT /PUT POINTER TO NEW ENTRY
1314 DCA I OLDN3 /INTO OLD
1315 TAD FREFLD /SAVE ENTRY FIELD
1316 DCA LUFLD /FOR POSSIBLE POST PROCESSING
1317 TAD (WORD1-1/PREPARE TO STICK IN THE VALUE
1320 TAD I X11 /MOVE IN THE VALUE
1323 ISZ N3SIZE /INCR SIZE COUNT
1327 STCHEK, 0 /CHECK FOR ENOUGH ROOM
1328 TAD NEXT /CHECK FOR OVERFLOW
1331 TAD I STCHEK /THIS IS LIMIT
1335 TAD FREFLD /BUMP FREE FIELD
1338 TAD FREFLD /PUT IN TWO PLACES
1340 DCA NEXT /START POINTER AT 0
1341 ISZ NFLDS /GONE TOO FAR ?
1343 STOVER, JMS I QERMSG /S.T. FULL
1345 JMP I XABORT /ABORT COMPILATION
1346 OLDN3, 0 /ADDR OF PREVIOUS ENTRY
1347 NEWN3, 0 /ADDR OF NEW ENTRY
1349 NFLDS, 0 /- COUNT OF AVAILABLE FIELDS
1350 N3SIZE, /SIZE OF ENTRY
1351 KBDCHK, 0 /CHECK FOR ^C OR ^O
1353 JMP I KBDCHK /NO CHAR
1355 AND (177 /REMOVE PARITY BIT
1358 JMP I XABORT /YES, EXIT TO OS8
1361 JMP I KBDCHK /NO, RETURN
1362 DCA TTX+1 /NOP TTY OUTPUT ROUTINE
1365 WSTEP, -123;-124;-105;-120;0
1366 \f/ SYMBOL TABLE LOOKUP
1368 LOOKUP, 0 /LOOK UP SYMBOL
1369 TAD NAME1 /GET NAME1*11+NAME2
1375 DCA NAME1 /THIS IS IT
1376 TAD TYPE /WHAT KIND SYMBOL ?
1377 CLL RTL /MOVE TYPE BITS
1378 RTL /INTO AC 9,10,11
1391 LUVAR, TAD (VARCNT /POINTER TO VAR COUNT
1395 DCA STPTR /ST POINTER
1396 CDF 10 /THATS WHERE ST IS
1397 TAD I STPTR /IS THIS VAR DEFINED YET ?
1400 TAD (4401 /GET 401 INTO AC
1402 TAD I VCPTR /PLUS VAR COUNT
1404 DCA SYMBOL /THATS THE NEW SYMBOL NUMBER
1405 TAD SYMBOL /PUT SYMBOL NUMBER
1406 DCA I STPTR /INTO S.T. ENTRY
1408 ISZ I VCPTR /BUMP SYMBOL NUMBER
1409 LURETN, JMP I LOOKUP
1410 JMP STOVER /S.T. OVERFLOW
1411 GOTSYM, DCA SYMBOL /PUT NUMBER INTO SYMBOL
1414 LUSTRG, TAD (SVCNT /POINTER TO STRING VAR COUNT
1417 TAD NAME1 /TWO WORDS PER ENTRY
1419 LUARAY, TAD (ACNT /ARRAY VAR COUNT
1421 TAD (ARAYST /ARRAY SYMBOL TABLE
1424 FINDA, TAD I STPTR /SEARCH TABLE
1426 JMP NEWARY /NEW ENTRY
1428 TAD NAME1 /IS THIS IT ?
1434 ISZ STPTR /GO TO NEXT ENTRY
1436 GOTARY, TAD (37 /GET NUMBER
1438 DCA SYMBOL /INTO SYMBOL
1441 NEWARY, TAD NAME1 /PUT IN NEW ENTRY
1444 TAD (41 /PUT IN NUMBER
1445 JMP CHEKST /GO DO THE REST
1446 LUSARY, TAD (SACNT /STRING ARRAY COUNT
1448 TAD (SARYST /USE STRING ARRAY TABLE
1449 JMP FINDA-2 /GO DO SEARCH
1450 \f/ FILE AND CLOSE PROCESSORS
1451 FILE, JMS I QLODSN /OUTPUT STMT NUMBER
1452 TAD (FOPENS /POINTER TO FILE OPENS
1454 JMS I QCHECKC /LOOK FOR "V"
1457 ISZ FILESW /YUP, INCR FILESW
1458 JMS I QCHECKC /LOOK FOR "N"
1461 ISZ FILESW /INCR FILESW BY TWO IF "N"
1463 JMS GETFN /GET FILE NUMBER
1464 JMS I QEXPR /GET DEVICE/FILE DESCRIPTOR
1466 JMS I QLOAD /LOAD INTO SAC
1467 TAD TYPE1 /TYPE MUST BE STRING
1470 JMS I QERMSG /IT WEREN'T
1472 TAD I FILESW /GET CORRECT OPEN
1475 FOPENS, OPENAF;OPENAV;OPENNF;OPENNV
1477 PLUS, 40;0;XADD;XADD
1478 \f/ EXPRESSION ANALYZER
1480 EXPR, 0 /POLISHIZE EXPRESSION
1482 TAD LEFT /SO WE CAN PUSH OLD VALUE
1484 TAD TEMP /NOW SET NEW VALUE
1485 DCA LEFT /OF THAT SWITCH
1487 JMS I QPUSH /SAVE RETURN ADDR
1488 JMS I QPUSH /MARK STACK
1489 TAD LEFT /IS THIS LEFT SIDE ?
1491 JMP OPRAND+1/YES, NO UNARY MINUS
1492 UNOPR, JMS I QGETC /LOOK FOR UNARY OPERATOR
1493 JMP MISARG /THERE HAS TO BE AN OPERAND
1494 TAD (-53 /UNARY+(NOP)
1499 JMP NOTMIN /NOT UNARY MINUS
1500 TAD (UMOPR /PUSH UNARY MINUS
1503 NOTMIN, TAD (55-50 /LOOK FOR (
1505 JMP OPRAND /NOT A SUB EXPRESSION
1506 JMS I QEXPR /COMPILE SUB EXPRESSION
1507 JMP BADEXP /BAD SUB EXPRESSION
1508 JMS I QCHECKC /LOOK FOR )
1512 JMS I QERMSG /PARENTHESIS MIS MATCH
1515 OPRAND, JMS I QBACK1 /PUT BACK NON UNARY OP
1516 JMS I QGETNAM /LOOK FOR VARIABLE REF
1518 JMS I QLOOKUP /SYMBOL TABLE SEARCH
1519 TAD SYMBOL /SAVE SYMBOL NUMBER
1520 DCA TEMP2 /BECAUSE SAVAC MIGHT KILL IT
1521 JMS I QSAVAC /GENERATE FSTA (MAYBE)
1523 TAD TYPE /WAS THIS A FUNCTION OR ARRAY ?
1526 JMP FUNSS /YES, GO PROCESS IT
1527 TAD TYPE /MAKE OPERAND STACK ENTRY
1529 TAD TEMP2 /FIRST TYPE THEN SYMBOL #
1531 OPR8R, TAD LEFT /LEFT SIDE ?
1532 SMA CLA /YES, NO OPERATORS LEGAL
1533 JMS I QGETC /LOOK FOR OPERATOR
1534 JMP ENDEXP /END OF EXPR
1535 TAD (-52 /** IS SPECIAL CASE
1538 JMS I QGETC /LOOK FOR SECOND *
1542 TAD (136-52 /** -> ^
1544 JMS I QBACK1 /PUT IT BACK
1545 NOSTAR, TAD (52 /RESTORE CHAR
1548 DCA X10 /PTR TO LIST
1549 OPRLUP, TAD I X10 /GET OPERATOR PTR
1551 JMP ENDEXP-3/END OF LIST
1552 DCA NEWOP /SAVE IT IN CASE
1556 JMP OPRLUP /KEEP LOOKING
1557 GOTOPR, JMS I QPOP /GET STACK TOP
1561 TAD I OLDOP /COMPARE PREC.
1563 TAD I NEWOP /NEW-OLD
1567 PUSH2, JMS I QPUSH /OLD < NEW
1568 TAD NEWOP /GO PUSH BOTH
1570 JMP UNOPR /GO LOOK FOR NEXT OPERAND
1571 OUTOLD, TAD OLDOP /OUTPUT CODE FOR OLD OPR8R
1573 JMP GOTOPR /LOOK AT NEXT TOP OF STACK
1574 JMS I QBACK1 /PUT BACK NON OPERATOR
1576 JMS I QOUTOPR /OUTPUT OPERATOR
1577 ENDEXP, JMS I QPOP /LOOK FOR STACK MARK
1579 JMP ENDEXP-1/NOT THIS
1580 JMS I QPOP /GET RETURN ADDR
1583 JMS I QPOP /GET LEFT SIDE SWITCH
1586 MISARG, JMS I QERMSG /MISSING OPERAND
1589 MINUS, 40;0;XISUB;XSUB
1590 SLASH, 50;0;XIDIV;XDIV
1591 \f/ EXPRESSION ANALYZER (HANDLE SUBSCRIPTS)
1593 FUNSS, AND (1000 /IS IT FUN CALL ?
1596 JMS I QSAVAC /YES, SAVE AC
1600 TAD TEMP2 /AND SYMBOL NUMBER
1602 TAD STPTR /AND SYMBOL TABLE PTR
1605 SSLOOP, JMS I QPOP /GET ARG/SS COUNT
1607 JMS I QPUSH /INCREMENT IT
1608 JMS I QEXPR /GET NEXT ARG/SS
1610 JMS I QGETA1 /IS THIS ARG(SS) AN ARRAY REF ?
1612 AND TYPE1 /CHECK THE TYPE
1614 JMP NOTSSD /NOT AN ARRAY REFERENCE
1615 JMS I QLOADSS /LOAD THE SS REGS
1616 JMS I QSAVAC /SAVE AC IF NEEDED
1618 TAD TYPE1 /SET THE MODE
1620 TAD (AFLDA /LOAD THIS ARG/SS
1623 TAD Q400 /SET THE IN-AC BIT
1624 TAD MODE /WE JUST CALLED MODSET
1625 DCA I OSTACK /CHANGE THIS STACK ENTRY
1627 NOTSSD, ISZ OSTACK /FIX UP OSTACK
1629 JMS I QCOMARP /LOOK FOR , OR )
1630 JMP BADFSS /NEITHER IS BAD
1631 JMP SSLOOP /, MEANS MORE ARGS/SS
1632 JMS I QPOP /GET # OF ARG/SS
1633 DCA TEMP /GET ARG/SS COUNT
1634 JMS I QPOP /RESTORE S.T. ADDR
1637 DCA SYMBOL /GET BACK THE SYMBOL #
1639 DCA TYPE /GET BACK THE TYPE
1640 TAD TYPE /IS IT AN ARRAY OR FUN REF ?
1643 JMP DOCALL /FUNCTION REFERENCE
1644 TAD TEMP /MOVE SS COUNT
1645 CLL RTR /INTO THE CORRECT
1647 DCA TEMP2 /AND SAVE IT
1649 TAD I STPTR /ANY PREV REFERENCE ?
1652 JMP NOTNEW /YES, GO CHECK NUMBERS
1653 TAD TEMP2 /IF NONE, PUT IN NUMBER
1657 NOTNEW, CIA /COMPARE NUMBER OF SS
1658 TAD TEMP2 /WITH ANY PREVIOUS
1660 JMP BADFSS+3/THEY DON'T MATCH
1663 TAD TEMP /AND DIM COUNT
1664 ONSTAK, JMS I QPUSHO /ONTO ARGUMENT STACK
1666 JMS I QPUSHO /AND SYMBOL NUMBER
1667 JMS I QSAVAC /SAVE FIRST SS IF LEFT IN AC
1669 JMP OPR8R /GO GET AN OPERATOR
1670 BADFSS, TAD (-4 /PURGE STACK JUNK
1673 JMS I QERMSG /PUT ERROR MESSAGE
1675 BADEXP, JMS I QPOP /LOOK FOR STACK MARK
1678 JMS I QPOP /RETURN ADDR
1680 JMS I QPOP /SS LOAD SWITCH
1682 JMP I TEMP /TAKE ERROR EXIT
1683 WTAB, -124;-101;-102;-50
1684 NOTVAR, TAD LEFT /LEFT SIDE ?
1686 JMP MISARG /YES, NO LITERALS LEGAL
1687 JMS I QNUMBER /LOOK FOR LITERAL
1688 JMP NOTNUM /NOT A NUMBER
1689 JMS I QLUKUP2 /SEARCH LITERAL TABLE
1692 JMS NEWVAR /IF NEW, GIVE IT NUMBER
1693 JMP ONSTAK /GO PUT IT ONTO THE STACK
1694 NOTNUM, JMS I QSTRING /LOOK FOR STRING LITERAL
1695 JMP MISARG /NO, MISSING ARG
1696 TAD WORD1 /GET -NUMBER WORDS - 1
1700 JMS I QLUKUP2 /LOOK UP LITERAL
1703 JMS NWSVAR /IF NEW, GIVE IT NUMBER
1704 CLL CML RAR /SET TYPE BIT FOR STRING
1705 JMP ONSTAK /PUT INFO ONTO STACK
1707 UPAROW, 60;1;EXPRTN-1
1708 \f/ EXPRESSION ANALYZER (HANDLE FUNCTION CALLS)
1710 DOCALL, TAD LEFT /IS THIS LEFT SIDE ?
1711 SMA CLA /IF YES, FUN ILLEGAL
1712 JMS OUTCAL /GENERATE CALL
1714 JMP OPR8R /GO LOOK FOR OPERATOR
1715 JMS I QERMSG /BAD FUNCTION REFERENCE
1718 OUTCAL, 0 /GENERATE FUN CALL; TYPE,
1719 /SYMBOL AND TEMP ARE INPUTS
1720 TAD SYMBOL /SAVE FUNCTION NUMBER AROUND SAVAC
1722 JMS I QSAVAC /SAVE SECOND FROM TOP
1724 TAD FUNNUM /SETUP FOR FINDING FUNCTION
1725 DCA WORD1 /INFO BLOCK
1726 JMS I QLUKUP2 /ON THE FUNCTION LIST
1729 JMP I OUTCAL /UNDEFINED FUNCTION
1730 TAD SYMBOL /CHECK NUMBER OF ARGS
1734 MOVARG, JMS I QLOAD /GET TOP OF STACK INTO AC
1735 JMS SETFLD /GET FIELD OF FORMAL-PARAMS
1736 TAD I X10 /GET FIRST ONE
1739 CLL CML RAR /COMPARE TYPE OF ARG
1740 AND TYPE1 /WITH THAT OF FORMAL PARAMETER
1742 SPA CLA /THEY MUST MATCH
1743 JMP I OUTCAL /(THEY DON'T)
1744 CLL CML RTR /SHOULD WE LEAVE IT IN THE AC ?
1747 JMP OKINAC /YES, SAVES AN INSTRUCTION
1749 JMS I QMODSET /APPROPRIATELY
1751 AND TEMP /GET SYM NUMBER
1752 TAD (FSTA /STORE VALUE IN FORM PARAM
1754 OKINAC, ISZ SYMBOL /MORE ARGS ?
1757 TAD I X10 /GET TYPE OF FUNCTION
1758 DCA TYPE1 /(ITS RESULT THAT IS)
1760 TAD TYPE /IS TYPE OF FUNCTION
1761 TAD TYPE1 /SAME AS TYPE OF CALL
1763 JMP I OUTCAL /NO, ERROR
1764 JMS I QMODSET /ALL CALLS IN N MODE
1765 TAD WORD1 /CHECK FOR USER FUNCTION
1767 JMP CALLUF /YES, DO SPECIAL CALL
1768 FINCAL, ISZ OUTCAL /FIX RETURN
1769 JMS I QOUTWRD /OUTPUT CODE
1770 TAD Q400 /SET TOP OF STACK
1773 DCA I OSTACK /SYMBOL NUMBER IS MEANINGLESS
1775 AND TYPE1 /INTERPRETER MODE SAME
1776 DCA MODE /AS FUNCTION TYPE
1777 JMP I OUTCAL /ON RETURN
1778 CALLUF, JMS I QNOREGS /FORGET REGS ON USER FUNC
1779 TAD LUFLD /OUTPUT JSUB
1780 AND (70 /WITH POINTER TO
1781 CLL RTL /DOUBLE WORD
1782 TAD (JSUB /VALUE OF LOCATION
1783 JMS I QOUTWRD /COUNTER FOR THE
1784 TAD X10 /START OF THE
1785 IAC /USER "DEF"INED FUNC
1787 FSUB1, 0 /FOR SUBROUTINE #1
1788 JMS I QEXPR /GET AN EXPRESSION
1790 JMS I QLOAD /LOAD VALUE
1791 TAD TYPE1 /MUST BE NUMERIC
1794 BADFOR, JMS I QERMSG /BAD FOR LOOP PARAMETERS
1797 FSUB2, 0 /FOR SUBROUTINE #2
1798 JMS FSUB1 /GET EXPR AND LOAD IT
1799 JMS GENTMP /MAKE A TEMP FOR IT
1800 TAD SYMBOL /STORE EXPR IN TEMP
1803 TAD SYMBOL /RETURN SLOT #
1806 NOREGS, 0 /FORGET REGISTORS
1807 CLA IAC /FILE NUMBER REG
1809 / CMA /SUBSCRIPT REG #1
1811 / CMA /SUBSCRIPT REG #2
1814 CLOSE, JMS I QLODSN /OUTPUT STMT NUMBER
1815 CLA IAC /NO COLON NEEDED AFTER FILE NUM
1816 JMS GETFN /GET FILE NUM
1817 TAD (CLOSEF /OUTPUT CLOSE
1823 JMS I QPOP /GET INDEX VAR
1826 DIMREAD,JMS I QLOADSS /PATCH TO INPUT PROC. SET UP SS REG
1827 TAD (READ /OUTPUT INSTR
1830 JMP I (FININP /RESUME IN LINE
1833 OUTOPR, 0 /OUTPUT CODE FOR OPERATOR
1834 DCA X10 /SAVE POINTER TO SKELETON
1835 TAD I X10 /GET CONTROL WORD
1837 JMP SPCIAL /TREAT AS SPECIAL CASE
1838 DCA TYPE /ITS THE TYPE ALLOWANCE
1839 TAD (XLOAD /GET SKEL ADDRS
1840 DCA CASEMM /FOR THE THREE CASES
1845 TAD TYPE /ENTER CORRECT MODE
1847 CLL CMA RAL /GET THE SECOND OPERAND
1851 DCA X10 /BY BACKING UP THE STACK
1855 DCA SYMBL2 /SYMBOL NUMBER
1859 TAD TYPE2 /LOOK AT OPERAND 2
1862 JMP MAC /MUST BE CASE M,AC
1863 CLL CML RTR /ITS IN MEMORY, IS IT SS'D
1866 JMP A2OK /NO, ITS SCALAR
1867 JMS I QLOADSS /LOAD NECESSARY SS REGS
1868 ISZ CASEMM /FIXUP THE SKELETON POINTERS
1870 A2OK, JMS GETA1 /GET STUF FOR ARG1
1871 TAD TYPE1 /LOOK AT IT
1874 JMP ACM /ITS CASE AC,M
1875 MM, TAD I CASEMM /ITS CASE M,M LOAD OPERAND 2
1879 MAC, JMS GETA1 /GET STUF FRO ARG1
1880 CLL CML RTR /IS IT SS'D ?
1883 JMP A1OK /NO, ITS SCALAR
1884 JMS I QLOADSS /LOAD THE SS REGS
1885 ISZ CASEMA /BUMP SKELETON ADDR
1886 A1OK, TAD I CASEMA /GET CORRECT INSTRUCTION
1887 TAD SYMBL1 /PLUS SYMBOL NUMBER
1888 TYPCHK, JMS I QOUTWRD /OUTPUT IT
1889 CLL CML RAR /TYPES OF OPERANDS MUST MATCH
1893 JMP MIXED /THEY DON'T
1894 TAD TYPE /TYPE OF OPERATOR
1895 TAD TYPE1 /MUST MATCH
1896 SPA CLA /THAT OF OPERANDS
1897 JMP MIXED /THEY DON'T
1898 TAD Q400 /GENERATE STACK ENTRY
1901 DCA I OSTACK /THIS IS SAFE
1903 ACM, TAD I CASEAM /ITS CASE AC,M
1904 TAD SYMBL2 /GEN OPERATION FOR OPERAND 2
1905 JMP TYPCHK /GO FINISH IT UP
1906 MIXED, JMS I QERMSG /MIXED TYPES
1909 SPCIAL, TAD I X10 /GET ADDR OF SPECIAL RTNE
1910 DCA TEMP /(PLUS 1 FROM THE TYPE WORD)
1911 JMP I TEMP /HANDLE SPECIAL CASE
1912 GETA1, 0 /GET STUFF FOR ARG 1
1913 CLL CMA RAL /BACK UP STACK
1918 TAD I X11 /GET TYPE1
1920 TAD I X11 /GET SYMBL1
1922 TAD TYPE1 /GET SS COUNT
1926 UMRTNE, JMS I QSAVAC /SAVE CURRENT AC IF NEEDED
1928 JMS I QLOAD /GET ARG IN AC
1929 DCA TYPE /TYPE MUST BE NUMERIC
1931 TAD (FNEG /DO NEGATE
1933 EXPRTN, DCA TYPE /SET FUNC TYPE
1934 CLL CML RTL /SET NUMBER OF ARGS
1938 JMS OUTCAL /OUTPUT FUNCTION CALL
1946 RETURN, JMS I QLODSN /OUTPUT STMT NUM LOAD
1947 JMS I QMODSET /ALWAYS RETURN IN N MODE
1949 RANDOM, TAD (RNDO-STOP
1950 STOPX, TAD (STOP /RETURN, RANDOMIZE, OR STOP
1953 \f/ LETTER AND DIGIT SCANNERS
1955 LETTER, 0 /SKIP ON LETTER
1957 JMP I LETTER /NO LETTER
1958 TAD (-133 /MUST BE .LT. 133
1961 TAD (133-100/MUST BE .GT. 100
1964 AND (77 /RESTORE 6 BITS
1965 ISZ LETTER /BUMP RETURN ADDR
1967 NOLETR, JMS I QBACK1 /PUT CHAR BACK
1969 DIGIT, 0 /SKIP ON DIGIT
1971 JMP I DIGIT /NO DIGIT
1972 TAD (-72 /MUST BE .LT. 72
1973 O7100, CLL /(USED AS LITERAL BY "TTY")
1974 TAD (72-60 /MUST BE .GE. 60
1977 ISZ DIGIT /RETURN DIGIT MINUS 60
1979 NODIGT, JMS I QBACK1 /PUT IT BACK
1981 \f/ STATEMENT NUMBER GETTER
1982 SNUM, 0 /GET A STATEMENT NUMBER
1983 DCA TEMP /SAVE DEFINED SWITCH
1984 JMS I QDIGIT /GET FIRST DIGIT
1985 JMP I SNUM /NO STATEMENT NUMBER
1986 DCA WORD2 /THIS WILL BE THE BUCKET
1988 CLL RAL /TWO WORDS PER BUCKET
1991 ISZ SNUM /OK, ITS A STMT NUMBER
1992 TAD (-4 /FIVE DIGITS MAX
1994 DCA WORD1 /CLEAR TOP WORD
1995 SNLOOP, JMS I QDIGIT /GET NEXT DIGIT
1996 JMP GOTSN /END OF NUMBER
1998 TAD (-4 /SET SHIFT COUNT
2000 SHIFT, TAD WORD2 /SHIFT LEFT ONE BIT
2006 ISZ ACO /BUMP SHIFT COUNTER
2008 TAD WORD2 /PUT IN NEW DIGIT
2011 ISZ TEMP2 /BUMP DIGIT COUNT
2013 GOTSN, JMS I QLUKUP2 /FIND STMT NUMBER
2016 JMP NEWSN /ITS A NEW STMT NUM
2017 CLL CML RAR /CHECK FOR MULTIPLY DEFINED
2021 JMP MDLABL /YES, IT IS
2022 TAD X10 /GET ADDR OF LABEL VALUE
2024 JMS SETFLD /GET TO FIELD OF ENTRY
2025 TAD TEMP /OR IN THESE BITS
2029 TAD LUFLD /GET FIELD BITS
2032 DCA TEMP /INTO A CONVIENIENT
2034 NEWSN, JMS SETFLD /GET FIELD
2035 TAD TEMP /PUT IN BITS
2037 TAD NEXT /SAVE N3 ADDR
2039 DCA I NEXT /1 EXTRA WORD
2041 MDLABL, JMS I QERMSG /MULTIPLY DEFINED
2044 TTY, 0 /CONVERT TO ASCII AND PRINT
2045 AND (77 /SIX BITS ONLY
2046 TAD (-40 /WHAT SIDE OF FORTY ?
2052 TTX, 0 /PRINT CHAR ON TTY
2053 SKP /(CONTROL O ZEROES THIS WORD)
2054 JMP .+4 /(THUS KILLING ERROR REPORTING)
2061 CHAIN, JMS I QLODSN /OUTPUT STMT NUMBER
2062 JMS I QEXPR /GET CHAIN STRING
2064 JMS I QLOAD /INTO SAC
2065 TAD TYPE1 /TYPE MUST BE STRING
2067 JMS I QERMSG /IT WASN'T
2068 0616 /(OK IF ERROR CODE IS NOP)
2069 TAD (CHN /OUTPUT CHAIN OPCODE
2073 \f/ SEVERAL SHORT UTILITY ROUTINES
2075 BACK1, 0 /BACK UP ONE CHAR
2083 GETCWB, 0 /GET A CHARACTER (PRESERVE BLANKS)
2087 DCA NCHARS /RESET NCHARS
2090 TAD I CHRPTR /GET THE CHAR
2092 SAVECP, 0 /SAVE CHAR POSITION
2098 RESTCP, 0 /RESTORE CHAR POS
2104 GETC, 0 /GET A CHARACTER (IGNORING BLANKS)
2111 TAD (-40 /IS IT A BLANK
2113 JMP GETC+1 /YES IGNORE IT
2117 POP, 0 /GET TOP OF STACK
2122 DCA STACK /DECREMENT STACK POINTER
2125 PUSH, 0 /PUT AC ONTO STACK
2127 TAD (-STACKA-STAKSZ+1
2128 TAD STACK /CHECK FOR OVERFLOW
2130 JMP I PUSH /OK, RETURN
2131 STKOVR, JMS I QERMSG
2133 JMP I XABORT /ABORT COMPILATION
2134 PUSHO, 0 /PUSH OPERAND STACK
2135 DCA I OSTACK /PUSHIT
2136 TAD (-STACKO-STOKSZ+1
2137 TAD OSTACK /CHECK FOR STACK OVERFLOW
2140 JMP STKOVR /TOO FULL
2141 COMARP, 0 /SKIP ON COMA OR RITE PAREN
2142 JMS I QGETC /GET CHAR
2146 ISZ COMARP /RITE PAREN, SKIP 2
2148 TAD (51-54 /CHECK FOR ,
2150 ISZ COMARP /, SKIP 1
2152 JMS I QBACK1 /NEITHER PUT BACK
2154 LOAD, 0 /LOAD SAC OR FAC
2155 JMS I QGETA1 /GET TOP OF STACK
2158 TAD TYPE1 /IS IT IN THE AC?
2162 CLL CML RTR /SUBSCRIPTED ?
2166 JMS I QLOADSS /FILL SS REGS
2168 TAD (FLDA /ARRAY OR SCALAR LOAD
2169 TAD SYMBL1 /PLUS SYMBOL NUMBER
2172 IFOPS, JNE;-7476 /<>
2185 \f/ TEMP GENERATORS AND AC SAVING ROUTINES
2187 GENTMP, 0 /GENERATE A TEMP
2189 JMP STRTMP /ITS A STRING TEMP
2191 ISZ TMPCNT /BUMP COUNT
2193 JMS I QLUKUP2 /LOOK UP THIS TEMP
2196 JMS NEWVAR /NEW ONE ON ME
2199 ISZ STMPCT /BUMP COUNT
2201 JMS I QLUKUP2 /LOOK UP THIS TEMP
2204 JMS NWSVAR /NEW STRING TEMP
2206 NEWVAR, 0 /MAKE SYM NUM FOR VAR
2207 TAD VARCNT /PUT SYM NUM
2209 DCA SYMBOL /INTO SYMBOL
2210 TAD SYMBOL /AND INTO ST ENTRY
2214 ISZ VARCNT /BUMP COUNT
2215 JMP I NEWVAR /RETURN WITH SYM NUM
2216 JMP STOVER /S.T. OVERFLOW
2217 NWSVAR, 0 /MAKE SYM NUM FOR VAR$
2218 TAD SVCNT /PUT SYM NUM
2221 TAD SYMBOL /INTO SYMBOL AND
2223 DCA I NEXT /S.T. ENTRY
2225 ISZ SVCNT /OVERFLOW ?
2226 JMP I NWSVAR /NO, WE'RE OK
2228 SAVAC, 0 /SAVE FAC (OR SAC) IF NECESSARY
2229 TAD I SAVAC /GET ENTRY POINTER
2232 DCA SVTEMP /ADDR OF TYPE WORD
2233 TAD I SVTEMP /LOOK AT IT
2236 JMP I SAVAC /NOT IN AC
2237 CLL CML RAR /SAVE STRING BIT ONLY
2238 AND I SVTEMP /OF TYPE WORD
2241 JMS GENTMP /GENERATE TEMP
2243 JMS I QMODSET /SET MODE
2245 TAD SYMBOL /GENERATE STORE
2247 TAD SYMBOL /RETURN S.T. NUMBER
2248 ISZ SVTEMP /MOVE TO SYMBOL NUM WORD
2249 DCA I SVTEMP /SAVE THE TEMP NUM THERE
2250 JMP I SAVAC /RETURN WITH SAVE MADE
2253 \f/ SUBSCRIPT REGISTER LOADING ROUTINE
2254 LOADSS, 0 /LOAD SS REGS
2255 CLL CMA RAL /LOOK AT NUMBER OF SS
2260 JMP TOOMNY /MORE THAN 2
2261 JMS SSLOAD /LOAD SS REG 1
2264 JMS SSLOAD /LOAD SS REG 2
2265 JMS SSLOAD /NOW SS REG 1
2268 TOOMNY, JMS I QERMSG /SUBSCRIPTING ERROR
2271 SSLOAD, 0 /LOAD A SS REG FROM TOP OF STACK
2272 DCA TEMP2 /SS REG 1 OR 2 SWITCH
2273 CLL CMA RAL /BACK UP ONE ENTRY
2274 TAD OSTACK /ON THE OPERAND STACK
2277 DCA X11 /USE X11 TO GET STUFF
2278 TAD I X11 /GET TYPE WORD
2280 JMP SSTYPE /SS MUST BE A NUMBER
2281 AND Q400 /GET AC BIT
2283 JMP SSINAC /ITS IN THE AC
2287 TAD (LSS1 /LOAD REG 1 OR 2 ??
2288 TAD I X11 /ANYHOW, THIS IS THE SOURCE
2289 JMS I QOUTWRD /OUTPUT THE CODE
2292 TAD (LSS1AC /NOTE: LSS2AC=LSS1AC+1
2293 JMS I QOUTWRD /SO OUTPUT ONE OF THEM
2296 XSCOMP, SCOMP;SACOMP
2306 STAR, 50;0;XMUL;XMUL
2307 \f/ NUMERIC CONVERSION ROUTINE (PART ONE)
2309 NUMBER, 0 /GENERAL NUMBER CONVERSION ROUTINE
2310 DCA DECPT /ZERO DECIMAL POINT SWITCH
2315 DCA SIGN /CLEAR SIGN SWITCH
2318 JMS I QGETC /GET A CHAR
2319 JMP I NUMBER /NO CHAR IS NO NUMBER
2320 JMS CHKSGN /CHECK FOR SIGN
2321 SIGN, 0 /THIS SWITCH GETS SET
2322 DCA NDIGIT /ZERO DIGIT COUNT
2323 CONVLP, JMS I QDIGIT /GET A DIGIT
2324 JMP TRYDEC /IS THERE A DECIMAL POINT ?
2325 DCA NXTDGT /SAVE THE DIGIT
2327 ISZ NDIGIT /INCR NUMBER OF DIGITS
2328 TAD WORD2 /PREPARE TO MULT BY 10
2334 JMS I (AL1 /DOUBLE FAC
2335 JMS I (AL1 /DOUBLE AGAIN
2336 JMS I (OADD /TIMES FIVE
2337 JMS I (AL1 /ONE MORE DOUBLING IS TIMES 10
2339 DCA OP3 /PUT NEWEST DIGIT INTO OPERAND
2342 JMS I (OADD /ADD IN NEWEST DIGIT
2344 TRYDEC, TAD DECPT /DECIMAL ALREADY ?
2346 JMP TRYE2 /YES, LOOK FOR EXPONENT
2347 JMS I QGETC /LOOK FOR .
2348 JMP DIGTST /SEE IF THERE WAS ANYTHING
2351 JMP TRYE1 /TRY FOR E
2352 ISZ DECPT /SET DECIMAL POINT SW
2353 JMP CONVLP-1/LOOP FOR OTHER DIGITS
2354 TRYE1, JMS I QBACK1 /PUT BACK NON .
2355 DIGTST, TAD NDIGIT /ANY DIGITS YET ?
2357 JMP I NUMBER /NO, NO NUMBER
2358 TRYE2, JMS I QGETC /LOOK FOR E
2359 JMP NOEXP+1 /GO HANDLE EXPONENT
2360 TAD WSTEP+2 /USE PART OF "STEP" LITERAL
2362 JMP NOEXP /NO EXPONENT
2363 GETEXP, DCA ESIGN /ZERO EXPONENT SIGN SWITCH
2364 JMS I QGETC /GET A CHAR
2365 JMP NOEXP /TREAT AS NO EXPONENT
2366 JMS CHKSGN /IS IT A SIGN
2368 ESIGN, 0 /THIS IS THE SWITCH TO SET
2369 JMS SMLNUM /GO GET THE EXPONENT
2370 FIXEXP, TAD ESIGN /CHECK EXPONENT SIGN
2373 TAD EXPON /COMPLEMENT EXPONENT
2376 NOEXP, JMS I QBACK1 /PUT BACK NON E
2377 DCA EXPON /ZERO EXPONENT
2378 TAD (43 /NORMALIZE THE NUMBER
2381 TAD DECPT /WAS THERE A DECIMAL POINT ?
2383 TAD NDIGIT /HOW MANY DIGITS TO THE RIGHT ?
2385 TAD EXPON /SUBTRACT THAT NUMBER FROM EXP
2387 JMP POSEXP /EXPONENT IS POSITIVE
2389 DCA EXPON /ONLY NEED ABS VALUE
2390 TAD (FPDIV /DO DIVIDES
2393 TAD (FPMUL /DO MULTIPLIES
2394 DCA FPRTNE /MULTIPLY/DIVIDE ROUTINE
2396 DCA X11 /POWERS OF TEN TABLE
2397 EXPMUL, TAD EXPON /LOOK AT THE EXPONENT
2399 JMP DOSIGN /IF 0 ITS THRU
2401 DCA EXPON /PUT LOWEST BIT INTO LINK
2403 JMP SKPEXP /THIS ONE DOESN'T COUNT
2404 TAD I X11 /MOVE FACTOR INTO OPERAND
2412 JMS I FPRTNE /MULTIPLY OR DIVIDE BY THIS FACTOR
2413 JMP EXPMUL /CHECK NEXT BIT
2414 SKPEXP, TAD X11 /SKIP OVER THIS FACTOR
2417 DOSIGN, TAD SIGN /CHECK THE SIGN
2419 JMS I (NEGFAC /NEGATE IF NEGATIVE
2420 ISZ NUMBER /BUMP RETURN
2421 JMP I NUMBER /RETURN
2424 /INPUT DEVICE HANDLER
2427 \f/INITIALIZATION CODE FOR RUN CASE
2429 RUNNED, CIF 10 /COME HERE IF .R BCOMP
2430 JMS I (200 /CALL COMMAND DECODER
2432 0201 /ASSUMED EXTENSION "BA"
2434 TAD I (7644 /TEST FOR /V
2444 SNA CLA /NULL INPUT?
2445 JMP RUNNED /YES: NAUGHTY
2447 CLL RAL /BATCH RUNNING
2457 DCA .+1 /CDF TO BATCH FIELD
2461 DCA I X10 /SAVE BOS WRDS IN INFO AREA
2464 DCA I X10 /ZERO EDITOR BLOCK NUMBER
2466 FINDSV, TAD I X11 /LOOKUP SOME SAVE FILES
2468 JMP LUBUF /GO LOOK FOR BASIC.UF
2469 DCA XXXXSV /SAVE POINTER TO NAME
2470 CLA IAC /THEY'RE ON SYS
2477 TAD XXXXSV /GET STARTING BLOCK
2480 DCA I X10 /INTO INFO AREA
2485 JMS I (200 /LOOKUP BASIC.UF
2487 BUFN /(USER DEFINED FUNCTIONS)
2489 JMP .+3 /OK IF NOT THERE
2490 TAD .-3 /GET STARTING BLOCK +1
2493 DCA I X10 /INTO INFO BLOCK
2495 CLA IAC /ENTER TEMPORARY FILE
2502 TAD TMPBLK /SAVE START OF TEMP FILE
2504 TAD TMPBLK /IN A COUPLE PLACES
2506 TAD TMPBLK+1/ALSO THE SIZE
2508 JMP GETDEV /GO FETCH DEVICE HANDLER
2530 TSF /WAIT FOR TTY TO GET DONE
2531 JMP .-1 /BEFORE RETURNING
2534 VTEXT, TEXT /BCOMP V/
2536 VERLOC, VERSON^100+6001
2538 \f/ NUMERIC CONVERSION ROUTINE (PART TWO)
2540 FPMUL, 0 /FLOATING MULTIPLY ROUTINE
2541 TAD WORD1 /COMPUTE NEW EXPONENT
2544 TAD WORD2 /SAVE AC MANTISSA
2548 TAD (-30 /SET ITERATION COUNTER
2550 DCA WORD2 /ZERO FAC MANTISSA
2553 MULLUP, JMS I (AR1 /SHIFT FAC RIGHT ONE
2554 TAD TW2 /SHIFT MULTIPLIER RIGHT
2561 JMS OADD /ADD IF LINK IS ONE
2562 ISZ ITRCNT /BUMP COUNT
2564 TAD OP1 /PUT IN CORRECT EXPONENT
2566 JMS ANORM /NORMALIZE THE RESULT
2573 ANORM, 0 /NORMALIZE FAC
2574 TAD WORD2 /IS MANTISSA 0 ?
2580 JMP ZEXP /YES, ZERO EXPONENT
2581 NORMLP, CLA CLL CML RTR /IS HIGH ORDER MANTISSA = 6000
2584 JMP NO6000 /NO, SKIP THIS CRAP
2585 TAD WORD3 /YES, IS THE REST 0 ?
2588 SZA CLA /SKIP IF 600000 ... 0000
2590 JMP I ANORM /NORM IS DONE WHEN BITS DIFFER
2591 JMS I (AL1 /SHIFT LEFT ONE
2592 CLA CMA /DECREMENT EXPONENT
2598 NEGFAC, 0 /NEGATE FAC
2599 TAD (ACO /GET POINTER TO OPERAND
2601 CLL CMA RTL /THREE WORD NEGATE
2605 TAD I NFPTR /GET NEXT WORD
2607 DCA I NFPTR /RESTORE AFTER COMPLEMENTING
2608 CML CLA CMA /LINK GETS COMPLEMENTED ONCE HERE
2609 TAD NFPTR /AND ONCE AGAIN HERE
2610 DCA NFPTR /RESTORE DECREMENTED POINTER
2616 JMS I (AR1 /UNNORMALIZE AC BY ONE
2617 TAD OP1 /COMPUTE FINAL EXPONENT
2620 DCA OP1 /AND SAVE IT
2621 TAD (-30 /SET ITERATION COUNTER
2624 RAL /INITIALIZE LINK
2625 FPDVLP, CLA RAR /COMPARE SIGNS
2629 TAD (OPO-ACO/NEGATE OPERAND
2631 JMS OADD /ADD OPERAND AND FAC
2638 JMS I (AL1 /LEFT SHIFT FAC ONE
2639 ISZ ITRCNT /TEST ITERATION COUNT
2641 TAD OP1 /PUT QUOTIENT INTO FAC
2648 JMS ANORM /NORMALIZE
2650 OADD, 0 /ADD OPERAND TO FAC
2665 \f/ NUMERIC CONVERSION ROUTINE (FINALE)
2667 SMLNUM, 0 /INPUT A NUMBER <= 4095
2668 EXPLUP, DCA EXPON /ZERO THE EXPONENT
2669 JMS I QDIGIT /GET THE NEXT DIGIT
2670 JMP I SMLNUM /NUMBER DONE
2671 DCA OPO /SAVE THE DIGIT
2672 TAD EXPON /MULT BY 10
2677 TAD OPO /ADD IN DIGIT
2678 JMP EXPLUP /STORE BACK INTO EXPONENT
2679 AR1, 0 /SHIFT FAC RIGHT 1 BIT
2692 AL1, 0 /SHIFT FAC LEFT ONE
2703 CHKSGN, 0 /CHECK FOR SIGN
2706 ISZ I CHKSGN /YES, SET SWITCH
2708 TAD (55-53 /IS IT + ?
2710 JMS I QBACK1 /RETURN CHAR OTHERWISE
2712 \f/ STRING LITERAL SCANNER
2713 STRING, 0 /LOOK FOR A STRING
2714 JMS I QCHECKC /LOOK FOR "
2716 JMP I STRING /NONE MEANS NO STRING
2718 DCA WORD1 /ZERO CHAR COUNT
2719 TAD (WORD2 /SETUP POINTER
2721 TAD (-STRLIM%2 /AND MAX SIZE
2723 SLOOP, JMS GCS /GET HIGH ORDER CHAR
2724 JMP I STRING /END OF STRING
2728 DCA I TEMP /PUT INTO UPPER HALF OF WORD
2729 JMS GCS /GET LOWER CHAR
2730 JMP PUT40 /FILL LAST WORD WITH BLANK
2731 TAD I TEMP /COMBINE THEM
2733 ISZ TEMP /BUMP POINTER
2734 ISZ TEMP2 /TOO BIG YET ?
2736 JMS I QGETC /MAX SIZE STRING, MUST FIND "
2737 JMP STRGER /BAD STRING LITERAL
2741 STRGER, JMS I QERMSG /STRING ERROR
2744 PUT40, TAD I TEMP /GET LAST WORD
2745 TAD (40 /PUT BLANK IN LOW CHAR
2746 DCA I TEMP /STORE NEW WORD
2747 JMP I STRING /RETURN
2748 GCS, 0 /GET A CHAR FOR STRING
2749 JMS I QGETCWB /GET A CHAR (INCLUDE BLANKS)
2754 JMS I QGETCWB /IS IT ""
2755 JMP I GCS /NO, THAT WAS IT
2756 TAD M42 /LOOK FOR SECOND "
2758 JMP NOTQOT /"" BECOMES "
2759 JMS I QBACK1 /PUT IT BACK
2760 JMP I GCS /LITERAL IS DONE
2761 NOTQOT, TAD (42 /RECREATE CHAR
2762 AND (77 /ELIMINATE EXTRA BITS
2763 ISZ WORD1 /BUMP STRING COUNT
2766 MODSET, 0 /SET INTERPRETER MODE
2767 TAD MODE /SUM OF DESIRED AND CURRENT
2769 JMP I MODSET /THEY WERE THE SAME
2770 TAD MODE /OTHERWISE SWITCH MODES
2773 TAD (SMODE /ENTER NMODE OR MAYBE SMODE
2776 TAD MODE /CHANGE THE SWITCH
2778 JMP I MODSET /AND RETURN
2780 WPNT, -120;-116;-124;-50;0
2781 \f/ VARIABLE OR FUNCTION REFERENCE SCANNER
2783 GETNAM, 0 /LOOK FOR VARIABLE OR FUNCT REFNCE
2785 JMS I QLETTER /MUST START WITH LETTER
2786 JMP I GETNAM /NO NAME
2788 JMS I QDIGIT /<LETTER><DIGIT> ?
2789 JMP TRYFUN /NO, LOOK FOR FUN REF
2790 IAC /INCREMENT DIGIT
2791 LFDOLR, DCA NAME2 /STORE AS NAME2
2792 JMS I QGETC /LOOK FOR $ (STRING)
2793 JMP GOTNAM+2/NOT THERE
2796 JMP NOSTRG /NO $ MEANS NO STRING
2797 CLL CML RAR /SET STRING BIT
2800 JMS I QGETC /LOOK FOR ( (ARRAY)
2801 JMP GOTNAM+2/NAME FINI
2802 TAD (-44 /PRIME THE CHAR
2803 NOSTRG, TAD (44-50 /LOOK FOR ( (ARRAY)
2805 CLL CML RTR /YES, SET ARRAY BIT
2807 JMS I QBACK1 /NO, BACKUP 1 CHAR
2808 GOTNAM, TAD TYPE /MODIFY TYPE
2810 ISZ GETNAM /BUMP RETURN
2812 TRYFUN, JMS I QSAVECP /SAVE CHAR POSITION
2813 TAD NAME1 /MOVE FIRST CHAR OVER
2818 JMS I QLETTER /LOOK FOR SECOND LETTER
2819 JMP LFDOLR /NONE THERE, LOOK FOR $
2820 TAD NAME2 /COMBINE WITH FIRST LETTER
2822 JMS I QLETTER /LOOK FOR THIRD LETTER
2823 JMP NOFNAM /NOT A FUNCTION NAME
2824 DCA NAME3 /PUT INTO NAME
2825 TAD NAME2 /IS IT A USER FUNCT ?
2829 TAD (FUNS-1 /NO, CHECK VALIDITY OF NAME
2831 FUNSRC, TAD I X10 /GET NEXT FUN NAME
2833 JMP NOFNAM /END OF LIST, INVALID NAME
2834 TAD NAME2 /COMPARE FIRST 2 CHARS
2836 JMP NOMATC /THEY DON'T MATCH
2837 TAD I X10 /COMPARE 3RD CHAR
2840 JMP NOMATC+1/DON'T MATCH
2841 TAD I X10 /GET FUNCTION CODE
2842 FUNOK, DCA SYMBOL /SAVE IT AS SYMBOL VALU
2843 TAD (1000 /SET FUNCTION BIT
2845 JMP LFDOLR /LOOK FOR Q$] Q(]
2846 NOMATC, ISZ X10 /SKIP THIRD CHAR
2847 ISZ X10 /SKIP FUNCTION NUMBER
2848 JMP FUNSRC /KEEP LOOKING
2849 NOFNAM, JMS I QRESTCP /RESTORE CHAR POS
2850 JMP LFDOLR /LOOK FOR Q$] Q(]
2851 USRFUN, TAD NAME3 /GENERATE FUN NUMBER
2853 \f/ ERROR MESSAGE REPORTER
2854 ERMSG, 0 /PRINT ERROR MESSAGE
2857 TAD I ERMSG /GET CODE
2858 CLL RTR /PRINT FIRST CHAR
2862 TAD I ERMSG /PRINT SECOND CHAR
2864 ISZ ERMSG /FIX RETURN ADDR
2865 TAD SPACE /PRINT SPACE
2867 DCA TTY /USE TTY AS A SWITCH
2868 TAD LINEH /PRINT HIGH ORDER
2870 TAD LINEL /THEN LOW ORDER
2871 JMS PSN /(LINE NUMBER NATCH !)
2872 TAD (215 /PRINT CARRIAGE RETURN
2874 TAD (212 /PRINT LINE FEED
2877 PSN, 0 /PRINT 3 DIGITS DECIMAL
2881 PRNTSN, TAD WORD2 /GET NEXT DIGIT
2882 CLL RTL /INTO THE LOW ORDER
2883 RTL /THREE BITS AND THE LINK
2884 DCA WORD2 /SAVE SHIFTED NUMBER
2885 TAD WORD2 /NOW DO LAST SHIFT
2887 AND (17 /ONLY FOUR BITS
2889 JMP NOZERO /NOT A ZERO
2890 TAD TTY /ANY DIGITS YET ?
2892 JMP LEAD0 /NO, ITS A LEADING ZERO
2893 NOZERO, TAD (60 /MAKE IT ASCII
2894 JMS TTY /PRINT DIGIT
2895 LEAD0, ISZ TEMP /BUMP COUNT
2896 JMP PRNTSN /MORE DIGIT(S)
2901 PETABL, 0004;2400;0000;0000
2921 \f/ FUNCTION NAME TABLE (INTERNAL FUNCTIONS)
2922 FUNS, -0102;-23;FUNC3
2941 ENDFNS, 0;0;FUNC4 /SPACE FOR NEW FUNCTIONS
2956 0;0;FUNC4+360 /SIXTEEN OF THEM
2959 KEYWRD, -114;-105;-124;LET
2960 -111;-106;-105;-116;-104;IFEND
2963 -116;-105;-130;-124;NEXTX
2966 -107;-117;-123;-125;-102;GOSUB
2967 -111;-116;-120;-125;-124;INPUT
2968 -120;-122;-111;-116;-124;PRINT
2970 -104;-101;-124;-101;DATA
2972 -106;-111;-114;-105;FILE
2973 -122;-105;-101;-104;READX
2974 -122;-105;-115;REMARK
2975 -122;-105;-123;-124;-117;-122;-105;RESTOR
2976 -122;-105;-124;-125;-122;-116;RETURN
2977 -123;-124;-117;-120;STOPX
2978 -122;-101;-116;-104;-117;-115;-111;-132;-105;RANDOM
2979 -103;-114;-117;-123;-105;CLOSE
2980 -103;-110;-101;-111;-116;CHAIN
2981 -125;-104;-105;-106;UDEF
2985 \f/ OS-8 OUTPUT ROUTINE
2989 OUTWRD, 0 /OUTPUT ROUTINE
2990 DCA OWTEMP /SAVE WORD
2991 ISZ LOCTRL /INCREMENT PSEUDO CODE
2992 SKP /LOCATION COUNTER
2993 ISZ LOCTRH /BOTH HALVES
2994 NOP /IT'LL NEVER HAPPEN
2995 ISZ OCOUNT /TEST FOR BUFFER FULL
2996 JMP NOWRIT /STILL SOME ROOM
2997 JMS OUDUMP /DUMP THE BUFFER
2998 TAD OUBLOK-1/RESET BUFFER PARAMETERS
3002 NOWRIT, TAD OWTEMP /PUT WORD
3004 DCA I OUPTR /INTO BUFFER
3006 ISZ OUPTR /MOVE POINTER
3008 OUDUMP, 0 /DUMP OUT BUFFER
3009 JMS I (7607 /CALL OUTPUT HANDLER
3014 ISZ OUBLOK /INCREMENT BLOCK NUMBER
3015 ISZ OUSIZE /CHECK FOR HOLE FULL
3017 OUERR, JMS I QERMSG /OUTPUT FILE ERROR
3019 JMP I XABORT /ABORT COMPILATION
3022 AMPRTN, JMS LOD1ST /LOAD OP1$
3024 SCRTN, JMS LOD1ST /LOAD OP1$
3026 LOD1ST, 0 /HANDLE ONE WAY INSTRUCTIONS
3027 JMS I QSAVAC /STORE 2ND ARG IF IN SAC
3029 CLA CMA /GET TYPE OF 2ND ARG
3032 CLL CML RTR /IS IT SUBSCRIPTED ?
3035 JMP SKIP2 /NO, ENTRY IS ONLY 2 WORDS
3036 TAD I TEMP /GET NUMBER OF DIMS
3037 AND SCOMPR /LITERAL 3
3040 SKIP2, TAD (-2 /FIND SIZE OF 2ND ARG
3041 DCA OP2SIZ /AND SAVE IT
3042 TAD OSTACK /BACK UP STACK
3045 TAD OSTACK /AND SAVE THIS ADDR
3047 JMS I QLOAD /LOAD ARG 1
3048 CLL CML RAR /GET TYPE BIT
3049 AND TYPE1 /PUT BACK ARG1
3053 TAD I X12 /PUT BACK ARG 2
3057 TAD I LOD1ST /GET OPERATOR FINISH
3058 JMP OUTOPR+1/GO FINISH CODE
3059 OP2SIZ, 0 /SACRED COUNT WORD
3060 CHECKC, 0 /CHAR CHECKER
3061 JMS I QGETC /GET A CHARACTER
3063 TAD I CHECKC /COMPARE
3065 ISZ CHECKC /MATCHES, SKIP TWO
3067 JMS I QBACK1 /NO MATCH, REPLACE
3068 ISZ CHECKC /ALWAYS SKIP AT LEAST 1
3070 SCOMPR, 3;SCRTN-3;4000;XSCOMP;XSCOMP
3071 \f/ OS-8 FILE INPUT ROUTINE
3073 ICHAR, 0 /READ CHAR FROM INPUT FILE
3074 ISZ INJMP /BUMP THREE WAY UNPACK SWITCH
3077 TAD INEOF /LAST READ YEILD END OF FILE ?
3080 INGBUF, TAD INCTR /BUMP RECORD COUNTER
3083 DCA INCTR /RESTORE IF IT HASN'T OVERFLOWED
3085 ISZ INEOF /SET END OF FILE SWITCH
3086 JMS I INHNDL /DO THE READ
3087 0200 /ONE BLOCK TO FIELD 0
3090 JMP INERR /HANDLER ERROR
3091 INBREC, ISZ INREC /BUMP RECORD NUMBER
3092 TAD (-601 /SET CHAR COUNT
3094 TAD INJMPP /RESET THREE WAY JUMP SWITCH
3096 TAD INBUFP /RESET BUFFER POINTER
3098 JMP ICHAR+1 /GO AGAIN
3101 ENDFIL, JMS I QERMSG /INPUT FILE ERROR
3103 ABORT, TAD (4207 /RESTORE ^C LOCZTIONS
3108 TAD INFO /GET START OF BASIC.SV
3111 JMP 7605 /T'WERE RUNNED
3112 DCA EDTBLK /SAVE MAGICAL BLOCK NUMBER
3113 JMS 7607 /USE SYS HANDLER
3114 EDTSIZ /TO READ IN THIS MUCH
3116 EDTBLK, 0 /FROM HERE
3117 HLT /HALT IF BAD READ
3118 JMP EDTBGN /GO RESTART EDITOR
3119 INJMP, HLT /3 WAY CHAR UNPACK JUMP
3122 ICHAR3, TAD INJMPP /RESET JUMP SWITCH
3125 AND (7400 /COMBINE THE HIGH ORDER BITS
3126 CLL RTR /OF THE TWO WORDS
3128 TAD INTMP /TO FORM THE THIRD CHAR
3131 ISZ INPTR /BUMP WORD POINTER
3132 JMP ICHAR1+1/DO SOME COMMON STUFF
3133 ICHAR2, TAD I INPTR /SAVE THE HIGH ORDER BITS
3135 DCA INTMP /FOR THE THIRD CHAR
3136 ISZ INPTR /GO TO THE SECOND WORD
3137 ICHAR1, TAD I INPTR /GET THE LOW 7 BITS
3138 AND (177 /AND I MEAN ONLY 7 !!
3139 SNA /IGNOR LEADER-TRAILER
3141 TAD (-134 /CHECK FOR \ (STMT SEPARATOR)
3143 JMP I ICHAR /TREAT LIKE CR
3144 TAD (134-32 /IS IT ^Z (END OF FILE)
3146 JMP ENDFIL /YES, ITS END OF FILE
3149 JMP ICHAR+1 /IGNORE LINE FEEDS
3155 JMP I ICHAR /RETURN ON CARRIAGE RETURN
3158 JMP ICHAR+1 /IGNORE FORM FEEDS
3161 JMP I ICHAR /RETURN TO THE CALLING WORLD
3165 INHNDL, 0 /ENTRY ADDR GOES HERE
3168 CHKWD, 0 /WORD CHECKER
3169 TAD I CHKWD /GET POINTER
3171 DCA CWTEMP /SAVE POINTER
3172 WDLOOP, TAD I CWTEMP /GET NEXT CHAR
3174 ISZ CHKWD /IF NON NEG, FIX RETURN
3176 JMS I QGETC /GET CHAR
3178 TAD I CWTEMP /COMPARE
3179 ISZ CWTEMP /INCR POINTER
3184 \f/ INITIALIZATION CODE
3186 START, JMP RUNNED /DO LOOKUPS, AND FIND TEMPFILE
3188 TAD I (7644 /WAS IT A CHAIN FROM BRTS ?
3192 JMP CHEDIT /NO, FROM THE EDITOR
3193 CIF 10 /CHAIN FROM BRTS, RESET
3194 JMS I (200 /TO FORGET DSK: HANDLER
3196 JMP STRT3 /NOW GO OPEN TEMP FILE
3197 CHEDIT, TAD (INFO+7 /PICK UP SOME STUFF
3199 CDF 10 /FROM THE INFO BLOCK
3200 TAD I X10 /START OF TEMP FILE
3202 JMP I (RUNNED+4 /MUST BE CHAIN FROM CCL
3204 TAD I X10 /SIZE OF HOLE
3210 TAD I X10 /ENTRY ADDR OF HANDLER
3215 TAD 7617 /GET DEVICE NUM FOR INPUT FILE
3218 JMS I (200 /GO FETCH THE DEVICE
3220 INDEVH+1 /2 PAGE HANDLER IS OK
3222 TAD .-2 /GET HANDLER ADDRESS
3225 JMS I (200 /RESET SYSTEM TABLES
3226 13 /DELETING TENTATIVE FILES
3228 TAD 7617 /SET UP INPUT FILE PARAMS
3236 TAD 7620 /GET BLOCK NUMBER
3240 TAD INFO+3 /GET START OF BRTS.SV (+1)
3242 TAD INFO /GET START OF BASIC.SV (+1)
3243 DCA ABORTX /BOTH FOR BLOAD
3244 TAD INFO+2 /GET START OF BLOAD.SV
3246 DCA LDRBLK /FOR CHAIN TO BLOAD
3252 INITST, TAD (VARST-1/INITIALIZE ST AREA
3255 DCA X11 /SIZE OF NUM AND STRING TABLES
3257 CLL CML RAR /SET TO 4000
3261 TAD (-440 /NOW ARRAY TABLES
3262 DCA X11 /AND BUCKETS
3264 ISZ X11 /SET THEM TO ZERO
3267 TAD JABORT /MODIFY ^C LOCATIONS
3271 JMP CORE /GET CORE SIZE
3273 JMS I QERMSG /SUPER ERROR
3277 JABORT, JMP I XABORT /ABORT COMPILATION
3281 CORE, TAD 7777 /MODIFIED CORE SIZE ROUTINE FROM
3289 JMP COREX /OS8 SOFTWARE SUPPORT MANUAL
3315 CLA CMA /HI FIELD IS #FIELDS-1
3321 CMA /HOW MANY FIELDS ?
3322 TAD HIFLD /MUST THIS BASIC USE ?
3323 SZA CLA /(SOUNDS LIKE A LINE BY DYLAN)
3325 TAD (PATCH1+3&177+5200
3326 DCA PATCH1 /ONLY 8K, DON'T USE CDF'S
3327 TAD (PATCH2+11&177+5200
3329 TAD (PATCH3+4&177+5200
3331 TAD (PATCH4+3&177+5200
3335 GENER, JMS GENTMP /GENERATE TEMP 0
3336 JMS GENTMP /GENERATE TEMP 1
3337 JMS GENTMP /GENERATE TEMP 2
3338 CLA IAC /GENERATE STRING TEMP 0
3341 DCA WORD1 /GENERATE LITERAL 1.0
3344 JMS I QLUKUP2 /ENTER INTO ST
3348 TAD (FNINIT /SET UP FUNCTIONS
3350 FDLOOP, TAD (WORD1-1
3352 TAD I FDPTR /GET FIRST WORD
3355 JMP I QREMARK /DONE, START COMPILER
3356 DCA I X12 /SAVE IN WORD1
3357 CLL CMA RTL /GET LOOKUP COUNT
3360 TAD FUNSIZ /GET SIZE OF MOVE
3363 TAD I FDPTR /GET A WORD
3365 DCA I X12 /PUT INTO WORDN
3368 JMS I QLUKUP2 /ENTER INTO S.T.
3376 NAMLST, BCOMPN /SAVE FILE NAME-POINTER LIST
3384 FNINIT, FUNC3;-1;2000;0 /ABS
3385 FUNC1;-1;2000;0 /ATN
3386 FUNC2;-1;6000;0 /ASC
3387 FUNC1+20;-1;2000;0 /COS
3388 FUNC2+20;-1;2000;4000 /CHR
3389 FUNC1+40;-1;2000;0 /EXP
3390 FUNC2+40;-1;2000;4000 /DAT
3391 FUNC1+220;-1;2000;0 /SQR
3392 FUNC1+60;-2;0;2000;0 /EXP2
3393 FUNC2+60;-1;6000;0 /LEN
3394 FUNC1+100;-1;2000;0 /INT
3395 FUNC2+100;-3;2000;4000;6000;0 /POS
3396 FUNC1+120;-1;2000;0 /LOG
3397 FUNC2+120;-3;0;2000;6000;4000 /SEG
3398 FUNC1+140;-1;2000;0 /SGN
3399 FUNC2+140;-1;2000;4000 /STR
3400 FUNC1+160;-1;2000;0 /SIN
3401 FUNC2+160;-1;6000;0 /VAL
3402 FUNC1+200;-1;2000;0 /RND
3403 FUNC2+220;-1;2000;0 /TRC
3405 BASICN, FILENAME BASIC.SV /FILE NAMES
3406 BCOMPN, FILENAME BCOMP.SV /FOR LOOKUPS
3407 BLOADN, FILENAME BLOAD.SV
3408 BRTSN, FILENAME BRTS.SV
3409 BAFN, FILENAME BASIC.AF
3410 BSFN, FILENAME BASIC.SF
3411 BFFN, FILENAME BASIC.FF
3412 BUFN, FILENAME BASIC.UF
3413 TMPFIL, FILENAME BASIC.TM