/ DATAPLAN FOCAL V40.1 / / / / / / / / / /COPYRIGHT (C) 1979,1980 BY DATAPLAN GMBH, LAUDA, BRD / / / / / / / / / / /THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE /AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DATAPLAN GMBH. /DATAPLAN GMBH ASSUMES NO RESPONSIBILITY FOR ANY ERRORS THAT MAY APPEAR /IN THIS DOCUMENT. / /THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER /UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED /(WITH INCLUSION OF DATAPLAN'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH /SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DATAPLAN. / /DATAPLAN GMBH ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY /OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DATAPLAN. / / / / / / / / / / / / XLIST /PSEUDO FLOATING POINT INSTRUCTIONS FIXMRI FGET=0000 FIXMRI FADD=1000 FIXMRI FSUB=2000 FIXMRI FDIV=3000 FIXMRI FMUL=4000 FIXMRI FPOW=5000 FIXMRI FPUT=6000 FNOR=7000 FINT=JMS I 7 FENT=JMS I 7 FEXT=0 FXIT=0 /PERMANENT SYMBOLS FOR PAL8-V9B /PDP8/E-SYMBOLS CAM=7621 SRQ=6003 CINT=6204 SINT=6254 CUF=6264 SUF=6274 /NEW INSTRUCTIONS RIE=6013 /S/CL ERR. INT. (READER) RCR=6015 /CLEAR READER/PUNCH ERROR RSE=6017 /SKIP ERROR READER PIE=6023 /S/CL ERR. INT. (PUNCH) PSK=6025 /SKIP ON READER OR PUNCH FLAG PSE=6027 /SKIP ERROR PUNCH /KE8-E (EAE)-SYMBOLS SWAB=7431 SWBA=7447 SKB=7671 SCA=7441 SCL=7403 MUY=7405 DVI=7407 NMI=7411 SHL=7413 ASR=7415 LSR=7417 ASC=7403 SAM=7457 DAD=7443 DLD=7663 DST=7445 DPIC=7573 DCM=7575 DPSZ=7451 FIXTAB EJECT DPF INTERPRETER XLIST FIELD 1 /MISCELLANEOUS ITEMS *0 ECHO, 1 TABC, 0 /TABCOUNTER SPC, 240 /CONSTANT ATSW, 0 0 0 /FOR OD 0 T=20 /TEXT FIELD NO. P=10 /PROGRAM FIELD NO. L=00 /LIBRARY FIELD NO. V=10 /VARIABLE FIELD NO. FPNT /ADRESS OF FLOATING POINT(LOC*7) /AUTO INDEX REGISTERS AXIN, LINE4 /STORAGE INDEX(LOC*10) XRT, 0 /EXTRA XR XRT2, 0 /EXTRA XR PER, 256 /LET'S HOPE IT IS NOT INDIRECTLY ADRESSED! FLTXR, 0 /XR FOR FLOATING POINT FLTXR2, 0 /EXTRA FOR F.P. MPER, -256 /CONSTANT TEXTP=. /TEXT POINTERS(LOC*17) AXOUT, LINE4 /OUTPUT INDEX XCT, 7777 /UNPACK SWITCH;THESE 4 ARE PUSHED GTEM, 0 /UNPACK STORAGE PC, PC0 /PROGRAM COUNTER THISLN, 0 /LINE POINTER FROM 'FINDLN' THISOP, 0 /CURRENT 'EVAL' OPERATION LASTLN, 0 /BACK POINTER FROM 'FINDLN' DEBGSW, 1 /DEBUG SWITCH;NON ZERO FOR LITERAL PACKST, 0 /RUBOUT PROTECTION PT1, 0 /VARIABLE POINTER LASTV, STVAR /ADRESS OF LAST VARIABLE T1, 0 /TEMP. REGISTER - MAIN T2, 0 /TEMP FOR NEW INSTR. T3, 0 /TEMP. REGISTER FOR OUTPUT INSUB, 0 /0=GETC;#0=READC SUBS, 0 /VARIABLE SUBSCRIPT P177, 177 /STEP MASK;DON'T MOVE;AND P177=37!! *40 /FLOATING POINT EX1, 0 /OPERAND STORAGE AC1H, 0 AC1L, 0 OVER1, 0 FLAC=. /FLOATING ACCUMULATOR EXP, 0 HORD, 0 LORD, 0 OVER2, 0 SIGNF, 0 /FLOATING SIGN MINSKI, ACMINS /NEGATE FLAC SUBROUTINE FISW, 1 /OUTPUT FORMAT 1=FIXED,0=FLOAT INTEGE, FIX /FIX FLAC *54 /VARIABLES - INITIALIZED FOR THE DIALOGUE CELSO=. /ECALL PUSHES THESE FOUR POPFP, CIF CDF P /+ECALL=15 BIT POPJ EFOP, 0 /FUNCTION CODE LASTOP, 0 /LAST OPERATION FOR EVAL SORTCN, 0 /NUMBER IN TABLE FROM SORTC BUFR, LINE4 /NEXT LOC. IN BUFFER=LAST LOC. IN TEXT ADD, 4300 /CHAR. BUF. IN XCTIN, 0000 /PACK SWITCH SPLAT, "\ /OR 210=BS FOR SCOPE INDEV, LOWIN /POINTER TO IN. SUB. CNTR, 0 /DELETE AND FP LIST6=. /INPUT LIST FOR "SFOUND" CVT, 213 /V.T. (^K) 207 /BELL LIST7=. 375 /ALT MODE 233 /ESCAPE 225 /^U P337, 337 /LEFT ARROW CLF, 212 /L.F. LIST3=. /EXCRETION LIST CCR, 215 /LIST BRANCHER DMPSW, HLT /(SEARCH CHAR)-VARIABLE /=0000 FOR TRACE ON P7600, 7600 /ENDS LISTS P77, 77 /DON'T MOVE;AND P77=100!!! /CONSTANTS P13, 13 /USEFUL CONSTANT C200, 200 M77, -77 /EXTEND CODE TEST P17, 17 /BCD MASK P277, 277 /"?" M2, -2 /CONSTANT ERROR2=JMS I . /FIELD 1 ERROR ADRESS ERROR /KEEP IT AT LOC. 107;SAME ADRESS IN USR;VOL!! C260, 260 /ASCII FOR ZERO M5, -5 /PAREN TEST M11, -11 /PAREN TEST P40, 40 FSIZE, 10 DECP, 4 DIGITS, 12 MFLT, -WORDS /=-4 FOR 4-WORD NAGSW, 0001 /4000=ONE;1=ALL;0=GROUP;ALSO PUSHED CHAR, 215 /THE MOST IMPORTANT REGISTER LINENO, 0000 /LINE NUMBER READ BY GETLN GINC, WORDS+2 /=6 FOR 4-WORD-CONSTANT /POINTERS ETC. PAXPNT, PDLXR /POINTER FOR RESET FLARGP, FLARG /DATA ADRESS CFRSX, FLTZER /POINTER TO ZERO DATA & DOUBLE, MULT2 /MULTIPLY FLAC BY 2 FOUTPU, FLOUTP /FLOATING OUTPUT FINPUT, FLINTP /FLOATING INPUT CFRS, LINE0 /ADRESS OF DUMMY LINE END, STVAR /FIRST LOCATION DECALL, ECALL /RECURSIVE EVAL DPART, PARTES /PAREN COMPARE ETC. ENDT, LINE1 WORDS=4 /PDL INSTRUCTIONS POPA=JMS I . /RESTORE AC XPOPA PUSHJ=JMS I . /RECURSIVE SUB. CALL XPUSHJ POPJ=JMP I . /SUB. RETURN XPOPJ PUSHA=JMS I . /SAVE AC XPUSHA PUSHF=JMS I . /SAVE GROUP OF DATA XPUSHF POPF=JMS I . /RESTORE GROUP XPOPF /NEW INSTRUCTIONS: STOCHR=JMS I . CHRSTO /STORE A CHARACTER TSTCHR=JMS I . CHRTST /SKIPS IF CHAR=ARG GETC=JMS I . /UNPACK A CHARACTER UTRA PACKC=JMS I . /PACK A CHARACTER PACBUF SORTJ=JMS I . /SORT AND BRANCH ON AC OR CHAR SORTB SORTC=JMS I . /SORT CHAR XSORTC PRINTC=JMS I . /PRINT AC OR CHAR OUT READC=JMS I . /READ DATA INTO CHAR AND PRINT IT IN PRNTLN=JMS I . /PRINT C(LINENO) XPRNT GETLN=JMS I . /UNPACK AND FORM A LINENUMBER CNUM, XGETLN FINDLN=JMS I . /SEARCH FOR A GIVEN LINE XFIND SPNOR=JMS I . /IGNORE SPACES AND LEADING ZEROS XSPNOR TESTN=JMS I . /PERIOD;OTHER;NUMBER XTESTN TSTLPR=JMS I . /SKIP IF 5.L.SORTCN.L.E.11(I.E. AN L-PAR) LPRTST TSTGRP=JMS I . /SKIP IF G(AC)=G(LINENO) GRPTST TESTC=JMS I . /TERM;NUMBER;FUNCTION;LETTER- AND IGNORE SPACES XTESTC DELETE=JMS I . /REMOVE OLD TEXT LINE XDELETE DRONEP=JMS I . XDRONE /VARIOUS NEW POINTERS ETC. DPC, PCD /PC DTHIS, THISD /THISLN DPT1, PT1D /PT1 DXRT, XRTD /(TAD I XRT) DAXIN, AXIND /(DCA I AXIN) SECRTV, STSECR /FOR SECRET VARIABLES EOL, 0 /END OF LINE SWITCH PDLSTR, PDLEND-1 /START OF PDL /FOCAL'S COMMAND/INPUT DRIVER *177 START, NEW /PROGRAM START FROM SELF (INDIRECT)(OR TO FORLEX) NEW, TAD C200 DCA PC /FOR COMMAND MODE IAC /USE ONE IN THE AC TO DCA DMPSW /INIT UNPACK AND TRACE SWITCH DCA DEBGSW /ENABLE TRACE FOR INPUT OF (?) TAD PDLSTR /SET HIGH LIMIT FOR PDL CDF T DCA I PAXPNT CDF P DCA ECHO /PRINT ONLY IF ECHO ISZ EOL /CHECK IF CR TERMINATED JMP IBAR /NO;($) TREAT LIKE ^U,_ IBAR1, TAD CNUM /ANNOUNCE PRESENCE WITH # PRINTC ISZ ECHO TAD BUFR /COMMAND INPUT BUFFER DCA AXIN /FOR UNPACKING DCA XCTIN TAD BUFR /RUBOUT PROTECTION DCA PACKST IGNOR, READC /READ COMMAND STRING SORTJ LIST7-1 INLIST-LIST7 PACKC /SAVE STRING CHARACTER JMP IGNOR INPUTX, PUSHJ /PROCESS IMMEDIATE COMMAND PROC JMS I DPC /TAD I PC SNA /END OF PROGRM? JMP I START /YES DCA PC /SAVE NEW LINE NO TAD PC /START NEW LINE IAC JMP GONE /PROCESS OTHER COMMANDS /TEXT LINE BUFFER FORMAT /#1 : POINTER OR ZERO IN LAST /#2 : LINENO /#3 - #N+1 : TEXT /#N : C.R. /LINE NUMBER FORMATION;RANGE OF ACCEPTIBLE LINE NUMBERS /=1.01 TO 31.99 XGETLN, 0 /COMPUTED LINE #'S SPNOR /IGNORE SPACES TSTCHR /'A' IS SPECIAL -"A SKP JMP TESTA PUSHJ /EVALUATE NUMBER OR EXPRESSION EVAL JMS I INTEGER /GET GROUP PART TAD P7740 /CHECK IF TOO BIG SMA CLA GZERR, ERROR2 /BAD GROUP # 206 /IG TAD LORD /GET GROUP AGAIN BSW CLL RAL DCA LINENO /SAVE IT JMS I MINSKI NOP /CDF V AFTER FENT FENT FADD I FLARGP /GET FRACTION FMUL FL100 FADD FLP5 /ROUND UP FEXT JMS I INTEGER TAD LINENO /ADD GROUP TESTA, DCA LINENO CLA CLL TAD LINENO /CHECK FOR ERROR AND P7600 SZA CLA CML TAD LINENO AND P177 SNL SZA JMP GZERR /ILLEGAL GROUP ZERO USAGE P7740, SMA SZA CLA /SMA FOR 7740 TAD P2000 /SET NAGSW;GROUP=0,LINE=4000,ALL=1 CML RAL DCA NAGSW JMP I XGETLN FL100, 0007 3100 0000 FLP5, 0000 P2000, 2000 0000 0000 IBAR, TAD CCR /ALTESC AND ^U,_ COME HERE PRINTC JMP IBAR1 /COMMAND/INPUT PROCESSOR ESRETN, TAD CCR STOCHR /ESCAPE CONVERTED TO CR CLA CMA IRETN, CMA DCA EOL /EOL REMEMBERS WHICH PACKC /START TO PACK C.R. PACKC /FINISH C.R. TAD BUFR /INITIALIZE FOR UNPACKING GONE, DCA AXOUT /SETUP CURRENT LINE DCA XCT GETC /READ FIRST CHARACTER TAD P7740 TAD PDLSTR /SET LOW LIMIT FOR PDL CDF T DCA I PAXPNT CDF P SPNOR /IGNOR LEADING BLANKC TESTN /DOES THE LINE BEGIN WITH 1-9? JMP GZERR /PERIOD =ILLEGAL GROUP ZERO USAGE JMP INPUTX /NO ISZ DEBGSW /YES, DISABLE TRACE FOR REPACKING GETLN /READ THIS LINE NUMBER CLA CLL CML RAR /TEST FOR SINGLE LINE TAD NAGSW SZA CLA ERROR2 /ILLEGAL LINE NUMBER ON INPUT 213 /IL TAD BUFR /SET POINTERS DCA AXIN DCA XCTIN TAD LINENO /SAVE LINE # JMS I DAXIN /DCA I AXIN SPNOR /IGNORE SPACES AFTER LINE NUMBER SKP GETC /READ 1ST AFTER LINENO TERMINATOR SRETN, PACKC /SAVE TEXT AND RESTORE DATA FIELD TSTCHR /TEST FOR END OF INPUT STRING -215 /-C.R. JMP .-4 DELETE /REMOVE OLD LINE, IF ANY CDF T /TERMINATE THE BUFFER LINE:OLD "ENDLN" TAD I LASTLN DCA I BUFR TAD BUFR /POINT TO NEW NEXT LINE DCA I LASTLN TAD ADD /CHECK FOR EXTRA INFO. SZA DCA I AXIN TAD AXIN /COMPUTE NEW END OF BUFFER IAC DCA BUFR GOKILL, CDF L DCA I LIBN /WE'VE CHANGED SOMETHING CDF P START1, JMP I START /POINTERS MUST BE REINITIALIZED LIBN, LIBFIL /PUSHDOWN LIST SATELLITES FLD1=CLA CLL IAC XPOPA, 0 MQL FLD1 CIF T JMS I .+1 ZPOPA XPUSHA, 0 MQL FLD1 CIF T JMS I .+1 ZPUSHA XPUSHF, 0 MQL FLD1 CIF T JMS I .+1 ZPUSHF XPOPF, 0 MQL FLD1 CIF T JMS I .+1 ZPOPF XPOPJ, CIF CDF T JMP I .+1 ZPOPJ /RECURSIVE OPERATE, EXECUTE, OR CALL DO, GETLN /EXECUTE ONE LUNE, A GROUP, OR ALL PUSHF /SAVE REST OF THIS LINE TEXTP /AXOUT,XCT,GTEM,PC DGRP, PUSHF /SAVE NAGSW; CHAR; AND LINENO NAGSW TAD NAGSW /CHECK DATA FROM GETLN SPA CLA /SKIP IF GROUP OR ALL JMP DOONE /DO ONE LINE FINDLN /INIT FOR GROUP AND SET THISLN INDOL, 233 /WILL BE CHANGED TO '$' (PERHAPS) TAD THISLN /TEST FOR GOOD GROUP NUMBER DCA XRT JMS I DXRT /TAD I XRT TSTGRP ERROR2 /NO SUCH GROUP NUMBER 66 /DG DGRP1, PUSHJ /EXECUTE OBJECT LINE AND SET PC PROCESS-2 POPF /RESTORE THE DATA NAGSW JMS I DPC /CHECK FOR END OF TEXT SNA JMP DCONT /ALL DONE IAC DCA PT1 /SAVE POINTER TO LINENO TAD NAGSW /CHECK FOR GROUP SMA SZA CLA JMP .+4 /DO ALL JMS I DPT1 /TEST GROUP TSTGRP /AGAINST LINENO JMP DCONT /NOT IN GROUP JMS I DPT1 /READ NEXT LINE NO DCA LINENO JMP DGRP /CONTINUE THE SUBROUTINE DOONE, FINDLN /FIND THE LINE ERROR2 /NO SUCH LINE NUMBER 73 /DL PUSHJ /EXECUTE IT PROCESS-2 /AND SET PC POPF /RESTORE CHAR NAGSW DCONT, POPF /RESTORE TEXT POINTERS TEXTP JMP I .+1 /CONTINUE PROCESSING THIS LINE PROC IN, 0 /READ IN A CHARACTER SUBROUTINE."READC" DCA INCOMP /IF AC # 0 THEN KEEP CHAR TO COMPARE CIF CDF L JMS I INDEV INCONV, STOCHR TAD CHAR CIA /NOW COMPARE TAD INCOMP SNA CLA POPJ /FOUND IT;EXIT FROM 'FIND' DCA ECHO SORTJ ECHOLST-1 /LF. OR RUB.:IGNORE ECHOGO-ECHOLST /ALT.:CHANGE,ESC.:PRINT PRINTC INEX, ISZ ECHO JMP I IN FIND, JMS I INTEGE /GET VALUE OF SEARCH CHAR. READC /PASS IT ON TO 'IN' TAD INCOMP JMP .-2 /LOOP;'IN' WILL GIVE 'POPJ' INCOMP, 0 INALT, ISZ ECHO /FOR 'FIND' POPJ TAD INDOL JMP INCONV /CONVERT TO ESC CHRTST, 0 /TEST CHAR SUB; "TSTCHR" TAD I CHRTST /GET ARG ISZ CHRTST /BUMP PAST ARG TAD CHAR SNA CLA ISZ CHRTST /SKIP IF EQUAL JMP I CHRTST TERMER, SPNOR /GOES TO TERMINATOR TAD CHAR /SAVE TEMP. MQL /FASTER THAN PUSHA SORTC GLIST-1 POPJ /FIRST CHAR IN MQ GETC JMP TERMER+3 FLIST2, FLIMIT /,=STANDARD FINFIN /;=SHORT FLIMIT-2 /CR=DUMB FLIST1, FINCR /,=STANDARD FORMAT PROCESS /;=SET;PLUS,.. PC1 /C.R.=SET COMMAND /PRIMARY CONTROL AND TRANSFER GOTO, GETLN /READ THE LINE NUMBER REQUESTE FINDLN /LOCATE IT AND RESET TEXTP ERROR2 /NOT THERE 156 /GO TAD THISLN /SET PC;DON'T MOVE ;REF. "DO" DCA PC PROCESS,GETC /TEST FOR END OF LINE PROC, DRONEP TSTCHR /FIRST CHARACTER READY = USE PROC -215 /C.R. SKP PC1, POPJ /EXIT "PROCESS" SORTC /IGNORE "SPACE",",", AND ";" GLIST-1 JMP PROCESS PUSHJ /GO TO TERMINATOR TERMER MQA AND P337 /ALLOW LOWER CASE SORTJ /GO DO COMMAND COMLST-1 COMGO-COMLST ERROR2 /ILLEGAL COMMAND 202 /IC COMMENTS=PC1 /ALSO IS CONTINUE /OUTPUT COMMAND TEXT WRITE, GETLN /SET LINENO OR 'DCA LINENO' *KEY* ISZ DEBGSW /DISABLE TRACE FINDLN /SEARCG FOR LINE NUMBER JMP WTESTG /NOT THERE OR GROUP OR '0' *KEY* TAD LINENO SZA CLA PRNTLN /PRINT LINE NUMBER AND A SPACE GETC PRINTC /PRINT TEXT OF A LINE TSTCHR -215 /C.R. JMP .-4 JMS I DTHIS /TEST FOR END OF TEXT OR '0' *KEY* WTEST2, SNA JMP WX-2 /EXIT;DO NEXT INDIRECT LINE IAC DCA PT1 /SAVE POINTER TO LINENO OF NEXT TAD NAGSW SMA CLA JMS I DPT1 TSTGRP /TRY NEXT LINENO FOR GROUP JMP WX WALL, JMS I DPT1 /SET LINENO DCA LINENO JMP WRITE+2 WTESTG, TAD THISLN /INIT GROUP PRINTOUT JMP WTEST2 DCA DEBGSW POPJ WX, TAD NAGSW SPA SNA CLA /SKIP IF ALL JMP WX-2 PRINTC /PRINT C.R. AGAIN JMP WALL XTESTC, 0 /TEST THE NATURE OF THE NEXT ALPHANUMERIC - "TESTC" SPNOR /IGNORE SPACES SORTC /TEST THE VARIABLE TERMINATORS TERMS-1 JMP I XTESTC /YES - SORTCN IS SET ISZ XTESTC /NO TESTN JMP I XTESTC /. SKP /OTHER JMP I XTESTC /NUMBER TSTCHR -"F /SKIP IF 'F' ISZ XTESTC ISZ XTESTC /RETURNS:T;N;F;A JMP I XTESTC XSORTC, 0 /SORT CHAR OR AC AGAINST TABLE - "SORIC" SNA /AC? TAD CHAR /NO.TAKE CHAR DCA T2 /STORE IN TEMP TAD I XSORTC DCA XRT2 /1ST ARG IS LIST-1 TAD I XRT2 SPA /LIST IS ENDED BY A NEGATIVE NUMBER JMP SEXC /2AND EXIT = NOT IN LIST CIA TAD T2 SZA CLA /COMPARE JMP .-6 TAD I XSORTC /COMPUTE INCREMENT : 0 - N CMA TAD XRT2 DCA SORTCN SKP /1ST EXIT = YES SEXC, ISZ XSORTC ISZ XSORTC CLA JMP I XSORTC GRPTST, 0 /AC VS LINENO - "TSTGRP" AND P7600 CIA DCA T2 TAD LINENO AND P7600 TAD T2 SNA CLA ISZ GRPTST JMP I GRPTST /INPUT FROM TEXT OR KEYBOARD; /IF BACK-ARROW, RESTART INPUT INPUT, 0 /INPUT A CHARACTER TAD INSUB /NON/ZERO FOR KEYBOARD SZA CLA JMP .+3 GETC JMP I INPUT READC SORTJ SPECIAL-1 INFIX-SPECIAL INPUAC, JMP I INPUT COMLST=. /COMMAND DECODING LIST "S /SET "F /FOR "I /IF "B /BRANCH "D /DO "G /GOTO "C /COMMENT "A /ASK "T /TYPE "L /LIBRARY "E /ERASE "W /WRITE "M /MODIFY "Q /QUIT "R /RETURN "O /OPEN / "X /EXTRA /THIS COMMAND LIST IS SPEED OPTIMIZED;"FOR" ENDS IT /LOOP CONTROL STATEMENT SET=. /SUBSET OF "FOR" FOR, PUSHJ /LOOPS, ETC. GETARG /LOOK FOR "=" NEXT SPNOR TSTCHR -"= ERROR2 /LEFT OF "=" IN ERROR:'FOR' OR 'SET' 324 /NE JMS SAVNAM /SAVE NAME OF VARIABLE PUSHJ EVAL-1 /GET INITIAL VALUE EXPRESSION JMS GETNAM /ALL THIS FOR ZEROED VARS NOP /EVENTUALLY FCDF V FINT /INITIALIZE NOW FGET I FLARGP /FLAC GETS KILLED BY GETNAM FPUT I PT1 FXIT SORTJ /TEST LAST CHAR FROM "EVAL" TLIST-1 FLIST1-TLIST ERROR2 /EXCESS R-PAR 117 /EP FINCR, JMS SAVNAM /SAVE VARIABLE NAME PUSHJ /EVALUATE THE INCREMENT,IF ANY EVAL-1 SORTJ /TEST TERMINATORS TLIST-1 FLIST2-TLIST ERROR2 /ILLEGAL TERMINATOR IN 'FOR' 122 /FC=FOR COMMAND FLIMIT, CDF V PUSHF /SAVE THE INCREMENT FLARG PUSHJ /GET THE LIMIT(NO ERROR DETECTION AFTER LIMIT) EVAL-1 FCONT, CDF V PUSHF /SAVE THE LIMIT FLARG PUSHF /SAVE TEXT OF OBJECT STATEMENTS TEXTP PUSHJ /DO THE OBJECT STATEMENTS PROCESS POPF /RESTORE REMAINING TEXT TEXTP CDF V POPF /GET LIMIT FLARG POPF /GET INCREMENT ITER1 JMS GETNAM /GET VARIABLE NAME NOP /FCDF V;IN AFTER FGET FINT /INCREMENT AND TEST FGET I FINKP /LOAD INCREMENT FADD I PT1 /ADD VARIABLE FPUT I PT1 /CHANGE IT FSUB I FLARGP /TEST IT FMUL I FINKP /ABSOLUTE FOR TEST FXIT TAD HORD SMA SZA CLA POPJ /END OF LOOP JMS SAVNAM /SAVE NAME PUSHF /SAVE INCREMENT AGAIN FINKP, ITER1 JMP FCONT FINFIN, PUSHF /SET INCREMENT TO ONE FLTONE JMP FCONT SAVNAM, 0 /LOCAL SUB TO SAVE NAME AND SUBSCRIPT IN PDL TAD SUBS PUSHA TAD EFOP PUSHA JMP I SAVNAM GETNAM, 0 /IDEM FOR GETTING POPA DCA EFOP POPA PUSHJ /PASSES AC GS1 /SETS PT1 JMP I GETNAM SORTB, 0 /SORT AND BRANCH ROUTINE. - "SORTJ" SNA TAD CHAR /ASSUME CHAR IF AC=0 CIA DCA T2 /SAVE SORT ITEM TAD I SORTB /FIRST ARG IS LIST LESS ONE ISZ SORTB /2AND IS INTRA-LIST LENGTH DCA XRT2 TAD I XRT2 SPA /**LISTS ENDED BY NEGATIVE NUMBER** JMP SEX /READ EXIT TAD T2 /FIND ADRESS SZA CLA JMP .-5 TAD XRT2 /MATCH FOUND TAD I SORTB DCA T2 TAD I T2 DCA SORTB JMP SEX+1 SEX, ISZ SORTB /MATCH NOT FOUND CLA CLL RDF TAD .+4 DCA .+1 HLT JMP I SORTB /RETURN TO CALLING SEQUENCE CIF CDF 0 COMGO=. /COMMAND ROUTINE ADRESSES SET FOR IF BR DO GOTO COMMENT ASK TYPE LIB ERASE WRITE MODIFY START1 /RETURN TO COMMAND MODE VIA 'QUIT' RETRN FILER /OPEN /INPUT OUTPUT STATEMENTS ASK, CLA CMA /REMEMBER WHICH CALL TYPE, DCA ATSW TASK, DCA DEBGSW /RE-ENABLE THE TRACE SORTJ /SPECIAL CHARACTER? ALIST-1 ATLIST-ALIST TAD ATSW /TEST QUOTE SWITCH SMA CLA JMP TYPE2 PUSHJ /DO ASK; SETUP PT1 GETARG TAD CHAR /SAVE IN LINE CHARACTER PUSHA DCA ECHO /ONLY IF ECHO TAD DIDO /RING-A-DING-DONG PRINTC ISZ ECHO ISZ INSUB /INDICATE 'READC' IAC /POINT PAST CHAR JMS I FINPUT /READ DATA AND SAVE JMP ENDASK TYPE2, PUSHJ /DO TYPE EVAL TAD CHAR PUSHA /SAVE FOR RETEST ENDESC, JMS I FOUTPUT /PRINT IAC DCA ECHO ENDASK, POPA /RETEST LAST TERMINATOR STOCHR JMP TASK /CONTINUE PROCESSING ESC, DCA ECHO /ONLY IF ECHO FINT FGET I PT1 FEXT JMP ENDESC /ECHO CURRENT VALUE OF LITERAL DIDO, 207 /BELL;CAN BE SET BY CD TQUOT, ISZ DEBGSW /DISABLE TRACE GETC /TYPE LITERALS SORTJ TLIST2-1 TLIST3-TLIST2 PRINTC JMP TQUOT+1 TINTR, TAD SPC DCA I LEADCH /RESET CHARS. TAD SPCMZE DCA I DFILL GETC /PASS PERCENT SIGN TESTC JMP FILL /TERM.,SHOULD BE '*' JMP FORMAT /NUMBER;NORMAL FORMAT STRMSP, "*-240 /FALLS THRU TSTCHR /OTHER;SET NO LEADER -"\ /IF %\XXXX JMP FORMAT /VARIABLE FORMAT TAD C200 JMP TINTR+1 /DELETE LEADER FILL, TSTCHR -"* JMP FORMFL /TERM., SET FLOAT FORMAT TAD STRMSP /SET "*" JMP TINTR+2 /GET NEXT CHAR SPCMZE, 240-"0 LEADCH, LEDCHR DFILL, FILLER FORMAT, CLA IAC /FIXED POINT FORMFL, DCA FISW /FLOATING GETLN TAD LINENO AND P7600 BSW CLL RAR SNA TAD DIGITS /FLOATING DCA FSIZE TAD LINENO AND P17 DCA DECP TAD FSIZE CIA TAD DECP SMA CLA FORMER, ERROR2 /FORMAT ERROR 136 /FO JMP TASK TCRLF, IAC /"!":CR,LF TFOFED, IAC /"&":FOFED TRESET, IAC /"#": RESET PAGE COMMAND TLFEED, TAD CLF /"'":LINE-FEED PRINTC TASK4, GETC /MOVE TO NEXT CHAR JMP TASK XTAB, PUSHJ EVAL-1 JMS I INTEGE SPA SNA CLA IAC /OVER LEFT MARGIN DCA LORD /AND ALLOW FOR 'T :,' FORW, TAD TABC /'T :1,' IS FIRST POSITION CMA CLL TAD LORD SNA JMP TASK /NO MOVEMENT SMA /NEGATIVE IF BACKUP CLL CML CIA /FORWARDS; SET LINK DCA CNTR SZL /FOR TERMINAL WITH BS JMP P216+1 / JMP .+2 TAD P216 / TAD M30 PRINTC / TAD SPC JMP FORW / DCA T3 P216, 216 /M30, -30 TAD SPC / TAD T3 PRINTC ISZ CNTR JMP .-3 CMA TAD LORD DCA TABC JMP TASK ALIST=. /ASK/TYPE LIST OF CONTROLS "' "& "# ": "% "" "! "$ GLIST=. 240 /SPACE TLIST=. ", "; 215 /C.R. /FIND OR ENTER A VARIABLE IN THE LIST GETARG, TESTC /FIRST LETTER OF ARG TLIST2, 0242 /" 0215 /C.R. - FUNCTION OR NUMBER IS NOT AN ARG. ERROR2 /BAD ARGUMENT IN 'FOR','SET',OR 'ASK' 20 /BA GETVAR, DCA XCTIN /PACK INTO ADD. PACKC /PACK FIRST CHAR TAD ADD /SAVE NAME DCA EFOP /WHERE WE CAN PUSH IT GETLP, GETC /GET NEXT CHAR SORTC /END OF NAME? TERMS-1 JMP GSERCH /YES ISZ XCTIN /IS THIS THE SECOND CHAR? JMP GETLP /MORE THAN 2 CHARS;IGNORE TAD CHAR /PACK SECOND CHAR AND P77 /MASK IT JMP GETLP-2 /ADD TO NAME GSERCH, TSTLPR /CHECK FOR SUBSCRIPT JMP GS1 /NONE JMS I DECALL /PICK IT UP POPA /RESTORE NAME DCA EFOP JMS I DPART /CHECK PAREN MATCH,ETC. JMS I INTEGE /CONVERT TO 12 BIT GS1, DCA SUBS /SAVE SUBSCRIPT MQL /CLEAR LAST ZERO HOLD TAD SECRTV /START SEARCH WITH SECRET JMP GSTRT /GO IN LOOP GS2, ISZ XRT /NAME DID NOT MATCH GS3, ISZ XRT /SUBSCRIPT DID NOT MATCH TAD I XRT /GETS HORD OF VAR. SZA CLA /IS VAR. ZERO? JMP .+3 /NO.MUST BE REAL TAD PT1 /YES!LET'S STORE ADRESSES MQL /AS WE GO ALONG TAD PT1 TAD GINC /NEXT /VARIABLES GET ADDED IN THE FOLLOWING WAY: /IF ANY ZERO'S AVAILABLE:FROM LASTV DOWNWARDS;BUT NOT SECRET /IF NO ZERO'S FROM LASTV UPWARDS;THEN BLOW-UP GSTRT, DCA PT1 /FIRST OR NEXT POINTER TAD LASTV /CHECK FOR END OF CIA CLL /EXISTING VARS. TAD PT1 SZL CLA JMP MAKVAR /VAR. NOT IN LIST;CREATE NEW ONE TAD PT1 /REPLICATE SO PT1 STAYS DCA XRT /AT START OF VAR. CDF V /VARIABLE FIELD TAD I PT1 /NAME CIA TAD EFOP /ASKED NAME SZA CLA /CHECK? JMP GS2 /NO TAD I XRT /OK.WHAT ABOUT SUBS.? CIA TAD SUBS SZA CLA JMP GS3 /ALMOST! ISZ PT1 /FOUND IT!! ISZ PT1 /POINT TO DATA POPJ MAKVAR, MQA /GET OUT LAST ZERO ADRESS SNA /ANY ZERO'S? JMP TOPVAR /NO.PUT IT ON TOP CIA /CHECK FOR SECRET VARS. TAD END /STVAR SNL SZA CLA JMP TOPVAR /IT WAS SECRET;ON TOP MQA /OK.USE ZERO VAR. DCA PT1 /RESET PT1 JMP VAREX TOPVAR, TAD VARTOP /CHECK FOR TOP CIA CLL TAD LASTV SZL CLA ERROR2 /REALLY NO MORE SPACE! 265 /LF=LITERALS FULL TAD LASTV /OK;UPDATE LASTV TAD GINC DCA LASTV VAREX, TAD EFOP /NOW STORE IN RIGHT PLACE DCA I PT1 ISZ PT1 TAD SUBS DCA I PT1 ISZ PT1 /POINTING AT DATA CDF P /CAREFUL FPNT! NOP /FOR FCDF V FINT FGET I CFRSX /ZERO THE DATA FPUT I PT1 FXIT POPJ /EXIT VARTOP, STARTF-10 CHRSTO, 0 /STORE A CHAR IN FLD 0 AND 1 - "STOCHR" DCA CHAR TAD CHAR CDF L DCA I XCHAR CDF P JMP I CHRSTO XCHAR, CHARL INLIST=. /INPUT CONTROL CHARACTERS ESRETN /ALTM = TERMINATE,ECHO $ ESRETN /ESCAPE = "" "" IBAR /^U = RESTART IBAR /B.A. = RESTART IGNOR /L.F. = IGNORE IRETN /C.R. = TERMINATE STRING ATLIST=. TLFEED /' - LINE FEED TFOFED /& - FORM FEED TRESET /# - RESET PAGE XTAB /: - TABULATOR TINTR /% - FORMAT DELIMITER TQUOT /" - LITERAL DELIMITER TCRLF /! - CARRIAGE RETURN AND LINE FEED TDUMP /DOLLAR/- DUMP THE SYMBOL TABLE CONTENTS TASK4 /SP- TERMINATOR FOR NAMES TASK4 /, - TERMINATOR FOR EXPRESSIONS PROCESS /; - TERMINATOR FOR COMMANDS PC1 /C.R.TERMINATOR FOR STRINGS /DOLLAR/ - FOR TDUMP TERMINATES THE COMMAND PAGE /EVALUATE AN EXPRESSION WHICH /TERMINATES WITH AN R-PAR, ; OR C.R. AND /LEAVE THE RESULT IN FLAC AND IN FLARG ECALL, 0 /RECURSIVE CALL TO "EVAL" PUSHF /SAVE SORTCN,LASTOP,EFOP CELSO /INCLUDES 'CIF CDF P' FOR POPJ TAD ECALL /RETURN TO CALLING PUSHA /ADRESS AFTER NEXT POPJ GETC /MOVE PAST EXTRA CHAR EVAL, DCA LASTOP /EVALUATION CONTROLLER(CHECKPOINT?) DRONEP /FOR ETOS TESTC /TEST CHAR AND IGNORE SPACES JMP ETERM1 /TERMINATOR JMP ENUM /NUMBER JMP EFUN /FUNCTION PUSHJ /LETTER OF VARIABLE GETVAR /FIND OR CREATE VARIABLE;ALSO SET PT1 OPNEXT, TESTC /PT1 TO ARG JMP ETERMN /T NOP /N-ERROR IN FORMAT NOP /F JMP ETERM+1 /'EVAL'FOUND A TERMINATOR WHICH WAS NOT AN OP. ETERM1, TAD CFRSX /SET PT1 DCA PT1 /TO POINT TO ZERO TAD M2 /TEST FOR UNARY OPERATIONS TAD SORTCN SNA JMP ETERM /CREATE DUMMY FOR UNARY MINUS IAC SNA CLA JMP ARGNXT /IGNORE UNARY PLUS TAD SORTCN /TEST FOR NULL PARENS TAD M11 SPA CLA JMP ELPAR /MIGHT BE AN L-PAR ETERMN, TSTLPR SKP ERROR2 /OPERATOR MISSING BEFORE PAREN 336 /NO=NO OPERATOR ETERM, TAD SORTCN /SET FROM "TESTC"-"SORTC" DCA THISOP TAD THISOP TAD M11 SMA CLA /END? DCA THISOP ETERM2, TAD THISOP /COMPARE PRIORITIES CIA TAD LASTOP SPA CLA JMP EPAR /CONTINUE TAD LASTOP /FIND OPERATION CLL RTR RTR TAD OPTABL DCA FLOP TAD LASTOP SZA CLA /TEST FOR END OF DATA INTO FLOATING AC POPF /GET LAST DATA FLAC NOP /LATER FCDF V FINT FLOP, 00 /(FLOPR I PT1)+-*/ FPUT I FLARGP /SAVE RESULT FXIT TAD FLARGP DCA PT1 TAD THISOP TAD LASTOP /=0? SNA CLA JMP EVLEX /EXIT EVAL POPA /GET PRIOR OP DCA LASTOP JMP ETERM2 /COMPARE THIS OP EVLEX, TAD SORTCN DCA I ULTSOR /SAVE LAST "SORTCN" POPJ EPAR, TSTLPR /TEST FOR SUB-EXPRESSION SKP JMP EPAR2 /GO EVALUATE EXPRESSION TAD LASTOP /CONTINUE READING THE EXPRESSION PUSHA /SAVE "LASTOP" TAD PT1 DCA .+3 CDF V PUSHF /SAVE LAST ARGUMENT 00 TAD THISOP /MORE TO COME DCA LASTOP ARGNXT, GETC /READ FIRST CHAR OF AN ARG. TESTC /DO SPECIAL CHECK JMP ELPAR JMP ENUM /N JMP EFUN /F JMP OPNEXT-2 /L OPTABL, FGET I PT1 /BASE FOR OPERATION COMPUTATION ENUM, PUSHF /TO PROCESS ANUMBER,SAVE AC FLAC TAD FLARGP /SET POINTER AS FOR A VARIABLE DCA PT1 DCA INSUB /POINT TO 'GETC' AND USE CHAR JMS I FINPUT /READ TEXT NUMBER INTO FLARG POPF /RESTORE THE AC FLAC JMP OPNEXT /CONTINUE EFUN, DCA EFOP /SET CODE GETC /READ FUNCTION NAME(1,2,3 LETTERS) SORTC /LOOK FOR TERMINATION CHAR TERMS-1 JMP EFUN2 /YES TAD EFOP /NO CLL RAL /MISH-MASH HASH CODE TAD CHAR JMP EFUN EFUN2, TSTLPR ERROR2 /MUST BE FOLLOWED BY PARENS TO SET ARGUMENT 25 /BF=BAD FUNCTION JMS ECALL /CALL "EVAL" TO COMPUTE ARGUMENT POPA /GET OUT EFOP SORTC FNTABL-1 JMP I STFUNC /FOUND IT ELPAR, TSTLPR /LEFT PAREN OR FELL THROUGH FUNCTION TABLE ERROR2 /DOUBLE OPERATORS OR ILLEGAL FUNCTION NAME 124 /FE=FUNCTION ERROR EPAR2, JMS ECALL /EVALUATE NESTED EXPRESSION POPA /DUMP EXTRA ARG JMP I EFUN3I STFUNC, FUNCST EFUN3I, EFUN3 ULTSOR, SORTUL TERMS=. /TERMINATOR TABLE FOR 'EVAL' AND 'GETARG' 240 /0 SPACE "+ /1 "- /2 "/ /3 "* /4 "^ /5 "( /6 "[ /7 274 /10 (LEFT ANGLE BRACKET) ") /11 "] /12 276 /13(RIGHT ANGLE BRACKET) ", /14 "; /15 215 /16 C.R. "= /17 TO END GETARG FROM 'SET' FNTAPT, FNTABF-1 /POINTER TO 2-WORD FNTABF FUNCST, TAD SORTCN /SET BY SORTC CLL RAL /*2 TAD FNTAPT DCA XRT2 TAD I XRT2 /GET FIELD OF FUNCTION DCA .+3 TAD I XRT2 /GET ADRESS DCA .+3 HLT PUSHJ HLT /POPJ COMES BACK .+1 EFUN3, NOP /FOR FCDF FINT FNOR /NORMALIZE FUNCTION RETURN FPUT I FLARGP /SAVE FUNCTION VALUE FXIT TAD FLARGP /SET POINTER DCA PT1 JMS PARTEST JMP I .+1 OPNEXT SORTUL, 0 P3, 3 LPRTST, 0 /SKIP IF LEFT PAREN. - 'TSTLPR' TAD SORTCN TAD M11 SMA CLA JMP I LPRTST TAD SORTCN TAD M5 SMA SZA CLA ISZ LPRTST JMP I LPRTST PARTES, 0 /TEST THE PAREN MATCHINGS POPA /RESTORE THE LAST OPERATION DCA LASTOP POPA TAD P3 /+3 TO COMPARE CODES CIA /CHECK FOR PAREN MATCH TAD SORTUL /(STILL SET FROM THE LAST 'EVAL') SZA CLA /SKIP IF MATCH ERROR2 /PAREN ERROR 317 /MP=MISSING PARENTHESIS GETC /MOVE PAST R-PAR JMP I PARTEST /THE DELETE ALINE ROUTINE XDELET, 0 /UNCHAIN A LINE AND RECOVER THE SPACE NOP/IOF /PROTECT POINTER CHANGES FROM INTERRUPTIONS FINDLN /SETS "THISLN" AND "LASTLN" JMP I XDELETE /ALREADY GONE ISZ DEBGSW /DISABLE TRACE GETC /MEASURE LENGTH TSTCHR -215 /C.R. JMP .-3 TAD AXOUT /SAVE LAST ADRESS CMA TAD THISLN DCA CNTR /LENGTH .L. 0 TAD CFRS /IT IS ILLEGAL TO DELETE THE FIRST LINE CIA TAD THISLN SNA CLA JMP I START /JUST IGNORE SUCH COMMANDS CDF T /CHANGE DATA FIELD TO TEXT TAD I THISLN /DISCONNECT DCA I LASTLN TAD CFRS /START LIST AT TOP DOK, DCA T2 /EXAMINATION ADRESS TAD I T2 SNA /TEST FOR END JMP DONE /YES-WRAP UP ALL DCA T1 /SAVE NEXT ADRESS TAD THISLN /COMPARE LINE POSITIONS CIA CLL TAD T1 SZL CLA /SKIP IF THISLN .G. X TAD CNTR /CHANGE (X) TO ACCOUNT FOR TAD T1 /GARBAGE COLLECTION DCA I T2 TAD T1 /GET NEXT JMP DOK /GARBAGE COLLECTION DONE, CMA /BACKUP L FOR XR TAD THISLN DCA XRT TAD CNTR /CORRECT END OF BUFFER POINTER TAD BUFR DCA BUFR TAD AXIN /COMPUTE COUNT CMA TAD AXOUT DCA T1 TAD AXIN TAD CNTR DCA AXIN TAD I AXOUT DCA I XRT ISZ T1 JMP .-3 JMP XDELETE+1 /RESET 'LASTLN','THISLN', AND DATA FIELD RETRN, TAD C200 DCA PC POPJ SRNLST=. /'MODIFY' CONTROL CHARACTER TABLE SCHAR /V.T. = CONTINUE SCONT /BELL = CHANGE SEARCH CHAR ESRETN /ALTM = END LINE ESRETN /ESC = END LINE SBAR /^U = RESTART SBAR /B.A. = RESTART SCEND /L.F. = FINISH THE LINE AS BEFORE LISTGO=. IRETN /C.R. = END THE LINE HERE AS IT IS SGOT /CHAR = SEARCH CHAR SPECIAL=. /INPUT CHARS 225 /CNTRL. U 334 /BACK-SLASH ECHOLS, 377 /RUBOUT 212 /LINE FEED 375 /ALT MODE 233 /ESCAPE MGETC, GETC POPJ /ERASE SINGLE LINES, GROUPS, OR VARIABLES ERASE, TESTC /TEST THE SECOND WORD IF ANY JMP ERVX /ERASE THE VARIABLES JMP ERL /LINES OR GROUPS JMP .+3 /ERROR TSTCHR /ALL TEXT -"A ERROR2 /BAD ARG FOR ERASE 24 /BE=BAD ERASE ERT, TAD ENDT /ERASE ALL TEXT DCA BUFR CDF T DCA I CFRS JMP I GOK /RESTART ERL, GETLN /ERASE LINES TAD BUFR /PROTECT REST OF TEXT DCA AXIN ERG, DELETE /EXTRACT ONE LINE ISZ THISLN TAD NAGSW SMA CLA JMS I DTHIS /(TAD I THISLN) TSTGRP /DONE ERASING GROUP?(SKIP) JMP I GOK /YES,ERASE 'CURRENT PROGRAM SAVED' FLAG JMS I DTHIS /(TAD I THISLN) DCA LINENO JMP ERG ERVX, TAD END /ZERO VARIABLES(BUT NOT SECRET VARIABLES) DCA LASTV /MAY BE INDIRECT COMMAND POPJ GOK, GOKILL /ROUTINE CALLED VIA "FINDLN": /SEARCH FOR A GIVEN LINE I.D. =[ "LINENO"] /1ST RETURN IF NOT FOUND, /2AND IF FOUND. /"THISLN" = FOUND LINE OR NEXT LARGER /"LASTLN" = LESSER AND/OR LAST /"TEXTP" IS SET XFIND, 0 TAD CFRS /INITIALIZE POINTERS TO FIRST LINE DCA LASTLN TAD CFRS FINDN, DCA THISLN /SAVE THIS ONE TAD THISLN DCA XRT TAD LINENO CLL CMA IAC /CLEAR LINK AND NEGATE LINENO JMS I DXRT /LINENO=0 WILL BE FOUND (X-MEM) SNA JMP FEND3-1 /FOUND IT SZL CLA JMP FEND3 /PASSED IT TAD THISLN /MOVE POINTERS DCA LASTLN JMS I DTHIS /END OF TEXT ? (X-MEM) SZA JMP FINDN /NOT YET SKP ISZ XFIND /2ND EXIT = FOUND FEND3, TAD THISLN /1ST RETURN = NOT FOUND IAC DCA AXOUT /SET "TEXTP" DCA XCT JMP I XFIND UTRA, 0 /UNPACK CHARACTER. - "GETC" JMS GET1 UTE, SPA CLA /NORM & EXTEND TAD GEND /300-337 & 340-376 TAD M137 /240-276 & 200-236 TAD CHAR SNA JMP UTX /"?" FOUND TAD P337 UTQ, STOCHR TAD DEBGSW TAD DMPSW SNA CLA /PRINT ONLY IF BOTH ARE ZERO PRINTC JMP I UTRA EXTR, JMS GET1 CMA JMP UTE UTX, TAD DEBGSW /TEST FOR TRACE-ENABLED M40, SMA SZA CLA /DEBGSW NEVER NEGATIVE JMP .+6 TAD DMPSW /FLIP THE TRACE FLOP SNA CLA IAC DCA DMPSW JMP UTRA+1 /GET NEXT CHARACTER INSTEAD TAD P277 /TRACE DISABLED = RETURN "?" JMP UTQ GET1, 0 /UNPACK 6 BITS ISZ XCT /STARTS=0 JMP GET3 TAD GTEM GEND, AND P77 SNA TAD P40 /CONVERT TO SPACE DCA CHAR /SAVE TAD CHAR TAD M77 SNA CLA JMP EXTR /EXTENDED TAD CHAR TAD M40 JMP I GET1 GET3, CDF T TAD I AXOUT CDF P DCA GTEM CMA DCA XCT TAD GTEM BSW JMP GEND M137, -137 /IF DEBGSW=0 : ENABLE FLIP-FLOP "DMPSW" / #0:DISABLE AND RETURN ALL"?" 'S /IF DMPSW = 0: TRACE ON, IF ENABLED / #0: TRACE OFF /IF BOTH = 0 : PRINT TRACE PGETLN, GETLN POPJ TLIST3=. TASK4 /" (LITERAL TERMINATORS) PC1 /C.R.=AUTOMATIC QUOTE MATCH INFIX=. /DATA CONTROL CHARACTERS FLINTP+2 /CNTRL. U = KILL FLINTP+2 /BACK-SLASH=KILL INPUAC /RUBOUT=TERMINATOR INPUT+1 /L.F.=IGNORE ESC /ALT MODE=EXIT ESC /ESC=ALT FLTONE, 0001 /(NO RELATIVE REFERENCES) 2000 0000 0000 M12, -12 XSPNOR, 0 /IGNORE LEADING SPACES - "SPNOR" TSTCHR -240 /SPACE JMP I XSPNOR GETC JMP XSPNOR+1 XTESTN, 0 /RETURNS: .; OTHER; NUMBER - "TESTN" TAD CHAR TAD MPER SZA ISZ XTESTN TAD M2 DCA SORTCN /SAVE VALUE OF NUMBER TAD SORTCN /TEST IF REALLY A DIGIT SPA CLA JMP I XTESTN TAD SORTCN TAD M11 SPA SNA CLA ISZ XTESTN /IF A NUMBER JMP I XTESTN XPRNT, 0 /PRINT A LINENUMBER -"PRNTLN" DCA COMBO+3 /IF AC='SKP' :PACK ALSO TAD LINENO AND P7600 BSW RAR JMS PRNT /TWO DIGIT PART NUMBER TAD PER JMS COMBO TAD LINENO JMS PRNT /TWO DIGIT STEP NUMBER TAD SPC JMS COMBO /PRINT AND SOMETIMES PACK DCA COMBO+3 /RESET TO PRINT ONLY JMP I XPRNT PRNT, 0 /PRINT TWO DECIMAL DIGITS AND P177 DCA T1 TAD C260 DCA T3 JMP .+3 ISZ T3 XYZ, DCA T1 TAD T1 TAD M12 SMA JMP XYZ-1 CLA TAD T3 JMS COMBO TAD T1 TAD C260 JMS COMBO JMP I PRNT COMBO, 0 /COMBINED PRINT PACK STOCHR PRINTC 0 JMP I COMBO PACKC JMP I COMBO /SYMBOL TABLE TYPEOUT ROUTINE TDUMP, TAD END /INIT POINTER FOR DUMP (DON'T DUMP SECRET VARIABLES) DCA PT1 TAD LASTV /TEST FOR END OF LIST CIA TAD PT1 SNA CLA POPJ CDF V TAD I PT1 /GET VARIABLE CDF T DCA I OP+1 CDF P TAD OP /SETUP UNPACK POINTERS DCA AXOUT DCA XCT GETC /READ AND PRINT "XX(" PRINTC GETC PRINTC GETC PRINTC ISZ PT1 CDF V TAD I PT1 /PRINT SUBSCRIPT TO 99 CDF P JMS PRNT GETC /PRINT ")" PRINTC ISZ PT1 NOP /FCDF V FINT /PICK UP VALUE FGET I PT1 FXIT JMS I FOUTPUT /PRINT VALUE TAD CCR PRINTC TAD GINC TAD M2 TAD PT1 JMP TDUMP+1 OP, PC0+3 PC0+4 LGOSUB, PUSHJ /EXECUTE THE SUBROUTINE DO+1 LIB, CIF CDF L /I.E. TO "PROC" FOR REST OF LINE JMP I LIBLOW LIBRET, TAD JMPGOS /RETURN TO APPROPRIATE ROUTINE DCA .+1 HLT PROCLB, PROC START1 LGOSUB GOTO+1 WRITE+1 /ONLY USED BY CD FOR /W OPTION LIBLOW, LOWLIB JMPGOS, JMP I PROCLB ECHOGO, INEX INEX INALT INEX-1 ILIST, IF1 /, PROCESS /; PC1 /CR /SEARCH ROUTINES MODIFY, TAD LINENO DCA ATSW /KEEP IF GETLN GIVES 0 GETLN /READ LINE NO. TAD LINENO SNA /OR 'SNA CLA' *KEY* TAD ATSW /USE LAST IF 0 DCA LINENO FINDLN /LOOK IT UP NOW ERROR2 /NOT THERE = BAD COMMAND UNLESS ZERO 34 /BM=BAD MODIFY TAD BUFR /SET POINTERS DCA AXIN /FOR INPUT DCA XCTIN TAD BUFR DCA PACKST TAD MODSKP /SET PRNTLN FOR PACKING PRNTLN SCONT, CLA STL RTL /=2 DISABLE ECHO FOR MULTI8 CIF CDF L JMS I INDEV /READ THE TELETYPE SILENTLY SCEND, DCA DMPSW /SAVE SEARCH CHAR. ISZ DEBGSW /NO BREAKS SCHAR, GETC /TYPE+TEST-F.F. PRINTC /PLAYBACK THE TEXT SORTJ /LOOK FOR MATCH LIST3-1 LISTGO-LIST3 PACKC /SAVE NEW LINE JMP SCHAR SBAR, STL CLA IAC RAL /RESTART-B.A. TAD BUFR DCA AXIN /SET POINTERS DCA XCTIN SFOUND, READC /READ FROM KEYBOARD SORTJ /TEST LIST6-1 SRNLST-LIST6 SGOT, PACKC /PACK CHAR. JMP SFOUND /MORE /CONDITIONAL TRANSFER PROCESS SPNA= SPA SNA CLA BR, CLA CMA /THIS SETS BRANCH COMMAND IF, DCA BRSW TESTC /FIRST CHAR. MUST BE TERMINATOR JMP IFOK /OK! FRSTIF, 0 SCNDIF, 0 JMP IFER IFOK, TAD (SPA DCA IF2 /RESET IF2 JMS I DECALL /EVALUATE FIRST EXPRESSION TSTCHR -", /TEST IF TERMINATED BY ',' JMP COMPIF /NO: COMPUTED IF GETC /GOBBLE COMMA SORTC IFLIST-1 /GET FIRST REL. OP. MODSKP, SKP IFER, ERROR2 /NO SUCH! 204 /IE=IF ERROR TAD SORTCN DCA FRSTIF /KEEP FIRST REL. OP. DCA SORTCN GETC /NEXT REL. OP. IF ANY SORTC IFLIST-1 GETC /FOUND ONE;MOVE TO NEXT CHAR TAD SORTCN DCA SCNDIF /KEEP;IF NONE = 0 CLA CLL IAC RAL /2=OP. '-' DCA THISOP PUSHJ EPAR /EVALUATE SECOND ARGUMENT TAD FRSTIF CIA TAD SCNDIF SNA CLA JMP IFER /SOME COMBINATION LIKE:'==' TAD (NOP DCA IF2 /SET FOR TWO EXITS TAD FRSTIF /NOW COMPUTE INSTRUCTION TAD SCNDIF CLL RAR /.GT. IN LINK SZL CMA /COMPL. IF .GT. SZL TAD (2004 /SET REVERSE SENSE BSW CLL RAR TAD (7600-SPNA COMPIF, TAD (SPNA DCA IF3-1 POPA /DUMP EFOP JMS I DPART /CHECK PARENS. TAD M2 DCA T1 TAD HORD /TEST COMP.IF. -,0,+ IF2, SPA ISZ T1 SPA SNA CLA /OR SOME OTHER INSTR. IF3, ISZ T1 /COUNT COMMAS SKP JMP IFBRCO /TRANSFER TO GO AND BRANCH SORTJ /SEARCH TEXT UNTIL ,;C.R. TLIST-1 ILIST-TLIST GETC JMP .-4 IF1, GETC /MOVE PAST COMMA JMP IF3 IFBRCO, GETLN /GET LINE FIRST JMS I (ENDCOM /GO TO END OF COMMAND ISZ BRSW JMP I (GOTO+1 JMP I (DO+1 BRSW, SCOPSU, 0 /FOR SCOPE RUBOUTS TAD P40 /BS ALREADY OUT PRINTC /SPACE TAD SPLAT /BS PRINTC ISZ ECHO JMP I SCOPSU PAGE OUT, 0 /OUTPUT A CHARACTER-"PRINTC" SNA /USE AC OR CHAR TAD CHAR AND P177 SNA JMP I OUT /IGNORE NULLS TAD M15 /CHECK FOR CR SNA JMP NEWLIN /TYPE CR,LF TAD CCR /ADD 200 BIT OUTCLF, CIF CDF L JMS I OUTDEV JMP I OUT NEWLIN, TAD CCR /CR CIF CDF L JMS I OUTDEV TAD CLF /LF JMP OUTCLF M15, -15 OUTDEV, LOWOUT /CHARACTER REMOVAL ROUTINE RUB1, TAD AXIN /RUBOUT ONE LETTER CIA TAD PACKST /PROTECTION SPA CLA TAD AXIN /IF TOO LOW PUT 0 IN T2 DCA T2 CDF T ISZ XCTIN /TEST HALF JMP RUB2 TAD I T2 /ADD IS FULL AND P77 /IF PROTECTION TAD M77 /THIS NEVER GIVES ZERO M140, SZA CLA /BECAUSE LOC.0 FLD T IS ZERO JMP RUB4 RUB3, CMA /IT IS EXTEND CODE DCA XCTIN /SET SWITCH CMA TAD AXIN DCA AXIN TAD I T2 /RESET ADD AND P7700 RUB4, DCA ADD CDF P DCA ECHO /ONLY IF ECHO TAD SPLAT /FOR RUBOUT ACKNOWLEDGEMENT PRINTC DELSCP, JMS I PSCOPS /OR 'ISZ ECHO' IF NO SCOPE RUBOUTS JMP I PACBUF RUB2, TAD T2 SNA CLA JMP PACX /PROTECTED! TAD I T2 /CHECK FOR EXTEND AND P7700 TAD M140-2 SZA CLA JMP RUB3 DCA I T2 /SAVE CORRECTION JMP RUB3+1 PSCOPS, SCOPSU /SUB TO PRINT SPACE,BACKSPACE PACBUF, 0 /PACK A CHAR. -"PACKC" TAD P277 CIA TAD CHAR SNA /CHANGE 277 TO 377 TAD P40 TAD P7700 SNA /TEST FOR RUBOUT JMP RUB1 TAD P377 DCA T2 /SAVE INPUT ITEM TAD T2 /SO THAT QUESTION DOESN'T MAKE P377, AND C140 /CHAR LOOK LIKE A LEFT ARROW TAD M140 SZA /DATA WORD TAD C140 SNA CLA JMP ESCA /200-237 & 340-377 PA1, TAD T2 /240-337 AND P77 SZA /IGNORE 300 JMS PCK1 PACX, CDF P JMP I PACBUF ESCA, TAD P77 JMS PCK1 JMP PA1 ROT, BSW DCA ADD CMA DCA XCTIN JMP I PCK1 P7700, 7700 PCK1, 0 ISZ XCTIN /=0 TO START JMP ROT TAD ADD JMS I DAXIN DCA ADD /CLEAR PACKING WORD JMP I PCK1 AXIND, 0 /AXIN SUB. NOW CHECKS FOR OVERFLOW CDF T DCA I AXIN TAD I PAXPNT /PDLXR CLL CIA TAD AXIN TAD SPC /PROGRAM UP TO 7300 CDF P /PROGRAMS MAX. 15 BLOCKS LONG SNL CLA /7300 GIVES SPACE FOR APPEN AND PDL JMP I AXIND ERROR2 /TEXT OVERFLOW 365 /PF=PROGRAM FULL FIN, READC /SINGLE CHAR. INPUT FUNCTION TAD CHAR /FLOAT CHAR. DCA HORD DCA LORD DCA OVER2 TAD P13 DCA EXP POPJ FOUT, JMS I INTEGE /SINGLE CHAR OUTPUT FUNCTION SNA TAD C200 /IN CASE IT'S ZERO PRINTC POPJ XINT, JMS I INTEGE CLA CLL POPJ C140, 140 /DON'T MOVE!! PAGE /INPUT-OUTPUT ROUTINES FOR THE /FOCAL FLOATING POINT PACKAGE /IN THE COMMENTS BELOW:- /F=NUMBER OF DIGITS TO BE OUTPUT =FISW ---F--- /D=NUMBER OF DECIMAL PLACES =DECP ABC.DEF E GHI /E=DECIMAL EXPONENT =BEXP -D- -E- /P=NUMBER OF PLACES REMAINING TO BE /PRINTED BEFORE DECIMAL POINT PLCE=SGNPRN TGO, 0 TAD DIGITS CMA DCA SCOUNT /SAVE MAX. NUMBER OF DIGITS AVAILABLE - SET COUNT TAD FSIZE CIA DCA FCOUNT /-F TAD FISW /(JMP FPRNT) - FOR NO ROUNDING SNA CLA /FLOATING OUTPUT ? JMP R6 /YES, F SIGNIFICANT PLACES TAD FCOUNT TAD DECP /D-F TAD T3 /COMPARE DEC. EXPONENT D-F+E SMA /F-D .G. E ? R6, CLA /NO, ROUND OF TO .F PLACES TAD FSIZE /YES SPA /D+E.L.0 ? JMP DEFEAT /YES, NO ROUNDING NEEDED, GO TO PRINT CMA /NO, ROUND TO D+E PLACES TAD DIGITS /-(D+E)-1+DIGITS SPA /TO A MAX OF D PLACES CLA CMA /*ROUND UP* CIA TAD DIGITS DCA T2 /SAVE NUMBER+1 OF PLACES TO ROUND TO TAD FLTXR TAD T2 /SET UP BUFFER ADDRESS AT WHICH DCA PLCE /ROUNDING OFF SHOULD START TAD T2 CIA /SETUP COUNT OF MAX NO DCA T2 /OF CARRIES ALLOWABLE TAD K6 /LITTLE EXTRA ON FIRST DIGIT RET, TAD I PLCE TAD OM12 SPA CLA /CARRY REQUIRED ? JMP FPRNT /NO, GO TO OUTPUT DCA I PLCE /YES, MAKE CURRENT DIGIT ZERO ISZ T2 /BEGIN OF BUF REACHED ? JMP DECR /NO, DECREMENT BUF ADDR. AND REPEAT ISZ I PLCE /YES, SET MANTISSA TO .1 DEFEAT, ISZ T3 /COMPENSATE BY INCREMENTING EXP LEDCHR, 240 /SPACE OR $,F,M,ETC. CLA CLL FPRNT, TAD DECP DCA PLCE /FOR INT/FLT CHECK TAD T3 DCA OUTEXP /KEEP T3 FOR LATER TAD FISW /AUTO-INDEX REG ALREADY SET - *PRINT* SNA CLA /F=0 ? JMP FLOUT /YES, OUTPUT AS FLOAT NUMBER TAD FCOUNT TAD T3 SMA SZA /E .G. F ? JMP FLOUT /YES, CONVERT TO E FORMAT TAD DECP /-F-E+D SMA /E.L.F-D ? CLA /NO, P=E CIA /YES, TAKE P=F-D TAD T3 CIA DCA T1 /SETUP -P BACK1, TAD OUTEXP /PRINT DD.DDD TAD T1 SZA CLA /B=E ? JMP NODIG /NO CMA /YES, PRINT DIGIT TAD OUTEXP /REDUCE E BY ONE DCA OUTEXP ISZ SCOUNT K6, 6 TAD SCOUNT SPA CLA /ALL SIGNIFICANT FIGURES? TAD I FLTXR /NO, OUTPUT NUMBER RIN, DCA OUTEM /YES-OUTPUT ZERO IN TEMP. TAD OUTSGN SNA /SIGN OUT ALLREADY? JMP FILOUT-1/YES - FORGET IT JMS I OPUT /NO - PRINT - OR FILL DCA OUTSGN /SIGNAL SIGN OUT TAD OUTEM /OUTPUT NUMBER FILOUT, JMS I OPUT /OR FILLER ISZ T1 /P CHARS. PRINTED? JMP NOPER TAD PLCE /IS IT INTEGER FORMAT? SNA CLA JMP NOPER /YES: NO PERIOD TAD PER /YES, PRINT PERIOD PRINTC /EVEN IF FIELD IS FULL NOPER, ISZ FCOUNT /F CHARS. PRINTED? JMP BACK1 /NO, BACK TO LOOP JMP I TGO /YES, CHECK IF FLOAT DECR, CMA /BACKUP TO TOP OF BUF TAD PLCE DCA PLCE ISZ I PLCE /ADD ONE TO DIGIT AT CURRENT POSITION JMP RET OM12, -12 OPUT, OUTDG FILLER, 240-"0 /SPACE OR * OUTSGN, 240-"0 /GETS "- - "0 OR 'FILLER' OUTEXP, 0 OUTEM, 0 SCOUNT, 0 FCOUNT, 0 NODIG, TAD T1 IAC SMA CLA /P .G. 1? JMP RIN /NO, PRINT ZERO TAD FILLER /YES, TYPE FILLER JMP FILOUT FLOUT, ISZ PLCE /NO INT WHEN FORMAT OVERFLOW ISZ TGO /TELL FLOUTP ABOUT FLOAT CLA IAC DCA OUTEXP /SET EXP=1 CLA CMA /FAKE F-D=1 JMP BACK1-1 SGNPRN, 0 /TYPES LEADER AND SETS SIGN TAD LEDCHR PRINTC TAD HORD SPA CLA /CHECK SIGN CLL CMA RTL /="- - "0 SNA TAD FILLER /IF POSITIVE DCA OUTSGN /WILL GET OUT LATER JMP I SGNPRN ERCALL, ERROR2 /NO ITEM IN LIST 320 /NA=NOT AVAILABLE PAGE IFLIST, 300 276 /.GT. 275 /.EQ. 300 274 /.LT. MMINSK, JMS I MINSKI POPJ FORLEX, CIF CDF L JMP I .+1 LEXIT XDRONE, 0 CIF L JMS I .+2 JMP I XDRONE XIDLE RELESE, SZA CLA /PRINT LINE ONLY IF RUNNING PRNTLN TAD P13 /=11 FOR MULTI8 RELEASE 6770 /GIANT IOT CLA /YOU NEVER KNOW! JMP I START /AND BACK TO KB OR OS/8 /SECRET VARIABLES STSECR=. 4400 0000 0013 DOLL, 0001 0000 0000 4300 NMBSGN=.+2 ZBLOCK 5 4100 EXCLA=.+2 ZBLOCK 5 /INTRPT VARIABLES 4200 QUOTS=.+2 ZBLOCK 5 2011 /SECRET PI 0000 0002 3110 3755 2421 2605 /VERSION NUMBER 40.1 0000 0006 2403 1463 1464 STVAR=. ZBLOCK OVRLAY-. XLIST EJECT DPF FCARIT AND FPP XLIST /HEADER FOR FCARIT.SV *5000 OVRLAY=. ARIT, HLT TAD STARIT DCA I DVAR /UP TO THE PROGRAMMER TO ORGANIZE CIF CDF L /HIS VARIABLES JMP I .+1 CHENTR /BACK TO FOS8 STARIT, ARIT-10 DVAR, VARTOP /EXPONENTIAL GETSGN=TAD HORD *5020 STARTF=. FEXP, GETSGN /TAKE ABSOLUTE VALUE SPA CLA JMS I NEGP DCA T3 /C(SIGN)=-1 IF I X2.L.0 FINT FMUL LG2E FPUT I X2 FEXT JMS I INTEGER DCA FLAG2 /SAVE LOX ORDER DATA FINT FNOR FPUT I XSQ2 FGET I X2 FSUB I XSQ2 FPUT I X2 FMUL I X2 FPUT I XSQ2 FADD DF FPUT TEMP FGET CF FDIV TEMP FSUB I X2 FADD AF FPUT TEMP FGET BF FMUL I XSQ2 FADD TEMP FPUT TEMP FGET I X2 FDIV TEMP FMUL TWO FADD ONE FEXT TAD FLAG2 TAD EXP DCA EXP ISZ T3 POPJ FINT FPUT I X2 FGET ONE FDIV I X2 FEXT POPJ /CONSTANTS FOR FEXP X2, X XSQ2, XSQR AF, 0004 2372 1402 BF, 7774 2157 5157 CF, 0012 5454 0343 DF, 0007 2566 5341 LG2E, 0001 2705 2435 ONE, 0001 2000 0000 TWO, 0002 2000 0000 NEGP, FNEG FLAG2, 0 TEMP, 0 0 0 0 /MAIN ALGORITHM FOR ARCTANGENT ARCALG, FINT FGET I X2 FMUL I X2 FPUT I XSQ2 FMUL BET2 FADD BET1 FMUL I XSQ2 FADD BETZ FPUT TEMP FGET ALF2 FMUL I XSQ2 FADD ALF1 FMUL I XSQ2 FADD ALFZ FMUL I X2 FDIV TEMP FEXT JMP I .+1 ARCRTN /CONSTANTS - FLOATING ARC TANGENT ALFZ, 0000 2437 1643 ALF1, 7777 3304 4434 ALF2, 7773 3306 5454 BETZ, 0000 2437 1646 BET1, 0000 2427 2323 BET2, 7775 3427 7052 PAGE /FLOATING POINT ARC TANGENT ARTN, GETSGN /TAKE ABSOLUTE VALUE SPA CLA JMS FNEG DCA T3 FINT FPUT X FSUB I CON1 FEXT GETSGN SPA CLA JMP GO /LESS THAN ONE FINT FGET I CON1 FDIV X FPUT X FEXT CLA CMA GO, DCA FLAG1 /SIGN FLAG OF RESULT JMP I .+1 ARCALG ARCRTN, ISZ FLAG1 /RETURN HERE JMP I EXIT1 FINT FPUT X FGET I PI2 FSUB X FEXT JMP I .+1 EXIT1, EXIT2 /CONSTANTS FOR ARCTANGENT PI2, PIOT CON1, ONE /FLOATING LOGARITHM FLOG, GETSGN SPA SNA ERROR2 /0 OR - ARGUMENT FOR LOG 274 /LM=LOG MINUS FINT FPUT I TEM FSUB I CON1 FEXT GETSGN SNA POPJ SMA CLA JMP STARTL FINT FGET I CON1 FDIV I TEM FPUT I TEM FEXT CLA CMA STARTL, DCA T3 TAD P13 DCA EXP CMA TAD I TEM DCA HORD DCA LORD DCA OVER2 IAC DCA I TEM FINT FMUL LOG2 FPUT X FGET I TEM FSUB I CON1 FPUT I TEM FMUL LOG8 FADD LOG7 FMUL I TEM FADD LOG6 FMUL I TEM FADD LOG5 FMUL I TEM FADD L4 FMUL I TEM FADD L3 FMUL I TEM FADD L2 FMUL I TEM FADD L1 FMUL I TEM FADD X FEXT JMP I EXIT1 L1, 0000 3777 7742 L2, 7777 4000 4100 L3, 7777 2517 0307 L4, 7776 4113 7211 /LOGARITHM CONSTANTS LOG5, 7776 2535 3301 LOG6, 7775 4746 0771 LOG7, 7774 2236 4304 LOG8, 7771 4544 1735 TEM, TEMP LOG2, 0 2613 4414 FLAG1, 0 FNEG, 0 JMS I MINSKI CLA CMA JMP I FNEG X, 0 0 0 0 XSQR, 0 0 0 0 PAGE /FLOATING POINT SINE AND COSINE FCOS, FINT /COS(X)=SIN(PI/2-X) FPUT I X1 FGET PIOT FSUB I X1 FEXT FSIN, GETSGN SMA SZA CLA JMP MOD GETSGN SMA CLA POPJ /YES SIN(0)=0 JMS I MINSKI CMA /NO:SIN(-X)=-SIN(X) MOD, DCA T3 FINT FDIV TWOPI /REDUCE X MODULO 2 PI FPUT I XSQR1 FEXT JMS I INTEGER FINT FNOR FPUT I X1 FGET I XSQR1 FSUB I X1 FMUL TWOPI FPUT I X1 FSUB PI /X .L. PI? FEXT GETSGN SPA CLA JMP PCHECK /YES FINT /NO, SIN(X-PI)=-SIN(X) FPUT I X1 FEXT TAD T3 CMA DCA T3 PCHECK, FINT /X.L.PI/2? FGET I X1 FSUB PIOT FEXT GETSGN SPA CLA JMP PALG /YES FINT /NO FGET PI /SIN(X)=SIN(PI-X) FSUB I X1 FPUT I X1 FEXT PALG, FINT FGET I X1 FDIV PIOT FPUT I X1 FMUL I X1 FPUT I XSQR1 FGET C9 FMUL I XSQR1 FADD C7 FMUL I XSQR1 FADD C5 FMUL I XSQR1 FADD C3 FMUL I XSQR1 FADD PIOT FMUL I X1 FEXT EXIT2, ISZ T3 POPJ JMS I MINSKI POPJ /CONSTANTS AND POINTERS TWOPI, 0003 3110 3755 /3756 3-WORD 2421 PI, 0002 3110 3755 /3756 3-W0RD 2421 PIOT, 0001 /USED BY SINE AND COSINE 3110 3755 /3756 3-W0RD 2421 X1, X XSQR1, XSQR /SINE CONSTANTS C9, 7764 2441 7015 1042 C7, 7771 5464 5514 6150 C5, 7775 2431 5361 4736 C3, 0000 5325 0414 3167 FRAN, FENT /PSEUDO RANDOM NUMBER FGET RNDM /X(1)=(2^17+3)*X(0) MOD.2^16 FPUT ADDR FEXT TAD M16 DCA T1S JMS I DOUBLE ISZ T1S JMP .-2 JMS I ADDO JMS I DOUBLE JMS I ADDO /2*(2^16*X+X)+X FINT FPUT RNDM FEXT DCA EXP CLA CLL CMA RAR /=3777 AND HORD DCA HORD /BE SURE IT'S POSITIVE POPJ M16, -16 ADDO, DUBLAD RNDM=. T1S, 0000 4421 3040 0001 PAGE /FLOATING SQUARE ROOT FUNCTION XSQRT, FINT FPUT I TITER /VALUE FEXT /NEWTON'S METHOD IS USED GETSGN SPA CLA ERROR2 /NUMBER IS NEGATIVE = IMAGINARY ROOTS 214 /IM=IMAGINARY TAD EXP /LINK =0 FROM FINT SPA /MATCH THE SIGN WITH LINK BIT CML RAR DCA SQAC /MAKE FIRST APPROXIMATION SZL /TEST LSB OF EXP ISZ SQAC NOP TAD SQCON1 DCA SQAC+1 DCA SQAC+2 DCA SQAC+3 TAD HORD SNA TAD LORD SNA CLA JMP SQEND /NUMBER = 0 CLCU, FINT FGET I TITER FDIV SQAC FADD SQAC FEXT CLA CMA TAD EXP DCA EXP TAD EXP CMA IAC TAD SQAC SZA CLA /ARE EXPONENTS EQUAL? JMP ROOTGO /NO TAD HORD /ARE HIGH ORDER MANTISSAS EQUAL? CMA IAC TAD SQAC+1 SZA CLA JMP ROOTGO /NO TAD LORD CMA IAC TAD SQAC+2 /DO LOW ORDER MANTISSAS AGREE? SMA CMA IAC /WITHIN ONE BIT? IAC SMA CLA POPJ ROOTGO, FINT FPUT SQAC FEXT JMP CLCU SQEND, DCA EXP POPJ SQCON1, 3015 TITER, ITER1 SQAC, 0 0 0 0 *XSQRT+100 /IN VERSION 2 AT 15700 FNTABL=. 2533 /ABS 2650 /SGN 2632 /OS8 2636 /ITR 2630 /RAN 2572 /ATN 2624 /EXP 2625 /LOG 2654 /SIN /LIST OF CODED FUNCTION NAMES 2575 /COS 2702 /SQT 1140 /IN 2672 /OUT 2604 /(F)IND 0324 /T 0325 /U 0326 /V 0327 /W 0330 /X 0331 /Y 0332 /Z -1 /ENDS TABLE / FUNCTIONS T,U,V,W,Y,Z NOT ASSIGNED (FREE FOR USER) / FOR CODING NAME, USE OCTAL CHARS WITH 200 BIT SET / AND CALCULATE THE FOLLOWING EXPRESSION: / / X=CHAR1 / IF CHAR2 THEN: X=X*2+CHAR2 / IF CHAR3 THEN: X=X*2+CHAR3 / THEN REPLACE A FREE SLOT BY THIS VALUE *XSQRT+126 /IN VERSION 2 AT 15726 FNTABF=. CDF L XABS /ABS -ABSOLUTE VALUE CDF L XSGN /SGN -REAL SIGN FUNCTION CDF L XOS8 /OS8 -OS8=1,MULTI8=0 FUNCTION CDF P XINT /ITR -INTEGER PART CDF P FRAN /RAN -RANDOM NUMBER * NOT CDF P ARTN /ATN - * LOADED CDF P FEXP /EXP -EXPO FUNCTIONS * WITH CDF P FLOG /LOG - * NO CDF P FSIN /SIN -TRIG FUNCTIONS * FUNCTIONS CDF P FCOS /COS - * OPTION CDF P XSQRT /SQT -SQUARE ROOT CDF P FIN /INP -CHAR INPUT CDF P FOUT /OUT -CHAR OUTPUT CDF P FIND /IND -FIND A CHAR CDF P ERCALL /T CDF P ERCALL /U CDF P ERCALL /V CDF P ERCALL /W CDF L XCOM /(F)X:ARRAY CDF P ERCALL /Y CDF P ERCALL /Z / THIS TABLE IS 2 TIMES LONGER THAN 'FNTABL' / INSERT THE FIELD AND ADRESS OF YOUR FUNCTION / IN THE APPROPRIATE FREE SLOT (CORRESPONDING / TO THE ONE SELECTED IN 'FNTABL'). BE SURE TO / LOAD A 'DPF0' SECTION IN THE FIELD YOU ARE / USING. SEE 'DPF0' FOR MORE INFO. /END OF ARIT OVERLAY PAGE /FIELD 1 ERROR ROUTINE ERROL+3 /FLD. 0 ERROR ROUTINE ADRESS ERROR, 0 /MUST BE AT THIS ADRESS!!USR.VOLATILE!! CLA CMA CLL TAD I ERROR /PASS ON CODE-1 CIF CDF L JMP I ERROR-1 ENDERR, DCA EOL /FORCE CR TAD SPC PRINTC ISZ PC /END OF ERROR ROUTINE;USES SUBS. IN THIS FIELD JMS I DPC DCA LINENO TAD LINENO JMP I .+1 RELESE /RELEASE MULTI-8 DEVICES /FLOATING OUTPUT CONVERSION ROUTINE FLOUTP, 0 JMS I PRNSGN /GO PRINT LEADER,SET SIGN JMS I ABSOL2 FGO2, DCA T3 /INITIALIZE DEZ EXP TAD EXP /IS EXP 0-4 ? SPA JMP FGO3 /TOO SMALL: MULT BY 10 SZA TAD M4 SPA SNA CLA JMP FGO4 FINT FMUL I PPTEN / /10 FEXT IAC TAD T3 JMP FGO2 FGO3, FINT FMUL I TENPT /*10 FEXT CMA JMP .-6 FGO4, DCA I DPT /MULTIPLY BY TWO TO POSITION BIT0 DCA I REPT /CLEAR OVERFLOW WORD TAD SADR /INIT BUFFER POINTER DCA FLTXR TAD EXP /COMPUTE BITS IN 1ST DIGIT CMA CLL DCA OUTDG /TEMP COUNT TAD DIGITS /SETUP COUNT OF TOTAL OUTPUT CMA DCA EXP JMS I DOUBLE /ROTATE OUT THE 1ST 4 BITS ISZ OUTDG JMP .-2 TAD I REPT /TEST FOR 10-15,0,1-9 SNA JMP FGO5 /IGNORE 1ST ZERO TAD FM12 SPA CLA JMP .+7 /0-9 IAC DCA I FLTXR /OUTPUT A 1 ISZ EXP /COUNT THE DIGIT TAD FM12 /CORRECT REMAINDER ISZ T3 /BUMP DECIMAL EXP NOP TAD I REPT /COMPUTE RESULTANT OR SECOND DIGIT ISZ T3 NOP SKP FGO5, JMS I M10PT /IE. .672X10=6+.72.. ETC. DCA I FLTXR ISZ EXP /ALL DIGITS OUTPUT?? JMP .-3 /NO:CONTINUE TAD SADR DCA FLTXR /RESET BUFFER POINTER JMS I ROUND /OUTPUT MANTISSA JMP I FLOUTP /FIXED POINT DONE TAD CHRT /PRINT "E" PRINTC /OUTPUT THE EXPONENT TAD I (BUFFER SZA CLA /IF #=0 KEEP EXP=0 CLA CMA TAD T3 /TAKE ABSOLUTE VALUE OF EXPONENT CLL SPA CIA CML DCA HORD /SAVE + POWER CMA RTL /PRINT SIGN TAD PER /.-3=+ ; .-1=- PRINTC TAD HORD ISZ EXP TAD M144 SMA JMP .-3 TAD C144 DCA HORD /SAVE TENS AND UNITS CMA /OUTPUT HUNDREDS TAD EXP SZA JMS OUTDG TAD HORD /PRINT TWO DIGITS JMS I PRNTI JMP I FLOUTP PRNSGN, SGNPRN PRNTI, PRNT CHRT, 305 /E M144, -144 /-100 C144, 0144 /+100 M4, -4 FM12, -12 PPTEN, PTEN /IEI DPT, DIGIT REPT, REMAIN /OVERFLOW FROM INTEGER MULTIPLY M10PT, MULT10 SADR, BUFFER-1 ROUND, TGO /ACTUAL OUTPUT ROUTINE TENPT, TEN ABSOL2, ABSOLV OUTDG, 0 TAD C260 PRINTC JMP I OUTDG RESOLV, 0 TAD SIGNF SPA CLA JMS I MINSKI CLA CLL JMP I RESOLV PAGE /FLOATING POINT INPUT FLINTP, 0 /IF C(AC)=0, USE CHAR SZA CLA /IF C(AC)#0, GET NEXT JMS I DINPUT /GET FIRST CHAR TSTCHR 7540 /-SPACE SKP JMP .-4 JMS I DPCVPT /READ FIRST DIGIT GROUP TSTCHR /ENDED BY PERIOD? -". JMP FIGO1 JMS I DINPUT /YES, READ SECOND GROUP DCA I DPN JMS I DCONP TAD I DPN /SAVE NUMBER OF DIGITS IN T3 CMA IAC FIGO1, DCA T3 /NO TAD P43 DCA EXP JMS I RESOL5 JMS I INORM /NORMALIZE FIRST ,THEN FINT /SAVE NUMBER FPUT I PT1 FEXT TSTCHR /"E" READ IN? -"E JMP ENDFI+3 /NO JMS I DINPUT /YES, READ 3RD DIGIT GROUP JMS I DPCVPT /I.E. CONVERT DECIMAL EXPONENT JMS I RESOL5 TAD OVER2 TAD T3 /C(SEXP) PLACES TO RIGHT OF LAST DIGIT DCA T3 /COMPENSATE FOR DECIMAL EXPONENTS ENDFI, FINT /RESTORE MANTISSA FGET I PT1 FEXT TAD T3 /TEST DECIMAL EXPONENT SNA JMP I FLINTP /FINISHED SMA CLA JMP FIGO4 FINT /. IS TO THE LEFT: FMUL PTEN /TIMES .1000 FPUT I PT1 FEXT IAC JMP .+6 FIGO4, FINT /. IS TO THE RIGHT: FMUL TEN /TIMES TEN FPUT I PT1 FEXT CMA TAD T3 DCA T3 JMP ENDFI+3 TEN, 0004 2400 0000 0000 PTEN, 7775 3146 3146 /3147 3-WORD 3150 DPCVPT, DECONV DCONP, DECON RESOL5, RESOLV DPN, DNUMBR DINPUT, INPUT INORM, DNORM P43, 43 ABSOLV, 0 TAD HORD DCA SIGNF TAD HORD SPA CLA JMS I MINSKI JMP I ABSOLV MINUS2, 0 /NEGATE OPERAND CLA CLL /TRIPLE PRECISION TAD OVER1 CMA IAC DCA OVER1 TAD AC1L CMA SZL IAC CLL DCA AC1L TAD AC1H CMA SZL IAC CLL DCA AC1H JMP I MINUS2 XRTD, 0 CDF T TAD I XRT CDF P JMP I XRTD PCD, 0 CDF T TAD I PC CDF P JMP I PCD THISD, 0 CDF T TAD I THISLN CDF P JMP I THISD PT1D, 0 CDF T TAD I PT1 CDF P JMP I PT1D XPUSHJ, 0 MQL FLD1 CIF T JMS I .+1 ZPUSHJ FILER, CIF CDF L JMP I .+1 FILEST ENDCOM, 0 /GO TO END OF COMMAND SORTC TLIST /; CR. JMP I ENDCOM GETC JMP .-4 PAGE /DOUBLE PRECISION DEZIMAL BINARY /INPUT AND CONVERSION FOR + OR - XXX.... DECONV, 0 DCA LORD DCA EXP /ZERO THE EXP AND DCA HORD /INITIALIZE FLAC DCA OVER2 DCA DNUMBR DCA SIGNF TAD CHAR /ALLOW KEYBOARD SIGN CHECKS TAD MPLUS SNA JMP .+6 /PLUS SIGN; GET NEXT TAD M2 /CHECK MINUS SIGN SZA CLA JMP .+4 CMA /INIT SIGN CHECK TO POS. DCA SIGNF JMS I XINPUT /GET NEXT TAD CHAR /A SPACE PERHAPS ? TAD MSPACE SNA CLA JMP .-4 JMS DECON JMP I DECONV DECON, 0 TAD CHAR /TEST LEAD. CHAR FOR TERMINATOR TAD MINE SNA CLA JMP I DECON /E TESTN JMP I DECON /. JMP DTST /OTHER TAD SORTCN /N DSAVE, DCA DIGIT /YES JMS MULT10 /REMAIN MUST =0 SINCE OVERFL. IS CHECKED ISZ DNUMBR /COUNT DIGITS SZA CLA ERROR2 /INPUT OVERFL ERROR 316 /MO=MANTISSA OVERFLOW JMS I XINPUT JMP DECON+1 /CONTINUE DTST, TAD CHAR /ALLOW A-Z TAD MINUSA SPA CLA JMP I DECON TAD CHAR TAD MINUSZ SZA SMA CLA JMP I DECON /USE 6 BITS OF ASCII TAD CHAR AND P77 JMP DSAVE MINE, -305 MINUSZ, -332 MPLUS, -253 MSPACE, -240 MINUSA, -"A XINPUT, INPUT MULT10, 0 /ROUTINE TO MULTIPLY FLAC BY 10 TAD OVER2 DCA OVER1 TAD LORD /DOUBLE PRECISION WORD DCA AC1L /BY 10(DEZ) TAD HORD /REMAIN=REMAINDER DCA AC1H DCA REMAIN /CLEAR OVERFLOW WORD JMS MULT2 /CALL SR TO JMS MULT2 /MULT BY 2 JMS DUBLAD /CALL DOUBLE ADD JMS MULT2 TAD DIGIT /ADD LAST DIGIT RECEIVED DCA OVER1 DCA AC1L DCA AC1H JMS DUBLAD TAD REMAIN /EXIT WITH REMAINDER JMP I MULT10 /IN AC REMAIN, 0 DIGIT, 0 /STORAGE FOR DIGIT DNUMBR, 0 /= NUMBER OF DIGITS MULT2, 0 /MULTIPLY OVER2, LORD, HORD BY TWO TAD OVER2 CLL RAL /CARRY INSERT BIT IS IN LINK DCA OVER2 TAD LORD RAL DCA LORD TAD HORD RAL DCA HORD TAD REMAIN RAL DCA REMAIN JMP I MULT2 DUBLAD, 0 /TRIPLE PRECISION ADDITION CLA CLL TAD OVER2 TAD OVER1 DCA OVER2 RAL TAD LORD TAD AC1L DCA LORD RAL TAD HORD TAD AC1H DCA HORD RAL TAD REMAIN DCA REMAIN JMP I DUBLAD DIV1, 0 /SHIFT OPERAND RIGHT CLA CLL /TRIPLE PRECISION TAD AC1H SPA CLL CML RAR DCA AC1H TAD AC1L RAR DCA AC1L TAD OVER1 RAR DCA OVER1 ISZ EX1 JMP I DIV1 JMP I DIV1 PAGE /FLOATING POINT INTERPRETER FOR FOCAL FPNT, 0 7600 /CLA;REFERENCED CLL NOP /DCA OVER1 NOP /DCA OVER2 3-WORD TAD I FPNT /GET NEXT INSTRUCTION SNA JMP I FPNT /FAST EXIT DCA JUMP TAD JUMP AND C200 /GET PAGE BIT SNA CLA /PAGE ZERO? JMP .+3 /YES TAD FPNT+1 /NO AND FPNT /C(FPNT) 0-4 CONTAINS PAGE BITS DCA ADDR TAD P177 /GET 7 BIT ADRESS AND JUMP TAD ADDR DCA ADDR TAD INDRCT /INDIRECT BIT =1? AND JUMP SNA CLA JMP LOOP01 /NO- GO ON TAD I ADDR /YES, DEFER W/O AUTO-INDEX DCA ADDR LOOP01, ISZ FPNT CMA TAD ADDR DCA FLTXR2 TAD JUMP /GET COMMAND CLL RTL RTL AND P17 /GET BITS 0-2,I.E. OPCODE SNA JMP FLGT TAD TABLE /LOOK UP THE TABLE DCA JUMP TAD I JUMP SNA JMP FLPT DCA JUMP TAD CEX1 /SAVE FLOATING ARGUMENT,UNLESS 'GET' OR 'PUT' DCA FLTXR TAD MFLT DCA CNTR TAD I FLTXR2 DCA I FLTXR ISZ CNTR JMP .-3 JMP I JUMP /GO THERE JUMP, 0 ADDR=EX1 INDRCT, 0400 TABLE, ITABLE FLPT, TAD CEXP /EXP TO (ADDR) JMP .+5 FLGT, TAD CEXP /(ADDR) TO EXP DCA FLTXR2 CMA TAD ADDR DCA FLTXR /SAVE 'FROM' ADRESS TAD MFLT /3 OR 4 WORDS DCA CNTR TAD I FLTXR DCA I FLTXR2 ISZ CNTR JMP .-3 JMP FPNT+1 CEXP, EXP-1 CEX1, EX1-1 FLSU, JMS I OPMINS /FSUB = 2, NEGATE THE OPERAND FLAD, JMS I ALGN /FLAD = 1, FIRST ALIGN EXPONENTS JMP FPNT+1 /RETURN IF NO ALIGMENT IS POSSIBLE JMS I RAR2 /TRIPLE PRECISION ADDITION JMS I RAR1 /SINCE BITS ARE SHIFTED JMS I TRAD /RIGHT NORF, JMS I NORM /NORMALIZE THE RESULT JMP FPNT+1 /HINT: USE 700X FOR FUNCTIONS /INTERPRETIVE POWER FLEX, TAD HORD /ZERO? SZA CLA JMP .+6 ZERO, DCA EXP /YES DCA HORD DCA LORD DCA OVER2 JMP FPNT+1 PUSHF /AC TO A + POWER FLAC PUSHF /SETUP ARGUMENT (THE EXPONENT) EX1 POPF FLAC JMS I INTEGER /ONLY POSITIVE, INTEGER EXPONENTS SPA JMP .+5 /(COULD DIVIDE) CMA DCA JUMP /TEMP STORAGE NOP /DCA OVER1 3-WORD TAD HORD SZA CLA ERROR2 /TOO LARGE OR NEGATIVE EXPONENT 116 /EO=EXPONENT OVERFLOW PUSHF /INITIALIZE TO ONE FLTONE POPF FLAC POPF ITER1 JMP .+6 PUSHF ITER1 POPF EX1 JMS I MULT /"MULT" ISZ JUMP JMP .-6 JMP FPNT+1 FLMY, JMS I MULT /MULTIPLY JMP FPNT+1 OPMINS, MINUS2 MULT, DMULT NORM, DNORM ALGN, ALIGN RAR1, DIV1 RAR2, DIV2 TRAD, DUBLAD PAGE ACMINS, 0 /ROUTINE TO COMPLEMENT FLAC - VIA "MINSKI" CLL CLA TAD OVER2 /TRIPLE PRECISION NEGATION CMA IAC /OF FLOATING AC DCA OVER2 TAD LORD CMA SZL IAC CLL DCA LORD TAD HORD CMA SZL IAC CLL DCA HORD JMP I ACMINS ALIGN, 0 /SUBROUTINE TO ALIGN TAD HORD /BINARY POINTS SNA TAD LORD SNA CLA /IS MANTISSA ZERO? JMP NOX1 /YES, RESULT=OPERAND TAD AC1H /NO, IS OPERAND ZERO? SNA TAD AC1L SNA TAD OVER1 SNA CLA JMP I ALIGN /YES, EXIT TAD EX1 CMA IAC TAD EXP SNA /ARE EXPONENTS EQUAL? JMP ADONE DCA ACMINS TAD ACMINS SMA /NO CIA /NEGATE AND DCA AMOUNT /SAVE THE DIFFERENCE TAD AMOUNT TAD TEST2 SPA CLA /CAN THE EXPONENTS BE ALIGNED? JMP NOX /NO, USE LARGER OF THE TWO TAD ACMINS /YES, SHIFT THE SMALLER SMA CLA JMP ASHFT JMS DIV2 ISZ AMOUNT JMP .-2 JMP ADONE ASHFT, CMA TAD EX1 DCA EX1 JMS I TAG1 ISZ AMOUNT JMP .-2 ADONE, ISZ ALIGN JMP I ALIGN NOX, TAD EX1 /MISSION IMPOSSIBLE! SMA CLA /CHECK FOR SIGN DIFFERENCE JMP NOX2 TAD EXP SMA CLA JMP I ALIGN /-+ JMP .+3 /-- NOX2, TAD EXP SMA CLA TAD ACMINS /TEMP STORAGE OF DIFFERENCE, SMA SZA CLA /-BOTH POSITIVE EXP OR BOTH NEG JMP I ALIGN /OK (+-) NOX1, TAD EX1 /USE LARGER DCA EXP TAD AC1H DCA HORD TAD AC1L DCA LORD TAD OVER1 DCA OVER2 JMP I ALIGN AMOUNT, 0 TAG1, DIV1 P27, 27 ABSOL, ABSOLV RESOL, RESOLV /LEAVE 12 BIT ANSWER IN AC UPON RETURN /LEAVE FLAC AS AN INTEGER FIX, 0 /VIA (INTEGER) JMS I ABSOL TAD EXP /TEST FOR FRACTION SPA SNA CLA JMP FIXM /DOUBLE CHECK FOR MINUS ONE IAC DCA OVER1 TAD P27 /INIT ALIGNEMENT DCA EX1 JMS ALIGN /DO THE ALIGNEMENT TO AN INTEGER TEST2, 0043 /ALREADY DONE; (27) FOR 3-WORD DCA OVER2 /CLEAR THE FRACTION JMS I RESOL TAD LORD /EXIT WITH LOW ORDER RESULT IN AC JMP I FIX FIXM, DCA EXP /CLEAR EXPONENT DCA HORD DCA LORD JMP TEST2+1 DIV2, 0 /SHIFT FLAC RIGHT CLA CLL TAD HORD SPA CML RAR DCA HORD TAD LORD RAR DCA LORD TAD OVER2 RAR DCA OVER2 ISZ EXP JMP I DIV2 JMP I DIV2 FLTZER, ZBLOCK 4 FLARG, ZBLOCK 4 PAGE /(A+B+C)*(D+E+F)=C*F,C*E,B*F,C*D,A*F,B*E,A*E,B*D,A*D DMULT, 0 /N-PRECISION MULTIPLY WITH IAC /PRODUCT IN TRIPLE PRECISION TAD EX1 /ADD EXPONENTS + 1 JMS SIGN /AND DETERMINE SIGN OF RESULT SPA CLA JMS I MINI DCA DATUM-1 /INIT RESULT DCA DATUM-2 DCA DATUM-3 DCA DATUM-4 TAD A /A*D SAVE /STORE IN MP2 TAD D /SINGLE PREC MULT MULTY 2 /ACCUM START IN #2 DATA WORD TAD E /A*E MULTY 3 TAD B /B*D SAVE TAD D MULTY 3 TAD E /B*E MULTY 4 DCA DATUM-5 /JMP DMDONE 3-WORD DCA DATUM-6 TAD F /A*F SAVE TAD A MULTY 4 TAD B /B*F MULTY 5 TAD C /C*D SAVE TAD D MULTY 4 TAD E /C*E MULTY 5 TAD F /C*F MULTY 6 DMDONE, TAD DATUM-1 /COPY RESULT DCA HORD TAD DATUM-2 DCA LORD TAD DATUM-3 DCA OVER2 JMS MULDIV NOP /DCA OVER2 3-WORD JMP I DMULT DATUM=.+6 /INTERMEDIATE STORAGE /#6-LOW ORDER /#5 /#4 /#3 /#2 /#1-HIGH ORDER *DATUM-1 MULDIV, 0 /TERMINATE MULTIPLY AND DIVIDE ISZ SIGNF /CORRECT FOR SIGN JMS I MINSKI JMS I NORMF /SHIFT LEFT NOP /ISZ OVER2 3-WORD JMP I MULDIV FLDV, TAD AC1H /4:DIVIDE SNA CLA ERROR2 /DIVISION BY ZERO 70 /DI=DIV TAD EX1 /SUBTRACT EXPONENTS+1 CMA IAC IAC JMS SIGN /SET UP SIGNS SMA CLA JMS I MINI /NEGATE DIVISOR JMS I DIVIDE /DIVIDE JMS MULDIV JMP I .+1 FPNT+1 /THIS SUBROUTINE PREPARES MULTIPLY AND DIVIDE /FOR ANY COMBINATION OF SIGNED ARGUMENTS AND FOR ZERO /THE RESULT OF EITHER IS ZERO IF FLAC = 0 /RESULT OF MULTIPLY IS ZERO IF EITHER IS ZERO; /DIVISION BY ZERO IS CHECKED BERFORE THIS /ROUTINE IS CALLED /THE CALLING AC CONTAINS AN UPDATE VALUE FOR THE /EXPONENT, THE RETURNING AC CONTAINS THE SIGN OF /THE ARGUMENT FOR FURTHER TESTING BY EACH ROUTINE. SIGN, 0 /TEST AND SAVE SIGN OF RESULT TAD EXP /COMPUTE NEW EXP FOR MUL-DIV. DCA EXP CLL CML RAR /LOAD 4000 TO XOR THE SIGN BITS AND HORD TAD AC1H SMA CLA /RESULT MAY BE ZERO CMA DCA SIGNF /+=-1;-=0 TAD HORD SNA JMP I REVIT /ANSWER IS ZERO SPA CLA /TAKE ABSOLUTE VALUE OF FLAC JMS I MINSKI TAD AC1H SNA /RESULT OF EITHER MAY BE ZERO JMP I REVIT JMP I SIGN MINI, MINUS2 REVIT, ZERO NORMF, DNORM DIVIDE, DUBDIV SAVE=DCA I . MP2 MULTY=JMS I . MP4 A=HORD B=LORD C=OVER2 D=AC1H E=AC1L F=OVER1 ITABLE=.-1 FLAD FLSU FLDV FLMY FLEX 0000 NORF XINTEG, JMS I INTEGE MQL /PRESERVE AC OVER POPJ POPJ BUFFER=. ITER1, ZBLOCK 13 PAGE MP4, 0 /SINGLE PREC,UNSIGNED "MULTY" SNA JMP I MP4 /NO RESULT ADDED DCA MP1 DCA MP5 TAD THIR DCA MP3 CLL MP6, TAD MP1 RAR DCA MP1 TAD MP5 SNL JMP .+3 CLL TAD MP2 RAR DCA MP5 /SAVE HI ORDER ISZ MP3 JMP MP6 TAD MP1 /CORRECT LO ORDER RAR DCA MP3 TAD I MP4 /PICKUP SCALE FACT. CIA TAD DATUMA DCA MP1 TAD MP3 /LO ORDER CLL TAD I MP1 /ACCUMULATE DCA I MP1 ISZ MP1 RAL TAD MP5 TAD I MP1 DCA I MP1 SNL JMP I MP4 /NO CARRY ISZ MP1 ISZ I MP1 JMP I MP4 JMP .-3 /CARRY AGAIN DATUMA, DATUM MP5, 0 /PRODUCT MP1, 0 /MULTIPLIER MP3, 0 MP2, 0 /MULTIPLICAND THIR, -14 /12 BITS MIF, -43 /-27 3-WORD DUBDIV, 0 /2 OR 3 PRECISION DIVIDE DCA MP4 DCA MP1 TAD MIF /INIT BIT COUNTER DCA MP3 SKP DV3, JMS I DOUBLE /SHIFT FLAC LEFT CLL TAD OVER1 /----FROM HERE 4-WORD TAD OVER2 DCA MP5 RAL TAD AC1L /COMBINE ONE POSITION AND TAD LORD DCA MP2 /SAVE RESULT RAL TAD HORD /ADD OVERFLOW TAD AC1H SNL /SKIP IF OVERFLOW JMP .+6 DCA HORD /UPDATE FLAC TAD MP5 DCA OVER2 TAD MP2 DCA LORD CLA /CLEAR ACCUMULATOR TAD MP1 /SAVE OVERFLOW BITS CIRCULARLY RAL DCA MP1 TAD MP4 RAL DCA MP4 TAD DNORM RAL /EXTRA FOR 4-WORD DCA DNORM ISZ MP3 /TEST FOR END OF DIVIDE JMP DV3 TAD DNORM DCA HORD TAD MP4 DCA LORD TAD MP1 DCA OVER2 JMP I DUBDIV DNORM, 0 /SUB TO NORMALIZE JMS I ABSOL3 JMS TEST4 TAD HORD SNA /IS MANT.=0? TAD OVER2 SNA TAD LORD SNA CLA JMP EXIT3 TAD HORD RAL CLL SPA CLA /WILL SHIFT TOO FAR? JMP .+6 JMS I DOUBLE CMA CLL TAD EXP DCA EXP JMP .-10 JMS I RESOL3 JMS TEST4 /DON'T LEAVE 4000 JMP I DNORM EXIT3, DCA EXP JMP I DNORM TEST4, 0 /TEST FOR 4000 TAD HORD SPA CIA SPA CLA JMS I XRAR2 /SHIFT BACK JMP I TEST4 XRAR2, DIV2 ABSOL3, ABSOLV RESOL3, RESOLV PAGE XLIST EJECT IO-UTILITY-INIT XLIST /****** STORAGE ALLOCATION MAP ****** /***** ***** /* 200 START,OCLOSE,NOCHAR,OSETUP /* 400 OOPEN,ICHAR,FILEST,EXITOS /* 600 IOPEN,POP,NAMEVL,XABS,XSGN,XOS8 /* 1000 NAME,GTMON,DISMISS /* 1200 HANDAD,COMPARE,LOADER,IOWAIT /* 1400 SAVPR,ENDLOD,OROI /* 1600 LOWLIB,LOADS,GOSUB,RETOUR,FILSEC /* 2000 OPEN,BUMP,XIN,EXIT,MORE /* 2200 XCOM,CORITE,CCLOSE /* 2400 COHNDL,ARRAY,LOWOUT,COCLR /* 2600 XIDLE,XOUT,ERROL /* 3000 ERROL,LOWIN,TERMNL COMBUF=3200 OUTBUF=5200 /ALSO INIT ##SEE BELOW## INBUFF=5600 /* 6200 OUTPUT HANDLER /* 6600 INPUT HANDLER /* 7200 LIBRARY AND COMMON HANDLER /***** ***** /************************************ /***** COMMAND DECODER INIT ***** /* /* 3200 KEYER,APPEN /* 3600 MONTHS /* 36XX DEVICES /* 4200 CDTBL /* 4400 USRTBL /* 4600 SETUP 1 /* 5000 SETUP 2 /* 5200 SETUP 3 /* 5400 SETUP 4 /* 5600 SETUP SUBS /* 6000 POPS PAGE /* 6200 HEADER PAGE /* ---- REST OVERLAYS-PATCHES /* 7200 ALWAYS RESERVED /***** ***** /************************************ FIELD 0 *1 CIF 30 /INTERRUPT? SERVICE ROUTINE JMP 1 /FOR SYMBIONT PAUS, -1 LINLEN, -110 PAGLEN, -110 CHRCNT, 0 LINCNT, 0 /AUTO-INDEX REGISTERS AUTO1, 0 /GENERAL AUTO2, 0 /COMPARE AUTO3, 0 /COMPARE INFLG, 0 /FILE INPUT:1,TTY:0,EOF:-1 INECH, 0 /INPUT ECHO:0,NO ECHO:-1 OUTFLG, 0 /FILE OUTPUT:1,TTY:0 OUTECH, 0 /OUTPUT ECHO:0,NO ECHO:-1 ERRCOD, 0 XCNTR, 0 /GENERAL COUNTER- USR, 7700 /POINTER TO MONITOR (200 IF USR IN) NAMLOC, ZBLOCK 3 /USED BY NAME EXTENS, 0 /"FC", "FD", OR "FN" NEWDEV, ZBLOCK 2 /USED BY NAME TEM7, 0 ATEM, 0 /KEEP HERE : TPOPF NEWDEV /DEFINE LOWER FIELD INSTRUCTIONS . . . DRONE=JMS I . XIDLE TSORTJ=JMS I . SORTB TINTEG=JMS I . MINTEG ERROR1=JMS I . ERROL TPOPA=JMS I . MPOPA TPUSHA=JMS I . MPUSHA TPUSHF=JMS I . MPUSHF TPOPF=JMS I . MPOPF TPUSHJ=JMS I . MPUSHJ TPOPJ=JMP I . MPOPJ ECHFLG, 0 /-1:NO ECHO OPNFLG, 0 /OOPEN:-1;OCLOSE:0 IPNFLG, 0 /IOPEN:-1;EOF:0 OUTINH, 0 /NOT LAST BLK:0,LAST BLK:1 DEVHLD, 0 /OOPEN:DEV. NO. FOR CLOSE FILEN, 0 /SPECIFIED FILE LENGTH [] FLNGTH, 0 /SET BY OPEN STBLK, 0 /SET BY OPEN DEVNO, 0 /SET BY HANDAD LIBFIL, 0 /START BLK OF SAVED PROG;UNSAVED:0 LIBBLK, 0 /FOR DEVICE NAME 0 7200 /LOAD POINT 0 /FOR DEVICE # LIBHND, 0 /HANDLER ENTRY INBLK, 0 0 6600 0 INHND, 0 OUTBLK, 0 0 6200 0 OUTHND, 0 DERR, ERROR1 /DEVICE ERROR 64 /DE=DEV.ERR. CHARL, 0 DCHAR, CHAR CLNGTH, 0 /SET BY COMMON COMFLG, 0 /1:WRITE;0:READ SETBLK, 0 /THE RELATIVE BLOCK IN USE THSBLK, 0 /ASKED FOR BLOCK COWRIT, 1 /WRITE:1 READ:0 TELSW, 0 GOSWIT, 0 MONA, 0 LISA, 0 YEAR, 0 INBUF, 0 DEPTH, 0 DXOUT, XOUT LF, 212 /RELOC PROBLEMS MECH, 3 /MULTI8 ECHO SWITCH WAIT, -1 /WAIT COUNTER PAGE /OS/8 FILE ROUTINES /CHAIN WITH AC=0 FOR PROCEED,1:START,2:GOSUB,3:GOTO,4:WRITE MAINTR, CLA IAC /MAIN ENTRY-POINT CHENTR, JMP I STRTSW /CHAIN ENTRY-POINT - - IFNDEF KEY < TPUSHF /OR 'DCA STRTSW' AFTER INIT MONHUK /INSTALL CTRL.C HOOK TPOPF 7600> IFDEF KEY < NOP;NOP;NOP;NOP> DCA TELSW /ALLOW TTY: TO START CLA CMA TAD STRTSW SNA CLA JMP I AAMESG /GO START DIRECT MODE TAD STRTSW CONTIN, DCA GOSWIT /GO BACK TO 'PROC':MAIN FLOW JMP I [EXITOS AAMESG, RESTRT STRTSW, SETUP OCLOSE, 0 /CLOSE THE OPEN OUTPUT FILE TAD OPNFLG SNA CLA /DON'T BOTHER IF IT ISN'T OPEN JMP I OCLOSE DCA OPNFLG /MUST BE HERE! DCA OUTINH /WE CAN CLOSE THE LAST BLK TAD [232 /WRITE '^Z' JMS I [NOCHAR TAD OPTR1 /PAD BUFFER WITH ZEROS TAD (-OUTBUF /(AND WRITE IT OUT) SZA CLA JMP .-4 JMS I [GTMON TAD DEVHLD /SAVED DEVICE # CIF 10 JMS I USR 4 /CLOSE ONMTMP /POINTER TO SAVED NAME BLKCNT, 0 /FILE LENGTH; ZEROED BY OOPEN JMP DERR /HUH? DCA OUTFLG /RESTORE TELETYPE OUTPUT ROUTINE JMP I OCLOSE /DO WHATEVER ELSE NEEDS TO BE DONE /OS/8 3/2 BUFFERED CHARACTER OUTPUT NOCHAR, 0 /ENTER WITH 2XX ISZ O3 /WHICH CHAR OF THREE?;-3 INITIALLY JMP O2 /STRAIGHT PACKING JMS RT /HALF WORD PACKING - PACK FIRST HALF TAD ATEM /GET SAVED ARG JMS RT /PACK SECOND HALF CLA CLL CMA RTL /RESET 3-WAY SWITCH DCA O3 ISZ OCHCT /BUFFER CAN ONLY BE FILLED JMP I NOCHAR / WITH 3RD CHAR OF 3 JMS I [PUTDEV /TELL USR THIS HANDLER'S IN OUTHND-1/POINTER TO DEVICE # AND ENTRY TAD OUTINH /LAST BLOCK? SZA CLA JMP OOVER /YES, CLOSE IN EXTREMIS JMS I OUTHND /WRITE ONE BLOCK BUFFER 4200 OUTBUF OBLK, 0 /SET BY OOPEN JMP DERR /DEVICE ERROR ISZ OBLK /BUMP OUTPUT BLOCK ISZ BLKCNT /AND COUNT OF BLOCKS SO FAR CLA CLL TAD OLNGTH /-MAXIMUM ALLOWABLE LENGTH+1 TAD BLKCNT /LENGTH SO FAR SZL CLA /HAS HE GONE TOO FAR? ISZ OUTINH /YES;MUST CLOSE BEFORE NEXT END TAD OUTINH /ONE WORD LESS IN NEXT BLOCK JMS OSETUP /RESET POINTERS FOR NEXT BUFFER JMP I NOCHAR O2, DCA I OPTR1 /NORMAL PACKING IS EASY! ISZ OPTR1 /BUMP POINTER JMP I NOCHAR O3=. /WHY NOT? RT, 0 /HALF-WORD PACK ROUTINE CLL RTL RTL DCA ATEM /SAVE FOR SECOND HALF TAD ATEM AND [7400 TAD I OPTR2 /ADD IN CHARACTER IN RIGHT HALF DCA I OPTR2 /PACK IT ISZ OPTR2 /BUMP POINTER AGAIN JMP I RT OOVER, CLA CMA /THERE IS JUST ROOM FOR CTRL.Z DCA OCHCT /LET CLOSE WRITE IT FROM ERROR ERROR1 345 /OF=OUTPUT FULL OSETUP, 0 /RESET ALL THE POINTERS TAD [7600 /THIS IS CHANGED TO -177 DCA OCHCT / FOR LAST BLOCK TAD OBLK-1 DCA OPTR1 TAD OBLK-1 DCA OPTR2 CLA CLL CMA RTL DCA O3 JMP I OSETUP OPTR1, 0 OPTR2, 0 OLNGTH, 0 /SET BY OOPEN OCHCT, 0 COMPO, SAVER FETCHER CHAINER BUMP GOSUB RETOUR LEXIT LOADER FOCTXT, FILENAME FOCAL.TM /USED BY GOSUB TTYTXT, DEVICE TTY NAMGO, NAMEVL PERD ECHCHK CHANEL RESTOR NAMLEN NAMEC MONHUK, CIF CDF L 5602 /'JMP I .+1' MEXIT CNMTMP, ZBLOCK 4 PAGE OOPEN, TAD [ORST /RESTORE ADRESS JMS I [OPEN /CALL USR, HANDLER; ENTER FILE YINT, OUTBLK-1/OUTPUT HANDLER BLOCK 3 /MONITOR 'ENTER' CODE JMP TTYOUT /'OPEN OUTPUT TTY:' JMP I (OCLCHK /SEE IF FILE OPEN TPUSHF /SAVE NAME AND EXTENSION NAMLOC TPOPF ONMTMP TAD STBLK /STARTING BLOCK DCA I (OBLK /IN NOCHAR TAD FLNGTH /-MAXIMUM ALLOWABLE LENGTH CLL IAC /CHECK IF ONE BL0CK LONG DCA I (OLNGTH /IN NOCHAR (+1) RAL /IF ONE LONG, LINK SET DCA OUTINH /SEND OUT ^Z AT END OF FIRST BUFF TAD OUTINH /ADJUST CHAR.CNT. JMS I (OSETUP /SET UP PACKING POINTERS CLA CLL CMA /THERE'S A FILE OPEN! DCA OPNFLG TAD DEVNO /SAVE FOR CLOSE DCA DEVHLD DCA I (BLKCNT /DITTO ORST, TAD OPNFLG /ENTRY FOR 'OPEN RESTORE OUTPUT' SZA CLA /IF 'OPEN OUTPUT', FLAG IS SET CLA IAC /SET OUTPUT TO NOCHAR TTYOUT, DCA OUTFLG /SET OUTPUT TO TTY (INTERRUPT) TAD ECHFLG DCA OUTECH /SET OUTPUT ECHO JMP I [CONTIN /FINISH THE LINE MINTEG, 0 /INTEGER FAKE CDF P TPUSHJ XINTEG MQA /RESTORE AC OVER POPJ JMP I MINTEG ICHAR, 0 /GET A CHARACTER FROM A FILE CLA CLL CML /MAKE SURE-SET LINK FOR KEY BIT ISZ INCHT /NEED ANOTHER BUFFER?;-1 INITIALLY JMP I RDPTR /NO, UNPACK THE CHARACTER JMS I INHND /YES, GO GET IT 0200 INBUFF IBLK, 0 /SET BY IOPEN SMA CLA /ONLY BOTHER WITH FATAL ERRORS SKP CLA /REFERENCED! JMP DERR /WE'VE GOT ONE JMS I [DISMIS ISZ IBLK /BUMP TO NEXT BLOCK TAD IBLK-1 /AND RESTORE POINTERS DCA IPNTR CLA CMA /-1 FOR FIRST TIME ROUND TAD [-600 DCA INCHT ICHARL, JMS RDPTR /FIRST TIME AND KEY IN POS. 0 RTL RTL SPA /KEY IN POS. 0? JMP ICHARL /YES;READ IN COMBINED WORD DCA ITEMP /SAVE HALF-WORD AND KEY:POS.8-4-0 TAD I IPNTR /GET FULL WORD JMS RDPTR TAD I IPNTR /GET HALF WORD ISZ IPNTR AND [7400 /ISOLATE CLL RAL /MAGIC STEP TAD ITEMP /ADD IN OTHER HALF? AND KEY JMP ICHARL+1 /GO SHIFT MORE AND TEST IF FULL RDPTR, 0 /THIS IS A COROUTINE AND [177 /ISN'T THAT AMAZING? SNA /IGNORE NULLS AND PARITY JMP ICHAR+1 TAD (-32 /END OF FILE? (^Z) SZA JMP .+4 /NO DCA IPNFLG /YES, CLEAR OPEN FILE FLAG CLA CMA /PREVENT AN DCA INFLG /'ATTEMPT-TO-READ-PAST-EOF'! TAD [232 /PASS ^Z TO PROGRAM FOR TESTING JMP I ICHAR ITEMP, 0 IPNTR, 0 INCHT, 0 /SET TO -1 BY IOPEN ONMTMP, ZBLOCK 4 FILEST, TAD (604 /HERE'S WHERE FILES START! DCA EXTENSION /SET '.FD' ASSUMED EXTENSION CDF P TPUSHJ TERMER MQA CIF P TSORTJ /GO DO COMMAND FILIST-1 FILGO-FILIST ERROR1 /OOPS - BAD 'O' COMMAND 36 /BO=BAD OPEN COMMAND FILGO, IOPEN OOPEN OROI OCLOSR ARRAY CCLOSR FILIST, "I /INPUT "O /OUTPUT "R /RESTORE "C /CLOSE "A /ARRAY=COMMON "T /TERMINATE(COMMON) SAVER, JMS I [NAME /GET NAME FOR SAVE JMS I (SAVPR /DO IT EXITOS, JMS I [DISMIS /NORMAL RETURN FOR OS/8 COMMANDS TAD GOSWIT CDF CIF 10 JMP I .+1 LIBRET PAGE IOPEN, TAD (IRST /RESTORE ADRESS JMS I [OPEN /CALL GENERAL-PURPOSE SUBROUTINE INBLK-1 2 /MONITOR 'LOOKUP' JMP TTYIN /'OPEN INPUT TTY:' JMP IRST+2 /WHOOPS - FILE NOT FOUND TAD STBLK /SET POINTERS AND OTHER CRAP DCA I (IBLK /IN ICHAR CLA CLL CMA DCA IPNFLG CLA CLL CMA DCA I (INCHT /IN ICHAR IRST, TAD IPNFLG /'OPEN RESTORE INPUT' COMES HERE SNA CLA /FLAG IS SET ALREADY IF 'OPEN INPUT' ERROR1 /NO INPUT FILE TO RESTORE 330 /NI=NO INPUT FILE CLA IAC /SET I/O POINTERS TTYIN, DCA INFLG TAD ECHFLG /AND ECHO MODE DCA INECH CLA STL IAC RAL /=3 + ECHO=0/NO ECHO=-1 TAD INECH DCA MECH /=> MULTI8 ECHO=3/NO ECHO=2 JMP I [CONTIN FLD0=CLA CLL /PDL SATELLITES;FIELD 0 MPOPA, 0 MQL FLD0 CIF T JMS I .+1 ZPOPA MPUSHA, 0 MQL FLD0 CIF T JMS I .+1 ZPUSHA MPUSHF, 0 MQL FLD0 CIF T JMS I .+1 ZPUSHF MPOPF, 0 MQL FLD0 CIF T JMS I .+1 ZPOPF MPUSHJ, 0 MQL FLD0 CIF T JMS I .+1 ZPUSHJ MPOPJ, CIF CDF T JMP I .+1 ZPOPJ /THE FOLLOWING CODE WILL RECOGNIZE FOR EX.L C DATA(X) /AND LOOK FOR DATA99 IF X=99 NAMEVL, TAD I (NAMECT /CHECK NUMBER OF CHARS TAD (-4 /AT MOST 4 SMA SZA CLA EVLERR, ERROR1 135 /FN=FILE NAME ERROR DCA ATEM /CLEAR TEN COUNTER CDF P /GO TO EVAL TPUSHJ /'('READY,DUMP ')' EVAL-1 TINTEG TAD (-144 /.LT. 100 (DEC) SZL /NOW WE HAVE X-100 JMP EVLERR TAD [12 /X-100+ATEM*10 ISZ ATEM SPA JMP .-3 MQL /OVERFLOW IS LOW ORDER TAD ATEM /ATEM IS 10 - HIGH ORDER CIA /HIGH ORDER - 10 TAD [12 /HIGH ORDER TAD [60 /6-BIT ASCII JMS I (NAMSTO MQA /LOW ORDER AGAIN TAD [60 JMS I (NAMSTO JMP I (NAMEC XOS8, CDF P /OS8-MULTI8 FUNCTION 6254 /SKIP ON MULTI8 JMP YOS8 /OS8=1 TPUSHF FLTZER /MULTI8=0 JMP NOS8 XSGN, CDF P /REAL SIGNUM FUNCTION TAD I (HORD SNA CLA TPOPJ /FSGN(0)=0 YOS8, TPUSHF /DF P! FLTONE NOS8, CDF P TPOPF FLAC XABS, CDF V /TAKE ABS OF FLAC TAD I FLARGH SMA CLA TPOPJ CDF P TPUSHJ MMINSK TPOPJ FLARGH, FLARG+1 DCWBM, 7757 GETDEV, 0 /GET DEVICE TYPE FROM MONITOR TABLE TAD DCWBM /DCB-1 TAD DEVNO DCA MPOPA CDF P TAD I MPOPA CDF L JMP I GETDEV PAGE /LIBRARY COMMAND PROCESSOR /READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV' NAME, 0 DCA NAMRET /SETUP RESTORE RETURN DCA FILEN /SET TO LARGEST EMPTY JMS I [DISMIS /'GETC' WON'T WITH THE USR IN CORE TAD [5723 /CODE FOR 'DSK:' DCA NEWDEV /(DEFAULT DEVICE) NAME2, DCA NEWDEV+1 DCA NAMLOC /CLEAR NAME AREA DCA NAMLOC+1 /(DON'T CLEAR ASSUMED EXTENSION) DCA NAMLOC+2 TAD [NAMLOC /INITIALIZE POINTERS DCA NMBASE CLA CMA DCA PERDSW NAME3, DCA NAMECT NAMEC, CDF P TPUSHJ MGETC NAMENC, CLA CLL CMA DCA ECHFLG /INIT. ECHO FLAG CIF P TSORTJ NAMLST-1 NAMGO-NAMLST JMS DECODE /MUST BE A-Z, 0-9 JMP NAMOUT /NO!, NOR IN NAMLST:END OF NAME SZL /RESTORE CHARACTER TAD (57 IAC /6-BIT ASCII JMS NAMSTO JMP NAMEC /CONTINUE LOOP NAMSTO, 0 DCA DECODE /TEMPORARY STORAGE TAD NAMECT /NO MORE THAN 6 CHARACTERS/NAME TAD [-6 US7700, SMA CLA JMP NAMEC TAD NAMECT /BUILD POINTER TO CHARACTER POS CLL RAR TAD NMBASE DCA TT TAD DECODE /LEFT OR RIGHT HALF? SNL BSW /LEFT, SHIFT OVER TAD I TT /ADD IN OTHER HALF DCA I TT ISZ NAMECT /BUMP COUNT JMP I NAMSTO PERD, TAD NAMLOC /FOUND A PERIOD IN STRING SZA CLA ISZ PERDSW ERROR1 /DOUBLE PERIODS OR NO FILE NAME 35 /BN=BAD NAME IN FILES DCA EXTENSION /CLEAR EXTENSION ISZ NMBASE /FAKE OUT POINTERS TAD [4 JMP NAME3 CHANEL, TAD NAMLOC /MOVE TO DEVICE AREA DCA NEWDEV TAD NAMLOC+1 JMP NAME2 /GET FILENAME RESTOR, TAD NAMRET /COMES HERE ON '"' SZA DCA NAME /CHANGE RETURN IF NON. 0 JMP NAMEC ECHCHK, CDF P /MOVE PAST COMMA TPUSHJ MGETC CDF P TPUSHJ /MOVE TO END KEEP FIRST TERMER MQA TAD (-"E /MUST BE 'E' NAMOUT, SNA CLA /DECODE 'NO' EXIT IS NON-ZERO DCA ECHFLG /SET ECHO FLAG JMP I NAME DECODE, 0 /CHECK FOR A-Z, 0-9 TAD CHARL /IF YES ISZ RETURN TAD (-"9-1 CLL TAD ["9+1-"0 SZL JMP DCDYES /NUMBER;CHAR-260;L=1 TAD ("0-"Z-1 CLL CML TAD ("Z-"A+1 SNL DCDYES, ISZ DECODE /ALPHA;CHAR-301;L=0 JMP I DECODE NMBASE, 0 PERDSW, 0 NAMECT, 0 TT, 0 NAMRET, 0 NAMLEN, CDF P /INDICATE OPT. FILE LENGHT TPUSHJ EVAL-1 /GETS NUMBER IN [] TINTEG CLL RTL RTL AND [7760 DCA FILEN JMP NAMEC GTMON, 0 /LOCK THE USR IN CORE /(NOP IF ALREADY IN CORE) CDF L CIF P JMS I USR 10 TAD [200 /SET POINTER FOR LATER CALLS DCA USR JMP I GTMON DISMIS, 0 /IF THE USR IS IN, KICK IT OUT CLA CLL CDF L /MAKE SURE TAD USR /CHECK POINTER TO FIND OUT SPA CLA JMP I DISMIS CIF P JMS I USR 11 TAD US7700 /RESET POINTER DCA USR JMP I DISMIS PAGE /HANDAD CALL: HANDAD /SLOT /SETS DEVNO; DEVICE NO. IN SLOT; ENTRYPOINT IN SLOT HANDAD, 0 /LOADS HANDLER INTO PROPER SLOT TAD I HANDAD /WHICH SLOT? ISZ HANDAD DCA SLOT JMS COMPARE /IF THE HANDLER HAS THE SAME NAME, -2 /DON'T LOAD IT AGAIN SLOT, 0 NEWDEV-1 JMP NOTEQ /DIFFERENT NAMES, LOAD NEW HANDLER ISZ AUTO2 TAD I AUTO2 /(SET BY 'COMPARE') DCA DEVNO /MOVE DEVICE# (FOR SAVE AND CLOSE) TAD AUTO2 /POINTS TO DEVICE # DCA .+2 JMS I [PUTDEV /SO USR KNOWS IT'S IN CORE 0 JMP I HANDAD 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 JMS I [GTMON RETRY, TAD NEWDEV /MOVE DEVICE NAME FOR MONITOR CALL DCA DEVC TAD NEWDEV+1 DCA DEVC+1 TAD I SLOT /MOVE LOAD POINT IAC /TWO PAGE HANDLER! DCA DLOAD CIF P JMS I USR /CALL MONITOR (ALREADY IN CORE) 1 /FETCH BY NAME DEVC, 0 /NAME 0 /RETURNS DEVICE NO. DLOAD, 0 /RETURNS ENTRY POINT ERROR1 /DEVICE NOT AVAILABLE 323 /ND=NO DEVICE CLL TAD DLOAD /ENTRY POINT FOR HANDLER TAD [200 /IF THIS HANDLER IS IN PAGE 7600, SZL CLA /DON'T CHECK FOR LEGALITY JMP HANDOK /SYSTEM HANDLER TAD DLOAD /IF THE HANDLER WAS NOT LOADED AND [7600 /INTO THE PROPER PAGE, RELOAD IT CLL CIA TAD I SLOT /PROPER LOADING ADDRESS SNA CLA JMP HANDOK /EVERYTHING'S ALL RIGHT DCA DLOAD /CLEAR ENTRY POINT JMS I [PUTDEV /TELL USR THE HANDLER IS NOT DEVC+1 /IN CORE ANYMORE JMP RETRY /LOAD IT THIS TIME HANDOK, ISZ SLOT /BUMP POINTER TO DEVICE # TAD DEVC+1 /SAVE IT DCA I SLOT ISZ SLOT /MOVE TO ENTRY POINT TAD DLOAD /SAVE ENTRY DCA I SLOT TAD DEVC+1 /GET DEVICE # DCA DEVNO /SAVE IT AND EXIT JMP I HANDAD COMPARE,0 /COMPARE TWO BLOCKS TAD I COMPARE /CALLING SEQUENCE: ISZ COMPARE /JMS COMPARE DCA XCNTR / -# OF WORDS TO CHECK TAD I COMPARE / FIRST-1 ISZ COMPARE / SECOND-1 DCA AUTO2 /RETURN IF NO MATCH TAD I COMPARE /RETURN IF MATCH ISZ COMPARE DCA AUTO3 AGAIN, TAD I AUTO2 /COMPARE TWO WORDS CIA TAD I AUTO3 SZA CLA JMP I COMPARE /NO MATCH ISZ XCNTR /FINISHED? JMP AGAIN /NO, CHECK NEXT TWO ISZ COMPARE /YES, BUMP RETURN POINTER JMP I COMPARE NAMLST, "( /SUBSCRIPTED FILE NAMES ". /EXTENSION ", /ECHO ": /DEVICE "" /RESTORE OLD IN/OUT "[ /FILE LENGHT SPEC. " /SPACE: IGNORE /THIS IS FOR CHAINING TO ANOTHER PROGRAM LOADER, JMS I [OCHK /DON'T FORGET TO CLOSE THE FILES JMS I [NAME /OR FOR OVERLAYING FOCAL ITSELF TAD (2326 /EXTENSION "SV" IS FORCED ON DCA EXTENSION /IT HAS TO BE A SAVE FILE:CHAIN JMS I [IOWAIT TAD [NAMLOC /POINTER TO NAME DCA LOADUS+2 CLA STL RTL /=2 DCA LOADUS+1 IAC /CHAIN EXPECTS IT TO BE ON SYS: CIF P LOADUS, JMS I USR 2 /LOOKUP RETURNS FILE START IN ARG2 NAMLOC 0 ERROR1 /USR DID NOT FIND IT 47 /CH=CHAINING ERROR DCA LIBBLK /KILL LIB HANDLER;CHAIN DOES RESET CLA IAC STL RTL /OK! CHANGE USR FUNCTION TO CHAIN=6 DCA LOADUS+1 JMP LOADUS-1 /BY-BY!! MIGHT SEE YOU AGAIN COMLIST,"S /SAVE "C /CALL "R /RUN "D /DELETE "G /GOSUB 215 /'LIBRARY RETURN' "E /EXIT "L /LOAD; CHAIN A PROGRAM OCLOSR, JMS I [OCLOSE /CLOSE OUTPUT FILE JMP I [CONTIN IOWAIT, 0 DRONE TAD TELSW SZA CLA JMP .-3 JMP I IOWAIT PAGE CODENU, 0 SAVPR, 0 /CALLED BY 'SAVER' AND 'GOSUB' TAD [NAMLOC /POINTER TO NAME DCA SAVEPT CDF P TAD I (BUFR DCA BLOCK /SAVE TEMP. PROGRAM LENGTH CDF T TAD [LINE0+2 DCA AUTO1 /SET AUTO-INDEX FOR TRNSFR. TAD NAMLOC DCA I AUTO1 TAD NAMLOC+1 DCA I AUTO1 /TRANSFER NAME TAD NAMLOC+2 DCA I AUTO1 TAD EXTENS BSW AND [77 TAD (5600 DCA I AUTO1 /TRANSFER .F TAD EXTENS AND [77 BSW DCA I AUTO1 /REST OF EXTENSION: C@ TAD MONA /GET MONTH NAME DCA I AUTO1 /SAVE TAD LISA /SECOND HALF+ "-" DCA I AUTO1 TAD YEAR DCA I AUTO1 /SAVE YEAR TAD BLOCK IFNDEF KEY< DCA I LINPUT /SAVE PROGRAM LENGTH > IFDEF KEY< CLA CLL > JMS I [GTMON /GET USR;RESETS DF JMS I [OCHK /CLOSE OUTPUT FILE, AVOID TROUBLE JMS I [HANDAD /AND GET HANDLER LIBBLK-1 TAD BLOCK AND [7600 /MASK OFF CLL RAR /CONVERT TO PAGES DCA BLOCK /FOR HANDLER TAD BLOCK /ROUND UP TO BLOCKS TAD [100 AND [7600 CLL RTR RAR DCA RECORD /FOR MONITOR 'ENTER':BITS 0-7 TAD DEVNO /PREDELETE FILE CIF 10 JMS I USR 4 NAMLOC 0 LINPUT, LINE0-1 /SKIP ERROR TAD RECORD /GET DESIRED LENGTH TAD DEVNO /(SET BY 'HANDAD') CIF 10 JMS I USR /ENTER OUTPUT FILE 3 SAVEPT, NAMLOC 0 ERROR1 /NO ROOM ON DEVICE 65 /DF=DEVICE FULL TAD RECORD /SHIFT FOR CLOSING LENGTH - CLL RTR / - OR '0' *KEY* RTR DCA SAVBLK TAD DEVNO /CLOSE THE FILE BEFORE WE WRITE IT! CIF 10 /(SURE, IT'S CHEATING, BUT JMS I USR /IT SAVES TIME!) 4 /CLOSE NAMLOC SAVBLK, 0 /NO. OF BLOCKS JMP DERR /IMPOSSIBLE ERROR! TAD SAVBLK /SAVE THIS CRAP TO REMEMBER CIA /WHERE THIS PROGRAM IS DCA LIBLEN /IN CASE WE WANT TO GOSUB TAD SAVEPT DCA LIBFIL TAD NEWDEV DCA LIBDEV TAD NEWDEV+1 DCA LIBDEV+1 TAD SAVEPT /MOVE STARTING BLOCK FOR WRITE DCA POINT4 TAD WRFUN /GET FUNCTION WORD OR 'TAD [OCLOSE' *KEY* TAD BLOCK /HOW MUCH TO WRITE /=220 READ!! DCA BLLL JMS I LIBHND BLLL, 0 /WRITE (BLOCK) BLOCKS FROM FIELD 2 200 /FROM 200 UP POINT4, 0 JMP DERR /GO COMPLAIN ABOUT DEVICE JMP I SAVPR WRFUN, 4021 /WRITE IN FIELD 2 FORW LIBLEN, 0 /SAVED LENGTH LIBDEV, ZBLOCK 2 RECORD, 0 BLOCK, 0 ENDLOD, TAD NEWDEV /SAVE THIS STUFF SO WE DCA LIBDEV /KNOW WHERE WE ARE TAD NEWDEV+1 DCA LIBDEV+1 TAD STBLK DCA LIBFIL TAD FLNGTH DCA LIBLEN CDF T TAD CODENU TAD I (PC0+2 DCA SAVBLK TAD I (PC0+2 SZA JMP SAVCIF TAD I LINPUT KEYRES, CDF P DCA I (BUFR CIF CDF L IFNDEF KEY< JMP I [EXITOS 1234 > IFDEF KEY< JMP I .+1 KEYER > SAVCIF, CIF T JMP I SAVBLK PAGE /ACTUAL LIBRARY PROCESSOR /STARTING WITH COMMAND DECODE: LOWLIB, DCA GOSWIT TAD [617 /NEW EXTENSION .FO DCA EXTENSION CDF P TPUSHJ TERMER MQA CIF P TSORTJ /AND BRANCH TO APPROPRIATE ROUTINE COMLIST-1 COMPO-COMLIST LIERR, ERROR1 /SORRY, CHARLIE! 270 /LI=LIBRARY COMMAND ERROR /LOOKUP AND LOAD ROUTINES CHAINER,ISZ GOSWIT /THESE ALL DO THE SAME THING GOSUB1, ISZ GOSWIT /AND THEN GO TO DIFFERENT PLACES FETCHER,ISZ GOSWIT JMS I [OPEN /CALL THE HANDLER AND LOOKUP FILE LIBBLK-1 2 JMP .+6 /TTY: NOT A DIRECTORY DEVICE ERROR1 337 /NP=NO PROGRAM FOUND JMS I [DISMISS JMS I [GETDEV /GET DEVICE TYPE SMA CLA ERROR1 /NOT A DIRECTORY DEVICE 63 /DD=NOT A DIR. DEV. CDF P TPUSHJ PGETLN /SOME COMMANDS HAVE LINE NUMBERS LOADGO, JMS I [DISMISS /ONLY USED BY 'RETOUR' TAD STBLK /BLOCK TO READ FROM DCA POINT6 CLA CLL CMA RAL /(=-2) TAD GOSWIT /IS THIS A GOSUB? SZA CLA JMP NOGOSB /NO, SKIP THIS GARBAGE TAD CHARL /YES, SAVE PROGRAM NAME, ETC. TPUSHA /PDL NOW CONTAINS: TAD [215 /CHAR,DEV,FILE LENGTH,START BLOCK CDF P DCA I DCHAR NOGOSB, TAD FLNGTH /COMPUTE FUNCTION WORD CMA /BLOCKS-1 BSW CLL CML RAL /SET TO SEARCH FORWARD DCA LENF1 TAD FLNGTH /NOW CHECK FOR LENGHT TAD (17 /.LE. 15(10) SPA JMP PLERR /READING IN NONSENSE SZA CLA /IS IT MAX. LENGTH? TAD [100 /NO: READ ALL TAD (120 /YES: READ 1 PAGE LESS (SET FIELD) TAD LENF1 DCA LENF1 /FINAL CONTROL WORD CDF T TAD I (PDLXR /BOTTOM OF PDL CIA CLL RAR /TEST CTW-(PDL-200)/2 TAD [100 /FOR PAGE 0 TAD LENF1 PLERR, CDF L SPA CLA ERROR1 /PROGRAM TOO LONG 373 /PL=PROGRAM LENGTH ERROR JMS I LIBHND /GET THE PROGRAM LENF1, 3521 /LARGEST CTW 200 POINT6, 0 JMP DERR JMP I (ENDLOD /REMARK: THE PDL MAY NOT BE LOWER THAN 7444 FOR / A PROGRAM OF MAXIMAL LENGTH (15 BLKS). GOSUB, TAD LIBFIL /CHECK FOR CURRENT PROGRAM SZA JMP NOSAVE /NO NEED TO SAVE CORE TPUSHF /MOVE 'FOCAL.TM' TO NAME AREA FOCTXT TPOPF NAMLOC TAD [5723 /DEVICE 'DSK' FOR SAVE DCA NEWDEV DCA NEWDEV+1 JMS I (SAVPR /SAVE FILE (LEAVE USR IN CORE) TAD [617 /RESET EXTENSION TO 'FO' DCA EXTENSION TAD LIBFIL /STARTING BLOCK NOSAVE, TPUSHA /'LIBFIL' STILL IN AC TAD I (LIBLEN TPUSHA TPUSHF LIBDEV ISZ DEPTH JMP GOSUB1 RETOUR, STA CLL TAD DEPTH DCA DEPTH /KEEP COUNT OF SUBS SNL JMP LIERR TPOPA /GET BACK ALL THE JUNK WE SAVED CDF 10 /FOR THE LAST GOSUB DCA I DCHAR /IN-LINE CHARACTER CDF TPOPF /DEVICE NAME NEWDEV TPOPA /FILE LENGTH DCA FLNGTH TPOPA /STARTING BLOCK DCA STBLK JMS I [HANDAD /GET THE HANDLER BACK LIBBLK-1 JMP LOADGO /LOAD THE PROGRAM COCLR, 0 /CLEAR COMMON BUFFER TAD (COMBUF-1 /DON'T TOUCH LINK! DCA AUTO1 TAD [-2000 DCA XCNTR DCA I AUTO1 ISZ XCNTR JMP .-2 JMP I COCLR PAGE /MISCELLANEOUS GENERAL-PURPOSE ROUTINES /THIS IS THE GENERAL OPEN SUBROUTINE /CALLNG SEQUENCE: /JMS I [OPEN /HANDLER BLOCK /MONITOR CALL CODE /RETURN IF TTY: IS DEVICE /ERROR RETURN /NORMAL RETURN /SETS STBLK, FLNGTH ON PAGE ZERO OPEN, 0 JMS I [NAME /GET DEVICE AND FILENAME JMS I (COMPAR /DEVICE 'TTY:' IS SPECIAL -2 NEWDEV-1 TTYTXT-1 JMP OTHER /DEVICE OTHER THAN TTY ISZ OPEN /INCREMENT TO PROPER RETURN ISZ OPEN JMP I OPEN OTHER, TAD I OPEN /GET HANDLER BLOCK TO USE DCA HND ISZ OPEN TAD [NAMLOC /POINTER TO NAME DCA NAMPT JMS I [GTMON JMS I [HANDAD /GET THE HANDLER HND, 0 /SET TO HANDLER BLOCK TAD I OPEN /GET MONITOR CALL CODE (2 OR 3) ISZ OPEN DCA CALL DCA LNGTH /FOR MONITOR KLUDGE TAD DEVNO /DO THE CALL TAD FILEN /ADD IN OPT. FILE LENGHT CIF 10 /DEV # IN AC JMS I USR /2: LOOKUP CALL, 0 /3: ENTER NAMPT, NAMLOC /NAME POINTER;RETURNS START BLOCK LNGTH, 0 /RETURNS -FILE LENGTH IN BLOCKS /TENTATIVE FOR ENTER JMP OTHER-2 /CALLING ROUTINE HANDLES ERROR TAD LNGTH /MOVE PARAMETERS TO PAGE ZERO DCA FLNGTH TAD NAMPT DCA STBLK JMP OTHER-3 /AND TAKE NORMAL RETURN BUMP, JMS I [NAME /DELETE IS AN EASY ONE (THANK GOD!) JMS I [GTMON JMS I [HANDAD LIBBLK-1 JMS I [OCHK /CLOSE ANY OPEN OUTPUT FILE CIF 10 /DELETE THE FILE TAD DEVNO JMS I USR 4 NAMLOC 0 ERROR1 123 /FD=FILE DELETION ERROR DCA LIBFIL /IF CURRENT PROGRAM DELETED JMP I [EXITOS OCLCHK, TAD OPNFLG SNA CLA ERROR1 344 /OE=OPEN OUTPUT ERROR JMS I [OCLOSE TAD (YINT DCA OPEN JMP OTHER PUTDEV, 0 /TELL USR A HANDLER IS IN OR OUT TAD I PUTDEV /GET POINTER TO DEV# AND ENTRY DCA XIN TAD I XIN /DEVICE# ISZ XIN /BUMP POINTER TO ENTRY TAD (7646 /MONITOR TABLE DCA PUTTEM /POINTER TO 'HANDLER IN CORE' FLAG TAD I XIN /FLAG IS HANDLER ENTRY CDF P /TABLE IS IN FIELD ONE DCA I PUTTEM CDF L ISZ PUTDEV JMP I PUTDEV PUTTEM, 0 MEXIT, KCC JMS I [IOWAIT /BE SURE ^C CAN BE SENT TAD (203 JMS I [TERMNL /TYPE ^C LEXIT, TPUSHF /LIBRARY EXIT ROUTINE RESMON /ALSO USED BY CTRL.C TPOPF 7600 /RESTORE MONITOR CALL JMS I [OCHK /CLOSE FILES JMS I [DISMISS /BOOT USR OUT JMS I [IOWAIT /WAIT FOR TTY;IOF JMP I [7600 /LEAVE FOCAL XIN, 0 /VIA (INDEV) JMS I [IOWAIT STA DCA WAIT /CLEAR WAIT KSF JMP .-1 DRONE TAD INBUF DCA PUTDEV DCA INBUF KCC TAD PUTDEV SNA JMP XIN+1 /IGNORE KILLER NULL JMP I XIN OROI, CDF P TPUSHJ TERMER MQA TAD (-"I SNA CLA TAD (IRST-ORST TAD [ORST /DEFAULT O R O DCA I [NAME /FAKE OUT NAME JMP I (NAMENC /TO SET ECHO MODE /LEIDER NO SPACE /MORE, 0 / CDF V / NOP /SKIP1 / JMP MORE2 /VAR. FLD STILL ON / DCA I XNMBSG /CLEARS HORD VAR "#" / NOP /CLEAR1 /MORE2, NOP /SKIP2 / JMP MORE3 / DCA I XEXCLA /VARIABLE "!" / NOP /CLEAR2 /MORE3, NOP /SKIP3 / JMP I MORE / DCA I XQUOTS /VARIABLE """ / NOP /CLEAR3 / JMP I MORE /XNMBSG, NMBSGN /XEXCLA, EXCLA /XQUOTS, QUOTS CONVER, 0 TAD (-33 SNA CLA JMP CONESC TAD (136 JMS I DXOUT /TYPE ^ TAD [100 JMP I CONVER /AND CONVERT;100+LOWIN=ALPHA CONESC, TAD ["$-33 JMP I CONVER PAGE XCOM, TINTEG /COMMON FOR 4096 4-W. VARIABLES DCA BLKTMP TAD BLKTMP AND [377 /ADRESS IN BUFFER CLL RTL /*4 : 4-WORD TAD I (COSTA /START OF BUFFER TPUSHA TAD BLKTMP AND [7400 /:8 BUFFERS BSW /OF 4 BLOCKS EACH TPUSHA /STORE RECURSIVELY TPUSHJ /PUT OR GET? ARG CLA CMA /GET DCA GEPUSW /PUT TPOPA /GET BLOCK # TPUSHJ COMEXT /GET BLOCK ISZ GEPUSW JMP COMPUT TPOPA /NOW GET ADRESS DCA GEPUSW TPUSHF GEPUSW, COMBUF CDF P TPOPF FLAC TPOPJ COMPUT, TPOPA DCA BLKTMP CDF P TPUSHF FLAC TPOPF BLKTMP, COMBUF IAC DCA COWRIT TPOPJ ARG, TAD CHARL TAD [-", SZA CLA TPOPJ CDF P TPUSHJ EVAL-1 IAC TPOPJ COMEXT, DCA THSBLK /ASKED FOR BLOCK TAD THSBLK CIA TAD SETBLK /IS IT ALLREADY HERE? SNA CLA TPOPJ /YES.EXIT CLL CML IAC RAL /+3 SO THAT WE DON'T TAD THSBLK / WRITE ON ANOTHER FILE TAD CLNGTH /SET TO 0 BY CCLOSE SMA CLA ERROR1 /WE ARE ASKING FOR TO MUCH! 4 /AE=ARRAY EXCEEDING CORE LIMITS JMS CORITE /WRITE OUT IF ANY MODIFICATIONS TAD COMFLG /AND CLEAR BUFFER IF WRITE SNA CLA /NEW OR OLD? JMP COINPT /OLD TAD COCNT /LARGEST SO FAR CIA TAD THSBLK SPA CLA JMP COINPT /THSBLK .LT. COCNT;ALREADY OUT TAD COCNT DCA SETBLK /SET TO WRITE AND CLEAR NEXT BUFF JMP COMEXT+1 COINPT, CLA CLL /LNK=0 FOR READ TAD THSBLK /READ ASKED FOR BLOCK MQL JMS I (COHNDL TAD THSBLK DCA SETBLK /NOW SET CURRENT BLOCK TAD COMFLG /IF NEW FILE SET WRITE FLAG, IF OLD DCA COWRIT /CLEAR WRITE FLAG TPOPJ CORITE, 0 /ALSO CALLED BY CCLOSE TAD COWRIT SNA CLA /ONLY WRITE IF NEW DATA JMP I CORITE CLA CLL CML /LNK=1 FOR WRITE TAD SETBLK /WRITE BLOCK IN CORE MQL JMS I (COHNDL JMS I (COCLR /NOW CLEAR BUFFER TAD SETBLK CIA TAD COCNT /CHECK IF LAST BUFFER SZA CLA JMP I CORITE CLA CLL IAC RTL /4 TAD COCNT DCA COCNT /UPDATE COCNT JMP I CORITE /SUBROUTINE CALLED BY 'OPEN TERMINATE' AND 'OCHK' CCLOSE, 0 TAD CLNGTH SNA CLA JMP I CCLOSE JMS CORITE TAD COMFLG SNA CLA JMP CLOOUT /ONLY CLOSE INTERNALLY JMS I [GTMON TAD DEVNO CIF P JMS I USR 4 /CLOSE CNMTMP COCNT, 0 ERROR1 2 /AC=ARRAY CLOSE ERROR CLOOUT, DCA CLNGTH /ONLY INCORE FX() NOW DCA SETBLK /AND ONLY FX(0)-FX(255) JMP I CCLOSE CCLOSR, JMS I [CCLOSE JMP I [CONTIN RESMON, 4207 /'JMS SHNDLR' 5000 /WRITE 10 PAGES FIELD 0 0000 /FROM ADRESS 0 0033 /IN BLOCK 33 PAGE COHNDL, 0 /SUB FOR READING OR WRITING ARRAY BUFFER SZL JMP .+6 /WRITE TAD SETBLK /READ TAD [12 /IF LAST WRITTEN BLOCK+4+7 CMA TAD THSBLK /IS SMALLER THAN ASKED FOR BLOCK CLA RTL /ROTATE LINK FOR SEARCH FORWARD TAD [2000 /HERE LNK=0:READ;1:WRITE RAR /5000:WRITE;1000:READ;8 PAGES DCA COARG /1001:READ FORWARD MQA /BLOCK TAD CBLOCK /FIRST OF FILE DCA COSTA+1 TPUSHF COMDEV TPOPF NEWDEV /GET HANDLER BACK JMS I [HANDAD LIBBLK-1 JMS I LIBHND COARG, 0 COSTA, COMBUF 0 JMP DERR JMS I [DISMIS JMP I COHNDL CBLOCK, 0 COMDEV, ZBLOCK 2 /"OPEN ARRAY" ARRAY, JMS I [CCLOSE //FILE STILL OPEN? TAD (0601 /ASSUMED EXTENSION .FA DCA EXTENS JMS I [OPEN LIBBLK-1 2 /FIRST DO A LOOKUP JMP NODIR /TTY NOT A DIRECTORY DEVICE SKP CLA /THERE WAS NO FILE OF THAT NAME JMP COMON /FOUND IT! TAD ARPNT /FAKE 'OPEN' FOR ENTER DCA I [OPEN JMP I (OTHER LIBBLK-1 3 /ENTER ARPNT, .-2 /IT CAN'T COME HERE;ALREADY TESTED ERROR1 /DEFINITELY AN ERROR 5 /AF=ARRAY FULL CLA IAC /1 IF NEW FILE COMON, DCA COMFLG /SET NEW/OLD FLAG JMS I [GETDEV /I.E. A DISPLAY IS NO GOOD SMA CLA NODIR, ERROR1 3 /AD=ARRAY DEVICE ERROR TPUSHF /EVERYTHING IS OK NAMLOC TPOPF CNMTMP /SAVE NAME FOR CLOSE TAD NEWDEV DCA COMDEV TAD NEWDEV+1 DCA COMDEV+1 TAD STBLK DCA CBLOCK /SAVE FIRST BLOCK CLL TAD FLNGTH TAD [100 /IS LENGTH GREATER THAN 100BLOCKS? SNL CLA CLL /YES;IGNORE TAD NODIR-1 /-100 DCA CLNGTH /STORE LENGTH .LE. 100 (NEG) DCA I (COCNT /NEW LENGTH IS ZERO DCA THSBLK /FIRST BLOCK IS IN CORE TPUSHJ /SET SETBLK=THSBLK, COWRIT=COMFLG COINPT /AND READ FIRST BUFFER (EVEN IF NEW) TAD COMFLG /IS IT AN NEW FILE? SZA CLA JMS I (COCLR /YES, CLEAR BUFFER OF FIRST BLOCK (HAS RUBBISH) JMP I [CONTIN OCHK, 0 /IF ANY FILE EXISTS CLOSE IT JMS I [CCLOSE JMS I [OCLOSE JMP I OCHK LOWOUT, 0 /OUT DRIVER DCA LOWOTM CDF P TAD I [ECHO /CHK ECHO TAD INECH SPA CLA /0+-1:NO PRINT JMP OUTOUT TAD LOWOTM TAD (-216 /IS IT CRONLY? SZA /YES; CHANGE TO REAL CR IAC /NO; DON'T CHANGE CHAR SNA /IF 215-216 RESET TABC DCA I (TABC TAD (215-240 /IS IT PRINTING? SMA ISZ I (TABC /YES INC TABC NOP TAD [240 DCA LOWOTM CDF L TAD OUTFLG SNA CLA /0:TTY JMP LOWTTO TAD LOWOTM JMS I [NOCHAR /WRITE ON FILE TAD OUTECH SZA CLA /0:ECHO JMP OUTOUT LOWTTO, TAD LOWOTM JMS I [TERMNL /ON TTY OUTOUT, CDF L DRONE CIF CDF P JMP I LOWOUT LOWOTM, 0 PAGE XIDLE, 0 CLA CLL RDF TAD CCDI DCA INTEXI+1 CDF L KSF /CHECK FOR KEYBOARD FIRST JMP TINT /MORE TO COME CTRLSO, KRS /INPUT CHARACTER AND [177 /IGNORE BLANK AND L-T AND PARITY BIT SNA JMP TINT-1 /GO INITIATE NEXT READ TAD [200 DCA XTEMP TAD XTEMP TAD [-203 /CTRL.C? SNA JMP I DMEXIT /YES TAD [-20 SNA /CTRL S? JMP CTRLS TAD [2 SNA /CTRL.Q? JMP TINT-1 /KILL TAD [2 /(CHAR-217)/2=0 FOR CTRL.O AND P CLL RAR /IS IT? SNA CLA JMP RECOVR /YES A BREAK TAD INBUF SNA TAD XTEMP DCA INBUF CDF V TAD INBUF DCA I XDOL /SAVE IN INPUT VARIABLE SKP KCC TINT, TSF JMP INTEXI DCA TELSW /TURN OFF THE IN-PROGRESS-FLAG CDF P TAD I OPTRI SNA JMP INTEXI TLS /TYPE NEXT DCA TELSW /CLEAR AC AND TURN ON THE FLAG DCA I OPTRI /ZERO OUT THE DATA AREA TAD OPTRI IAC AND K37 TAD OPTR0 DCA OPTRI INTEXI, CLA / JMS I DMORE HLT JMP I XIDLE XDOL, DOLL XTEMP, 0 /DMORE, MORE DMEXIT, MEXIT OFILES=7600 OPTR0, OFILES OPTRO, OFILES OPTRI, OFILES CTRLS, KCC /KILL ^S IN BUFFER KSF JMP .-1 /WAIT FOR GODOT JMP CTRLSO /USE GODOT XOUT, 0 /VIA (OUTDEV) DCA ERROL ISZ CHRCNT K37, 37 CDF P TAD I OPTRO /ANY ROOM ? SNA CLA /A CHAR. IS NONZERO JMP .+4 CCDI, CIF CDF 0 DRONE /NO = WAIT JMP .-6 TAD TELSW /IN PROGRESS ? MIN40, SMA SZA CLA JMP .+5 TAD ERROL /NO TLS /TYPE CHAR DCA TELSW /SET IN PROGRESS FLAG JMP .+10 /RETURN TAD ERROL /SEND DATA DCA I OPTRO TAD OPTRO /SET POINTERS IAC AND K37 TAD OPTR0 DCA OPTRO CDF L JMP I XOUT ERRONC, -2 ERROL, 0 /ERROR PRINT AND RESET CLA CMA CLL TAD I ERROL /GET ERROR CODE DCA ERRCOD /DEFINED BY TECO CODE: /^O^T-1&37*20UY^T-1&17+QY==^D CODES UP TO ?ZP JMS I [IOWAIT /WAIT FOR OUTPUT TO FINISH TAD ERRCOD RECOVR, IAC /AB=A BREAK RESTRT, DCA ERRCOD /AA=START ALL OVER KCC ISZ ERRONC /AVOID STAYING IN CLOSE ERROR JMS I [OCHK JMS I [DISMISS CLA CLL CMA RAL /NOW WE ARE OK DCA ERRONC DCA DEPTH DCA INBUF /CLEAR INPUT BUFFER TAD MIN40 /CLEAR OUTPUT BUFFER DCA XCNTR CMA TAD OPTR0 DCA AUTO1 TAD OPTR0 DCA OPTRI TAD OPTR0 DCA OPTRO DCA OUTECH DCA INECH CLA STL IAC RAL /ENABLE MULTI8-ECHO DCA MECH DCA OUTFLG /CLEAR IN/OUT FLAGS DCA INFLG CDF P DCA I AUTO1 ISZ XCNTR JMP .-2 CLA IAC /RESET ECHO TO ON DCA I [ECHO CDF L TAD [215 /BACK TO START OF LINE JMS TERMNL TAD LF JMS TERMNL TAD (213 /RESET COUNTERS JMS TERMNL TAD [77 JMS TERMNL /? TAD ERRCOD CLL RTR RTR TAD (301 /FIRST LETTER JMS TERMNL TAD ERRCOD AND (17 TAD (301 /SECOND LETTER JMS TERMNL CIF CDF P JMP I .+1 /FOR LINENO PRINTOUT ENDERR /IN DRIVER LOWIN, 0 SNA /DISABLE ECHO =2 IN AC TAD MECH /DEFAULT SET BY INECH 6770 /IN MULTI8 DRONE TAD INFLG SPA JMP EOF /-:END OF FILE SNA CLA JMP LOWTTI /0:TTY JMS I (ICHAR /INPUT FROM FILE SKP LOWTTI, JMS I (XIN /FROM TTY CIF CDF P JMP I LOWIN EOF, ERROR1 105 /EF=END-OF-FILE TERMNL, 0 /HANDLER FOR TTY DEVICE AND [177 DCA LOWIN TAD LOWIN TAD [-16 /CHAR-16 CLL TAD [7 /OVERFLOW IF 7.LE.CHAR.GE.15 SZL CLA /FORMAT CHAR.? JMP TERCTL TAD LOWIN /CONTRL.CHAR.? AND TERNMV SZA CLA JMP TEROUT /NO;OUT NORMAL TAD INFLG CIA SMA TAD INECH /O I TTY:? SMA /FALLS THRU WITH -1;SO NO MOVE JMP TERCON /NO. CONVERT TO ^X TERMMV, IAC /WITH NEXT GIVES -2 TERNMV, CMA CLL /-1, ALSO MASK 140 TAD CHRCNT DCA CHRCNT /MODIFIED CHAR.CNT. TEROUT, TAD LOWIN /GIVE OUT STANDARD JMS I DXOUT TERCHK, TAD CHRCNT /CHECK IF OVERFLOW SPA CLA JMP I TERMNL /NO. GO BACK TAD [215 /FALLS IN FROM LINE OVERFLOW JMS I DXOUT TERLFD, TAD LF ISZ LINCNT /TEST IF AT END OF PAGE JMP LINRES-1 /NO: GIVE LF TERPS, JMS I [IOWAIT TERLUP, ISZ LINCNT JMP TERLUP KSF SKP JMP TERLST ISZ WAIT JMP TERLUP TERLST, TAD LF JMS I DXOUT TAD PAUS DCA WAIT TERRES, TAD PAGLEN /AT END ***** DCA LINCNT /RESET JMP LINRES /NOW RESET LINE TERCTL, TAD LOWIN /BUILD JUMP TAD TERJMP DCA .+1 HLT /MUST!! BE 6 AFTER 'TERRES'***** JMP TERNMV /" 7":BELL;UNCHANGED;NO MOVE JMP TERMMV /"10":BSPC; " " ;BACKUP CHAR.CNT. JMP TERTAB /"11":HTAB JMP TERLFD /"12":LF ;RESETS CHAR.CNT. TERJMP, JMP TERRES /"13":VTAB;RESET JMP TERFF /"14":FFED;SIMULATE TAD [215 /"15":CRET;CRLF JMS I DXOUT LINRES, TAD LINLEN /RESET CHAR. CNTR. DCA CHRCNT JMP I TERMNL /FORMFEED: /HARDWARE /SOFTWARE TERFF, TAD [214 / ISZ LINCNT JMS I DXOUT / SKP TAD [200 / JMP .+4 JMS I DXOUT / TAD LF ISZ LINCNT / JMS I DXOUT JMP .-3 / JMP TERFF CLA STL IAC RAL / JMP TERLST / TERTAB, TAD (240 JMS I DXOUT TAD CHRCNT AND [7 SZA CLA JMP TERTAB JMP TERCHK /GO CHECK IF END OF LINE TERCON, TAD LOWIN JMS I (CONVER JMP TEROUT *COMBUF IFNDEF KEY< ZBLOCK 400 > XLIST EJECT DPF COMMAND DECODER AND INIT XLIST /FILE SECURITY DATAPLAN-FOCAL80 /TO BE ASSEMBLED WITH PARAMETER KEY=1 /CALL PROGRAM TO BE MODIFIED WITH COMMAND DECODER /PROGRAM THAN SAVES AGAIN AND COMES BACK FOR MORE /THE CODE NUMBER IS INDICATED IN FIRST CD CALL WITH /=OPTION. FURTHER SPECS ASSUME INITIAL =CODE. /IF DPF IS TO BE RECODED:INSERT THE CODE-NUMBER FIRST /ADRESS FOR CODE-NUMBER IN DPF IS:00000 IFDEF KEY< KEYER, CDF L TAD I (CODENU /TRANSFER CODE-NUMBER CIA DCA TMCOD /NEG. TEMP. TAD I (CODENU DCA I (CODE /IN APPEN CDF P TAD I (BUFR /GET LENGTH OF PROGRAM CDF L DCA APPSTR TAD APPSTR DCA I (APBUF /KEEP FOR L CALL TAD APPSTR AND (177 DCA KRELOC /RELOCATION VALUE TAD KRELOC TAD (APPLEN-200 /DOES CODE FIT? SPA CLA JMP .+6 /YES DCA KRELOC /NO RELOC TAD APPSTR TAD (200 /NEXT PAGE AND (7600 DCA APPSTR /STORE TEMP TAD APPSTR TAD (APPLEN CDF P DCA I (BUFR /RESET BUFR TAD (APPEN-2 DCA AUTO1 CMA TAD APPSTR DCA AUTO2 TAD (APPLEN CIA DCA COUNT TAD KRELOC DCA REL1 TRNSLP, CDF 0 /NOW TRANSFER APPEN TO FLD 2 TAD I AUTO1 SNA /ZERO ENDS RELOCATION DCA REL1 SMA /DON'T RELOCATE IOTS&OPRS$JMPJMSS TAD REL1 CDF 20 DCA I AUTO2 ISZ COUNT JMP TRNSLP TAD TMCOD TAD I (LINE1 DCA I (PC0+1 /C(LINE1)-CODE TO PC0+1 TAD TMCOD TAD I (LINE0 DCA I (LINE1 /C(LINE0)-CODE TO LINE1 DCA I (LINE0 /0 TO LINE0 TAD TMCOD TAD APPSTR IAC DCA I (PC0+2 /APPEN ENTRY-CODE TO PC0+2 DCA I (LINE0-1 /NOT NEEDED ANY MORE CDF 0 TAD I (APPJMP MQL TAD I (APPEN TAD KRELOC /RELOCATE 'JMS .' CDF T ISZ APPSTR DCA I APPSTR TAD APPSTR TAD (APPJMP-APPEN DCA APPSTR MQA TAD KRELOC DCA I APPSTR /RELOCATE 'JMP I APPBCK' CDF L TAD (RECORD&177+1200 DCA I (SAVEPT+4 TAD (WRFUN&177+1200 DCA I (BLLL-4 JMS I (SAVPR /NOW RESAVE PROGRAM JMS I [DISMISS CDF P TAD (200 DCA I (PC DCA I (LINENO CDF T TAD (GORETN-1 DCA I (PDLXR CDF L CLA IAC JMP I (SETUP /BACK TO COMMAND DECODER TMCOD, 0 APPSTR, 0 KRELOC, 0 REL1, 0 COUNT, 0 PAGE /THIS PART IS MOVED TO FLD 2 AT THE END OF THE PROGRAM SKP /FALLING IN WILL GIVE ERROR APPEN, JMS . /ADRESS: C (PC0+2) + CODE CMA /AC CARRIES C(PC0+2)=CODE-APPEN-1 TAD APPEN /AC=CODE CIA TAD CODE SZA /IF ZERO ALL OK JMP PCHK+12 DCA I PC02PT /CLEAR POINTER TAD I LIN1PT TAD CODE DCA I LIN0PT /SET LINE0 TAD I PC01PT TAD CODE DCA I LIN1PT /SET LINE1 DCA I PC01PT CDF 10 TAD SNACL DCA I MODPT /KILL MODIFY TAD DCALIN DCA I WRITPT DCA I WRIT1P /KILL WRITE DCA I WRIT2P CIF CDF 0 DCA I SVPTPT TAD SAVMOD DCA I BLM4PT /KILL SAVE TAD APBUF /APPEN IN AC FOR BUFR APPJMP, JMP I APPBCK 0 /END OF RELOC APPBCK, KEYRES CODE, 0 PC02PT, PC0+2 LIN1PT, LINE1 LIN0PT, LINE0 PC01PT, PC0+1 SNACL, SNA CLA DCALIN, DCA LINENO MODPT, MODIFY+4 WRITPT, WRITE WRIT1P, WRITE+3 WRIT2P, WRITE+14 SVPTPT, SAVEPT+4 SAVMOD, TAD [OCLOSE /READ INSTEAD OF WRITE BLM4PT, BLLL-4 APBUF, 0 APPLEN=.-APPEN+1 IFZERO APPLEN-70&4000 <APERR, ????> PAGE > /MONTHS OF THE YEAR MONAME, TEXT "--19" *.-1 TEXT "JAN-" *.-1 TEXT "FEB-" *.-1 TEXT "MAR-" *.-1 TEXT "APR-" *.-1 TEXT "MAY-" *.-1 TEXT "JUN-" *.-1 TEXT "JUL-" *.-1 TEXT "AUG-" *.-1 TEXT "SEP-" *.-1 TEXT "OCT-" *.-1 TEXT "NOV-" *.-1 TEXT "DEC-" /DEVICE NAME TABLE: CODE / # OF OF INDEXED NAMES-1 / DEVICE NAME /7777 IN CODE ENDS LIST /CODES IN INCREASING ORDER! DVCDNM, 406 / 0 DEVICE DF 2426 / 0 DEVICE TV 4004 / 0 DEVICE HDX 4020 / 0 DEVICE LPT 4023 / 0 DEVICE LST 4024 / 0 DEVICE PTP 4215 /4217 2 DEVICE RL0A 4224 / 0 DEVICE PTR 4315 /4317 2 DEVICE RL1A 4415 /4417 2 DEVICE RL2A 4503 /4512 7 DEVICE CSA0 4513 / 0 DEVICE DIAB 4515 /4517 2 DEVICE RL3A 4573 /4576 3 DEVICE DKA0 4604 /4613 7 DEVICE DTA0 4631 / 0 DEVICE SYS 4673 /4676 3 DEVICE DKB0 5074 /5077 3 DEVICE SLU0 5524 / 0 DEVICE TTY 5604 /5613 7 DEVICE LTA0 5704 /5713 7 DEVICE MTA0 5723 / 0 DEVICE DSK 6002 / 0 DEVICE DBL 6003 /6012 7 DEVICE DSK0 6034 / 0 DEVICE COMM 6145 / 0 DEVICE DUMP 6362 /6371 7 DEVICE RBA0 6373 /6376 3 DEVICE RKA0 6410 /6417 7 DEVICE RXA0 6464 /6467 3 DEVICE SDA0 6473 /6476 3 DEVICE RKB0 6504 / 0 DEVICE CDR 6564 /6567 3 DEVICE SDB0 6601 / 0 DEVICE BAT 6605 /6614 7 DEVICE TUA0 7010 /7017 7 DEVICE VXA0 7241 / 0 DEVICE NULL 7310 /7317 7 DEVICE RXH0 7421 / 0 DEVICE LQP 7501 /7510 7 DEVICE LQP0 7777 PAGE CDTBL, ZBLOCK 200 USRTBL, ZBLOCK 200 /FIRST TIME INITIALIZING FOR OS/8 FOCAL SETUP, DCA CHAINS /REMEMBER CALL CDF 0 CIF 10 JMS I (7700 /CALL USR 10 /LOCK IN TAD CHAINS SNA CLA JMP NODECD CIF 10 JMS I (200 5 /COMMAND DECODE 5200 /SPECIAL MODE NODECD, TAD I (7777 /GET BOS WORD AND (600 /EXTRACT EXT DATE SNA TAD (200 /78 IF NONE CLL RTR RTR DCA YEAR /SAVE DCA TEM7 /INIT COUNTER CDF 10 TAD I (7666 /GET DATE WORD AND (7 /EXTRACT MOD 8 YEAR SNA CLA CLL IAC RAL /80 IF NONE TAD YEAR /ADD FOR 5 BIT YEAR TAD (-12 /DIVIDE BY 10(10) ISZ TEM7 SMA /DONE? JMP .-3 TAD (6760-100+12 BSW /YES TAD TEM7 /PUT IN 10'S BSW DCA YEAR /YEAR IN 2 6-BITS TAD I (7666 /GET MONTH AND (7400 BSW CLL RAR TAD (MONAME /ADDRESS OF NULL MONTH NAME DCA TEM7 CDF 0 TAD I TEM7 /GET 'JA' FROM JAN- DCA MONA ISZ TEM7 TAD I TEM7 /GET 'N-' FROM JAN- DCA LISA CDF 10 STA TAD I (36 /GET POINTER TO DEVNAM TABLE CDF 0 DCA .+4 JMS I (MVCORE /MOVE TABLE DOWN -20 CDF 10 HLT CDF 0 USRTBL /IN BUFFER AREA JMS I (MVCORE /MOVE FILE TABLE DOWN -50 CDF 10 7600 CDF 0 CDTBL /ALSO IN BUFFER AREA CIF 10 JMS I (200 11 /USROUT JMS I (MVCORE /CLEAR OUTPUT BUFFER -40 CDF 0 COMBUF CDF 10 7600 TAD I (CDTBL+6 /CHECK IF NAME SNA CLA JMP I (GOSTRT /NO;RUN FCINIT(MAYBE) TAD I (CDTBL+5 /GET DEVNO JMS I (DNTONM /CONVERT LINE3A+4 JMP I (DEVERR JMS I (MVCORE -3 /MOVE FILENAME CDF 0 CDTBL+6 CDF 0 LINE3A+7 TAD I (CDTBL+11 /CHECK EXTENSION SNA TAD (617 /DEFAULT - FO DCA I (LINE3A+13 JMP I (CHKINP CHAINS, 0 PAGE CHKINP, TAD I (CDTBL+12 /CHECK INPUT SNA JMP NOINPT+3 /SET TTY:,E JMS I (DNTONM LINE2A+4 JMP I (DEVERR TAD I (CDTBL+13 SNA CLA JMP NOINPT /NO NAME JMS I (MVCORE -3 /MOVE NAME CDF 0 CDTBL+13 CDF 0 LINE2A+7 TAD (5640 /SET . FOR EXTNSN DCA I (LINE2A+12 TAD I (CDTBL+16 SNA TAD (604 /DEFAULT .FD DCA I (LINE2A+13 NOINPT, JMS I (GESWIT "I-300 /INPUT ECHO? SKP TAD (5405 /YES - SET ,E DCA I (LINE2A+14 TAD I (CDTBL /GO ON WITH O O SNA JMP NOOUTP+3 JMS I (DNTONM LINE1A+4 JMP I (DEVERR TAD I (CDTBL+1 SNA CLA JMP NOOUTP JMS I (MVCORE -3 CDF 0 CDTBL+1 CDF 0 LINE1A+7 TAD (5640 DCA I (LINE1A+12 TAD I (CDTBL+4 SNA TAD (604 DCA I (LINE1A+13 NOOUTP, JMS I (GESWIT "O-300 SKP TAD (5405 DCA I (LINE1A+14 JMP MOD3 GOSTRT, JMS I (GESWIT /CHECK IF CHAIN TO FCINIT "C-300 SKP CLA MOD3, CLA IAC CLL CML RAL /SETS MODE TO 1 OR 3 DCA I (MODE /FOR START OR GOTO JMS I (GESWIT /NO FUNCTIONS? "N-300 JMP .+4 TAD (CDF 10 JMS I (PATCH NOFUNC JMS I (GESWIT /REDUCED PRECISION? "6-225 JMP I (FULPRC TAD (CDF 10 /REDUCED PRECISION PATCHES JMS I (PATCH REDPRC TAD (CDF 0 JMS I (PATCH OTHVAR JMS I (MVCORE -31 CDF 0 DIVOVL CDF 10 DUBDIV+10 JMS I (MVCORE -36 CDF 0 NEWVAR CDF 10 STSECR JMP I (FULPRC PAGE FULPRC, JMS I (GESWIT "B-300 /BACK SPACE TERMINAL? JMP NOBCKS JMS I (MVCORE -6 CDF 0 BACKSP CDF 10 FORW+11 NOBCKS, JMS I (GESWIT "A-300 /MODIFY ASK TO COLON? JMP NOCOL TAD (": JMP SETASK NOCOL, JMS I (GESWIT "R-300 JMP NOBEL TAD (207 /BELL IN ASK JMP SETASK NOBEL, JMS I (GESWIT "Q-300 JMP NOQUES TAD ("? /? IN ASK SETASK, CDF 10 DCA I (DIDO CDF 0 NOQUES, JMS I (GESWIT "P-300 JMP NOPAG JMS I (MVCORE -6 CDF 0 SFTFF CDF 0 TERFF NOPAG, CDF 10 TAD I (7726 /LOOK FOR SCOPE BIT AND (200 SNA CLA JMP NOSCOP TAD (210 /BACKSPACE DCA I (SPLAT /FOR RUBOUT TAD (-120 DCA LINLEN TAD (-30 DCA PAGLEN TAD (-200 DCA PAUS TAD PAUS DCA WAIT JMP SCOPMR NOSCOP, TAD (ISZ ECHO DCA I (DELSCP /KILL BS-SPACE-BS SCOPMR, CDF 0 TAD I (CDTBL+42 AND (3777 /ELIMINATE ALT-MODE SWITCH CIA SNA TAD PAGLEN DCA PAGLEN TAD I (CDTBL+46 /CHECK = OPTION IFNDEF KEY < CIA SNA TAD LINLEN /ALREADY DEFINED (SET?) DCA LINLEN> IFDEF KEY < SNA TAD I (CODENU DCA I (CODENU NOP> TAD LINLEN DCA CHRCNT TAD PAGLEN DCA LINCNT NOTTWD, JMS I (GESWIT "S-300 /SAVE SWITCH;GO BACK TO KM. SKP JMP I (7600 /WITH PATCHES SET JMS I (GESWIT "W-300 /WRITE PROGRAM? JMP I (NOWRIT TAD (340 /YES;SET L C;NO EXECUTION DCA I (LINE3A+3 CLA CLL IAC CML RAL /'GO'=3 DCA I (MODE TAD (ENDWRT /SET TO COME BACK HERE CDF 10 DCA I (FORLEX+2 JMP I (NOWRIT+3 /SIMULATE ALT-MODE ENDWRT, TAD (LEXIT /RESET CDF 10 DCA I (FORLEX+2 TAD (200 DCA I (PC CDF 20 TAD (GORETN-1 DCA I (PDLXR /RESET PDL FOR RETURN CDF 0 CLA CLL IAC RTL /'WRITE'=4 JMP I (CHENTR PAGE NOWRIT, JMS I (GESWIT 0 /CHECK ALT-ESC JMP NOALTM /NONE CDF 10 /YES CHANGE EXIT TAD (FORLEX DCA I (START CDF 0 JMP YESGO NOALTM, JMS I (GESWIT /CHECK IF GO "G-300 SKP CLA JMP YESGO TAD (340 DCA I (LINE3A+3 /SET L C YESGO, CMA TAD MODE SZA CLA /IF START ERASE ALL JMP NOSTRT DCA I (LINE0A TAD (LINE1 CDF 10 DCA I (BUFR CDF 0 NOSTRT, TAD CHNDCA DCA I (CHENTR /RESET CHAIN ENTRY JMS I (MVCORE /NOW MOVE HEADER UP -400 CDF 0 POPSUB CDF 20 0 JMS I (MVCORE /AND PDL (WIPE OUT BATCH?) -100 CDF 0 PDLMON CDF 20 7500 CDEXIT, IFNDEF KEY <JMS I (COCLR> TAD MODE /GO TO FOCAL JMP I (CHENTR MODE, 0 CHNDCA, STRTSW&177+3200 PAGE /MOVE CORE ROUTINE: JMS MVCORE / -# OF WORDS / CDF FROM / ADRESS FROM / CDF TO / ADRESS TO MVCORE, 0 TAD I MVCORE DCA MVCNT ISZ MVCORE TAD I MVCORE DCA FRMCDF ISZ MVCORE TAD I MVCORE DCA MVPTFR ISZ MVCORE TAD I MVCORE DCA TOCDF ISZ MVCORE TAD I MVCORE DCA MVPTTO ISZ MVCORE FRMCDF, HLT TAD I MVPTFR ISZ MVPTFR TOCDF, HLT DCA I MVPTTO ISZ MVPTTO ISZ MVCNT JMP FRMCDF CDF 0 JMP I MVCORE MVCNT, 0 MVPTFR, 0 MVPTTO, 0 /GET A SWITCH ROUTINE: JMS GESWIT / CODE: ALTESC=0,A-Z="X-300,0-9="#-225 / RETURN NOT SET / RETURN SET GESWIT, 0 TAD I GESWIT CIA DCA SWITNU /SAVE SWITCH NUMBER NEGATIVE TAD SWILOC DCA SWIPNT /RESET POINTER TAD SWITNU SZA CLA /ALT-ESC? JMP NEXSWI /NO CLA CMA /YES DCA SWITNU /ROTATE ONLY ONCE SKP /KEEP POINTER AT FIRST WORD NEXSWI, ISZ SWIPNT /NEXT WORD CLA CLL CML /SET MASK-BIT SWILUP, RAR SZL /AT END OF WORD? JMP NEXSWI /YES;TO NEXT WORD,DON'T BUMP SWITNU ISZ SWITNU /RIGHT LOC? JMP SWILUP /NO;SHIFT MORE AND I SWIPNT /YES;AND MASK WITH SWITCH ISZ GESWIT SZA CLA /BIT SET? ISZ GESWIT /YES;BUMP RETURN JMP I GESWIT SWITNU, 0 SWIPNT, 0 SWILOC, CDTBL+42 /DEVICE CODE TO NAME AND STORE ROUTINE / TAD DEVNO / JMS DNTONM / ADRESS FOR STORE / ERROR RETURN (NOT IN LIST) / NORMAL RETURN (STORED) DNTONM, 0 AND (17 /TAKE DEVICE BITS TAD (USRTBL /ADRESS OF TABLE DCA DNPTR TAD I DNTONM DCA PUTDCN /SET ADRESS FOR STORE ISZ DNTONM /AT ERROR RETURN TAD I DNPTR /GET USR DEVICE NAME CIA DCA DCCODE TAD (DVCDNM /START SEARCH DCA DNPTR DNLOOP, CLA CLL TAD DCCODE TAD I DNPTR /GET CODE,IS IT .GE. DCCODE? ISZ DNPTR SNA JMP DNFND+2 /EXACT SZL JMP DNEXIT /NOT IN LIST TAD I DNPTR /SEE IF WE GET AN INDEXED NAME SZL JMP DNFND /YES;OVERFLOW IS MAX#-# ISZ DNPTR ISZ DNPTR /BUMP POINTER-SEARCH ON ISZ DNPTR JMP DNLOOP DNFND, CIA /#-MAX# TAD I DNPTR /# MQL ISZ DNPTR TAD I DNPTR /TRANSFER NAME DCA I PUTDCN ISZ DNPTR ISZ PUTDCN MQA /ADD IN NUMBER TAD I DNPTR DCA I PUTDCN ISZ DNTONM /NORMAL RETURN DNEXIT, CLA CLL JMP I DNTONM DNPTR, 0 PUTDCN, 0 DCCODE, 0 PATCH, 0 /ROUTINE PATCH CDF ADRESS OF TABLE DCA PATCDF /COMES IN WITH CDF X TAD I PATCH /GET LIST ADRESS ISZ PATCH DCA PATATO PATLUP, TAD I PATATO /GET ADRESS TO PATCH SNA JMP I PATCH /0 ENDS LIST DCA PATTER ISZ PATATO TAD I PATATO /A LA RIM LOADER PATCDF, HLT DCA I PATTER CDF 0 ISZ PATATO JMP PATLUP PATATO, 0 PATTER, 0 DEVERR, CIF 10 /USER ERROR 7 JMS I (7700 7 7 PAGE FIELD 0 *6000 POPSUB=. RELOC 0 /GETS LOADED IN FIELD 2 /CORE MAP: /0-177: PDL SUBROUTINES /200-X: TEXT /X-7545: PUSHDOWN LIST /7546-7577: MONTHS OF THE YEAR 0 /FOR RUBOUT PROTECTION;SEE RUB1 PSHBUF, BUFR /INDIRECT FOR TEXT PROTECTION PSHCDF, CDF 0 PSHERR, ERROL+3 /POINTER TO ERRROR ROUTINE 0 0 /FOR ODT 0 PSHCNT, 0 PSHAX, 0 PDLXR, GORETN-1 /MAIN AX FOR PDL PSHM4, -4 PSHMSK, 7 POPOVR, 376-1 /PO=PDL. OVERFLOW PSHM5, -5 FLDCDI, HLT /CDI CURRENT JMP I FLDRET /EXIT FLDRET, 0 ZPOPA, 0 /ONE ITEM FROM PDL TO AC;OLD AC IN MQ JMS FLDSET TAD I PDLXR JMP FLDCDI /NO INC RETURN ZPUSHA, 0 /AC TO PDL;AC TO MQ JMS FLDSET CLA CMA JMS PCHK MQA DCA I PDLXR CLA CMA JMS PCHK JMP FLDCDI /NO INC RETURN /LOCAL FIELD SATELLITES FOR ALL POPS EXCEPT /POPJ MUST BE AS FOLLOWS: /XPOPU, 0 / MQL / FLDCUR (DEFINED ON OTHER PAGE) / CIF T (WHERE T IS FIELD OF POP SUBS.) / JMS I .+1 / ZPOPU /FLDCUR=CLA FOR FIELD 0 / =CLA IAC 1 / =CLA IAC RAL 2 / =CLA CLL CML IAC RAL 3 / =CLA IAC RTL 4 / =CLA CLL CMA RTL 5 / =CLA CLL CMA RAL 6 / =CLA CMA 7 FLDSET, 0 /SUBROUTINE FOR ANALYZING FIELDS AND ADRESSES AND PSHMSK /TAKE ONLY 7 BITS CLL RAL RTL TAD PSHCDF DCA FLDCDF /CALLING DATA FIELD TAD PSHCDF /NOW LET'S SEE WHICH D.F. HE PUT RDF DCA ACCES /ACCES DATA FIELD CDF T /THIS FIELD CLA CLL CMA RAL /JMS FLDSET ALWAYS FIRST INSTR. OF ZPOPU'S TAD FLDSET /ZPOPU+2 DCA FLDRET /NOW BECAUSE OF STANDARD FORM OF SATELLITES TAD PSHM5 /-5 PLUS THE TAD I FLDRET /CONT. OF ZPOPU ENTRY,GIVES ADRESS OF XPOPU DCA FLDRET FLDCDF, HLT /CHANGE TO CALLING D.F. TAD I FLDRET /THIS IS ADRESS OF ARG. DCA FLDRET /AND FINAL RETURN ADD. FOR POPA,PUSHA CLA CMA /FOR RELATIVE ADRESSING:'TAD FLDRET' TAD I FLDRET /ARGUMENT-1 FOR AX DCA PSHAX CLA CLL IAC RAL /BUILD A CIF CDF CALLING FIELD TAD FLDCDF /FOR FINAL RETURN DCA FLDCDI CDF T /BACK TO THIS FIELD JMP I FLDSET /BY THE WAY: THE DATA FIELD IS ALWAYS RESET TO CURRENT /THIS CAN BE USEFUL /CALLS IN A PROGRAM WILL LOOK LIKE THIS: /CDF ACCES /PUSHF / LOC /RELATIVE: LOC-.-1 /WILL PUSH 4 WORDS STARTING IN LOC IN FIELD ACCES ZPUSHF, 0 /4 WORDS IN PDL;AC CONSERVED;AC TO MQ JMS FLDSET TAD PSHM4 JMS PCHK TAD PSHM4 DCA PSHCNT ACCES, HLT /SET BY FLDSET TAD I PSHAX /"" CDF T DCA I PDLXR /STORE IN PDL ISZ PSHCNT JMP ACCES /LOOP TAD PSHM4 JMS PCHK /RESET PDLXR PSHFEX, MQA /RESTORE AC ISZ FLDRET /BUMP PAST ARG JMP FLDCDI ZPOPF, 0 /4 WORDS FROM PDL IN LOC;AC CONSERVED;AC TO MQ JMS FLDSET TAD PSHM4 DCA PSHCNT TAD ACCES /RELOCATE CDF ACCES DCA .+3 POPLOP, CDF T TAD I PDLXR HLT DCA I PSHAX ISZ PSHCNT JMP POPLOP /LOOP JMP PSHFEX /SAME RETURN AS ZPUSHF /!!!!! /POPJ IS THE ONLY POPU THAT NEEDS ANOTHER SATELLITE! /XPOPJ, CIF CDF T / JMP I .+1 /JMP!! / ZPOPJ ZPUSHJ, 0 /GO TO ARG IN ACCES;CDF ALSO ACCES;AC CONSERVED JMS FLDSET /AC TO MQ CLA CLL CMA RAL /-2 JMS PCHK IAC /TO BUMP PAST ARG TAD FLDRET /RETURN AFTER POPJ DCA I PDLXR TAD FLDCDI /CDI AFTER POPJ DCA I PDLXR CLA CLL CMA RAL JMS PCHK CLA CLL IAC RAL TAD ACCES /BUILD CDI ACCES DCA .+2 MQA HLT JMP I PSHAX /!! ZPOPJ, TAD I PDLXR /AC INCS RETURN AND IS LOST;MQ CONSERVED DCA FLDRET TAD I PDLXR DCA FLDCDI JMP FLDCDI PCHK, 0 /SUB TO BACKUP PDL AND CHECK OVERFLOW TAD PDLXR /AC COMES IN WITH AMOUNT OF BACKUP DCA PDLXR TAD PDLXR CIA CLL CDF P /SOME OTHER FIELD TAD I PSHBUF /GET LOWER BOUNDARY CDF T SNL CLA JMP I PCHK /NO OVERFLOW TAD POPOVR CIF CDF L JMP I PSHERR VPOPA=JMS I . /FOR FIELD T POPS NOP VPUSHA=JMS I . NOP VPUSHJ=JMS I . NOP VPOPJ=JMP I . NOP VPUSHF=JMS I . NOP VPOPF=JMS I . NOP RELOC *6200 RELOC 200 PC0, 0 /TEXT BUFFER HEAD 0 /OR C(LINE1)-CODE *KEY* 0 /OR APPEN-CODE *KEY* 0 0 5051 /LPAR,RPAR FOR DUMP BUFR LINE4+1 /OR '0' *KEY* LINE0, LINE1 LINE0A=LINE0+POPSUB 0 IFNDEF KEY < TEXT "C-DATAPLAN FOCAL80" > IFDEF KEY < TEXT "C-DATAPLAN FOKEY80" > *.-1 7715 /DUMMY CR LINE1A=.+POPSUB /TEXT FOR AUTOMATIC LOADING AFTER CHAIN LINE1, LINE2 /OR C(LINE0)-CODE *KEY* 212 /LINE 1.1 TEXT "O O TTY : ,E" *.-1 7715 LINE2A=.+POPSUB LINE2, LINE3 224 /LINE 1.2 TEXT "O I TTY : ,E" *.-1 7715 LINE3A=.+POPSUB LINE3, 0000 236 /LINE 1.3 TEXT "L R DSK : FCINIT. FO <00.0> " *.-1 7715 LINE4A=.+POPSUB LINE4=. 7715 7715 RELOC /OVERLAYS DIVOVL=. RELOC DUBDIV+10 TAD AC1L TAD LORD DCA MP2 RAL TAD HORD TAD AC1H SNL JMP .+4 DCA HORD TAD MP2 DCA LORD CLA TAD MP1 RAL DCA MP1 TAD MP4 RAL DCA MP4 ISZ MP3 JMP DV3 TAD MP1 DCA LORD TAD MP4 DCA HORD JMP I DUBDIV RELOC BACKSP=. RELOC FORW+11 /FOR TERMINAL WITH BS JMP .+2 TAD M30 TAD SPC DCA T3 M30, -30 TAD T3 RELOC SFTFF=. RELOC TERFF /FOR SIMULATED FF'S ISZ LINCNT SKP JMP .+4 TAD LF JMS I DXOUT JMP TERFF RELOC NEWVAR=. RELOC STSECR 4400 0000 0013 DOLL1, 0001 0000 4300 NMBSG1=.+2 ZBLOCK 4 4100 EXCLA1=.+2 ZBLOCK 4 4200 QUOTS1=.+2 ZBLOCK 4 2011 /PI 0000 0002 3110 3756 2605 /VERSION NUMBER 40.1 0000 0006 2403 1463 STVAR1=. RELOC PDLMON=. RELOC 7500 ZBLOCK 36 GORETN, INPUTX+2 /RETURN FOR GOTO CIF CDF P ZBLOCK 40 PDLEND=. RELOC /PATCHES NOFUNC, VARTOP / XSQRT-10 FNTABF+11 / ERCALL FNTABF+13 / ERCALL FNTABF+15 / ERCALL FNTABF+17 / ERCALL FNTABF+21 / ERCALL FNTABF+23 / ERCALL 0000 OTHVAR, /XNMBSG / / NMBSG1 / XEXCLA / / EXCLA1 / XQUOTS / / QUOTS1 XDOL / DOLL1 0000 REDPRC, LASTV /ADRESS STVAR1 END / STVAR1 FSIZE / 6 DECP / 3 GINC / 5 MFLT / -3 DIGITS / 7 TWOPI+2 / 3756 PI+2 / 3756 PIOT+2 / 3756 PTEN+2 / 3147 FPNT+3 / DCA OVER1 FPNT+4 / DCA OVER2 ZERO+20 / DCA OVER1 TEST2 / 27 DMULT+32 / DMDONE&177+5200 DMDONE+7 / DCA OVER2 MULDIV+4 / ISZ OVER2 MIF / -27 0000 FIELD 0 *200 $$$$