/ U/W-FOCAL VERSION 4E FOR 16K / 16KCPR.PA / REVISIONS: / NEW FLAGS CLEARED AT 13112 - 13126 / COPYRIGHT (C) 1978 - ALL RIGHTS RESERVED BY / LAB DATA SYSTEMS - SEATTLE, WASHINGTON 98125 / **CORE MAP** / (16K VERSION) /FIELD 0: USER AREA, STACK, OS/8 ROUTINES, & I/O BUFFERS /FIELD 1: INTERPRETER, FUNCTIONS, FLOATING POINT PACKAGE /FIELD 2: PROGRAM TEXT ASCENDING - FCOM AREA COMING DOWN /FIELD 3: VARIABLES / 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 CDI=CDF CIF FIXTAB / SPECIAL PSEUDO-OPS FOR CROSS-FIELD CALLS: FGETIPT1=FGET I 0 FADDIPT1=FADD I 0 FMULIPT1=FMUL I 0 FPUTIPT1=FPUT I 0 / ASSEMBLY INSTRUCTIONS USING PAL8-V10: / UWF.BN<16KCPR,12KFNS,8KFIO,8KFPP,16KLIB/L/K=100 / EAE VERSION: 8XFIO,8XFPP / FIELD 1 /PROCESSOR FIELD PAGE 0 P134, "\&177 /SCOPE INPUT LIST BELL, "G&277 /MODIFY " " P337, "_ /COMMAND " " CFF, FF CLF, LF CCR, CR TRACE, RO /SEARCH CHAR & TRACE SWITCH FPNT /ADDRESS OF F.P. INTERPRETER /AUTO-INDEX REGISTERS SAVMQ, 0 /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, 0 /UNPACKING TEMP. STORAGE XCT, RANDOM+1 /UNPACKING SWITCH PC, 100 /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 BUFEND, -7557 /LAST PROGRAM LOCATION TXTEND, -7577 /LAST LOCATION FOR INPUT FIRSTV, STVAR /**MASTER LOCATION** SECRTV, STVAR-1 /BEGINNING OF VARIABLES TABEND, -3 /END OF THE SYMBOL TABLE /'E1' FOR 8K, '2200' FOR 12K IFNDEF STVAR /'3200' FOR 8K, '2200' FOR 12K /MISCELLANEOUS THINGS 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, 0 /FOR ABS VALUE & MUL/DIV T1, 0 /FOR INSTRUCTIONS & F.P.P. T2, 0 /FOR FUNCTIONS & I/O T3, 0 /ARGUMENT SIGN & DEC. EXP. FLAC=. EXP, 0 /FLOATING ACCUMULATOR HORD, 0 LORD, 0 OVER, 0 FLOP=. EX1, 0 /FLOATING OPERAND AC1H, 0 AC1L, 0 OVR1, 0 TELSW, 0 /OUTPUT DONE FLAG INBUF, 0 /INPUT BUFFER (*LOC 55) INDEV, XI33 /POINTER TO INPUT DEVICE OUTDEV, XOUTL /AND OUTPUT DEVICE (TTY) BUFR, LINE1 /NEXT LOCATION IN TEXT BUFFER LASTV, STVAR /NEXT LOCATION IN SYMBOL TABLE PT1, 0 /VARIABLE POINTER THISOP, 0 /CURRENT OP, FN OR VARIABLE NAME LASTOP, 0 /PREVIOUS ARITHEMETIC OPERATION SORTCN, 0 /RELATIVE POSITION IN A LIST CHAR, 0 /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 FISW, 0 /CODED OUTPUT FORMAT THISLN= THISOP /NOT USED SIMULTANEOUSLY LASTLN= LASTOP /CONSTANTS USEFUL THROUGHOUT FOCAL: P7, 7 /FOR 'FPOW' AND DIGIT MASK P13, 13 /FOR FLOAT AND PDLXR POINTER P177, 177 /STEP MASK & POINTER P43, 43 /35 BITS P77, 77 /RIGHT MASK C100, 100 /CHARACTER TESTS & PC0 P17, 17 /BCD MASK AND CONSTANT C200, 200 /TEST CONSTANT & POINTER C240, 240 /SPACE P7600, 7600 /GROUP MASK & FLARG POINTER FLARGP= P7600 /TEMPORARY STORAGE FOR 'EVAL' M4, -4 /FOR 'GETARG', 'FPOW', & 'FRAN' M5, -5 /FOR 'PRINTN', 'QUIT', ' 'FSQT' M14, -14 /FOR 'LPRTST', 'TESTN' MCR, -CR /FOR 'WRITE','IF','DELETE','PRINTC' FP1, FLTONE /FOR 'FLOG', 'FSIN', 'Y' & 'DBLSUB' GINC, WORDS+2 /FOR 'GETARG', 'TDUMP' & 'FSF'S *.+5 /FOR USER CONSTANTS /TEMPORARY STORAGE HAS ALL BEEN PLACED ON THE LAST /PAGE USING THE COMMAND DECODER AREA FROM 7600-7646. FLARG= 7600 /TEMPORARY FOR 'EVAL' NEXTP= 7604 /TEXT POINTERS FOR 'NEXT' & 'BREAK' BUFFER= 7610 /TEMPORARY FOR FUNCTIONS & OUTPUT RANDOM= 7642 /UPPER LIMIT FOR STACK POINTERS /SYMBOLS USEFUL THROUGHOUT FOCAL: WORDS=4 /HURRAY! DIGITS=12 L=00 /DATA FIELD FOR LIBRARY V=30 /DATA FIELD FOR VARIABLES S=00 /DATA FIELD FOR THE STACK P=10 /DATA FIELD FOR PROCESSOR T=20 /DATA FIELD FOR THE TEXT LF=212 FF=214 CR=215 SP=240 RO=377 /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 . /SAVE 4 WORDS XPUSHF POPF= JMS I . /RESTORE THEM XPOPF SORTJ= JMS I . /SORT AND BRANCH ON AC OR CHAR SORTB SORTX= JMS I . /LOOK FOR SP, COMMA, SEMI, CR XSORT 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 READC= JMS I . /READ & 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 PRINTD= JMS I . /PRINT A SINGLE DIGIT FROM THE AC OUTDG READN= JMS I . /USE 'FETCH' TO INPUT A NUMBER FLINTP PRINTN= JMS I . /CONVERT BINARY TO ASCII & PRINT ATSW, FLOUTP /FOR 'ASK', 'TYPE', 'FBLK' & 'FRA' PACKC= JMS I . /PACK A CHARACTER PACBUF GETC= JMS I . /UNPACK A CHARACTER BKSW, UTRA /'BREAK' SWITCH SPNOR= JMS I . /IGNORE LEADING SPACES XSPNOR 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 DMPSW, XPRNT /TRACE DISABLE SWITCH DELETE= JMS I . /REMOVE A LINE AND PACEND, XDELETE /RECOVER THE SPACE DCAIAXIN=JMS I . /'DCA I AXIN' IN FIELD T AXIND /FLOATING POINT PSEUDO INSTRUCTIONS: FLOAT= JMS I . /FLOAT THE AC FIGO6 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 INTEGER MULT10= JMS I . /MULTIPLY FLAC BY TEN & ADD THE AC XTEN CHKSGN= JMS I . /TAKE ABSOLUTE VALUE + CHECK FOR 0 SGNCHK RTL6= JMS I . /ROTATE THE AC LEFT 6 BETA, XRTL6 /FOR THE PDP12 OVERLAY *.+4 /PATCH AREA PRODUCT=. /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 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 4 *177 START=. /PROGRAM SELF-START (=7610) BUFFPT, SKP CLA /OUTPUT BUFFER IS AT 17610. JMP I "* /CONSOLE START (FROM 10200) TAD .-1 /ANNOUNCE PRESENCE ECHOC /(DON'T PRINT IF THE ECHO IS OFF) TAD BOTTOM DCA PDLXR /RESET THE STACK POINTERS TAD LEVEL0 DCA FORLVL TAD TXTEND /SET THE INPUT LIMIT DCA I PACEND TAD C100 /SET PC FOR COMMAND MODE DCA PC IBAR, DCA T3 /RESET THE PACKING SWITCH *FF /RETURN FROM LINEFEED TAD BUFR /INITIALIZE THE BUFFER POINTER DCA AXIN /=*CR DCA TRACE /TURN OFF THE TRACE DCA I DMPSW /BUT ENABLE THE TRAP IGNOR, READC /READ THE COMMAND STRING SORTJ P337-1 INLIST-P337 PACKC /SAVE EACH LITTLE CHARACTER JMP IGNOR ///// INLIST, IBAR /B.A. = RESTART IGNOR /F.F. = IGNORE LNFEED /L.F. = RETYPE IRETN /C.R. = TERMINATE ///// IRETN, PACKC /PACK THE CR PACKC /BE SURE ITS ALL THERE TAD BUFEND DCA I PACEND /SET REPACKING LIMIT TAD BUFR /INITIALIZE 'TEXTP' ///// /TEXT BUFFER FORMAT: /#1 : POINTER OR ZERO IN LAST /#2 : LINENO /#3 - #N-1 : TEXT /#N : CR (=7715) /IMMEDIATE AND SEQUENTIAL COMMAND EXECUTION: NEXTLN, DCA AXOUT /SET LINE 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 /NO, ITS A DIRECT COMMAND ISZ I DMPSW /YES, KILL TRACE TO PROTECT '?' GETLN /READ THE LINE NUMBER JMS I MODIFY+2 /INITIALIZE THE NEW LINE JMP SRETN /REPACK THE FIRST CHARACTER *"* /FOR 'LINEFEED' M20-1 /MANUAL RESTART ECHOFF, PRINTC /ECHO FF TO CLEAR THE SCREEN JMP IGNOR /(FOR THE SCOPE VERSIONS) GETC /GET THE NEXT CHARACTER SRETN, PACKC /REPACK TESTCR /TEST FOR THE END OF LINE JMP .-3 PACKC /FINISH THE CR DELETE /REMOVE THE OLD LINE, IF ANY CDF T TAD I LASTLN /INSERT NEW ONE DCA I BUFR TAD BUFR DCA I LASTLN TAD T3 /-1 IF CR NEEDED 2ND WORD CIA TAD AXIN /COMPUTE NEW END-OF-BUFFER DCA BUFR CDI L DCA I P77 /SET 'PROGRAM MODIFIED' FLAG JMP 100 /TURN ON INTERRUPTS & RESTART ///// *"? /FOR 'QUIT' VIA 'PACLST' TAD M5 /CREATES 'PUSHJ;GOTO+1' INPUTX, PUSHJ /PROCESS THE IMMEDIATE COMMAND PROC CDF T TAD I PC SNA /END OF THE PROGRAM? JMP START /YES DCA PC /SAVE THE NEW LINE POINTER TAD PC IAC /ADVANCE TO THE LINENO JMP NEXTLN /AND CONTINUE PROCESSING /LINE NUMBER EVALUATION: 'GETLN' XGETLN, 0 /NOW HANDLES NEGATIVE NUMBERS TAD .-1 / AND PERMITS RECURSIVE CALLS PUSHA PUSHJ /EVALUATE THE ARGUMENT EVAL MODEPT, TAD EXP /MODIFY AND FSF ENTRY POINT TAD M5 SMA SZA CLA /.GT. 31? ERROR2 TAD PC /POINT TO THE CURRENT LINE DCA XRT TYPEPT, 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 RTL6 /SHIFT INTO PLACE ('BSW') 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 FENT /RESETS D.F. FADD I FLARGP /SUBTRACT THE GROUP NUMBER FMUL FL100 /SHIFT THE DECIMAL POINT FADD FLP5 /ROUND OFF THE RESULT FEXT FIXIT /LEAVES L=0 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' /LINE NUMBERS MAY RANGE FROM 0 TO +- 31.99 /NEGATIVE NUMBERS FORCE THE 'GROUP' SWITCH. / NAGSW: /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 ERROR2 /NOT THERE TAD HORD /TEST SECOND ARGUMENT SZA CLA /NEW LINENO? PUSHJ /YES: 'MOVE' AS WELL AS 'MODIFY' MODEPT /.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 A '_' 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 /B.A. = DELETE LINE TO THE LEFT SCHAR /F.F. = LOOK FOR NEXT OCCURANCE 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, ZBLOCK 2 /INITIALIZE A NEW LINE DCA T3 TAD BUFR /RESET INPUT POINTERS DCA AXIN TAD LINENO /PACK LINENO DCAIAXIN ISZ I DMPSW /KILL THE TRACE JMP I INITLN /USED BY MODIFY, ERASE AND INPUT /OUTPUT THE INDIRECT PROGRAM WEND, POPA /RESTORE TEXT POINTERS DCA CHAR POPF TEXTP DCA I DMPSW /RESTORE TRACE 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 AN ARGUMENT JMP ZALL /NO ARG = ALL VARIABLES GETC /F (SLIGHT FUDGE) SPNOR /N (ALSO ILLEGAL) SORTJ /L VARIABLE NAME ZLIST-1 ZGO-ZLIST PUSHJ /NOT A TERMINATOR GETARG /SO IT MUST BE A NAME ISZ XRT2 /ADVANCE DATA POINTER PUSHJ ZFOUND /THEN ZAP IT JMP ZERO+3 ZALL, TAD FIRSTV /RESET THE TABLE DCA LASTV JMP ZERO+4 /E.G. Z,A,B,C... ///// 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 CML CMA RAR / 3777 OR 7777 DCA LASTLN /SET RETURN FLAG POPF /RESTORE FSF FLARG /'CLA' POPJ /GO BACK A LEVEL /PRIMARY CONTROL AND TRANSFER GOTO, GETLN /READ THE LINE NUMBER REQUESTED FINDLN /LOCATE IT AND RESET TEXTP ERROR2 /NOT THERE - 'NOP' TO USE NEXT! TAD THISLN /SET THE PC DCA PC GETC /TEST FOR THE END OF THE LINE PROC, TAD CHAR AND P337 /EXECUTE LOWER CASE TOO! DCA LASTC /SAVE COMMAND & CLEAR A FLAG SORTX /CHECK FOR SP, COMMA, SEMI, CR JMP PC1+1 /NONE OF THE ABOVE JMS CRTEST /CR? JMP PROC-1 /IGNORE SPACES, COMMAS, SEMIS PC1, JMP I COMGO-1 /EXIT AT THE END OF A LINE GETC /SKIP TO END OF THE COMMAND SORTX JMP .-2 TAD LASTC /RECALL COMMAND LETTER TAD (-"Z-1 STL IAC TAD ("Z-"? SZL SNA /IS IT @-Z? CERR, ERROR2 /ILLEGAL COMMAND TAD PC1 DCA .+1 /EXECUTE AN INDIRECT JUMP ///// CRTEST, 0 /SKIP IF CHAR IS A CR: 'TESTCR' TAD CHAR TAD MCR SNA CLA ISZ CRTEST JMP I CRTEST /RECURSIVE OPERATE, EXECUTE, OR CALL LGOSUB, TAD P7600 /GET RETURN FLAG JMP DO+1 /EXECUTE THE SUBROUTINE LCMNDS, SPNOR /'L' COMMAND ENTRY POINT CIF L JMP I FENT&177 /SAME ADDRESS AS THE FPP ///// DOXIT, SZA /CHECK FOR 'DO' OR 'GOSUB' 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 GOSUB PUSHF /ENTRY POINT FOR FSF'S TEXTP /SAVE TEXT POINTERS ///// DOGRP, PUSHF /SAVE SORTCN, CHAR, LINENO, NAGSW SORTCN FINDLN /FIND THE OBJECT LINE JMP DOERR /NOT THERE: DO WE CARE? PUSHJ /EXECUTE A SINGLE LINE GOTO+3 POPF /RESTORE THE DATA SORTCN TAD PC /CHECK THE NEXT LINE JMS I (GRPCHK /SHOULD WE EXECUTE IT? JMP DORTN /ALL DONE JMP DOGRP /CONTINUE SUBROUTINE ///// DORTN, 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 /GOSUB? POPF /YES, DUMP PROGRAM INFO FLOP /OTHERWISE 'NOP' TAD THISLN DCA LINENO /GET THE LINE NUMBER JMP GOTO+1 /AND GO SOMEWHERE ELSE ///// ERROR /PATCHED BY PROGRAM INTERRUPT DOERR, JMS I (GRPCHK /TEST FOR A GOOD LINE OR GROUP JMS I .-2 /SORRY JMP DOGRP+2 /OK- GET THE FIRST LINE ///// /COMMAND BRANCH TABLE: NINE NEW COMMANDS ARE AVAILABLE XPOPJ /STARTS THE TABLE COMGO, CERR /@ INDIRECT ASK /A BREAK /B PC1 /C DO /D ERASE /E FOR /F GOTO /G HESI /H HESITATE IF /I JUMP /J CERR /K KONTROL LCMNDS /L MODIFY /M NEXT /N ON /O CERR /P PLOT QUIT /Q RETRN /R SET /S TYPE /T CERR /U USER CERR /V VIEW WRITE /W SET /X XECUTE YNCR /Y YNCREMENT ZERO /Z ///// CONT, SKP CLA /COMMAND RETURN - 'CONTINUE' GETC SORTJ /SEARCH FOR A ';' OR A C.R. ILIST-1 IGO-ILIST JMP CONT+1 ///// CMATST, 0 /TEST FOR A COMMA: 'TSTCMA' CLA TAD CHAR TAD (-", SZA CLA JMP I CMATST /FIRST RETURN IF IT'S NOT GETC ISZ CMATST JMP I CMATST /REMOVE IT AND TAKE 2ND RTN ///// PAGE 4 FOR, PUSHJ /LOOP CONTROL BEGINS WITH 'SET' EVAL SORTJ /TEST LAST CHAR FROM 'EVAL' TLIST-1 FGO-TLIST JMP FOR /ALLOW SPACES BUT DON'T ADVERTISE MEQ, -"= /'EVAL' FOUND A REPLACEMENT OPERATOR (=): STACK THE / LAST OPERATION AND LOCK THE VARIABLE IN POSITION. *TAD FENT&177 /WIERD! EQLS, 0 /PLACED HERE TO SAVE A WORD TAD CHAR TAD MEQ SZA CLA JMP I EQLS CDF V /SOLVE THE 'ZVR' PROBLEM! TAD I XRT2 SNA CLA CMA /PROTECT ZERO VARIABLES TAD I PT1 DCA I PT1 TAD LASTOP /STACK CURRENT OPERATOR PUSHA TAD PT1 PUSHA /SAVE POINTER TO VARIABLE SP1 JMP I FCONT-1 /SET 'LASTOP' TO 1 FOR '=' ///// FINCR, GETC /SKIP THE COMMA THAT GOT US HERE TAD LASTC /IS IT 'SET' OR 'FOR' ? SNA CLA JMP FOR /'SET I=1,N=2' TAD PT1 /'FOR I=1,N' PUSHA /RESAVE THE VARIABLE POINTER PUSHJ /EVALUATE THE INCREMENT EVAL SORTJ /TEST THE NEW TERMINATOR ILIST-1 FLIST-ILIST ERROR2 /ILLEGAL TERMINATOR IN 'FOR' ///// FINFIN, PUSHF /STANDARD INCREMENT FLTONE JMP FCONT FLIMIT, PUSHF /SAVE THE INCREMENT; GET THE LIMIT FLAC PUSHJ /(NO ERROR DETECTION AFTER LIMIT) EVAL-3 FCONT, PUSHF /SAVE THE LIMIT FLAC /THE POINTER TO THE TOP OF THE STACK IS SAVED EACH TIME. /THIS PERMITS 'BREAKS' WHICH CUT THROUGH ALL INTERVENING /SUBROUTINE CALLS. THE LEVEL POINTERS ARE STACKED FROM /'RANDOM' DOWNWARDS, PERMITTING 15 OR MORE NESTED LOOPS. /NO CHECKING IS PERFORMED SINCE THE PROBABILITY OF AN /OVERFLOW OCCURING IS VANISHINGLY SMALL. PUSHF /SAVE THE CURRENT TEXT POSITION TEXTP CMA TAD FORLVL /ADJUST LEVEL COUNTER DCA FORLVL CMA TAD PDLXR /SAVE RETURN POINTER DCA I FORLVL PUSHJ /EXECUTE TO THE END FPROC, PROC-1 /RETURN FROM OBJECT STATEMENTS POPF /RESET THE TEXT POINTERS TEXTP POPF /RECOVER THE LIMIT BUFFER POPF /LOAD THE INCREMENT FLAC POPA /RESTORE THE VARIABLE POINTER DCA PT1 ISZ I BKSW /TEST FOR A 'BREAK' JMP FTEST /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 MCR /CHECK FOR A LINENO (CF. 'IF') FTEST, SM0 AND HORD DCA SIGN /SAVE SIGN OF THE INCREMENT FENT FADDIPT1 /INCREMENT LOOP INDEX FPUTIPT1 /AND SAVE IT AGAIN FSUB I BUFFPT /COMPARE WITH LIMIT FEXT TAD SIGN 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 MCR /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 SNL 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 ON JMP FOR /OFF: USE THE 'FOR' ROUTINE ///// TYPSET, PUSHJ /EVALUATE THE EXPRESSION EVAL PRINTN /OUTPUT IT & RESET 'ATSW' TASK, SPNOR /MOVE TO NEXT ARGUMENT SORTJ /!,",#,$,%,: ? ALIST-1 AGO-ALIST ISZ I ATSW /'ASK' OR 'TYPE'? JMP TYPSET ///// PUSHJ /LOOKUP THE VARIABLE GETARG TAD CHAR /SAVE THE CHARACTER DCA LASTC TAD PROMPT NOP /'ECHOC' READ, SP1 READN /GET THE NUMBER YLST, "; CR /SORT LIST FOR 'YNCR' "- /IS THE INPUT SWITCH FENT FPUTIPT1 /SAVE THE VALUE FEXT ENDFI, TAD CHAR /'ALTMODE' RETURN DCA I ASK /SAVE THE TERMINATOR TAD LASTC DCA CHAR /RESTORE TEXT CHARACTER ASK, CLA SM1 /POINTS TO 'TERM' TYPE, DCA I ATSW /SET THE SWITCH JMP TASK ///// TBACK, TAD CCR /'#' = CR ONLY JMS I OUTDEV DCA I TABCNT TAD (200-CR /CREATE A NULL FOR DELAY TCRLF, TAD CCR /'!' = CR AND LF PRINTC TASK4, GETC /MOVE ALONG JMP TASK ///// /DISPATCH TABLE FOR 'ASK' 'TYPE' 'ZERO' 'FOR' 'SET' 'IF' AGO, TQUOT+1 /" - PRINT CHAR STRING TASK4 /, - END OF EXPRESSION TCRLF /! - CR AND LF TFRMT /% - SET OUTPUT FORMAT TBACK /# - CARRIAGE RETURN ONLY TDUMP /$ - DUMP THE SYMBOL TABLE TABX /: - TABULATE OR SKIP ZGO, ZERO+2 /, - MULTIPLE ZERO COMMAND FGO, FINCR /, - MULTIPLE SETS OR FOR IGO, THEN /, - UNUSED 'IF' BRANCHES YGO, PROC-1 /; - END OF COMMAND PROC+2 /CR END OF LINE DECR /- - DECREMENT A VARIABLE ///// ALIST, "" /'SORTJ' CONTROL TABLE ", "! "% "# "$ PROMPT, ": /FOR 'ASK' ZLIST, ", /FOR 'ZERO' TLIST, ", /FOR 'SET' ILIST, ", /FOR 'IF/ON' "; CR /'PUSHJ' ENDS THE LIST ///// TFRMT, PUSHJ /MOVE PAST THE '%' EVAL-3 TAD C100 /POINT TO PC0 DCA XRT PUSHJ /READ FORMAT TYPEPT TAD LINENO DCA FISW /SAVE FOR LATER JMP TASK ///// TQUOT, PRINTC /ECHO ISZ I DMPSW /DISABLE TRACE GETC /PASS QUOTE - READ NEXT DCA I DMPSW /RESTORE THE TRACE SORTJ TLIST2-1 /QUOTE OR CR TLIST3-TLIST2 JMP TQUOT ///// AXIND, 0 /'DCAIAXIN' CDF T DCA I AXIN CDF P JMP I AXIND /PUSHDOWN LIST SUBROUTINES - STACK IS IN FIELD 0 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 /AND PUSH IT ON THE STACK XPUSHA, 0 /PUSH THE AC ONTO THE STACK CDI L JMP I (APUSHX JMP I XPUSHA XPOPJ, CDF S TAD I PDLXR /GET THE RETURN ADDRESS DCA XPOPA JMP XPOPA+3 /RESTORE D.F. AND BRANCH 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 FOR THIS DCA I (MPUSHF CDF P /RESET THE CALLING FIELD JMP I (MPUSHF+2 /UPPER FIELD ENTRY POINT XPOPF, 0 /RESTORE 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 PAGE /FIND OR ENTER A VARIABLE IN THE SYMBOL TABLE GETARG, TESTC /GET FIRST LETTER OF NAME LPRTST /FUNCTIONS AND NUMBERS XINC, WORDS+1 /ARE NOT GOOD VARIABLES ERROR2 /BAD ARG IN ASK, YNCR OR ZERO GETVAR, SM1 /ENTRY POINT FOR 'EVAL' FLOAT /SET COUNTER & CLEAR SUBSCRIPT TAD CHAR AND P77 /USE 6-BIT CODES RTL6 /MOVE TO THE LEFT - 'BSW' DCA THISOP /SAVE WHERE WE CAN PUSH IT GETLP, GETC /GET NEXT CHARACTER TESTX /END OF THE NAME? JMP GSERCH /YES ISZ HORD /IS THIS THE SECOND CHAR? JMP GETLP /IGNORE ADDITIONAL CHARS TAD CHAR AND P77 /MASK IT OFF TAD THISOP /MERGE THE OTHER HALF JMP GETLP-1 ///// GSERCH, JMS I GETARG+1 /CHECK FOR A SUBSCRIPT JMP GS1 /NONE JMS I (ECALL /PICK IT UP JMS I (DBLSUB /CHECK FOR DOUBLE SUBSCRIPTS POPA /GET VARIABLE NAME FROM PDL JMS I (PARTEST /CHECK FOR PROPER RIGHT PAREN. GETC /MOVE PAST CLOSING PARENS FIXIT /CONVERT ALL THIS TO AN INTEGER CIA /INVERT FOR FAST CHECKING GS1, DCA T3 /SAVE SUBSCRIPT TAD THISOP CIA /INVERT NAME FOR THE SAME REASON DCA T1 CDF V DCA I LASTV /DEFINE THE END OF THE TABLE TAD SECRTV /BEGIN WITH SECRET VARIABLES JMP GLOOP+2 ///// CMA /BACKUP TO NAME GLOOP, TAD XINC /ADVANCE ONE TAD XRT2 DCA XRT2 TAD I XRT2 /CHECK NAME SNA /END OF THE TABLE? JMP MAKVAR /YES TAD T1 /'SAM' SZA CLA /MATCH? JMP GLOOP /TRY AGAIN TAD T3 TAD I XRT2 /CHECK SUBSCRIPT SZA CLA JMP GLOOP-1 /NOT THIS ONE STL /L=1 IF FOUND ISZ XRT2 /POINT TO DATA GEXIT, TAD XRT2 DCA PT1 POPJ /RESETS D.F. ///// MAKVAR, TAD TABEND /SYMBOL TABLE LIMIT STL CIA TAD LASTV TAD GINC /COMPARE WITH NEW END POINT SNL JMP ZSERCH /FULL: TRY TO REPLACE A ZERO TAD TABEND DCA LASTV /UPDATE STORAGE POINTER STL CMA JMP ZFOUND+2 /INSERT NAME & CLEAR DATA ///// ZSERCH, CLA STL IAC /INITIATE SEARCH FOR ZERO TAD FIRSTV JMP ZINITL ZLOOP, TAD LASTV /CHECK PROGRESS CLL CMA TAD XINC /ADVANCE TO NEXT ONE TAD XRT2 SZL /ALL DONE? ERROR2 /YES: SYMBOL TABLE IS FULL TAD LASTV /SETS THE LINK ZINITL, DCA XRT2 /XRT2=XRT2+XINC-1 TAD I XRT2 /EXPONENT + TAD I XRT2 /HIGH ORDER SNA CLA /CHECK THAT BOTH ARE ZERO SNL /AND NOT ADDITIVE INVERSES JMP ZLOOP ///// ZFOUND, CDF V /ALSO USED BY 'ZERO' TAD M4 /POINT TO THE NAME TAD XRT2 /CLEAR THE LINK DCA XRT2 TAD THISOP /REPLACE IT DCA I XRT2 TAD LORD /AND THE SUBSCRIPT TOO DCA I XRT2 DCA I XRT2 /ZERO THE DATA TAD XRT2 DCA XRT /SWITCH INDEX REGISTERS DCA I XRT DCA I XRT DCA I XRT /'NOP' FOR 3-WORD VERSION JMP GEXIT /L=0 ///// TLIST3, TASK4 /SORT LIST FOR QUOTED STRINGS XPOPJ /AUTOMATIC RIGHT QUOTE MARK /CONDITIONAL TRANSFER PROCESSES: 'IF', 'ON' AND 'JUMP' /'IF' TRANSFERS WITH A 'GOTO' BRANCH WHILE 'ON' USES A /'DO' CALL AND RETURNS TO THE CALLING POINT AFTERWARDS. /'JUMP' USES THE VALUE OF THE EXPRESSION TO SELECT CALL ON, TESTC /THIS IS ALSO THE 'O' COMMAND SM1 /T R-PAR MEANS ITS 'ON' DCA LASTC /F ILLEGAL - WILL BE TRAPPED JMP IF+1 /N CONTINUE WITH 'IF' CIF L /L DOUBLE-WORD 'O' COMMAND JMP I .+1 /CONTINUE WITH LOWER-FIELD CHECKS OCMND JM, JMS I (ECALL /'JUMP (...) S1,S2,S3,S4,S5,...' SM1 /SET THE 'DO' FLAG DCA LASTC FIXIT /GET SUBROUTINE CALL CIA JMP IF+3 /THEN USE 'IF' TO FINISH UP IF, TESTC /IGNORE SPACES AND TEST JMS I (ECALL /T SM2 /F ISZ PDLXR /N DUMP 'THISOP' JMS I (PARTEST /L CHECK FOR PAREN MATCH TAD HORD /TEST -,0,+ SPA ISZ THISOP SPA SNA CLA THEN, ISZ THISOP /COUNT COMMAS JMP I (CONT+1 /KEEP LOOKING GETC /MOVE PAST IT JMP I MCR /CHECK WHETHER ITS 'IF' OR 'ON' ///// *-CR /VIA MCR ! GETLN /PATCH TO CHECK FOR MISSING LINENO SZL /AND TO CHOOSE BETWEEN 'IF' & 'ON' CONTINUE /NO NUMBER = CONT. WITH SAME LINE ISZ LASTC /TEST FLAG JMP I (GOTO+1 /IF (ALSO 'NEXT' OR 'BREAK') TSTCMA /ON (ALSO 'JUMP') JMP I (DO+1 /CALL THE SUBROUTINE JMP .-2 /PREVENT MULTIPLE 'DO' CALLS PAGE 7 /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 /ALA FOCAL65. THANKS TO WAYNE WALL FOR SOME SUPER IDEAS! ECALL, 0 /RECURSIVE CALL TO 'EVAL' TAD .-1 DCA PT1 PUSHF /= 'PT1, THISOP, LASTOP, SORTCN' PT1 ARGNXT, DCA LASTOP /SET OR CLEAR THE OP CODE GETC /SKIP THE TERMINATOR SKP /CONTINUE 'EVAL' ///// EVAL, DCA LASTOP /EVALUATION CONTROLLER TESTC /TEST CHARACTER & IGNORE SPACES JMP ETERM1 /TERMINATOR JMP EFUN /FUNCTION JMP ENUM /NUMBER PUSHJ /LETTER OF VARIABLE GETVAR /LOOKUP THE NAME SPNOR /SKIP TO THE OPERATOR JMS I EQLSPT /IS IT AN 'EQUAL SIGN'? FENT FGETIPT1 /NO, MOVE VALUE TO FLAC FEXT ///// OPNEXT, TESTC /CHECK NEXT OPERATOR JMP ETERMN /T TLIST2, "" /F - ERROR IN FORMAT CR /N JMP EMINUS+1 /L - MISSING OPERATOR ///// 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 '=' M10, 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 ///// EQUALS, POPA /GET VARIABLE POINTER DCA PT1 EQLSPT, TAD FENT&177 /DOUBLE KLUDGE = 'FPUTIPT1' JMP OPER-2 ///// 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 /ADVANCE THE OPERATOR JMP ARGNXT ///// EFUN, DCA THISOP /CLEAR THE FUNCTION NAME GETC TESTX /LOOK FOR A TERMINATOR JMP EFUN2 /FOUND ONE TAD THISOP CLL RTL /GENERATE THE HASH CODE TAD CHAR TAD P7600 JMP EFUN ///// 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 SORTJ /BRANCH ON FUNCTION CODE FNTABL-1 FNTABF-FNTABL ELPAR, JMS LPRTST /LEFT PAREN OR FELL THROUGH TABLE ERROR3, ERROR2 /DOUBLE OPERATORS OR UNKNOWN FUNC EPAR2, JMS ECALL /EVALUATE NESTED EXPRESSION ISZ PDLXR /DUMP THE EXTRA ARGUMENT RETURN /COMPLETE THE FUNCTION CALL ///// LPRTST, 0 /SKIP IF CHAR IS A LEFT PAREN TAD SORTCN TAD M10 SNA /AND CATCH SINGLE QUOTES TOO JMP ECHR AND M4 /=7774 SNA CLA ISZ LPRTST /1-3 ARE PARENS JMP I LPRTST ///// ENUM, READN /READ A NUMBER FROM TEXT JMP OPNEXT /'JMP' IS NEGATIVE ///// *.!177-4 /PUT THIS RIGHT AT THE END ECHR, ISZ I DMPSW GETC /GET THE NEXT CHARACTER DCA I DMPSW TAD CHAR /FLOAT IT FLOAT JMP EFUN3+1 /ALMOST LIKE A 'RETURN' ///// /FUNCTION RETURNS AND CHARACTER TESTING: *2001 PARTEST,0 /TEST THE PAREN MATCHING DCA THISOP /SAVE THE AC IN 'THISOP' POPA /RESTORE LAST OPERATION DCA LASTOP SP2 /GET OPENING PAREN + TWO POPA CMA /NEGATE AND SUBTRACT ONE TAD SORTCN /(PARENS DIFFER BY THREE) SZA CLA /DO THEY MATCH? ERROR2 /NO THEY DON'T - TOO BAD! JMP I PARTEST /ENTRY POINT IS A BETA REGISTER ///// XRTL6, 0 /ROTATE THE AC LEFT SIX - 'RTL6' CLL RTL RTL RTL JMP I XRTL6 /'XRTL6' IS ALSO A BETA REGISTER ///// FL0AT, CLL RAR /UNSIGNED INTEGER FLOAT ROUTINE FLOAT RAR DCA LORD /JUST SHIFT EVERYTHING RIGHT ONE ISZ EXP EFUN3, JMS PARTEST /'RETURN' - CLEARS AC & RESETS DF NORMALIZE GETC /SKIP THE TERMINATOR JMP I .+1 OPNEXT /CONTINUE WITH 'EVAL' ///// MF, -"F /'FN' CHECK FOR 'TESTC' C232, 232 /'EOF' CHECK FOR 'FIND' ///// CTEST, 0 /TEST THE NEXT CHARACTER - 'TESTC' SPNOR /IGNORE SPACES JMS XTEST /CHECK ALL THE TERMINATORS JMP I CTEST /IT WAS A TERM - 'SORTCN' IS SET TAD CHAR TAD MF SNA CLA JMP XT3 /FUNCTION JMS NTEST SKP /PERIOD ISZ CTEST /OTHER ISZ CTEST /NUMBER XT3, ISZ CTEST JMP I CTEST /RETURNS: T;F;N;L ///// /NEW ROUTINE TO TEST IF 'CHAR' IS A TERMINATOR - 'TESTX' /THIS ROUTINE WAS DEVISED BY JIM CRAPUCHETTES (FOCAL8-269) /TO SHORTEN THE TIME REQUIRED FOR THIS TEST BY A FACTOR OF /3-5. THIS RESULTS IN A NET IMPROVEMENT OF ABOUT 12%. XTEST, 0 /TERMINATOR TEST - SETS 'SORTCN' TAD CHAR TAD M336 SMA SZA /IS IT > 336? JMP NO /NOT A TERMINATOR TAD P4 SMA SZA /IS IT > 332? JMP YES RANK, TAD P34 SMA SZA /IS IT > 276? JMP NO /IT'S A LETTER TAD P3 SMA /IS IT > 272? JMP YES+2 TAD P14 SMA SZA /IS IT > 257? JMP NO /IT'S A NUMBER TAD P11 SMA SZA /IS IT > 247? JMP YES+1 TAD P6 SZA /IS IT A SPACE? TAD P23 NO, SNA CLA /IS IT A CR? JMP YES+2 ISZ XTEST /NOT A TERMINATOR JMP I XTEST YES, TAD P11 / [ \ ] ^ TAD P3 / ' ( ) * + , - . / TAD RANK / ; < = > CR DCA .+1 TAD RANK /GET PRIORITY NO. SPA JMP NO /OMIT PERIOD & \ DCA SORTCN JMP I XTEST ///// 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 ///// / PRIORITY TABLE FOR 'EVAL' P34, 34 /; 01 = = 13 /< 03 = + 0 /= 04 = - 16 /> 05 = / 10 /' 06 = * P11, 11 /( 07 = ^ P14, 14 /) 10 = ' P6, 6 /* 11 = ( P3, 3 /+ 12 = [ P23, 23 /, 13 = < P4, 4 /- 14 = ) MPER, -". /. 15 = ] 5 // 16 = > P12, 12 /[ 23 = , M336, -"^ /\ 34 = ; 15 /] 34 = CR 7 /^ 34 = SPACE ///// /TRANSFER LIST FOR 'SET' AND 'FOR' FLIST, FLIMIT /, FINFIN /; FINFIN-1 /CR ///// /LIST OF CODED FUNCTION NAMES (LOCATIONS IN 'FNTABF') F2=200^4+200 F3=200^4+200^4+200 FNTABL=. "C^4+"O^4+"M-F3 /COM "I^4+"T^4+"R-F3 /ITR "R^4+"A^4+"C-F3 /RAC "S^4+"G^4+"N-F3 /SGN "A^4+"B^4+"S-F3 /ABS "S^4+"Q^4+"T-F3 /SQT "R^4+"A^4+"N-F3 /RAN "S^4+"I^4+"N-F3 /SIN "C^4+"O^4+"S-F3 /COS "A^4+"T^4+"N-F3 /ATN "L^4+"O^4+"G-F3 /LOG "E^4+"X^4+"P-F3 /EXP "R^4+"A-F2 /RA "L^4+"S-F2 /LS "S^4+"R-F2 /SR "M^4+"Q-F2 /MQ "I^4+"N-F2 /IN "O^4+"U^4+"T-F3 /OUT "I^4+"N^4+"D-F3 /IND "M^4+"I^4+"N-F3 /MIN "M^4+"A^4+"X-F3 /MAX "B^4+"L^4+"K-F3 /BLK "L^4+"E^4+"N-F3 /LEN "T^4+"R^4+"M-F3 /TRM "D^4+"A^4+"C-F3 /DAC "A^4+"D^4+"C-F3 /ADC "T^4+"R^4+"G-F3 /TRG "B^4+"U^4+"F-F3 /BUF "T^4+"I^4+"M-F3 /TIM "D^4+"I^4+"N-F3 /DIN "R^4+"E^4+"Q-F3 /REQ "C^4+"T^4+"R-F3 /CTR "D^4+"V^4+"M-F3 /DVM "X^4+"T^4+"R-F3 /XTR "N^4+"E^4+"W-F3 /NEW "D^4+"A^4+"Y-F3 /DAY /THE HASH CODE HAS BEEN CHANGED TO IMPROVE UNIQUENESS. /CHARACTERS ARE SHIFTED 2 BITS AT A TIME AFTER MASKING /THE LEADING BIT. THE TABLE IS ENDED BY 'EXTR' /UNPACK A CHARACTER FROM THE TEXT BUFFER: 'GETC' EXTR, JMS GET1 /EXTENDED CHARACTER SNA /300? JMP UTE-1 /RESTORE '@' TAD M40 SMA /REVERSE THE TEST JMP UTE+1 /340-376 JMP UTE+2 /201-237 ///// TOGL, ISZ TRACE /TOGGLE THE TRACE FLOP SM1 DCA TRACE M40, SMA SZA CLA /GET THE NEXT CHARACTER UTRA, 0 /UNPACK A CHARACTER JMS GET1 SZA /TURN NULLS INTO SPACES TAD M40 /SUBTRACT 40 UTE, SPA /WHICH SET? TAD C100 /300-337 TAD M77 /240-276, 200 SZA /IS IT A QUESTION MARK? JMP UTX /NO, RESTORE THE CHAR TAD XPRNT /YES SNA CLA /DOES IT GET SPECIAL ATTN? JMP TOGL /YES, TOGGLE THE TRACE FLOP TAD M40 /NO, TREAT IT NORMALLY UTX, TAD P337 DCA CHAR TAD XPRNT /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 ///// GET1, 0 /UNPACK 6 BITS ISZ XCT /STARTS WITH 0 JMP GET3 TAD GTEM GEND, AND P77 TAD M77 SNA JMP EXTR /EXTENDED TAD P77 JMP I GET1 M77, -77 ///// XSPNOR, 0 /IGNORE INTERVENING SPACES: 'SPNOR' TAD CHAR TAD M240 SZA CLA JMP I XSPNOR JMS UTRA JMP XSPNOR+1 GET3, CLA CMA /RESET THE FLIP-FLOP DCA XCT CDF T TAD I AXOUT /GET 12-BITS CDF P DCA GTEM TAD GTEM RTR RTR /BSW RTR JMP GEND /RETURN WITH THE FIRST CHARACTER ///// XPRNT, 0 /PRINT A LINE NO. - 'PRNTLN' TAD C240 /SET UP A SPACE DCA CHAR TAD LINENO /THE ENTRY POINT IS 'DMPSW' SNA JMP I XPRNT /NO NUMBER FOR THE HEADER RTL6 AND P77 JMS I PRNTX /TWO-DIGIT 'GROUP' NUMBER SM2 /TO GENERATE A '.' PRINTD TAD LINENO JMS I PRNTX /TWO-DIGIT 'STEP' NUMBER PRINTC JMP I XPRNT PRNTX, PRNT ///// / NEW ROUTINE TO TEST IF 'CHAR' IS A SPACE, SEMICOLON, /COMMA OR CARRIAGE RETURN; SKIPS IF IT IS ANY OF THESE. XSORT, 0 /COMMAND WORD SORT - 'SORTX' TESTCR TAD M240 /-SPACE SZA TAD CHAR /NOT CR M240, SMA SZA TAD MSC /SEMICOLON SPA TAD P17 /COMMA SNA CLA ISZ XSORT /ONE OF THE ABOVE JMP I XSORT MSC, SP-"; ///// /'PACKC' LIST - ALLOWS ROOM FOR 'FNTABF' TO GROW PACGO, PQST /? PCAT /@ RUB1 /RO /LIST OF FUNCTION ADDRESSES (NAMES ARE IN 'FNTABL') FNTABF=. FCOM /COM -COMMON STORAGE FITR /ITR -NEW INTEGER 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 RADIANS FATN /ATN -USE PI TO CONVERT FLOG /LOG -NAPERIAN LOGARITHM FEXP /EXP -EXPONENTIAL (BASE E) /END OF BASIC NUMERICAL FUNCTIONS - REMAINDER DO I/O FRA /RA -RANDOM ACCESS STORAGE ERROR3 /LS -READ THE LEFT SWITCHES FSR /SR -SW. REG. OR R. SWITCHES FMQ /MQ -DISPLAY A NO. IN THE MQ FIN /IN -SINGLE CHARACTER INPUT FOUT /OUT -SINGLE CHARACTER OUTPUT FIND /IND -CHARACTER SEARCH FMIN /MIN -MINIMUM VALUE FMAX /MAX -MAXIMUM VALUE FBLK /BLK -STARTING BLOCK FLEN /LEN -FILE LENGTH FTRM /TRM -INPUT TERMINATOR /ADDITIONAL LABORATORY-TYPE FUNCTIONS ERROR3 /DAC -ANALOG OUTPUT ERROR3 /ADC -ANALOG INPUT ERROR3 /TRG -SCHMITT TRIGGERS ERROR3 /BUF -DISPLAY BUFFER STORAGE ERROR3 /TIM -ELAPSED TIME INTERVAL ERROR3 /DIN -DIGITAL INPUT REGISTER ERROR3 /REQ -PROGRAMABLE OSCILLATOR ERROR3 /CTR -FREQUENCY COUNTER ERROR3 /DVM -DIGITAL VOLTMETER ERROR3 /XTR -EXTRA FUNCTION SLOT ERROR3 /NEW -UNDEFINED FUNCTION FDAY /DAY -SET THE OS/8 DATE /INSERT A CHAR IN THE TEXT BUFFER - 'PACKC' PACBUF, 0 /ALSO HANDLES DELETIONS DCA PCK1 /SAVE LINENO PROTECTION SORTJ PACLST-1 /CHECK FOR '?', '@', 'RO' PACGO-PACLST TAD CHAR TAD C240 /DECODE AND C100 SZA CLA /EXTENDED? JMP .+3 PCAT, TAD P77 /201-237, 300, 340-376 JMS PCK1 TAD CHAR /200, 240-276, 301-336 JMS PCK1 PACX, CDF P DCA RUB3 /RESET ERROR TRAP JMP I PACBUF ///// PCK1, 0 AND P77 ISZ T3 /=0 TO START JMP PCK2 TAD LASTC DCAIAXIN JMP I PCK1 ///// PCK2, RTL6 /'BSW' DCA LASTC STL CMA DCA T3 TAD AXIN TAD I PACEND /CHECK TEXT LIMIT SNL CLA ERROR2 /TEXT BUFFER FULL JMP I PCK1 ///// PQST, TAD P337 /REPLACE 277 WITH 337 JMP PACX-1 ///// /A NOTE OF APPRECIATION TO EDWARD TAFT III /FOR HELPING WITH THIS APPROACH TO 'PACKC'. /REFERENCE: DECUS FOCAL8-52 (FOCAL 5/69) RUB1, TAD T3 /RUBOUT ONE LETTER SMA CLA /HALF-WORD? JMS RUB3 /CHECK POSITION TAD P134 /'TAD START' JMP .+4 /'ECHOC' PRODUCES TAD SPAC /'BS', 'SP', 'BS' ECHOC /FOR VIDEO TERMINALS TAD START ECHOC /7-BIT '\' OTHERWISE TAD AXIN DCA PT1 CDF T ISZ T3 /WHICH HALF? JMP RUB2 TAD I PT1 /'T3' HAS BEEN RESET! CMA AND P77 /TEST FOR EXTENDED CHAR SPAC, SZA CLA JMP PACX JMS RUB3 /LOOK OUT FOR LINE NUMBERS! RUB2, CLL CMA /REMOVE 2ND HALF OF STORED WORD TAD AXIN DCA AXIN /RESET STORAGE POINTER TAD I PT1 AND RUB1+1 /=7700 DCA LASTC TAD LASTC TAD C100 /CHECK FOR EXTENDED CLA CMA RAR /L=1 IF NOT " DCA T3 /RESET BYTE COUNTER JMP PACX ///// 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 ///// /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 JMP I PACLST /THEN RESTART THE PROG. /ERROR RECOVERY ROUTINE: MODIFIED FOR THE ERROR TRAP ERROR, 0 /TAB COUNTER TOO ! I0N CLA TAD TELSW /WAIT FOR TTY TO FINISH SZA CLA JMP .-3 CDF P TAD RUB3 /SHOULD WE TRAP THIS ONE? SZA JMP ERTRAP /YES TAD ERROR /PROCESS ERROR CODE TO AND C100 /ELIMINATE NON-NUMERICS CMA STL RAR /7777 OR 7737 JMP I .+1 /NO - REPORT IT M20+1 /THE EXPANDED 'JUMP' COMMAND PROVIDES KEYBOARD CHECKING JM JUMP, TESTC /CHECK WHICH FORM WE'VE GOT JMP I JUMP-1 /T = 'JUMP (...) *, *, *, *, ' PACLST, "? /N 'PACKC' LIST FITS IN HERE TO "@ /F SERVE AS 'NOPS' FOR 'TESTC' RO /L TAD INBUF / IF NOT A TERMINATOR, ASSUME A SZA CLA / LINE NUMBER & CHECK THE INPUT CONTINUE / BUFFER. NOTHING THERE: BRANCH JMP I MCR / OTHERWISE CONTINUE WITH PROG. SORTB, 0 /SORT AND BRANCH ROUTINE - 'SORTJ' SNA TAD CHAR /ASSUME CHAR IF AC=0 CIA DCA DCAT2 TAD I SORTB /FIRST ARGUMENT IS LIST-1 ISZ SORTB DCA XRT TAD I XRT SPA /LISTS ARE ENDED BY NEGATIVE NOS.! JMP SEX /NOT THERE! TAD DCAT2 SZA CLA /MATCH? JMP .-5 /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 ///// /IMPROVED SYMBOL TABLE DUMP /THE NUMBER OF VARIABLES PER LINE IS DETERMINED BY THE EX- /PRESSION FOLLOWING THE '$'. THUS 'TYPE $4' WILL PRINT 4 /VARIABLES PER LINE. IF NO VALUE IS SPECIFIED (OR 0) THE /PREVIOUS VALUE WILL BE USED. THE DEFAULT IS INITIALLY 3. TDUMP, PUSHJ /GET NUMBER OF VARIABLES PER LINE EVAL-3 FIXIT CIA SZA DCA DMPNO /CHANGE DEFAULT VALUE TAD TRACE DCA LASTC /SAVE THE TRACE SWITCH TAD FIRSTV DCA PT1 /START AT THE BEGINNING TAD DMPNO DCA TRACE /INITIALIZE THE COUNTER JMP DUMPT+4 /(THESE THREE COULD GO) ///// DUMPT, TAD DMPNO /SET COUNTER AND TURN ON TRACE DCA TRACE TAD CCR PRINTC /RESETS THE DF TAD GINC CIA DCA XCT /INITIALIZE LOOP TAD DCAT1 DCA DCAT2 CDF V DCA I LASTV /CLEAR THE LAST NAME TAD I PT1 /MOVE VAR. TO THIS FIELD ISZ PT1 /NO HARM IF IT SKIPS ISZ .+1 DCAT2, DCA T1 /T2, T3, ETC. ISZ XCT /RESETS THE SWITCH TOO! JMP .-5 TAD T2 /LAST ONE? SNA JMP DUMPX /YES CDF T DCA I C200 /SAVE THE NAME TAD P177 DCA AXOUT /SET 'TEXTP' GETC /RESETS THE DF GETC GETC /PRINT 'XX(' JMS I (FGO6 /PRINT SUBSCRIPT GETC /PRINT ')' PRINTN /PRINT VALUE CDF V ISZ TRACE /FINISHED THIS LINE? TAD I PT1 /NO, LAST ENTRY? SNA CLA /NEITHER JMP DUMPT /START A NEW LINE TAD C240 JMP DUMPT+3 /SEPARATE THE VARIABLES ///// DMPNO, -3 /DEFAULT = 3 DUMPX, TAD LASTC /RESET THE TRACE SWITCH DCA TRACE POPJ /RESET DF AND END THE LINE ///// /REMOVE A LINE OF TEXT AND RECOVER THE SPACE - 'DELETE' XDELETE,0 /ENTRY POINT IS PACKING LIMIT 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 DCAT1, 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 /TTY INTERUPT I/O HANDLERS: /OUTPUT BUFFER HAS BEEN MOVED AND THE INPUT MODIFIED /TO INCREMENT A RANDOM NO. OR CALL A DISPLAY ROUTINE KEYCK, XI33+1 /PATCHED BY DISPLAY ROUTINE XOUTN, TAD XI33 TLS /TYPE FIRST CHARACTER DCA TELSW /SET IN-PROGRESS FLAG CDF P JMP I XOUTL P7757, 7757 /LOC = PAGE+6 XI33, (REKOVR /VIA (INDEV) ISZ I XCT /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 INBUF /CLEAR INPUT BUFFER TAD XI33+1 /PLACE CHARACTER IN AC JMP I XI33 MCP, "C-"P /OINK, OINK XOUTL, 0 /VIA (OUTDEV) DCA XI33 /SAVE CURRENT CHARACTER CDF L I0N /BE SURE INTERRUPT IS ON TAD I OPTRI /ANY ROOM? SZA CLA /A CHARACTER IS NON-ZERO JMP .-3 /NO = WAIT CIF P /INHIBIT POINTER CHANGES TAD TELSW /IN PROGRESS? SNA CLA JMP XOUTN /NO TAD XI33 /PUT DATA IN EXTRA DCA I OPTRI /BUFFER SPACE TAD OPTRI /ADVANCE POINTER IAC /MODULO 20 AND P7757 /(CIRCULAR STORE) DCA OPTRI /NEW VALUE JMP XOUTN+3 /RE-ENABLE INTERRUPTS MINT, CDI /CTRL/C EXIT JMP I P7600 /MONITOR = 07600 SM8=6254 DCMA=6601 PCLF=6662 RCTF=6677 /INTERRUPT PROCESSOR: CHANGES FOR ^C AND ^F OR ^P INTRPT, DCA SAVAC /SAVE WORKING REGISTERS RAR DCA SAVLK TINT, TSF /CHECK OUTPUT FIRST WHILE DF=0 JMP KINT TCF DCA TELSW /TURN OFF THE IN-PROGRESS FLAG TAD I OPTRO /I/O BUFFER IS IN FIELD 0 NOW SNA JMP KINT /DONE TLS /TYPE NEXT CHARACTER DCA TELSW /CLEAR AC & TURN ON THE FLAG DCA I OPTRO /ZERO OUT THE DATA JUST USED TAD OPTRO /GET POINTER AND IAC /ADVANCE MODULO 20 CTRLF, AND P7757 /(CIRCULAR BUFFER) DCA OPTRO /NEW POINTER KINT, KSF /NOW CHECK THE KEYBOARD JMP UINT KRS /READ BUFFER AND P177 /IGNORE PARITY TAD (-3 SNA /TEST FOR CTRL C JMP MINT TAD (-3 /'TAD MCP' -> ^P SNA CLA /TEST FOR CTRL F JMP M20+2 TAD INBUF /CHECK BUFFER CLL CIA KRB /RE-READ CHAR AND P177 SNA /LEADER/TRAILER? JMP UINT TAD C200 SNL /OVERFLOW? ERROR2 /'NOP' IF YOU DON'T CARE DCA INBUF UINT, NOP /RESERVED FOR PLOTTER OVERLAY NOP / " NOP / " 6302 /NOW CLEAR SOME ANNOYING FLAGS 6312 6322 6332 6342 6076 6402 JMP XINT /CDI 0 /USE THS PATCH FOR ADDITIONAL NOP /JMP I .+1 /INTERRUPT SERVICE NOP /DDRESS /IN ANY FIELD XINT, NOP /16KXII.PA OVERLAYS HERE NOP / " RCTF DCMA PCLF /LPT8I.PA OVERLAYS HERE PCF TAD SAVLK CLL RAL TAD SAVAC CDI JMP PRNTC /RETURN FROM THE INTERRUPT OPTRI, TBUF /OUTPUT BUFFER POINTERS OPTRO, TBUF /'I'= 'IN', 'O'= 'OUT' /PRINT THE ERROR MESSAGE DCA TELSW /CLEAR THE BUSY FLAG M20, SMA SZA SNL CLA /SKIP ERROR CODE TAD I TABCNT /AC= -1 OR -41 DCA LINENO DCA INBUF TAD OPTRI /RESET POINTER DCA OPTRO CDI L JMS REKOVR /CLEAR OUTPUT BUFFER ///// TAD ("?-"_ /RETURN VIA 'EOF' PRINTC /PRINT A "?" PRNTLN /FOLLOWED BY ERROR CODE ISZ PC CDF T TAD I PC /GET PROGRAM STEP SNA JMP .+6 /DIRECT COMMAND ERROR DCA LINENO TAD C100 /ATSIGN PRINTC /RESETS DF PRINTC /SPACE PRNTLN /LINE NO. TAD CCR PRINTC BATXIT, JMP START /OR RETURN TO BATCH ///// PAGE /END OF COMMAND PROCESSOR /IN THE 8K VERSION THE VARIABLES COME NEXT AND EXTEND TO /THE BEGINNING OF THE FUNCTIONS. IN THE 12K VERSION THIS /SPACE IS AVAILABLE FOR USER ADDITIONS - HELP FOCAL GROW! / FUNCTION PACKAGE FOR 12K U/W-FOCAL: -JVZ- / 12KFNS.PA /REVISIONS: / TAD TXTEND CHANGED TO TAD BUFEND AT 14447 1/3/79 / FCOM AND FRA: RANDOM ACCESS FUNCTIONS /THE 'FCOM' FUNCTION PROVIDES ACCESS TO DATA ARRAYS IN FIELD /2 (OR 4) USING EITHER OF 2 STORAGE MODES: SIGNED DOUBLE PRE- /CISION OR 4-WORD FLOATING-POINT. THE STORAGE MODE IS DETER- /MINED BY THE SIGN OF THE 'FCOM' INDEX. POSITIVE INDICES /(0-1023) ACCESS FLOATING-POINT NUMBERS WHILE NEGATIVE VALUES /REFERENCE DOUBLE PRECISION INTEGERS IN THE SAME WAY THAT THE /KE-8E EAE DOES IT. STORAGE BEGINS AT THE TOP OF THE FIELD & /EXTENDS DOWNWARD TOWARD THE TEXT AREA. THIS PROVIDES A REA- /SONABLE TRADEOFF BETWEEN LARGE DATA ARRAYS AND LONG PROGRAMS. /THE VALUE OF THE 'FCOM' FUNCTION IS JUST THE VALUE OF THE /VARIABLE AT THE LOCATION REFERENCED. TO STORE A NEW VALUE /AT THAT LOCATION, SIMPLY INCLUDE A SECOND PARAMETER IN THE /FUNCTION CALL; THE VALUE OF THIS EXPRESSION WILL THEN BE /PLACED IN THE ARRAY AT THE SPECIFIED LOCATION. DATA CON- /VERSION BETWEEN INTEGER AND FLOATING-POINT MODES IS AUTO- /MATIC. EXAMPLES: SET X(I)=FCOM(I+100); X FCOM(J,FSIN(J)) /THE 'FRA' FUNCTION PROVIDES 'FCOM-LIKE' ACCESS TO DATA ARRAYS /STORED IN BINARY FORM ON ANY MASS-STORAGE DEVICE. SEVERAL /DATA MODES ARE AVAILABLE: SINGLE WORD (SIGNED OR UNSIGNED), /DOUBLE PRECISION AND 4-WORD FLOATING POINT. A DIFFERENT /INDEXING SCHEME IS EMPLOYED TO HANDLE ALL THESE MODES. /THE FILE USED BY FRA MUST FIRST BE LOOKED UP USING THE /'OPEN INPUT' COMMAND. FOLLOWING THIS 'FRA' MUST BE INITIAL- /IZED SO THAT THE NECESSARY POINTERS CAN BE TRANSFERRED AND /THE DATA FORMAT SELECTED. THE FOLLOWING TYPES OF CALLS ARE /PERMITTED: (I IS NON-NEGATIVE, V IS ANY EXPRESSION) / FRA(I) READ THE I-TH VALUE / FRA(I,V) STORE V IN THIS LOCATION / FRA(-1) UPDATE THE LAST BLOCK / FRA(-1,M) INITIALIZE AND SET THE DATA MODE /THE VALUE OF 'M' DETERMINES THE DATA MODE: / M=0 UNSIGNED INTEGERS / M=1 SIGNED INTEGERS / M=2 DOUBLE PRECISION / M=4 4-WORD FLOATING-POINT /'FRA' RETURNS 0 WHEN CALLED WITH A NEGATIVE INDEX. /'FRA' USES ITS OWN ROUTINES FOR MODES 0-1, AND THE 'FCOM' /ROUTINES FOR MODES 2 & 4. BOTH FUNCTIONS ARE COMPLETELY /RECURSIVE, I.E. THEY MAY BE USED AS ARGUMENTS OF THEMSELVES. PAGE 21 /PRECEEDING THE 8K FUNCTIONS FRA, TAD HORD /CHECK SIGN OF THE INDEX SPA CLA /INITIALIZATION? JMP INITL /YES, OR UPDATE FIXIT R3, CLA CLL RTL /=7306 PUSHF /SAVE THE INDEX FLAC TSTCMA /READ OR WRITE? JMP .+4 /READ PUSHJ /WRITE EVAL /EVALUATE THE EXPRESSION TAD P13 /ALTER THE INSTRUCTION DCA REED POPF /RECALL THE INDEX FLOP TAD SHIFTS DCA LAST1 JMS I R3 /SHIFT RIGHT ONE BIT ISZ LAST1 JMP .-2 TAD (BLKNO&0 /FIRST BLOCK OF THIS FILE SNA ERROR2 /FILE NOT AVAILABLE TAD AC1L /THIS IS NOW THE RELATIVE BLOCK # CIA TAD ARG3 /IS IT THE SAME AS THE LAST ONE? SNA CLA JMP CORE /YES, DATA IS IN CORE JMS LAST1 /CHECK FOR ANY UPDATES TAD (FLNGTH /FILE SIZE STL CIA TAD AC1L SNL CLA /IS THIS A LEGAL INDEX? ERROR2 /NO, IT'S TOO LARGE TAD AC1L TAD (BLKNO&0 DCA ARG3 /SET THE NEW BLOCK NUMBER JMS DISK /AND READ IT IN CORE, TAD REED /R OR W? SZA CLA DCA DISK /SET THE 'CHANGE' FLAG TAD REED TAD WRIT /SET UP THE PROPER EXIT DCA REED TAD OVR1 /DEVELOP THE BUFFER ADDRESS CLL RTR CLL RTR TAD (3200-1 /BUFFER ADDRESS CDF DCA XRT REED, JMP W0 /NOW FOR THE EASY PART! WRIT, JMP R0 /OR ELSEWHERE... INITL, TSTCMA /UPDATE OR INITIALIZE? JMP FINAL /UPDATE PUSHJ EVAL FIXIT /GET THE DATA MODE TAD M4 SNA CLL IAC SZL /0-4? (EXCLUDING 3) ERROR2 /MODE ERROR TAD (-15 STL RAR /DETERMINE THE SHIFT COUNT DCA SHIFTS TAD LORD STL RAL TAD JMPR0 /AND THE PROPER R/W ROUTINE DCA WRIT CDF /NOW GET THE POINTERS TAD I ATSW /=BLKNO DCA (BLKNO&0 TAD I (ILNGTH DCA (FLNGTH TAD I W0+1 /=INHND DCA (HANDLR CDF P FINAL, JMS LAST1 /UPDATE THE LAST BLOCK DCA ARG3 FLOATR DISK, NOP /READ/WRITE SUBROUTINE TAD C200 /= 1 BLOCK IN FIELD 0 DCA ARG1 CIF /GO BELOW I0F /OR 'NOP' JMS I (HANDLR /CALL THE (INPUT) HANDLER ARG1, 200 3200 ARG3, 0 JMP W3 /DEVICE ERROR I0N JMP I DISK LAST1, 0 /CHECK FOR CHANGES & UPDATE TAD DISK /HAVE WE WRITTEN ANYTHING? SZA CLA JMPR0, JMP .+3 /NO SM0 /YES JMS DISK /RESET THE FLAG JMP I LAST1 /AND REALLY DO IT /HERE ARE ALL THE READ AND WRITE ROUTINES: R0, TAD I XRT /UNSIGNED INTEGERS FL0ATR R1, TAD I XRT /SIGNED INTEGERS FLOATR R2, TAD W0 /DOUBLE PRECISION DCA EXP JMP I .+1 GET+6 R4, JMP I .+1 /FLOATING POINT GET+2 SHIFTS, 0 /SEPARATES THE LISTS BY 13 W0, 27 /SINGLE PRECISION INHND /<1000(8) W1, FIXIT /SIGNED OR UNSIGNED JMP I (GET-2 W2, JMP I .+1 PUT+6 W3, CIF /GENERATE ?29.70 JMP I R3 W4, JMP I .+1 PUT PAGE /FCOM: STORAGE FUNCTION FOR DATA ARRAYS FCOM, FIXIT /FIX INDEX AND SET EXP, OVER PUSHA /SAVE INDEX ON THE STACK TSTCMA /CHECK FOR A SECOND ARGUMENT JMP GET PUSHJ /GET THE ARGUMENT EVAL JMS INDEX /COMPUTE THE INDEX JMP .+7 /IT WAS NEGATIVE PUT, TAD EXP /FLOATING STORAGE DCA I XRT TAD OVER DCA I XRT TAD LORD SKP FIXIT /INTEGER STORAGE DCA I XRT TAD HORD DCA I XRT RETURN /FUNCTION RETURN GET, JMS INDEX /FIGURE IT OUT JMP .+5 /NOTE: EXP=27, OVER=0 TAD I XRT /FLOATING RETRIEVAL DCA EXP TAD I XRT DCA OVER TAD I XRT /INTEGER RETRIEVAL DCA LORD TAD I XRT DCA HORD RETURN /'RETURN' FLOATS INTEGERS NOP INDEX, 0 /COMPUTE INDEX AND BRANCH POPA /EXAMINE THE ARGUMENT SPA /FLOATING JMP .+3 /INTEGER ISZ INDEX /SET POSITIVE RETURN CMA CLL RAL /-(I+1)*4 FOR FLOATING CLL RAL /*2 FOR INTEGER STORAGE STL CMA TAD BUFEND /'IAC' IF LAST PAGE FREE TAD BUFR /'NOP' FOR 20K SYSTEM SNL SZA /CHECK TEXT LIMIT ERROR2 /FCOM INDEX EXCEEDED RANGE CMA /SUBTRACT ONE TAD BUFR /'NOP' FOR 20K SYSTEM DCA XRT /LOAD INDEX REGISTER CDF T /'CDF 40' FOR 20K JMP I INDEX /NOTE: 'INDEX' IS EASILY CHANGED TO STORE IN FIELDS 4-7. /THIS PATCH MODIFIES THE 'INDEX' ROUTINE SO THAT POSITIVE /INDICES FROM 0-2047 MAY BE USED TO ADDRESS ALL LOCATIONS /IN FIELDS 4 & 5. THE 'NEGATIVE INDEX' FEATURE HAS BEEN /ELIMINATED: ONLY FLOATING-POINT STORAGE IS AVAILABLE. NOPUNCH *PUT-1 NOP /ELIMINATE THE 'NEG.' RETURN *GET CDF 40 /USE THIS LOC. FOR A CONSTANT JMS INDEX /AND MOVE THIS DOWN ONE *INDEX+2 SPA /CHECK STORAGE LIMIT JMP .+10 /KEEP THE SAME ERROR CODE CLL RTL /MULTIPLY THE INDEX BY 4 SZA /LEAVING THE FIELD INFO CIA /IN THE LINK CMA /SUBTRACT ONE DCA XRT /AND SAVE THE INDEX RTL /SHIFT THE FIELD BIT OVER SKP ERROR2 /INDEX GREATER THAN 2047(10) RTL TAD GET /ADD THE 'CDF' INSTRUCTION DCA .+1 /THIS PATCH MODIFIES THE 'INDEX' ROUTINE SO THAT POSITIVE /INDICES FROM 0-4095 MAY BE USED TO ADDRESS ALL LOCATIONS /IN FIELDS 4-7. THE 'NEGATIVE INDEX' FEATURE HAS BEEN /ELIMINATED: ONLY FLOATING-POINT STORAGE IS AVAILABLE. *PUT-1 NOP /ELIMINATE THE 'NEG.' RETURN *GET CDF 40 /USE THIS LOC. FOR A CONSTANT JMS INDEX /AND MOVE THIS DOWN ONE *INDEX+2 CLL RTL /MULTIPLY THE INDEX BY 4 DCA XRT /LEAVING THE FIELD INFO IAC /IN BIT 11 AND THE LINK AND XRT RTL /SHIFT THE FIELD BITS OVER RTL TAD GET /ADD THE 'CDF' INSTRUCTION DCA .+6 /AND SAVE FOR LATER SM2 /=7776 AND XRT /CLEAN UP THE INDEX CIA CMA /SUBTRACT ONE ENPUNCH;*.+3 /THE CHANGES ARE CONSTRUCTED SO THAT THEY DO NOT INTER- /FERE WITH 'FRA' WHICH USES SOME OF THE 'FCOM' ROUTINES. /THE 'HESITATE' COMMAND PROVIDES A PROGRAMMABLE PAUSE TO /BE USED WHENEVER IT IS NECESSARY TO SYNCHRONIZE THE PRO- /GRAM WITH AN EXTERNAL DEVICE. THE TIMING IS PROVIDED BY /A SOFTWARE LOOP WHICH MUST BE ADJUSTED FOR DIFFERENT MA- /CHINES. ASSEMBLY OPTIONS ARE PROVIDED FOR THE 8/E AND /8/I AND OTHERS ARE EASILY PATCHED. TIMES ARE EXPRESSED /IN MILLISECONDS, SO 'H 1000' PROVIDES A 1 SECOND DELAY. HESI, PUSHJ /PARAMETER = DELAY TIME EVAL / (IN MILLISECONDS) NEGATE SZL /ZERO OR MISSING ARGUMENT? CONTINUE /AVOID A 4HR 40MIN DELAY ! FIXIT /CONVERT TO DOUBLE PRECISION SNA /1ST CYCLE MAY BE A BIT OFF TAD TATE /GET LOOP CONSTANT IAC /COUNT DOWN SNA /DONE? ISZ LORD /1.003 MS PER MAJOR CYCLE JMP .-5 /TIMES THE NUMBER OF CYCLES ISZ HORD JMP .-6 CONTINUE /RETURN TO MAINLINE TATE, IFDEF TFLI <-320> /1.2 USEC (8/E) IFNDEF TFLI <-234> /1.6 USEC (8/I) ///// / FUNCTION PACKAGE FOR 8K U/W-FOCAL: -JVZ- /THESE FUNCTIONS ARE BASED ON THE SERIES APPROXIMATIONS DE- /VELOPED BY D.A. DALBY AND D.E. WELLS OF THE BEDFORD INSTI- /TUTE OF OCEANOGRAPHY, DARTMOUTH, NOVA SCOTIA (DECUS 8-103) /WHILE EXHAUSTIVE TESTING HAS NOT BEEN CARRIED OUT, TYPI- /CALLY THE RESULTS ARE CORRECT TO CA. 3 IN THE TENTH DIGIT. *4600-12 /EXPONENTIAL CONSTANTS: E1, +0;4000;0000;0275 E2, -1;3777;7775;1652 E3, -2;5252;5353;1521 E4, -4;2524;7613;5106 E5, -6;5700;2131;0200 E6, -11;2560;3573;7333 E7, -14;5542;5227;4775 /BASE E EXPONENTIAL FUNCTION: FEXP, CHKSGN /TAKE THE ABSOLUTE VALUE 1 FENT FDIV LN2 /FORM N+F FPUT I FLARGP FEXT NEGATE FIXIT /FORM -N DCA T2 NORMALIZE ///// FENT FADD I FLARGP /FORM F FMUL LN2 FPUT I FLARGP FMUL E7 FADD E6 FMUL I FLARGP FADD E5 FMUL I FLARGP FADD E4 FMUL I FLARGP FADD I X3 FMUL I FLARGP FADD I X2 FMUL I FLARGP FADD I X1 FMUL I FLARGP FADD I X0 FEXT ///// TAD T2 /DIVIDE THE SUM BY 2^N TAD EXP DCA EXP TAD FINISH /POINT TO 'RETURN' DCA CHKARG TAD T3 JMP EXPX /FEXP(X)=1/FEXP(-X) ///// X3, E3 X2, E2 X1, E1 X0, E0 CHKARG, 0 /ARGUMENT CHECK FOR 'FLOG', 'FATN' DCA T2 /SET THE FLIP-FLOP CHKSGN /LOOK AT THE SIGN FIRST JMP I CHKARG /ZERO ISZ CHKARG /NON-ZERO CLA CMA /COMPARE WITH UNITY TAD EXP TAD T2 /.LT. OR .GT. ONE? EXPX, SPA CLA JMP I CHKARG /YOUR CHOICE FENT FPWR FEXP+1 /= -1.7427... FPUT I FLARGP /SAVE THE RECIPROCAL FEXT TAD .-2 JMP I CHKARG /T3=SIGN FLAG, AC=INVERSION FLAG ///// /LOGARITHM CONSTANTS: LN2, +0;2613;4413;7676 L12, -12;4132;5467;5141 L11, -7;3467;0413;5110 L10, -5;4633;3721;5500 L9, -4;3470;0312;3507 L8, -3;4770;3123;3611 L7, -2;2050;7523;5173 /NAPERIAN LOGARITHM FLOG, SM0 /CHECK OUT THE ARGUMENT JMS CHKARG ERROR2 /CAN'T TAKE THE LN OF ZERO DCA T3 CMA TAD EXP FLOAT /FLOAT THE EXPONENT IAC DCA I FLARGP /REPLACE IT WITH 1 NORMALIZE ///// FENT /DO THE SERIES FMUL LN2 FPUT I BUFFPT FGET I FLARGP /JUST THE MANTISSA NOW FSUB I FP1 FPUT I FLARGP /BACK AGAIN! FMUL L12 FADD L11 FMUL I FLARGP FADD L10 FMUL I FLARGP FADD L9 FMUL I FLARGP FADD L8 FMUL I FLARGP FADD L7 / PAGE BOUNDARY FMUL I FLARGP FADD L6 FMUL I FLARGP FADD L5 FMUL I FLARGP FADD L4 FMUL I FLARGP FADD L3 FMUL I FLARGP FADD L2 FMUL I FLARGP FADD L1 FMUL I FLARGP FADD I BUFFPT /ADD N*LN2 FEXT JMP I (EXIT2 /NEGATE RESULT IF NECESSARY /ARCTANGENT FUNCTION FOR ANGLES IN RADIANS FATN, JMS I (CHKARG RETURN /ATN(0)=0 DCA INVRS /SET THE EXIT FENT FMUL FLAC FPUT I BUFFPT /SAVE THE SQUARE FMUL A23 FADD A21 FMUL I BUFFPT FADD A19 FMUL I BUFFPT FADD A17 FMUL I BUFFPT FADD A15 FMUL I BUFFPT FADD A13 FMUL I BUFFPT FADD A11 FMUL I BUFFPT FADD A9 FMUL I BUFFPT FADD A7 FMUL I BUFFPT FADD A5 FMUL I BUFFPT FADD A3 FMUL I BUFFPT FADD A1 FMUL I FLARGP /CONVERT TO ODD POWERS INVRS, FPUT I FLARGP /OR 'FEXT' FGET I (PIOV2 FSUB I FLARGP /ATN(X)=PI/2-ATN(1/X) FEXT JMP I (EXIT2 /TAKE CARE OF THE SIGN ///// /ARCTANGENT CONSTANTS A23, -12;5457;4432;1701 A21, -7;2145;4241;4605 A19, -6;4166;3357;4120 A17, -4;2040;1626;5457 A15, -4;4507;1221;3170 A13, -3;2222;2557;0167 A11, -3;5107;0475;7567 E0, +0;3777;7777/7775 A9, -3;3427;7472;2175 A7, -2;5555;7621;6402 A5, -2;3146;3041;1767 A3, -1;5252;5253;5611 A1, +0;3777;7777;7755 /LOGARITHM CONSTANTS L6, -2;5312;1653;0406 L5, -2;3137;6765;6402 L4, -2;4000;7041;0031 L3, -1;2525;2301;7431 L2, -1;4000;0006;2241 L1, +0;3777;7777;7445 PAGE /EXTENDED PRECISION SIN & COS - TAKEN FROM DEC'S FLOATING- /POINT PACKAGE (R. BEAN) & FOCAL8-231 (DR. H.B. THOMPSON). /THE COEFFICIENTS HAVE BEEN OPTIMIZED FOR U/W-FOCAL (JVZ). FCOS, SM0 /ONLY NEGATE IF POSITIVE JMS I ABSOL /(SUGGESTED BY G. CHASE) FENT FADD PIOV2 /COS(X)=SIN(PI/2-X) FEXT FSIN, CHKSGN /CHECK THE SIGN JMP QUAD1 /ARGUMENT WAS 0 FENT FDIV PIOV2 /CONVERT TO QUADRANTS FPUT I FLARGP FEXT FIXIT /GET THE INTEGER PART AND SC3 /MODULO 4 TAD FSIN+1 DCA QUAD0 /SET UP THE BRANCH JMS FRCT /GET THE FRACTION QUAD0, 0 /AND PROCESS IT FENT FSUB I FP1 /SUBTRACT 1.0 FEXT JMP I QUAD0 NEGATE QUAD1, JMP QUAD5 /USE X QUAD2, JMS QUAD0 /USE 1-X QUAD3, JMP QUAD1-1 /USE -X QUAD4, JMS QUAD0 /USE X-1 QUAD5, FENT /SIX TERM POLYNOMIAL FPUT I FLARGP /SAVE THE ARGUMENT FMUL FLAC FPUT I BUFFPT /SAVE THE SQUARE FMUL C11 FADD C9 FMUL I BUFFPT FADD C7 FMUL I BUFFPT FADD C5 FMUL I BUFFPT FADD C3 FMUL I BUFFPT FADD PIOV2 FMUL I FLARGP /CONVERT TO ODD POWERS FEXT /COMMON EXIT ROUTINE FOR EXTENDED FUNCTIONS EXIT2, TAD T3 /CHECK SIGN JMP FABS+1 /SINE AND COSINE CONSTANTS SC3, 3 C11, -22;4313;2133 C9, -14;2500;3207 C7, -7;5464;5650;4204 C5, -3;2431;5360;3221 C3, +0;5325;0414;3240 PIOV2, +1;3110;3755;2421 /COMMON ROUTINES FOR EXTENDED FUNCTIONS SGNCHK, 0 /ALSO CALLED BY 'GETLN' JMS I ABSOL /TAKE THE ABSOLUTE VALUE FENT FPUT I FLARGP /AND PUT IT BACK AGAIN FEXT TAD SIGN /'FPUT' LEAVES L=1 SZA ISZ SGNCHK /FIRST RETURN = ZERO DCA T3 TAD T3 JMP I SGNCHK /AC,T3 = SIGN OF THE ARGUMENT FRCT, 0 /CALLED BY 'FSIN', 'FRAC' FENT FIXER /='FNOR' FSUB I FLARGP FEXT NEGATE JMP I FRCT /REVISED SQUARE ROOT FUNCTION FSR, LAS SKP /READ THE SWITCH REGISTER FSQT, CHKSGN /BETTER CHECK THE SIGN FLOATR /0 OR SWITCHES SPA CLA /WAS THE ARGUMENT NEGATIVE? ERROR2 /CAN'T TAKE IMAGINARY ROOTS TAD EXP /'CHKSGN' SETS L=1 SMA CLL /USE AN ARITHMETIC SHIFT RAR /DIVIDE EXPONENT BY TWO SZL /TEST IF IT WAS ODD OR EVEN IAC /ODD - ADD ONE DCA EXP TAD M5 /INITIALIZE ITERATION COUNTER DCA T3 SQRT, FENT /NEWTON'S METHOD IS USED FPUT I BUFFPT /SAVE APPROXIMATION FGET I FLARGP /GET BACK THE ARGUMENT FDIV I BUFFPT FADD I BUFFPT FMUL I (FLP5 /DIVIDE BY 2 FEXT ISZ T3 /5 ITERATIONS ARE SUFFICIENT JMP SQRT RETURN FRAC, FIXIT /FIND THE FRACTIONAL PART JMS FRCT RETURN FOUT, FIXIT /SINGLE-CHARACTER OUTPUT SNA SM0 /IN CASE IT'S ZERO PRINTC FSGN, TAD HORD /REAL SIGNUM FUNCTION SZA CLA IAC FLOAT /PREPARE 1.0 FITR, TAD P43 /IMPROVED INTEGER FUNCTION JMS I FRCT+2 /REPLACES 'FIXIT;CLA' (6D) FABS, TAD I (FLARG+1 /CHECK THE ORIGINAL SIGN SPA CLA NEGATE RETURN /ALSO USED BY OTHER FUNCTIONS PAGE 36 /MORE AFTER THE F.P. PACKAGE /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 YNCR+2 /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 /REPEAT? FSUB I FP1 /BECAUSE THE USERS DEMAND IT! / 'FMIN' & 'FMAX' COMPARE TWO ARGUMENTS, RETURNING THE /LARGER OR SMALLER OF THE TWO. THANKS TO R. MAZUR OF /THE HOCHSHULE DER BUNDESWEHR IN MUENCHEN FOR THE IDEA. FMIN, SM0 /AC=4000 FMAX, PUSHA /REMEMBER THE ENTRY POINT PUSHF /SAVE THE FIRST ARGUMENT FLAC PUSHJ /GET THE SECOND ARGUMENT EVAL-3 POPF /RECALL ARGUMENT NO. 1 BUFFER FENT FSUB I BUFFPT /MAKE THE COMPARISON FEXT POPA /GET THE SWITCH TAD HORD /CHECK THE SIGN SPA CLA TAD .+2 JMP FSFX /GET THE RIGHT ONE & RETURN BUFFPT-FLARGP ///// FIN, READC /SINGLE CHARACTER INPUT TAD CHAR FLOAT /'FLOATR' RETURN ///// /FOCAL STATEMENT FUNCTIONS: F(N,ARG1,ARG2,...) /N IS A LINE OR GROUP NO. (USE A CONVENIENT VARIABLE TO /LABEL THE FUNCTION) AND THE ARGUMENTS REPLACE THE VALUE /OF THE SECRET VARIABLES, BEGINNING WITH '#'. FSF'S ARE /NOT FULLY RECURSIVE SINCE THEY ALL USE THE SAME SECRET /VARIABLES. THE VALUE RETURNED BY THE FUNCTION IS JUST /THE LAST EXPRESSION EVALUATED. *SNA FSF, PUSHJ /EVALUATE THE LINE NUMBER MODEPT /(ARG. IS ALREADY IN FLAC) PUSHF /SAVE LINENO, NAGSW, AND LASTC LINENO TAD FSFP ARG, DCA LASTC TSTCMA /MORE ARGUMENTS? JMP DOF /NO PUSHJ EVAL /GET THE NEXT ONE TAD LASTC DCA PT1 /MUST USE THE VAR. PTR. FENT FPUTIPT1 FEXT TAD GINC TAD LASTC /POINT TO THE NEXT JMP ARG DOF, POPA /RESTORE LINENO & NAGSW DCA LINENO POPA DCA NAGSW PUSHJ /EXECUTE A 'DO' CALL DO+2 POPA /RECALL PREVIOUS POINTER DCA LASTC ISZ PDLXR /DUMP 'FISW' FSFX, TAD (FGET I FLARGP DCA .+2 FENT FGET I FLARGP /GET THE RESULT AGAIN IN CASE FEXT /A 'FOR' COMMAND WIPED IT OUT RETURN ///// FSFP, WORDS^3+STVAR+10/# GETL, GETLN /READ LINE NUMBER FOR 'GTNAME' CDI L JMP NAMEND+2 ///// /IMPROVED RANDOM NUMBER FUNCTION (OMSI) USES A TTY WAIT /LOOP TO INITIALLY SET A RANDOM VALUE. AFTER THE FIRST /INPUT SUCCESSIVE NUMBERS ARE GENERATED FROM THE POWER /RESIDUE ALGORITHM DUE TO P.T. BRADY (DECUS 5-25). SEE /THE DISCUSSION BY G.A. GRIFFITH IN DECUS FOCAL8-1. FRAN, FENT / X(1)=(2^17+3)*X(0) MOD 2^35 FNOR I LEVEL0 / GET PREVIOUS VALUE FGET I (RANDOM+1/ SHIFT LEFT TWELVE FEXT DCA EXP / ZERO THE EXPONENT SHIFTL SHIFTL / SHIFT LEFT FOUR MORE SHIFTL SHIFTL JMS I (DUBLAD / PLUS 3 TIMES ORIGINAL SHIFTL JMS I (DUBLAD FENT FPUT I LEVEL0 / SAVE FOR THE NEXT CALL FEXT CMA CLL RAR /=3777 AND HORD DCA HORD /BE POSITIVE IT'S POSITIVE RETURN ///// VFN, TAD LORD /+HORD /GENERATE A NUMERIC FILE NAME SZA CLA /IS THE ARGUMENT ZERO? SM0 /ROUND UP DCA OVER NORMALIZE SM1 PRINTN /CONVERT TO ASCII CIF L JMP VFR /RETURN WITH STRING ADDRESS ///// LGETC, SNL /'GETC' FOR THE LIBRARY ROUTINES GETC TAD CHAR CDI L JMP MGETC+3 /SAME PAGE, DOWN BELOW ///// GETA, PUSHJ /CALLED BY 'GTNAME', 'O A' & 'O C' EVAL /EVALUATE AN EXPRESSION FIXIT CIF L JMP MGETA-1 /DF=P, L=0 ///// PAGE /FLOATING POINT INPUT/OUTPUT ROUTINES: / 8XFPP.PA / FOR PDP8I OR PDP12 WITH EAE / REVISIONS: / PRINTC CHANGED TO CLA AT 15666 TO DELETE LEADING SPACE / /NOTE: THESE ROUTINES HAVE BEEN EXTENSIVELY REVISED! *5400 /AFTER THE FUNCTIONS FLINTP, 0 /CONVERT ASCII TO BINARY - 'READN' JMS FIGO5 /CHECK LEADING CHARACTERS JMS FIGO4 /READ FIRST DIGIT GROUP SNL /ENDED BY A PERIOD? JMS FETCH /SKIP IT & READ 2ND GROUP JMS FIGO7 /AND SET NEW DIGIT COUNT JMS I RESOL /FIX UP THE SIGN TAD CHAR TAD (-"E /DID WE READ AN 'E'? SZA CLA JMP FIGO2 /NO FIGO1, JMS FETCH /YES, PASS THE 'E' FENT FPUT I FLARGP /SAVE THE MANTISSA & DEC. PT. FEXT JMS FIGO4 /READ THE DECIMAL EXPONENT TAD OVER ISZ SIGN /CHECK THE SIGN CIA DCA FIGO4 /SAVE THE RESULT FENT FGET I FLARGP /RESTORE WHAT WE HAD FEXT TAD FIGO4 /COMBINE THE SCALE FACTORS FIGO2, TAD EXP /SET UP THE LOOP COUNTER CLL SPA STL CIA /WITH -(ABS. VALUE+1) CMA DCA FIGO4 SZL /TEST DIRECTION TAD FL10 TAD (FMUL FLP1 /OR 'FMUL FL10' DCA FIGO3+1 TAD P43 /INSERT THE PROPER EXPONENT DCA EXP NORMALIZE JMP FIGO3+3 FIGO3, FENT /SCALE LEFT OR RIGHT FMUL FL10 FEXT ISZ FIGO4 JMP FIGO3 JMP I FLINTP /***RETURN*** FIGO4, 0 /READ A GROUP OF DIGITS JMS FIGO6 /START WITH ZERO SM1 DCA SIGN /INITIALIZE SIGN TAD CHAR TAD (-"- SZA ISZ SIGN /RESET IF POSITIVE CMA CLL RAL /SET CODE FOR "+" CMA CLL RAR /"+" -> 0000(1) SNA CLA /NOT "+" OR "-" IAC /SKIP THE SIGN JMS FIGO5 /AND IGNORE SPACES JMS FIGO7 /DO ALL THE WORK JMP I FIGO4 ///// FIGO5, 0 /PROCESS LEADING CHARACTERS SMA SZA /-240, ONLY 'SZA' OCCURS JMS FETCH /GET FIRST OR NEXT TAD CHAR TAD .-3 /IS IT A SPACE? SNA CLA JMP .-4 /IGNORE LEADING SPACES JMP I FIGO5 ///// FIGO6, 0 /'FLOAT' DCA HORD DCA LORD DCA OVER TAD P13 DCA EXP JMP I FIGO6 ///// /READ A CHARACTER FROM TEXT OR THE INPUT DEVICE: FETCH, 0 TAD I FLINTP /CHECK THE NEXT INSTRUCTION SMA CLA JMP ACCEPT GETC /READ FROM THE TEXT BUFFER JMP I FETCH ///// PRINTC /IN CASE WE WANT TO ECHO FF ACCEPT, READC /READ FROM THE INPUT DEVICE SORTJ /TEST FOR SPECIAL ACTION SPECIAL-1 ACTION-SPECIAL JMP I FETCH ///// FIGO7, 0 /DECIMAL-TO-BINARY CONVERSION DCA EXP /CLEAR DIGIT COUNTER TESTN JMP I FIGO7 /PERIOD, L=0 JMP FIGO9 /OTHER, L=0 TAD SORTCN /GET THE NUMBER FIGO8, MULT10 /ADD IT IN SZA CLA JMP .+3 TAD HORD /CHECK FOR OVERFLOW SPA CLA ERROR2 /INPUT OVERFLOW ERROR ISZ EXP /COUNT THE DIGITS JMS FETCH /GET ANOTHER ONE JMP FIGO7+2 ///// FIGO9, TAD CHAR /ALLOW A-Z TAD (-"E SNA JMP I FIGO7 /'E' IS SPECIAL AND L=1 TAD ("E-"Z-1 STL IAC TAD ("Z-"A+1 SNL SZA JMP FIGO8 /TREAT A-Z LIKE NUMBERS STL CLA JMP I FIGO7 /L=1 ///// /THESE TWO CONSTANTS MUST NOT BE SEPARATED FLP1, -3;3146;3146;3147 FL10, +4;2400;0000;0000 ECHOGO=. /BRANCH LIST FOR 'READC' IECHO-2 /FF IECHO+1 /LF IECHO+1 /RO *PRODUCT SPECIAL,233 /ESCAPE 375 /ALTMODE "_ /RESTART ECHOLST,FF /IGNORE (KEYBOARD ONLY) LF /IGNORE RO /IGNORE /THIS ROUTINE EXTENDS THE FORMAT SPECIFICATIONS (%W.DD) TO /ALLOW THE NUMBER OF DIGITS PRINTED IN SCIENTIFIC NOTATION /TO BE CONTROLLED. A FORMAT OF '0' MEANS 'ALL SIGNIFICANT /DIGITS' WHILE '.05' MEANS 'JUST PRINT 5' WITH APPROPRIATE /ROUNDING. THIS FORMAT PRINTS A LEADING DIGIT FOLLOWED BY /A DECIMAL POINT, MORE DIGITS AND THEN THE EXPONENT. /ANOTHER IMPROVEMENT IS THAT THE MINUS SIGN IS ALWAYS OUT- /PUT JUST AHEAD OF THE FIRST SIGNIFICANT DIGIT. *5600 /A RATHER SPECIAL LOCATION! PD, DIGITS /DEFAULT TGO, 0 /CALLED BY 'PRINTN' DCA XRT2 /SAVE BUFFER ADDRESS TAD FISW /GET FORMAT SAVED BY % TRAP AND P7600 /ISOLATE THE FIELD LENGTH RTL6 STL CIA /NEGATE AND TEST FOR ZERO DCA FLAC /SAVE MINUS FIELD LENGTH TAD FISW /GET NO. OF DECIMAL PLACES SNA TAD PD /USE DEFAULT IF NONE SPEC. ESGN, AND P177 /A REASONABLE LIMIT! SNL /SCIENTIFIC? JMP SPM0+1 /YES, ROUND TO D PLACES TAD FLAC /COMPARE FIELD SIZE SNL / D-F < 0 ? STA STL /NO, TAKE D = F-1 TAD T3 /COMPARE DECIMAL EXPONENT SNL SMA SZA / E > F-D ? SPM0, SNL SMA SZA CLA /ROUND OFF TO F PLACES CIA /ENTER HERE FOR SCI. NOT. DCA T2 /SAVE F-D-E (OR 0 OR -D) TAD T2 /THIS IS TRICKY BUSINESS! STL /EXTEND THE SIGN TAD FLAC / -(E+D), -F OR -D (-D-F) TAD PD /COMPARE WITH LIMIT SZL /SKIPS FOR 0 < AC < PD+1 CLA /LIMIT ROUNDOFF TO DIGITS+1 TAD EX1 /ADD -PD-1 (MDM1) TO RESTORE STL CIA /(E+D), F, D, DIGITS (+1) BUMP, TAD XRT2 /SET UP BUFFER ADDRESS DCA OUTA ISZ I OUTA /INCREMENT THIS DIGIT TAD I OUTA /NOW TEST IT SNL /LITTLE EXTRA THE FIRST TIME TAD M4 TAD M5 SPA SNA CLA /CARRY REQUIRED? JMP RNDC+4 /NO: GO TO OUTPUT DCA I OUTA /YES: MAKE CURRENT DIGIT ZERO STL IAC /SET UP LINK FOR NEXT CYCLE & DCA I START /ANTICIPATE CARRY FROM 999... TAD OUTA /DECR AND CHECK THE POINTER TAD RNDC /-(START OF BUFFER) SZA /BEGINNING OF BUFFER REACHED? JMP BUMP /NO: BUMP THE NEXT DIGIT ISZ T3 /YES: INCR. DECIMAL EXPONENT RNDC, -BUFFER-1 /'NOP' CMA /AND SET THE MANTISSA TO 0.1 TAD XRT2 /BY DECREMENTING THE POINTER JMP TGO+1 /RECOMPUTE THE DECIMAL POINT SM1 /SET SIGN COUNTER DCA T1 TAD C240 /'TAD ESGN' IF YOU WISH CLA /PRINTC TO PRINT A LEADING SPACE BEFORE # TAD FLAC /GET FIELD SIZE SNA /FLOATING OUTPUT ? JMP FLOUT /YES TAD T3 /COMPARE WITH EXPONENT SMA SZA CLA / E > F ? JMP FLOUT+2 /YES: USE FLOATING FORMAT TAD T2 / F-D-E (OR 0 IF E > F-D) TAD T3 / F-D OR E CIA /CALCULATE -NO. OF POSITIONS DCA T2 /TO PRINT BEFORE DECIMAL PT. BACK, TAD T2 /PRINT DD.DDD TAD T3 SNA CLA / P = E ? JMP DIG /YES: PRINT DIGIT IAC /NO ('376' TO SUPPRESS 1ST ZERO) TAD T2 SPA CLA / P < 1 ? TAD SPM0 /YES: PRINT SPACE AGAIN, JMS OUTA /PRINT CHARACTER ISZ T2 /P CHARACTERS PRINTED? JMP BACK /NO SM2 /YES ('TAD 376') PRINTD /PRINT DECIMAL POINT JMP BACK FLOUT, TAD T2 /SET FIELD SIZE DCA FLAC / -D SM1 /SET FLAG DCA OUTA ISZ TGO /SET SECOND RETURN DIG, CLA SM1 /POINTS TO 'TERM' TAD T3 /REDUCE E BY 1 DCA T3 JMS GETD /GET NEXT DIGIT ISZ OUTA /TEST FLAG JMP AGAIN /NORMAL RETURN PRINTD /PRINT FIRST FLOATING DIGIT SM2 /CREATE A PERIOD (256-260) SKP /DON'T FETCH & DON'T COUNT JMS GETD /FETCH NEXT DIGIT JMS OUTA /PRINT IT JMP .-2 /AND REPEAT OUTA, 0 PRINTD /PRINT CHARACTER ISZ FLAC /F CHARACTERS PRINTED? JMP I OUTA /NO: RETURN JMP I TGO /YES: NUMBER FINISHED ///// GETD, 0 /ROUTINE TO UNLOAD BUFFER TAD I XRT2 /AUTO-INDEX REG. SETUP UPON ENTRY ISZ EX1 /TEST FOR END OF SIGNIFICANT FIG. JMP I GETD CLA CMA /FORCE -1 IN ORDER TO DCA EX1 /OUTPUT EXTRA ZEROS JMP I GETD /LEAVE C(AC)=0 ///// FTRM, TAD I DIG /GET THE INPUT TERMINATOR FLOATR ///// DBLSUB, 0 /CHECK FOR A SECOND SUBSCRIPT TSTCMA JMP I DBLSUB /ONLY ONE PUSHF FLAC /SAVE THE FIRST ONE PUSHJ EVAL /GET THE SECOND ONE POPF FLARG /TEMPORARY STORAGE TAD DIMEN DCA PT1 /SET THE VARIABLE POINTER FENT FSUB I FP1 /THE SECOND MINUS ONE FMULIPT1 /TIMES THE DIMENSION FADD I FLARGP /PLUS OFFSET OF FIRST FEXT JMP I DBLSUB /CALLED BY 'GETARG' DIMEN, STVAR+2+WORDS+2 /DATA POINTER FOR (!) PAGE LNFEED= (0&(1&(2 /RESERVE 3 LOCATIONS XLIST; NOPUNCH; PAGE 30; ENPUNCH; XLIST /FLOATING POINT OUTPUT CONVERSION: 'PRINTN' /REWRITTEN TO PROVIDE THREE NEW FEATURES: (1) A 'FLOATING' /MINUS SIGN WHICH APPEARS BEFORE THE FIRST DIGIT; (2) A /MEANS FOR 'TDUMP' TO OUTPUT 3-DIGIT SUBSCRIPTS (+/-999); /(3) A PROVISION FOR NON-PRINTING CALLS WHICH JUST SET UP /THE OUTPUT BUFFER BUT DO NOT DO ANY PRINTING. /THANKS TO JIM CRAPUCHETTES FOR TWELVE LOCATIONS! MDM1, -DIGITS-1 /START FLOUTP AT PAGE+1 FLOUTP, 0 /CONVERT BINARY TO ASCII DCA T2 /SET THE NON-PRINT FLAG STL IAC DCA T3 /INITIALIZE THE EXPONENT JMS I ABSOL /TAKE THE ABSOLUTE VALUE CMA RAR /LINK WILL BE ZERO IF NEGATIVE DCA FGO6 /SET THE SIGN FLAG TAD SIGN SNA CLA /ZERO? JMP FGO3 FGO1, FENT /NUMBER TOO LARGE FMUL I (FLP1 /MULTIPLY BY .1 FEXT ISZ T3 /INCREASE DECIMAL EXPONENT TAD EXP SMA SZA CLA /CHECK THE BINARY EXPONENT JMP FGO1 FGO2, FENT /NUMBER TOO SMALL FMUL I (FL10 /MULTIPLY BY 10 FEXT CMA /DECREASE DECIMAL EXPONENT TAD T3 DCA T3 TAD EXP /CHECK THE BINARY EXPONENT SPA SNA JMP FGO2 FGO3, CMA /NEGATE THE BIT COUNT DCA EXP TAD MDM1 /INITIALIZE DIGIT COUNT DCA OUTDG TAD START /INITIALIZE BUFFER POINTER DCA XRT2 FGO4, DCA EX1 /SHIFT OUT THE FIRST DIGIT SHIFTL TAD EX1 RAL ISZ EXP JMP FGO4 SKP FGO5, MULT10 /IE. 0.672 X 10 = 6 + 0.72.. ETC. DCA I XRT2 ISZ OUTDG /ALL DIGITS OUTPUT? JMP FGO5 /NO: CONTINUE TAD MDM1 DCA EX1 /SAVE NO. OF DIGITS TAD START /GET BUFFER POINTER ISZ T2 /TEST PRINT FLAG JMS I .+1 /OUTPUT MANTISSA JMP I FLOUTP /FIXED POINT DONE TAD ("E /PRINT 'E' PRINTC JMS FGO6 /OUTPUT THE EXPONENT JMP I FLOUTP /FLOATING POINT DONE ///// OUTDG, 0 /MULTI-PURPOSE ROUTINE - 'PRINTD' SMA /IGNORE SPACES AND THE LIKE OR ISZ T1 /DIGITS OTHER THAN THE FIRST ! JMP DGOUT DCA T1 /SAVE THE FIRST DIGIT ISZ FGO6 /CHECK THE SIGN FLAG TAD C255 /MAKE A '-' TAD C240 /'SZA' TO OMIT THIS SPACE PRINTC TAD T1 /RESTORE AC DGOUT, TAD ("0 /FORM ASCII PRINTC JMP I OUTDG C255, 15 /'255' ///// FGO6, 0 /ALSO CALLED BY 'TDUMP' TAD T3 /GET EXPONENT SPA CLA /TEST SIGN SP2 /+2 -> -3 TAD M5 JMS OUTDG /PRINT SIGN TAD T3 SPA CIA MQL DVI /DIVIDE BY ONE HUNDRED 144 DCA T2 SWP /PRINT QUOTIENT SZA /UNLESS IT'S ZERO JMS OUTDG TAD T2 /NOW PRINT REMAINDER JMS PRNT JMP I FGO6 PRNT, 0 /PRINT TWO DECIMAL DIGITS AND P177 MQL DVI /DIVIDE BY TEN 12 DCA T2 SWP /GET QUOTIENT JMS OUTDG TAD T2 /GET REMAINDER JMS OUTDG DCA T1 /RESET SWITCH JMP I PRNT /CALLED BY 'FGO6' & 'PRNTLN' ///// MPLY, 0 /CONTINUATION OF EAE MULTIPLY TAD LORD DCA .+3 TAD AC1L /B*E SWP MUY 0 TAD EX1 MQL /DISCARD FOUR RAL DCA EX1 /INITIALIZE TWO TAD HORD DCA .+3 TAD AC1L /A*E SWP MUY 0 TAD EX1 /ADD TO TWO DCA EX1 TAD LORD DCA .+3 TAD AC1H /B*D SWP MUY 0 TAD EX1 /BUILD UP TWO JMP I MPLY /FINISH ONE & TWO FIELD 1 /FORGET LITERALS *LNFEED TAD I TABCNT /WHERE ARE WE? SNA CLA JMP I CFF /IGNORE THE LF AFTER A CR TAD LASTC DCAIAXIN /SAVE THE LAST CHARACTER JMP I .+1 LFCONT-7 /RETYPE THE INPUT LINE /THIS IS A VERY HANDY ROUTINE FOR CONVERTING BCD DATA TO /BINARY FLOATING POINT FORM. JUST SET EXP=43 AT THE END. *6204 XTEN, 0 /MULTIPLY THE FLAC BY 10 (DECIMAL) SWP /AND ADD IN C(AC) DCA CPRNT /SAVE THE MQ TAD OVER SWP MUY /THANKS TO REV. GEOFFREY CHASE 12 /FOR SUGGESTING AN EAE VERSION SWP DCA OVER TAD LORD SWP MUY 12 SWP DCA LORD TAD HORD SWP MUY 12 SWP DCA HORD TAD CPRNT /RESTORE MQ SWP /AC=OVERFLOW JMP I XTEN /EXECUTION TIME = 60 MICROSECONDS ///// MULT2, 0 /MULTIPLY FLAC BY 2 - 'SHIFTL' TAD OVER CLL RAL DCA OVER TAD LORD RAL DCA LORD TAD HORD RAL DCA HORD JMP I MULT2 /DOES NOT CHANGE 'EXP' ///// DUBLAD, 0 /TRIPLE PRECISION ADDITION CLL TAD OVR1 TAD OVER DCA OVER RAL TAD AC1L TAD LORD DCA LORD RAL TAD AC1H TAD HORD DCA HORD JMP I DUBLAD /CHARACTER INPUT/OUTPUT ROUTINES: 'READC' AND 'PRINTC' /THE INPUT ROUTINE MAY ALSO BE USED TO ECHO A CHARACTER. CHIN, 0 /INPUT A CHARACTER CDF P SNA /'ECHOC' IF AC#0 JMS I INDEV /'READC' IF AC=0 DCA CHAR SORTJ /TAKE CARE OF SPECIAL CHARACTERS ECHOLST-1 ECHOGO-ECHOLST JMP IECHO TAD INDEV /ONLY ECHO FF TO A FILE SPA CLA IECHO, PRINTC /'ZERO' IF NOT ECHOING JMP I CHIN ///// CHOUT, 0 /OUTPUT A CHARACTER - 'PRINTC' SNA /USE AC IF NON-ZERO TAD CHAR /OTHERWISE USE CHAR TAD MCR CIF L JMP TAB /ADJUST TAB COUNTER CROUT, TAD CCR JMS I OUTDEV /CARRIAGE RETURNS TAD CLF JMS I OUTDEV /NORMAL RETURNS JMP I CHOUT ///// /CALLS TO AND FROM THE TAB ROUTINES IN FIELD 0: TABX, PUSHJ /EVALUATE THE COLUMN NO. EVAL-3 FIXIT CIF L JMP ZER+1 /SAME PAGE, FIELD 0 SKPX, JMS CHIN /NEGATIVE COL. NO. CIF L JMP NEG+2 /RETURN TO LOWER FIELD ///// FILIN, ICHAR0 /FILE INPUT ECODEV, XOUTL /DEFAULT OUTPUT /FILE INPUT/OUTPUT ROUTINES: ICHAR, 0 /FILE INPUT VIA (INDEV) CDI L JMP I FILIN /CALL LOWER FIELD JMP I ICHAR FLEN, CLA IAC /CHECK THE FILE LENGTH AND EXP /0=OUTPUT, 1=INPUT CLL RTL /*4 TAD (XLEN DCA CPRNT JMP CPRNT+2 /OFF TO THE LOWER FIELD OCHAR, 0 /FILE OUTPUT VIA (OUTDEV) CDI L JMS I (OCHAR0 JMS I ECODEV /ECHO RETURN JMP I OCHAR /NO-ECHO RETURN EOF, 0 /TRAPS ATTEMPT TO READ BEYOND TAD (XI33 /THE 'END-OF-FILE' CHARACTER DCA INDEV /RESETS POINTERS TO THE TTY: TAD ECODEV DCA OUTDEV TAD CPRNT+1 /AND TURNS ON THE ECHO, TOO DCA IECHO TAD P337 /RETURN A '_' TO CLEAR THE '^Z' JMP I EOF /'EOF' IS ALSO USED BY 'RECOVR' CPRNT, 0 /'PRINTC' FOR DOWN BELOW PRINTC CDI L JMP I CPRNT FBLK, CDF L /READ THE INPUT BLOCK NUMBER TAD I ATSW /SAME PLACE! FL0ATR FIND, FIXIT /CHARACTER SEARCH FUNCTION DCA I TESTC&177 /SAVE IN 'CTEST' JMS I INDEV /READ A CHARACTER DCA CHAR SORTJ /CHECK FOR EOF, MATCH C232-1 FINISH-CTEST TAD CHAR /AND ECHO AS DIRECTED ECHOC JMP FIND+2 /EOF->0, MATCH->CHAR PAGE /FLOATING POINT PACKAGE FOR U/W-FOCAL *FPUTIPT1 FPNT, 0 /VIA 'FENT' CLA /= PAGE 35 CDF P /RESET DATA FIELD TAD I FPNT SNA JMP I FPNT /EXIT CLL RTL /SHIFT PAGE BITS OVER AND RTL /PUT OPERATION CODE IN 9-11 DCA LSORT TAD LSORT /PAGE 0? SPA CLA TAD FPNT /GET CURRENT PAGE AND P7600 DCA T1 /SAVE PAGE, GET RELATIVE TAD I FPNT AND P177 TAD T1 /MERGE SNL /IS IT INDIRECT? JMP NOTID /NO SNA /IS IT OUT-OF-FIELD? JMP CDFV /YES DCA T1 TAD I T1 /GET THE INDIRECT ADDRESS NOTID, CIA CMA CLL /BACKUP ONE DCA XRT2 /LOAD THE INDEX REGISTER ISZ FPNT /ADVANCE PROGRAM COUNTER TAD LSORT /GET BACK THE INSTRUCTION AND P7 /MASK THE OP CODE SNA JMP FLGT TAD M6 /TEST IT SNA JMP FLPT TAD JUMPX /SOMETHING ELSE DCA LSORT TAD I XRT2 /LOAD THE OPERAND DCA EX1 TAD I XRT2 DCA AC1H TAD I XRT2 DCA AC1L TAD I XRT2 /'DCA OVER' FOR 3-WORD VERSION DCA OVR1 CDF P LSORT, 0 /BRANCH TO THE PROPER ROUTINE SKP CLA /LOWER FIELD COMMAND SCANNER GETC SORTX /SEARCH FOR END OF THE 2ND WORD JMP .-2 SPNOR /SKIP TO THE START OF THE THIRD CIF L JMP I LSORT /NOTE: 'CHAR' PRESERVED BELOW ! CDFV, CDF V /CHANGE TO THE VARIABLES FIELD TAD PT1 /GET THE DATA POINTER JMP NOTID JUMPX, JMP I M6 /BRANCH TABLE FOR 'FPNT' FLAD FLSB FLDV FMPY FLEX M6, -6 FLNR /HERE ARE THE FLOATING POINT OPERATIONS: FLGT, TAD I XRT2 /FGET=0 DCA EXP TAD I XRT2 DCA HORD TAD I XRT2 DCA LORD TAD I XRT2 /'NOP' FOR 3-WORD VERSION DCA OVER JMP FPNT+2 /L=0 FLPT, TAD EXP /FPUT=6 DCA I XRT2 TAD HORD DCA I XRT2 TAD LORD DCA I XRT2 TAD OVER /'JMP FPNT+2' FOR 3-WORD VERSION DCA I XRT2 JMP FPNT+2 /L=1 ///// FLTONE, 1;2000;0;0 /USED BY 'FOR' 'Y' 'FLOG' & 'FSIN' FLEX, PUSHF /FPWR=5 FLAC JMS I FPNT+1 /SAVE FLAC AND MOVE EXPONENT FIXIT /ONLY HANDLES INTEGER POWERS SMA CMA /BUT THEY MAY BE EITHER DCA LSORT /POSITIVE -OR- NEGATIVE! TAD HORD DCA SIGN /SAVE SIGN OF EXPONENT IAC FLOAT /START WITH UNITY NORMALIZE IBLE, POPF /RECALL THE ARGUMENT FLOP TAD (.+4-FPNT-3 /LOAD THE RETURN ADDRESS ISZ SIGN /CHECK THE DIRECTION JMP .+5 JMP I M6-3 /TAKE THE INVERSE (ONCE) PUSHF /SAVE THE RECIPROCAL FLAC JMP IBLE TAD P7 /ADVANCE THE RETURN ISZ LSORT /CHECK THE LOOP COUNT JMP I M6-2 /ACCUMULATE THE PRODUCT JMP FPNT+1 /DONE TAD M4 TAD PDLXR /REUSE THE SAME DATA DCA PDLXR JMP IBLE ///// FMQ, FIXIT /DISPLAY A NUMBER IN THE MQ MQL RETURN /LINC-MODE VERSION IS LONGER ///// IFZERO T-20 < FDAY, FIXIT /READ OR CHANGE THE SYSTEM DATE CIF T JMP DAY > *.!177-6 /BRANCH LIST FOR 'FETCH' ACTION, ENDFI /ESCAPE = RETAIN CURRENT ENDFI /ALTMODE = DITTO READ /BA = RESTART INPUT ACCEPT /FF = IGNORE IT ACCEPT /LF = IGNORE IT ACCEPT /RO = IGNORE IT PAGE /THIS ROUTINE COMBINES THE EXPONENTS FOR MULTIPLY AND /DIVIDE AND DETERMINES THE SIGN OF THE RESULT; IF THE /RESULT IS ZERO IT EXITS IMMEDIATELY. SGNTST, 0 /TEST AND SAVE SIGN OF THE RESULT IAC /ADD ONE TO EXPONENT TAD EXP DCA EXP JMS ABSOLV /TAKE THE ABSOLUTE VALUE TAD SIGN SNA JMP MDXIT+6 /QUICK RETURN AND P4000 /STRIP THE SIGN BIT TAD AC1H /DO AN EXCLUSIVE OR DCA SIGN /AND SAVE THE RESULT SWP DCA ABSOLV /CLEAR & SAVE THE MQ TAD AC1H SZA ISZ SGNTST SPA CLA /TEST SIGN OF OPERAND JMS REVERS /FOR BOTH MULTIPLY AND DIVIDE JMP I SGNTST ///// /THREE-WORD BY THREE-WORD MULTIPLICATION: /THE ANSWER IS ROUNDED OFF TO THREE WORDS / (A+B+C)*(D+E+F) = NINE PARTIAL PRODUCTS FMPY, DCA T1 /SAVE THE RETURN ADDRESS TAD EX1 /ADD THE EXPONENTS (PLUS 1) JMS SGNTST /AND DETERMINE THE SIGN OF RESULT JMP MDONE /THE RESULT IS ZERO! TAD OVER /C*F DCA .+3 TAD OVR1 MQL MUY 0 MQL /SAVE HIGH ORDER & ERASE SIX TAD LORD /B*F DCA .+3 TAD OVR1 SWP MUY /USE PREVIOUS HIGH ORDER AS 0 /REMAINDER IN THIS POSITION TAD P4000 /ROUND UP DCA SGNTST /SAVE FOUR RAL DCA EX1 /SAVE CARRY TAD OVER /C*E DCA .+3 TAD AC1L SWP MUY /ADD IN PREVIOUS 0 /PARTIAL PRODUCT TAD SGNTST /SUM HIGH ORDER PARTS MQL /DISCARD FIVE SZL ISZ EX1 /ACCUMULATE CARRIES TAD HORD /A*F DCA .+3 TAD OVR1 SWP MUY 0 TAD EX1 /BUILD UP THREE DCA EX1 TAD OVER /C*D DCA .+3 TAD AC1H SWP MUY 0 TAD EX1 DCA EX1 /ADD TO THREE JMS I MEND /DO 'B*E', 'A*E', AND 'B*D' SWP MDONE, DCA OVER /SAVE THREE TAD HORD /A*D DCA .+3 TAD AC1H SWP MUY 0 MDXIT, DCA HORD /SAVE ONE SWP DCA LORD /SAVE TWO DVXIT, TAD ABSOLV MQL TAD T1 TAD FPNTP3 /COMPUTE THE RETURN POINT DCA RESOLV NORMALIZE JMP RESOLV+1 /EXIT FROM MULTIPLY / DIVIDE ///// MEND, MPLY /SOFTWARE MULTIPLY AREA P4000, 4000 FPNTP3, FPNT+3 ///// ABSOLV, 0 /TAKE THE ABSOLUTE VALUE TAD HORD DCA SIGN /BUT REMEMBER WHAT IT WAS JMS RESOLV JMP I ABSOLV RESOLV, 0 /RESTORE THE PROPER SIGN TAD SIGN SPA CLA JMS INVERT JMP I RESOLV INVERT, 0 /COMPLEMENT FLAC - 'NEGATE' TAD OVER CLL CIA DCA OVER CML RAL TAD LORD CIA DCA LORD CML RAL TAD HORD CIA DCA HORD JMP I INVERT REVERS, 0 /NEGATE THE OPERAND TAD OVR1 CLL CIA DCA OVR1 CML RAL TAD AC1L CIA DCA AC1L CML RAL TAD AC1H CIA DCA AC1H JMP I REVERS /EAE INSTRUCTIONS: MUY=7405 DVI=7407 NMI=7411 SHL=7413 MQL=7421 SCA=7441 CAM=7621 /THREE-WORD BY THREE-WORD EAE DIVIDE ROUTINE *6766 FLDV, DCA T1 /SAVE THE RETURN POINT TAD EX1 /SUBTRACT THE EXPONENTS CMA /COMPENSATE FOR SHIFT JMS SGNTST ERROR2 /THE DIVISOR IS ZERO! SM3 DCA RESOLV /SET THE COUNTER TAD P13 /'XRT-1' DCA XRT2 /INITIALIZE QUOTIENT POINTER TAD OVR1 CLL RAL DCA OVR1 /SHIFT THE OPERAND TO THE LEFT TAD AC1L RAL DCA AC1L TAD AC1H RAL DCA DVSR /SAVE THE TRIAL DIVISOR JMP DVLP+1 ///// DADJ, DCA LORD /RESTORE THE OVERDRAUGHT STA STL RTL /POINTS TO 'AND EX1' TAD QUOT /REDUCE THE QUOTIENT DCA QUOT TAD OVR1 /NOW ADD IN THE DIVISOR TAD EX1 DCA EX1 /THE LEAST-SIGNIFICANT WORD RAL TAD AC1L TAD OVER DCA OVER RAL TAD DVSR JMP DVCK /CHECK FOR SUCCESS AGAIN ///// DVSB, 0 /MULTIPLY QUOTIENT*DIVISOR SWP /AND SUBTRACT FROM DIVIDEND SNL IAC /ADD IN THE PREVIOUS CARRY MUY QUOT, 0 SWP /GET BITS FOR THIS POSITION CLL CIA TAD I NORM /SUBTRACT FROM THE DIVIDEND DCA I NORM CMA CML TAD NORM /BACKUP AND REVERSE THE LINK DCA NORM JMP I DVSB /CALLED TWELVE TIMES /THIS NORMALIZE ROUTINE WORKS FOR BOTH POSITIVE & NEGATIVE /NUMBERS, PRESERVING THE VALUE OF 'SIGN' FOR USE LATER ON. NORM, 0 /NORMALIZE THE FLAC - 'NORMALIZE' SM0 /=4000 AND HORD DCA XRT2 /SIGN BIT TAD HORD SNA TAD LORD SNA TAD OVER SZA CLA /MANTISSA=0 ? JMP NORGO DCA EXP JMP I NORM /YES NORML, SHIFTL /ONE BIT AT A TIME CMA TAD EXP DCA EXP NORGO, TAD HORD RAL TAD XRT2 /COMPARE SIGN & BIT 1 SMA CLA /ARE THEY DIFFERENT ? JMP NORML /NOT YET SM0 /CHECK FOR 4000 ..... TAD HORD / SNA / TAD OVER SNA CLA JMS I NORM+1 /SHIFT IT BACK A BIT JMP I NORM ///// TAD BUFR DCA AXOUT /SET 'TEXTP' DCA XCT /CONTINUE LINEFEED TAD CCR /START WITH A CR PRINTC TAD I C200 /THEN PRINT A STAR ISZ I DMPSW /PREVENT STUTTERING LFCONT, PRINTC /RETYPE THE INPUT LINE GETC TAD AXIN CIA /THROUGH THE CURRENT POSITION TAD AXOUT SPA CLA JMP LFCONT TAD T3 /CHECK FOR AN EXTRA CHARACTER SPA CLA PRINTC CMA TAD AXIN JMP I CCR /RESET PACKING POINTERS DVLP, DCA I XRT2 /ONLY 2 TIMES: XRT, THEN XRT2!! TAD LORD MQL /LOAD 24 BITS OF THE DIVIDEND TAD HORD DVI /CALLED THREE TIMES DVSR, 0 /THE TRIAL DIVISOR STA /SET TO THE MAXIMUM SNL /DIVIDE CHECK? SWP /GET THE ANSWER DCA QUOT /SAVE THE PARTIAL QUOTIENT DCA EX1 /CLEAR THE GUARD WORD TAD I DADJ+1 /INITIALIZE THE WORD POINTER DCA NORM TAD OVR1 /FORM: DIVIDEND-QUOT*DIVISOR JMS DVSB TAD AC1L JMS DVSB TAD DVSR JMS DVSB JMS DVSB /FINISH PROCESSING DVSR DVCK, TAD LORD /CHECK FOR SUCCESS SNL JMP DADJ /TOO BIG, CORRECT QUOTIENT DCA HORD /SHIFT THE REMAINDER LEFT TAD OVER DCA LORD TAD EX1 /THE 'GUARD WORD' DCA OVER TAD QUOT ISZ I RESOL /CHECK THE LOOP COUNTER JMP DVLP DCA OVER /SAVE THE FULL QUOTIENT TAD XRT2 DCA LORD TAD XRT SMA /CHECK THE 'SIGN' BIT JMP .+5 /OK, SAVE HORD DCA HORD JMS I .+1 /SHIFT RIGHT A BIT SM0 /POINTS TO 'DIV2' TAD HORD /CLEAR THE SIGN BIT DCA HORD JMP I (DVXIT /CONCLUDE EAE DIVIDE PAGE *CLA / FOR 'FLEX' 0 / FLOP -> FLAC TAD EX1 DCA EXP TAD AC1H DCA HORD TAD AC1L DCA LORD TAD OVR1 DCA OVER JMP I CLA ///// ALIGN, 0 /SUBROUTINE TO LINE THINGS UP TAD AC1H /IS THE OPERAND ZERO? SNA CLA JMP I ALIGN /DON'T WASTE ANY TIME TAD HORD /IS FLAC ZERO ? SNA TAD LORD SNA CLA JMP OSHFT /YES, FLOP -> FLAC TAD EX1 /ARE THE EXPONENTS EQUAL? CIA TAD EXP SNA JMP AOK /YES, SO THERE'S NOTHING TO DO DCA CLA TAD CLA /SAVE AND CHECK THE DIFFERENCE SMA CIA /NEGATE FOR LOOPING DCA T1 TAD T1 /CAN THEY BE ALIGNED? ALC, TAD P43 /'P27' FOR 3-WORD VERSION SPA CLA JMP NOWAY /NO, USE THE BIGGEST ONE TAD CLA /YES, WHICH ONE IS BIGGER? SMA JMS DIV1 /FLAC SPA JMS DIV2 /FLOP ISZ T1 JMP .-6 /REPEAT AOK, ISZ ALIGN JMP I ALIGN ///// JMS DIV2 /OPERANDS HAVE THE SAME SIGN JMS DIV1 /SO SHIFT THEM RIGHT ONCE AND RAR TAD DIV2 /ADD THE LEAST-SIGNIFICANT BITS CLA RAL JMP FLNR-1 /THEN ADD THE REST /TURN THE FLOATING ACCUMULATOR INTO A 24-BIT INTEGER WITH /THE LEAST MOST SIGNIFICANT 12 BITS IN THE AC UPON RETURN INTEGER,0 /'FIXIT' TAD P27 JMS FIXER /CONVERT TO A 24-BIT INTEGER DCA OVER /CLEAR THE FRACTION JMS I RESOL CLL /VERY USEFUL! TAD LORD JMP I INTEGER ///// FIXER, 0 /FIX UP A FLOATING POINT NUMBER DCA EX1 /SAVE THE DESIRED BINARY POINT TAD EXP SPA SNA CLA /IS IT GREATER THAN ONE? JMP NOFIX /NO, RETURN ZERO JMS I ABSOL /NECESSARY FOR NEG. VALUES DCA AC1H TAD HORD /IGNORE UNNORMALIZED NUMBERS JMS ALIGN /DO IT... P27, 27 JMP I FIXER /DONE NOFIX, FLOAT /STUFF WITH ZEROS DCA EXP JMP I FIXER ///// *CLA CLL RTL /FOR 'FRA' DIV1, 0 /SHIFT FLOP RIGHT CLA RAR DCA DIV2 TAD AC1H SPA CML RAR DCA AC1H TAD AC1L RAR DCA AC1L TAD OVR1 RAR DCA OVR1 ISZ EX1 JMP I DIV1 JMP I DIV1 ///// FP3, FPNT+3 *SM0 /FOR NORMALIZE, DIVIDE DIV2, 0 /SHIFT FLAC RIGHT CLA CLL TAD HORD SPA CML RAR DCA HORD TAD LORD RAR DCA LORD TAD OVER RAR DCA OVER ISZ EXP JMP I DIV2 JMP I DIV2 ///// REVERS FLSB, JMS I .-1 /FSUB=2 - NEGATE THE OPERAND FLAD, JMS ALIGN /FADD=1 - ALIGN EXPONENTS JMP I FP3 /NOT POSSIBLE SM0 AND HORD /COMPARE SIGNS TAD AC1H SMA CLA JMP AOK+2 /SIMILAR: SHIFT RIGHT ONCE JMS I (DUBLAD FLNR, NORMALIZE /FNOR=7 - CALL NORMALIZE JMP I FP3 ///// *CLA SM1 /FOR 'ASK' AND EAE DIVIDE TERM, 0 /INPUT TERMINATOR NOWAY, SM0 /MISSION IMPOSSIBLE AND EX1 /POINTER FOR EAE DIVIDE TAD EXP /FIND OUT WHO'S BIGGEST SPA CLA TAD EXP /SIGNS DIFFER: TEST 'EXP' SNA TAD CLA /SIGNS EQUAL: CHECK DIFF. SPA CLA OSHFT, JMS CLA /EX1 > EXP JMP I ALIGN /EXP > EX1 PAGE /LIBRARY AND FILE COMMAND PROCESSOR: /****** STORAGE ALLOCATION MAP ****** /***** ***** /* 1200 2ND INPUT BUFFER /* 1600 THE OUTPUT BUFFER /* 2200 STACK LIVES HERE /* 3000 PUSHDOWN ROUTINES /* 3200 MAIN INPUT BUFFER /* 3600 MAIN INPUT HANDLER /* 4200 THE LIBRARY HANDLER /* 4600 THE OUTPUT HANDLER /* 5200 2ND INPUT HANDLER /* /* 5600 FILE OUTPUT, CLOSE & ABORT /* 6000 OPEN, RESTORE & FILE INPUT /* 6200 TABULATE, HANDLER & SETDHT /* 6400 DECODER, DATER, SAVER, GOSUB /* 6600 RUN,CALL,BRANCH,RETURN,LJUMP /* 7000 LIBRARIAN, IOWAIT /* 7200 OPEN, DISMISS & COMPARE /* 7400 GTNAME /***** ***** /************************************ / INITIAL TEXT FOR U/W-FOCAL FIELD 2 PAGE 1 0 /PROGRAM LENGTH 5051 /'()' FOR TDUMP LINE0, 0 /POINTER TO NEXT 0 /LINE NO. ZERO TEXT "C U/W-FOCAL:" TITLE, TEXT "VER-4E" /'?M'=CODED CR DATE, TEXT "15.10.78?M" LINE1= DATE+5 /NULLS BECOME SPACES *100 ZBLOCK 2 /PC0 FOR COMMAND MODE /PAGE ZERO STORAGE HAS BEEN CAREFULLY ARRANGED ! FIELD 0 PAGE 0 INITLZ /INTERRUPT SERVICE ROUTINE CIF P JMP I [INTRPT /PATCH 177 FOR POWER FAIL PRNTC, RMF /RETURN FROM THE INTERRUPT I0N CL0SE, 5600 /'JMP I 0' USR, 7700 //POINTER TO MONITOR (200 IF IN CORE) K77, 77 //LOCATION 7 FOR PLOTTER ROUTINES AUTO, ZBLOCK 4 /AUTO-INDEX REGISTERS ICHARX, ICHAR0 /USE THE REMAINING ONES OFFSET, ICHAR-XI33 /FOR THE EXTRA FEATURES SCHARX, SCHAR0-ICHAR0 *20 NONAME, LPUSHF /INSERT VERSION NO. AFTER 'ERASE' H0RD, VERSION LPOPF XCHAR, NAMLOC-1 /STRATEGICALLY LOCATED! IOWAIT, SP1 /POINTER TOO! DCA GOSW /SET RETURN POINTER JMS TEMP /THEN UPDATE HEADER DCA LIBFLG /ZAP 'PROGRAM SAVED' FLAG TAD GOSW /RETURN FOR LOAD CALLS EXIT, TAD GOJUMP /NORMAL RETURNS='JMP I (PROC' DCA GOSW DISMISS /REMOVE THE USR CDI P I0N GOSW, [DERR /LOWER FIELD ERROR ROUTINE DISMISS /CLEARS AC (JMP 135) TAD GOSW /(RELOCATE FOR LINC INTERRUPTS) CDI P DCA I [ERROR /SIMULATE A 'JMS' JMP I [ERROR+1 GOJUMP, JMP I K177-1 /PLUS (GOSW) *HORD VERSION,TEXT "16K-V4" LGOSUB /-1 CONT / 0 K177, START /+1 GOTO+1 /+2 NEWDEV, ZBLOCK 4 /'NEWDEV-1'='TELSW' FLNGTH= .-2 STBLK= .-1 /'LIBBLK-1'='BUFR' LIBBLK, ZBLOCK 2 /FOR DEVICE NAME 4201 /LOAD POINT DEVNO, 0 /FOR DEVICE # LIBHND, ERTRAP /HANDLER ENTRY CHAR, [7200 /LOWER FIELD COPY NAMLOC, ZBLOCK 4 /(MUST BE 'CHAR+1') EXTENSION=.-1 DSK, 5723 /HASH CODE FOR DEFAULT DEVICE LIBDEV, ZBLOCK 4 LIBFLG= .-1 /REFERENCE VIA P77 *100 PC0, 0 /ENTRY AND RESTART POINT JMP I 0 /INITIALIZE (ONCE ONLY) SWAP, CLA CLL IAC /POINTER TO SWAP ROUTINE JMP EXIT *.+2 /FOR COMPATIBILITY TEMP, [7400 /UPDATE THE HEADER CIF T JMP NUHEAD+1 SINBLK, ZBLOCK 2 5201 /4201 PATCHED BY PLOT 0 SINHND, 0 SPOINT, 0 D, DATE-1 XNAME, NAMLOC INBLK, ZBLOCK 2 3601 0 INHND, GOSW /REREAD TRAP OUTBLK, ZBLOCK 2 4601 FILDEV, 0 OUTHND, 0 OUTFLG, 0 *PRINTC&177 ERROR0= JMS I . /='PRINTC' TRAP ERROR1= JMS GOSW /SECONDARY INPUT ROUTINES: THE 'O S' AND 'O R S' COMMANDS /IN THE ABSENCE OF THE PLOTTER ROUTINES THERE ARE NO RE- /STRICTIONS ON THE SECOND INPUT FILE, BUT THE ADDITION OF /THESE ROUTINES LIMITS THE 'L' COMMANDS TO THE USE OF THE / DEVICE - OR ANY HANDLER CO-RESIDENT WITH THE SYS- /TEM DEVICE, SUCH AS 'RKB0', OR 'DTA1' IN A 'TD8E' SYSTEM. *200 SINPUT, CLL CMA /USE THE REGULAR LOOKUP ROUTINE JMS I [OPEN SINBLK-1 ERROR0 /FILE MISSING JMP I CRT /PATCHED BY SCOPE OVERLAY TAD STBLK DCA SBLK SM1 DCA SINFLG SRST, TAD SINFLG SNA CLA ERROR0 /NOTHING LEFT TAD SCHARX *CR TAD ICHARX /ENTRY POINT FOR 'O I', 'O R I' CDF P DCA I INP /CHANGE THE FILE INPUT POINTER JMP I TTY INP, FILIN TTY, TTYIN-1 CRT, TTYIN /OR 'OSCOPE' END, ENDCHK SEND, 0 /POINTS TO NEXT STEP JMS I END /CHECK FOR THE EOF SINFLG, 0 /'FILE OPEN' FLAG SCHAR0, ISZ SINFLG /BUFFER EMPTY? JMP I SEND /NO, GET THE NEXT CHARACTER I0F JMS I SINHND /READ ANOTHER BLOCK 0200 1200 /2200 PATCHED BY PLOT SBLK, 0 SMA CLA /FATAL ERROR? SKP CLA JMP I [DERR TAD [-600 DCA SINFLG /RESET THE WORD COUNTER ISZ SBLK /ADVANCE THE BLOCK NO. TAD SBLK-1 DCA SPOINT /AND RESTART FROM THE TOP I0N SCHAR1, TAD I SPOINT /UNPACK THE BUFFER JMS SEND TAD I SPOINT /SAVE UPPER 4 BITS AND [7400 DCA I SBLK-1 ISZ SPOINT /POINT TO THE NEXT TAD I SPOINT JMS SEND TAD I SPOINT /NOW TO PUT THE PIECES ISZ SPOINT /ALL TOGETHER AGAIN AND [7400 CLL RTR RTR TAD I SBLK-1 RTR RTR JMS SEND JMP SCHAR1 /ROUND & ROUND & ROUND WE GO ///// LPTDEV, XOUTL; ZBLOCK 2 /CHANGE THESE 3 LOCATIONS TO THE /DEVICE LPT /ENTRY POINT AND THE DEVICE NAME LPTCHK, [PDLXR /CHECK FOR CALLS TO 'LPT:' SM2 COMPAR /NOW CHECK IT LPTDEV NEWDEV-1 JMP I LPTCHK /NOT WHAT WE'RE LOOKING FOR ISZ LPTCHK /RETURN WITH THE ENTRY POINT TAD LPTDEV /(INSERT OTHER CODE HERE - FOR EX: JMP I LPTCHK /A CHECK FOR THE ',E' OPTION,ETC.) /THE STACK, TTY BUFFER & ERROR TRAP ALL LIVE HERE *3024 /BEGINNING OF THE STACK PCHK, ["0 /STACK OVERFLOW CHECK CDF P TAD I [PDLXR /ADJUST FIELD 1 X-REGISTER DCA PDLXR /BACKUP & COPY TAD PDLXR DCA I [PDLXR TAD PDLXR /CHECK FOR OVERFLOW STL CIA TAD (2200 /2600 PATCHED BY PLOT CDI L SPA SNA SZL CLA /-10 = L-P JMP I PCHK PDERR, TAD .-3 /TOO BAD! JMP EXIT+1 /USE 'CDI L' AS THE ERROR CODE MPUSHF, 0 /PUSH 4 WORDS ON THE STACK TAD PDERR-2 /LOWER FIELD ENTRY TAD PCHK+1 /UPPER FIELD ENTRY DCA FCDF CLL CMA TAD I MPUSHF /BACKUP POINTER ISZ MPUSHF DCA AUTO TAD [-4 JMS PCHK TAD [-4 DCA PCHK FCDF, CDF L P /CHANGE TO CALLING FIELD TAD I AUTO CDF S DCA I PDLXR /LOAD STACK ISZ PCHK JMP FCDF /WITH FOUR WORDS SP2 TAD FCDF /CHANGE 'CDF' TO 'CDI' DCA .+1 CDI L P JMP I MPUSHF APUSHX, DCA MPOPF /PUSH THE AC ON THE STACK SM1 JMS PCHK TAD MPOPF DCA I PDLXR CDI P JMP I (XPUSHA+3 /ONLY USED BY FIELD 1 *.&7757 TBUF, ZBLOCK 20 /TELETYPE OUTPUT BUFFER MPOPF, 0 /POP 4 WORDS TAD I MPOPF DCA AUTO JMS PCHK /COPY THE PDLXR TAD [-4 DCA PCHK TAD I PDLXR DCA I AUTO CDF P ISZ I [PDLXR /FAKE A FIELD 1 USE CDF L ISZ PCHK JMP .-6 ISZ MPOPF JMP I MPOPF TRAP, 0 /RECOVER FROM SELETED ERRORS DISMISS TAD TRAP DCA GOSW /ASSUME NORMAL ERROR EXIT SP2 CDF P ISZ I (NAGSW /WAS A LINE NUMBER GIVEN? JMP EXIT /YES, FALL INTO THE TRAP JMP GOSW+1 /NO, DO THE USUAL STUFF REKOVR, 0 /CONTINUATION OF ERROR ROUTINE KCC TAD (-17 DCA TBUF TAD (TBUF DCA PDLXR DCA I PDLXR /CLEAR OUT THE TTY BUFFER ISZ TBUF JMP .-2 TAD I SWAP /CHECK CORE-SWAP FLAG SNA CLA JMS I SWAP /RESTORE THE SCRATCH AREA TAD [CR /PRINT A CR AHEAD OF ERROR MESSAGE CLA /OR 'JMS I PRNTC' TAD REKOVR /LET 'EOF' RESTORE THE TTY CDI P DCA I [EOF JMP I (EOF+1 /THEN GO PRINT THE ERROR MESSAGE PAGE 26 /INITIALIZE THE VARIABLES AND THE DATE INITLZ, ZBLOCK 20 /CLEAR ANNOYING FLAGS SM8 /PATCH FOR MULTI-8 JMP .+4 6770 /GET THE TIME-OF-DAY JMS I MV1 /REVERSE HRS, MINUTES DCA MV1-4 /INITIALIZE RANDOM NO. TAD .+3 JMS MOVE /LOAD COMMAND DECODER AREA .+1-MV1 RELOC RANDOM-16 PUTV, .-1 /SUBROUTINE TO LOCATE VARIABLES DCA THISOP /SAVE THE NAME DCA LORD /CLEAR SUBSCRIPT PUSHJ GS1 /DO THE LOOKUP POPF FLAC /GET THE VALUE FENT FPUTIPT1 /STORE IT FEXT TAD LASTV /ADVANCE THE POINTER DCA FIRSTV CIF L JMP I PUTV /RETURN RANDOM, 0;4421;3040;1;0 /RANDOM ENOUGH? RELOC MV1, SM1 /SET THE ADDRESS POINTERS TAD I (FIRSTV /USING THE VALUE HERE DCA I (SECRTV TAD I (FIRSTV DCA I (LASTV JMS SETV /CALL OUR FIELD 1 ROUTINE PI;2011 SP2 TAD I (LASTV DCA I (DIMEN /FOR DOUBLE SUBSCRIPTING JMS SETV FPZ;4100 /! JMS SETV FPZ;4200 /" SP2 TAD I (LASTV DCA I (FSFP /FOR FSF'S JMS SETV FPZ;4300 /# JMS SETV FPZ;4400 /$ JMS SETV FPZ;4500 /% JMP FINALZ /'NOP' FOR MORE JMS SETV FPZ;4600 /& JMS SETV FPZ;7200 /: JMS SETV FPZ;3400 /\ JMP .+3 /SINGLE QUOTE IS OUT FPZ;4700 /' FINALZ, CIF T JMS I (DATA /SET THE DATE WORDS JMS I (ENVIR /CHECK THE ENVIRONMENT KSF /KEYBOARD INPUT? JMP NONAME /NO JMP SWAP /YES: LEAVE VERSION ID FPZ= TBUF /FLOATING POINT ZERO PI, 2;3110;3755;2421 SETV, 0 /CROSS-FIELD CALL CDF L TAD I SETV /GET THE DATA VALUE ISZ SETV DCA .+2 LPUSHF /SAVE IT ON THE STACK 0 TAD I SETV /NOW GET THE NAME ISZ SETV CDI P JMS I (PUTV /AND INSERT IT JMP I SETV /DF=P MOVE, 0 /CLEVER LITTLE ROUTINE DCA AUTO TAD I MOVE DCA PC0+1 ISZ MOVE CDF L TAD I MOVE /WHERE ITS AT CDF P DCA I AUTO /WHERE ITS GOING ISZ PC0+1 /COVER OUR TRACKS JMP MOVE+4 ISZ MOVE JMP I MOVE /DF=P PAGE 15 /CHECK THE RUN-TIME ENVIRONMENT: 7777 /BIPCCL POINTER XI33+1 /RELOCATION POINTER ENVIR, 0 TAD I ENVIR-2 /ARE WE RUNNING UNDER SOMETHING? RTL /2000=BATCH, 1000=RTS8 SNL SMA CLA /EITHER BATCH OR RTS8? JMP VIDEO /NO, CHECK SCOPE MODE TAD ENVIR-1 /GET RELOCATION POINTER JMS I .+12 /CHANGE TO NON-INTERRUPT I/O .+1-MV2 RELOC XI33+2 /XI33, 0 / KSF /ANY INPUT? JMP .-1 /WAIT UNTIL THERE IS JMS KCHK TAD INBUF /HERE IT IS DCA XOUTL KCC DCA INBUF /CLEAR INPUT FLAG TAD XOUTL JMP I XI33 XOUTL, MOVE TLS /THIS IS ALL WE NEED! 7600 /'CLA' = MONITOR EXIT JMS KCHK /CHECK FOR INPUT TSF /BUFFER FULL? JMP .-1 JMP I XOUTL BYEBYE, CDI /RETURN TO OS/8 JMP I XOUTL+2 /OR TO BATCH... "P-"C POPX, JMS KCHK /CHECK INPUT AFTER A 'POPJ' JMP I .+1 XPOPJ "C&277 KCHK, POPX /KEYBOARD CHECK KSF JMP I KCHK /NOTHING WAITING KRS AND P177 SNA JMP I KCHK /IGNORE NULLS TAD M20 SNA /CTRL P? JMP M20+2 TAD POPX-1 SNA /CTRL C? JMP BYEBYE TAD KCHK-1 /SET PARITY DCA INBUF /SAVE THE INPUT JMP I KCHK RELOC MV2, TAD .-20 /PATCH 'POPJ' DCA I (POPJ&177 TAD .-21 /MOVE 'KSF' DCA I ENVIR-1 /INTO PLACE / DISABLE ALL THE 'IONS' DCA I [ERROR+1 DCA I (4333 /FRA CDF L DCA GOSW-1 DCA I (247 /SINPUT DCA I (OECHO-1 DCA I (ICHAR1-1 TAD MV3-5 /NOP DCA I (TAB+10 DCA I (IOWATE+2 / CHECK FOR BATCH TAD I ENVIR-2 /IS BATCH RUNNING? RAL SMA CLA JMP VIDEO /NO, CHECK SCOPE MODE TAD I ENVIR-2 AND .+16 /GET THE BATCH FIELD TAD .+16 /ADD 'CIF' DCA .+15 /SET UP THE INSTRUCTION TAD ENVIR-1 /CHANGE TTY TO BATCH I/O JMS I ENVIR+20 /=MOVE .+1-MV3 RELOC XI33+2 /XI33, 0 / CIF BF /CHANGE TO THE BATCH FIELD JMS I BATIN /READ FROM THE BATCH STREAM ERROR2 /NOTHING LEFT! TAD XOUTL-1 /CAST OUT LINEFEEDS SNA JMP XI33+1 TAD CLF JMP I XI33 -LF XOUTL, 70 /OUTPUT TO THE BATCH LOG CIF /'PATCHED FOR BATCH' 7000 /'NOP' = BATCH EXIT JMS I BATOUT JMP I XOUTL BATIN, 5400 BATOUT, 7400 RELOC MEMSIZ= CDI T V /SELECT THE HIGHEST FIELD MV3, TAD .-6 /MOVE THE 'CDI' INSTR DCA I ENVIR-1 /TO 'XI33+1' TAD .-10 /AND THEN TO 'BYEBYE' DCA I (BYEBYE /TO CATCH CTRL/C'S TAD MV2-4 DCA I (BATXIT /FIX UP THE ERROR ROUTINE TAD .-14 TAD (-MEMSIZ /CHECK MEMORY SIZE SPA SNA CLA ERROR1 /NOT ENOUGH MEMORY! VIDEO, CDF 10 TAD I (17726 /DO WE HAVE A VIDEO TERMINAL? AND [200 SNA CLA JMP .+6 /NO, LEAVE RUBOUT ALONE TAD (TAD START DCA I (RUB1+3 TAD (ECHOC /YES, USE 'BS', 'SP', 'BS' DCA I (RUB1+4 SKP DCA I (MODLN /REMOVE LINENO PRINTOUT CDF L JMP I ENVIR PAGE / FILE CLOSING AND OUTPUT ROUTINES PAGE 27 /'JMP I 0' CLOSER, 0 /CLOSE OR REMOVE THE FILE DCA TEMP /SET THE 'CALL' FLAG TAD OUTFLG /IS THERE AN OPEN FILE? SNA CLA JMP I CLOSER /NO, IGNORE THE COMMAND TAD O2 /WHICH COMMAND? SNA CLA JMP REMOVE /'ABORT' TAD [232 /'CLOSE' JMS NOCHAR /INSERT A 'CTRL/Z' GETSIZ, SNL SMA /POINTS TO 'MGETA' JMP .-2 /AND PAD WITH ZEROS ISZ TEMP /CHECK CALLING FLAG JMP NOSIZE REMOVE, JMS I GETSIZ /GET THE CLOSING LENGTH, IF ANY STL /ONLY 'O A' & 'O C' HAVE SIZES TAD OLNGTH /COMPARE WITH THAT AVAILABLE SNL SZA CLA ERROR1 /BETTER LUCK NEXT TIME TAD I [LORD /GET THE SIZE BACK SZA /ZERO MEANS 'AS IS' DCA BLKCNT /ENTRY POINT FOR OVERFLOW ERROR NOSIZE, CDF P /RESTORE OUTPUT TO THE ECHO DEVICE TAD I [ECODEV DCA I [OUTDEV /THE USR MUST NOT BE IN CORE! JMS I IOWAIT /WAIT FOR TELETYPE (RESETS DF) JMS I [SETDHT /SET THE ENTRY POINT FOR 'CLOSE' FILDEV-1 / POINTER TO DEVICE # AND ENTRY CIF 10 TAD FILDEV /SAVED DEVICE NO. JMS I USR 4 ONMTMP /FILE NAME POINTER BLKCNT, 0 /CURRENT FILE LENGTH OLNGTH, 0 /MAXIMUM " " TAD OUTFLG SNA CLA ERROR1 /FILE WAS TOO LONG DCA OUTFLG /CLEAR THE 'FILE OPEN' FLAG JMP I CLOSER /ALSO CALLED BY 'SAVE' & 'DELETE' ABORT, DCA O2 /'OUTPUT ABORT' COMMAND DCA BLKCNT CLOSE, SM1 /'OUTPUT CLOSE' COMMAND JMS CLOSER /L=1 JMP EXIT /SIMPLE - ONCE YOU KNOW HOW! NOCHAR, 0 /OS/8 3/2 BUFFERED CHARACTER OUTPUT AND (377 /MASK OUT GARBAGE ISZ O2 /WHICH CHAR OF THREE? JMP O1 /STRAIGHT PACKING JMS O2 /HALF WORD PACKING - PACK 1ST HALF TAD O3 /GET SAVED ARG JMS O2 /PACK SECOND HALF SM3 /RESET 3-WAY SWITCH DCA O2 /BUFFER CAN ONLY BE FILLED WITH ISZ OUTFLG /THE 3RD CHARACTER OF 3 JMP O1+2 /NOT FULL YET TAD OLNGTH /CHECK THE FILE SIZE TAD BLKCNT /AMOUNT USED SO FAR SNL CLA /HAVE WE GONE TOO FAR? JMP NOSIZE-1 /YES, DELETE THE FILE I0F JMS I OUTHND /WRITE ONE BLOCK BUFFER 4200 1600 /5200 PATCHED BY PLOT OBLK, 0 JMP I [DERR /DEVICE ERROR ISZ OBLK /BUMP OUTPUT BLOCK ISZ BLKCNT /AND COUNT OF BLOCKS SO FAR JMS O3 /RESET POINTERS FOR NEXT BUFFER JMP I NOCHAR /L=1 O1, DCA I OPTR1 /NORMAL PACKING IS EASY! ISZ OPTR1 /BUMP POINTER CLL JMP I NOCHAR /L=0 O2, 0 /HALF-WORD PACK ROUTINE CLL RTL RTL DCA O3 /SAVE FOR SECOND HALF TAD O3 AND [7400 TAD I OPTR2 /ADD IN CHARACTER IN RIGHT HALF DCA I OPTR2 /PACK IT ISZ OPTR2 /BUMP POINTER AGAIN JMP I O2 O3, 0 /RESET THE OUTPUT POINTERS SM3 DCA O2 TAD OBLK-1 DCA OPTR1 TAD OPTR1 DCA OPTR2 TAD [-200 /X3 = 384 CHARACTERS/BUFFER DCA OUTFLG JMP I O3 /'SM3' SETS THE LINK OPTR1, 0 /PACKING POINTERS OPTR2, 0 JMS NOCHAR /'OUTPUT BUFFER' COMMAND DUMPER, TAD OUTFLG /DUMPS THE OUTPUT BUFFER SNL SZA CLA /L=0 INITIALLY JMP DUMPER-1 JMP EXIT /PAD WITH ZEROS AND EXIT ILNGTH XLEN, TAD OLNGTH /FUNCTION TO CHECK FILE LENGTH TAD BLKCNT /(MINUS THE AMOUNT USED SO FAR) CIA SKP TAD I XLEN-1 /FUNCTION TO CHECK INPUT SIZE CDI P JMP I .+1 FL0AT /THIS IS THE 'OPEN OUTPUT' COMMAND: TTYOUT OUTPUT, STL CMA /SET ECHO FLAG AND CALL=3 JMS I [OPEN /CALL USR, HANDLER; ENTER FILE OUTBLK-1 /OUTPUT HANDLER BLOCK ERROR0 /ENTER ERROR: CLOSE FILE & RETRY? JMP I OUTPUT-1 /'OPEN OUTPUT TTY:' (OR JUST 'O O') TAD FLNGTH /MAXIMUM ALLOWABLE LENGTH CIA DCA OLNGTH TAD STBLK /STARTING BLOCK DCA OBLK JMS O3 /SET UP PACKING POINTERS DCA BLKCNT LPUSHF /SAVE THE FILE NAME FOR CLOSING NAMLOC LPOPF ONMTMP-1 /CODE SPILLS ACROSS THE PAGE *FLOUTP-1 /FUDGE TO SAVE A WORD OR TWO JMP ORST BLKNO, 0 ILNGTH, 0 ORST, TAD OUTFLG /'OPEN RESTORE OUTPUT' COMMAND SNA CLA /FLAG IS CHARACTER COUNT ERROR0 /NO OUTPUT FILE TO RESTORE TAD OFFSET /POINTER TO FILE OUTPUT ROUTINE TTYOUT, TAD [XOUTL /SWITCH OUTPUT TO THE TELETYPE CDF P /ENTRY POINT FOR INTERNAL HANDLERS DCA I [OUTDEV ISZ GOSW /SKIP IF NO ECHO TAD OCHAR0+2 /'TAD ENDCHK' DCA OECHO /SET OUTPUT ROUTINE JMP EXIT /FINISH THE LINE TTYP, XI33 /TTY INPUT INDEV /THE 'OPEN' AND 'RESTORE' COMMANDS AND FILE INPUT/OUTPUT SCANER OCMND, JMS I .-1 /'O' COMMAND ENTRY - SKIP TO NEXT TAD DOTDA DCA EXTENSION /SET '.DA' CMA DCA GOSW /INITIALIZE THE ECHO SWITCH LJUMP /GO DO COMMAND FILIST-1 FILEGO-FILIST ERROR1 /OOPS - BAD 'O' COMMAND RESTOR, CDF P /'O R' COMMANDS - GET NEXT LETTER TAD I XCHAR DCA TEMP /SAVE COMMAND LETTER GTNAME /CHECK FOR ECHO AND LINE NUMBER TAD TEMP DCA CHAR LJUMP /SORT OUT "I", "O", OR "R" ORLIST-1 ORGO-ORLIST ERROR1 /BAD 'RESTORE' COMMAND DOTDA, 401 /WAS 604 FOR '.FD' /THE 'OPEN INPUT' COMMAND: INPUT, CLL CMA /INITIALIZE ECHO AND SET 'CALL'=2 JMS I [OPEN /CALL THAT AMAZING INBLK-1 /GENERAL-PURPOSE SUBROUTINE ERROR0 /WHOOPS - FILE NOT FOUND JMP TTYIN /'OPEN INPUT TTY:' (OR JUST 'O I') TAD FLNGTH DCA ILNGTH /FOR 'FLEN' AND 'FRA' TAD STBLK DCA BLKNO RERD, TAD BLKNO /'OPEN RE READ' COMMAND DCA IBLK /FIRST BLOCK NO. SM1 /RESET FILE POINTERS DCA INFLG /CHARACTER COUNTER IRST, TAD INFLG /'OPEN RESTORE INPUT' COMMAND SNA CLA /CHECK CHARACTER COUNT ERROR0 /NO INPUT FILE TO RESTORE JMP I [CR /SET POINTER TO 'ICHAR0' (12K) TAD OFFSET /=ICHAR-XI33 TTYIN, TAD TTYP /'OPEN INPUT TTY:' CDF P DCA I TTYP+1 /= 'INDEV' ISZ GOSW /CHECK ECHO MODE TAD IRST+2 /= 'PRINTC' DCA I ECHOP JMP EXIT /RETURN /OFFSET,OCHAR-XOUTL /8K CONSTANT OCHAR0, 0 /FILE OUTPUT VIA 'PRINTC' DCA ENDCHK /SAVE CHARACTER FOR ECHO TAD ENDCHK JMS I FILOUT /WRITE IT I0N OECHO, TAD ENDCHK /=0000 IF NO ECHO SNA ISZ OCHAR0 /SET NO ECHO RETURN CDI P JMP I OCHAR0 FILOUT, NOCHAR RDPTR, 0 /THIS IS A COROUTINE ! JMS ENDCHK /ISN'T THAT AMAZING ? INFLG, 0 ICHAR0, ISZ INFLG /DO WE NEED ANOTHER BUFFER? JMP I RDPTR /NO, UNPACK THE CHARACTER I0F JMS I INHND /YES, GO GET IT 0200 3200 IBLK, 0 SMA CLA /ONLY BOTHER WITH FATAL ERRORS SKP CLA JMP I [DERR /WE'VE GOT ONE TAD [-600 /=384 CHARACTERS/BUFFER DCA INFLG ISZ IBLK /BUMP TO NEXT BLOCK TAD IBLK-1 /AND RESTORE POINTERS DCA IPNTR I0N ICHAR1, TAD I IPNTR /STRAIGHT-FORWARD UNPACK ROUTINE JMS RDPTR /DO COMMON STUFF TAD I IPNTR /SAVE LEFT HALF FOR LATER AND [7400 DCA I IBLK-1 ISZ IPNTR /INCREMENT TO NEXT WORD TAD I IPNTR /ANOTHER EASY ONE JMS RDPTR TAD I IPNTR /THIS IS THE TRICKY ONE! ISZ IPNTR /GET LOW-ORDER HALF AND [7400 CLL RTR /SHIFT RIGHT RTR TAD I IBLK-1 /GET HIGH-ORDER HALF (REMEMBER?) RTR /SHIFT SOME MORE RTR JMS RDPTR /GOT IT! JMP ICHAR1 /1-2-3-1-2-3-1-2-3 ... IPNTR, 0 ECHOP, IECHO /PROCESS THE CHARACTERS FROM EITHER INPUT FILE: ENDCHK, 0 /CALLED BY 'RDPTR' AND 'SEND' AND K177 /IGNORE PARITY SZA /NULL? JMP .+4 /NO ISZ ENDCHK /YES, TAKE THE 2ND EXIT AND JMP I ENDCHK /RETURN TO THE INPUT ROUTINE -32 TAD .-1 /END OF FILE? (^Z) SZA JMP .+5 /NO DCA I ENDCHK /YES, CLEAR 'FILE OPEN' FLAG CDF P /AND SET UP A CLEVER RETURN TAD [EOF /TO RESTORE THE KEYBOARD FOR DCA I TTYP+1 /INPUT AND FLAG THE ERROR AT TAD [232 /THE SAME TIME! THIS -ALSO- CDI P /REMOVES THE ^Z SO YOU DON'T JMP ICHAR+3 /GET A SECOND ERROR MESSAGE! *CDF L PLTDEV, XOUTL; ZBLOCK 2 /COULD BE USEFUL! /TABULATE ROUTINES: CALLED FROM THE UPPER FIELD CR-SP TAB, CDI P /'PRINTC' TAB COUNTER SNA /TEST FOR CR DCA I [ERROR /RESET COUNTER SNA JMP CROUT TAD TAB-1 /CR-SP SMA /NON-PRINTING CHARACTERS ISZ I [ERROR /ADD 1 TO TAB COUNT (FIELD 1) I0N /TURN ON AFTER AN ERROR TAD [SP JMP CROUT+3 ZER, TASK SMA CLA /INITIAL ENTRY POINT JMP POS TAD I XCHAR /SAVE THE CURRENT CHARACTER DCA CHAR NEG, CDI P JMP SKPX /SKIP OVER ONE (OR MORE) ISZ I [LORD JMP NEG TAD CHAR DCA I XCHAR /RESTORE THE ORIGINAL ONE POS, CDI P TAD I [LORD /FIND OUT WHERE WE'RE GOING STL CIA TAD I [ERROR /SUBTRACT FROM WHERE WE ARE SNL CLA JMP I ZER /FORGET IT... TAD [SP JMS CPRNT /PRINT SPACES JMP POS *RMF 0 /'PRINTC' FOR LISTING AND DATE CDI P JMS CPRNT JMP I RMF /LOAD A HANDLER INTO THE PROPER SLOT: (ENTRY AT 'HANDLR') NOTEQ, ISZ SLOT /BUMP POINTER TO SAVE NAME TAD NEWDEV /MOVE NEW DEVICE NAME TO TABLE DCA I SLOT ISZ SLOT TAD NEWDEV+1 DCA I SLOT ISZ SLOT GETMON /NEED USR, MIGHT AS WELL LOCK IT IN RETRY, TAD NEWDEV /MOVE DEVICE NAME FOR MONITOR CALL DCA DEVC TAD NEWDEV+1 DCA DEVC+1 TAD I SLOT /MOVE LOAD POINT DCA DLOAD CIF 10 JMS I USR /CALL MONITOR (ALREADY IN CORE) 1 DEVC, 0 0 /DEVICE NO. DLOAD, 0 /ENTRY POINT ERROR0 /DEVICE NOT AVAILABLE TAD DLOAD /CHECK IF THE HANDLER HAS BEEN AND [7600 /LOADED INTO THE PROPER PAGE CMA /'CIA' FOR 1-PAGE HANDLERS TAD I SLOT /DESIRED PAGE SZA CLA TAD DLOAD /WRONG PAGE! TAD [200 /IS IT THE SYSTEM HANDLER? SPA CLA /IF .GT. 7600 WE'RE OK JMP NOGOOD /SORRY, TRY IT AGAIN ISZ SLOT /BUMP POINTER TO DEVICE # TAD DEVC+1 /SAVE IT DCA I SLOT ISZ SLOT /MOVE TO ENTRY POINT TAD DLOAD DCA I SLOT /SAVE ENTRY TAD DEVC+1 HANDX, DCA TEMP /DEVICE NO. JMP I HANDLR NOGOOD, DCA DLOAD /CLEAR ENTRY POINT JMS SETDHT /TELL USR THE HANDLER DLOAD-2 /IS NOT IN CORE ANYMORE JMP RETRY /LOAD IT THIS TIME *ECODEV HANDLR, 0 /AC = BLOCK POINTER DCA SLOT SM2 /IF THE HANDLER HAS THE SAME NAME, COMPARE /DON'T LOAD IT AGAIN SLOT, 0 NEWDEV-1 JMP NOTEQ /DIFFERENT NAMES, LOAD NEW HANDLER ISZ AUTO 2 /BUMP PAST LOAD POINT TAD AUTO 2 /(SET BY 'COMPARE') DCA .+2 JMS SETDHT /IN CASE USR RESET THE TABLE 0 TAD I AUTO 2 JMP HANDX /SAVE THE DEVICE NO. TTYDEV, DEVICE TTY /FOR COMPARISON PURPOSES *EOF SETDHT, 0 /SET THE DEVICE HANDLER TABLE TAD I SETDHT / (TO FAKE OUT THE USR) DCA PDLXR /POINTER TO DEVICE # AND ENTRY TAD (17646 /TABLE LOCATION TAD I PDLXR /PLUS DEVICE NUMBER DCA DEVC /POINTS TO 'HANDLER-IN-CORE' FLAG TAD I PDLXR CDF 10 DCA I DEVC /FLAG IS SIMPLY HANDLER ENTRY CDF L ISZ SETDHT JMP I SETDHT /ALSO CALLED BY 'CLOSER' /CHARACTER TABLE FOR LOWER-FIELD COMMANDS: KOMLST, CR-200 /RETURN ";-200 /DITTO "Z /ZERO "N /NAME "G /GOSUB "P /P??? FILIST, "L /LIST "A /ALL OR ABORT "C /CALL OR CLOSE "D /DATE OR DELETE "B /BR. OR BUFFER "E /EXIT OR EVERY ORLIST, "S /SAVE OR SECOND "R /RUN OR RESTORE "I /INPUT OR INITIAL "O /OUTPUT OR ONLY PAGE 32 /LIBRARY COMMANDS: SAVER, DELETR, CALLER, RUNNER, GOSUB *FPNT /ENTER VIA 'JMP I 7' LCMND, JMS SCANER /SAVE CHAR AND MOVE TO THE NEXT TAD (603 /SET '.FC' DCA EXTENSION DCA GOSW /POINT TO 'PROC' LJUMP /BRANCH TO THE APPROPRIATE ROUTINE KOMLST-1 KOMGO-KOMLST ERROR1 /SORRY, TRY AGAIN SCANER, (CALL /COMMAND WORD SCANNER CDI P TAD I XCHAR /SAVE CURRENT CHARACTER DCA CHAR JMS LSORT /SCAN TO THE END JMP I SCANER SAVER, GTNAME /'LIBRARY SAVE' COMMAND JMS TEMP /FILL IN THE HEADER JMS SAVE /DO IT JMP EXIT /DONE DELETR, JMS I CL0SE /'LIBRARY DELETE' COMMAND GTNAME TAD LBUFR /'LIBBLK-1' GETHND JMS LCLOSE JMP EXIT-2 LCLOSE, (OPENUP /SAVE OR DELETE A FILE DCA SAVBLK TAD DEVNO CIF 10 JMS I USR 4 NAMLOC SAVBLK, (20 ERROR0 /NOT THERE JMP I LCLOSE FOCLTM, FILENAME FOCAL.TM GOSUB, LPUSHF /'LIBRARY GOSUB' COMMAND FOCLTM LPOPF /MOVE 'FOCAL.TM' TO NAME AREA NAMLOC-1 TAD DSK /IN CASE WE NEED TO SAVE IT DCA NEWDEV DCA NEWDEV+1 TAD LIBFLG /ARE WE ALREADY SAVED? SNA CLA JMS SAVE /NO TAD (603 DCA EXTENSION /RESET EXTENSION TO 'FC' /LOOKUP AND LOAD ROUTINES: SUBBER, SM3 /THESE ALL DO THE SAME THING AND RUNNER, CLL IAC /THEN BRANCH TO DIFFERENT PLACES CALLER, CLL IAC /LOAD HAS 5 POSSIBLE EXITS ! JMS I [OPEN /CALL THE HANDLER AND LOCATE FILE LBUFR, LIBBLK-1 /= 'BUFR' TOO LIB3, 3 /NOT THERE, NO NAME, OR ERROR1 /SOMETHING JUST AS STUPID JMS I (DEVCHK /FILE STRUCTURED? TAD GOSW /CHECK FOR GOSUB SPA CLA LPUSHF /SAVE CURRENT PROGRAM INFO. LIBDEV JMP LOADGO /'JMP I (LCHECK+2' FOR 8K GOBACK, LPOPF /RESTORE CALLING PROGRAM POINTERS NEWDEV-1 TAD LBUFR GETHND /GET THE HANDLER BACK LOADGO, JMS LOADER /READ THE PROGRAM CDF T /'CDI T' FOR INITIAL DIALOG TAD I D /CHECK PROGRAM I.D. SZA CLA / JMP I D /ENTER SPECIAL PROGRAM INITIAL,ERROR1 /(NONE RIGHT NOW) TAD I [200 /MOVE PROGRAM LENGTH CDF P DCA I LBUFR CDI L /RETURN TO: JMP EXIT-1 /PROC, START, GOTO, OR DO SAVE, 0 /CALLED BY 'SAVER' AND 'GOSUB' JMS I CL0SE /AVOID TROUBLE CDF P TAD I LBUFR /GET PROGRAM LENGTH CDF T DCA I [200 /SAVE IT WITH THE PROGRAM LSHFT, SM1 TAD I [200 /COMPUTE FILE SIZE CDF L AND [7600 /MASK PAGE COUNT JMS I LSHFT /SHIFT IT IAC /ROUND UP TO BLOCKS CLL RAR DCA FLNGTH /SAVE GETMON /CALL THE MONITOR TAD LBUFR GETHND /GET THE HANDLER JMS I (DEVCHK /CHECK FOR STUPIDITY TAD LIB3 DCA I (CALL /SET UP OUR SUBROUTINE JMS I (OPENUP ERROR1 /NO ROOM OR WRITE-LOCKED TAD FLNGTH JMS LCLOSE /UPDATE DIRECTORY IN ADVANCE! TAD (20 /SET THE 'WRITE' BIT JMS LOADER /SAVE THE PROGRAM JMP I SAVE ///// LOADER, 0 /READ (OR WRITE) A PROGRAM TAD FLNGTH /COMPUTE FUNCTION WORD JMS I LSHFT /'SHFTL6' STL RAL /SET TO SEARCH FORWARD IFNZRO T < TAD (T > /ADD FIELD BITS (12K) DCA .+4 TAD STBLK DCA .+4 JMS I LIBHND /GET THE PROGRAM 0 200 /LOADS FROM 200 UP 0 /STARTING BLOCK NO. JMP I [DERR DISMISS /SO WE CAN USE THE STACK LPUSHF NEWDEV /SAVE NEW POINTERS LPOPF LIBDEV-1 /IN CASE WE 'GOSUB' JMP I LOADER PAGE /THE 'OUTPUT DATE' COMMAND DATER, TAD [NODATE-1 DCA AUTO TAD [-4 DCA GOSW CDF T TAD I AUTO /GET DATE JMS I ZEROER-1 /OUTPUT IT ISZ GOSW JMP .-4 JMP EXIT /RETURN ///// DEVCHK, 0 /CHECK THE DEVICE TYPE TAD DEVNO TAD P17757 DCA JUMPER CDF 10 TAD I JUMPER CDF L SMA CLA ERROR1 /DEVICE IS NOT FILE STRUCTURED JMP I DEVCHK P17757, 17757 /DEVICE CONTROL WORD TABLE ///// JUMPER, 0 /SORT AND BRANCH SUBROUTINE JMS I IOWAIT /CLEAR AC, RESET DF, TURN IOF TAD I JUMPER /GET LIST ADDRESS ISZ JUMPER DCA AUTO TAD I AUTO SPA /END OF LIST ? JMP ERR STL CIA TAD CHAR SZA CLA /FOUND IT ? JMP .-6 /NO TAD AUTO TAD I JUMPER /ADD OFFSET DCA JUMPER TAD I JUMPER /POINT TO ENTRY DCA JUMPER ERR, CLA CLL /FALL THROUGH OFFSET JMP I JUMPER /L=0 ///// /LIBRARY COMMAND LIST: KOMGO, GOBACK /CR GOBACK /; ZEROER /Z NAMER /N GOSUB /G SCANER-1 /P LLIST /L LISTAL /A CALLER /C DELETR /D BRANCH /B 7600 /E SAVER /S RUNNER /R INITIAL /I /FILE COMMAND LIST FILEGO, LIST1 /O,L ABORT /A CLOSE /C DATER /D DUMPER /B ECOSET /E SINPUT /S RESTOR /R INPUT /I OUTPUT /O /RESTORE COMMAND LIST ORGO, SRST /S RERD /R IRST /I ORST /O /THE 'LOGICAL BRANCH' COMMAND ALLOWS PROGRAMS TO TEST THE /TELETYPE WITHOUT READING A CHARACTER. THE BRANCH OCCURS /IF THERE IS -NO- INPUT: 1.1 T PI;L B .1;C A KEY WAS HIT /'FIN()' MAY THEN BE USED TO READ AND TEST THE CHARACTER. /THIS HAS NOW BEEN REPLACED BY THE 'JUMP' COMMAND (V4D). BRANCH, CDI P /'LOGICAL BRANCH' COMMAND I0N JMP I .+1 /USES THE 'JUMP' COMMAND! PACLST+3 ///// ONMTMP, ZBLOCK 4 /SAVED FILE NAME /THE 'OUTPUT EVERYTHING' COMMAND SWITCHES TO A DIFFERENT /INTERNAL HANDLER FOR ALL OUTPUT, INCLUDING THE ECHO AND /ERRORS; THIS DEVICE IS RESTORED FOLLOWING AN 'O C' OR /'O A' COMMAND. THE HANDLER MAY ALSO BE CALLED BY 'O O' ECOSET, GTNAME /THE 'O E' COMMAND JMS I INTCHK /WAS IT 'O E LPT:'? TAD [XOUTL /NO, EVERYTHING ELSE = 'TTY:' JMP OSCOPE+1 /SAVE ENTRY POINT ZBLOCK 1 /PATCHED BY LAB OVERLAY OSCOPE, TAD .-1 /THE 'O S' COMMAND CDF P DCA I [ECODEV /AFFECTS BOTH 'OCHAR' AND 'EOF' TAD I [ECODEV JMP I .+1 /INSERT ENTRY PT. INTO 'OUTDEV' TTYOUT+1 ///// INTCHK, LPTCHK /CHECK FOR INTERNAL HANDLERS INTRNL+1 /RETURN POINT JMS I INTCHK /CHECK FOR 'LPT:' SKP /TRY AGAIN JMP I INTCHK-1 /PUT ENTRY POINT INTO 'OUTDEV' SM2 COMPARE /CHECK FOR 'PLTR' PLTDEV NEWDEV-1 JMP I INTCHK+1 /NEITHER OF THESE TAD I .-3 JMP I INTCHK-1 /MOVE THE ENTRY POINT ////// LZERO, HANDLR-3 /THE 'LIBRARY ZERO' COMMAND SM1 /DANGEROUS - BUT USEFUL! DCA I FILCNT /RESET THE FILE COUNT DCA I [HANDLR-2 /CLEAR THE LINK WORD DCA I AUTO /CREATE AN 'EMPTY' WITH TAD FLNGTH / THE SPECIFIED LENGTH SNA /IF NO LENGTH, PROBABLY ERROR1 /DIDN'T WANT TO DO THIS! LZXIT, CIA TAD I LZERO /SUBTRACT SYSTEM BLOCKS DCA I AUTO JMS I LIBHND /PUT IT BACK 4200 FILCNT, HANDLR-4 1 JMP I [DERR /OH DEAR! JMP I LZXIT /RESTORE THINGS AND EXIT ///// /THE 'LIBRARY LIST' COMMAND SHOWS ONLY FILES WITH ONE EX- /TENSION. 'LIST ALL' SHOWS EVERYTHING, 'LIST ONLY' JUST 1. LIBBLK-1 LLIST, CMA CLL RTR /'LIBRARY LIST' COMMAND LIST1, CMA STL RAL /'LIST ONLY' / 'ONLY LIST' LISTAL, DCA I [OPEN /'LIST ALL' COMMAND SM3 /CLEAR THE 'L Z' SWITCH ZEROER, DCA 0 /'LIBRARY ZERO' COMMAND DCA GOSW /= NO EMPTIES GTNAME /GET DEVICE TO LIST TAD LLIST-1 GETHND /GET THE HANDLER JMS DEVCHK /CHECK DEVICE TYPE DISMISS /REMOVE THE USR JMS I [7607 /SWAP OUT CORE TO MAKE ROOM 4200 /FOR DIRECTORY HANDLR-4 40 /SYSTEM SCRATCH AREA JMP I [DERR /WHOOPS! DCA I SWAP /SET THE FLAG TO SWAP BACK IN IAC /DIRECTORY BEGINS WITH BLOCK 1 BLOKLP, DCA LBLOCK JMS I LIBHND 0200 HANDLR-4 /POSITIONED FOR OUR CONVENIENCE! LBLOCK, 1 JMP I [DERR TAD [HANDLR /FIRST 5 WORDS ARE INFORMATION DCA AUTO TAD 0 /CHECK FOR 'L Z' SNA CLA JMP I (LZERO+1 /OR 'EMPTY-2' TO DISABLE 'L Z' LOOP2, TAD AUTO /SAVE NAME POINTER FOR PRINTING DCA LIBX TAD I AUTO SNA CLA JMP EMPTY /CHECK IF WE SHOULD LIST EMPTIES ISZ AUTO ISZ AUTO TAD I AUTO /PICK UP EXTENSION DCA LBLOCK TAD I [HANDLR /WASTE WORDS (NEGATIVE) CIA TAD AUTO /SKIP TO LENGTH DCA AUTO TAD I AUTO /ZERO LENGTH MEANS TEMPORARY FILE *CIA SNA /LZERO RETURN JMP LOOP3 /IGNORE SUCH THINGS DCA FLNGTH TAD NAMLOC /WAS A NAME GIVEN ? SNA CLA JMP CKEXTN /NO TAD EXTENSION /CHECK THIS TOO? SNA CLA IAC /NO, ONLY CHECK THE NAME TAD [-4 COMPARE /COMPARE THIS NAME WITH ARG LIBX, AUTO-1 NAMLOC-1 JMP LOOP3 /NON-MATCHING ISZ I [OPEN /TEST FOR ONLY ONE TAD EXTENSION /OR A NULL EXTENSION SZA CLA DCA NAMLOC /DON'T CHECK ANY MORE JMP DIRLST CKEXTN, TAD EXTENSION /DO WE WANT THIS ONE? CIA TAD LBLOCK SZA CLA TAD I [OPEN /TEST FOR 'ALL' SPA CLA JMP LOOP3 /GUESS NOT DIRLST, SM3 /PRINT 3 WORDS DCA TEMP ISZ LIBX TAD I LIBX JMS I DIRLST /PRINT 2 CHARS ISZ TEMP JMP .-4 TAD DOT JMS I PRNTC TAD LBLOCK /PRINT EXTENSION JMS I DIRLST TAD NPRNT+2 /SET UP FOR DECIMAL LENGTH PRINT DCA NEWDEV NLOOP, DCA NEWDEV+1 /INITIALIZE LEADING-ZERO FLAG DCA SHFTL6 /CLEAR QUOTIENT TAD I NEWDEV /FINISHED ALL POWERS OF 10? SNA JMP LOOP3-2 /YES, ALL DONE TAD FLNGTH /NO, ADD THIS POWER SMA SZA /OVERFLOW? JMP DIDJET /YES, PRINT THIS DIGIT DCA FLNGTH /NO, GO THROUGH THE LOOP AGAIN ISZ SHFTL6 /ADD ONE TO THIS DIGIT JMP NLOOP+2 /ANOTHER DIVIDE CYCLE TAD [CR /DONE WITH THIS LINE (WHEW!) JMS I PRNTC LOOP3, ISZ I LBLOCK-1 /DONE WITH THIS BLOCK? JMP LOOP2 /NO, KEEP GOING JMS I IOWAIT /WAIT FOR I/O TAD I [HANDLR-2 /LINK TO NEXT BLOCK SZA /LAST BLOCK? JMP BLOKLP /NO, GET THE NEXT JMS I SWAP /YES, RESTORE SWAPPED CORE JMP EXIT /(JMS RESETS THE FLAG) /MANY THANKS TO STEVE L. GILLETT FOR FIGURING OUT /HOW TO MAKE ROOM FOR THE 'LIST EMPTIES' OPTION!! EMPTY, TAD I AUTO /LIST THE EMPTIES! DCA FLNGTH /GET THE LENGTH TAD GOSW /ARE WE SUPPOSED TO? SMA SZA CLA /',E' TESTED BY 'GTNAME' JMP NLOOP-3 /YES, INDENT SLIGHTLY JMP LOOP3 /FORGET IT DIDJET, CLA CLL /CLEAN UP THE AC ISZ NEWDEV /NEXT POWER OF TEN TAD SHFTL6 /IF THIS DIGIT IS ZERO, AND NO ISZ NEWDEV+1 /OTHER DIGITS HAVE BEEN NON-ZERO, SZA /PRINT A SPACE INSTEAD JMP NPRNT TAD [SP JMS I PRNTC JMP NLOOP NPRNT, TAD ["0 /CHANGE TO ASCII JMS I PRNTC CMA STL /SET ZERO SWITCH JMP NLOOP DECIMAL;*CMA STL /TRICKY, HUH? 1000 100 10 1 OCTAL; *SM1 /MORE TRICKS! SHFTL6, 0 /CLEVER USE TERMINATES TABLE CLL RTL RTL RTL JMP I SHFTL6 /CONSIDER 'BSW' FOR THE 8/E NAMLST, "< /BLOCK ": /DEVICE "( /VARIABLE DATA DOT, ". /EXTENSION "[ /SIZE ", /ECHO PAGE 35 /ROUTINE TO ENTER OR FIND A FILE FOR 'O O', 'O I' & 'LIB' OPEN, 0 /LOOKUP AND ENTER ROUTINE DCA GOSW /SET ECHO/LOAD SWITCH IAC RAL /SET CALL CODE (2 OR 3) DCA CALL GTNAME /GET DEVICE AND FILENAME TAD MDSK /CALLING SEQUENCE: TAD NEWDEV / AC=GOSW, L=1 FOR ENTER SNA / JMS I [OPEN TAD NAMLOC / HANDLER BLOCK (-1) SNA CLA / ERROR RETURN JMP SHUT+1 / 'TTY' RETURN SM2 / REGULAR RETURN COMPAR /CHECK FOR CALLS TO 'TTY:' TTYDEV-1 /'TTY:' IS ALSO THE DEFAULT TLSW, NEWDEV-1 /WHEN NO OTHER NAME IS FOUND JMP I INTRNL /CHECK FOR OTHER INTERNAL DEV. JMP SHUT+1 /'TTY:' INTRNL, INTCHK+2 /'.+1' FOR 8K TAD I OPEN /GET HANDLER BLOCK TO USE GETHND /LOAD THE HANDLER TAD NAMLOC /CHECK FOR A DIRECT ACCESS CALL SHFT, CMA STL RAL /POINTS TO 'SHFTL6' TAD CALL /'NAMLOC'=1, 'CALL'=2 (ONLY) SNA ERROR1 /CANNOT USE '<>' WITH 'OPEN OUTPUT' IAC SNA CLA JMP SHUT-1 /OK: 'STBLK' & 'FLNGTH' ARE SET JMS OPENUP /DO WHAT WE CAME FOR JMP SHUT+2 /ERROR RETURN TAD CALL+2 CIA DCA FLNGTH /SAVE POSITIVE LENGTH ISZ OPEN SHUT, DISMISS /REMOVE THE USR ISZ OPEN ISZ OPEN JMP I OPEN /NORMAL RETURN ///// USRIN, 0 /LOCK THE USR IN CORE - 'GETMON' I0F CIF 10 JMS I USR 10 TAD [200 DCA USR JMP I USRIN OPENUP, 0 /CALLED BY 'SAVE' AND 'OPEN' TAD XNAME DCA CALL+1 /INITIALIZE USR CALL TAD FLNGTH /REQUESTED SIZE FROM 'GTNAME' CLL RTL RTL AND O7760 /SIZE TAD TEMP /DEVICE NO. CIF 10 JMS I USR /'ENTER' OR 'FETCH' CALL, 0 NAMLOC /BECOMES THE BLOCK NO. 0 / AND THE FILE LENGTH O7760, SNL SMA SZA CLA /ERROR RETURN ISZ OPENUP TAD CALL+1 /SAVE STARTING BLOCK DCA STBLK JMP I OPENUP *CLA CLL IAC SWAPIN, NOP /RESTORE CORE AFTER DIRECTORY LIST JMS I [7607 /SYSTEM HANDLER 200 HANDLR-4 40 DERR, ERROR1 /DEVICE ERROR = 'CLA CLL RTL' JMP I SWAPIN USROUT, 0 /REMOVE THE USR - 'DISMISS' SM0 TAD USR /CHECK POINTER TO FIND OUT SMA CLA JMP I USROUT /ALREADY GONE TAD .-2 /RESET THE POINTER DCA USR I0F CIF 10 JMS I [200 11 JMP I USROUT *SP1 IOWATE, 0 /WAIT FOR TELETYPE TO FINISH CDF P I0N TAD I TLSW SZA CLA JMP .-3 I0F CDF L JMP I IOWATE /THEN TURN THE INTERRUPT OFF MDSK, -5723 XFORM, 0 AND K77 SMA SZA TAD [240 AND K77 TAD [240 JMS I PRNTC JMP I XFORM *SM3 NPACK, 0 /STANDARD 6-BIT UNPACK ROUTINE DCA CMPR TAD CMPR JMS I SHFT /'BSW' RAL JMS XFORM TAD CMPR JMS XFORM JMP I NPACK /CALLED BY 'DIRLST' & 'DATER' CMPR, 0 /COMPARE TWO BLOCKS OF ANY LENGTH DCA XFORM /CALLING SEQUENCE: TAD I CMPR / AC= -# OF WORDS ISZ CMPR / COMPARE DCA AUTO 2 / FIRST-1 TAD I CMPR / SECOND-1 ISZ CMPR / RETURN IF NO MATCH DCA AUTO 3 / RETURN IF MATCH TAD I AUTO 2 /COMPARE TWO WORDS CIA TAD I AUTO 3 SZA CLA JMP I CMPR /NO MATCH ISZ XFORM /DONE ? JMP .-6 /NO, CHECK TWO MORE ISZ CMPR /YES, BUMP RETURN POINTER JMP I CMPR ///// PAGE 36 /READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV' NAME, 0 SM1 /POINTER TO 'SHFTL6' DCA AUTO 1 /PERIOD COUNTER DCA MGETA /DIGIT COUNTER TAD DSK DCA NEWDEV DEVNAM, DCA NEWDEV+1 DCA NAMLOC /CLEAR NAME AREA DCA NAMLOC+1 DCA NAMLOC+2 /BUT NOT THE EXTENSION! TAD XNAME DCA STBLK DCA AUTO 2 /CHAR. COUNTER DCA FLNGTH NAMLUP, JMS MGETC /'SM1' SETS L=1 LJUMP /'LJUMP' CLEARS IT NAMLST-1 /TRAP '< : ( . [ ,' NAMGO-NAMLST PLUS10, "9-"0+1 /'NOP' TAD CHAR /CHECK FOR A-Z, 0-9 TAD MINUS9 CLL TAD PLUS10 SZL JMP .+4 /OK TAD K7760 /"0-"@ = -20 STL TAD ("@-"Z-1 SNL CLA JMP NAMEND /ILLEGAL CHARACTER TAD AUTO 2 TAD (-5 K7760, SNL SMA SZA CLA /TOO MANY? JMP IGNORE TAD AUTO 2 CLL RAR TAD STBLK DCA MGETC /NAME POINTER ISZ AUTO 2 TAD CHAR AND K77 SNL JMS I NAME+1 /'SHFTL6' CDF L TAD I MGETC DCA I MGETC NXTNUM, CDF P TAD I PDLXR /MAY BE GARBAGE TAD ["0 DCA CHAR IGNORE, ISZ MGETA TAD MGETA SPA SNA CLA /END OF THE STRING? JMP NAMLUP+1 TAD I XCHAR /YES, IS THERE MORE? TAD MCOMMA CLL SZA CLA /CHECK FOR A COMMA JMP NAMLUP *-"E VARBL, JMS MGETA /PROCESS A VARIABLE FILE NAME CLL CIA DCA CHAR /ASSUME ITS A LETTER TAD I H0RD /NOW CHECK THE SIGN SPA JMP VLETR /IT WAS, USE -1 AS THE COUNT CDI P JMP VFN /CONVERT POS. NUM. TO ASCII BLKNUM, JMS MGETA /READ THE BLOCK NUMBER ISZ NAMLOC /SET THE BLOCK FLAG JMP NAMLUP-3 *-"9-1 COLON, TAD NAMLOC /MOVE NAME TO 'NEWDEV' DCA NEWDEV TAD NAMLOC+1 JMP DEVNAM MGETC, 0 /CROSS-FIELD CALL CDI P JMP LGETC /L=1 TO SKIP 'GETC' DCA CHAR JMP I MGETC *SNL SMA-1 JMP I .+1 /TRY TO FIGURE THIS OUT! MGETA, 0 /EVALUATE AN EXPRESSION JMS MGETC /SKIP THE DELIMITER CDI P JMP GETA /CALL 'EVAL' *-", PERIOD, ISZ AUTO 1 /DOUBLE PERIODS? JMP NAMEND /APPARENTLY DCA EXTENSION /CLEAR OUT THE ASSUMED ONE ISZ STBLK /ADVANCE STORAGE POINTER TAD (4 /ALLOW FOR TWO MORE CHARACTERS JMP NAMLUP-2 NAMGO, BLKNUM /BLOCK MINUS9, COLON /DEVICE MINUSE, VARBL /LETTERS & NUMBERS MCOMMA, PERIOD /EXTENSION SQBRKT /SIZE ECHCHK /ECHO *SMA SZA SQBRKT, JMS MGETA /READ REQUESTED FILE SIZE JMP NAMLUP-1 VFR, DCA PDLXR /SAVE STARTING ADDRESS TAD I (T3 SPA SNA /CHECK DECIMAL EXPONENT CLA IAC /FORCE 1 IF .LE. ZERO STL CIA VLETR, DCA MGETA /EXPONENT=NUMBER OF DIGITS SNL JMP IGNORE /LETTERS JMP NXTNUM /NUMBERS ECHCHK, TAD [SP /REPLACE THE COMMA WITH A SPACE SKP ISZ GOSW /CLEAR THE SWITCH & REMOVE THE 'E' CDF P DCA I XCHAR JMS I (SCANER /SKIP TO THE 'ECHO' OR LINE NO. TAD I XCHAR TAD MINUSE /DOES IT BEGIN WITH AN 'E'? SNA CLA JMP ECHCHK+2 /YES, MARK IT AND CONTINUE NAMEND, CDI P /EVALUATE THE LINE NUMBER JMP GETL JMS I IOWAIT /AND WAIT FOR THE TERMINAL JMP I NAME /***RETURN*** NAMER, GTNAME /'LIBRARY NAME' COMMAND JMP IOWAIT+1 /JUST UPDATES THE HEADER PAGE 37 /PAGE ZERO (FIELD 0) LITERALS: LPUSHF= JMS I [MPUSHF LPOPF= JMS I [MPOPF LJUMP= JMS I [JUMPER COMPAR= JMS I [CMPR GTNAME= JMS I [NAME GETHND= JMS I [HANDLR GETMON= JMS I [USRIN DISMIS= JMS I [USROUT FIELD 0 /READ AND STORE THE OS/8 DATE WORD: FIELD 2 *14 NODATE, TEXT "NO/DA/TE" /BECOMES THE CURRENT DATE *20 NUHEAD, 0 /MOVE THE NAME UP FROM FIELD L TAD I .+2 DCA NUHEAD TEMP TAD .+2 DCA PDLXR NAMLOC-1 TAD .+2 DCA AUTO TITLE-1 SM3 DCA DATUM CDF L TAD I PDLXR CDF T DCA I AUTO ISZ DATUM JMP .-5 DCA I AUTO /CLEAR THE I.D. TAD NODATE+0 /MOVE THE DATE INTO PLACE DCA I AUTO TAD NODATE+1 DCA I AUTO TAD NODATE+2 DCA I AUTO TAD NODATE+3 DCA I AUTO CDI L JMP I NUHEAD DAY, SZA /ZERO = READ CURRENT DATE JMP NIGHT /NON-ZERO = SET NEW DATE TAD I (17666 JMP NIGHT+2 NIGHT, DCA I (17666 JMS DATUM CDI P JMP I .+1 /'FL0ATR' FL0AT PACK1, 0 /HALF-WORD PACK ROUTINE TAD (60 /ADD OFFSET AND (77 ISZ (-1 /TEST THE SWITCH JMP PACK0 CLL RTL RTL RTL DCA PDLXR /SAVE LEFT HALF JMP I PACK1 *0 PACK0, TAD PDLXR /MERGE THE PIECES CDF T DCA I AUTO CDF 10 SM1 DCA (-1 /RESET THE SWITCH JMP I PACK1 *7 600 /EXTENDED DATE MASK ZBLOCK 4 /INDICATE USAGE *104 /LEAVE ROOM FOR 'PC0' PACK2, 0 DCA AUTO 2 /SAVE DIGITS DCA AUTO 1 /CLEAR QUOT. JMP .+3 ISZ AUTO 1 /DIVIDE BY TEN DCA AUTO 2 TAD AUTO 2 TAD (-12 SMA JMP .-5 CLA /CLEAR OVERDRAW TAD AUTO 1 /FIRST DIGIT JMS PACK1 TAD AUTO 2 /SECOND DIGIT JMS PACK1 SM2 /"0"-2="." JMS PACK1 JMP I PACK2 /ROUTINE TO UNPACK THE DATE - USED BY 'FDAY' DATA, 0 /CALLED FROM 'INITLZ' JMS DATUM CDI L JMP I DATA DATUM, 0 /UNPACK THE DATE WORD SM1 DCA (-1 /INITIALIZE TAD (NODATE-1 DCA AUTO CDF 10 TAD I (17666 SNA JMP I DATUM /SKIP NULL DATE RTR AND (77 CLL RAR JMS PACK2 /DAY TAD I (17666 RTL RTL AND K7 RAL JMS PACK2 /MONTH TAD I (17666 AND K7 DCA PDLXR CDF 0 TAD I (7777 /WILL BE -1! K7, AND 7 CLL RTR RTR TAD (106 /1970 TAD PDLXR JMS PACK2 /YEAR JMP I DATUM FIELD 2 $