/ 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: / 8NFIO.PA / FOR PDP8I OR PDP12 WITHOUT EAE / BASED ON 8XFIO.PA NEW NON-EAE EMULATION 2025-10 / BY BILL CATTEY AND CHATGPT /=============================================================== / NON-EAE EMULATION SUPPORT FOR U/W FOCAL 4E / TARGET RANGE: 13200-14177 /--------------------------------------------------------------- / THIS MODULE HOLDS LONGER NON-EAE ROUTINES SO 8NFPP/8NFIO / CAN REMAIN FOOTPRINT-IDENTICAL TO THE ORIGINAL 8X MODULES. / / THE EMULATION IS HERE IN THE FIO MODULE TO STAY COMPATIBLE / WITH THE LEGACY LAYOUT OF U/W FOCAL V4E OF 1978 / AS BEST WE COULD FIND IT. / / CURRENTLY IMPLEMENTED EMULATIONS: / MUY - MULTIPLY (AC × MQ → 24-BIT PRODUCT) / DVI - DIVIDE (MQ:AC ÷ OPERAND → QUOTIENT/REMAINDER) / SWP - SWAP AC ↔ MQ (VIA PAGE-ZERO JUMP TABLE) /--------------------------------------------------------------- / NOTES: / MQL IS REDEFINED INLINE AS "DCA SAVMQ" / ALL OTHER EAE OPS (MQA, MQR, ACL, CAM, SCA, ETC.) / WERE VERIFIED AS UNUSED IN 8XFPP/8XFIO. /=============================================================== / THIS MODULE INCORPORATES TWO LEVELS SELF-TEST LOGIC / / DEFINE "EMTEST=1" IF YOU WANT A POST-HOC / REPEAT EVERY EMULATION WITH THE EAE AND HALT / ON ANY DISCREPENCY. / / THERE IS ALSO A STAND-ALONE TEST MODE. / WHEN 8NFIO IS ASSEMBLED WITHOUT U/W FOCAL, / THE VIRTUAL MQ SAVMQ STORED IN 10010 ISN'T DEFINED. / WE DETECT THAT AND DEFINE TESTME=1. / / TESTME IS A SHORT PROGRAM THAT PERFORMS / TESTS RECORDED IN THE TABLE APTLY NAMED / "TABLE". HERE AGAIN, THE EMULATION AND / THE EAE PERFORM BOTH TESTS AND HALTS / ON ANY DISCREPANCY. /--------------------------------------------------------------- / PAGE-ZERO “INSTRUCTION” VECTORS. APPENDING TO THOSE DEFINED / IN 16KCPR.PA IN SPACE LEFT FOR "FOR SOFTWARE MULTIPLY" /EMTEST=1 / DEFINE IF WE WANT IN-LINE EMULATION TEST. / IF WE HAVE EMTEST, AND ARE INSIDE U/W FOCAL / SAVMQ IS DEFINED. WE NEED TO DEFINE / THE EAE OPS FOR TESTING THEY NORMALLY / DONT GET DEFINED IN NON-EAE U/W FOCAL IFDEF SAVMQ < MUY=7405 DVI=7407 > / TESTME CONTROLS STAND ALONE TESTING / 1 FOR ENABLE / 0 FOR NORMAL IFNDEF SAVMQ < *10 SAVMQ, 0 TESTME=1 IFNDEF EMTEST < EMTEST=1 / WE USE EMTEST STAND ALONE > > IFDEF TESTME < /================================================================ / PAL-8 TEST HARNESS — EAE vs EMULATION (MODE A) / 8 TEST CASES, HALT AFTER EACH SUBTEST / Inspect AC & MQ (hardware) vs AC & SAVMQ (emulation) at each HLT /================================================================ / Combined instructions L0001=CLL CLA IAC L0002=CLL CLA CML RTL L0003=CLL CLA CML IAC RAL L0006=CLL CLA CML IAC RTL L2000=CLL CLA CML RTR /EAE INSTRUCTIONS TO BE EMULATED MUY=7405 DVI=7407 MQL=7421 *0200 / origin for harness (pick a safe page / TABLE OF TESTS: / EMUOP, OPERAND, MQ, AC START, CLA CLL TAD TSTART DCA TABLEP DCA TNUM REP, TAD I TABLEP SNA HLT DCA EMUOP ISZ TABLEP TAD I TABLEP DCA EMUOP+1 ISZ TABLEP TAD I TABLEP DCA SAVMQ ISZ TABLEP TAD I TABLEP EMUOP, 0 0 ISZ TABLEP ISZ TNUM CLA CLL JMP REP TABLEP, 0 TNUM, 0 TSTART, TABLE / EM: OP; MQ; AC. SWP: AC and MQ swap PAGE TABLE, EMMUY; 5; 3; 0 / T0: 3 * 5; AC=0 MQ=17 EMMUY; 12; 0; 3 / T1: 0 * 12 + 3: AC=0 MQ=3 EMMUY; 2; 7777; 0 / T2: 7777 * 2: AC=1 MQ=7776 EMMUY; 7; 6; 0 / T3: 6 * 7: AC=0 MQ=52 EMDVI; 3; 2000; 1 / T4: 12000 / 3: AC=2 MQ=3252 EMDVI; 4; 14; 0 / T5: 14 / 4: AC=2 MQ=3 EMDVI; 400; 0; 2000 /T6: 20000000 / 400:AC=2000;MQ=1;L=1 EMDVI; 4; 12; 0 / T7: 12 / 4: AC=2 MQ=2 EMDVI; 6; 5; 0 / T10: 6 /5: AC=5 MQ=0 SWPMUY; 0; 0; 3146 / T11: 0 * 3146 + 0 = 0 NO ADD SWPMUY; 0; 1000; 3146 / T12: 0 * 3146 + 1000 AC=1147 MQ=1000 SWPMUY; 6316; 4000; 2400 / T13: 6316 * 2400 + 4000 AC=2000 MQ=7000 EMMUY; 0; 0; 3 / T14 0 * 0 + 3 AC=0 MQ=3 EMMUY; 3110; 2400; 0 / T 15 3110 * 2400 AC=766 MQ=0 EMMUY; 6650; 2400; 0 / T 16 6650 * 2400 AC=2104 MQ=4000 SWPMUY; 3000; 4000; 3147 /T 17: 3000 * 3147 + 4000: AC=1147 MQ=1000 SWPMUY; 3000; 1000; 3146 /T 20 3000 * 3146 + 1000 AC=1146 MQ=3000 SWPMUY; 6316; 7000; 2400 / T 21 6316 * 2400 + 7000 AC=2001 MQ=2000 EMDVI; 6000; 0; 2400 /T 22 24000000 / 6000 AC=4000 MQ=3252 EMDVI; 6000; 0; 2200 /T 23 22000000 / 6000 AC=0 MQ=3000 EMDVI; 5000; 0; 0 /T24 0 / 6000 AC=0 MQ=0 ZERO DIVIDEND IS NOT OVERFLOW. 0 / END OF HARNESS > /FLOATING POINT INPUT/OUTPUT ROUTINES: / 8NFIO.PA / FOR PDP8I OR PDP12 WITHOUT EAE / BASED ON 8XFIO.PA NEW NON-EAE EMULATION 2025-09 / BY BILL CATTEY AND CHATGPT /=============================================================== / NON-EAE EMULATION SUPPORT FOR U/W FOCAL 4E / TARGET RANGE: 13200-14177 /--------------------------------------------------------------- / THIS MODULE HOLDS LONGER NON-EAE ROUTINES SO 8NFPP/8NFIO / CAN REMAIN FOOTPRINT-IDENTICAL TO THE ORIGINAL 8X MODULES. / / THE EMULATION IS HERE IN THE FIO MODULE TO STAY COMPATIBLE / WITH THE LEGACY LAYOUT OF U/W FOCAL V4E OF 1978 / AS BEST WE COULD FIND IT. / / CURRENTLY IMPLEMENTED EMULATIONS: / MUY - MULTIPLY (AC × MQ → 24-BIT PRODUCT) / DVI - DIVIDE (MQ:AC ÷ OPERAND → QUOTIENT/REMAINDER) / SWP - SWAP AC ↔ MQ (VIA PAGE-ZERO JUMP TABLE) /--------------------------------------------------------------- / NOTES: / MQL IS REDEFINED INLINE AS "DCA SAVMQ" / ALL OTHER EAE OPS (MQA, MQR, ACL, CAM, SCA, ETC.) / WERE VERIFIED AS UNUSED IN 8XFPP/8XFIO. /=============================================================== /--------------------------------------------------------------- / PAGE-ZERO “INSTRUCTION” VECTORS. APPENDING TO THOSE DEFINED / IN 16KCPR.PA IN SPACE LEFT FOR "FOR SOFTWARE MULTIPLY" IFDEF EMTEST < IFNDEF TESTME < *PRODUCT-2 / EAT 2ND FROM LAST LOC FOR AUTO TEST > IFDEF TESTME < *100 > CMPEAE= JMS I . EAECMP > IFNDEF TESTME < *PRODUCT-1 / EAT LAST PATCH LOC > IFDEF TESTME < *101 > EMSWP= JMS I . / EMULATE EAE SWP SWPEM IFNDEF TESTME < *GINC+1 / CONSUME ALL USER CONSTANTS > EMMUY= JMS I . / EMULATE EAE MUY MUYEM MQLMUY= JMS I . / EMULATE EAE MQL MUY MUYMQL SWPMUY= JMS I . / EMULATE EAE SWP MUY MUYSWP EMDVI= JMS I . / EMULATE EAE DVI DVIEM MQLDVI= JMS I . / EMULATE EAE DVI DVIMQL /--------------------------------------------------------------- /========================================================== / EAE MODE A EMULATORS FOR U/W FOCAL 4E (PAL-8) / 5 ROUTINES: SWPEM, MUYEM, MUYMQL, DVIEM, DVIMQL / TEMP LOCS: EMOP..EMAC / SAVMQ USED AS SOFTWARE MQ /========================================================== IFNDEF TESTME < *14500 > IFDEF TESTME < *700 > / ONE COMBINED INSTRUCTION NOT DEFINED IN UWF L0002=CLL CLA CML RTL L4000=CLL CLA CML RAR L7777=CLL CLA CMA IFNDEF TESTME < *13200 > IFDEF TESTME < *1000 > /--------------------- SWPEM -------------------------------- / SWP EMULATOR (SINGLE WORD ENTRY) / SWP: SWAP AC and SAVMQ SWPEM, 0 DCA RMDPHI / SAVE AC to SWPET1 TAD SAVMQ DCA EMAC / SAVE OLD MQ to SWPET2 TAD RMDPHI DCA SAVMQ / NEW MQ := OLD AC TAD EMAC JMP I SWPEM / RETURN (AC := OLD MQ) MUYSWP, 0 / RELIES ON USE OF EMAC TO DO THE SWAP DCA EMAC / SAVE AC TAD MUYSWP / FIX RETURN ADDRESS DCA MUYEM TAD EMAC / RESTORE AC AND SWAP EMSWP / CALL OUT TO DISTANT EMSWP JMP MUYEM+1 / JUMP INTO MUYEM /============================================================ / MUY EMULATION FAMILY (MODE A) / MUYEM - MUY (PLAIN) : MULTIPLICAND IS SAVMQ (MQ EMULATED) / IF AC NON-ZERO ON ENTRY, ADD IT TO PRODUCT / MUYMQL - MQL + MUY : MULTIPLICAND IS AC (MQL STORES AC IN SAVMQ) / MULTIPLICAND IS IN NEXT WORD AFTER CALL / MUYCORE - COMMON KERNEL : 12-ITER SHIFT/ADD to 24-BIT PRODUCT / RESULTS: AC = HIGH 12 BITS, SAVMQ = LOW 12 BITS / TEMPS: MDCNT, EMOP, EMAC, AND RMDPHI, / ALGORITHM: REUSE SAVMQ AS BOTH MULTIPLIER AND LO RESULT / INITIALIZATION: LINK IS CLEAR; MULTIPLIER IN MQ; / MDCNT -14; MULTIPLICAND IN EMOP; HI PROD IN RMDPHI / IF LSB OF PRODUCT IS 1 ADD EMOP TO SAVMQ / CONSTANTS: NEG14 -14 OCTAL FOR 12 WAY SHIFT /============================================================ /---------------- MUYEM (PLAIN MUY) ------------------------- MUYEM, 0 DCA EMAC / SAVE ORIGINAL AC to EMAC DCA RMDPHI / IN CASE WE DO FAST EXIT TAD MUYEM DCA MUYMQL IFDEF EMTEST < TAD SAVMQ / PRESERVE MQ ACROSS QUICK EXIT MQL > TAD SAVMQ / TEST MULTIPLIER (MQ EMULATED IN SAVMQ) SZA CLA / MUYMQL WILL FETCH SAVMQ WHEN NEEDED. JMP MUYMQL+3 / IF NONZERO MULTIPLICAND, DO FETCH PATH JMP MPEXIT / IF ZERO, ADD TO MQ AND EXIT /---------------- MUYMQL (MQL + MUY) ----------------------- MUYMQL, 0 DCA SAVMQ / MOVE AC to SAVMQ (MQL EFFECT) DCA EMAC / MQL MUY CLEARS AC DCA RMDPHI / PRODUCT HIGH := 0 IFDEF EMTEST < / PRESERVE ORIGINAL SAVMQ TAD SAVMQ MQL > TAD I MUYMQL / FETCH MULTIPLIER (LITERAL) SNA JMP EXMQ0 / FAST EXIT IF MULTIPLIER = 0 DCA EMOP / EMOP := MULTIPLIER NEVER CHANGES TAD NEG14 DCA MDCNT / MDCNT := -14 (COUNT FOR 12 ITERATIONS) MPLOOP, CLL TAD SAVMQ RAR / SHIFT MULTIPLIER RIGHT, LSB to LINK DCA SAVMQ SZL / IF LINK = 1 (LSB WAS 1) DO ADD TAD EMOP CLL / ADD MAY HAVE SIGNIFICANT CARRY TAD RMDPHI RAR / AND ROTATE IT / PROD LO HAS MULTIPLIER RIGHT SHIFTED / PROD HI IS RIGHT SHIFTED / MAYBE WITH MULTIPLICAND ADDED DCA RMDPHI / IF HI SHIFTED A RIGHT BIT / ADD IT TO HI BIT OF SAVMQ SZL L4000 TAD SAVMQ DCA SAVMQ ISZ MDCNT JMP MPLOOP / --- ADD ORIGINAL AC (EMAC) INTO PRODUCT LOW, PROPAGATE CARRY --- MPEXIT, CLA CLL / LINK MIGHT HAVE BEEN SET ON ENTRY. IFDEF EMTEST < TAD I MUYMQL / FAST EXIT NEEDS TO INITIALIZE DCA EMOP / OP FOR TESTING. > TAD EMAC / GET SAVED AC TAD SAVMQ / ADD TO PRODUCT DCA SAVMQ / AND SAVE IT SZL IAC / IF ADDING TO SAVMQ OVERFLOWED TAD RMDPHI / PUT PRODUCT INTO AC ISZ MUYMQL CLL IFDEF EMTEST < CMPEAE > MPRET, JMP I MUYMQL / RETURN TO CALLER (MUYEM OR MUYMQL) EXMQ0, DCA SAVMQ JMP MPEXIT /---------------- TEMP & CONSTS ----------------------------- MDCNT, 0 / COUNTER EMOP, 0 / OPERAND -- MULTIPLIER OR DIVISOR RMDPHI, 0 / PROD HIGH OR DIVIDEND HI EMAC, 0 / SAVE OF AC AT ENTRY MINDIV, 0 / NEGATED DIVISOR NEG14, -14 /============================================================= / DVIEM - MODE A DVI NONRESTORING UNSIGNED DIVIDE / ENTRY: EMDVI, NEXT WORD = DIVISOR LITERAL / INPUT: AC = HIGH 12 BITS OF DIVIDEND / SAVMQ = LOW 12 BITS OF DIVIDEND / OUTPUT: NORMAL: AC = REMAINDER, SAVMQ = QUOTIENT, LINK = 0 / OVERFLOW: AC UNCHANGED, SAVMQ = (SAVMQ LEFT SHIFT 1)+1, LINK=1 /============================================================= / EMULATE COMBINATION OF MQL DVI / WHICH FILLS SAVMQ WITH AC AND CLEARS AC DVIMQL, 0 DCA SAVMQ TAD DVIMQL DCA DVIEM SKP / REGULAR DVI DVIEM, 0 / SAVE DIVIDEND DCA RMDPHI / RMDPHI := AC / FETCH DIVISOR TAD I DVIEM CIA DCA MINDIV IFDEF EMTEST < TAD SAVMQ / PRESERVE ORIGINAL SAVMQ MQL TAD RMDPHI / PRESERVE AC ORIGINALLY CALLED DCA EMAC TAD I DVIEM DCA EMOP > ISZ DVIEM / TEST FOR OVERFLOW: IF AC GREATER OR EQUAL TO EMOP CLL TAD MINDIV TAD RMDPHI / AC = EMOP - RMDPHI SNL CLA JMP DVNORM /---------------- OVERFLOW CASE ------------------------------ DVIOVF, TAD SAVMQ / MQ = (MQ LEFT SHIFT 1) + 1 RAL DCA SAVMQ TAD RMDPHI / RESTORE AC = ORIGINAL HIGH HALF STL / SET LINK IFDEF EMTEST < CMPEAE > JMP I DVIEM / DIVISION ALGORITHM FROM DECUS 8-436 / WITH A BIT MORE OPTIMIZATION /---------------- NORMAL DIVISION ---------------------------- DVNORM, L7777 TAD NEG14 DCA MDCNT / 13 ITERATIONS 15 OCTAL DVIS1, CLA CLL SKP DVIS2, DCA RMDPHI TAD SAVMQ RAL DCA SAVMQ TAD RMDPHI ISZ MDCNT SKP JMP DVDONE RAL DCA RMDPHI TAD RMDPHI TAD MINDIV SNL JMP DVIS1 JMP DVIS2 / COMMIT THE SUBTRACTION DVDONE, CLL IFDEF EMTEST < CMPEAE > JMP I DVIEM IFDEF EMTEST < PAGE / IN-LINE EMULATION TESTING / HALT IF THE EAE ACTION IS DIFFERENT / MQ SET TO PRE EMULATION SAVMQ BY CALLER / FROM THE EMULATED ACTION EAECMP, 0 DCA ACEM / SAVE AC EMULATION RETURN RAR DCA LINKEM / SAVE LINK EMULATION RETURN TAD I EMOPPT / FETCH EMOP (MULTIPLICAND/DIVISOR) DCA EMOPCP TAD I EMACPT / FETCH EMAC (ORIGINAL AC) DCA EMACP MQA / FETCH MQ FROM BEFORE ACTION DCA MQSAVE TAD MULPTR / CALLED FROM MULTIPLY? CIA TAD EAECMP SZA CLA / OR ONE OF THE DIV CALLS L0002 / DVI = MUL + 2 TAD KMUY DCA TESTOP DOTEST, TAD EMOPCP DCA EAEARG TAD MQSAVE MQL TAD EMACP TESTOP, 0 EAEARG, 0 / THE OPERATION TO TEST DCA ACREPL RAR / FIRST TEST THE LINK REPLY TAD LINKEM SZA CLA HLT / LINK DOESN'T MATCH. HALT TAD ACREPL CIA TAD ACEM SZA CLA HLT / AC DOESN'T MATCH HALT MQA / COMPARE EAE MQ WITH EMULATION CIA TAD SAVMQ SZA CLA HLT TAD LINKEM RAL / RESTORE LINK REPLY TAD ACEM / RESTORE AC REPLY JMP I EAECMP / TAKE IT ON HOME! / ARGS TO THE EMULATION / HERE IN ORDER OF PLACEMENT IN THE TEST TABLE / OP, MQ, AC EMOPCP, 0 / COPY OF EMOP FROM EMULATION MQSAVE, 0 / COPY OF PRESERVED MQ BEFORE EMULATION EMACP, 0 / COPY OF EMAC FROM EMULATION / RESULTS TO COMPARE: / AC FROM EMULATION THEN AC FROM EAE / LINK FROM EMULATION THEN LINKL FROM EAE / WE COMPARE SAVEMQ WITH MQ REGISTER. ACEM, 0 / COPY OF AC REPLY FROM EMULATION ACREPL, 0 / AC REPLY FROM EAE LINKEM, 0 / COPY OF LINK REPLY FROM EMULATION LREPL, 0 / LINK REPLY FROM EAE / POINTERS TO STUFF IN THE EMULATION EMOPPT, EMOP EMACPT, EMAC MULPTR, MPRET / WHERE WE WOULD REURN TO IF MPY KMUY, MUY > IFNDEF TESTME < / CODE IMPORTED FROM 8XFIO.PA *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 /"+" to 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 LESS THAN 0 ? STA STL /NO, TAKE D = F-1 TAD T3 /COMPARE DECIMAL EXPONENT SNL SMA SZA / E GREATER THAN 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 LESS THAN AC LESS THAN 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 GREATER THAN F ? JMP FLOUT+2 /YES: USE FLOATING FORMAT TAD T2 / F-D-E (OR 0 IF E GREATER THAN 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 LESS THAN 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 to -3 TAD M5 JMS OUTDG /PRINT SIGN TAD T3 SPA CIA MQLDVI /DIVIDE BY ONE HUNDRED 144 DCA T2 EMSWP /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 MQLDVI /DIVIDE BY TEN 12 DCA T2 EMSWP /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 SWPMUY 0 TAD EX1 DCA SAVMQ /DISCARD FOUR RAL DCA EX1 /INITIALIZE TWO TAD HORD DCA .+3 TAD AC1L /A*E SWPMUY 0 TAD EX1 /ADD TO TWO DCA EX1 TAD LORD DCA .+3 TAD AC1H /B*D SWPMUY 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) EMSWP /AND ADD IN C(AC) DCA CPRNT /SAVE THE MQ TAD OVER SWPMUY /THANKS TO REV. GEOFFREY CHASE 12 /FOR SUGGESTING AN EAE VERSION EMSWP DCA OVER TAD LORD SWPMUY 12 EMSWP DCA LORD TAD HORD SWPMUY 12 EMSWP DCA HORD TAD CPRNT /RESTORE MQ EMSWP /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 to 0, MATCH to CHAR PAGE > /NON-EAE 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 DCA SAVMQ 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 EMSWP 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 MQLMUY 0 DCA SAVMQ /SAVE HIGH ORDER & ERASE SIX TAD LORD /B*F DCA .+3 TAD OVR1 SWPMUY /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 SWPMUY /ADD IN PREVIOUS 0 /PARTIAL PRODUCT TAD SGNTST /SUM HIGH ORDER PARTS DCA SAVMQ /DISCARD FIVE SZL ISZ EX1 /ACCUMULATE CARRIES TAD HORD /A*F DCA .+3 TAD OVR1 SWPMUY 0 TAD EX1 /BUILD UP THREE DCA EX1 TAD OVER /C*D DCA .+3 TAD AC1H SWPMUY 0 TAD EX1 DCA EX1 /ADD TO THREE JMS I MEND /DO 'B*E', 'A*E', AND 'B*D' EMSWP MDONE, DCA OVER /SAVE THREE TAD HORD /A*D DCA .+3 TAD AC1H SWPMUY 0 MDXIT, DCA HORD /SAVE ONE EMSWP DCA LORD /SAVE TWO DVXIT, TAD ABSOLV DCA SAVMQ 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 / EMULATED AS EMMUY / DVI=7407 / EMULATED AS EMDVI / NMI=7411 / NOT EMULATED / SHL=7413 / NOT EMULATED / MQL=7421 / EMULATE AS DCA SAVMQ / SCA=7441 / NOT EMULATED / CAM=7621 / NOT EMULATED /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 EMSWP /AND SUBTRACT FROM DIVIDEND SNL IAC /ADD IN THE PREVIOUS CARRY EMMUY QUOT, 0 EMSWP /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 DCA SAVMQ /LOAD 24 BITS OF THE DIVIDEND TAD HORD EMDVI /CALLED THREE TIMES DVSR, 0 /THE TRIAL DIVISOR STA /SET TO THE MAXIMUM SNL /DIVIDE CHECK? EMSWP /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 $