/5E L A B - F O C A L -JVZ- / COPYRIGHT (C) 1984 - ALL RIGHTS RESERVED BY / LAB DATA SYSTEMS - SEATTLE, WASHINGTON 98125 / **CORE MAP** / (32K VERSION) /FIELD 0: ERROR MSGS, BUFFERS, STACK AND SYSTEM ROUTINES /FIELD 1: INTERPRETER, FUNCTIONS, FLOATING POINT PACKAGE /FIELD 2: PROGRAM TEXT ASCENDING - FCOM AREA COMING DOWN /FIELD 3-7 VARIABLES (BATCH GOES IN FIELD 7 IF NECESSARY) / ADDITIONAL INSTRUCTION CODES: FENT=JMS I 7 FIXMRI FGET=0000 FIXMRI FADD=1000 FIXMRI FSUB=2000 FIXMRI FDIV=3000 FIXMRI FMUL=4000 FIXMRI FPWR=5000 FIXMRI FPUT=6000 FIXMRI FNOR=7000 FEXT=0000 / MORE GENERALLY: 'FENT' = 'CIF 10; JMS I (16400' CDI= CDF CIF FIXTAB / SPECIAL PSEUDO-OPS FOR ACCESSING VARIABLES: FGETIPT1=FGET I 0 FADDIPT1=FADD I 0 FMULIPT1=FMUL I 0 FPUTIPT1=FPUT I 0 / ASSEMBLY INSTRUCTIONS FOR OS/8 (PAL8-V12B,MODIFIED): / .PAL 32ECPR,32EFNS,32EFIO,32EFPP,ERRORS,32KLIB/L=100 / EAE VERSION: 32EXIO,32EXFP FIELD 1 /PROCESSOR FIELD PAGE 0 PDEL, "\ / OR 'BS' /SCOPE LIST BELL, "G&77 /MODIFY INPUT LIST P25, "U&77 /COMMAND " " CFF, FF CLF, LF CCR, CR TRACE, RO /SEARCH CHAR & TRACE SWITCH FPNT /ADDRESS OF F.P. INTERPRETER /AUTO-INDEX REGISTERS SAVMQ, HLT /INTERRUPT REGISTERS SAVAC, 0 SAVLK, 0 PDLXR, PCHK-1 /PUSHDOWN LIST INDEX REGISTER XRT, 0 /FOR POPF, GETARG, DELETE, FINDLN XRT2, 0 /FOR SORTJ, DELETE, FLOATING PT. AXIN, 0 /INPUT (PACKING) POINTER TEXTP=. AXOUT, 0 /OUTPUT (UNPACKING) REG. GTEM, RANDOM+1 /UNPACKING TEMP. STORAGE XCT, 0 /UNPACKING SWITCH PC, PC0 /PROGRAM (LINE) POINTER /PACKING AND STORAGE CONSTANTS BOTTOM, PCHK-1 /BEGINNING OF PDL LEVEL0, RANDOM /BEGINNING OF 'FOR' STACK FORLVL, RANDOM /'FOR' LOOP STACK POINTER HEADER, LINE0 /BEGINNING OF TEXT BUFFER TXTEND, -7577 /LAST LOCATION FOR INPUT MSTS, -SPF^NF+3+RESRVD/-TOTAL # VARBL. (EVEN!!) FIRSTV, STVAR /**MASTER LOCATION** IFNDEF STVAR /RESERVED SPACE IN FIELD V /MISCELLANEOUS THINGS SETSVP= JMS I . /SET D.F. AND PT1 FOR S.V. XSETSV RTL6= JMS I . /ROTATE AC LEFT 6 XRTL6 CONTINUE=JMP I . /COMMAND RETURN CONT NORMALIZE=JMS I . /NORMALIZE C(FLAC) NORM ABSOL, ABSOLV /TAKE THE ABSOLUTE VALUE RESOL, RESOLV /RESTORE THE PROPER SIGN /FLOATING POINT REGISTERS (LOC *40) SIGN=. /FOR ABS VALUE AND MUL/DIV T1, 0 /FOR INSTRUCTIONS AND F.P. T2, 0 /FOR FUNCTIONS, I/O, JMP I T1 /AND FIELD CHANGE CALLS T3, 0 /PACKING SWITCH, DEC. EXP. FLAC=. EXP, 0 /FLOATING ACCUMULATOR HORD, 0 LORD, 0 OVER, 0 FLOP=. EX1, 0 /FLOATING OPERAND AC1H, 0 AC1L, 0 OVR1, 0 INBUF, 0 /INPUT BUFFER TELSW, 0 /OUTPUT DONE FLAG INDEV, XI33 /POINTER TO INPUT DEVICE OUTDEV, XOUTL /AND OUTPUT DEVICE (TTY) FORMAT, 12^200+12 /ENCODED OUTPUT FORMAT (%10.1) SPACSW, 4000 /LEADING SPACES SWITCH /THE FOLLOWING REGISTERS ARE STACKED 'FOUR-AT-A-TIME' IN /VARIOUS COMBINATIONS - SO DON'T TRY TO REARRANGE THEM!! PT1, 0 /VARIABLE POINTER (CDF IS IN T2) THISOP, 0 /CURRENT OP, FN OR VARIABLE NAME LASTOP, 0 /PREVIOUS ARITHEMETIC OPERATION SORTCN, 0 /RELATIVE POSITION IN A LIST THISLN= THISOP /NOT USED SIMULTANEOUSLY LASTLN= LASTOP CHAR, SP /THE MOST IMPORTANT REGISTER LINENO, 0 /SET BY 'GETLN' NAGSW, 0 /'NOT ALL' AND/OR 'GROUP' SWITCH LASTC, 0 /FOR 'NEXT', 'ASK', 'ON' & FSF'S FCNT, -NF-1 /NO. OF FIELDS FOR SYMBOL TABLE BUFR, LINE1 /NEXT LOCATION IN TEXT BUFFER /TEMPORARY STORAGE HAS ALL BEEN PLACED ON THE LAST PAGE OF /FIELD 1, USING THE COMMAND DECODER AREA FROM 17600-17646. FLARG= 7600 /TEMPORARY FOR 'EVAL' NEXTP= 7604 /TEXT POINTERS FOR 'NEXT' & 'BREAK' BUFFER= 7610 /TEMPORARY FOR FUNCTIONS & OUTPUT RANDOM= 7643 /UPPER LIMIT FOR STACK POINTERS /CONSTANTS USEFUL THROUGHOUT LAB-FOCAL: P7= BELL /FOR 'FPP' AND 'FQUE' P12= CLF /FOR 'TESTX' P13, 13 /FOR 'FLOAT', 'TESTX', 'FRA', OTHERS P14= CFF /FOR 'TESTX', 'FSF' AND 'FRAC' P17, 17 /BCD MASK AND CONSTANT P43, 43 /FOR 'FLINTP' AND 'ALIGN' P7600=. /GROUP MASK & ADDRESS POINTER FLARGP, 7600 /LOCN=(BUFFPT-100) FOR 'FMIN' P77, 77 /RIGHT MASK, '?' C100, 100 /CHARACTER TESTS P177, 177 /STEP MASK & POINTER FP1, FLT1 /FOR 'FLOG', 'FSIN', 'YNCR', 'DBLSUB' M4, -4 /FOR 'EVAL', 'QUIT', 'FRA', 'PRINTN' M5, -5 /FOR LOOPS, 'GETLN', 'FSQT', 'PRINTN' UNAVAL, -RESRVD /FOR 'BATCH' AND ROMS (*LOC 106) M14, -14 /FOR 'EVAL' AND 'TESTN' M15, -15 /FOR 'TESTCR' AND 'PRINTC' P27, 27 /FOR 'FRA', 'FIXIT' AND 'FTIM' HTIM, 0 /HIGH-ORDER TIME LTIM, 0 /LOW-ORDER TIME FQSW, 0 /SCHEDULER ENABLE SWITCH OTIM, -3720 /TC FOR 1.2 MICROSEC MACHINES CPLEVL, 0 /CURRENT PROCESSING LEVEL EVFLGS, 0 /MULTI-TASKING EVENT FLAGS NF= 5 /NUMBER OF VARIABLE FIELDS IFDEF MEM /ADJUST FOR OTHER CASES SPF= 7777%6 /NUMBER OF SYMBOLS PER FIELD RESRVD= 3000%6 /RESERVED FOR BATCH MONITOR RESRVD= 1 /RESERVED TO KEEP LINK SET /SYMBOLS USEFUL THROUGHOUT LAB-FOCAL: DIGITS=12 /THE ONLY WAY TO FLY! S=00 /DATA FIELD FOR STACK L=00 /DATA FIELD FOR LIBRARY P=10 /DATA FIELD FOR PROCESSOR T=20 /DATA FIELD FOR THE TEXT V=30 /DATA FIELD FOR VARIABLES LF=12 /ALL 7-BIT VALUES NOW! FF=14 CR=15 SP=40 EOF=32 ESC=33 RO=177 /NEW INSTRUCTIONS: PUSHA= JMS I . /SAVE THE AC ON THE STACK XPUSHA POPA= JMS I . /UNLOAD THE STACK XPOPA PUSHJ= JMS I . /CALL A SUBROUTINE XPUSHJ POPJ= JMP I . /RETURN FROM A SUBROUTINE XPOPJ PUSHF= JMS I . /PUT 4 WORDS ON STACK XPUSHF POPF= JMS I . /RESTORE THEM XPOPF POPVP= JMS I . /POP VARIABLE POINTER XPOPVP SORTJ= JMS I . /SORT AND BRANCH ON AC OR CHAR SORTB TESTC= JMS I . /TEST FOR TERM, FN, NO., OR VAR. CTEST TESTX= JMS I . /TEST FOR TERM AND SET SORTCN XTEST TESTN= JMS I . /TEST FOR PERIOD, NUMBER NTEST READN= JMS I . /USE 'FETCH' TO INPUT A NUMBER FLINTP PRINTN= JMS I . /CONVERT BINARY TO ASCII & PRINT ATSW, FLOUTP /FOR 'ASK', 'TYPE', AND 'FRA' READC= JMS I . /READ AND ECHO A CHARACTER (AC=0) ECHOC= JMS I . /PRINT C(AC) WHEN ECHO IS ENABLED CHIN PRINTC= JMS I . /PRINT C(AC) OR 'CHAR' IF AC=0 CHOUT GETC= JMS I . /UNPACK A CHARACTER BKSW, UTRA /'BREAK' SWITCH (MUST BE LOC 137) PACKC= JMS I . /PACK A CHARACTER PACBUF SPNOR= JMS I . /IGNORE LEADING SPACES XSPNOR TESTRP= JMS I . /TEST FOR MATCHING RIGHT PAREN PARTEST TSTCMA= JMS I . /SKIP IF CHAR=COMMA & MOVE PAST IT CMATST TESTCR= JMS I . /SKIP IF CHAR = CR CRTEST GETLN= JMS I . /COMPUTE A LINE NUMBER (RECURSIVE) XGETLN FINDLN= JMS I . /SEARCH TEXT FOR A GIVEN LINE XFIND PRNTLN= JMS I . /PRINT LINE NUMBER QSWTCH, XPRNT /TRACE ENABLE SWITCH DELETE= JMS I . /REMOVE A LINE AND XDELETE /RECOVER THE SPACE DCAIAXIN=JMS I . /'DCA I AXIN' IN FIELD T AXIND /FLOATING POINT PSEUDO INSTRUCTIONS: FLOAT= JMS I . /FLOAT THE AC FIGO9 FLOATR= JMP I . /FLOAT THE AC AND RETURN FIN+2 FL0ATR= JMP I . /UNSIGNED FLOAT & RETURN FL0AT RETURN= JMP I . /REGULAR FUNCTION RETURNS FINISH, EFUN3 SHIFTL= JMS I . /MULTIPLY FLAC BY 2 MULT2 NEGATE= JMS I . /COMPLEMENT AND INCREMENT FLAC INVERT FIXIT= JMS I . /CONVERT FLAC TO A 24-BIT INTEGER CSTAR, FIXER MULT10= JMS I . /MULTIPLY FLAC BY TEN & ADD THE AC XTEN CHKSGN= JMS I . /TAKE ABS VALUE AND CHECK FOR ZERO SGNCHK GETNXT= JMS I . /NON-RECURSIVE ARGUMENT EVALUATION NXTARG GET10X= JMS I . /RETURN VALUE OF NEXT ARGUMENT X10 NXT10X *.+3 /SPACE FOR USER MACROS & CONSTANTS PRODUCT= 170 /FOR SOFTWARE MULTIPLY *176 ERROR2= JMS I . /FIELD 1 ERROR TABCNT, ERROR /ENTRY POINT IS THE TAB COUNTER /DEFINE SOME MICROCODED INSTRUCTIONS: SP1= CLA STL RAL SP2= CLA STL RTL SP3= CLA STL IAC RAL SP4= CLA CLL IAC RTL SP6= CLA STL IAC RTL SM0= CLA STL RAR SM1= CMA STL RAL /NO CLA SM2= STA CLL RAL SM3= STA CLL RTL I0N= ION /MAKE THESE EASY TO CHANGE I0F= IOF /OR 'NOP' / COMMAND PROCESSOR FOR VERSION 5 *177 START=. /PROGRAM SELF-START BUFFPT, SKP CLA /OUTPUT BUFFER IS AT 17610. JMP I CZ /CONSOLE START (FROM 10200) TAD CSTAR /ANNOUNCE PRESENCE ECHOC /(UNLESS THE ECHO IS OFF) TAD BOTTOM DCA PDLXR /RESET THE STACK POINTERS TAD LEVEL0 DCA FORLVL TAD CTRLZ /TRAP CTRL/Z DURING INPUT DCA TRACE DCA I QSWTCH /AND RESET TRACE SWITCHES DCA T3 /RESET THE PACKING SWITCHES DCA EX1 TAD BUFR /INITIALIZE BUFFER POINTER LFRTN, DCA AXIN TAD C100 /SET PC FOR COMMAND MODE DCA PC DCA FQSW /DISABLE EXTERNAL EVENTS DCA CPLEVL ///// IGNOR, READC /READ THE COMMAND STRING SORTJ P25-1 INLIST-P25 PACKC /SAVE EACH LITTLE CHARACTER JMP IGNOR ///// / *.+1 /BELL = RESERVED INLIST, ERRX+1 /C.U. = RESTART ECHOFF /F.F. = IGNORE LNFEED /L.F. = RETYPE IRETN /C.R. = TERMINATE CZ, M20-1 /C.Z. = RESET I/O ///// IRETN, PACKC /PACK THE CR PACKC /BE SURE ITS ALL THERE DCA EVFLGS /CLEAR EVENT FLAGS TAD BUFR JMP NEXTLN /INITIALIZE 'TEXTP' ///// / TEXT BUFFER FORMAT: / #1 : POINTER OR ZERO IN LAST / #2 : LINENO / #3 - #N-1 : TEXT / #N : CR (=4055) /IMMEDIATE AND SEQUENTIAL COMMAND EXECUTION: ECHOFF, PRINTC /ECHO FF TO CLEAR THE DISPLAY JMP IGNOR /BUT OTHERWISE JUST IGNORE IT ///// INPUTX, PUSHJ /PROCESS THE NEXT LINE PROC CDF T TAD I PC SNA /END OF THE PROGRAM? JMP I INLIST /YES DCA PC /SAVE THE NEW LINE POINTER TAD PC IAC /AND ADVANCE TO THE LINENO NEXTLN, DCA AXOUT /SET 'GETC' POINTERS DCA XCT GETC /READ FIRST CHARACTER SPNOR /IGNORE LEADING BLANKS TESTN /DOES THE LINE BEGIN WITH 0-9? SKP /PERIOD: ALLOW GROUP ZERO JMP INPUTX /A DIRECT (OR STORED) COMMAND ISZ I QSWTCH /YES, PROTECT '?'S DURING COPY GETLN /READ LINE NUMBER; SETS EX1=27 JMS I MODIFY+2 /INITIALIZE THE NEW LINE SKP /GET THE FIRST CHARACTER GETC /GET THE NEXT CHARACTER SRETN, PACKC /AND REPACK IT TESTCR /WATCH FOR A CARRIAGE RET. JMP .-3 PACKC /FOUND ONE, FINISH PACKING IT DELETE /REMOVE THE OLD LINE (IF ANY) CDF T TAD I LASTLN /INSERT THE NEW ONE DCA I BUFR TAD BUFR DCA I LASTLN IAC /ALLOW FOR AN EXTRA HALF-WORD AND T3 /(IF CR DIDN'T COME OUT EVEN) TAD AXIN DCA BUFR /SAVE NEW END-OF-BUFFER LOCN. CDI L JMP IOWAIT /TURN ON INTERRUPTS & RESTART ///// CTRLZ, "Z&77 /FOR 'FIND' AND COMMAND INPUT /LINE NUMBER EVALUATION: 'GETLN' XGETLN, 0 /NOW HANDLES NEGATIVE NUMBERS TAD .-1 / AND PERMITS RECURSIVE CALLS PUSHA PUSHJ /EVALUATE THE ARGUMENT EVAL YGETLN, TAD EXP /MODIFY AND FSF ENTRY POINT TAD M5 SMA SZA CLA /.GT. 31? ERROR2 TAD PC /POINT TO THE CURRENT LINE DCA XRT ZGETLN, SM1 /TFRMT ENTRY POINT DCA NAGSW /SET NAGSW FOR 'ALL' CHKSGN /TAKE THE ABSOLUTE VALUE JMP ALL /ZERO=ALL, L=1 FROM 'FPUT' SMA SZA CLA /CHECK THE ORIGINAL SIGN DCA NAGSW /CLEAR SWITCH IF POSITIVE FIXIT /GET THE GROUP NUMBER BSW /SHIFT INTO PLACE ('RTL6') CLL RAL CDF T /SHIFT TO TEXT BUFFER SNA /RELATIVE ADDRESSING? TAD I XRT /YES, USE CURRENT GROUP AND P7600 DCA LINENO /SAVE GROUP NUMBER NEGATE CDF P /RESET D.F. FOR F.P. PKG. FENT FADD I FLARGP /SUBTRACT THE GROUP NUMBER FMUL FL100 /SHIFT THE DECIMAL POINT FADD FLP5 /ROUND OFF THE RESULT FEXT FIXIT /LEAVES L=0, EX1=27 ISZ NAGSW /FORCE ZERO FOR NEG LINENO DCA NAGSW /SET 'NOT-ALL/GROUP SWITCH' TAD NAGSW /AC = LINENO IF WE SKIPPED TAD LINENO /COMBINE LINE & GROUP NUMBERS ALL, DCA LINENO POPJ /LINK=1 IF ALL (SET BY CHKSGN) FL100, 7;3100;0 /CONSTANTS FOR 'GETLN' FLP5, 0;2000;ZBLOCK 2 /ALSO USED BY 'FSQT', 'FTIM' /LINE NUMBERS MAY RANGE FROM 0 TO +- 31.99 /NEGATIVE NUMBERS FORCE THE 'GROUP' SWITCH. / NAGSW: LINK: / ALL= 7777 1 / GROUP= 0000 0 / LINE= 0XXX 0 /'MODIFY' AND 'MOVE' COMMANDS DIFFER ONLY IN THAT 'MOVE' /HAS A SECOND LINE NUMBER (SEPARATED BY A COMMA) WHICH /BECOMES THE LINENO OF THE CORRECTED LINE. THE OLD LINE /REMAINS UNCHANGED IN THIS CASE. MODIFY, GETLN /READ THE FIRST LINENO TSTCMA /PASS THE COMMA IF THERE IS ONE INITLN /'NOP' PUSHJ /OTHERWISE 'EVAL' GIVES ZERO EVAL FINDLN /LOOK UP THE OLD LINE POPJ /NOT THERE TAD HORD /TEST SECOND ARGUMENT SZA CLA /NEW LINENO? PUSHJ /YES: 'MOVE' AS WELL AS 'MODIFY' YGETLN /.LT. 1000 SO WE CAN DO THIS MODLN, PRNTLN /'NOP' TO OMIT THE NUMBER ///// JMS INITLN /SAVE LINENO SCONT, JMS I INDEV /GET SEARCH CHARACTER (SILENTLY) DCA TRACE SCHAR, GETC /PLAYBACK TEXT TAD CHAR ECHOC /ALLOW SILENT EDITING SORTJ /LOOK FOR A MATCH CCR-1 LISTGO-CCR PACKC /SAVE THE NEW LINE JMP SCHAR ///// SBAR, JMS INITLN /RESTART AFTER CTRL/U SFOUND, READC /READ FROM KEYBOARD SORTJ /AND TEST BELL-1 SRNLST-BELL SGOT, SP1 /PROTECT LINENO FROM RUBOUTS PACKC /PACK CHAR JMP SFOUND /MORE ///// SRNLST, SCONT /BELL = CHANGE SEARCH CHARACTER SBAR /C.U. = DELETE LINE TO THE LEFT SCHAR /F.F. = LOOK FOR NEXT OCCURRENCE SCONT+1 /L.F. = FINISH THE LINE AS BEFORE LISTGO, SRETN /C.R. = END THE LINE RIGHT HERE SGOT /CHAR = STOP ON SEARCH CHARACTER ///// INITLN, 0 /INITIALIZE A NEW LINE DCA T3 TAD BUFR /RESET INPUT POINTERS DCA AXIN TAD LINENO /PACK LINENO DCAIAXIN ISZ I QSWTCH /PROTECT Q.M.'S JMP I INITLN /USED BY MODIFY, ERASE AND INPUT /OUTPUT THE INDIRECT PROGRAM WEND, POPA /RESTORE TEXT POINTERS DCA CHAR POPF TEXTP DCA I QSWTCH /TURN ON TRACE ENABLE AGAIN TSTCMA /CHECK FOR MULTIPLE LISTING CONTINUE TAD CCR PRINTC /SEPARATE MULTIPLE CALLS ///// WRITE, GETLN /SET LINENO PUSHF /SAVE TEXT POSITION TEXTP TAD CHAR PUSHA WCONT, FINDLN /SEARCH FOR LINE NUMBER JMP WTESTG /NOT THERE OR GROUP PRNTLN /ALSO DISABLES THE TRACE GETC PRINTC /PRINT A LINE OF TEXT TESTCR /SKIP AT THE END JMP .-3 TAD THISLN /POINT TO THE NEXT LINE WTESTG, JMS GRPCHK /CHECK ITS VALIDITY JMP WEND /LAST ONE OR ONLY ONE TAD LASTLN /STILL IN THE GROUP? SZA CLA PRINTC /SEPARATE GROUPS JMP WCONT /RETURN TO LOOP /DELETE SINGLE LINES, GROUPS OR EVERYTHING ERASE, GETLN /WHICH SHALL IT BE? SZL /ALL? JMP ERA /YES JMS INITLN /SET MEMORY PROTECTION ERG, DELETE /REMOVE A SINGLE LINE TAD LASTLN /WATCH OUT FOR THE END JMS GRPCHK /CHECK IF NEXT LINE IS OK JMP ERX /DONE: CLEAR PROGRAM FLAG JMP ERG /DELETE SOME MORE ///// LINE1 ERA, TAD .-1 /RESET THE COMMAND BUFFER DCA BUFR CDF T /PUT ZERO IN THE FIRST LINE DCA I HEADER ERX, CDI L /AND REMOVE THE PROGRAM NAME JMP NONAME /CLEAR THE SYMBOL TABLE AND/OR SELECTED VARIABLES ZERO, TESTC /CHECK FOR 'Z 1' OR 'Z A' JMP ZALL /TERMINATOR TSTCMA /FUNCTION OR COMMA RETURN JMP ZALL /NUMBERS ARE LEGAL NOW SPNOR /VARIABLE NAME ZRTN, SORTJ ZLIST-1 /TEST FOR END OF COMMAND ZGO-ZLIST PUSHJ /LOOK UP THE VARIABLE GETARG PUSHJ /ZERO THE DATA ZEROIT JMP ZRTN /LOOP TO THE NEXT NAME ZALL, PUSHJ /GO DO ALL THE WORK ZAPPER JMP ZRTN /SEE IF THERE'S MORE ///// GRPCHK, 0 /FOR REPEATED OPERATIONS CDF T /TEXT BUFFER SNA /AC = POINTER TO NEXT JMP .+6 /FIRST LINE IN A GROUP DCA INITLN /SAVE POINTER TAD I INITLN /'THISLN', 'LASTLN', 'PC' SNA /END OF TEXT BUFFER? JMP GRPXIT+1 /YES DCA THISLN /SAVE NEW POINTER TAD NAGSW /CHECK THE TYPE OF OPERATION SMA SZA /FIRST EXIT = SINGLE OR E.O.G. JMP GRPXIT /ALSO SERVES FOR END-OF-TEXT DCA LASTLN /SAVE A COPY OF NAGSW ISZ THISLN /POINT TO LINE NUMBER TAD I THISLN AND P7600 CIA TAD LINENO /COMPARE WITH CURRENT AND P7600 ISZ LASTLN /FORCE 2ND EXIT FOR 'ALL' SNA CLA ISZ GRPCHK /SECOND EXIT = KEEP GOING DCA LASTLN /NON-ZERO = 'ALL' BUT N.I.G. TAD I THISLN GRPXIT, DCA LINENO /UPDATE THE LINE NUMBER CDF P JMP I GRPCHK ///// / THE IMPROVED 'RETURN' COMMAND PERMITS AN OPTIONAL LINE /NUMBER WHICH WILL TRANSFER TO THAT LINE RATHER THAN RE- /TURNING TO THE CALL. A VERY USEFUL FEATURE! RETRN, PUSHF /SAVE FSF RESULTS FLARG GETLN /CHECK FOR A LINENO TAD LINENO /SAVE IT DCA THISLN TAD C100 /POINT TO PC0 DCA PC CMA CML RAR / 3777 OR 7777 DCA LASTLN /SET RETURN FLAG POPF /RESTORE FSF FLARG /'CLA' POPJ /GO BACK A LEVEL /PRIMARY CONTROL AND TRANSFER - NOW ALLOWS 'GROUP GOTOS' GOTO, GETLN /EVALUATE THE LINE NUMBER EXPRS. JMS NXTLN /FIND IT (OR THE NEXT AVAILABLE) PUSHJ /'TAD THISLN' - SET THE PC, AND SCHED /'DCA PC' - THEN CALL SCHEDULER GETC PROC, TAD CHAR /GET FIRST (NEXT) COMMAND LETTER AND .-2 /EXECUTE LOWER CASE TOO! DCA LASTC /SAVE CHARACTER & CLEAR A FLAG TESTX /CHECK FOR IMMEDIATE TERMINATOR JMP PC1+2 /NONE: SCAN PAST COMMAND WORD TESTCR /CR? JMP PROC-1 /IGNORE SPACES, COMMAS, SEMIS PC1, JMP I COMGO-1 /YES: DONE WITH THIS LINE (POPJ) 200-"Z-1 GETC /SKIP TO END OF COMMAND WORD TESTX JMP .-2 TAD LASTC /NOW CHECK COMMAND LETTER TAD PC1+1 STL IAC TAD ATOZ /IS IT @-Z? SZL SNA CERR, ERROR2 /NOPE: ILLEGAL COMMAND TAD PC1 DCA .+1 /PUT 'JMP' INSTRUCTION INLINE ///// NXTLN, 0 /LOCATE THE NEXT PROGRAM LINE FINDLN JMP ATOZ+2 /NOT THERE: IS THAT AN ERROR? JMP I NXTLN ATOZ, "Z-"@+1 /SINGLE LINES, OR OUT-OF-GROUP GRPCHK /REQUESTS: YES - OTHERWISE: NO JMS I .-1 ERROR2 /BAD LUCK: THE LINE IS MISSING JMP NXTLN+1 /OK: USE THE NEXT LINE INSTEAD /RECURSIVE OPERATE, EXECUTE, OR CALL DEWPT, CMA CML RAR /LIBDO=7777, FQUE=3777 JMP DO+1 /EXECUTE THE SUBROUTINE LCMNDS, SPNOR /'L' COMMAND ENTRY POINT CDI L JMP I FENT&177 /SAME ADDRESS AS THE FPP ///// DOXIT, SZA /CHECK FOR 'DO' OR 'LIBDO' JMP LCMNDS+1 /RETURN TO CALLING PROGRAM TSTCMA /CHECK FOR ADDITIONAL CALLS CONTINUE /NONE: PROCESS NEXT COMMAND ///// DO, GETLN /EXECUTE A LINE, GROUP, OR ALL DCA SORTCN /ENTRY POINT FOR LIBDO, FQUE PUSHF /ENTRY POINT FOR FSF'S TEXTP /SAVE TEXT POINTERS PUSHF INDEV /SAVE I/O CONSTANTS ///// DOGRP, PUSHF /SAVE SORTCN, CHAR, LINENO, NAGSW SORTCN JMS NXTLN /GET THE FIRST (NEXT) LINE PUSHJ /EXECUTE IT PROC-3 POPF /RESTORE CALLING DATA SORTCN TAD PC /CHECK THE NEXT LINE JMS I ATOZ+1 /SHOULD WE EXECUTE IT? JMP DORTN /ALL DONE JMP DOGRP /CONTINUE SUBROUTINE ///// DORTN, POPF /RESTORE I/O CONSTANTS INDEV POPF /RESTORE TEXT POINTERS TEXTP TAD SORTCN /CHECK RETURN FLAG SMA SZA JMP GOTO-2 /FSF RETURN ('CLA;POPJ') ISZ LASTLN /CHECK RETURN OPTION JMP DOXIT /NONE, RETURN TO CALL SZA CLA /LIBDO? POPF /YES, DUMP PROGRAM INFO FLOP /OTHERWISE 'NOP' TAD THISLN DCA LINENO /MOVE RETURN POINT ///// ENDON, ISZ LASTC /TEST 'IF/ON' FLAG JMP I ENDIF /IF, RETURN, NEXT, BREAK, JUMP TSTCMA /ON JMP DO+1 /CALL THE SUBROUTINE JMP .-2 /PREVENT MULTIPLE CALLS ///// /COMMAND BRANCH TABLE: FOUR UNUSED COMMANDS AVAILABLE ENDIF, GOTO+1 /PATCH THIS FOR SCOPE REFRESH XPOPJ /DITTO ('COMGO' MUST BE *.+1) COMGO, CERR /@ CONTROL ASK /A BREAK /B SCHED+2 /C DO /D ERASE /E FOR /F GOTO /G HESI /H IF /I JUMP /J CERR /K KEYPAD LCMNDS /L MODIFY /M NEXT /N ON /O CERR /P PLOT QUIT /Q RETRN /R SET /S TYPE /T UNTIL /U CERR /V VIEW WRITE /W CONT /X YNCR /Y ZERO /Z ///// SGNCHK, 0 /CHECK SIGN - 'CHKSGN' TAD HORD SZA ISZ SGNCHK /FIRST RETURN = ZERO DCA T3 JMS I ABSOL /TAKE ABSOLUTE VALUE FENT FPUT I FLARGP /AND PUT IT BACK AGAIN FEXT TAD T3 JMP I SGNCHK /AC,T3=SIGN, L=1 FROM FPUT ///// PAGE FOR, PUSHJ /LOOP CONTROL BEGINS WITH 'SET' EVAL SORTJ /TEST LAST CHAR FROM 'EVAL' TLIST-1 FGO-TLIST JMP FOR /'SP' IS A LEGAL SEPARATOR NEXIT, ENDNB /CHECK FOR 'VAR=' CONSTRUCT: STACK LAST OP, VAR ADR *TAD FENT&177 /WIERD! EQLS, 0 /PLACED HERE TO SAVE A WORD SPNOR /SKIP TO THE OPERATOR TAD M60 TESTCR /TEST FOR '=' ("=-CR IS 60) JMP I EQLS TAD LASTOP /STACK CURRENT OPERATOR PUSHA JMS PUSHVP /SAVE POINTER TO VARIABLE SP1 JMP I FCONT-1 /SET 'LASTOP' TO 1 FOR '=' ///// FINFIN, PUSHF /USE DEFAULT INCREMENT FLT1 JMP FCONT ///// FINCR, GETC /SKIP THE COMMA THAT GOT US HERE TAD LASTC /IS IT 'SET' OR 'FOR' ? SNA CLA /'FOR I=1,N=2' JMP FOR /'SET I=1,N=2' JMS PUSHVP /SAVE THE VARIABLE POINTER PUSHJ /EVALUATE THE INCREMENT EVAL SORTJ /TEST THE NEW TERMINATOR ILIST-1 FLIST-ILIST FORERR, ERROR2 /IMPROPER TERMINATOR IN 'FOR' /THE STACK POINTER IS SAVED EACH TIME WE START A NEW LOOP /TO ALLOW 'BREAKS' TO CUT THROUGH ANY INTERVENING SUBROU- /TINE CALLS. THE LEVELS ARE STACKED BACKWARDS FROM 'RAN- /DOM', PERMITTING 16 OR MORE NESTED LOOPS; NO CHECKING IS /PERFORMED SINCE OTHER LIMITS WILL BE ENCOUNTERED FIRST. PUSHTP, 0 /SAVE TEXT, STACK POINTERS SM1 TAD FORLVL /ADJUST LEVEL COUNTER DCA FORLVL TAD PDLXR /SAVE STACK POINTER TAD M5 DCA I FORLVL PUSHF /SAVE TEXT POSITION TEXTP JMP I PUSHTP /CALLED BY 'FOR' AND 'UNTIL' PUSHVP, 0 /SAVE CDF TO VARIABLE TAD PT1 PUSHA TAD T2 PUSHA JMP I PUSHVP /CALLED BY 'FOR' AND 'EQLS' ///// FLIMIT, PUSHF /SAVE THE INCREMENT; GET THE LIMIT FLAC PUSHJ /(NO ERROR DETECTION AFTER LIMIT) ENEXT FCONT, PUSHF /SAVE THE LIMIT FLAC JMS PUSHTP /SAVE TEXT POSITION PUSHJ FPROC, PROC-1 /EXECUTE TO END OF LOOP /RETURN FROM OBJECT STATEMENTS POPF /RESET THE TEXT POINTERS TEXTP POPF /RECOVER THE LIMIT BUFFER POPF /LOAD THE INCREMENT FLAC POPVP /RESTORE THE VARIABLE POINTER ISZ I BKSW /TEST FOR A 'BREAK' JMP FNEXT /NONE FEXIT, ISZ FORLVL /REMOVE ONE LEVEL ISZ LASTC /CHECK FOR CONTINUATION POPJ /NONE, END THIS LINE PUSHF NEXTP POPF /MOVE TO NEW TEXT POSITION TEXTP JMP I NEXIT /CHECK FOR A LINENO (CF. 'IF') FNEXT, SM0 AND HORD DCA EQLS /SAVE SIGN OF THE INCREMENT FENT FADDIPT1 /INCREMENT LOOP INDEX FPUTIPT1 /AND SAVE IT AGAIN FSUB I BUFFPT /COMPARE WITH LIMIT FEXT TAD EQLS TAD HORD /TEST RESULT SMA SZA CLA JMP FEXIT /EXIT FROM 'FOR' TAD I FORLVL /EFFECTIVE PUSHDOWN FOR DCA PDLXR /PT1, INCREMENT, LIMIT JMP I FPROC /TEXTP, & PUSHJ(PROC-1) /THE 'NEXT' AND 'BREAK' COMMANDS ADD A NEW DIMENSION TO /FOCAL'S LOOPS BY PERMITTING NESTED OPERATIONS AND EARLY /TERMINATION. THEY ARE PATTERNED AFTER SIMILAR COMMANDS /IN 'COLPAC' & 'FOCLF'. SPECIAL THANKS TO THESE AUTHORS! /BOTH COMMANDS MAY INCLUDE A LINENO TO SPECIFY A BRANCH. /WHEN NO LOOPS ARE IN PROGRESS THESE COMMANDS ARE SIMPLY /'NOPS' UNLESS A BRANCH IS SPECIFIED, IN WHICH CASE IT /WILL BE TAKEN. THUS A LINE CONTAINING AN 'N' OR A 'B' /COMMAND CAN BE EXECUTED BY ANY PART OF THE PROGRAM. BREAK, SM1 /SET THE 'BREAK' FLAG DCA I BKSW / (RESET BY 'GETC') NEXT, TAD I FORLVL /IS THERE A MATCHING 'FOR'? SNA JMP I NEXIT /NO, TREAT LIKE A SPECIAL 'GOTO' DCA PDLXR /YES, DROP THE STACK TO THIS LEVEL SM1 /SET THE 'NEXT' SWITCH DCA LASTC PUSHF TEXTP POPF /AND SAVE THE CURRENT POSITION NEXTP POPJ /THEN RETURN TO THE 'FOR' LOOP ///// /SEARCH FOR A GIVEN LINE NUMBER: 1ST RETURN IF MISSING, / 2ND IF FOUND. 'THISLN'= TARGET LINE OR NEXT LARGER - /'LASTLN'=LESSER AND OR LAST. 'GETC' POINTERS ARE SET, /BUT NOT THE PC SO ERRORS SHOW THE CORRECT LINE NUMBER. XFIND, 0 /FIND A LINE OF TEXT - 'FINDLN' CDF T TAD HEADER DCA LASTLN /INITIALIZE TO THE HEADER LINE TAD LASTLN FINDN, DCA THISLN /SAVE NEW LINE POINTER TAD THISLN DCA AXOUT /INITIALIZE UNPACKING REG. TAD LINENO STL CIA TAD I AXOUT /ADVANCE AND COMPARE SNA CLA ISZ XFIND /FOUND IT - TAKE 2ND EXIT M60, SNL SMA CLA JMP FINDX /FOUND IT OR PAST IT TAD THISLN DCA LASTLN /SAVE POINTER TAD I THISLN SZA /END OF TEXT? JMP FINDN /NOT YET FINDX, DCA XCT /CLEAR UNPACKING SWITCH CDF P JMP I XFIND /1ST RETURN = NOT FOUND /INPUT-OUTPUT COMMANDS: -ASK- AND -TYPE- /'SET' TURNS INTO 'TYPE' WHEN THE TRACE SWITCH IS ON *.!177-3 /PUT 'SET' JUST BEFORE 'TYPE' SET, DCA LASTC /THE MOST IMPORTANT COMMAND ! TAD TRACE /CHECK THE TRACE SWITCH SMA CLA /SKIP IF ITS TURNED ON JMP FOR /OFF: USE THE 'FOR' ROUTINE JMP TYPE /ON: BEHAVE JUST LIKE 'TYPE' ///// TYPSET, TAD SPACSW /PRINT VALUE OF EXPRESSION PRINTN TASK, SPNOR /MOVE TO NEXT ARGUMENT TAD FORMAT /SET UP FORMAT AND DCA LASTC /CLEAR 'ESC SEQ FLAG' SORTJ /!,",#,$,%,: ? ALIST-1 AGO-ALIST ///// / SP4 /SET PT1 GUARD FOR ASK SETSVP PUSHJ /GET VALUE/VARIABLE EVAL ISZ I ATSW /'ASK' OR 'TYPE'? JMP TYPSET TAD CHAR /SAVE TEXT CHARACTER DCA LASTC JMP READ /'NOP' TO PRINT A '?' ///// ASKOVR, TAD P77 /DELETE = PRINT A '?' ECHOC /AND RE-TRY ///// READ, SP1 /GET VALUE FROM 'INDEV' READN TLIST2, CR /MUST BE POSITIVE! SP /SPACES IN ESC. SEQ. "$&177 /OUTPUT ANOTHER ESC. ""&177 /MATCHING QUOTE MARK FENT FPUTIPT1 /SAVE IT FEXT ASKEQ, TAD LASTC /RESTORE TEXT CHARACTER DCA CHAR ASK, CMA TYPE, DCA I ATSW /SET THE SWITCH JMP TASK ///// /ASKEQ, FENT / FGETIPT1 /'EQUALS' ROUTINE TO / FEXT / PRINTN /PRINT THE OLD VALUE / JMP ASK-2 ///// /NOTE: THINGS ARE ARRANGED HERE SO THAT 'TLIST3' WILL BE /EXACTLY 33 GREATER THAN 'TLIST2' - CAVEAT ERGO MEDDLER! TFRMT, PUSHJ /MOVE PAST THE '%' ENEXT TAD C100 /POINT TO PC0 DCA XRT PUSHJ /READ FORMAT ZGETLN TAD LINENO SNA TAD P12 /DEFAULT = '%.1' DCA FORMAT /SAVE FOR LATER TAD T3 SMA CLA /TEST THE SIGN SM0 DCA SPACSW /4000=PRINT, 0= DON'T JMP TASK ///// /DISPATCH TABLE FOR 'ASK' 'TYPE' 'ZERO' 'FOR' 'SET' 'IF' TLIST3, PC1 /CR AUTO END-OF-STRING TESCSP /SP SPACES IN ESC. SEQ. TDOLR /$ - EMBEDDED ESCAPES / TASK4 /" - MATCHING QUOTE MARK ///// AGO, TASK4 /, - END OF EXPRESSION TQUOT+1 /" - PRINT CHAR STRING TCRLF /! - CR AND LF TFRMT /% - SET OUTPUT FORMAT TCHAR /# - PRINT ASCII VALUE TESCP /$ - PROC AN 'ESC SEQ' TABX /: - TABULATE OR SKIP ZGO, ZERO+2 /, - MULTIPLE ZERO COMMAND FGO, FINCR /, - MULTIPLE SETS OR FOR IGO, ELSE /, - UNUSED 'IF' BRANCHES YGO, PROC-1 /; - END OF COMMAND PROC+2 /CR END OF LINE DECR /- - DECREMENT A VARIABLE ///// ALIST, ",&177 /'SORTJ' CONTROL TABLE ""&177 "!&177 "%&177 "#&177 "$&177 ":&177 ZLIST, ",&177 /FOR 'ZERO' TLIST, ",&177 /FOR 'SET' ILIST, ",&177 /FOR 'IF/ON' ";&177 CR /'GETC' ENDS THE LIST ///// TCHAR, GETC /'#' = PRINT ASCII VALUE GETNXT SNA /'0' = PRINT A FORMFEED TAD CFF /'TAD CCR' FOR A CR... JMS I OUTDEV /OMIT ALL CHAR CHECKING JMP TASK ///// TESCP, DCA LASTC /SET THE 'ESC-SEQ' FLAG TDOLR, TAD LASTC /PRINT STRING CONSTANTS SNA CLA TAD TESC /'$' = ESCAPE TQUOT, PRINTC /ECHO ISZ I QSWTCH /PROTECT Q.M.'S GETC /PASS QUOTE - READ NEXT DCA I QSWTCH /RE-ENABLE TRAP SORTJ TLIST2-1 /QUOTE OR CR OR SP OR $ TESC, TLIST3-TLIST2 JMP TQUOT ///// TESCSP, TAD LASTC /FOUND A SPACE IN STRING SZA CLA /CHECK THE FLAG JMP TQUOT /JUST PRINT IT PUSHJ /PROCESS ARITHMETIC EXPRS. EVAL PRINTN /OUTPUT VALUE (%-5 FORMAT) JMP TQUOT ///// TCRLF, TAD CCR /'!' = CR, LF PRINTC TASK4, GETC /MOVE ALONG JMP TASK /CHECK FOR DOUBLE SUBSCRIPTING AND DO CONVERSION DBLSUB, M2011+1 /A(I,J) = A(I+(J-1)*@) TSTCMA JMP DBLXIT /QUICK EXIT FOR S.S. PUSHF FLAC /SAVE THE ROW VALUE PUSHJ EVAL /GET THE COL NUMBER POPF FLARG SP4 /DIMENSION OFFSET FROM PI SETSVP /SET THE VARIABLE POINTER FENT FSUB I FP1 / SUBTRACT '1' FMULIPT1 /* (DIMENSION) FADD I FLARGP /+ ROW OFFSET FEXT DBLXIT, POPA /RECALL VARIABLE NAME JMP I DBLSUB /RETURN TO 'GETARG' ///// XRTL6, 0 /ROTATE THE AC LEFT 6 - 'RTL6' CLL RTL RTL RTL JMP I XRTL6 /NOT QUITE THE SAME AS 'BSW'.. XSETSV, 0 /LOCATE SECRET VRBL - 'SETSPV' TAD FIRSTV /AC HAS RELATIVE LOCATION DCA PT1 TAD CDFSV /HAVE TO SET THE D.F. TOO DCA T2 JMP I XSETSV /CALLED BY GETVAR & FSF'S /FIND OR ENTER A VARIABLE IN THE SYMBOL TABLE ECALL GETLP, TAD CHAR /NAME= FIRST+LAST CHARACTERS AND P77 DCA OVER /ENTRY POINT GETC TESTX /END OF THE NAME? JMP GETLP TAD HORD /MERGE THE TWO PIECES SNA SM0 /ELIMINATE NULL NAMES TAD OVER DCA THISOP /SAVE WHERE WE CAN PUSH IT ///// TAD SORTCN /CHECK FOR A SUBSCRIPT TAD GM10 AND M4 /7774 (PARENS ARE 1-3) SZA CLA JMP GSV /NONE JMS I GETLP-1 /GET THE FIRST SUBSCRIPT M2011, JMP I GETARG+1 /CHECK FOR DOUBLE TESTRP /CHECK THAT PARENS MATCH FIXIT /PUT SUBSCRIPT IN THE AC CLL RAL /HASH IT ('RTL', 'NOP', ETC) GS1, TAD THISOP /ADD NAME AND SUBSCRIPT TO DCA HORD /GET THE INITIAL HASH CODE TAD MSTS DCA OVER /INITIALIZE REHASH COUNTER GLOOP, TAD HORD /GET HASH (OR REHASH) CODE STL IAC TAD MSTS SNL /SKIP IF HASH < TABLE SIZE JMP .-3 DCA HORD /SAVE REMAINDER (=REHASH!) ZLOOP, TAD FCNT /INITIALIZE FIELD COUNTER DCA FLAC TAD UNAVAL /-UNAVAILABLE LOCATIONS TAD HORD IFNZRO .&177+1200-SPF PSPF, TAD PSPF /SPLIT ADR. INTO FIELDS ISZ FLAC SNL P5252, JMP PSPF DCA PT1 /MULTIPLY LOCATION BY 6 TAD PT1 STL RAL /*2+1 TAD PT1 IAC RAL /*6+4 DCA PT1 TAD FLAC /COMPUTE THE CDF CMA CLL RAL RTL TAD CDFSV DCA T2 JMS T1 /SET THE DATA FIELD TAD OVER /CHECK 'ZERO' FLAG SZA CLA TAD I PT1 /CHECK NAME STL CIA SNA JMP MAKVAR /MISSING: L=0 ISZ PT1 TAD THISOP SZA CLA JMP ZCHECK /COLLISION TAD LORD CLL CIA TAD I PT1 /CHECK SUBSCRIPT SNA CLA JMP GEXIT /FOUND IT: L=1 ZCHECK, ISZ OVER /COUNT NO. OF TRIES JMP GLOOP ERROR2 /SYMBOL TABLE IS FULL ///// MAKVAR, TAD THISOP /STORE NAME DCA I PT1 TAD LORD /AND SUBSCRIPT ISZ PT1 ZEROIT, JMS T1 /'ZERO' ENTRY DCA I PT1 TAD PT1 DCA XRT SNL /'ZERO' SETS LINK DCA I XRT DCA I XRT DCA I XRT DCA I XRT /'NOP' FOR 3-WORD VERSION GEXIT, ISZ PT1 /BUMP POINTER TO DATA CDF P POPJ /L=1 IF FOUND, 0 IF NOT ///// / CHECK FOR THE SECRET VARIABLES: GSV, TAD THISOP /CHECK FOR 'PI' TAD M2011 SNA JMP ITSPI /THAT WAS EASY! TAD P5252 /NOW LOOK FOR '@' TO '%' M640, CLL CMA TAD .-1 /REUSE HANDY INSTRUCTION SNL ISZ OVER /SKIP IF ONE-LETTER NAME JMP GM10 /AC CONTAINS SUPER HASH! CMA RTR RTR ITSPI, JMS XSETSV /SET D.F. AND PT1 FOR S.V. POPJ ///// / GET SUBSCRIPT FOR LC VARIABLES: GM10, SZL SPA SNA CLA /IS IT A LOWER CASE NAME? TAD THISOP SMA CLA JMP GS1 /UPPER CASE TAD PC DCA XRT /NEED (PC+1) CDF T TAD I XRT /USE GROUP NUMBER RTL6 AND P77 /AS THE SUBSCRIPT FLOAT JMP GS1-2 /FOR LC VARIABLES ///// *.!177-11 /FOR 'M2011' GETARG, TESTC /GET FIRST LETTER OF NAME DBLSUB+1 /FUNCTIONS AND NUMBERS CDFSV, CDF V /ARE NOT GOOD VARIABLES ERROR2 /BAD ARG IN YNCR OR ZERO GETVAR, TAD CHAR AND P77 BSW /MOVE TO THE LEFT - 'RTL6' FLOAT /CLEAR LOW BYTE, SUBSCRIPT SM1 JMP GETLP+2 /SET 'ONE-LETTER NAME' FLAG PAGE /THE 'I.O.U.' COMMANDS: IF/ON/UNTIL, INPUT/OUTPUT/USER /'IF' TESTS AN EXPRESSION, BRANCHING ON ITS SIGN/VALUE /WITH A 'GOTO' BRANCH; 'ON' IS SIMILAR, BUT USES A 'DO' /CALL. 'UNTIL' LOOPS UNTIL THE EXPRESSION IS NEGATIVE. /'I','O','U' ARE ALSO USED FOR 'INPUT'/'OUTPUT'/'USER' /COMMANDS. THE DISTINCTION IS MADE BY CHECKING FOR AN /ARITHMETIC EXPRESSION (IN PARENTHESES) FOLLOWING THE /COMMAND WORD. IF THERE IS NONE, WE LOOK FOR A SECOND /COMMAND LETTER TO IDENTIFY THE COMMAND. /THE 'IF/ON' SYNTAX IS: CMD (EXPRES)-,0,1,2,3,4,5,6,... /WHERE '-' IS THE 'NEGATIVE' BRANCH IDENTIFIER, '0' IN- /DICATES THE 'ZERO' BRANCH, AND '1,2,3,4,...' REPRESENT /BRANCHES SELECTED FROM CORRESPONDING INTEGER VALUES OF /THE EXPRESSION. ALL POSITIVE VALUES WILL TAKE THE '1' /BRANCH IF BRANCHES '2,3,4...' ARE OMITTED. NO BRANCH /IS TAKEN IF THE SELECTED IDENTIFIER IS MISSING (OR=0). /SPECIAL THANKS TO GARY COLE FOR THE IDEA OF EXTENDING /THE BRANCH LIST - IT'S THE PERFECT WAY TO INCLUDE THE /'COMPUTED GOTO' IN FOCAL (AND THE 'COMPUTED DO' TOO!). ON, SM1 /'O' COMMAND ENTRY POINT IF, DCA LASTC /'I' COMMAND ENTRY POINT JMS TSTCON /TEST CONDITIONAL EXPRESSION SM2 TESTRP /CHECK FOR MATCHING R.P. SM2 DCA LINENO /SET 2ND COMMA COUNTER TAD HORD /TEST SIGN SPA ISZ THISOP /SET BY 'TESTRP' LM30, SPA SNA CLA ISZ THISOP /COUNT COMMAS CONTINUE /KEEP LOOKING ///// THEN, SNA /MATCH? JMP ENDNB /YES: GO TO IT PUSHA /SAVE INDEX VALUE PUSHJ EVAL /READ LINE NUMBER POPA DCA THISOP /RESET COMMA COUNTER ///// ELSE, TSTCMA /TEST & SKIP THE COMMA JMP IFXIT /ONLY TWO COMMAS ISZ LINENO /TIME TO SWITCH MODES? JMP LM30+1 /NO FIXIT /SET UP COMPUTED BRANCH CIA SZA /LESS THAN, OR IAC /EQUAL TO 1.0? JMP THEN /THE 'UNTIL' COMMAND ESTABLISHES A LOOP CONTAINING ALL THE /COMMANDS ON THE REMAINDER OF THE LINE (OR THOSE DELIMITED /BY A 'NEXT'). THE FORM IS 'UNTIL (EXPR); CMDS; CMDS; ...' /WITH THE LOOP REPEATING UNTIL THE EXPRESSION IS NEGATIVE, /OR IF A LOGICAL EXPRESSION IS USED, UNTIL THE RELATION IS /TRUE. IF THIS CONDITION IS SATISFIED INITIALLY, THE REST /OF THE LINE IS SKIPPED AND THE PROGRAM CONTINUES WITH THE /NEXT SEQUENTIAL PROGRAM STEP. THE PROGRAMMER MUST ENSURE /THAT THE EXPRESSION WILL EVENTUALLY BECOME NEGATIVE(TRUE) /OR ELSE THE LOOP WILL NEVER END! HERE IS AN EXAMPLE: / Z I; UNTIL(I,GE,9);TYPE I=I+1; NEXT; U[I=I-1,EQ,0];T I /NOTE THAT INITIALIZATION STATEMENTS ARE USUALLY REQUIRED /AT THE BEGINNING ('ZERO I'), AND THAT 'NEXT' AND 'BREAK' /COMMANDS CAN BE USED TO LIMIT THE LOOP. 'FOR' LOOPS AND /'UNTIL' LOOPS CAN BE NESTED TO A TOTAL DEPTH OF 16(10). PUSHTP UNTIL, TAD CHAR /'U' COMMAND ENTRY POINT PUSHA JMS I UNTIL-1 /SAVE TEXT POSITION ///// ULOOP, POPF /RESTORE TEXT POSITION TEXTP POPA /RESTORE CHAR DCA CHAR TAD PDLXR /RE-SAVE BOTH TAD M5 DCA PDLXR JMS TSTCON /EVALUATE EXPRESSION TESTRP TAD HORD SPA CLA /CONDITION SATISFIED? JMP UEXIT /YES PUSHJ /EXECUTE REMAINDER OF LINE PROC-1 ISZ I BKSW /DID WE ENCOUNTER A 'BREAK'? JMP ULOOP /NO ///// UEXIT, SP6 /YES (OR SATISFIED CONDITION) TAD I FORLVL DCA PDLXR /RESET STACK POINTER JMP I .+1 /USE 'FOR' EXIT CODE FEXIT ///// TSTCON, 0 /LOOK FOR A LEFT PAREN TESTC /INGORE LEADING SPACES JMP LCOMP /T ENDON /F FILL IN THE BLANKS P237, 237 /N TAD LASTC /L LASTC IS CMD SWITCH CDI L /IN=0, ON=-1, U=+,NZ JMP I .+1 /CHECK THE NEXT LETTER IOCMDS /(IF U, FIX STACK PTRS!) /'LCOMP' PROCESSES EXPRESSIONS ENCLOSED IN PARENTHESES. /BOTH ARITHMETIC AND LOGICAL EXPRESSIONS ARE EVALUATED. LCOMP, TAD TSTCON /MUST BE RECURSIVE, SO... DCA THISOP /PUT RETURN ON THE STACK! JMS I (ECALL /EVALUATE THE EXPRESSION TSTCMA /ENDED WITH A COMMA? POPJ /NO - ITS AN ARITHMETIC EXPR. /LOGICAL EXPRESSIONS CONSIST OF TWO ARITHMETIC EXPRESSIONS /SEPARATED BY ONE OF THE FOLLOWING 'RELATIONAL OPERATORS': /'EQ', 'NE', 'LT', 'LE', 'GT' OR 'GE'. A COMMA BEFORE AND /AFTER THE OPERATOR IS REQUIRED, AND THE ENTIRE EXPRESSION /MUST BE SURROUNDED BY 'PARENTHESES'. EX: <3*A,GT,PI/2> /LOGICAL EXPRESSIONS HAVE TWO POSSIBLE VALUES: +1.0 IF THE /RELATION IS FALSE, -1.0 IF IT IS TRUE. 'TYPE [3,GT,2+2]' /WILL OUTPUT '+1'. WHEN SUCH EXPRESSIONS ARE USED IN 'IF' /OR 'ON' COMMANDS, ONLY THE '-' (TRUE) BRANCH IS GENERALLY /SPECIFIED: 'IF(A,EQ,B).3' BRANCHES TO XX.3 IF A=B. TAD CHAR /SAVE FIRST CHAR OF OPERATOR DCA COMP GETC /GET THE SECOND CHARACTER TAD CHAR TAD COMP /VERY SIMPLE HASH CODE! AND P237 SORTJ LGLST-1 LM10, LGGO-LGLST ERROR2 /NOT: EQ, NE, GT, LE, GE, LT ///// LGGO, EQ /THE BRANCH LIST NE GT LE GE LT IFXIT, PUSHJ /FINISH 'GTLINE' YGETLN /(HERE TO GET LM10) LGLST, "E+"Q&237 /THE OPERATOR LIST "N+"E&237 /OR "L+"G OR "G+"L "G+"T&237 "L+"E&237 "G+"E&237 "L+"T&237 JMP ENDNB+1 /THEN TEST THE RESULT /COMPUTE THE APPROPRIATE RELATIONAL INSTRUCTION AND /COMBINE THE TWO EXPRESSIONS: (A,OP,B) TESTS (B-A). NE, TAD LM10 /COMPUTE THE TEST INSTRUCTION EQ, TAD LM30 LE, TAD LM10 GT, TAD LM30 LT, TAD LM10 GE, TAD LM30 /NEAT! 'SPA SNA CLA' = '-30'! PUSHA GETC /SKIP TO THE COMMA TSTCMA JMP LM10+1 /NO COMMA = BAD OPERATOR PUSHF FLAC /SAVE FIRST VALUE PUSHJ EVAL /GET THE SECOND ONE POPF FLOP POPA /RECALL THE TEST INSTRUCTION DCA COMP FENT FSUB FLOP /COMPARE THE TWO FEXT TAD HORD /ONLY NEED TO CHECK 12 BITS COMP, SKP HLT SM1 /SET -1 IF RELATION IS TRUE STL RAL /SET +1 IF RELATION IS FALSE FLOAT POPJ /RETURN /THE 'JUMP' COMMAND TESTS THE KEYBOARD INPUT BUFFER, /PERFORMING A 'GOTO' BRANCH UNLESS THERE -IS- INPUT! JUMP, TAD INBUF /CHECK THE KEYBOARD BUFFER SZA CLA /BRANCH IF NOTHING THERE CONTINUE /FALL THROUGH TO NEXT STEP ENDNB, GETLN /CODE TO CHECK FOR MISSING LINENO SZL CLA /AND TO CHOOSE BETWEEN 'IF' & 'ON' CONTINUE /NO NUMBER = CONT. WITH SAME LINE JMP I P237-1 /OTHERWISE CHECK THE 'IF/ON' FLAG ///// PAGE /EVALUTE AN EXPRESSION ENDING WITH A TERMINATOR AND LEAVE /THE RESULT IN 'FLAC' AND 'FLARG'. 'JMS ECALL' EVALUATES /SUB-EXPRESSIONS, 'PUSHJ;EVAL' SCANS THE CURRENT ONE. NOW /HANDLES MULTIPLE REPLACEMENT OPERATORS AND CHAR VALUE OP ECALL, 0 /RECURSIVE CALL TO 'EVAL' TAD .-1 DCA PT1 PUSHF /= 'PT1, THISOP, LASTOP, SORTCN' PT1 ENEXT, DCA LASTOP /CLEAR (OR SET) OP CODE GETC /PASS TERMINATOR SKP /CONTINUE 'EVAL' ///// EVAL, DCA LASTOP /CLEAR OP CODE TESTC /TEST CHARACTER & IGNORE SPACES JMP ETERM1 /TERMINATOR JMP EFUN /FUNCTION JMP ENUM /NUMBER PUSHJ /VARIABLE: LOOK IT UP GETVAR JMS I EQUALS+1 /FOLLOWED BY AN '='? FENT FGETIPT1 /NO, MOVE VALUE TO FLAC FEXT OPNEXT, TESTC /CHECK NEXT OPERATOR JMP ETERMN /T YLST, ";&177 /F - 'YNCR' SORT LIST CR /N "-&177 /L - MISSING OPERATOR JMP EMINUS+1 TSTCON ///// ETERM1, SM2 /DO SPECIAL CHAR CHECK TAD LASTOP SMA CLA /INITIALLY OR AFTER AN '=' JMP ELPAR FLOAT /SET UP DEFAULT VALUE DCA FLAC TAD SORTCN /CHECK FOR '-', '+', PARENS TAD M4 SNA JMP EMINUS /CREATE DUMMY FOR UNARY MINUS SPA CLA JMP EVAL-2 /IGNORE UNARY PLUS, EXTRA '=' TAD SORTCN /TEST FOR NULL PARENTHESES TAD M14 SPA CLA JMP ELPAR /MIGHT BE A LEFT PARENTHESIS ETERMN, JMS LPRTST /ETERM1 FALLS THROUGH 'LPRTST' TAD SORTCN SNA /PARENS OR AN '=' OUT OF PLACE ERROR2 /MISSING OPERATOR OR ILLEGAL '=' TAD M14 SPA CLA /CHECK FOR END OF THE EXPRESSION EMINUS, TAD SORTCN DCA THISOP /ZERO = **THE END** ETERM2, TAD THISOP /COMPARE PRIORITIES CIA TAD LASTOP SPA CLA JMP ESTACK /STACK AND CONTINUE FENT BASE, FPUT I FLARGP /MOVE THE OPERAND FEXT SM1 TAD LASTOP /FIND OPERATION SNA JMP EQUALS /PROCESS AN '=' EM10, SPA SNA SZL CLA POPJ /NONE, EXIT 'EVAL' POPF FLAC /GET THE PREVIOUS RESULT TAD LASTOP CLL RTR /SHIFT OP CODE INTO PLACE RTR TAD BASE /COMPENSATES FOR OP CODE DCA OPER FENT OPER, 0000 /'FXXX I FLARGP' FEXT POPA /GET NEXT OPERATION DCA LASTOP JMP ETERM2 ///// ESTACK, JMS LPRTST /TEST FOR SUB-EXPRESSION SKP JMP EPAR2 /GO EVALUATE EXPRESSION TAD LASTOP /STACK CURRENT OPERATOR PUSHA PUSHF /SAVE THE RESULT TOO FLAC TAD THISOP JMP ENEXT /START ON NEW EXPRESSION ///// ENUM, READN /READ A NUMBER FROM TEXT JMP OPNEXT /'JMP' IS NEGATIVE ///// EFUN2, TAD CHAR /GENERATE THE HASH CODE AND EFUN+1 TAD THISOP /(UPPER -OR- LOWER CASE) CLL IAC RTL EFUN, DCA THISOP /CLEAR THE FUNCTION NAME GETC TESTX /LOOK FOR THE TERMINATOR JMP EFUN2 ///// JMS LPRTST /MUST BE FOLLOWED BY PARENS ERROR2 /VARIABLE NAME BEGINS WITH 'F' JMS ECALL /CALL 'EVAL' TO READ THE ARGUMENT POPA SNA /IS IT A FSF? JMP I .-1 CLL RAR /MAKE IT POSITIVE SORTJ /BRANCH ON THE FUNCTION CODE FNTABL-1 FNTABF-FNTABL ///// ELPAR, JMS LPRTST /LEFT PAREN OR FELL THROUGH TABLE ERROR3, ERROR2 /DOUBLE OPERATORS OR UNKNOWN FUNC EPAR2, JMS I ETERM1-1 /EVALUATE LOGICAL EXPRESSIONS EFUN3, TESTRP /'RETURN' - CLEARS AC & RESETS DF NORMALIZE JMP OPNEXT /CONTINUE WITH 'EVAL' ///// LPRTST, 0 /SKIP IF CHAR IS A LEFT PAREN TAD SORTCN TAD EM10 SNA /AND CATCH SINGLE QUOTES TOO JMP ECHR AND M4 /=7774 SNA CLA ISZ LPRTST /1-3 ARE PARENS JMP I LPRTST ///// EQUALS, POPVP /GET VARIABLE POINTER TAD FENT&177 /DOUBLE KLUDGE = 'FPUTIPT1' JMP OPER-2 ///// ECHR, ISZ I QSWTCH GETC /GET THE NEXT CHARACTER DCA I QSWTCH TAD CHAR FLOAT TESTCR /DON'T SKIP OVER A C.R. GETC / JMP EFUN3+1 /ALMOST LIKE A 'RETURN' ///// / TERMINATOR CODE TABLE FOR 'EVAL' / DCA I QSWTCH /: SWAP WITH P34 P34, 34 /; 01 = = 13 /< 03 = + 0 /= 04 = - 16 /> 05 = / 10 /' 06 = * P11, 11 /( 07 = ^ ~ 14 /) 10 = ' P6, 6 /* 11 = ( P3, 3 /+ 12 = [ { P23, 23 /, 13 = < P4, 4 /- 14 = ) JMP I MPER+1 /. 15 = ] } 5 // 16 = > 12 /[ { 23 = , M10, -10 /\ | 34 = ; 15 /] } 34 = CR 7 /^ ~ 34 = SPACE MPER, 200-". /_ -X = END EFUN3+1 ///// XSPNOR, 0 /SKIP OVER SPACES - 'SPNOR' TAD CHAR TAD CM40 M140, SZA CLA JMP I XSPNOR GETC JMP XSPNOR+1 ///// CRTEST, 0 /SKIP IF CHAR IS A CR: 'TESTCR' TAD CHAR TAD M15 SNA CLA ISZ CRTEST JMP I CRTEST /USED AS THE 'NOECHO' CALL TOO ///// PARTEST,0 /TEST PAREN MATCHING - 'TESTRP' DCA THISOP /SAVE THE AC IN 'THISOP' GETC /PASS RIGHT PAREN AND RESET DF POPA DCA LASTOP /RESTORE LAST OPERATION POPA TAD P3 /GET OPENING PAREN + 3 CIA TAD SORTCN /(PARENS DIFFER BY THREE) SZA CLA /DO THEY MATCH? ERROR2 /NO THEY DON'T - TOO BAD! JMP I PARTEST ///// /NEW ROUTINE TO TEST IF 'CHAR' IS A TERMINATOR - 'TESTX' /THIS ROUTINE WAS ORIGINALLY DEVISED BY JIM CRAPUCHETTES /(FOCAL8-269) TO REDUCE THE TIME REQUIRED FOR TERMINATOR /TESTING BY A FACTOR OF 3-5 (A NET IMPROVEMENT OF 12%). /THIS VERSION IS MUCH MORE COMPACT WITHOUT BEING SLOWER! /IT ALLOWS 'BRACES' AS WELL AS 'BRACKETS' TO BE USED FOR /ENCLOSURES, AND CHECKS FOR FUNCTION CALLS TOO... XTEST, 0 /TERMINATOR TEST - SETS 'SORTCN' TAD CHAR TAD M140 /IS IT > 140? SMA TAD CM40 /CONVERT LC TO UC TAD P6 SPA SNA /IS IT > 132? JMP TADP34 YES, TAD P11 / [ \ ] ^ { | } ~ _ TAD P3/4 / ' ( ) * + , - . / TAD TADP34 / ; < = > CR SP DCA .+1 TAD P34 /GET TERMINATOR CODE SPA JMP NO+1 /'.', '\', '|', '_' DCA SORTCN ISZ XTEST /TAKE THE 2ND RETURN JMP I XTEST TADP34, TAD P34 /IS IT > 76? SMA SZA JMP NO /IT'S A LETTER TAD P3/4 SMA /IS IT > 72/1? JMP YES+2 TAD P13/2 STL TAD P12 /IS IT 47-57? SNL SZA JMP YES+1 TAD P6 SZA /IS IT A SPACE? TAD P23 SNA CLA /OR A CR? JMP YES+2 NO, TAD M10 /IS IT A 'F'? ISZ CTEST DCA XSPNOR /SET 'F' FLAG JMP I XTEST ///// CTEST, 0 /TEST THE NEXT CHARACTER - 'TESTC' JMS XSPNOR /IGNORE SPACES JMS XTEST /CHECK FOR A TERMINATOR TAD XSPNOR /OR A FUNCTION SNA CLA JMP I CTEST /TERMINATOR OR FUNCTION ISZ CTEST JMS NTEST CM40, SMA SZA CLA /PERIOD ISZ CTEST /OTHER JMP I CTEST /NUMBER ///// NTEST, 0 /TEST FOR PERIOD, NUMBER - 'TESTN' TAD CHAR TAD MPER SZA ISZ NTEST TAD M14 /TEST FOR 0-9 CLL TAD P12 DCA SORTCN /SAVE RESULT SZL ISZ NTEST /IF A NUMBER JMP I NTEST ///// /LIST OF CODED FUNCTION NAMES (LOCATIONS IN 'FNTABF') F1= 376 F2=2366 /8 TO 7-BIT CONVERSION F3=6326 FNTABL=. "C^4+"O^4+"M^2-F3 /COM "I^4+"T^4+"R^2-F3 /ITR "R^4+"A^4+"C^2-F3 /RAC "S^4+"G^4+"N^2-F3 /SGN "A^4+"B^4+"S^2-F3 /ABS "S^4+"Q^4+"T^2-F3 /SQT "R^4+"A^4+"N^2-F3 /RAN "S^4+"I^4+"N^2-F3 /SIN "C^4+"O^4+"S^2-F3 /COS "A^4+"T^4+"N^2-F3 /ATN "L^4+"O^4+"G^2-F3 /LOG "E^4+"X^4+"P^2-F3 /EXP "M^4+"I^4+"N^2-F3 /MIN "M^4+"A^4+"X^2-F3 /MAX "A^4+"N^4+"D^2-F3 /AND "R^4+"D^4+"G^2-F3 /RDG "R^4+"A^2-F2 /RA "I^4+"N^2-F2 /IN "O^4+"U^4+"T^2-F3 /OUT "I^4+"N^4+"D^2-F3 /IND "B^4+"L^4+"K^2-F3 /BLK "L^4+"E^4+"N^2-F3 /LEN "T^4+"A^4+"B^2-F3 /TAB "T^4+"R^4+"M^2-F3 /TRM "P^4+"A^4+"L^2-F3 /PAL "T^4+"I^4+"M^2-F3 /TIM "S^4+"R^2-F2 /SR "M^4+"Q^2-F2 /MQ "V^4+"B^2-F2 /VB "A^4+"D^4+"C^2-F3 /ADC "L^4+"G^4+"S^2-F3 /LGS "D^4+"I^4+"N^2-F3 /DIN "D^4+"A^4+"C^2-F3 /DAC "C^4+"U^4+"R^2-F3 /CUR "D^4+"A^4+"Y^2-F3 /DAY "Q^2-F1 /Q UM1, -1 /END /THE HASH CODE HAS BEEN CHANGED TO IMPROVE UNIQUENESS: /CHARACTERS ARE SHIFTED 2 BITS AT A TIME AFTER CONVER- /TING LOWER CASE TO UPPER CASE. A RIGHT-SHIFT AT THE /END ENSURES THAT THE CODED NAME IS -ALWAYS- POSITIVE. /UNPACK A CHARACTER FROM THE TEXT BUFFER: 'GETC' UTRA, 0 /UNPACK 'EXCESS-40' CODE JMS GET1 JMP TOGL /QUESTION MARK TAD C100 UTX, DCA CHAR TAD I QSWTCH /IF XPRNT=0, TRAP '?' MARKS TAD TRACE / >0, IGNORE '?' MARKS SPA CLA /IF TRACE=0, THE TRACE IS OFF PRINTC / -1, THE TRACE IS ON JMP I UTRA /PRINT ONLY IF SUM IS NEGATIVE ///// TOGL, AND I QSWTCH /DOES '?' GET SPECIAL ATTEN? SZA CLA JMP UTQ /NO, TREAT IT NORMALLY ISZ TRACE SM1 /TOGGLE THE TRACE FLOP DCA TRACE JMP UTRA+1 /GET THE NEXT CHARACTER ///// GET1, 0 /UNPACK 6 BITS ISZ XCT JMP GET3 /GET LEFT BYTE TAD GTEM GET2, CDF P /'GETC' RESETS D.F. AND P77 TAD M37 /QSTMRK OR RUBOUT? SZA UTQ, ISZ GET1 /NO: TAKE 2ND EXIT TAD UM1 SZA /CTRL CODE OR L.C.? JMP I GET1 ///// JMS GET1 /YES - GET 2ND BYTE AND C100 /'@' AND P177 /KEEP THE GOOD BITS JMP UTX ///// M37, -37 GET3, CLA CMA /RESET THE FLIP-FLOP DCA XCT CDF T TAD I AXOUT /GET 12-BITS DCA GTEM TAD GTEM BSW /RTR;RTR;RTR JMP GET2 /RETURN WITH THE FIRST CHARACTER ///// *FSUB I FP1 SORTB, 0 /SORT AND BRANCH ROUTINE - 'SORTJ' SNA TAD CHAR /ASSUME CHAR IF AC=0 CIA DCA UTRA TAD I SORTB /FIRST ARGUMENT IS LIST-1 ISZ SORTB DCA XRT SLOOP, TAD I XRT SPA /LISTS ARE ENDED BY NEG. NUMBERS! JMP SEX /NOT THERE! TAD UTRA SZA CLA /MATCH? JMP SLOOP /NOT REALLY TAD XRT TAD I SORTB /COMPUTE ADDRESS DCA SORTB TAD I SORTB /DEBUG: AC = ADDRESS DCA SORTB SEX, SZA CLA /CLEAR AC IF NO MATCH ISZ SORTB /TAKE THE SECOND EXIT JMP I SORTB ///// /THE 'Y' COMMAND ADDS OR SUBTRACTS ONE TO A LIST OF VARI- /ABLES DEPENDING UPON WHETHER THE NAME IS PRECEEDED BY A /MINUS SIGN OR NOT. THUS 'Y I' IS THE SAME AS 'S I=I+1', /WHILE 'Y-I' IS LIKE 'S I=I-1'. SPACES, COMMAS OR MINUS /SIGNS MAY BE USED TO SEPARATE THE NAMES: 'Y N-O,P Q- R' /WILL ADD ONE TO 'N,P,Q' AND SUBTRACT ONE FROM 'O,R'. DECR, GETC /PASS THE MINUS SIGN TAD SORTJ&177 /MODIFY THE INSTRUCTION DCA YNCR-3 /'FADD/FSUB I FP1' SPNOR SORTJ /CHECK ON WHAT TO DO YLST-1 YGO-YLST PUSHJ /ERRORS WILL BE TRAPPED HERE GETARG TSTCMA /REMOVE SEPARATORS FADD I FP1 /NOP FENT FGETIPT1 /LOAD THE VARIABLE FADD I FP1 /ADD OR SUBTRACT ONE FPUTIPT1 /STORE IT AWAY AGAIN FEXT YNCR, TAD .-6 /'Y' DO WE HAVE THIS COMMAND? JMP DECR+2 /BECAUSE THE USERS DEMAND IT! ///// /LIST OF FUNCTION ADDRESSES (NAMES ARE IN 'FNTABL') FNTABF=. FCOM /COM -COMMON STORAGE FITR /ITR -INTEGER PART FN FRAC /RAC -FRACTIONAL PART FSGN /SGN -SIGN= -1, 0, +1 FABS /ABS -ABSOLUTE VALUE FSQT /SQT -SQUARE ROOT FRAN /RAN -RANDOM NUMBER FSIN /SIN -TRIG FUNCTIONS FOR FCOS /COS -ANGLES IN RDG UNITS FATN /ATN -DEGREES = 'FRDG(90)' FLOG /LOG -NAPERIAN LOGARITHM FEXP /EXP -EXPONENTIAL (BASE E) /ADDITIONAL NUMERIC AND I/O FUNCTIONS FMIN /MIN -MINIMUM VALUE FMAX /MAX -MAXIMUM VALUE FAND /AND -DOUBLE PRECISION 'AND' FRDG /RDG -CIRCULAR MEASURE UNITS FRA /RA -RANDOM ACCESS STORAGE FIN /IN -SINGLE CHARACTER INPUT FOUT /OUT -SINGLE CHARACTER OUTPUT FIND /IND -CHARACTER SEARCH FBLK /BLK -STARTING BLOCK FLEN /LEN -FILE LENGTH FTAB /TAB -PRINT POSITION FTRM /TRM -INPUT TERMINATOR /ADDITIONAL LABORATORY-TYPE FUNCTIONS FPAL /PAL -MACHINE LANG. ROUTINES FTIM /TIM -ELAPSED TIME INTERVAL FSR /SR -READ (RIGHT) SWITCHES FMQ /MQ -DISPLAY ARG IN THE MQ ERROR3 /VB -DISPLAY BUFFER STORAGE ERROR3 /ADC -ANALOG INPUT ERROR3 /LGS -EVENT FLAGS ERROR3 /DIN -DIGITAL INPUT ERROR3 /DAC -ANALOG OUTPUT ERROR3 /CUR -TEKTRONIX CURSOR INPUT FDAY /DAY -GET OR SET SYSTEM DATE FQUE /Q -MULTI-TASKING /INSERT A CHAR IN THE TEXT BUFFER - 'PACKC' PACBUF, 0 /ALSO HANDLES DELETIONS DCA PCK1 /SAVE LINENO PROTECTION SORTJ C100-1 /CHECK FOR '@', 'RO' PACGO-C100 TAD CHAR TAD PM40 /DECODE AND C100 /EXTENDED? PM40, SMA SZA CLA JMS PCK1 /001-037, 140-176, 100 TAD CHAR PACX, SZA JMS PCK1 /040-077, 101-137 CDF P DCA RUB3 /RESET ERROR TRAP JMP I PACBUF ///// PCAT, CMA /REPLACE 100 WITH 177 DCA CHAR JMP PM40+1 ///// PCK1, 0 TAD PCAT /XS40 PACKING P100, AND P77 ISZ T3 /=0 TO START JMP PCK2 TAD LASTC DCAIAXIN JMP I PCK1 ///// PCK2, RTL6 /COULD USE 'BSW' DCA LASTC STL CMA DCA T3 TAD EX1 /BREATHING SPACE TAD AXIN TAD TXTEND /CHECK TEXT LIMIT SNL CLA ERROR2 /TEXT BUFFER FULL JMP I PCK1 ///// AXIND, 0 /FILL TEXT BUFFER - 'DCAIAXIN' CDF T DCA I AXIN CDF P JMP I AXIND ///// /SPECIAL 'PACKC' CHARACTERS: PACGO, PCAT /@ - C100 RUB1 /RO - P177 ///// RUB1, TAD T3 /RUBOUT ONE LETTER SMA CLA /HALF-WORD? JMS RUB3 /CHECK POSITION TAD PDEL /PRINT 8-BIT '\' ON JMP .+4 /HARDCOPY TERMINALS / ECHOC TAD PCAT /OR 'BS', 'SP', 'BS' ECHOC TAD PDEL /ON VIDEO TERMINALS ECHOC TAD AXIN DCA PT1 CDF T ISZ T3 /WHICH HALF? JMP RUB2 TAD I PT1 /'T3' HAS BEEN RESET! TAD PM40 AND P77 /TEST FOR EXTENDED CHAR SMA SZA CLA JMP PACX JMS RUB3 /LOOK OUT FOR LINE NUMBERS! RUB2, CLL CMA /PROCESS THE UPPER BYTE TAD AXIN DCA AXIN /RESET STORAGE POINTER SM0 TAD I PT1 /TEST FOR EXTENDED (40XX) BSW /RTL6;RAL AND P77 JMP PACX /REPACK IF NOT EXTENDED ///// P144, 144 /FOR 8/E EAE VERSION ///// RUB3, 0 /WATCH OUT FOR THE BEGINNING TAD AXIN STL CIA TAD BUFR TAD PCK1 /PROTECT THE LINENO SNL CLA JMP PACX /DON'T DO ANYTHING! JMP I RUB3 ///// /A NOTE OF APPRECIATION TO EDWARD TAFT III FOR SOME /GOOD 'PACKC' IDEAS: DECUS FOCAL8-52 ('FOCAL 5/69'). /THE QUIT COMMAND NOW HAS A 'RESTART' OPTION: 'QUIT 5.1' /WILL STOP THE PROGRAM, AND THEN RESTART IT AT LINE 5.1. /'QUIT 0' (OR JUST 'Q') WORKS AS BEFORE. THE RESTART CAN /BE DEFERRED UNTIL THE OCCURRENCE OF ANY ERROR BY SPECI- /FYING A NEGATIVE LINE NUMBER: 'QUIT -5.1' WILL SAVE THE /LINE NUMBER UNTIL YOU ACTUALLY GET AN ERROR. QUIT, GETLN /GET THE LINE NUMBER SZL JMP START /ZERO: (OR NO ARGUMENT) TAD T3 SMA CLA /CHECK THE SIGN JMP ERTRAP+1 /POSITIVE: AUTO-RESTART TAD LINENO DCA RUB3 /NEGATIVE: SAVE FOR LATER CONTINUE ///// ERTRAP, DCA LINENO /MOVE THE LINE NUMBER TAD BOTTOM DCA PDLXR TAD LEVEL0 /CLEAR THE STACKS DCA FORLVL DCA RUB3 TAD M4 /CREATES 'PUSHJ;GOTO+1' JMP I INPUTP /THEN RESTART THE PROG. /ERROR RECOVERY ROUTINE: MODIFIED FOR THE ERROR TRAP ERROR, 0 /TAB COUNTER TOO ! I0N KCC TAD TELSW /WAIT FOR TTY TO FINISH SZA CLA JMP .-4 CDF P TAD RUB3 /SHOULD WE TRAP THIS ONE? SZA JMP ERTRAP /YES TAD ERROR /PROCESS ERROR CODE TO INPUTP, AND P100 /ELIMINATE NON-NUMERICS CMA STL RAR /7777 OR 7737 JMP I (M20+1 /NO - REPORT IT PAGE 25 /FOR STACK ROUTINES CONT, SKP CLA /COMMAND RETURN - 'CONTINUE' GETC SORTJ /SEARCH FOR A ';' OR A C.R. ILIST-1 IGO-ILIST /';'='PROC-1', 'CR'='PROC+2' JMP CONT+1 ///// FLIST, FLIMIT /, - LIST FOR 'SET' AND 'FOR' FINFIN /; FORERR /CR ///// /THE FOLLOWING ARE SET UP BY THE INITIALIZATION ROUTINE NUMVF, +NF /NO. OF DATA FIELDS IN USE MAXVF, -NF-1 /NO. OF DATA FIELDS ALLOWED MISING, 4+RESRVD+SPF&7776/NUMBER OF MISSING SYMBOLS /CODE TO ZERO THE SYMBOL TABLE REPLACES CODE TO DUMP IT ZAPPER, GETNXT /GET SIZE (FIELD) PARAMETER TAD MAXVF /TEST AGAINST MAX. SZL CLA ERROR2 /TOO MANY TAD LORD SZA /'NONE' = 'PREVIOUS' DCA NUMVF ZINITL, TAD NUMVF /SET THE FIELD COUNTER CMA DCA THISOP /CLEAR THE NAME TAD THISOP DCA FCNT /'CLA' TO SKIP FIELDS TAD MISING TAD (-SPF /MULTIPLY: SPF*FIELDS ISZ THISOP JMP .-2 DCA MSTS /SAVE TOTAL SYMBOL COUNT TAD MSTS IAC /SKIP THE HIGHEST ONE FLOAT /(LOOP COUNTER = SYM. #) PUSHJ /ONE GOOD LOOP - ZLOOP /DESERVES ANOTHER... ISZ HORD /BUMP POSITION BY ONE JMP .-3 /THIS TAKES A LITTLE WHILE ///// /FALL INTO 'POPJ' FOR EXIT /PUSHDOWN LIST SUBROUTINES (THE STACK IS IN FIELD 0) XPOPJ, CDF S TAD I PDLXR /GET THE RETURN ADDRESS DCA XPOPA JMP XPOPA+3 /RESTORE D.F. AND BRANCH XPUSHJ, 0 /RECURSIVE SUBROUTINE CALL TAD I XPUSHJ /GET THE TARGET ADDRESS DCA XPUSHA /SAVE FOR THE INDIRECT JUMP TAD XPUSHJ /GET THE RETURN ADDRESS IAC /BUMP IT SKP XPUSHA, 0 /PUSH THE AC ONTO THE STACK CDI L JMP APUSHX JMP I XPUSHA XPOPA, 0 /PULL SOMETHING OFF THE STACK CDF S TAD I PDLXR CDF P JMP I XPOPA XPUSHF, 0 /SAVE A FLOATING-POINT NUMBER TAD XPUSHF CDI L /USE LOWER FIELD ROUTINE DCA I PUSHJ&177 CDF P /RESET THE CALLING FIELD JMP MPUSHF+2 /UPPER FIELD ENTRY POINT XPOPF, 0 /POP A FLOATING-POINT NUMBER CLA CMA TAD I XPOPF /BACKUP DATA POINTER ISZ XPOPF /AND ADVANCE THE RETURN DCA XRT JMS XPOPA /DUMP FOUR WORDS DCA I XRT JMS XPOPA DCA I XRT JMS XPOPA DCA I XRT JMS XPOPA DCA I XRT JMP I XPOPF XPOPVP, 0 /RESTORE VARIABLE POINTER JMS XPOPA DCA T2 JMS XPOPA DCA PT1 JMP I XPOPVP /USED BY 'FOR' AND 'EVAL' /REMOVE A LINE OF TEXT AND RECOVER THE SPACE - 'DELETE' XDELETE,0 TAD LINENO /TRYING TO DELETE LINE 0? SNA CLA JMP START /JUST IGNORE SUCH COMMANDS FINDLN /SETS THISLN, LASTLN, AND TEXTP JMP I XDELETE /ALREADY GONE ///// I0F /PROTECT TEXT POINTERS GETC /MEASURE LENGTH TESTCR JMP .-2 TAD AXOUT /GET LAST ADDRESS CMA TAD THISLN /SUBTRACT FROM FIRST DCA T1 TAD T1 /CORRECT BUFFER POINTER TAD BUFR DCA BUFR CDF T TAD I THISLN /DISCONNECT DCA I LASTLN TAD HEADER /START AT THE BEGINNING XLOOP, DCA LASTLN /CORRECT LINE POINTERS TAD I LASTLN /GET THE NEXT ADDR DCA GTEM /SAVE TAD GTEM /COMPARE LINE POSITIONS CLL CIA TAD THISLN SNL CLA /SKIP IF THISLN > X TAD T1 /CHANGE (X) TO ACCOUNT TAD GTEM /FOR GARBAGE COLLECTION DCA I LASTLN TAD GTEM /GET NEXT SZA /TEST FOR END JMP XLOOP ///// TAD AXIN /COMPUTE COUNT CIA TAD AXOUT DCA XCT CMA TAD THISLN /RESET AXIN DCA AXIN TAD I AXOUT DCA I AXIN /SHIFT REMAINDER OF BUFFER DOWN ISZ XCT JMP .-3 JMP XDELETE+4 /RESET 'LASTLN', 'THISLN' AND D.F. ///// PAGE 15 /TERMINAL I/O HANDLERS: /OUTPUT BUFFER WAS ELIMINATED AND THE INPUT MODIFIED /TO INCREMENT A RANDOM NO. OR CALL A DISPLAY ROUTINE KEYCK, XI33+1 /PATCHED BY DISPLAY ROUTINE MCC, -3 /CTRL/C TEST OPTRO, 0 /DOUBLE-BUFFERED OUTPUT OPTRI=. /'I'= 'IN', 'O'= 'OUT' XI33, 0 /VIA (INDEV) ISZ I GTEM /BUMP RANDOM NUMBER TAD INBUF /ANY INPUT? SNA /YES AND NON-ZERO RNDM NO. JMP I KEYCK /NO OR ZERO RANDOM NUMBER DCA XI33+1 /SAVE AND KILL 'ISZ' DCA PAUSW /CLEAR EXTRA CTRL/S'S DCA INBUF /CLEAR INPUT BUFFER KCC /INITIATE NEXT READ JMP XI33X /KEEP (XOUTL-XI33)=12 XOUTL, 0 /VIA (OUTDEV) DCA OPTRI /SAVE CURRENT CHARACTER I0N /BE SURE INTERRUPT IS ON TAD OPTRO /ANY ROOM? SZA CLA /A CHARACTER IS NON-ZERO JMP .-3 /NO = WAIT TAD OPTRI DCA OPTRO /OK, PUT IT IN THE BUFFER CDI P /PROTECT TELSW TAD TELSW SNA CLA /WILL THE FLAG COME UP? TFL /FORCE IT JMP I XOUTL /RE-ENABLE INTERRUPTS ///// XI33X, TAD XI33+1 /REMOVE PARITY AND P177 JMP I XI33 /RETURN CHAR IN THE AC ///// M10D, -12 /CLOCK CONSTANTS TICK, TOCK ETIM, TIMERS ///// XOFF, TAD TINT+1 /SET THE PAUSE SWITCH XON, DCA PAUSW KCC /CLEAR THE INPUT FLAG JMP PAUSW ///// CLZE=6130 /KE8E CLOCK INSTRUCTIONS CLDE=6132 CLAB=6133 CLSA=6135 /(ALSO VT/78,278,EURO12) /INTERRUPT PROCESSOR: HANDLES ^C, ^F, ^S AND ^Q INTRPT, DCA SAVAC /SAVE WORKING REGISTERS RAR DCA SAVLK KINT, KSF /NOW CHECK THE KEYBOARD JMP TINT KRS /READ BUFFER AND P177 /IGNORE PARITY SNA /LEADER/TRAILER? JMP XON+1 TAD MCC SNA /TEST FOR CTRL C JMP MINT TAD M20 SNA /TEST FOR CTRL S JMP XOFF IAC IAC /TEST FOR CTRL Q SNA JMP XON TAD P13 /'IAC' -> CTRL P SNA CLA /TEST FOR CTRL F JMP M20+2 KRS /RE-READ CHAR DCA INBUF KCF /CLEAR FLAG TINT, TSF /CHECK OUTPUT NEXT JMP CINT TCF DCA TELSW /TURN OFF BUSY FLAG PAUSW, 0 /OR 'JMP CINT' TAD OPTRO /GET NEXT CHARACTER SZA TLS /TYPE IT DCA TELSW /SET FLAG DCA OPTRO /REMOVE IT CINT, CLSA /CLOCK FLAG UP? SMA CLA JMP XINT /NO ISZ LTIM SKP /BUMP FTIM COUNT ISZ HTIM ISZ I TICK /0.1 SECOND YET? JMP XINT /NO TAD ETIM JMS I TICK /BUMP EVENT TIMERS TASKID, 0 JMS I TICK 0 JMS I TICK 0 JMS I TICK 0 TAD M10D /RESET PRE-SCALER DCA I TICK ISZ OTIM /BUMP HESITATE TIMER XINT, NOP /CLEAR ANNOYING FLAGS PCE 6655 /LINEPRINTER FLAGS 6665 TAD SAVLK CLL RAL TAD SAVAC CDI JMP PRNTSP /DISMISS THE INTERRUPT MINT, CDI /CTRL/C EXIT JMP I P7600 /KBM = 07600 /PRINT THE ERROR MESSAGE RESTOR= JMP XINT /KLUDGE FOR RESTORE DCA TELSW /CLEAR THE BUSY FLAG M20, SMA SZA SNL CLA /SKIP ERROR CODE TAD I TABCNT /AC= -1 OR -41 CDI L JMS I TASKID-3 /RESTORE TERMINAL I/O DCA OPTRO DCA PAUSW TAD CCR /START A NEW LINE? CLA / PRINTC TAD P77 /PRINT A '?' PRINTC PRNTLN /PRINT ERROR CODE ISZ PC CDF T TAD I PC /GET PROGRAM STEP SNA JMP ERRX /DIRECT COMMAND ERROR DCA LINENO TAD C100 PRINTC /PRINT '@', RESET D.F. PRINTC /SPACE PRNTLN /LINE NO. ERRX, DCA INBUF /'JMP BYEBYE' UNDER BATCH TAD CCR ECHOC JMP START /PATCH FOR ERROR MESSAGES ///// PAGE /END OF COMMAND PROCESSOR