/39 OS/8 Commercial BASIC Runtime system, V6A / / / / / / / / / / / /COPYRIGHT (C) 1972, 1973, 1974, 1975, 1977, 1978 /Digital Equipment Corporation, Maynard, Mass. / / / /This software is furnished under a license for use only on a /single computer system and may be copied only with the inclu- /sion of the above copyright notice. This software, or any other /copies thereof, may not be provided or otherwise made available /to any other person except for use on such system and to one who /agrees to these license terms. Title to and ownership of the /software shall at all times remain in DEC. / / /The information in this software is subject to change without /notice and should not be construed as a commitment by Digital /Equipment Corporation. / /DEC assumes no responsibility for the use or reliability of its /software on equipment which is not supplied by DEC. / / / / / / /AUGUST 19, 1972 / /R.G. BEAN, 1972 /SHAWN SPILMAN, 1973 / J.K.,1975 /JR 21-Apr-77 ADDED EXTENDED DATE CODE, CLEANED UP LISTING /JR 26-Apr-77 TIGHTENED UP STRING ROUTINES /JR 28-Apr-77 ADD SOURCE FIX FOR SEVERAL KNOWN BUGS /JR 04-May-77 REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY /JR 26-Jan-78 REMOVE TTY RING BUFFER, ADD 8 BIT ASCII /JR 03-Feb-78 ADD STRING ARITHMETIC INTERFACE /JR 22-Feb-78 ADD PRINT USING /JR 28-Feb-78 ADD TEXT ERROR MESSAGES /JR 22-Mar-78 ADD GENERAL 2 PAGE SYSTEM HANDLER RELOCATION /JR 28-Mar-78 INSTALL EXTENDED FIELD 1 CODE /JR 01-Apr-78 TIGHTEN UP FILE I/O ROUTINES, RELOCATE TTY HANDLER /JR 02-Apr-78 PUT IN DIRECT ACCESS PRIMITIVES /JR 09-Apr-78 EXTEND OVERLAYS TO 3 BLKS, MOVE JMP TABLES TO OVERLAYS /JR 14-Apr-78 CLEAN UP LOGIC IN FILE OPEN/CLOSE ROUTINES /JR 15-Apr-78 ADD CAP$ FN, MAKE DATE RETURN DD-Mmm-YY FORMAT /JR 18-Apr-78 FIXUP LOGIC IN CHAINING ROUTINE /JR 20-Apr-78 ADD IFOPEN STMT, NON FATAL ENTER/LOOKUP ERROR FEATURE / FIX BUG WITH LARGE PRE COMPILED PROGRAMS UNDER BATCH /JR 07-May-78 ADD OCT, BIN, KEY$, CCL$, AND PMT$ FUNCTIONS / PUT IN IN-CORE OVERLAY SHUFFLER, EXPAND TO 7 I/O FILES /JR 15-May-78 Added ON-GOTO/GOSUB Feature, CLOSE all Feature /JR 23-May-78 Rewrote FFIN routine for greater accuracy / / VERSON= 6 /VERSION OF BRTS /VERSION LOCATED AT TAG "VERLOC" SUBVER= 01 /SUBVERSION OF BRTS SUBVAF= 01 /SUBVERSION OF MATH FUNCTIONS OVERLAY SUBVSF= 01 /SUBVERSION OF STRING FUNCTIONS OVERLAY SUBVEF= 01 /SUBVERSION OF BASIC ERROR MESSAGE OVERLAY SUBVFF= 01 /SUBVERSION OF FILE FUNCTIONS OVERLAY /FIRST WORD OF EACH OVERLAY CONTAINS /60+VERSON IN LEFT HALF AND SUBVERSION OF OVERLAY /IN RIGHT HALF. /OS/8 SYSTEM DEFINES MDATE= 7666 /CONTAINS OS/8 DATE IN FIELD 1 BIPCCL= 7777 /CONTAINS YEAR EXTENSION BITS, BATCH FLAG AND BATCH FIELD JSW= 7746 /OS/8 JSW IN FIELD 0 CDOPT2= 7642 /HIGH ORDER CD = OPTION AND ALTMODE FLAG CDOPT3= 7643 /CD SWITCHES [ABC DEF GHI JKL] CDOPT4= 7644 /CD SWITCHES [MNO PQR STU VWX] CDOPT5= 7645 /CD SWITCHES [YZ0 123 456 789] CDOPT6= 7646 /LOW ORDER CD = OPTION SCOPWD= 7726 /WORD CONTAINING SCOPE FLAG IN 200 BIT USRDHT= 0037 /POINTER TO USR DEVICE HANDLER TABLE IN FIELD 1 RESTBL= 7647 /ADDR OF DEVICE RESIDENCY TABLE IN FIELD 1 CCLMAX= 47 /MAX SIZE COMMAND STRING FOR CCL /BRTS SYSTEM DEFINES EDBLK= 7604 /CONTAINS BLOCK NUMBER OF EDITOR WIDTH= 204 /WIDTH OF PRINTER COLWID= 16 /WIDTH OF ONE PRINT COLUMN SACLIM= 205 /DEFINE WIDTH OF STRING ACCUMULATOR SAC= 200 /DEFINE ADDR OF SAC IN FIELD 1 OVERLAY=3400 /ADDRESS OF START OF 6 PAGE OVERLAY BUFFER BRTSZ0= 3400 /HANDLER SIZE CONTROL WORD FOR FIELD 0 OF BRTS BCSIZ1= 1000 /BCOMP SIZE CONTROL WORD FOR FIELD 1 LOAD DURING CHAIN BCLOD1= 2000 /BCOMP LOAD ADDR IN FIELD 1 FOR CHAIN STATEMENT CCHAIN= 3201 /ENTRY POINT OF BCOMP IN FIELD 1 FOR CHAIN STATEMENT EDTBGN= 0201 /ENTRY POINT FOR EDITOR RESTART EDTSIZ= 2400 /HANDLER SIZE CONTROL WORD FOR EDITOR READ BUFAREA=4400 /I/O BUFFER AREA IN FIELD 1 (MUST BE ON EVEN BOUNDRY) HAREA= 7000 /BASE ADDR OF HANDLER LOAD AREA IN FIELD 0 MAXFIL= 7 /MAXIMUM FILE NUMBER ALLOWED MAGIC= 1234 /MAGIC CD = OPTION TELLS BASIC .SV PROGRAMS /THEY'RE BEING CHAINED TO FROM BRTS INFO= 7604 /BASIC SYSTEM INFORMATION AREA IN FIELD 1 /INFO STARTING BLOCK +1 OF BASIC.SV /INFO+1 STARTING BLOCK +1 OF BCOMP.SV /INFO+2 STARTING BLOCK +1 OF BLOAD.SV /INFO+3 STARTING BLOCK +1 OF BRTS.SV /INFO+4 STARTING BLOCK +1 OF BASIC.OV /INFO+5 STARTING BLOCK +1 OF BASIC.UF /INFO+6 *UNUSED* /INFO+7 *UNUSED* /INFO+10 STARTING BLOCK OF BASIC.TM /INFO+11 SIZE IN BLOCKS OF BASIC.TM /INFO+12 INPUT HANDLER ENTRY ADDRESS /INFO+13 SIZE AND DEVICE NUMBER OF INPUT FILE /INFO+14 STARTING BLOCK OF INPUT FILE /INFO+15 THROUGH /INFO+20 NAME OF WORKSPACE RECPAK= 400 /ORIGIN IN FIELD 1 OF RECORD I/O CODE /STRING ARITHMETIC LINKAGES STPACK= 2000 /ORIGIN IN FIELD 1 OF STRING ARITHMETIC PACKAGE ABUF= STPACK+2001 BBUF= STPACK+2023 SBUF= STPACK+2103 FMTBUF= STPACK+2142 SADD= STPACK SSUB= STPACK+2 SISUB= STPACK+4 SMUL= STPACK+6 SDIV= STPACK+10 SIDIV= STPACK+12 USING= STPACK+1232 SINTEG= STPACK+707 UINIT= STPACK+2000 DI= STPACK+242 DP= STPACK+245 DM= STPACK+250 OVS= STPACK+326 DVS= STPACK+1011 /ASSEMBLY INSTRUCTIONS / .PAL BRTS/W/E / .PAL SARITH/E / .LOAD BRTS,SARITH /WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE /CORE LAYOUT IS AS FOLLOWS: / /BRTS IS AT 0-6777,10000-14377 /MATH FUNCTIONS (OVERLAY 0) ARE AT 3400-4777 /STRING FUNCTIONS (OVERLAY 1) ARE AT 22000-23377 /ERROR MESSAGES (OVERLAY 4) ARE AT 23400-26377 /FILE FUNCTIONS (OVERLAY 2) ARE AT 33400-34777 /FILE BASIC.UF SHOULD CONTAIN OVERLAY 3 IN 3400-4777 / /TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC, /ASSEMBLE THIS SOURCE IN A 16K OR MORE MACHINE,THEN /PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS / /.LOAD BRTS,SARITH / /.SAVE SYS:BRTS 0-6777,10000-14377;7605 /.SAVE SYS BASIC.OV 3400-4777,22000-26377,33400-34777;7605 / /THE BASIC RUN-TIME SYSTEM IS CONDITIONALIZED TO TAKE ADVANTAGE /OF THE PDP-8/E KE8/E EAE OPTION. /NORMALLY,THE SYSTEM IS ASSEMBLED SUCH THAT IT WILL RUN ON ANY /PDP-8 OR PDP-12. TO TAKE ADVANTAGE OF THE ADDITIONAL HARDWARE,SET /THE SWITCH EAE=1 IF THE SYSTEM INCLUDES A KE8/E EAE. /YOU MAY DO THIS BY CONCATENATING TTY: ONTO BRTS.PA AS FOLLOWS /.PAL EAERTS 80,000 /.STRING FETCH WHEN COUNT IS IN ONE FLD & / TEXT IS IN THE NEXT AC4000= CLA STL RAR AC2000= CLA STL RTR AC0002= CLA STL RTL AC7775= CLL STA RTL AC7776= CLL STA RAL AC3777= CLL STA RAR AC5777= CLL STA RTR IFNDEF EAE /PAGE 0 LOCATIONS *1 CIF 30 /SYMBIOSIS INTERRUPT LINKAGE JMP .-1 *6 VERLOC, /VERSION AND SUBVERSION OF BRTS ROOT USECON, VERSON^100+SUBVER+6000 /USE CONSTANT GENERATED BY "USE" STATEMENT FSTOP1, CCTRAP /POINTER TO RTS EXIT ROUTINE USED /BY ^C HOOKS IN SYSTEM HANDLER. *10 SACXR, 0 /INDEX REGISTER FOR STRING ROUTINES XR1, 0 XR2, 0 XR3, 0 XR4, 0 /INDEX REGISTERS XR5, 0 DATAXR, 0 /POINTER FOR IN-CORE DATA LIST LWIDTH, -WIDTH /COMMON WIDTH FOR PRINTER *20 /COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY /A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR /TO THE BRTS LOAD CDFIO, 0 /* CDF FOR I/O TABLE AND SYMBOL TABLES SCSTRT, 0 /* POINTER TO START OF SCALAR SYMBOL TABLE ARSTRT, 0 /* POINTER TO START OF ARRAY SYMBOL TABLE-1 STSTRT, 0 /* POINTER TO START OF STRING SYMBOL TABLE-1 SASTRT, 0 /* POINTER TO START OF STRING ARRAY TABLE-1 CDFPS, 0 /* CDF FOR START OF PSEUDO-CODE PSSTRT, 0 /* POINTER TO START OF PSEUDO CODE-1 DLSTOP, 0 /* POINTER TO TOP OF DATA LIST DLSTRT, 0 /* POINTER TO BOTTOM OF INCORE DATA LIST-1 PSFLAG, 0 /* OS/8 SWAPPING FLAGS WORD /BIT 0 SET IF OS/8 SAVED IN N7400 INSTEAD OF N7600 / FOR 2 PAGE SYSTEM HANDLER /BIT 11 SET IF 17600 IS IN 17600. BIT 11 TOGGLED BY /PSWAP ROUTINE /SYSTEM REGISTERS SACLEN, 0 /LENGTH OF STRING IN SAC S1, 0 /SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!) S2, 0 /SUBSCRIPT 2 (MUST BE PRECEEDED BY S1!) DMAP, 0 /MAP OF DRIVER PAGES BUFSTK, BSTACK /STACK OF FREE I/O BUFFERS *37 /FLOATING POINT PACKAGE LOCATIONS, CONSIDERED VOLATILE FF, 0 /SPECIAL MODE FLIP-FLOP AC0, 0 /VOLATILE TEMPORARY AC1, 0 /VOLATILE TEMPORARY AC2, 0 /VOLATILE TEMPORARY TM, 0 ACX, 0 /FAC EXPONENT ACH, 0 /FAC HIGH ORDER FRACTION ACL, 0 /FAC LOW ORDER FRACTION OPX, 0 /OPERAND EXPONENT OPH, 0 /OPERAND HIGH ORDER FRACTION OPL, 0 /OPERAND LOW ORDER FRACTION CHAR, 0 /LAST CHAR READ FROM ASCII FILE /SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE MODESW, 0 /0 FOR ARTHIMETIC MODE,1 FOR STRING MODE INSAV, 0 /CURRENT PSEUDO-INSTRUCTION BEING EXECUTED LINEHI, 0 /HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED LINELO, 0 /LOW ORDER BITS OF CURRENT LINE NUMBER STRMAX, 0 /MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING STRCNT, 0 /- # OF CHARACTERS IN CURRENT STRING STRPTR, 0 /POINTER TO SIZE WORD OF CURRENT OPERAND STRING IOMASK, 177 /MASK WORD FOR 7 OR 8 BIT I/O TEMP1, 0 TEMP2, 0 DECEXP= TM /I/O TABLE POINTER AREA-THIS BLOCK HOLDS POINTERS TO THE I/O TABLE /ENTRY FOR THE CURRENT FILE.THE POINTERS ARE CHANGED EVERY TIME AN /SFN IS EXECUTED. A TAD I OFF ONE OF THE POINTERS WILL GET THE INFORMATION /NOTED IN THE COMMENT FOR THE CURRENT I/O DEVICE /THIS BLOCK IS INITIALIZED FOR TTY /THE FORMAT OF THE HEADER WORD IS AS FOLLOWS /BITS USAGE /0-3 OS/8 DEVICE NUMBER /4 FLAG SET IF NEXT CHAR IS 3RD CHAR IN PREV DOUBLEWORD /5 UNUSED /6 SET IF BUFFER HAS BEEN MODIFIED AND NEEDS TO BE WRITTEN /7 SET IF NOT FILE STRUCTURED DEVICE /8 SET IF HANDLER IS 2 PAGES LONG /9 SET IF VARIABLE LENGTH (OUTPUT) FILE /10 SET IF EOF /11 SET IF ASCII FILE, CLEAR IF NUMERIC IMAGE FILE ENTNO, 0 /ENTRY NUMBER NOW IN AREA IOTHDR, TTYF /HEADER WORD IOTBUF, TTYF+1 /BUFFER ADDRESS IOTBLK, TTYF+2 /CURRENT BLOCK IN BUFFER IOTPTR, TTYF+3 /READ\WRITE POINTER IOTHND, TTYF+4 /HANDLER ENTRY POINT IOTLOC, TTYF+5 /FILE STARTING BLOCK # IOTLEN, TTYF+6 /ACTUAL FILE LENGTH IOTRSZ, TTYF+7 /PHYSICAL RECORD LENGTH (INCLUDES CR/LF, ETC) /ZERO IF NOT RANDOM ACCESS IOTSUB, TTYF+10 /POINTER TO CURRENT RECORD FIELD LENGTH IOTNRH, TTYF+11 /HIGH ORDER MAX RECORD SO FAR IOTNRL, TTYF+12 /LOW ORDER MAX (NUMBER LT 384*2**12) IOTMAX, TTYF+13 / DEVICE / (FILE MAXIMUM LENGTH) IOTPOS, TTYF+14 / NAME / (POSITION OF PRINT HEAD) IOTFIL, TTYF+15 / / TTYF+16 / FILE / TTYF+17 / NAME / TTYF+20 / .EX IOTDEV= IOTMAX IOTEND= IOTFIL+4 /END OF FILENAME AND LAST WORD IN IOTABLE IOTSIZ= IOTEND+1-IOTHDR /CURRENT SIZE OF IO TABLE *200 /FETCH NEXT PSEUDO WORD PWFECH, 0 ISZ INTPC /BUMP PSEUDO-CODE PROGRAM COUNTER JMP CDFPSU /NO-SKIP;JUST GET NEXT PSEUDO-CODE WORD TAD CDFPSU /SKIP MEANS WE HAVE TO INCREMENT PS-CODE FIELD TAD [10 DCA CDFPSU CDFPSU, HLT /SET DF TO FIELD OF PSEUDO-CODE TAD INTPC /PUT PC IN MQ MQL TAD I INTPC /GET NEXT WORD OF CODE CDF 0 /SET DATA FIELD BACK TO INTERPRETER FIELD JMP I PWFECH /RETURN SSMODE, IAC /SET INTERPRETER TO STRING MODE AMODE, DCA MODESW /SET INTERPRETER TO ARITH MODE /FALL BACK INTO I-LOOP /BRTS I-LOOP ILOOP, CLA CLL /FLUSH DCA FF /PUT FPP IN SI MODE JMS PWFECH /GET NEXT PSEUDO-INSTRUCTION DCA INSAV /SAVE FOR LATER JMS I (CTCCHK /TEST IF ^C STRUCK TAD INSAV AND [7400 /STRIP TO OPCODE BITS CLL RTL RTL RAL /OPCODE NOW IN BITS 8-11 TAD (7770 /SUBTRACT 10 SMA /IS OPCODE <10? JMP SCASE /CALL TO INSTRUCTION COMMON TO SMODE AND AMODE DCA AC0 /YES-SAVE THE OFFSET TAD MODESW /WHICH MODE? SZA CLA JMP SMODE /STRING MODE TAD AC0 /ARITHMETIC MODE-GET OFFSET TAD JMSI /MAKE JMS TO FP PACKAGE ROUTINE DCA .+2 /PUT IN LINE JMS ARGPRE /SET UP ARGUMENT FROM SYMBOL TABLE ILOOPF, HLT /JMS TO THE FLOATING POINT PACKAGE ROUTINE NOP /FPP SOMETIMES RETURNS TO CALL+2 JMP ILOOP /DONE SCASE, TAD JMPI /JUST DISPATCH TO ROUTINE CALLED FOR DCA .+1 HLT /JUMP TO APPROPRIATE ROUTINE JMSI, JMS I SEP1 /JMS USED FOR CALLS TO FPP BY AMODE INST JMPI, JMP I SEP1 /JMP USED TO CALL ROUTINES COMMON TO AMODE AND SMODE /JUMP TABLE FOR AMODE INSTRUCTIONS AJTAB, FFADD /FAC_C(A)+FAC OPCODE 0000 FFSUB /FAC_FAC-C(A) OPCODE 0400 FFMPY /FAC_FAC*C(A) OPCODE 1000 FFDIV /FAC_FAC/C(A) OPCODE 1400 FFGET /FAC_C(A) OPCODE 2000 FFPUT /C(A)_FAC OPCODE 2400 FFSUB1 /FAC_C(A)-FAC OPCODE 3000 FFDIV1 /FAC_C(A)/FAC OPCODE 3400 /ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE SEP1, LS1I /S1_C(A) OPCODE 4000 LS2I /S2_C(A) OPCODE 4400 FJOCI /IF TRUE, PC_C(PC,PC+1) OPCODE 5000 ILOOP /NOP OPCODE 5400 LINEI /LINE NUMBER OPCODE 6000 ARRAYI /ARRAY INST OPCODE 6400 ILOOP /NOP OPCODE 7000 OPERI /OPERATE INST OPCODE 7400 SMODE, TAD AC0 /INST OFFSET TAD JMSSI /BUILD JMP OFF STRING TABLE DCA SDIS /PUT IN LINE CLL /CLEAR LINK FOR SCALAR STRING JMS I (STFIND /SET UP ARGUMENT ADDRESS SDIS, HLT /CALL STRING ROUTINE REQUESTED /JUMP TABLE FOR SMODE INSTRUCTIONS SJTAB, SCON1 /SAC_SAC&C(A$) OPCODE 0000 SCOMP /IF SAC .NE. C(A$),PC_PC+2 OPCODE 0400 SREAD /C(A$)_DEVICE OPCODE 1000 SARITH /STRING ARITHMETIC LINKAGE OPCODE 1400 SLOAD /SAC_C(A$) OPCODE 2000 SSTORE /C(A$)_SAC OPCODE 2400 INTPC, 0 /* INTERPRETER PC OPCODE 3000 JMSSI, JMP I .+1 /* SMODE DISPATCH JMP OPCODE 3400 /OPERATE CLASS INSTRUCTIONS OPERI, TAD INSAV /GET OPERATE INSTRUCTION AND [17 /MASK OFF OPERATE OPCODE TAD JMPI3 /BUILD JUMP OFF OPERATE JUMPTABLE DCA .+1 /STORE THE JUMP IN LINE HLT /DISPATCH TO PROPER OPERATE ROUTINE JMPI3, JMP I .+1 /JUMP TO OPERATE ROUTINE CALLED FOR /OPERATE JUMP TABLE FUNC3I /CALL RESIDENT FUNCTION OPCODE 7400 SPFUNC /SPECIAL FUNCTIONS OPCODE 7401 SFN /SET FILE NUMBER OPCODE 7402 FNEGI /NEGATE FAC OPCODE 7403 RETRNI /GOSUB RETURN OPCODE 7404 RESTOR /RESTORE DEVICE OPCODE 7405 LSUB1I /LOAD S1 FROM FAC OPCODE 7406 LSUB2I /LOAD S2 FROM FAC OPCODE 7407 FUNC6I /CALL FIELD 1 FUNCTIONS OPCODE 7410 READI /READ DEVICE OPCODE 7411 WRITEI /WRITE DEVICE OPCODE 7412 SWRITE /STRING WRITE OPCODE 7413 FUNC5I /CALL FILE FUNCTION OPCODE 7414 FUNC4I /CALL USER FUNCTION OPCODE 7415 FUNC1I /CALL FUNCTIONS 1 OPCODE 7416 FUNC2I /CALL FUNCTIONS 2 OPCODE 7417 /ARGPRE-ROUTINE TO TRANSLATE OPERAND FIELD INTO 12 BIT POINTER /INTO SCALAR TABLE FOR USE IN FPP CALLS. ARGPRE, 0 TAD INSAV /GET INSTRUCTION AND [377 /STRIP TO OPERAND FIELD DCA AC0 /SAVE TAD AC0 CLL RAL /*2 TAD AC0 /PTR*3 TAD SCSTRT /MAKE 12 BIT ADDR SCALDF, HLT /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER) JMP I ARGPRE /RETURN /ROUTINE TO ZERO FAC FACCLR, 0 CLA DCA ACX /ZERO EXPONENT DCA ACL /ZERO LOW FRACTION DCA ACH /ZERO HIGH FRACTION JMP I FACCLR /SPECIAL FUNCTIONS SPFUNC, JMS I [FBITGT /ISOLATE FUNCTION BITS TAD JMPSPC /MAKE A JUMP OFF SPECIAL FUNCTION TABLE DCA .+1 /PUT IN LINE HLT JMPSPC, JMP I .+1 /JUMP TO SPECIAL FUNCTION ROUTINE /SPECIAL FUNCTION JUMP TABLE SETF /SET FSWITCH 000 FRANDM /RANDOMIZE 020 ONPFX /ON-GOTO PREFIX 040 SRLIST /STRING READ FROM DATA LIST 060 CSFN /SET FILE # TO TTY 100 RDLIST /READ DATA LIST 120 AMODE /SWITCH TO A MODE 140 SSMODE /SWITCH TO S MODE 160 PAGE /ON GOTO or GOSUB ONPFX, TAD ACH /TEST SIGN OF ACH SMA SZA CLA /IF LE TREAT AS 0 JMS I [UNSFIX CIA /SET NEGATIVE COUNT DCA AC0 ONSRCH, JMS I [PWFECH /GET GOTO/GOSUB OPCODE SNA /SKP IF NOT END OF VECTOR JMP ON /GIVE WARNING AND CONTINUE DCA INSAV /SAVE IT JMS I [PWFECH /GET ADDRESS WITHIN FIELD DCA NEWPC /SAVE IT ISZ AC0 /TEST COUNT JMP ONSRCH /GET ANOTHER ONFLSH, JMS I [PWFECH /NOW FLUSH TO END OF LIST SNA CLA JMP JMPGO /JMP IF FLUSH DONE JMS I [PWFECH CLA JMP ONFLSH ON, JMS I [ERROR /PRINT WARNING JMP I [ILOOP /EXIT TO ILOOP /JUMP ON CONDITION FJOCI, JMS I [PWFECH /GET JMP ADDRESS DCA NEWPC /SAVE IT JMPGO, TAD INSAV /PICK UP OPCODE AND [17 /MASK OFF JUMP CONDITION SNA /IS IT GOSUB? JMP GOSUB /YES-PUSH PC ON STACK THEN JUMP TAD SKPTAD /BASE TAD FOR BUILD OF TAD INSTRUCTION DCA .+1 /PUT IN LINE HLT /GET PROPER SKIP DCA .+2 /PUT IN LINE TAD ACH /GET HIGH ORDER FAC HLT /SKIP INSTRUCTION JMP SUCJMP /CONDITION TRUE-JUMP JMP I [ILOOP /CONDITION FALSE, DON'T JUMP /JMP IF FILE IS OPEN JFOPEN, CLA /FLUSH ACH FROM AC TAD I IOTHND /SEE IF HANDLER EP IS PRESENT JMP FSKIP /GO TEST FILE CONDITION /JUMP ON END OF FILE JEOFI, CLA /CLEAR HORD FROM AC JMS I [IDLE /SEE IF FILE OPEN AC0002 /MASK FOR EOF BIT IN HEADER AND I IOTHDR /GET THAT BIT FSKIP, SNA CLA /SKP INTO JUMP ROUTINE IF TRUE JMP I [ILOOP /ELSE EXIT TO ILOOP SUCJMP, TAD INSAV /GET JUMP INSTRUCTION AND [340 /MASK OFF DESTINATION FIELD CLL RTR /SLIDE OVER TAD CDFINL /MAKE A CDF INSTRUCTION DCA I [CDFPSU /AND SET NEW PC INSTRUCTION FIELD TAD NEWPC /PICK UP NEW PC JMP SETPC /SET INTERPRETER PC AND EXIT /GOSUB GOSUB, TAD I GSP SMA CLA GS, JMS I [ERROR /ERROR IF STACK OVERFLOW TAD I [CDFPSU /ELSE GET CDF INSTR DCA I GSP ISZ GSP TAD I (INTPC DCA I GSP /STORE INT PC ISZ GSP JMP SUCJMP /EXEC AS NORMAL GOTO NOW /GOSUB RETURN RETRNI, AC7776 /BACK UP STACK PTR 2 LOCATIONS TAD GSP DCA GSP TAD I GSP /GET CDF SMA /SKP IF HAVE CDF GR, JMS I [ERROR /FATAL ERROR IF NO RETURN DCA I [CDFPSU SKPTAD, TAD GSP /SET PTR TO ADDR DCA XR1 TAD I XR1 SETPC, DCA I (INTPC /SET PC JMP I [ILOOP /NOW RESUME EXECUTION NEWPC, 0 /FOR-LOOP JUMP ROUTINE /ENTER WITH AC = HORD JFOR, SNA /IS FAC=0? JMP I [ILOOP /YES-DO NOT JUMP TAD FSWITC /ADD FSWITCH SPA CLA /ARE SIGN BIT=FSWITCH? JMP I [ILOOP /NO-DO NOT JUMP JMP SUCJMP /YES-DO JUMP /ROUTINE TO INITIALIZE FSWITCH SETF, AC4000 AND ACH /ISOLATE SIGN OF MANTISSA DCA FSWITC /STORE IN FSWITCH JMP I [ILOOP /DONE FSWITC, 0 /SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS GSP, GSTCK /0 PUSHJ (STACK POINTER MUST PRECEDE SKIP TABLE) CLA /1 JUMPA SMA CLA /2 JUMPGE SZA CLA /3 JUMPN SMA SZA CLA /4 JUMPG SPA CLA /5 JUMPL SNA CLA /6 JUMPE SPA SNA CLA /7 JUMPLE JMP JFOR /10 FORLOOP JUMP ROUTINE JMP JFOPEN /11 JUMP IF FILE IS OPEN JMP JEOFI /12 JUMP IF END OF FILE SET /CALL TO DEVICE DRIVER FOR FILE I/O /ENTRY AC = FUNCTION WORD FOR READ OR WRITE /IOTABLE FOR CURRENT FILE HAS BLOCK, BUFFER ADDR, AND HANDLER ENTRY PT DRCALL, 0 DCA DRFUN /FUNCTION WORD INTO DRIVER CALL CDFINL, CDF /DF TO CURRENT FIELD TAD I IOTBUF /GET BUFFER ADDRE FROM I/O TABLE ENTRY DCA DRBUF /PUT IN DRIVER CALL TAD I IOTBLK /GET BLOCK NUMBER FROM I/O TABLE DCA DRBLK /PUT IN DRIVER CALL TAD I IOTHND /GET DRIVER ENTRY DCA DRIVER /SAVE JMS I DRIVER /CALL DRIVER DRFUN, 0 /FUNCTION CONTROL WORD DRBUF, 0 /BUFFER ADDRESS DRBLK, 0 /BLOCK # SMA CLA /DEVICE ERROR-IS IT FATAL? JMP I DRCALL /ALLS WELL DE, JMS I [ERROR /FATAL DRIVER, 0 /USE FUNCTION-TAKES WORD FOLLOWING CALL AND STUFFS IT IN USECON FOR /USE A BUFFER POINTER FOR USER SUBROUTINE USE, JMS I [PWFECH /GET NEXT WORD FROM PSEUDO-CODE STREAM DCA USECON /STORE IN PAGE 0 SLOT JMP I [ILOOP /RETURN PAGE /HANDLE SUBSCRIPTED NUMERIC AND STRING VARIABLES ARRAYI, TAD INSAV /FIRST GET OPCODE AND [340 CLL RTR RTR TAD MODESW /SHIFT MODE SWITCH TO LINK RAR TAD (AJTAB /ASSUME ARITHMETIC MODE SZL /SKP IF ARITH MODE TAD (SJTAB-AJTAB /CORRECT ADDR OF DISPATCH TABLE DCA ARAYOP /LINK MUST NOT TOGGLE ON ABOVE ADD TAD I ARAYOP /PICK UP DISPATCH ADDR DCA ARAYOP /SAVE IT SZL /SKP IF ARITH MODE JMP SARRY /ELSE DO STRING ARRAY OPERATION TAD INSAV /GET ARRAY INSTRUCTION AND (37 /MASK OFF ARRAY OPERAND CLL RTL /MULTIPLY BY 4 (ENTRY LENGTH) TAD ARSTRT /MAKE POINTER INTO ARRAY TABLE DCA XR1 /POINTS TO ARRAY FOR THIS OPERATION ATABDF, HLT /CHANGE DF TO ARRAY TABLE FIELD (SET BY START) IFZERO EAE< TAD I XR1 /GET POINTER TO FIRST ARRAY ELEMENT DCA TEMP2 /SAVE FOR LATER TAD I XR1 /GET DF FOR VARIABLE DCA ADFC /PUT IN LINE AT END OF ROUTINE TAD I XR1 /GET ARRAY DIMENSION 1 DCA AC2 /SAVE TAD S1 /GET SUBSCRIPT 1 CLL CMA /SET UP 12 BIT COMPARE TAD AC2 /DIMENSION 1 +1 SNL CLA /S1 TOO BIG? SU, JMS I [ERROR /YES-SUBSCRIPT OUT OF BOUNDS ERROR DCA OPH /CLEAR TEMPORARY TAD I XR1 /GET DIMENSION 2 SNA /IS SECOND DIMENSION 0?(ARRAY UNIDIMENSIONAL) JMP ADCALC /YES-DON'T CHECK S2 FOR OUT OF BOUNDS CLL CIA /COMPARE TO SUBSCRIPT 2 TAD S2 SZL CLA /SKP IF S2 LO DIM2+1 JMP SU /ELSE TAKE ERROR EXIT TAD S2 /MULTIPLY DIM1+1 BY S2 JMS I (MPY /12 BY 12 MULTIPLY ROUTINE ADCALC, CLL TAD S1 /LORD OF S1+(DIM1+1)*S2 DCA OPX /SAVE RAL /CARRY TO BIT 11 TAD OPH /HORD OF S1+(DIM1+1)*S2 DCA OPH /SAVE TAD OPX /LORD OF S1+(DIM1+1)*S2 CLL RAL /*2 DCA OPL /LORD OF [S1+(DIM1+1)*S2]*2 TAD OPH /HORD OF S1+(DIM1+1)*S2 RAL /*2 DCA AC2 /HORD OF [S1+(DIM1+1)*S2]*2 CLL TAD OPX /LORD OF S1+(DIM1+1) TAD OPL /LORD OF [S1+(DIM1+1)*S2] DCA OPL /LORD OF 3*[S1+(DIM1+1)*S2] RAL /CARRY TO BIT 11 TAD OPH /HORD OF [S1+(DIM1+1)*S2)*2 TAD AC2 /HORD OF S1+(DIM1+1)*S2 DCA OPH /HORD OF 3*[S1+(DIM1+1)*S2] CLL TAD OPL /INDEX TO ELEMENT TAD TEMP2 /AC POINTS TO CORRECT ARRAY ELEMENT DCA XR1 /SAVE POINTER RAL /CARRY TO BIT 11 TAD OPH /COMBINE TO MAKE TOTAL # OF FIELD OVERLAPS CLL RTL RAL /SLIDE OVERLAPS TO FIELD BITS (6-8) TAD ADFC /ADD ANY CHANGE IN DATA FIELD TO CDF DCA ADFC /PUT ABSOLUTE CDF IN LINE > IFNZRO EAE< TAD I XR1 /GET ADDR OF FIRST ELEMENT DCA ABASE /STORE TAD I XR1 /GET CDF TO FIRST ELEMENT DCA ADFC /STORE INLINE TAD I XR1 /GET DIM1+1 DCA AC2 /SAVE IT TAD AC2 /TEST VALUE OF S1 CLL CIA TAD S1 SZL CLA /SKP IF S1 LO DIM1+1 SU, JMS I [ERROR /ELSE TAKE ERROR EXIT TAD S1 /LOAD S1 TO MQ SWAB /AND SET B MODE EAE TAD I XR1 /GET DIM2+1 CDF SNA /SKP IF HAVE 2 DIMENSIONS JMP ONESS /SINGLE DIMENSION, SKIP THIS CALCULATION CLL CIA /SIZE CHECK S2 TAD S2 SZL CLA /SKP IF S2 LO DIM2+1 JMP SU /ELSE ERROR TAD S2 /COMPUTE S1+S2*(DIM1+1) SWP MUY AC2 /DIM1+1 ONESS, DST OPH /SAVE DOUBLEWORD SHL /*2 1 DAD OPH /*3 DAD ABASE /ADD TO BASE OF ARRAY CLL RTL /ADD CARRYS INTO CDF RAL TAD ADFC DCA ADFC /STORE BACK INLINE MQA /GET ADDRESS POINTER DCA XR1 /TO XR1 > IAC DCA FF /PUT FPP IN "SPECIAL MODE" ADFC, HLT /CHANGE DF TO DF OF ARRAY ELEMNT TAD XR1 /AC POINTS TO ARRAY ELEMENT JMS I ARAYOP /PERFORM REQUIRED OPERATION JMP I [ILOOP /FPP SOMETIMES RETURNS TO CALL+2 JMP I [ILOOP /DONE SARRY, JMS I (STFIND /INIT STRING ROUTINES (LINK ON) JMP I ARAYOP /JMP TO STRING ROUTINE ARAYOP, 0 IFNZRO EAE< ABASE, ZBLOCK 2 > /SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC FBITGT, 0 TAD INSAV CLL RTR RTR /PUT FUNCTION BITS IN BITS 8-11 AND [17 /MASK THEM OFF JMP I FBITGT /RETURN /SUBROUTINE FTYPE-RETURNS TO CALL+1 IF FILE NUMERIC,CALL+2 IF ASCII FTYPE, 0 TAD I IOTHDR /GET HEADER CLL RAR /TYPE TO LINK SZL CLA /IS IT NUMERIC? ISZ FTYPE /NO-BUMP RETURN JMP I FTYPE /RETURN /CALL FOR RESIDENT FUNCTION FUNC3I, JMS I [FBITGT /ISOLATE FUNCTION # TAD JMPRES /MAKE A JUMP OFF JUMP TABLE DCA .+1 HLT JMPRES, JMP I .+1 /JUMP TABLE FOR RESIDENT FUNCTIONS XABSVL /FUNCTION BITS 000 COMMA / 020 CRFUNC / 040 ILOOPF / 060 UNUSED TAB / 100 PNT / 120 USE / 140 PUINIT / 160 PRINT USING INIT PUEXEC / 200 PRINT USING OUTPUT CURSOR / 220 CURSOR POSITIONING FUNCTION AND23 / 240 23 BIT LOGICAL AND IOR23 / 260 23 BIT LOGICAL OR COL / 300 IO CHANNEL PRINT COLUMN NUMBER /CALL FOR FIELD 1 FUNCTIONS FUNC6I, JMS I [FBITGT /GET FUNCTION BITS CIF CDF 10 /JMP TO FIELD 1 DISPATCHER WITH AC = FUNCTION NUMBER JMP I (F1DISP PAGE /STRING ARITHMETIC INTERFACE SARITH, CLA IAC /CALL IN OVERLAY 1 JMS I (OVLOAD JMP I (XSARITH /NOW JMP TO STRING DISPATCH ROUTINE /PRINT USING INTERFACE PUINIT, CLA IAC /CALL OVERLAY 1 JMS I (OVLOAD JMP I (XPUINIT PUEXEC, CLA IAC JMS I (OVLOAD /CALL OVERLAY 1 JMP I (XPUEXEC /FLOATING NEGATE FNEGI, JMS I [FFNEG /NEGATE THE FAC JMP I [ILOOP /DONE /ERROR TRAPS O0, JMS I [ERROR /OVERFLOW DV, JMS I [ERROR /DIVISION ERROR JMS I [FACCLR /RETURN 0 IN FAC JMP I [ILOOP LM, JMS I [ERROR /ILLEGAL ARGUMENT /AND(L,R) - 23 BIT LOGICAL AND FUNCTION AND23, JMS FIXRGS /GET THE PAIR OF ARGUMENTS TAD ACL AND TEMP1 DCA ACL /AND THE LOW BITS TAD ACH AND TEMP2 JMP FLOTHI /FLOAT RESULT AND EXIT /IOR(L,R) - 23 BIT LOGICAL INCLUSIVE OR IOR23, JMS FIXRGS /GET THE PAIR OF ARGUMENTS TAD ACL /OR THE LOW BITS AND TEMP1 CIA TAD ACL TAD TEMP1 DCA ACL TAD ACH /INCLUSIVE OR THE HIGH BITS AND TEMP2 CIA TAD ACH TAD TEMP2 JMP FLOTHI /GO STORE HIGH BITS AND EXIT /CUR$(V,H) FUNCTION FOR VT52 /DIRECTLY OUTPUTS TO CURRENT I/O CHANNEL AND SETS NEW PRINT COLUMN /ADDR 0,0 IS UPPER LEFT CORNER OF SCREEN /SHOULD NORMALLY BE CALLED FROM PRINT STATEMENTS ONLY CURSOR, JMS FIXRGS /FIX THE ARGUMENTS DCA SACLEN /RETURN NULL STRING (SO PRINT POSITION WILL NOT ALTER) TAD (33 JMS I [PUTCH /OUTPUT ESC TAD (131 JMS I [PUTCH /OUTPUT "Y" TAD TEMP1 AND [177 TAD [40 /ADD TERMINAL BIAS JMS I [PUTCH /OUTPUT VERTICAL ADDR TAD ACL AND [177 TAD [40 /ADD BIAS JMS I [PUTCH /OUTPUT HOROZONTAL ADDR TAD ACL /NOW SET NEW HOROZONTAL PRINT POSITION AND [177 DCA I IOTPOS JMP I (SSMODE /RETURN IN SMODE /COL(N) - RETURN PRINT COLUNM NUMBER FOR I/O CHANNEL N COL, JMS I (SETIOT /PICK UP RELATIVE ADDR OF IO CHANNEL N TAD (TTYF+IOTPOS-IOTHDR /MAKE ABSOLUTE PRINT POSITION ADDR DCA AC0 TAD I AC0 /GET IT /FALL INTO FLOAT ROUTINE FLOT12, DCA ACL /STORE 12 BIT INTEGER FLOTHI, DCA ACH /CLEAR HIGH ORDER BITS FLOT23, DCA AC1 /CLEAR OVERFLOW BITS TAD (27 /SET EXPONENT DCA ACX JMS I [FFNOR /NORMALIZE THE INTEGER JMP I [ILOOP /RETURN TO ILOOP /FIX TWO REAL ARGUMENTS TO 23 BITS FIXRGS, 0 JMS I (FIX23 /FIX THE FAC TAD ACH /SAVE THE INTEGER DCA TEMP2 TAD ACL DCA TEMP1 DCA INSAV /GET TEMP0 JMS I PARGPRE JMS I [FFGET PARGPRE,ARGPRE JMS I (FIX23 /FIX IT TOO JMP I FIXRGS /RETURN /LINE NUMBERS LINEI, TAD INSAV /GET INSTRUCTION DCA LINEHI /SAVE JMS I [PWFECH /GET WORD FOLLOWING LINE # INST DCA LINELO /SAVE AS LOW ORDER LINE # TRHOOK, JMP I [ILOOP /RETURN TO I-LOOP TAD (4 /LOAD OVERLAY 4 JMS I (OVLOAD JMP I (TPRINT /NOW JMP TO PRINT ROUTINE /INTERMEDIATE CHAR BUFFER FOR "FFOUT" /AND A FEW FPP TEMPORARIES INTERB, ZBLOCK 7 FPPTM5, ZBLOCK 3 FPPTM4, ZBLOCK 3 FPPTM3, ZBLOCK 3 NUMBUF, FPPTM2, ZBLOCK 3 FPPTM1, ZBLOCK 3 PAGE /VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE) HEIGHT, 0 /NEGATIVE SCREEN HEIGHT DELAY, 0 /NEGATIVE DELAY VALUE IFNZRO HEIGHT-1200 <__FIX SET COMMAND__> HCTR, 0 /HEIGHT COUNTER INITIALIZED BY SET DCTR, 0 /DELAY COUNTER INITIALIZED BY SET /LOW LEVEL ROUTINE TO TYPE A CHAR PCH, 0 PCHLP, ISZ SPINNR /SPIN RND NUMBER SEED WHILE WAITING TSF /WAIT FOR PREV CHAR JMP PCHLP TLS /TYPE THE CURRENT ONE AND [177 /MASK TO 7BIT TAD (-15 /TEST IF LINE FEED WILL BE SENT NEXT SZA CLA JMP PCHXIT /RETURN IF NOT ISZ HCTR /TEST SCREEN HEIGHT IF LF JMP PCHXIT /RETURN IF NOT AT BOTTOM OF SCREEN TAD HEIGHT DCA HCTR /RESET HEIGHT COUNTER NOW TAD DELAY SNA /TEST FOR ZERO DELAY JMP PCHXIT /RETURN IF SO DCA DCTR /ELSE SET DELAY COUNTER DLOOP, ISZ GCH /NOW EXEC INNER LOOP 4096 TIMES (USUALLY) JMP .-1 KSF /TEST IF KEY STRUCK SKP JMP PCHXIT /RETURN AT ONCE IF YES ISZ DCTR /TEST DELAY TIMER JMP DLOOP /REITERATE PCHXIT, JMS CTCCHK /TEST FOR ^C HIT TAD XFLAG SZA CLA JMP PCHXIT /LOOP IF ^S HIT JMP I PCH /NOW ALLOW PRINTING TO CONTINUE /LOW LEVEL ROUTINE TO WAIT FOR A CHAR FROM THE CONSOLE GCH, 0 TAD O2525 /LOAD PATTERN INTO AC GCHLP, KSF JMP SPIN /SPIN RND SEED WHILE WE WAIT CLA CLL /CLEAR PATTERN FROM AC JMS CTCCHK /FIRST SEE IF ANY CONTROL CHARS HIT KSF JMP GCH+1 /LOOP IF NO CHAR KRB /READ CHAR AND CLEAR FLAG AND [177 /MASK TO 7 BITS JMP I GCH /RETURN TO CALLER SPIN, ISZ SPINNR /SPIN RANDOM NUMBER SEED JMP GCHLP CMA CML RAL /MOVE PATTERN JMP GCHLP /LOOP /CHECK FOR CONTROL C STRUCK CTCCHK, 0 CTCNOP, KSF /IS KEYBOARD FLAG UP? (NOP'D ON FATAL ERRORS) JMP I CTCCHK /NO, RETURN KRS /SAMPLE CHAR AND [177 /REMOVE PARITY BIT TAD (-3 /SEE IF ^C HIT SNA JMP CCTRAP /YES, ABORT EXECUTION TAD (3-21 /SEE IF ^Q (XON) OR ^S (XOFF) HIT CLL RTR SZA CLA /SKP IF EITHER JMP I CTCCHK /ELSE RETURN WITH CHAR STILL IN BUFFER RAL /LINK ON IF ^S DCA XFLAG /SET FLAG APPROPRIATELY KCC /CLEAR CHAR FROM BUFFER JMP I CTCCHK /RETURN CCTRAP, KCC /CLEAR ^C CLA IAC /SET COLUMN NONZERO TO FORCE CRLF BEFORE MESSAGE DCA I (TTYF+IOTPOS-IOTHDR CC, JMS I [ERROR /TAKE ERROR ABORT WITH MESSAGE XFLAG, 0 /^S FLAG (ALSO MARKS START OF GOSUB STACK) SPINNR, 0 /NEW RANDOM NUMBER SEED FOR RANDOMIZE (HIGH 12 BITS) /GOSUB STACK GSTCK, 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 6000;0 O2525, 2525 /POSITIVE TO MARK THE END OF THE GOSUB STACK PAGE /INTERPRETER ERROR ROUTINE /ENTRY DF = CALLING FIELD IF NON FATAL ERROR /ACHTUNG! NON FATAL ERRORS FROM WITHIN OVERLAYS SWAP THEM OUT ERROR, 0 CLA CLL /ENTRY AC RANDOM RDF /READ DF OF CALLER TAD .+2 /STORE RETURN IN CASE NON FATAL DCA XERRRET CIF CDF CLA CLL IAC AND PSFLAG /TEST IF OS/8 17600 RESIDENT SZA CLA /SKP IF NOT JMS I [PSWAP /ELSE FORCE IT OUT TAD I (OVRLAY /SAVE PREVIOUS OVERLAY DCA OVSAVE TAD (4 /BRING IN ERROR OVERLAY JMS OVLOAD JMS I (ERRORR /JMP TO ERROR HANDLER TAD OVSAVE /NOW RESTORE PREV OVERLAY JMS OVLOAD XERRRET,HLT JMP I ERROR /RETURN TO CALLER IF NON FATAL ERROR OVSAVE, 0 /LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY LSUB2I, ISZ DCASUB JMP LSUB1I LS2I, ISZ DCASUB LS1I, JMS I [FFPUT /SAVE THE FAC INTERB JMS I (ARGPRE /GET ARG POINTER INTO AC JMS I [FFGET /LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN) DCAS1, DCA S1 JMP .+3 LSUB1I, JMS I [FFPUT /SAVE THE FAC INTERB JMS I [UNSFIX /GET INT(FAC) DCASUB, DCA S1 /SET RESULT AS SUBSCRIPT 1 JMS I [FFGET /RESTORE THE FAC INTERB TAD DCAS1 DCA DCASUB /FUDGE INSTR BACK JMP I [ILOOP /NEXT INSTRCUTION /FUNCTION OVERLAY DRIVER FUNC4I, IAC /USER FUNCTIONS FUNC5I, IAC /FILE FUNCTIONS FUNC2I, IAC /STRING FUNCTIONS FUNC1I, JMS OVLOAD /MATH FUNCTIONS JMP I (OVDISP /JMP TO OVERLAY DISPATCHER /ROUTINE FOR CROSS FIELD SUBROUTINE CALLS CALLF0, 0 CDF 10 /ALWAYS SET DF TO 1 DCA ACARG /SAVE THE AC TAD I CALLF0 /GET ROUTINE ADDR ISZ CALLF0 /BUMP PAST ROUTINE ADDR DCA SUBRTN CDF /SET DF TO OUR FIELD TAD ACARG /GET CALLING AC JMS I SUBRTN /CALL THE ROUTINE SKP /ALLOW SKIP RETURNS ISZ CALLF0 CIF CDF 10 /RETURN TO CALLER JMP I CALLF0 ACARG, 0 SUBRTN, 0 /OVERLAY LOAD ROUTINE OVLOAD, 0 DCA AC0 /STORE OVERLAY NUMBER PASSED IN AC CDF /DF TO THIS FIELD TAD AC0 /GET OVERLAY # AGAIN CIA /NEGATE TAD OVRLAY /COMPARE AGAINST OVERLAY FLAG SNA CLA /IS THE ONE WE WANT ALREADY RESIDENT? JMP I OVLOAD /YES-JUST JUMP TO FUNCTION TAD AC0 /NO-GET NUMBER OF OVERALY DESIRED TAD (ARITHA /USE AS OFFSET TO BUILD STARTING BLOCK TAD DCA TEMP2 /POINTS TO PROPER STARING BLOCK # TAD I TEMP2 /GET STARTING BLOCK FOR THIS OVERLAY SNA /SKP IF NON RESIDENT IN FIELD 2 JMP INCORE /ELSE DO FAST CORE SHUFFLE DCA OVADD /PUT IN DRIVER CALL JMS I (7607 /CALL SYSTEM HANDLER 0600 /OVERLAY 3400-4777 OVERLAY OVADD, 0 /STARTING BLOCK # OF OVERLAY OE, JMS I [ERROR /I/O ERROR JMP OVREDY /ALL SET, EXIT INCORE, TAD AC0 /CONVERT NEW OVERLAY NUMBER TO POINTER CLL RAR TAD AC0 /*3 RTR RTR /SHIFT TO PAGE BITS TAD (-1 /THEY START AT *20000 DCA XR1 TAD (OVERLAY-1 /NOW SET FIELD 0 PTR DCA XR2 TAD [7400 /MOVE 6 PAGES DCA TEMP2 OVMOVE, CDF 20 /GET A WORD FROM FIELD 2 TAD I XR1 CDF DCA I XR2 /STORE HERE IN OUR FIELD CDF 20 /DO 3 TIMES IN LINE TAD I XR1 CDF DCA I XR2 /SAVES 512 ISZ/JMP'S CDF 20 TAD I XR1 CDF DCA I XR2 ISZ TEMP2 JMP OVMOVE OVREDY, TAD AC0 DCA OVRLAY /CHANGE RESIDENT FLAG JMP I OVLOAD /--RETURN-- OVRLAY, 0 /# OF CURRENTLY RESIDENT OVERLAY /0=ARITHMETIC,1=STRING,2=FILE,3=USER,4=ERROR /OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS /INITIALIZED BY LOADER. ENTRY SET TO ZERO INDICATES OVERLAY RESIDENT IN FIELD 2 ARITHA, 0 /STARTING BLOCK OF ARITHMETIC OVERLAY STRNGA, 0 /STARTING BLOCK OF STRING OVERLAY FILEFA, 0 /STARTING BLOCK OF FILE OVERLAY USRA, 0 /STARTING BLOCK OF USER FUNCTIONS ERRA, 0 /STARTING BLOCK OF ERROR MESSAGE PROCESSOR PAGE /ERROR EXIT FOR USER FUNCTIONS IA, JMS I [ERROR /ROUTINE TO FIX A POSITIVE 23 BIT INTEGER FROM FAC /RESULT IN ACH;ACL /ERROR IF NEGATIVE NUMBER OR OUT OF RANGE EXPONENT FIX23, 0 TAD ACH /FIRST TEST IF POSITIVE SPA CLA FM, JMS I [ERROR /JMP OUT IF ERROR TAD ACX /SEE IF LT 1 SPA SNA CLA /TRUNCATE TO ZERO IF YES TAD (-30 SMA /SKP IF RESULT LT 2**23 FO2, JMS I [ERROR /ELSE TAKE ERROR EXIT IFZERO EAE< DCA ACX /SET SHIFT COUNTER TAD ACX /TEST IF MORE THAN 12. SHIFTS TAD (14 SMA JMP LT12 /JMP IF NO DCA ACX /DROP COUNTER DOWN IF YES TAD ACH /DO FAST WORD SHIFT DCA ACL DCA ACH LT12, CLA JMP FIXGO /JMP INTO LOOP FIXLUP, TAD ACH /NOW SHIFT DOUBLE WORD RIGHT CLL RAR DCA ACH TAD ACL RAR DCA ACL FIXGO, ISZ ACX /TEST IF DONE YET JMP FIXLUP /NO, ITERATE > IFNZRO EAE< CMA /SET SHIFT COUNT DCA FXSHFT /STORE INLINE SWAB /GET INTO B MODE DLD ACH /LOAD FRACTION BITS SWP LSR /DO THE SHIFT FXSHFT, 0 DCA ACH /STORE BACK IN FAC SWP /(DST WON'T CLEAR AC) DCA ACL > JMP I FIX23 /OK, RETURN /ROUTINE TO FIX A POSITIVE 12 BIT NUMBER FROM FAC /RETURN RESULT IN AC /SPECIAL CASE OF FIX23 UNSFIX, 0 CDF /RESET DF ON ENTRY JMS FIX23 /FIX THE FAC TAD ACH /SEE IF GE 2**12 SZA CLA /SKP IF NO FO, JMS I [ERROR /ELSE TAKE ERROR EXIT TAD ACL /OK, RETURN LOW 12 BITS JMP I UNSFIX /--RETURN-- /RESTORE ROUTINE RESTOR, TAD ENTNO /GET CURRENT FILE # SNA CLA /IS IT 0? JMP RESDLS /YES-RESTORE DATA LIST JMS I (WRBLK /NO-WRITE CURRENT BUFFER STA /-1 TAD I IOTLOC /STARTING BLOCK-1 DCA I IOTBLK /SET CURRENT BLOCK # TAD I IOTBUF /GET BUFFER ADDRESS DCA I IOTPTR /USE IT TO RESET READ\WRITE POINTER TAD I IOTHDR /GET HEADER WORD AND (7535 /CLEAR EOF BIT, BUFFER WRITTEN BIT, AND CHAR #3 FLAG DCA I IOTHDR JMS I (NEXREC /READ FIRST BLOCK INTO BUFFER JMP I [ILOOP /DONE RESDLS, TAD DLSTRT /ADDRESS OF START OF INCORE DATA LIST DCA DATAXR /USE IT TO RESET DATA LIST POINTER JMP I [ILOOP /THATS ALL! /SUBROUTINE STFIND-WHEN CALLED,IF LINK=1 STRING ARRAY TABLE IS /USED,IF LINK=0 STRING SYMBOL TABLE IS USED. RETURNS WITH AC SET /TO CDF OF OPERAND STRING,STRPTR POINTING TO THE FIRST WORD /IN THE STRING, AND THE MAX LENGTH OF THE STRING IS IN STRMAX. ALSO, /THE ACTUAL LENGTH OF THE STRING IS IN STRCNT STFIND, 0 SZL /IS THIS AN ARRAY INST? JMP SAFIND /YES-POINTER IS INTO ARRAY TABLE TAD INSAV /GET INST AGAIN AND [377 /ISOLATE OPERAND POINTER DCA AC0 /NO-SAVE OPERAND POINTER TAD AC0 /N CLL RAL /2N TAD AC0 /3N (3 WORDS/ENTRY) TAD STSTRT /ADD BASE ADR OF STRING TABLE STCOM, DCA XR2 /POINTER TO THIS ENTRY IN STRING TABLE STDF, HLT /DF TO THAT OF SYMBOL TABLES (SET BY START) TAD I XR2 /GET POINTER TO STRING DCA STRPTR TAD I XR2 /GET CDF FOR OPERAND STRING DCA STRCDF /SAVE TAD I XR2 /GET NUMBER OF WORDS PER STRING DCA STRMAX /SAVE SNL /ARRAY ELEMENT? JMP STRCDF /NO-SKIP THIS SUBSCRIPT CALCULATION TAD S1 /GET SUBSCRIPT STL CMA /SET UP 12 BIT COMPARE TAD I XR2 /GET DIMENSION SZL CLA /IS S1>DIMENSION? JMP I (SU /YES IFZERO EAE< TAD STRMAX /GET NUMBER OF WORDS PER ELEMENT DCA AC2 /# OF WORDS IN EACH ARRAY ELEMENT TAD S1 /GET SUBSCRIPT JMS I (MPY /S1*ELEMENT LENGTH (ASSUMES LINK UNCHANGED ON RETURN) TAD STRPTR /ARRAY OFFSET+POINTER TO A(0) DCA STRPTR /FINAL STRING POINTER RAL /CARRY TO BIT 11 TAD OPH /ADD TO ACCUMLATED OVERLAPS FROM MULTIPLY CLL RTL RAL /PUT OVERLAP # INTO BITS 6-8 TAD STRCDF /ADD TO CDF IF NECESSARY DCA STRCDF /SAVE AGAIN > IFNZRO EAE< CDF TAD STRMAX /GET NUMBER OF WORDS/ELEMENT SWAB /TO MQ TAD STRPTR /CALCULATE STRPTR+S1*STRMAX MUY S1 CLL RTL RAL TAD STRCDF /ADD CARRY TO CDF DCA STRCDF /STORE BACK INLINE MQA /GET ADDRESS DCA STRPTR /STORE IT > STRCDF, 0 /DF TO STRING FIELD TAD I STRPTR CDF DCA STRCNT /STORE -(CURRENT LENGTH OF STRING) TAD STRCDF /CDF TO OPERAND IN AC DCA I (SSTEX /SETUP STRING STORE EXIT DF HERE STA /NOW SET MAX SIZE OF STRING IN CHARS TAD STRMAX CLL RAR TAD STRMAX CIA /NEGATE IAC /COMPENSATE FOR SIZE WORD DCA STRMAX JMS I (BYTSET /ENTER FUNCTIONS WITH BYTE POINTERS SETUP JMP I STFIND /RETURN SAFIND, TAD INSAV /GET INST AND (37 /ISOLATE OPERAND POINTER CLL RTL /4N (4 WORDS/ENTRY) TAD SASTRT /USE STRING ARRAY TABLE STL /SET LINK FOR ARRAY INST JMP STCOM /RETURN TO SUBROUTINE MAINLINE PAGE /ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER /AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER CSFN, DCA ACL /RESET CHANNEL NUMBER TO CONSOLE SKP SFN, JMS SETIOT /GO GET ADDRESS OF IOTABLE FOR THIS CHANNEL TAD (TTYF /MAKE ABSOLUTE POINTER TO HEADER WORD DCA XR1 /STORE IN TEMP TAD ACL /SET ENTRY NUMBER FROM LOW FAC DCA ENTNO TAD (IOTHDR-1 /NOW POINT AT PAGE 0 AREA DCA XR2 TAD (IOTHDR-IOTFIL-1 /SETUP ALL BUT FILENAME DCA TEMP2 SFNLUP, TAD XR1 DCA I XR2 ISZ XR1 ISZ TEMP2 JMP SFNLUP /SET UP THE POINTERS NOW AC7776 /NOW GET USER RECORD SIZE (PHYS RECORD SIZE-2) TAD I IOTRSZ SZL /SKP IF HAVE A SIZE CLA /ELSE ASSUME 0, NOT DIRECT ACCESS CDF 10 DCA I (REMSIZ /STORE INITIAL REMAINING SIZE IN RECORD DCA I (EOLPTR /ZERO THE ONCE ONLY FLAG CDF TAD I IOTSUB /NOW SET THE FIELD POINTER CDF 10 DCA I (NXTFLD / CDF JMP I [ILOOP /--RETURN-- /ROUTINE TO PICK UP AND RANGE CHECK AN I/O CHANNEL NUMBER FROM FAC SETIOT, 0 JMS I [UNSFIX /FIX FAC TO GET FILE # STL TAD (-MAXFIL /IS RESULT A LEGAL FILE #? SNL SZA CLA FN, JMS I [ERROR /NO-ERROR TAD ACL /PICK UP FILE NUMBER CLL RAL /*2 CLL RTL /*10 TAD ACL /*11 CLL RAL /*22 IFNZRO IOTSIZ-22 <__ASSEMBLY ERROR__> JMP I SETIOT /RETURN WITH AC INDEXING INTO IOTABLE /ROUTINE TO RETURN RECORD FIELD DEFINITIONS TO FREELIST RTNDEF, 0 TAD I IOTSUB /GET HEAD OF USER DEFINED FIELDS CDF 10 RTNLUP, SNA /SKP IF HAVE ONE JMP EORETN /ELSE DONE DCA AC0 /SAVE IT TAD I AC0 /GET ITS LINK DCA AC1 /SAVE IT TAD I (FREHD /NOW GET THE CURRENT FREELIST PTR DCA I AC0 /STORE IN CURRENT FIELD BUFFER TAD AC0 /UPDATE FREELIST DCA I (FREHD TAD AC1 /REPEAT FOR NEXT ONE JMP RTNLUP EORETN, CDF DCA I IOTSUB /ZERO THE RECORD FIELD LIST NOW JMP I RTNDEF /--RETURN-- /ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE) /WHERE N IS THE HIGH CORE FIELD PSWAP, 0 TAD P7600 /POINTER TO 17600 AND COUNTER DCA AC0 TAD PSFLAG /GET SWAPPING FLAGS RAR CML RAL /TOGGLE THE INPLACE BIT DCA PSFLAG /STORE IT BACK TAD HICORE /PICK UP ADDR OF HIGH CORE DCA TEMP2 /POINTER TO HIGH CORE P1CDF, HLT /DF TO HI CORE TAD I TEMP2 /GET WORD FROM HI CORE DCA TM /SAVE IT P2CDF, CDF 10 TAD I AC0 /GET WORD FROM 17600 P1CDF1, HLT /DF TO HI CORE AGAIN DCA I TEMP2 /PUT 17600 WORD IN HI CORE P2CDF1, CDF 10 TAD TM /GET SAVED HI CORE WORD DCA I AC0 /AND PUT IN 17600 ISZ TEMP2 /BUMP HI CORE POINTER P7600, 7600 /CLA ISZ AC0 /BUMP 17600 POINTER AND CHECK FOR DONE JMP P1CDF /NO DONE-MOVE NEXT WORD CDF JMP I PSWAP /DONE-RETURN HICORE, 0 /POINTS TO LOCATION OF 17600 SAVE AREA /STRING COMPARE /COMPARE SAC WITH MEMORY, BLANK EXTENDING THE /SHORTER STRING ON THE RIGHT SCOMP, DCA MODESW /SET INTERPRETER TO ARITH MODE NOW JMS I [FACCLR /TENTATIVELY ASSUME EQUAL (FAC = 0) SCOMLP, TAD STRCNT /IS THE MEMORY STRING EMPTY NOW? SNA CLA TAD L40 /PAD WITH SPACE IF YES SNA JMS I (LDB /LOAD NEXT BYTE IF NOT DCA TEMP2 TAD SACLEN /NOW IS THE SAC EMPTY SNA CLA TAD L40 /YES, PAD IT CDF 10 /GET INTO SAC FIELD SNA TAD I SACXR /NO GET IT CDF CLL CIA /COMPARE TO MEMORY TAD TEMP2 SZA CLA JMP SNEQ /JMP IF NOT EQUAL, L=SENSE OF COMPARE TAD STRCNT /IS MEMORY STRING DONE SZA CLA ISZ STRCNT /NO, BUMP COUNT L40, 40 /EFFECTIVE NOP TAD SACLEN /IS THE SAC EMPTY SZA CLA ISZ SACLEN /NO BUMP COUNT TAD SACLEN /GET SAC REMAINDER (SKP IF IS JUST ZERO) TAD STRCNT /ADD ARG REMAINDER SZA CLA JMP SCOMLP /LOOP IF BOTH NOT EMPTY JMP I [ILOOP /OTHERWISE EQUAL SNEQ, STA RAR DCA ACH /STORE SIGN BIT JMP I [ILOOP /--RETURN-- PAGE /STRING DATA LIST READ, STRING LOAD AND STRING CONCATENATE NOP /PAD TO CHANGE VALUE OF TAG "SC" SRLIST, JMS DLREAD /FIRST READ NEG BYTE COUNT DCA STRCNT /STORE IT TAD DATAXR /NOW KLUDGE UP LDB ROUTINE DCA I (BYTPTR TAD (LDBL DCA I (GIVB TAD DLCDF DCA I (BYTCDF DCA SACLEN /CLEAR LENGTH OF CURRENT STRING JMS SCOMN /CALL COMMON CODE TAD I (BYTPTR /NOW RESTORE DATA LIST POINTER DCA DATAXR JMP I [ILOOP /DONE SLOAD, DCA SACLEN /CLEAR SAC LENGTH IF LOAD SCON1, JMS SCOMN /CALL COMMON CODE JMP I [ILOOP /DONE SCOMN, 0 TAD STRCNT SNA CLA JMP I SCOMN /NOTHING TO DO IF NULL STRING TAD SACLEN /COMPUTE OFFSET INTO SAC CIA TAD [SAC-1 DCA SACXR /TO STORE AFTER END OF PREV STRING SEGCOM, JMS I (LDB /GET A BYTE CDF 10 DCA I SACXR /STORE IT CDF STA TAD SACLEN /NOW BUMP SIZE OF SAC DCA SACLEN TAD SACLEN /CHECK IF ROOM LEFT TAD (SACLIM SPA CLA SC, JMS I [ERROR /FATAL ERROR IF SAC OVERFLOW ISZ STRCNT JMP SEGCOM /ITERATE IF MORE JMP I SCOMN /--RETURN-- /SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS /OF AC2 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN OPH /AND THE LOW RESULT IN THE AC MPY, 0 DCA TEMP1 DCA OPH TAD (-14 DCA OPX MP12LP, TAD AC2 RAR DCA AC2 TAD OPH SNL JMP .+3 /12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2 CLL TAD TEMP1 RAR DCA OPH ISZ OPX JMP MP12LP TAD AC2 /LORD OF (DIM1+1)*S2 IN AC RAR /HORD OF (DIM1+1)*S2 IN OPH JMP I MPY /RETURN /ROUTINE TO CHECK IF FILE IDLE IDLE, 0 TAD I IOTHND /GET HANDLER ENTRY SNA CLA /IS IT EMPTY? FI, JMS I [ERROR /YES-USER TRIED TO DO SOMETHING TO AN UNOPEN FILE JMP I IDLE /NO-RETURN /ROUTINE TO READ NEXT WORD IN DATALIST INTO AC DLREAD, 0 TAD DATAXR /DATA LIST POINTER CLL CMA /SET UP 12 BIT COMPARE TAD DLSTOP /ADDR OF END OF DATA LIST SNL CLA /POINTER AT END OF LIST? DA, JMS I [ERROR /YES DLCDF, . /NO-DF TO DATA LIST TAD I DATAXR /FETCH WORD FROM DATA LIST CDF JMP I DLREAD /DONE /RANDOMIZE STATEMENT FRANDM, TAD I (SPINNR /LOAD NEW VALUE INTO HIGH ORDER 12 BITS OF SEED DCA SEEDH JMP I [ILOOP /RETURN TO ILOOP SEEDH, 0 /31 BIT RANDOM NUMBER SEED FOR RND(0) SEEDL, 1000 SEED1, 140 /SUBROUTINE CR,LF CRLFR, 0 TAD [15 JMS I [PUTCH TAD (12 JMS I [PUTCH /PRINT A CR,AND LF / DCA I IOTPOS /ZERO NUMBER OF CHARS PRINTED SO FAR JMP I CRLFR /SUBROUTINE FOTYPE /RETURNS TO CALL+1 IF FILE FIXED LENGTH,CALL+2 IF VARIABLE FOTYPE, 0 TAD I IOTHDR /GET HEADER AND (4 /ISOLATE TYPE BIT SZA CLA /IS IT FIXED LENGTH? ISZ FOTYPE /NO-BUMP RETURN JMP I FOTYPE /RETURN /ABS(X) FUNCTION XABSVL, JMS ABSVAL /NEGATE FAC IF NEGATIVE JMP I [ILOOP /--RETURN-- /SUBROUTINE TO TAKE ABS VALUE OF FAC ABSVAL, 0 TAD ACH SPA CLA /IS FAC<0? JMS I [FFNEG /YES-NEGATE IT JMP I ABSVAL /RETURN /PNT(X) /SEND 8BIT CHAR TO THE CURRENT FILE PNT, JMS I [UNSFIX /FIX X AND [377 /MASK TO 8 BITS JMS I [PUTCH /PUT IN FILE BUFFER JMP I [ILOOP /DONE /ROUTINE TO ZERO THE CURRENT I/O BUFFER BLZERO, 0 STA TAD I IOTBUF DCA XR1 /POINT INTO THE BUFFER TAD [7400 DCA XR2 /SET COUNT TO 400 WORDS TAD (32 /INSERT A ^Z IN THE BUFFER FIRST CDF 10 DCA I XR1 ISZ XR2 JMP .-2 /LOOP FOR THE REST CDF JMP I BLZERO /--RETURN-- PAGE /STRING STORE SSTORE, TAD SACLEN SNA JMP I (SSTEX /EXIT IF NULL STRING IN SAC DCA AC0 /SET COUNT TAD SACLEN /SEE IF WILL FIT CIA TAD STRMAX SMA SZA CLA /SKP IF LEN.LE.MAX LEN SL, JMS I [ERROR /ERROR IF TARGET STRING TOO SMALL SSTLP, CDF 10 TAD I SACXR /PICK UP SAC BYTE CDF JMS I (DPB /STORE IT ISZ AC0 JMP SSTLP JMP I (SSTEX /--RETURN-- /STRING READ FROM FILE TO MEMORY SREADL, TAD CHAR /DEPOSIT THE CHAR JMS I (DPB SREAD, JMS I (GETCH /GET CHAR FROM FILE TAD CHAR TAD (-15 /IS IS CR? SNA JMP I (SSTEX /YES, EXIT CLL /TEST IF FF, VT OR LF TAD (3 SZL CLA /SKP IF NO JMP SREAD /YES, IGNORE IT TAD I (BYTCNT /SEE IF THIS CHAR WILL FIT TAD STRMAX SPA CLA JMP SREADL ST, JMS I [ERROR JMP I (SSTEX /SET STRING SIZE AND EXIT /STRING WRITE FROM SAC TO DEVICE SWRITE, DCA COMMAS TAD SACLEN /SEE IF NULL STRING SNA JMP I [ILOOP /RETURN IF SO CIA TAD I IOTPOS /ADD TO NUMBER OF CHARS PRINTED SO FAR TAD LWIDTH SMA SZA CLA /SKP IF LE WIDTH OF LINE JMS I [CRLFR /ELSE RESET CARRAIGE TAD SACLEN DCA STRCNT /SET LOOP COUNTER TAD [SAC-1 DCA SACXR /POINT AT SAC SWRLP, CDF 10 TAD I SACXR CDF JMS I [PUTCH ISZ STRCNT JMP SWRLP /ITERATE IF MORE JMP I [ILOOP /--RETURN-- /COMMA FUNCTION (KNOWN ONLY TO COMPILER FOR FORMATTING PRINT /STATEMENTS) COMMA, JMS I [FTYPE /SKP IF FILE IS ASCII JMP I [ILOOP /NO-COMMA FUNCTION IS A NOP TAD COMMAS /GET COMMA SWITCH SNA CLA /WAS LAST THING PRINTED A COMMA? JMP .+3 /NO-WE ARE OK TAD [40 /YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION JMS I [PUTCH IAC DCA COMMAS /SET COMMA SWITCH JMP COMGO /JMP INTO TAB LOOP COMLUP, TAD TEMP2 /SEE IF PAST THIS TAB STOP CIA TAD I IOTPOS SPA JMP SLOVER /IF NUMBER OF CHARS SO FAR LT TAB STOP, TAB OUT SNA CLA JMP I [ILOOP /RETURN IF EXACTLY ON A COLUMN TAD TEMP2 COMGO, TAD (COLWID /MOVE UP TO NEXT COLUMN DCA TEMP2 TAD TEMP2 /SEE IF END OF THIS COL FITS ON OUR LINE TAD LWIDTH SPA SNA CLA /SKP IF NO, GIVE CRLF JMP COMLUP /TRY NEXT STOP /CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING /PRINT STATEMENTS) CRFUNC, STA TAD I IOTHDR CLL RTR SMA SNL CLA /SKP CRLF IF EOF SET OR NON ASCII FILE JMS I [CRLFR /DO AS WE ARE TOLD JMP I [ILOOP /NEXT INST /TAB FUNCTION TAB, JMS I [UNSFIX /FIX X TO INTEGER STL /REDUCE MODULO LINE WIDTH TAD LWIDTH SNL JMP .-3 CIA TAD LWIDTH /COL 0 IS LEFT MARGIN TAD I IOTPOS /COMPARE DESIRED COLUMN TO REAL COLUMN SMA /IS X>=CURRENT COLUMN? JMP I [ILOOP /YES-THEN DO NOTHING /FALL INTO SPACE OUT ROUTINE SLOVER, DCA COLCNT /-# OF COLUMNS TO NEXT MARKER JMS I [FTYPE /IS FILE NUMERIC? JMP I [ILOOP /YES-THIS IS A NOP TAD [40 /GET SPACE JMS I [PUTCH /PRINT IT ISZ COLCNT /THERE YET? JMP .-3 /NO-TYPE ANOTHER SPACE JMP I [ILOOP /YES-DONE COMMAS, 1 /SET TO 1 IF LAST PRINT WAS A COMMA MOVE COLCNT, 0 /LIST OF AVAILABLE I/O BUFFERS BSTACK, BUFAREA+3000 /ORDERED HIGH TO LOW ON ENTRY TO BRTS BUFAREA+2400 BUFAREA+2000 BUFAREA+1400 BUFAREA+1000 BUFAREA+0400 BUFAREA 0 /TERMINATED BY ZERO WORD /36 BIT SKIP IF FAC NONZERO SNFAC, 0 TAD ACH /TEST ALL 36 BITS FOR ZERO SNA TAD ACL SNA TAD AC1 SZA CLA /SKP RETURN BUMP IF ALL ZERO ISZ SNFAC JMP I SNFAC /--RETURN-- PAGE /INCREMENT AND LOAD 7 BIT BYTE FROM MEMORY /ENTRY DF MAY BE RANDOM LDB, 0 JMP I GIVB /COROUTINE RETURN GIVB, 0 CDF /RESET DF NOW AND IOMASK /MASK TO 7 OR 8 BIT JMP I LDB /--RETURN-- LDBL, JMS BUMP /BUMP POINTER AND SET DF TAD I BYTPTR /GET A WORD AND [7400 /MASK PART OF THIRD CHAR DCA BYT1 /SAVE TAD I BYTPTR /NOW GET WORD AGAIN JMS GIVB /CALL CALLER BACK JMS BUMP /BUMP POINTER AGAIN TAD I BYTPTR /GET CHAR AND [7400 /SAVE HIGH 4 BITS DCA BYT2 TAD I BYTPTR /GET WORD AGAIN JMS GIVB /RETURN TO CALLER TAD BYT2 /NOW COMBINE LOW AND HIGH NIBBLES CLL RTR RTR TAD BYT1 CLL RTR RTR JMS GIVB /GIVE TO CALLER JMP LDBL /LOOP FOR NEXT PAIR OF WORDS /INCREMENT AND DEPOSIT A 7BIT BYTE IN MEMORY /ENTRY DF MAY BE RANDOM DPB, 0 AND IOMASK /MASK TO 7 OR 8 BIT DCA BYTE /SAVE JMP I TAKB /RETURN TO COROUTINE TAKB, 0 DCA I BYTPTR /STORE WORD BACK NOW CDF /RESET DF ISZ BYTCNT /TALLY NUMBER OF BYTES STORED JMP I DPB /--RETURN-- DPBL, JMS BUMP /FIRST BUMP POINTER AND SET DF TAD BYTCDF /BACK UP CDF TO FIRST WORD DCA BYTCD1 TAD BYTPTR /SAVE POINTER TO FIRST WORD DCA BYT1 TAD BYTE /NOW GET THE BYTE JMS TAKB /STORE IT AND TAKE ANOTHER JMS BUMP /BUMP POINTER TAD BYTCDF /SAVE CDF TO WORD2 INLINE DCA BYTCD2 TAD BYTE /NOW GET BYTE JMS TAKB /STORE AND TAKE ANOTHER TAD BYTE /GET BYTE CLL RTL RTL AND [7400 BYTCD1, 0 TAD I BYT1 DCA I BYT1 /RESTORE WORD1 TAD BYTE /NOW ISOLATE LOW 4 BITS CLL RTR RTR RAR AND [7400 BYTCD2, 0 TAD I BYTPTR /ADD TO WORD2 JMS TAKB /STORE SECOND WORD AND RETURN TO CALLER JMP DPBL /REITERATE /BUMP BYTE POINTER BUMP, 0 ISZ BYTPTR /FIRST INCREMENT WORD POINTER JMP BYTCDF /JMP IF FIELD BOUNDRY NOT CROSSED TAD BYTCDF /ELSE PROPAGATE CARRY INTO CDF TAD [10 DCA BYTCDF BYTCDF, 0 JMP I BUMP /BYTE LOAD/STORE INITIALIZE ROUTINE BYTSET, 0 TAD SSTEX /GET FIELD OF STRING DCA BYTCDF /STORE INLINE TAD STRPTR /NOW GET ADDR OF COUNT WORD DCA BYTPTR /STORE TAD (LDBL /INITIALIZE COROUTINES NWO DCA GIVB TAD (DPBL DCA TAKB DCA BYTCNT /CLEAR DEPOSITED BYTE COUNT TAD [SAC-1 DCA SACXR /ALWAYS RETURN WITH SAC POINTER SET UP JMP I BYTSET /--RETURN-- /STRING STORE EXIT ROUTINE SSTEX, 0 /GETS SET BY STFIND TO DF OF STRING TAD BYTCNT /ENTER WITH POSITIVE LENGTH IN COUNT CIA DCA I STRPTR /STORE IN STRING JMP I [ILOOP /--RETURN-- (ILOOP RESETS DF) BYTCNT, 0 BYTPTR, 0 BYTE, 0 BYT1= BYTSET BYT2= BYTCD2 /WRITE AC INTO FILE BUFFER AND BUMP POINTER WRITFL, 0 DCA OPH /SAVE WORD JMS I [IDLE /FIRST TEST IF FILE OPEN TAD I IOTPTR /IF OK, GET BUFFER POINTER DCA OPL /SAVE CDF 10 /GET INTO BUFFER SPACE TAD OPH /NOW STORE THE WORD DCA I OPL CDF /RESET DF ISZ I IOTPTR /BUMP BUFFER POINTER NOP /MAY SKIP IF LAST BUFFER TAD I IOTHDR /NOW SET BUFFER DIRTY BIT AND (7777-40 TAD [40 DCA I IOTHDR AC0002 /AFTER THE FACT, TEST IF EOF BIT SET AND I IOTHDR SNA CLA JMP I WRITFL /OK, RETURN WE, JMS I [ERROR /ELSE GIVE WARNING JMP I [ILOOP /ABORT TO ILOOP PAGE /ROUTINE TO SEND AN ASCII STREAM TO A FILE /ENTER WITH CHAR IN AC /PRESERVES UNUSED BITS IN 3/2 PACKED WORDS PUTCH, 0 DCA AC0 /SAVE THE CHAR JMS I [FTYPE /SKP IF FILE IS ASCII TYPE SW, JMS I [ERROR /TAKE ERROR IF NOT ISZ I IOTPOS /BUMP COL NUMBER TAD AC0 /RESET COLUMN NUMBER IF CHAR LT 40 TAD [-40 SPA CLA /SKP IF NON SPECIAL CODE DCA I IOTPOS /ELSE RESET IT (FOR ESCAPE SEQUENCES) TAD ENTNO /TEST IF FILE IS TTY SNA CLA JMP PUTTTY /HANDLE SEPARATELY IF YES JMS TH4TWO /SKP IF 3/2 PACKING BIT SET JMP PUT3RD /ELSE HANDLE ODD CHAR JMS BUFGET /GET CURRENT CONTENTS OF NEXT WORD AND [7400 /PRESERVE HIGH 4 BITS FOR RANDOM ACCESS I/O TAD AC0 /ADD THE NEW CHAR JMS I (WRITFL /WRITE BACK AND BUMP POINTER JMP I PUTCH /--RETURN-- PUT3RD, TAD AC0 /STORE HIGH 4 BITS OF ODD CHAR CLL RTL RTL JMS P4BITS /MASK AND STORE THEM TAD AC0 /SHIFT LOW 4 BITS INTO PLACE CLL RTR RTR RAR JMS P4BITS /STORE THEM JMP I PUTCH /--RETURN-- PUTTTY, TAD AC0 /GET THE CHAR JMS I [PCH /PRINT ON THE CONSOLE JMP I PUTCH /--RETURN-- /COMBINE AND STORE 4 BITS OF ODD CHAR P4BITS, 0 AND [7400 /ISOLATE THE BITS DCA TEMP2 JMS BUFGET /GET CONTENTS OF BUFFER WORD AND [377 /PRESERVE LOW 8 BITS TAD TEMP2 /ADD HIGH BITS JMS I (WRITFL /WRITE IN FILE AND BUMP POINTER JMP I P4BITS /ROUTINE TO GET AN ASCII STREAM FROM A FILE /RETURN WITH THE CHAR STORED IN "CHAR" GETCH, 0 JMS I [FTYPE /SKP IF FILE IS ASCII SR, JMS I [ERROR /TAKE ERROR EXIT IF NUMERIC IMAGE FILE GETLP, TAD ENTNO /TEST IF CONSOLE TTY SNA CLA JMP GETTTY /HANDLE SPECIALLY IF YES JMS TH4TWO /HANDLE ODD CHAR FLAG, SKP IF NOT SET JMP GET3RD /DO THE 3RD CHAR JMS READFL /READ A WORD JMP GETRTN /DO COMMON CODE GET3RD, JMS READFL /HANDLE ODD CHAR, GET HIGH 4 BITS AND [7400 DCA AC0 JMS READFL /GET LOW 4 BITS AND [7400 CLL RTR /SHIFT AND COMBINE RTR TAD AC0 RTR RTR GETRTN, AND IOMASK /MASK TO 7 OR 8 BITS DCA CHAR /STORE TAD CHAR /REGET CHAR / AND [177 /FORCE 7 BITS FOR ^Z TEST SNA JMP GETLP /IGNORE NULLS TAD (-32 /SEE IF ^Z GOTTEN SZA CLA /SKP INTO EOF ROUTINE IF YES JMP I GETCH /ELSE RETURN /ROUTINE TO SET EOF BIT IN I/O ENTRY EOFSET, TAD I IOTHDR /HEADER CLL RTR /EOF BIT TO LINK STL RTL /SET LINK /PUT LINK IN EOF BIT DCA I IOTHDR /STORE IN I/O TABLE ENTRY JMP I [ILOOP /EOF BIT SET-ABORT TO ILOOP GETTTY, CIF CDF 10 /CALL THE CONSOLE ROUTINE JMS I (TTYGCH JMP GETRTN /RETURN THE CHAR /COMMON ROUTINE TO HANDLE 3/2 PACKING BIT /GETS NEXT RECORD IF PAST END OF BUFFER /ADJUSTS POINTERS AS NECESSARY TH4TWO, 0 TAD I IOTHDR /TEST THE FLAG AND [200 SZA JMP DO3RD /JMP IF ODD CHAR IAC JMS I (BUFCHK /SEE IF NEED NEW BUFFERFULL IAC /SEE IF ODD CHAR WILL BE NEXT AND I IOTPTR SZA CLA /SKP IF NOT TAD [200 /TELL OURSELVES BY SETTING FLAG TAD I IOTHDR DCA I IOTHDR ISZ TH4TWO /RETURN TO CALL+2 JMP I TH4TWO DO3RD, CMA AND I IOTHDR DCA I IOTHDR /CLEAR THE BIT AC7776 /BACK UP THE POINTER FOR 3RD CHAR TAD I IOTPTR DCA I IOTPTR JMP I TH4TWO /RETURN TO CALL+1 /ROUTINE TO READ 1 WORD FROM A FILE AND BUMP POINTER READFL, 0 TAD I IOTRSZ /ALLOW READS OF OUTPUT FILE IF RANDOM ACCESS SNA CLA JMS I (FOTYPE /SKP IF OUTPUT ONLY FILE SKP VR, JMS I [ERROR /TAKE ERROR EXIT IF YES AC0002 /SEE IF END OF FILE BIT SET AND I IOTHDR SNA CLA JMP .+3 RE, JMS I [ERROR /GIVE WARNING IF YES JMP I [ILOOP /ABORT TO ILOOP JMS I [IDLE /TEST IF FILE OPEN OR NOT JMS BUFGET /OK, GET THE WORD ISZ I IOTPTR /BUMP POINTER JMP I READFL /MAY SKIP IF LAST BUFFER JMP I READFL /--RETURN-- /GET WORD FROM I/O BUFFER IN FIELD 1 BUFGET, 0 TAD I IOTPTR /GET POINTER DCA BFPTR CDF 10 /GET INTO BUFFER SPACE TAD I BFPTR /GET WORD CDF JMP I BUFGET /RETURN BFPTR, 0 PAGE /READ FLOATING POINT NUMBERS TO FAC FROM FILE OR DATA LIST READI, JMS I [FTYPE /SKP IF ASCII FILE JMP RIMAGE /HANDLE IMAGE FILE JMS I (FFIN /CALL FLOATING POINT INPUT ROUTINE JMP I [ILOOP /DONE RIMAGE, JMS BUFCHK /SEE IF BUFFER EMPTY TAD (READFL-DLREAD /SET FOR FILE READ RDLIST, TAD (DLREAD /SET FOR DATA LIST READ DCA ACL /STORE ROUTINE POINTER JMS I ACL /GET WORD DCA ACX /STORE 3 WORDS JMS I ACL DCA ACH JMS I ACL DCA ACL JMP I [ILOOP /DONE /WRITE FLOATING POINT NUMBER TO FILE FROM FAC WRITEI, JMS I [FTYPE /SKP IF FILE IS ASCII JMP WIMAGE /ELSE DO IMAGE WRITE JMS I (FFOUT /CONVERT INTERNAL TO ASCII TAD XR1 CIA TAD (INTERB-1 /CALCULATE NUMBER OF CHARS STORED IN BUFFER DCA TEMP1 /SAVE TAD (INTERB-1 DCA SACXR /NOW POINT SACXR INTO BUFFER TAD TEMP1 /GET COUNT OF CHARS TO BE PRINTED CIA TAD I IOTPOS /ADD TO PRINT HEAD POSITION TAD LWIDTH /COMPARE AGAINST LINE SIZE SMA SZA CLA /WILL THE NUMBER FIT ON THIS LINE? JMS I [CRLFR /NO-ISSUE A CR,LF CPLOOP, TAD I SACXR /GET CHAR FROM INTERMEDIATE BUFFER JMS I [PUTCH /PUT ON DEVICE ISZ TEMP1 /BUMP COUNTER JMP CPLOOP /NEXT TAD [40 JMS I [PUTCH /SEND OUT A SPACE AFTER NUMBER JMP WDONE /TAKE COMMON EXIT WIMAGE, JMS BUFCHK TAD ACX /EXPONENT JMS I (WRITFL /WRITE IN BUFFER TAD ACH /HIGH MANTISSA JMS I (WRITFL /WRITE IN BUFFER TAD ACL /LOW MANTISSA JMS I (WRITFL /WRITE IN BUFFER WDONE, DCA I (COMMAS /CLEAR COMMA SWITCH JMP I [ILOOP /WRITE IS DONE /END OF BUFFER TEST /AC = 1 IF ASCII FILE, 0 IF IMAGE FILE BUFCHK, 0 TAD I IOTBUF TAD [377 /SEE IF AT LAST WORD OF BUF CIA TAD I IOTPTR SNA CLA JMS NEXREC /GET NEXT RECORD IF YES JMP I BUFCHK /ROUTINE TO GET NEXT RECORD /IF FILE STRUCTURED DEVICE, WRITES CURRENT BLOCK (IF DIRTY) /AND READS NEXT BLOCK IF NOT NEW FILE ENTRY. IF EOF ENCOUNTERED, SETS EOF INSTEAD /MAY EXTEND FILE SIZE BY ONE BLOCK IF VARIABLE LENGTH OUTPUT FILE /IF NON FILE STRUCTURED INPUT FILE, JUST READS ANOTHER BUFFERFULL /IF NON FILE STRUCTURED OUTPUT FILE, WRITES BUFFER (IF DIRTY) NEXREC, 0 TAD I IOTHDR /GET HEADER AND (20 /GET READ/WRITE ONLY BIT SNA CLA /IS IT ON? JMP FILSTR /NO-DEVICE IS FILE STRUCTURED JMS I (FOTYPE /SKP IF VARIABLE LENGTH OUTPUT FILE JMP RONLY JMS WRBLK /WRITE BLOCK (UNLESS FILE JUST OPENED OR RESTORED) SKP RONLY, JMS BLREAD /READ NEXT BUFFER, OR DO BLOCK 0 INITIALIZATION ISZ I IOTBLK JMS BLINIT /INIT FILE TABLE ENTRIES JMP I NEXREC /DONE FILSTR, JMS WRBLK /WRITE THE CURRENT BLOCK IF IT HAS BEEN CHANGED JMS BLINIT /INIT FILE TABLE ENTRIES ISZ I IOTBLK /BUMP BLOCK # TAD I IOTLOC /STARTING BLOCK CIA /NEGATE TAD I IOTBLK /SUBTRACT FROM CURRENT BLOCK FOR FILE LENGTH CLL CMA /SET UP CURRENT FILE LENGTH FOR 12 BIT COMPARE TAD I IOTLEN /COMPARE TO ACTUAL LENGTH SNL CLA /IS IT > CURRENT LENGTH? JMP LASTB /YES-EXTEND THE FILE IF IT IS OUTPUT JMS BLREAD /READ IN THE NEXT RECORD JMP I NEXREC /RETURN LASTB, JMS I (FOTYPE /IS FILE FIXED LENGTH? JMP I [EOFSET /YES-SET EOF FLAG TAD I IOTLEN /NO-GET ACTUAL LENGTH CLL CMA TAD I IOTMAX /MAXIMUM LENGTH SNL CLA /IS ACTUAL LENGTH >= MAXIMUM LENGTH? JMP I [EOFSET /YES-SET EOF BITS ISZ I IOTLEN /NO-BUMP ACTUAL LENGTH JMP I NEXREC /RETURN WITHOUT READING NEXT RECORD /ROUTINE TO READ 2 PAGES FROM DEVICE BLREAD, 0 JMS I (BLZERO TAD (210 /"READ 2 PAGES" JMS I (DRCALL /HANDLER CALL JMP I BLREAD /ROUTINE TO WRITE 2 PAGES ONTO DEVICE WRBLK, 0 TAD I IOTHDR /GET FILE HEADER AND [40 /GET FILE WRITTEN BIT SNA CLA /HAS THIS BLOCK BEEN CHANGED? JMP I WRBLK /NO-RETURN TAD (4210 /"WRITE 2 PAGES" JMS I (DRCALL /CALL TO DEVICE HANDLER JMS I (BLZERO JMP I WRBLK /ROUTINE TO INITIALIZE I/O TABLE ENTRIES AFTER READ OR WRITE BLINIT, 0 TAD I IOTBUF DCA I IOTPTR /INIT READ/WRITE POINTER TAD I IOTHDR AND (7537 /CLEAR DIRTY BIT AND CHAR #3 FLAG DCA I IOTHDR JMP I BLINIT PAGE ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// //////////// OVERLAY BUFFER 3400-4777 //////////////////// //////////// CONTAINS FUNCTION OVERLAYS //////////////////// //////////// AT RUN TIME //////////////////// ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// ////////////// OVERLAY 1-ARITHMETIC FUNCTIONS /////////////// ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// *OVERLAY VERSON^100+SUBVAF+6000 /VERSION AND PATCH LEVEL FOR ARITH FNS OVDISP, JMS I [FBITGT /GET FUNCTION TO USE TAD JMSAF /BUILD IN LINE JMS DCA .+1 /STORE IT HLT JMP I [ILOOP /RETURN TO ILOOP JMSAF, JMS I .+1 /CALL FOR CANNED FUNCTION SET 1 /JUMP TABLE FOR FUNCTION CALL 1 ATAN /FUNCTION BITS= 000 COS / 020 EXPON1 / 040 EXPON / 060 INT / 100 LOG / 120 SGN / 140 SIN / 160 RND / 200 FROOT / 220 TAN / 240 /INTEGER FUNCTION /RANGE=ALL X INT, 0 JMS I [FFPUT /SAVE X FPPTM1 TAD ACX /GET EXPONENT SMA SZA CLA /IS EXP<0? JMP INSC /NO-GO ON TAD ACH /YES SPA CLA /IS X<0? JMP M1R /YES-INT=-1 JMS I [FACCLR /YES-RETURN A 0 JMP I INT INSC, TAD ACH /GET HI MANTISSA SMA CLA /IS IT <0? JMP INTPOS /NO-USE FAC AS IS JMS I [FFNEG /YES-NEGATE FAC (MAKE IT POS) IAC /AND SET FLAG INTPOS, DCA AC2 /FLAG FOR NEGATIVE DCA OPX /ZERO LORD MASK CLL CML RAR DCA TM /INITIALIZE HORD MASK TO 4000 TAD ACX CIA /- COUNT DCA TEMP2 MASKL, TAD TM CLL CML RAR /ROTATE 1'S THROUGH 3 WORD MASK DCA TM / TAD OPX /UNTIL THERE IS A COUNT OF ZERO RAR DCA OPX ISZ TEMP2 /DONE? JMP MASKL /NO TAD ACH /YES-MASK HORD AND TM DCA ACH TAD ACL /MASK LORD AND OPX DCA ACL TAD AC2 /NEG FLAG SNA CLA /WAS ORIGINAL NUMER <0? JMP I INT /NO-DONE JMS I [FFPUT /SAVE INT(X) FPPTM2 JMS I (FFADD /-INT(X)+(X) FPPTM1 TAD ACH /SAVE HORD DCA AC2 JMS I [FACCLR /FLUSH FAC TAD AC2 /WAS INT(X)=X? SNA CLA JMP JUSNEG /YES-JUST NEGATE INT(X) JMS I (FFADD /NO-ADD 1 ONE JUSNEG, JMS I (FFADD /GET INT(X) FPPTM2 JNEG, JMS I [FFNEG /AND NEGATE (INT(5.3)=-6) JMP I INT /DONE M1R, JMS I [FFGET /LOAD FAC WITH 1 ONE JMP JNEG /JUST NEGATE AND RETURN ONE, 1 2000 0 /RND(0) RANDOM NUMBER GENERATOR /USES MULTIPLIER OF 2**16+3 MOD 2**31 /RETURNS HIGH 23 BITS AS FRACTION 00,A^B=0 /IF A=0 AND B<0,DIVIDE BY ZERO ERROR MESSAGE RESULTS AND A^B=0 /IF B=INTEGER > 0, A^B=A*A*A*.......*A /IF B=INTEGER < 0, A^B=1/A*A*A*.......*A /IF B=REAL AND A>0, A^B=EXP(B*LOG(A)) /IF B=REAL AND A<0, A FATAL ERROR RESULTS EXPON, 0 JMS I [FFPUT /SAVE A FPPTM5 TAD ACH /HI ORDER OF A DCA EXPON /SAVE IT DCA INSAV /POINTER TO B IN SYMBOL TABLE JMS I ARGPLL /FIND B JMS I [FFGET /GET B ARGPLL, ARGPRE /LOC SKIPPED BY FPP,SO WE USE IT FOR CONSTANT CDF TAD ACH /HI ORDER OF B SNA /IS B=0? JMP RETRN1 /YES A^B=1 SMA CLA /IS B<0? JMP .+4 /NO TAD EXPON /YES-GET HI ORDER A SNA CLA /IS A=0? JMP I (DV /YES-DIVIDE BY ZERO ERROR TAD EXPON /B>0. IS A=0? SNA CLA JMP RET0 /YES A^B=0 JMS I [FFPUT /SAVE B FPPTM3 JMS I (INT /GET INT(B) TAD ACX /TEST IF B GE 2**23 TAD (-30 SMA CLA JMP USELOG /JMP IF RIDICULOUS EXPONENT JMS I (FFSUB /INT(B)-B FPPTM3 TAD ACH /SEE IF B INTEGER SZA CLA JMP USELOG /NO, USE EXP(B*LOG(A)) INSTEAD JMS I [FFGET /GET B BACK FPPTM3 TAD ACH /SAVE SIGN OF B DCA EXPON JMS I (ABSVAL /TAKE ABS(B) JMS I (FIX23 /FIX TO UNSIGNED INTEGER IN ACH;ACL TAD ACH /COPY TO SHIFT REGISTER DCA EXPH TAD ACL DCA EXPL JMS I [FFGET /INITIALIZE RUNNING PRODUCT TO ONE ONE JMS I [FFPUT FPPTM4 JMP EXPGO /JMP INTO LOOP EXPLUP, JMS I [FFPUT /SAVE RUNNING PRODUCT FPPTM4 JMS I [FFGET /GET RUNNING POWER OF A FPPTM5 JMS I (FFMPY /SQUARE IT FPPTM5 JMS I [FFPUT /STORE BACK FPPTM5 /A**2**K JMS I [FFGET /GET PRODUCT AGAIN FPPTM4 EXPGO, TAD EXPH /SHIFT EXPONENT RIGHT CLL RAR DCA EXPH TAD EXPL RAR DCA EXPL SNL /SKP IF THIS POWER OF A GOES IN JMP NOMULT /ELSE JMP BY JMS I (FFMPY FPPTM5 /MULTIPLY A**2**K IN NOMULT, TAD EXPH /SEE IF EXPONENT REDUCED TO ZERO YET SNA TAD EXPL SZA CLA JMP EXPLUP /REITERATE IF YES EMDONE, TAD EXPON /GET SIGN OF B SMA CLA /WAS IT -? JMP I [ILOOP /NO-A^B=A*A*A*...*A JMS I (FFDIV1 /YES-INVERT ONE JMP I [ILOOP /A^B=1/A:A*A*...*A RET0, JMS I [FACCLR JMP I [ILOOP RETRN1, JMS I [FFGET ONE /SET FAC TO 1 JMP I [ILOOP USELOG, TAD EXPON /SIGN OF A SPA CLA /A<0? EM, JMS I [ERROR /YES-PRINT A MESSAGE JMS I [FFGET /LOAD A FPPTM5 JMS I (LOG /LOG(A) JMS I (FFMPY /B*LOG(A) FPPTM3 JMS I (EXPON1 /EXP(B*LOG(A)) JMP I [ILOOP /DONE EXPH, 0 EXPL, 0 /SGN FUNCTION SGN, 0 TAD ACH /GET HIGH MANTISSA SNA /IS X=ZERO? JMP I [ILOOP /YES-THEN LEAVE IT ALONE SPA CLA /IS X>0? JMP .+3 /NO IAC /YES-SET FAC=1 SKP CMA /NO-SET FAC=-1 DCA ACX /SET UP FLOAT JMS I [FFLOAT /FLOAT VALUE OF SGN FUNCTION JMP I [ILOOP /DONE PAGE IFZERO EAE < /FLOATING SQUARE ROOT /USES A HARDWARE TYPE ALGORITHM FOR BINARY SQUARE ROOTS /REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES-P 409 / FROOT, 0 TAD ACH SNA JMP I [ILOOP /ZERO FAC-NORMALIZED!-RETN. SAME SMA CLA /SKP IF NEGATIVE JMP .+3 JMS I [FFNEG /TAKE ROOT OF ABSOLUTE VALUE IS, JMS I [ERROR /PRINT IMAGINARY SQUARE ROOT WARNING CLA CLL CML RTR /SET RESULT TO 2000;0000 DCA AN1 DCA AN2 CDF /DF TO PACKAGE FIELD TAD KM22 /SET COUNTER FOR DEVELOPING 22 BITS OF RESULT DCA AC2 /ALREADY HAVE 1 TAD ACX /GET EXPONENT OF FAC SPA /IF NEGATIVE-MUST PROPAGATE SIGN CML RAR /DIVIDE EXP. BY 2 DCA ACX /STORE IT BACK SZL /INCREMENT EXP. IF ORIGINAL EXP ISZ ACX /WAS ODD NOP SNL /DO A PRE-SHIFT FOR EVEN EXPONENTS JMS I AL1K /SO FIRST BIT PAIR IS 10 NOT 01 CLA CLL CMA RAL /SET COUNTER FOR DETECTING A DCA ZCNT /ZERO REMAINDER CLA CLL CML RTR /SET UP POSITION OF TRIAL BIT RTR /FOR FIRST PASS THRU LOOP DCA OPH DCA OPL TAD K6000 /GET A FAST FIRST BIT-WE KNOW TAD ACH /THIS WILL WORK SINCE # IS NORMALIZED DCA ACH /IF # IS A POWER OF TWO, AND A PERFECT TAD ACH /SQUARE-WE ARE DONE HERE! SNA /WELL IS IT? TAD ACL /COULD BE-CHECK LOW ORDER SNA CLA JMP DONE /WHOOPPEE-WE WIN BIG. JMP LOP01 /NOPE-LOOP DON'T SHIFT FIRST TIME SLOOP, TAD OPH /SHIFT TRIAL BIT 1 PLACE CLL RAR /TO THE RIGHT DCA OPH /AND STORE BACK TAD OPL RAR DCA OPL JMS I AL1K /SHIFT FAC LEFT 1 PLACE LOP01, TAD OPL /ADD TRIAL BIT TO`ANSWER TAD AN2 /SO FAR CLL CMA IAC /NEGATE IT TAD ACL /AND ADD TO FAC (REMAINDER SO FAR) SNA /IS RESULT ZERO? ISZ ZCNT /YES-INCREMENT COUNTER DCA TM /STORE RESULT IN TEMPORARY CML RAL /ADD CARRY TO HIGH ORDER FOR SUBTRACT TAD OPH /ADD TRIAL BIT TAD AN1 /ADD RESULT SO FAR (HI ORDER) CLL CMA IAC /AND SUBTRACT FROM HI ORDER FAC TAD ACH SNL /RESULT NEGATIVE? JMP GON /YES-NEXT RESULT BIT IS 0 SZA /NO-IS HI ORDER RESULT=0? JMP LOP02 /NO-GO ON ISZ ZCNT /YES-WAS LOW ORDER =0? JMP .+3 /NO-GO ON CMA /YES-REM.=0-SET COUNTER SO DCA AC2 /LOOKS LIKE WE'RE DONE LOP02, DCA ACH /STORE HIGH ORDER REM. IN FAC TAD TM /STORE LO ORDER REM. IN FAC DCA ACL TAD OPL /TRIAL BIT SHIFTED LEFT 1 IS CLL RAL /RESULT BIT-ADD IT TO ROOT DEVELOPED TAD AN2 /SO FAR DCA AN2 TAD OPH RAL TAD AN1 DCA AN1 GON, CLA CLL CMA RAL /RESET COUNTER FOR ZERO REM. DCA ZCNT ISZ AC2 /DONE ALL 23 RESULT BITS? JMP SLOOP /NO-GO ON DONE, TAD AN1 /YES-STORE ANSWER IN FAC DCA ACH /ITS NORMALIZED ALREADY TAD AN2 DCA ACL JMP I [ILOOP /AND RETURN K6000, 6000 ZCNT, 0 AL1K, AL1 AN1, 0 AN2, 0 KM22, -26 PAGE > IFNZRO EAE < / /FLOATING SQUARE ROOT /USES MODIFIED HARDWARE ALGORITHM FOR BINARY SQUARE ROOTS /REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES; P-409 FROOT, 0 TAD ACH /SAVE SIGN OF FAC DCA FROOT /FOR WARNING MESSAGE CLA CLL CML RTR /SET RESLT TO 2000,0000 DCA OPL DCA OPH SWAB /MODE B OF EAE-ALSO DOES MQL CDF DCA RBCNT /CLR. SHIFT COUNTER TAD KM22 DCA AC2 /SET COUNTER FOR 23 BITS OF RESULT TAD ACX /GET EXPONENT OF FAC ASR /DIVIDE BY 2 1 DCA ACX /STORE IT BACK DPSZ /INCREMENT EXP. IF ORIG. EXP ISZ ACX /WAS ODD NOP MQA /DETERMINE WHETHER TO DO A CLL RAL /PRE-SHIFT FOR EVEN EXPONENTS. CML RAL DCA RKNT /STORE BIT-0 OR 1 SHIFT CNT CLL CML RTR /SET UP FIRST TRIAL BIT RTR DCA AC1 DCA AC0 /STORE AWAY DCA ACNT /ZERO COUNTER DLD /GET THE FAC ACH SWP /GET IN RIGHT ORDER SNA /IS IT ZERO? (HI ORD=0) JMP I [ILOOP /YES-ROOT = 0 SPA /NEGATIVE? DCM /YES-TAKE ABSOL. VALUE SHL /SHIFT # 1 BIT IF EXP WAS EVEN RKNT, 0 /SO FIRST BIT PAIR IS 10 NOT 01 TAD K6000 /SUBTRACT 2000-KNOW FIRST BIT DPSZ /IS 1(NORMALIZED)-DONE?? JMP LOP1 /NO-WE MUST LOOP JMP DONE /YES-AN EASY ONE!!! LOOP, DLD /GET THE FAC ACH SHL /SHIFT FAC APPROPRIATELY 1 LOP1, DST /MUST STOR BACK IN CASE RESLT ACH /BIT IS 0 DLD /GET TRIAL BIT AC0 ASR /SHIFT THE BIT APPROPRIATELY ACNT, 0 ISZ ACNT /SHIFT 1 MORE NEXT TIME DAD /ADD IN RESULT SO FAR OPH DCM /NEGATE IT ISZ RBCNT /BUMP COUNTER FOR RESLT BIT DAD /DO THE SUBTRACT ACH SNL /RESULT NEGATIVE? JMP GON /YES-NEXT RESULT BIT = 0 DPSZ /NO-DID WE GET A ZERO REMAINDER? JMP NOTZRO /NOPE ZREM, CMA /YES-SET SO LOOKS LIKE WE'RE DONE DCA AC2 NOTZRO, DST /GOOD SUBTR.-MODIFY FAC ACH /ITS NOT CHANGED BY BAD SUBTRACT CAM /CLEAR EVERYTHING RTR ASR /SHIFT RESLT BIT TO RIGHT PLACE RBCNT, 0 DAD /ADD IT TO THE RESULT SO FAR OPH /WE APPEND IT TO RIGHT OF LAST DST /BIT OPH /STORE IT BACK GON, ISZ AC2 /DONE 23 BITS? JMP LOOP /NO-GO ON DONE, DLD /YES-GET RESULT-ITS NORMALIZED OPH DCA ACH /STORE HIGH ORDER BACK SWP DCA ACL /STORE LOW ORDER BACK TAD FROOT /TEST IF IMAGINARY ROOT TAKEN SPA CLA /SKP IF NO IS, JMS I [ERROR /ELSE GIVE WARNING MESSAGE JMP I [ILOOP /RETURN KM22, -26 K6000, 6000 PAGE > /23-BIT EXTENDED FUNCTIONS /1-31-72 R BEAN /******SINE****** SIN, 0 JMS NHNDLE /IF X<0,NEGATE X AND SET NFLAG JMS I (FFMPY /X*2/PI TOVPI JMS FRACT /SAVE X IN AC0,THE INTEGER PART OF X IN NUM,AND GET FRACTIONAL PART IN FAC TAD NUM /GET INTEGER PART OF (2/PI)*X AND (3 /ISOLATE BITS 10,11 TAD JMPISN DCA .+1 /MAKE JUMP TO ARGUMENT REDUCING ROUTINE JMP . /AND ADJUST ARG ACCORDING TO QUADRANT OF X JMPISN, JMP I .+1 POLYSN /X IN QUAD1,SIN(X)=SIN(X) QUAD2 /X IN QUAD2,SIN(X)=SIN(1-X) QUAD3 /X IN QUAD3,SIN(X)=SIN(-X) QUAD4 /X IN QUAD4,SIN(X)=SIN(X-1) QUAD2, JMS I (FFSUB1 /1-X ONE JMP POLYSN /CALCULATE SIN(1-X) QUAD3, JMS I [FFNEG /-X JMP POLYSN /CALCULATE SIN(-X) QUAD4, JMS I (FFSUB /X-1 ONE POLYSN, JMS I [FFPUT /SAVE X FPPTM1 JMS I (FFSQ /U=X**2 JMS I [FFPUT /SAVE U FPPTM2 JMS I (FFMPY /A7*U SINA7 JMS I (FFADD /A5+A7*U SINA5 JMS I (FFMPY /A5*U+A7*U**2 FPPTM2 JMS I (FFADD /A3+A5(U)+A7(U**2) SINA3 JMS I (FFMPY /A3(U)+A5(U**2)+A7(U**3) FPPTM2 JMS I (FFADD /A1+A3(U)+A5(U**2)+A7(U**3) SINA1 JMS I (FFMPY /A1(X)+A3(X**3)+A5(X**5)+A7(X**7) FPPTM1 JMS NCHK /IF NFLAG IS SET,SET SIN(X)=-SIN(X) JMP I SIN /FAC=SIN(X) /******COSINE****** /USES SIN ROUTINE TO CALCULATE COS(X) COS, 0 JMS I (FFADD /COS(X)=SIN(PI/2+X) PIOV2 JMS SIN JMP I COS /RETURN /ROUTINE TO SEPERATE THE INTEGER AND FRACTIONAL PARTS OF FAC /ORIGINAL FAC IS SAVED IN AC0,THE INTEGER PORTION OF FAC IS /SAVED AT NUM,AND THE FRACTIONAL FORTION OF THE FAC IS LEFT IN THE FAC FRACT, 0 JMS I [FFPUT /SAVE X FPPTM1 JMS I (FFIX /INTEGER PORTION OF X TAD ACX DCA NUM /SAVE FIXED FORTION OF X JMS I [FFLOAT /FAC=FLOAT(FIX(X)) JMS I (FFSUB1 /FAC=X-INT(X)=FRACTION (X) FPPTM1 JMP I FRACT /RETURN /ROUTINE TO CHECK IF FAC<0; IF IT IS,FAC IS NEGATED AND NFLAG IS /SET TO 1 NHNDLE, 0 TAD ACH /FETCH HIGH ORDER MANTISSA SMA CLA /IS IT <0? JMP NFLGST /NO-CLEAR NFLAG JMS I [FFNEG /YES-NEGATE FAC IAC /AND SET NFLAG NFLGST, DCA NFLAG JMP I NHNDLE /ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0 NCHK, 0 /LOC ALSO USED FOR TEMP STORAGE TAD NFLAG SZA CLA /IS NFLAG=0? JMS I [FFNEG /NO-NEGATE FAC JMP I NCHK /YES-RETURN NUM=NCHK /******EXPONENTIAL****** EXPON1, 0 /LOC USED FOR TEMP STORAGE BY SIN,ARCTAN JMS I (FFMPY /Y=XLOG2(E) LOG2E JMS FRACT /GET FRACTIONAL PART OF Y JMS I (FFMPY /(FRACTION(Y))*(LN2/2) LN2OV2 JMS I [FFPUT /SAVE Y FPPTM1 JMS I (FFSQ /Y**2 JMS I (FFADD /B1+Y**2 EXPB1 JMS I (FFDIV1 /A1/(B1+Y**2) EXPA1 JMS I (FFADD /A0+A1/(B1+Y**2) EXPA0 JMS I (FFSUB /A0-Y+A1/(B1+Y**2) FPPTM1 JMS I [FFPUT /SAVE FPPTM2 JMS I [FFGET /GET Y FPPTM1 ISZ ACX /MULT. BY 2=2Y NOP JMS I (FFDIV /2Y/(A0-Y+A1/(B1+Y**2)) FPPTM2 JMS I (FFADD /1+2Y/(AO-Y+A1/(B1+Y**2)) ONE JMS I (FFSQ /[1+2Y/(A0-Y+A1/(B1+Y**2))]**2=EXP(Y) TAD NUM TAD ACX /EXP(X)=(2**N)(EXPY) DCA ACX JMP I EXPON1 /FAC=EXPON(X) NFLAG=EXPON1 /CONSTANT THAT WOULDN'T FIT ELSEWHERE TOVPI, 0 /.6366198 2427 6302 PAGE /******ARC TANGENT****** ATAN, 0 JMS I NHNDLL /IF X<0,SET NFLAG AND NEGATE JMS I [FFPUT /SAVE X FPPTM1 JMS I FSUBM /X-1 ONE TAD ACH /GET HI MANTISSA SPA CLA /WAS X>1? JMP ARGPOL /NO-CLEAR GT1FLG JMS I [FFGET /YES-ATAN(X)=PI/2-ATAN(1/X) ONE JMS I FDIVM /1/X FPPTM1 JMS I [FFPUT FPPTM1 IAC /SET GT1FLG ARGPOL, DCA GT1FLG JMS I [FFGET /GET X OR 1/X FPPTM1 JMS I FSQRM /Y**2 JMS I [FFPUT /SAVE FPPTM2 JMS I FADDM /Y**2+B3 ATANB3 JMS I FDIV1M /A3/(Y**2+B3) ATANA3 JMS I FADDM /B2+A3/(Y**2+B3) ATANB2 JMS I FADDM /Y**2+B2+A3/(Y**2+B3) FPPTM2 JMS I FDIV1M /A2/(Y**2+B2+A3/(Y**2+B3)) ATANA2 JMS I FADDM /B1+A2/(Y**2+B2+A3/(Y**2+B3)) ATANB1 JMS I FADDM /Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)) FPPTM2 JMS I FDIV1M /A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))) ATANA1 JMS I FADDM /B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))) ATANB0 JMS I FMPYM /ATAN(Y)=X*(B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))) FPPTM1 TAD GT1FLG /WAS X>1? SNA CLA JMP NGT /NO-TEST IF X<0? JMS I FSUB1M /ATAN(X)=PI/2-ATAN(1/X) PIOV2 NGT, JMS I NCHKL /IF NFLAG SET,NEGATE FAC JMP I ATAN /FAC=ATAN(X) NHNDLL, NHNDLE NCHKL, NCHK /******NAPERIAN LOGARITHM****** GTFLG=ATAN LOG, 0 TAD ACH SPA SNA /X<0 OR X=0? JMP I ARTRAP /YES-TAKE ILLEGAL ARGUMENT TRAP CLL RTL SNA /NO-HORD=2000? TAD ACX /YES-EXP=1? CMA IAC IAC SNA TAD ACL /YES-LORD=0? SZA CLA JMP POLYNL /NO-ARG IS LEGAL AND NOT 1 DCA ACX DCA ACL LTRPRT, DCA ACH JMP I LOG /YES-LOG(1)=0 POLYNL, TAD ACX DCA GTFLG /SAVE EXPONENT FOR LATER DCA ACX /ISOLATE MANTISSA IN FAC JMS I [FFPUT /SAVE F FPPTM1 JMS I FADDM /F+SQR(.5) SQRP5 JMS I [FFPUT /SAVE FPPTM2 JMS I [FFGET FPPTM1 JMS I FSUBM /F-SQR(.5) SQRP5 JMS I FDIVM /Z=F+SQR(.5)/F-SQR(.5) FPPTM2 JMS I [FFPUT FPPTM1 JMS I FSQRM /Z**2 JMS I [FFPUT FPPTM2 JMS I FMPYM /C5(Z**2) LOGC5 JMS I FADDM /C3+C5(Z**2) LOGC3 JMS I FMPYM /C3(Z**2)+C5(Z**4) FPPTM2 JMS I FADDM /C1+C3(Z**2)+C5(Z**4) LOGC1 JMS I FMPYM /C1(Z)+C3(Z**3)+C5(Z**5) FPPTM1 JMS I FSUBM /C1(Z)+C3(Z**3)+C5(Z**5)-1/2=LOG2(F) ONEHAF JMS I [FFPUT /SAVE LOG2(F) FPPTM2 TAD GTFLG /I DCA ACX /SET UP FLOAT JMS I [FFLOAT JMS I FADDM /I+LOG2(F) FPPTM2 JMS I FMPYM /[I+LOG2(F)]*LOGE(2)=LOGE(X) LN2 JMP I LOG /FAC=LN(X) GT1FLG=LOG FMPYM, FFMPY FADDM, FFADD FDIVM, FFDIV FDIV1M, FFDIV1 FSUBM, FFSUB FSUB1M, FFSUB1 FSQRM, FFSQ ARTRAP, LM /CONSTANTS USED BY VARIOUS FUNCTIONS SINA1, 1 /1.5707949 3110 3747 SINA3, 0 /-.64592098 5325 1167 SINA5, 7775 /.07948766 2426 2466 SINA7, 7771 /-.004362476 5610 3164 PIOV2, 1 /1.5707963 3110 3756 LOG2E, 1 /1.442695 2705 2434 LN2OV2, 7777 /.34657359 2613 4415 EXPB1, 6 /60.090191 3602 7054 EXPA1, 12 /-601.80427 5514 3104 EXPA0, 4 /12.015017 3001 7301 ATANB0, 7776 /.17465544 2626 6157 ATANA1, 2 /3.7092563 3553 1071 ATANB1, 3 /6.762139 3303 670 ATANA2, 3 /-7.10676 4344 5267 ATANB2, 2 /3.3163354 3241 7554 ATANA3, 7777 /-.26476862 5703 4040 ATANB3, 1 /1.44863154 2713 3140 SQRP5, 0 /.7071068 2650 1170 LOGC1, 2 /2.8853913 2705 2440 LOGC3, 0 /.9614706 3661 566 LOGC5, 0 /.59897865 2312 5525 ONEHAF, 0 /.5 2000 0 LN2, 0 /.6931472 2613 4415 /******FIX****** /ROUTINE TO FIX ANY FLOATING NUMBER IN FAC BETWEEN -2047 AND +2047 TO /A TWELVE BIT INTEGER AND LEAVE RESULT IN EXP (LOC 44) FFIX, 0 CLA TAD ACX /FETCH EXPONENT SZA SMA /IS NUMBER <1? JMP .+3 /NO-CONTINUE ON FTRPRT, CLA JMP FIXDNE+1 /YES-FIX IT TO ZERO TAD (-13 /SET BINARY POINT AT 11 SNA /PLACES TO RIGHT OF CURRENT POINT? JMP FIXDNE /NO-NUMBER IS ALREADY FIXED THEN. SMA /YES-IS NUMBER TOO LARGE TO FIX? JMP I (FO /YES-TAKE OVERFLOW TRAP DCA ACX /NO-SET SCALE COUNT FIXLP, CLL /0 IN LINK TAD ACH /GET HIGH MANTISSA SPA /IS IT <0? CML /YES-PUT A 1 IN LINK RAR /SCALE RIGHT DCA ACH /SAVE ISZ ACX /DONE YET? JMP FIXLP /NO FIXDNE, TAD ACH /YES-ANSWER IN AC DCA ACX /RETURN WITH ANSWER IN 44 JMP I FFIX /RETURN /******FLOAT****** /ROUTINE TO FLOAT ANY INTEGER IN EXP (LOC 44) INTO FAC FFLOAT, 0 TAD ACX DCA ACH /PUT NUMBER IN HI MANTISSA DCA ACL /CLEAR LOW MANTISSA TAD (13 /11(10) INTO EXPONENT DCA ACX JMS I [FFNOR /NORMALIZE JMP I FFLOAT /RETURN /FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF FFSQ, 0 JMS I (FFMPY /CALL MULTIPLY TO MULTIPLY ACX /FAC BY ITSELF JMP I FFSQ /DONE /TAN(X) /COMPUTED AS SIN(X)/COS(X) DUE TO LAZINESS AND LACK OF SPACE TAN, 0 JMS I [FFPUT /SAVE ANGLE FPPTM3 /IN TEMP NOT USED BY SIN(X) JMS I (COS /COMPUTE COS(X) JMS I [FFPUT /SAVE COS FPPTM4 JMS I [FFGET /GET ANGLE BACK FPPTM3 JMS I (SIN /COMPUTE SIN(X) JMS I (FFDIV /RETURN TAN(X)=SIN(X)/COS(X) FPPTM4 JMP I TAN /--RETURN-- PAGE /FLOATING POINT OUTPUT ROUTINE /CONVERT INTERNAL NUMBER TO ASCII /EXIT WITH CHAR STRING IN 'INTERB' /XR1 = POINTER TO LAST CHAR STORED FFOUT, 0 TAD (INTERB-1 DCA XR1 /SET POINTER TO ASCII BUFFER TAD ACH /SEE IF FAC NEGATIVE SMA CLA JMP OKPOS /JMP IF POSITIVE JMS I [FFNEG /TAKE ABS VALUE IF NEGATIVE TAD (177&"- /PRINT MINUS SIGN SKP OKPOS, TAD [40 /PRINT SPACE IF POSITIVE DCA I XR1 TAD ACH /SEE IF NUMBER IS ZERO SNA CLA JMP ZERXIT /SPECIAL CASE IF SO JMS I (CVTNUM /CALL ROUTINE TO UNPACK TO BASE 10 TAD (NUMBUF-1 DCA XR2 /POINT XR2 AT DIGIT BUFFER TAD (5 /TEST FORMAT TO USE TAD DECEXP CLL TAD (-4 SNL JMP SMLFMT /JMP IF .0NNNNNN TO .0000NNNNNN TAD (-7 SZL CLA JMP REGFMT /JMP IF .NNNNNN TO NNNNNN /OTHERWISE USE E FORMAT N.NNNNNE+NNN OR N.NNNNNE-NNN TAD I XR2 /GET DIGIT TO LEFT OF POINT JMS PUTD /PUT IT OUT TAD (177&". DCA I XR1 /NOW SEND OUT DECIMAL POINT TAD (-5 DCA AC2 /DO 5 MORE DIGITS TAD I XR2 /PICK UP DIGIT JMS PUTD /CONVERT TO ASCII AND STORE ISZ AC2 JMP .-3 /LOOP FOR MORE TAD (177&"E /PRINT E DCA I XR1 / CLL TAD DECEXP /TAKE ABS(DECEXP) SPA CML CIA DCA DECEXP RTL /CONVERT "+" TO "-" IF NEGATIVE TAD (177&"+ DCA I XR1 JMS IDIV /PRINT 3 DIGITS OF EXPONENT NOW -144 JMS IDIV -12 TAD DECEXP JMS PUTD JMP I FFOUT /ALL DONE --RETURN-- /HANDLE .0NNNNNN TO .0000NNNNNN SMLFMT, DCA AC0 /STORE NUMBER OF LEADING ZEROES TAD (177&". /PUT OUT DECIMAL POINT DCA I XR1 JMS PUTD /SEND A 0 ISZ AC0 JMP .-2 /LOOP FOR LEADING 0'S /GENERAL NON E FORMAT .NNNNNN TO NNNNNN REGFMT, TAD (-7 DCA AC1 /INIT COUNT OF NONZERO DIGITS TAD (NUMBUF+6 DCA AC2 /POINT AT END OF DIGIT BUFFER SHRINK, STA /DECREMENT DIGIT POINTER TAD AC2 DCA AC2 ISZ AC1 /REDUCE SIGNIFICANT DIGIT COUNT TAD DECEXP IAC TAD AC1 SMA CLA JMP PRTLP /JMP OUT IF NOT TO RIGHT OF DECIMAL POINT TAD I AC2 /ELSE LOOK AT DIGIT SNA CLA JMP SHRINK /DISCARD IT IF ZERO PRTLP, STA TAD DECEXP DCA DECEXP /SEE IF DIGIT TO BE PRINTED FOLLOWS DP AC0002 TAD DECEXP SZA CLA JMP NODP /NO TAD (177&". /YES, PRINT DP DCA I XR1 NODP, TAD I XR2 /PICK UP DECIMAL DIGIT JMS PUTD /PUT OUT ISZ AC1 JMP PRTLP /JMP IF MORE DIGITS TO PRINT JMP I FFOUT /--RETURN-- ZERXIT, JMS PUTD JMP I FFOUT /--RETURN-- /DIVIDE DECEXP BY -DIVISOR IN CALL+1 IDIV, 0 DCA AC1 /CLEAR QUOTIENT IDIVLP, TAD DECEXP TAD I IDIV SPA JMP IDVOUT /JMP OUT IF LESS THAN DIVISOR DCA DECEXP /ELSE UPDATE IT ISZ AC1 /TALLY QUOTIENT JMP IDIVLP /ITERATE IDVOUT, CLA TAD AC1 /GET QUOT AS NEXT DIGIT JMS PUTD /PUT OUT ISZ IDIV JMP I IDIV /CONVERT NUMBER IN AC TO ASCII DIGIT /MUST NOT TOUCH THE LINK PUTD, 0 TAD (177&"0 /ADD IN 0 DCA I XR1 /STORE IN BUFFER JMP I PUTD O5000, 5000 PAGE /CONVERT NUMBER IN FAC TO FORMAT N.NNNNNE NNN /DECIMAL EXPONENT RETURNED AS SIGNED NUMBER IN DECEXP /6 DIGITS STORED IN NUMBUF AS BINARY 0-9 /FIRST REDUCES MANTISSA TO FORM 0DD DDF FFF FFF... /BY SUCCESSIVE MULTIPLIES OR DIVIDES BY 10. FOLLOWED BY /RENORMALIZATIONS UNTIL INTEGER BITS /DDDD ARE LT 10. /DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10. CVTNUM, 0 DCA AC1 /CLEAR OVERFLOW WORD JMS ADJDEC /NORMALIZE NUMBER AND SET RETURN ADDR TAD ACX /RANGE CHECK BINARY EXPONENT NOW SPA SNA JMP MULGO2 /JMP IF NUMBER LT 1 TAD (-5 /SEE IF EXP GT 4 SMA JMP DIVGO /JMP IF YES, REDUCE TOWARDS ZERO INRANG, DCA AC2 /SET SHIFT COUNTER SKP JMS AR1 /SHIFT FAC RIGHT ISZ AC2 JMP .-2 /LEAVE EFFECTIVE BINARY POINT RIGHT OF ACH BIT 4 TAD ACH /ACH = 0DD DDF FFF FFF (D=DECIMAL DIGIT BITS) TAD (5400 /SEE IF DDDD GE 10 SMA CLA JMP DIVGO /DIVIDE AGAIN (NORMALIZATION WILL WORK) CLL TAD AC1 /NOW ROUND BY ADDING 0.000005 TAD (4761 DCA AC1 IAC /ADD 24761 TO LOW BITS RAL TAD ACL DCA ACL SZL ISZ ACH TAD ACH TAD (5400 /SEE IF CARRY INTO 9.XXX... SZA CLA JMP CVT10 /JMP IF NO TAD [200 /ELSE SET TO 1.00000 DCA ACH DCA ACL DCA AC1 ISZ DECEXP /AND BUMP DECIMAL EXPONENT O4, 4 /EFFECTIVE NOP /NOW CONVERT TO DECIMAL DIGITS CVT10, TAD (-6 /DO 6 DIGITS DCA AC0 TAD (NUMBUF-1 DCA XR3 JMP CVTGO /FIRST DIGIT IS ALREADY IN CVTLP, TAD ACH /ZERO OUT PREV DIGIT AND [177 DCA ACH JMS I (MPY10 /NOW MULTIPLY BY 10. CVTGO, TAD ACH /GET DIGIT FROM 0DD DDF FFF FFF RTL RTL RTL AND [17 DCA I XR3 /STORE IT ISZ AC0 JMP CVTLP /LOOP IF MORE JMP I CVTNUM /--RETURN-- /ROUTINE TO TRADE BINARY FOR DECIMAL EXPONENTS /ENTER TO NORMALIZE 36 BIT NUMBER AND SET RETURN ADDR /RE ENTER TO MULTIPLY OR DIVIDE BY 10. AND RENORMALIZE ADJDEC, 0 DCA DECEXP /STORE UPDATED DECIMAL EXPONENT NORML, TAD ACH /SEE IF FRACTION IS NORMALIZED RAL SPA SZL CLA JMP I ADJDEC /RETURN IF YES JMS I (AL1 /SHIFT AC LEFT 1 BIT STA TAD ACX /COMPENSATE BINARY EXPONENT DCA ACX JMP NORML /TRY AGAIN MULGO, TAD ACX /INCREASE BINARY EXP TOWARDS ZERO MULGO2, TAD O4 DCA ACX JMS AC2OP /COPY AC TO OP JMS AR1 /SHIFT RIGHT 4 BITS AND MULTIPLY BY 10. JMS AR1 /MAX RELATIVE ERROR LT (7*2^-34)/5 PER MULTIPLY JMS I (OADD JMS AR1 AC7776 /DECREASE DECIMAL EXPONENT JMP DECRXP /RENORMALIZE AND TRY AGAIN DIVGO, IFZERO EAE< CLA CLL TAD [-40 /SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE) DCA AC2 /MAX RELATIVE ERROR WILL BE LT 9*2^-34. PER DIVIDE DVLOOP, TAD ACH /SEE IF GE 10. TAD (5400 SMA DCA ACH /UPDATE IF YES CML STA RAL DCA AC0 /SAVE LOW ORDER BIT JMS I (AL1 /SHIFT MANTISSA NOW ISZ AC0 /STORE BIT NOW ISZ AC1 ISZ AC2 /BUMP COUNT JMP DVLOOP /ITERATE TAD ACH /NOW ZERO OUT REMAINDER AND [377 DCA ACH > IFNZRO EAE< AC7775 /ADJUST BINARY EXPONENT TAD ACX DCA ACX JMS AR1 /ALIGN FRACTION AS 001 XXX XXX ... SWAB /GET INTO B MODE DLD /LOAD HIGH 24 BITS ACH SWP DVI /DIVIDE BY 10. AS 101 000 000 ... O5000 SWP /GET HIGH ORDER QUOTIENT AS 0QQ QQQ ... DCA ACH /STORE IT TAD AC1 /GET NEXT 24 BITS SWP DVI /DO NEXT DIVIDE O5000 SWP /GET NEXT 12 BITS OF QOUTIENT DCA ACL /STORE THEM SWP DVI /NOW DO LAST DIVIDE STEP O5000 SWP /GET FINAL QOUTIENT BITS DCA AC1 /STORE THEM > DECRXP, IAC /NOW INCREASE DECIMAL EXPONENT TAD DECEXP JMP ADJDEC+1 /COPY AC FRACTION TO OP FRACTION AC2OP, 0 TAD ACH DCA OPH TAD ACL DCA OPL TAD AC1 DCA AC2 JMP I AC2OP /SHIFT FAC RIGHT 1 BIT AR1, 0 TAD ACH CLL RAR DCA ACH TAD ACL RAR DCA ACL TAD AC1 RAR DCA AC1 JMP I AR1 /DONE PAGE /FLOATING POINT INPUT ROUTINE /IGNORES LEADING SPACES, TABS, CARRAIGE CONTROL CHARS /PRODUCES ROUNDED RESULT GOOD TO 23 BITS USING 35 BIT ARITHMETIC FFIN, 0 STA DCA I [FFGET /SET A DECIMAL POINT FLAG STA DCA SIGN /INITIALIZE MINUS SIGN FLAG DCA I (MPY10 /USE ROUTINE ENTRY AS A FLAG DCA I [FFPUT /ZERO OVERFLOW DIGIT COUNT JMS I [FACCLR /ZERO OUT THE FAC DCA AC1 /CLEAR OVERFLOW WORD TOO FRACLP, DCA DIGCNT /CLEAR DIGIT COUNTER DIGLUP, JMS GCHR /GET A CHAR JMP NOTDIG /JMP IF NOT A DIGIT TAD ACH /SEE IF ROOM IN REGISTER TAD (-314 /OK IF HIGH WORD LT 2048/10 = 204 SPA CLA /SKP IF NO JMP DGFITS /ELSE HANDLE IT NORMALLY TAD I [FFGET /SEE IF DIGIT IS AFTER DP SPA CLA /SKP IF YES ISZ I [FFPUT /ELSE BUMP IGNORED SIGNIFICANT DIGIT COUNT JMP DIGLUP /TRY NEXT CHAR DGFITS, JMS I (MPY10 /MULTIPLY BY 10 (INDICATES A DIGIT GOTTEN) TAD DIGIT /NOW ADD IN THE NEW DIGIT DCA AC2 /PUT IN OP LOW WORD DCA OPL DCA OPH /ZERO HIGH OP JMS I (OADD /ADD IT IN STA /NOW BUMP DIGIT COUNTER TAD DIGCNT JMP FRACLP /GET ANOTHER CHAR NOTDIG, ISZ I [FFGET /TEST THE DP FLAG JMP NOTPD /JMP IF DP SEEN ALREADY AC0002 /ELSE SEE IF THIS IS DP TAD DIGIT SNA CLA /SKP IF NO JMP FRACLP /GET FRACTION DIGITS IF YES DCA DIGCNT /ZERO FRACTION DIGIT COUNT IF NO DP SEEN NOTPD, TAD SIGN /SAVE SIGN OF FRACTION DCA I [FFNEG /IN A TRULY RANDOM PLACE STA /NOW RESET MINUS SIGN FLAG DCA SIGN ISZ I (MPY10 /DISABLE LEADING SPACE SUPRESSION NOW TAD CHAR /SEE IF E FORMAT TAD (-105 SNA CLA /SKP IF NO GETEXP, JMS GCHR /ELSE GET A DECIMAL EXPONENT CHAR JMP EDONE /JMP IF AT DELIMITER TAD DECEXP /MULTIPLY CURRENT EXP BY 10 CLL RTL /*4 TAD DECEXP /*5 CLL RAL /*10 TAD DIGIT /ADD IN NEW DIGIT JMP GETEXP /UPDATE DECEXP AND GET NEXT DIGIT EDONE, JMS I (SNFAC /SPECIAL CASE TEST FOR ZERO FRACTION JMP I FFIN /RETURN IF YES, (SIMPLIFIES ADJDEC ROUTINE) TAD O43 /OK, SET INITIAL EXPONENT DCA ACX TAD DECEXP /GET EXPONENT ISZ SIGN CIA /IN TWOS COMPLEMENT TAD DIGCNT /ADD COMPENSATION FOR DIGITS AFTER DP TAD I [FFPUT /ADD EXCESS DIGITS IGNORED BEFORE DP JMS I (ADJDEC /SET IT AND NORMALIZE TAD DECEXP /TEST THE REMAINING DECIMAL EXP SPA JMP I (DIVGO /DIVIDE FRACTION BY 10 IF MINUS SZA CLA JMP I (MULGO /MULTIPLY FRACTION BY 10 IF POSITIVE TAD AC1 /ROUND TO 23 BITS IF REDUCED TO ZERO SPA CLA /SKP IF NO ROUND ISZ ACL JMP NOBUMP /NO CARRY ISZ ACH TAD ACH /TEST IF OVERROUND SMA CLA /SKP IF YES JMP NOBUMP JMS I (AR1 /CORRECT IT ISZ ACX /COMPENSATE BINARY EXPONENT O43, 43 /EFFECTIVE NOP NOBUMP, ISZ I [FFNEG /TEST SIGN OF RESULT JMS I [FFNEG /COMPLEMENT IF NEGATIVE JMP I FFIN /--RETURN-- DIGCNT= XR3 SIGN= XR4 DIGIT= XR5 /ROUTINE TO GET NEXT DIGIT /RETURN TO CALL+1 IF DON'T HAVE DIGIT /RETURN TO CALL+2 IF HAVE DIGIT GCHR, 0 DCA DECEXP /STORE ACCUMULATED EXPONENT (MAYBE) JMS INPUT /GET A CHAR FROM TTY. TAD CHAR /PICK IT UP TAD (-53 /TEST IF + OR - CLL RTR /LINK ON IF MINUS SZA CLA /SKP IF + OR - JMP NOTSGN /ELSE SKIP THIS SZL /SKP IF + DCA SIGN /FLIP SWITCH IF - JMS INPUT /GET A CHAR. NOTSGN, TAD CHAR TAD (-72 /SEE IF ITS A DIGIT CLL TAD (12 DCA DIGIT /STORE FOR LATER SZL /DIGIT? ISZ GCHR /YES-RETN. TO CALL+2 JMP I GCHR /NO-RETN. TO CALL+1 /INPUT ROUTINE, IGNORES LEADING SP, HT, LF, VT, FF, AND CR CHARS INPUT, 0 JMS I IGETCH /USE OUR ROUTINE TO GET CHAR TAD I (MPY10 /TEST IF ANY INPUT YET SNA CLA /BYPASS LEADING CHAR IGNORES IF YES TAD CHAR /NO-GET CHAR TAD [-40 /COMPARE AGAINST SPACE SZA /SKP IF SPACE TAD (40-11 /CHECK IF HT, LF, VT OR FF CLL TAD (-5 SNL CLA /SKP IF NONE OF ABOVE JMP INPUT+1 /YES-IGNORE IT JMP I INPUT /RETURN IGETCH, GETCH /POINTER TO GET CHAR ROUTINE /ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL) PAGE IFZERO EAE < / /INVERSE FLOATING SUBTRACT-USES FLOATING ADD /!!FSW1!!-THIS IS OP-FAC / FFSUB1, 0 JMS I [PATCHF /WHICH MODE? TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP. JMS I (ARGET /GO PICK UP OPERAND CDF JMS I [FFNEG /NEGATE FAC TAD FFSUB1 /AND GO ADD JMP I (SUB0 / /INVERSE FLOATING DIVIDE /FSWITCH=1 /THIS IS OP/FAC / FFDIV1, 0 JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFDIV1 /CALLED BY USER-GET ADDR. JMS I (ARGET /PICK UP OPERAND TAD ACL /SWAP THE FAC AND OPERAND DCA OPL /THERE IS A POINTER TO OPL TAD I AC2 /IN AC2 LEFT FROM ARGET SUBR. DCA ACL TAD ACX /MIGHT AS WELL SUBTRACT THE CLL CMA IAC /EXPONENTS HERE (SAVES A WORD) TAD OPX /THEN ZERO OPX SO WILL NOT DCA ACX /MESS UP WHEN ITS DONE AGAIN DCA OPX /LATER (SEE DIV. ROUTINE) TAD ACH DCA AC2 /NOW SWAP HIGH ORDER MANTISSAS TAD OPH DCA ACH TAD AC2 DCA OPH CDF /DF TO PACKAGE FIELD TAD FFDIV1 /NOW KLUDGE UP A SUBROUTINE LINKAGE DCA I (FFDIV TAD (FFD1 DCA I (MDSET JMP I (MD1 /GO SET UP AND DIVIDE /MDSET-SETS UP SIGNS FOR MULTIPLY AND DIVIDE /ALSO SHIFTS OPERAND ONE BIT TO THE LEFT. /EXIT WITH EXPONENT OF OPERAND IN AC FOR EXPONENT /CALCULATION-CALLED WITH ADDRESS OF OPERAND IN AC AND /DATA FIELD SET PROPERLY FOR OPERAND. / MDSET, 0 JMS I (ARGET /GET ARGUMENT MD1, CDF /DF TO PACKAGE FIELD CLA CLL CMA RAL /SET SIGN CHECK TO -2 DCA TM TAD OPH /IS OPERAND NEGATIVE? SMA CLA JMP .+3 /NO JMS I (OPNEG /YES-NEGATE IT ISZ TM /BUMP SIGN CHECK TAD OPL /AND SHIFT OPERAND LEFT ONE BIT CLL RAL DCA OPL TAD OPH RAL DCA OPH DCA AC1 /CLR. OVERFLOW WORF OF FAC TAD ACH /IS FAC NEGATIVE SMA CLA JMP LEV /NO-GO ON JMS I [FFNEG /YES-NEGATE IT ISZ TM /BUMP SIGN CHECK NOP /MAY SKIP LEV, TAD OPX /EXIT WITH OPERAND EXPONENT IN AC JMP I MDSET / /CONTINUATION OF FLOATING DIVIDE ROUTINE / FD1, TAD AC2 /NEGATE HI ORDER PRODUCT CLL CMA IAC TAD ACH /COMPARE WITH REMAINDER OF FIRST DIV. SNL /WELL? JMP I (DVOPS /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV. CLL /OK-DO (REM-(Q*OPL))/OPH DCA ACH /FIRST STORE ADJUSTED PRODUCT JMS I (DV24 /DIVIDE BY OPH (HI ORDER OPERAND) DVL1, TAD AC1 /GET QUOT. OF FIRST DIV. SMA /IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT JMP FD /NO-ITS NORMALIZED-DONE CLL ISZ ACL SKP IAC RAR DCA ACH /STORE IN FAC TAD ACL /P@ LOW ORDER RIGHT RAR DCA ACL /STORE BACK ISZ ACX /BUMP EXPONENT NOP TAD ACH JMP DVL1+1 FD, DCA ACH /STORE HIGH ORDER RESULT JMP I (FDDON /GO LEAVE DIVIDE / /CONTINUATION OF ROUTINE TO ADJUST QUOT. OF FIRST DIV. /DBAD1 IS ONLY EXECUTED ON DIVIDE OVERFLOW-OTHERWISE THE /ROUTINE STARTS AT DVOP2 / DBAD1, DCA ACX /DIVIDE OVERFLO-ZERO ALL DVOP2, SNA /IS IT ZERO? DCA ACL /YES-MAKE WHOLE THING ZERO DCA ACH JMS I (DV24 /DIVIDE EXTENDED REM. BY HI DIVISOR TAD ACL /NEGATE THE RESULT CLL CMA IAC DCA ACL SNL /IF QUOT. IS NON-ZERO, SUBTRACT CMA /ONE FROM HIGH ORDER QUOT. JMP DVL1 /GO TO IT /MULTIPLY ACH;ACL;AC1 BY 10. MPY10, 0 JMS I (AC2OP /COPY AC FRACTION TO OP JMS I (AL1 /*2 JMS I (AL1 /*4 JMS I (OADD /*5 JMS I (AL1 /*10 JMP I MPY10 / /ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS / PATCHF, 0 SZA /IS AC EMPTY JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC TAD FF /YES-GET SPECIAL MODE FLIP-FLOP SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0 RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND JMP I PATCHF /RETURN PAGE /FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES FFMPY, 0 JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFMPY /CALLED BY USER-GET OPERAND ADDR. JMS I (MDSET /SET UP FOR MPY-OPX IN AC ON RETN. TAD ACX /DO EXPONENT ADDITION DCA ACX /STORE FINAL EXPONENT DCA DV24 /ZERO TEM STORAGE FOR MPY ROUTINE DCA AC2 TAD ACH /IS FAC=0? SNA CLA DCA ACX /YES-ZERO EXPONENT JMS MP24 /NO-MULTIPLY FAC BY LOW ORDER OPR. TAD OPH /NOW MULTIPLY FAC BY HI ORDER MULTIPLIER DCA OPL JMS MP24 TAD AC2 /STORE RESULT BACK IN FAC RTZRO, DCA ACL /LOW ORDER TAD DV24 /HIGH ORDER DCA ACH TAD ACH /DO WE NEED TO NORMALIZE? RAL SMA CLA JMP SHLFT /YES-DO IT FAST MDONE, DCA AC1 /NO-ZERO OVERFLOW WD(DO I NEED THIS???) ISZ FFMPY /BUMP RETURN POINTER ISZ TM /SHOULD RESULT BE NEGATIVE? JMP I FFMPY /NOPE-RETN. JMS I [FFNEG /YES-NEGATE IT JMP I FFMPY /RETURN SHLFT, CMA /SUBTRACT 1 FROM EXP. TAD ACX DCA ACX JMS I (AL1 /SHIFT FAC LEFT 1 BIT JMP MDONE+1 /DONE. / /24 BIT BY 12 BIT MULTIPLY. MULTIPLIER IS IN OPL /MULTIPLICAND IS IN ACH AND ACL /RESULT LEFT IN DV24,AC2, AND AC1 MP24, 0 TAD (-14 /SET UP 12 BIT COUNTER DCA OPX TAD OPL /IS MULTIPLIER=0? SZA JMP MPLP1 /NO-GO ON DCA AC1 /YES-INSURE RESULT=0 JMP I MP24 /RETURN MPLP, TAD OPL /SHIFT A BIT OUT OF LOW ORDER MPLP1, RAR /OF MULTIPLIER AND INTO LINK DCA OPL SNL /WAS IT A 1? JMP MPLP2 /NO-0-JUST SHIFT PARTIAL PRODUCT CLL /YES-ADD MULTIPLICAND TO PARTIAL PRODUCT TAD AC2 TAD ACL /LOW ORDER DCA AC2 RAL /PROPAGATE CARRY TAD ACH /HI ORDER MPLP2, TAD DV24 RAR /NOW SHIFT PARTIAL PROD. RIGHT 1 BIT DCA DV24 TAD AC2 RAR DCA AC2 RAR /1 BIT OF OVERFLOW TO AC1 DCA AC1 ISZ OPX /DONE ALL 12 MULTIPLIER BITS? JMP MPLP /NO-GO ON JMP I MP24 /YES-RETURN / /PART OF DIVIDE ROUTINE-FFDIV MUST BE AT LOC. 6722 MP12L, DCA OPL /STORE BACK MULTIPLIET TAD AC2 /GET PRODUCT SO FAR SNL /WAS MULTIPLIER BIT A 1? JMP .+3 /NO-JUST SHIFT THE PARTIAL PRODUCT CLL /YES-CLEAR LINK AND ADD MULTIPLICAND TAD ACL /TO PARTIAL PRODUCT RAR /SHIFT PARTIAL PRODUCT-THIS IS HI ORDER DCA AC2 /RESULT-STORE BACK DVLP1, TAD OPL /SHIFT A BIT OUT OF MULTIPLIER RAR /AND A BIT OR RESLT. INTO IT (LO ORD. PROD.) ISZ FFMPY /DONE ALL BITS? JMP MP12L /NO-LOOP BACK CLL CMA IAC /YES-LOW ORDER PROD. OF QUOT. X OPL IN AC DCA ACL /NEGATE AND STORE CML RAL /PROPAGATE CARRY JMP I (FD1 /GO ON / /FLOATING DIVIDE ROUTINE /USES THE METHOD OF TRIAL DIVISION BY HI ORDER FFDIV, 0 /(USED AS A TEM. BY I/O ROUTINES) JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFDIV /CALLED BY USER-GET ARG. ADDR. JMS I (MDSET /GO SET UP FOR DIVIDE-OPX IN AC ON RETN. FFD1, CMA IAC /NEGATE EXP. OF OPERAND TAD ACX /ADD EXP OF FAC DCA ACX /STORE AS FINAL EXPONENT TAD OPH /NEGATE HI ORDER OP. FOR USE CLL CMA IAC /AS DIVISOR DCA OPH JMS DV24 /CALL DIV.--(ACH+ACL)/OPH TAD ACL /SAVE QUOT. FOR LATER DCA AC1 TAD (-15 /SET COUNTER FOR 12 BIT MULTIPLY DCA FFMPY /TO MULTIPLY QUOT. OF DIV. BY JMP DVLP1 /LOW ORDER OF OPERAND (OPL) / /END OF FLOATING DIVIDE-FUDGE SOME /STUFF THEN JUMP INTO MULTIPLY / FDDON, TAD FFDIV /STORE RETN. ADDR. IN MULT ROUTINE DCA FFMPY JMP MDONE /GO CLEAN UP / /DIVIDE ROUTINE--24 BITS IN ACH,ACL ARE DIVIDED BY 12 BITS /IN OPH. OPH IS ASSUMED NEGATIVE AND .GT. ACH IN ABSOLUTE VALUE /ELSE-DIVIDE OVERFLOW--WE RETURN NORMALLY WITH QUOTIENT /IN ACL AND REM. IN ACH. (AC2=0 ON RETN.) / DV24, 0 TAD ACH /CHECK THAT DIVISOR IS .GT. DIVIDEND TAD OPH /DIVISOR IN OPH (NEGATIVE) SZL CLA /IS IT? JMP I (DV /NO-DIVIDE OVERFLOW TAD (-15 /YES-SET UP 12 BIT LOOP DCA AC2 JMP DV1 /GO BEGIN DIVIDE DV2, TAD ACH /CONTINUE SHIFT OF FAC LEFT RAL DCA ACH /RESTORE HI ORDER TAD ACH /NOW SUBTRACT DIVISOR FROM HI ORDER TAD OPH /DIVIDEND SZL /GOOD SUBTRACT? DCA ACH /YES-RESTORE HI DIVIDEND CLA /NO-DON'T RESTORE--OPH.GT.ACH DV1, TAD ACL /SHIFT FAC LEFT 1 BIT-ALSO SHIFT RAL /1 BIT OF QUOT. INTO LOW ORD OF ACL DCA ACL ISZ AC2 /DONE 12 BITS OF QUOT? JMP DV2 /NO-GO ON JMP I DV24 /YES-RETN W/AC2=0 PAGE / /FLOATING ADD / FFADD, 0 JMS I [PATCHF /WHICH MODE FO CALL? TAD I FFADD /CALLED BY USER-GET ADDR. OF OPR. JMS I (ARGET /PICK UP OPERAND FAD1, CDF /DF TO PACKAGE FIELD TAD OPH /IS OPERAND = 0 SNA CLA JMP DONA /YES-DONE TAD ACH /NO-IS FAC=0? SNA CLA JMP DOADD /YES-DO ADD AC4000 AND ACX /NO, DO EXPONENT CALCULATION TAD OPX RAL /DO 13 BIT SUBTRACT CLA TAD ACX CML CIA TAD OPX SNL SZA /SKP IF OPX .LE. ACX JMP FACR /JMP IF OPX .GT. ACX CIA JMS OPSR JMS ACSR /SHIFT FAC ONE PLACE RIGHT DOADD, TAD OPX /SET EXPONENT OF RESULT DCA ACX JMS OADD /DO THE ADDITION JMS I [FFNOR /NORMALIZE RESULT DONA, ISZ FFADD /BUMP RETURN JMP I FFADD /RETURN FACR, JMS ACSR /SHIFT FAC = DIFF.+1 JMS OPSR /SHIFT OPR. 1 PLACE JMP DOADD /DO ADDITION / /OPERAND SHIFT RIGHT-ENTER WITH POSITIVE COUNT-1 /IN AC OPSR, 0 CMA /- (COUNT+1) TO SHIFT COUNTER DCA AC0 LOP2, TAD OPH /GET SIGN BIT RAL /TO LINK CLA TAD OPH /GET HI MANTISSA RAR /SHIFT IT RIGHT, PROPAGATING SIGN DCA OPH /STORE BACK TAD OPL RAR DCA OPL /STORE LO ORDER BACK RAR /SAVE 1 BIT OF OVERFLOW DCA AC2 /IN AC2 ISZ OPX /INCREMENT EXPONENT NOP2, NOP ISZ AC0 /DONE ALL SHIFTS? JMP LOP2 /NO-LOOP JMP I OPSR /YES-RETN. / /SHIFT FAC LEFT 1 BIT / AL1, 0 TAD AC1 /GET OVERFLOW BIT CLL RAL /SHIFT LEFT DCA AC1 /STORE BACK TAD ACL /GET LOW ORDER MANTISSA RAL /SHIFT LEFT DCA ACL /STORE BACK TAD ACH /GET HI ORDER RAL DCA ACH /STORE BACK JMP I AL1 /RETN. / /SHIFT FAC RIGHT-ENTER WITH COUNT-1 IN AC (POSITIVE) / ACSR, 0 CMA /AC CONTAINS COUNT-1 DCA AC0 /STORE COUNT LOP1, TAD ACH /GET SIGN BIT OF MANTISSA RAL /SET UP SIGN PROPAGATION CLA TAD ACH /GET HIGH ORDER MANTISSA RAR /SHIFT RIGHT`1, PROPAGATING SIGN DCA ACH /STORE BACK TAD ACL /GET LOW ORDER RAR /SHIFT IT DCA ACL /STORE BACK RAR DCA AC1 /SAVE 1 BIT OF OVERFLOW ISZ ACX /INCREMENT EXPONENT NOP1, NOP ISZ AC0 /DONE? JMP LOP1 /NO-LOOP JMP I ACSR /YES-RETN-AC=L=0 / /DIVIDE OVERFLOW-ZERO ACX,ACH,ACL / DBAD, CLA CLL /NECESSARY SO WE DON'T GET OVRFLO AGAIN JMP I (DBAD1 /GO ZERO ALL / /FLOATING SUBTRACT / FFSUB, 0 JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFSUB /CALLED BY USER-GET ADDR. OF OP JMS I (ARGET /PICK UO THE OP. JMS OPNEG /NEGATE OPERAND TAD FFSUB /JMP INTO FLTG. ADD SUB0, DCA FFADD /AFTER SETTING UP RETURN JMP FAD1 / /FLOATING NEGATE / FFNEG, 0 /(USED AS A TEM. BY OUTPUT ROUTINE) TAD ACL /GET LOW ORDER FAC CLL CMA IAC /NEGATE IT DCA ACL /STORE BACK CML RAL /ADJUST OVERFLOW BIT AND TAD ACH /PROPAGATE CARRY-GET HI ORD CLL CMA IAC /NEGATE IT DCA ACH /STORE BACK JMP I FFNEG / /NEGATE OPERAND / OPNEG, 0 TAD OPL /GET LOW ORDER CLL CMA IAC /NEGATE AND STORE BACK DCA OPL CML RAL /PROPAGATE CARRY TAD OPH /GET HI ORDER CLL CMA IAC /NEGATE AND STORE BACK DCA OPH JMP I OPNEG / /ADD OPERAND TO FAC / OADD, 0 CLL TAD AC2 /ADD OVERFLOW WORDS TAD AC1 DCA AC1 RAL /ROTATE CARRY TAD OPL /ADD LOW ORDER MANTISSAS TAD ACL DCA ACL RAL TAD OPH /ADD HI ORDER MANTISSAS TAD ACH DCA ACH JMP I OADD /RETN. > IFNZRO EAE < /EAE FLOATING POINT PACKAGE /FOR PDP8/E WITH KE8-E EAE / /W.J. CLOGHER / /DEFINITIONS OF EAE INSTRUCTIONS SWP= 7521 CAM= 7621 MQA= 7501 MQL= 7421 SGT= 6006 SWAB= 7431 SWBA= 7447 SCA= 7441 MUY= 7405 DVI= 7407 NMI= 7411 SHL= 7413 ASR= 7415 LSR= 7417 ACS= 7403 SAM= 7457 DAD= 7443 DLD= 7663 DST= 7445 DPIC= 7573 DCM= 7575 DPSZ= 7451 /FLOATING SUBTRACT-USES FLOATING ADD /FSW1!! FFSUB1, 0 JMS I [PATCHF /WHICH MODE? TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP JMS I (ARGET /PICK UP ARGUMENT CDF JMS I [FFNEG /NEGATE FAC! TAD FFSUB1 JMP I (SUB0 /FLOATING DIVIDE /FSWITCH=1 /THIS IS OP/FAC / FFDIV1, 0 JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFDIV1 /CALLED BY USER-GET ADDR. JMS I (ARGET /(INTERP.)-GET OPRND.-ADDR. IN AC CDF /CDF TO FIELD OF PACKAGE TAD ACH /SWAP FAC AND OPRND-OPH IN MQ! DCA OPH /STORE ACH IN OPH TAD ACX /GET EXP OF FAC SWP /OPH TO AC, ACX TO MQ DCA ACH /STORE OPH IN ACH TAD OPX /STORE OPX IN ACX DCA ACX TAD OPL /OPL TO MQ, ACX TO AC SWP DCA OPX /STORE ACX IN OPX TAD ACL DCA OPL /STORE ACL IN OPL TAD OPH /OPH TO MQ FOR LATER SWP DCA ACL /STORE OPL IN ACL TAD FFDIV1 /SET UP SO WE RETN TO DCA I (FFDIV /NORMAL DIVIDE ROUTINE TAD (FFD1 DCA I (MDSET JMP I (MD1 /GO ARRANGE OPERANDS /PATCH TO EAE ADD ROUTINE ADDPCH, 0 TAD AC1 TAD RB4000 DPSZ JMP ADDP1 CLL CML RTR ISZ ACX NOP ADDP1, TAD RB4000 JMP I ADDPCH RB4000, 4000 PTCHAD, CDF TAD OPH SNA CLA /OPERAND ZERO JMP I JADON /YES TAD ACH /FAC ZERO SZA CLA JMP I JFAD1 /NO TAD OPX DCA ACX TAD OPH DCA ACH TAD OPL DCA ACL JMP I JADON JADON, ADON JFAD1, FAD1 /ADD OP TO FAC OADD, 0 CLL TAD AC2 TAD AC1 DCA AC1 /ADD GUARD BITS RAL TAD OPL TAD ACL DCA ACL /ADD LOW ORDER BITS RAL TAD OPH TAD ACH DCA ACH /ADD HIGH ORDER BITS JMP I OADD /SHIFT FAC LEFT 1 BIT AL1, 0 TAD AC1 CLL RAL DCA AC1 TAD ACL RAL DCA ACL TAD ACH RAL DCA ACH JMP I AL1 /MULTIPLY ACH;ACL;AC1 BY 10. MPY10, 0 JMS I (AC2OP /COPY AC FRACTION TO OP JMS I (AL1 /*2 JMS I (AL1 /*4 JMS I (OADD /*5 JMS I (AL1 /*10 JMP I MPY10 / /ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS / PATCHF, 0 SZA /IS AC EMPTY JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC TAD FF /YES-GET SPECIAL MODE FLIP-FLOP SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0 RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND JMP I PATCHF /RETURN PAGE /FLOATING MULTIPLY--DOES 4 SINGLE MULTIPLIES WITH EAE /THIS USES THE FACT THAT IF AC IS NON-ZERO WHEN YOU DO /A MUY INSTR, THE AC IS ADDED TO RESULT OF THE MULTIPLY. /(IN THE LOW ORDER, NATCHERLY) FFMPY, 0 JMS I [PATCHF /WHICH MODE? TAD I FFMPY /CALLED BY USER-GET ADDRESS JMS MDSET /SET UP FOR MULT CLA MUY /MULTIPLY-LOW ORDER FAC STILL IN MQ OPH /THIS IS PRODUCT OF LOW ORDERS MQL /ZAP LOW ORDER RESULT-INSIGNIFICANT TAD ACH /GET LOW ORDER(!) OF FAC SWP MUY /TO MQ-HIGH ORD. RESLT OF LAST MPY OPL /TO AC-WILL BE ADDED TO RESLT-THIS DST /IS PRODUCT-LOW ORD FAC,HI ORD OP AC0 /STORE RESULT DLD /HIGH ORDER FAC TO MQ, OPX TO AC ACL TAD ACX /ADD FAC EXPONENT-GET SUM OF EXPS. DCA ACX /STORE RESULT MUY /MUL. HIGH ORDER FAC BY LOW ORD OP. OPH /HIGH ORDER FAC WAS IN MQ DAD /ADD IN RESULT OF SECOND MULTIPLY AC0 DCA ACH /STORE HIGH ORDER RESULT TAD ACL /GET HIGH ORDER FAC SWP /SEND IT TO MQ AND LOW ORD. RESULT DCA AC0 /OF ADD TO AC-STORE IT RAL /ROTATE CARRY TO AC DCA ACL /STORE AWAY MUY /NOW DO PRODUCT OF HIGH ORDERS OPL /FAC HIGH IN MQ, OP HIGH IN OPL DAD /ADD IN THE ACCUMULATED # ACH SNA /ZERO? JMP RTZRO /YES-GO ZERO EXPONENT NMI /NO-NORMALIZE (1 SHIFT AT MOST!) DCA ACH /STORE HIGH ORDER RESULT CLA SCA /GET STEP CNTR-DID WE NEED A SHIFT? SNA CLA JMP SNCK /NO-JUST CHECK SIGN CLA CMA /YES-MUST DECREASE EXP. BY 1 TAD ACX RTZRO, DCA ACX /STORE BACK TAD AC0 SPA CLA /IS HIGH ORDER OF OVERFLO WD. 1? DPIC /YES-ADD 1 TO LOW ORDER-STILL IN MQ SNCK, ISZ MSIGN /RESULT NEGATIVE? JMP MPOS /NO-GO ON TAD ACH /YES-GET HIGH ORDER BACK DCM /LOW ORDER STILL IN MQ-NEGATE DCA ACH /STORE HIGH ORDER BACK MPOS, SWP /LOW ORDER TO AC DCA ACL /STORE AWAY ISZ FFMPY /BUMP RETURN JMP I FFMPY /RETIRN MSIGN, 0 / /ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE / MDSET, 0 JMS I (ARGET /GET OPERAND (ADDR. IN AC) CDF /CHANGE TO DATA FIELD OF PACKAGE MD1, CLA CLL CMA RAL /MAKE A MINUS TWO DCA MSIGN /AND STORE IN MSIGN. TAD OPL /GET LOW ORDER MANTISSA OF OP. SWP /GET INTO RIGHT ORDER ( OPH IN MQ) SMA /NEGATIVE? JMP .+3 /NO DCM /YES-NEGATE IT ISZ MSIGN /BUMP SIGN COUNTER SHL /SHIFT OPRND LEFT 1 TO AVOID OVRFLO 1 DST /STORE BACK-OPH CONTAINS LOW ORDER OPH / OPL CONTAINS HIGH ORDER DLD /GET THE MANTISSA OF THE FAC ACH SWP /MAKE IT CORRECT ORDER SMA /NEGATIVE? JMP FPOS /NO DCM /YES-NEGATE IT ISZ MSIGN /BUMP SIGN COUNTER (MAY SKIP) NOP FPOS, DST /STORE BACK-ACH CONTAINS LOW ORDER ACH / ACL CONTAINS HIGH ORDER JMP I MDSET /RETURN /FLOATING DIVIDE FFDIV, 0 JMS I [PATCHF /WHICH MODE? TAD I FFDIV /CALLED BY USER-GET ARG. ADDRESS JMS MDSET /GET ARG. AND SET UP SIGNS FFD1, DVI /DIVIDE-ACH AND ACL IN AC,MQ OPL /THIS IS HI (!) ORDER DIVISOR DST /QUOT TO AC0,REM TO AC1 AC0 SZL CLA /DIVIDE ERROR? JMP I (DV /YES-HANDLE IT TAD OPX /DO EXPONENT CALCULATION CMA IAC /EXP. OF FAC - EXP. OF OP TAD ACX DCA ACX DPSZ /IS QUOT = 0? SKP /NO-GO ON DCA ACX /YES-ZERO EXPONENT DVLP, MUY /NO-THIS IS Q*OPL*2**-12 OPH DCM /NEGATE IT TAD AC1 /SEE IF GREATER THAN REMAINDER SNL JMP I (DVOPS /YES-ADJUST FIRST DIVIDE DVI /NO-DO Q*OPL*2**-12/OPH OPL SZL CLA /DIV ERROR? JMP I (DV /YES DVLP1, TAD AC0 /NO-GET QUOT OF FIRST DIV. SMA /NEGATIVE? JMP .+5 /NO-REMEMBER-QUOT OF 2ND DIV. IN MQ LSR /YES-MUST SHIFT IT RIGHT 1 1 ISZ ACX /ADJUST EXPONENT NOP ISZ MSIGN /SHOULD SIGN BE MINUS? SKP /NO DCM /YES-DO IT DBAD1, DCA ACH /STORE IT BACK SWP DCA ACL ISZ FFDIV JMP I FFDIV /BUMP RETN. AND RETN. DBAD, CAM DCA ACX /ZERO EXPONENT JMP DBAD1 /GO ZERO MANTISSA PAGE /FLOATING ADDITION-IN ORDER NOT TO LOSE BITS, WE DO NOT /SHIFT BOTH NUMBERS RIGHT 1 BIT BEFORE ADD-ONLY SHIFTS DONE /ARE TO ALIGN EXPONENTS. FFADD, 0 JMS I [PATCHF /WHICH MODE OF CALLING TAD I FFADD /CALLED DIRECTLY BY USER JMS I (ARGET /PICK UP ARGUMENTS JMP I (PTCHAD /CHECK FOR ADDITION BY ZERO FAD1, TAD OPX /PICK UP EXPONENT OF OPERAND MQL /SEND IT TO MQ FOR SUBTRACT TAD ACX /GET EXPONENT OF FAC SAM /SUBTRACT-RESULT IN AC SPA /NEGATIVE RESULT? CMA IAC /YES-MAKE IT POSITIVE DCA CNT /STORE IT AS A SHIFT COUNT TAD CNT /COUNT TOO BIG?(CAN'T BE ALIGNED) TAD M27 SPA SNA CLA CMA /NO-OK DCA AC0 /YES-MAKE IT A LOAD OF LARGEST # DLD /GET ADDRESSES TO SEE WHO'S SHIFTED ADDRS SGT /WHICH EXP GREATER(GT FLG SET /BY SUBTR. OF EXPS.) SWP /OPERAND'S-SHIFT THE FAC DCA SHFBG /STORE ADDRESS OF WHO GETS SHIFTED SWP /GET ADDRESS OF OTHER (0 TO MQ) DCA DADR /THIS ONE JUST GETS ADDED SGT /WHICH EXPONENT WAS GREATER? JMP .+3 /FAC'S - DO NOTHING TAD OPX /OPERAND'S-PUT FINAL EXP. IN ACX DCA ACX DLD /GET THE LARGER # TO AC,MQ DADR, 0 SWP /PUT IN THE RIGHT ORDER ISZ AC0 /COULD EXPONENTS BE ALIGNED? JMP LOD /NO-JUST LEAVE LARGER IN AC,MQ DST /YES-STORE THIS TEMPORARILY AC0 /(IF ONLY FAC STORAGE WAS REVERSED) DLD /GET THE SMALLER # SHFBG, 0 SWP /PUT IT IN RIGHT ORDER ASR /DO THE ALIGNMENT SHIFT CNT, 0 DAD /ADD THE LARGER # AC0 DST /STORE RESULT AC0 SZL /OVERFLOW?(L NOT = SIGN BIT) CMA /NOTE-WE DIDN'T SHIFT BOTH RIGHT 1 SMA CLA JMP NOOV /NOPE CLA CLL CML RAR /MAYBE-SEE IF 2 #S HAD SAME SIGN AND ACH TAD OPH SMA CLA /SIGNS ALIKE? JMP OVRFLO /YES-OVERFLOW NOOV, JMS I (ADDPCH /JUMP TO PATCH FOR THIS ROUTINE LOD, NMI /NORMALIZE (LOW ORDER STILL IN MQ) DCA ACH /STORE FINAL RESULT SWP /GET AND STORE LOW ORDER DCA ACL SCA /GET SHIFT COUNTER(# OF NMI SHIFTS) CMA IAC /NEGATE IT TAD ACX /AND ADJUST FINAL EXPONENT DCA ACX ADON, ISZ FFADD /BUMP RETURN PAST ADDRESS JMP I FFADD /RETURN OVRFLO, TAD AC1 /OVERFLOW-GET HIGH ORDER RESLT BACK ASR /SHIFT IT RIGHT 1 1 TAD KK4000 /REVERSE SIGN BIT DCA ACH /AND STORE SWP DCA ACL /STORE LOW ORDER ISZ ACX /BUMP EXPONENT NOP JMP ADON /DONE KK4000, 4000 M27, -27 ADDRS, OPH ACH /FLOATING SUBTRACT-USES FLOATING ADD /FSW0!! FFSUB, 0 JMS I [PATCHF /WHICH MODE? TAD I FFSUB /CALLED BY USER-GET ADDRESS OF OP. JMS I (ARGET CDF TAD OPL /OPH IS IN MQ! SWP /PUT IT IN RIGHT ORDER DCM /NEGATE IT DCA OPH /STORE BACK MQA DCA OPL TAD FFSUB /GO TO ADD SUB0, DCA FFADD JMP FAD1-1 /FLOATING NEGATE--NEGATE FLOATING AC FFNEG, 0 SWAB /MUST BE MODE B DLD /GET MANTISSA ACH SWP /CORRECT ORDER PLEASE! DCM /NEGATE IT DCA ACH /RESTORE SWP /SEND 0 TO MQ DCA ACL JMP I FFNEG /CONTINUATION OF DIVIDE ROUTINE /WE ARE ADJUSTING THE RESULT OF THE /FIRST DIVIDE. DVOPS, CMA IAC DCA AC1 /ADJUST REMAINDER TAD OPL /WATCH FOR OVERFLOW CLL CMA IAC TAD AC1 SNL JMP DVOP1 /DON'T ADJUST QUOT. DCA AC1 CMA TAD AC0 DCA AC0 /REDUCE QUOT BY 1 DVOP1, CLA CLL TAD AC1 /GET REMAINDER SNA /ZERO? CAM /YES-ZERO EVERYTHING DVI /NO OPL SZL CLA /DIV. OVERFLOW? JMP I (DV /YES DCM /NO-ADJUST HI QUOT (MAYBE) JMP I (DVLP1 /GO BACK > PAGE /ARGUMENT PICK UP ROUTINE-ENTER WITH DATA FIELD SET TO EITHER /FLTG. DATA FIELD OR FLTG. INSTR. FIELD. /ADDRESS OF OPERAND IS IN THE AC ON ENTRY. /ON RETURN, THE`AC IS CLEAR ARGET, 0 DCA AC2 /STORE ADDRESS OF OPERAND TAD I AC2 /PICK UP EXPONENT DCA OPX JMS ISZAC2 /MOVE POINTER TO HORD,WATCH FOR FIELD OVERLAP TAD I AC2 /PICK IT UP IFNZRO EAE < SWAB /OPH INTO MQ BECAUSE EAE ROUTINES MQA /EXPECT TO FIND IT THERE > DCA OPH /STORE JMS ISZAC2 /MOVE POINTER TO LORD,WATCHING FOR OVERLAP TAD I AC2 /PICK IT UP DCA OPL /STORE IT JMP I ARGET /RETURN IFZERO EAE < / /ROUTINE TO NORMALIZE THE FAC / FFNOR, 0 TAD ACH /GET THE HI ORDER MANTISSA SNA /ZERO? TAD ACL /YES-HOW ABOUT LOW? SNA TAD AC1 /LOW=0, IS OVRFLO BIT ON? SNA CLA JMP ZEXP /#=0-ZERO EXPONENT NORMLP, AC2000 /NOT 0-MAKE A 2000 IN AC TAD ACH /ADD HI ORDER MANTISSA SZA /HI ORDER = 6000 JMP .+3 /NO-CHECK LEFT MOST DIGIT TAD ACL /YES-6000 OK IF LOW=0 SZA CLA SPA CLA /2,3,4,5,ARE LEGAL LEFT MOST DIGS. JMP FFNORR /FOR NORMALIZED #-(+2000=4,5,6,7) JMP FNLP /JUMP SO FFGET AND PUT ARE ORGED RIGHT FFNORR, DCA AC1 /DONE W/NORMALIZE-CLEAR AC1 JMP I FFNOR /RETURN AL1P, AL1 > IFNZRO EAE < / /ROUTINE TO NORMALIZE THE FAC / FFNOR, 0 CDF /CHANGE D.F. TO FIELD OF PACKAGE SWAB /FORCE MODE B DLD /PICK UP MANTISSA ACH SWP /PUT IT IN CORRECT ORDER NMI /NORMALIZE IT SNA /IS THE # ZERO? DCA ACX /YES-INSURE ZERO EXPONENT DCA ACH /STORE HIGH ORDER BACK SWP /STORE LOW ORDER BACK DCA ACL CLA SCA /STEP COUNTER TO AC CMA IAC /NEGATE IT TAD ACX /AND ADJUST EXPONENT DCA ACX JMP I FFNOR /RETURN > /FLOATING GET FFGET, 0 JMS I [PATCHF /WHICH MODE OF CALL TAD I FFGET /CALLED BY USER-GET ADDR. OF OP JMS ARGET /PICK UP OPERAND TAD OPX DCA ACX /LOAD THE OPERAND INTO FAC TAD OPL DCA ACL TAD OPH DCA ACH ISZ FFGET CDF JMP I FFGET /RETN. TO CALL +2 / /FLOATING PUT / FFPUT, 0 JMS I [PATCHF /WHICH MODE OF CALL? TAD I FFPUT /CALLED BY USER-GET OPR. ADDR DCA FFGET /STORE IN A TEMP TAD ACX /GET FAC AND STORE IT DCA I FFGET /AT SPECIFIED ADDRESS JMS ISZFGT /BUMP POINTER,WATCHING FOR FIELD OVERLAP TAD ACH DCA I FFGET JMS ISZFGT TAD ACL DCA I FFGET ISZ FFPUT /BUMP RETN. CDF JMP I FFPUT /RETN. TO CALL+2 /ROUTINES TO BUMP ARGET AND FPUT POINTERS AND INCREMENT THE /DATA FIELD IF THE POINTER CROSSES A FIELD BOUNDARY ISZFGT, 0 ISZ FFGET /BUMP POINTER JMP I ISZFGT /NO SKIP MEANS JUST RETURN SKP /SKIP MEANS WE HAVE TO INCREMENT DATA FIELD NEWCDF, DCA ISZFGT /THIS INST EXECUTED ONLY BY ISZAC2 RDF /GET THE DATA FIELD TAD CDF10 /BUMP BY 1 AND MAKE A CDF DCA .+1 /PUT IN LINE . JMP I ISZFGT /RETURN CDF10, CDF 10 ISZAC2, 0 ISZ AC2 /BUMP POINTER JMP I ISZAC2 /NOTHING HAPPENED TAD ISZAC2 /NEED NEW DF. GET RETURN ADDR JMP NEWCDF /AND BUMP DF IFZERO EAE < / /ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE /REMAINDER OF THE FIRST`DIVIDE IS LESS THAN QUOT*OPL /USED BY FLTG. DIVIDE ROUTINE / DVOPS, CMA IAC /NEGATE AND STORE REVISED REMAINDER DCA ACH CLL TAD OPH TAD ACH /WATCH FOR OVERFLOW SNL JMP DVOP1 /OVERFLOW-DON'T ADJUST QUOT. OF 1ST DIV. DCA ACH /NO OVERFLOW-STORE NEW REM. CMA /SUBTRACT 1 FROM QUOT OF TAD AC1 /FIRST DIVIDE DCA AC1 DVOP1, CLA CLL TAD ACH /GET HI ORD OF REMAINDER JMP I DVOP2P /GO ON DVOP2P, DVOP2 FNLP, CLL CML CMA /-1 TAD ACX /SUBTR. 1 FROM EXPONENT DCA ACX JMS I AL1P /SHIFT FAC LEFT 1 JMP NORMLP /GO BACK AND SEE IF NORMALIZED ZEXP, DCA ACX JMP FFNORR > /EDITOR READ ROUTINE SITS HERE ABOVE EDITOR LOAD AREA EDREAD, DCA EBLK /ENTER WITH AC = BLOCK JMS I E7607 /READ EDITOR OFF SYS: EDTSIZ /THIS MUCH TO FIELD 0 0000 /STARTING HERE EBLK, 0000 /FROM HERE HLT /CRASH SYS ON ERROR HERE JMP I .+1 /JMP INTO EDITOR CHAIN ENTRY NOW EDTBGN E7607, 7607 /I/O TABLE FOLLOWS AND CROSSES PAGE BOUNDRY /I/O TABLE ENTRIES TTYF, 1 /ASCII ZBLOCK IOTSIZ-1 /FILE #0 (CONSOLE) ZBLOCK IOTSIZ^MAXFIL /FILES #1 THROUGH #7 PAGE /CROSS FIELD LITERAL EQUATES PILOOP= [ILOOP PPUTCH= [PUTCH PPCH= [PCH PSACM1= [SAC-1 PFFNOR= [FFNOR PFFGET= [FFGET PFFPUT= [FFPUT PUNSFIX= [UNSFIX PERROR= [ERROR PFACCLR= [FACCLR PIDLE= [IDLE PPSWAP= [PSWAP PFTYPE= [FTYPE O177= [177 O377= [377 O200= [200 O10= [10 O17= [17 O7400= [7400 O77= [77 O40= [40 O15= [15 O7700= [7700 /PAGE ZERO LITERAL POOL FIELD 1 /FIELD 1 PAGE ZERO TEMPORARIES (VOLATILE) *10 SXR, 0 TXR, 0 /RECORD I/O PARAMETERS, MUST REMAIN VALID FOR LIFE OF I/O STATEMENT *20 EOLPTR, 0 /ONCE ONLY FLAG/PTR ZEROED ON IOTABLE INITIALIZATION REMSIZ, 0 /INITIALIZED TO REMAINING SIZE OF CURRENT RECORD NXTFLD, 0 /INITIALIZED TO HEAD OF RECORD FIELD DEFINITIONS EXPNDF, 0 /NEGATIVE IF CURRENT RECORD CAUSED FILE TO EXPAND /VOLATILE TEMPORARIES PRODL, 0 PRODH, 0 STPCNT, 0 SUBFPT, 0 SACPT, 0 /IOTABLE POINTER IMAGE FOR FIELD 1 IOHDR1, 0 IOBUF1, 0 IOBLK1, 0 IOPTR1, 0 IOHND1, 0 IOLOC1, 0 IOLEN1, 0 IORSZ1, 0 IOSUB1, 0 IONRH1, 0 IONRL1, 0 IOMAX1, 0 IOPOS1, 0 IOFIL1, 0 PAGE /STRING ACCUMULATOR, ONE 7 OR 8 BIT CHAR PER WORD SAC, START, 0 /ONCE ONLY STARTUP CODE TLS /SET TTY FLAG CDF TAD I (CDFIO /SET CDF'S IN PSWAP DCA I (P1CDF TAD I (CDFIO DCA I (P1CDF1 TAD I (PSFLAG /SET SWAP PAGE SMA CLA /SKP IF 2 PAGE SYSTEM HANDLER TAD (200 /ELSE USE 7600 AS SWAP AREA TAD (7400 DCA I (HICORE CLA IAC /BE SURE OS/8 SWAPPED IN AND I (PSFLAG SZA CLA JMP .+4 CIF JMS I (CALLF0 /SWAP IN IF NOT ALREADY IN PSWAP CDF 10 TAD I (SCOPWD /SAVE SCOPE FLAG AND (200 DCA I (SCOPFG CDF TAD I (HEIGHT DCA I (HCTR /INITIALIZE SCREEN HEIGHT KLUDGE (OS78) TAD (OVDESC-1 /SETUP OVERLAY BLOCK TABLE DCA SXR TAD (ARITHA-1 DCA TXR OVSET, CDF 10 TAD I SXR /GET BLOCK LOCATION PTR SNA /SKP IF NOT EOL JMP SETEM /GO SET ERROR MESSAGE OVERLAY IF DONE DCA SACPT /STORE TAD I SACPT /PICK IT UP TAD I SXR /ADD OFFSET TO THIS OVERLAY CDF SNA /SKP IF HAVE OVERLAY JMP NOOVLY /ELSE DON'T TRY TO READ IT DCA CURBK /STORE INLINE TAD CUROV /SEE IF IT WILL FIT IN FIELD 2 TAD (1400 CLL CIA TAD I (PSSTRT /COMPARE TO START OF PSEUDO CODE CLA CML RAL TAD (CDF 20 CIA TAD I (CDFPS SPA CLA /SKP IF THERE IS ROOM JMP NOFIT /ELSE DON'T LOAD IT CDF 10 CIF /CALL SYS: TO READ IT IN JMS I (7607 0620 /6 PAGES TO FIELD 2 CUROV, 0000 /STARTING HERE CURBK, 0000 /FROM HERE HLT /CRASH SYS ON THIS UNLIKELY ERROR CDF /RESET DF SKP NOFIT, TAD CURBK /STORE BLOCK IN OVERLAY TABLE IF COULDN'T LOAD IT NOOVLY, DCA I TXR /ELSE CLEAR THE ENTRY TAD CUROV /BUMP TO NEXT OVERLAY SLOT TAD (1400 DCA CUROV JMP OVSET SETEM, CDF 10 /NOW SET ERROR OVERLAY ADDR TAD I (CDOPT4 /SAVE CD SWITCHES M-X FOR VERSION AND FREE SPACE MSGS DCA PRODL /IN A RANDOM TEMPORARY TAD I (INFO+4 /SITS AT END OF STRING FUNCTIONS IMAGE CDF TAD (6 DCA I (ERRA CIF JMS I (CALLF0 /OUT WITH OS/8 NOW PSWAP CDF /NOW SET VARIOUS CDF'S AND ADDRESSES TAD I (CDFPS /INTERPRETIVE CODE DF AND ADDR DCA I (CDFPSU TAD I (PSSTRT DCA I (INTPC TAD I (CDFIO /STRING STOREAGE CDF DCA I (STDF TAD I (CDFIO /ARRAYS DCA I (ATABDF TAD I (CDFIO /SCALAR NUMERICS DCA I (SCALDF TAD I (CDFIO /INCORE DATA LIST DCA I (DLCDF TAD I (DLSTRT DCA I (DATAXR JMP I START /OK, NOW GO DO SOME INTERPRETING! PAGE *RECPAK /BRTS FIELD 1 STARTUP CODE (RESIDES IN INPUT BUFFER) /ENTER WITH AC = STARTING BLOCK OF BRTS ON SYS: /CALL+1 = ADDR OF BRTS PARAMETER BLOCK INBUF= SAC+SACLIM+1 /START INPUT BUFFER PAST SAC BRTBG1, 0 TAD F0BLK /ADD FIELD 0 OFFSET TO ADDR OF BRTS PASSED IN AC DCA F0BLK /STORE INLINE CDF TAD I BRTBG1 /NOW GET ADDR OF PARAMETER BLOCK FROM CALL+1 DCA PARM1 /POINT AT IT SAVPRM, CDF TAD I PARM1 /SAVE BRTS PARAMETERS CDF 10 DCA I SAV1 ISZ PARM1 ISZ SAV1 ISZ CNT1 JMP SAVPRM CIF /NOW READ IN FIELD 0 OF BRTS JMS I (7607 BRTSZ0 /SIZE CONTROL WORD 0000 /ADDR TO LOAD F0BLK, 11 /FROM HERE (INITIALLY CONTAINS BLOCK OFFSET TO FIELD 0) HLT /CRASH SYSTEM IF ERROR HERE RSTPRM, TAD I SAV2 /NOW RESTORE SYSTEM PARAMETERS CDF DCA I PARM2 CDF 10 ISZ SAV2 ISZ PARM2 ISZ CNT2 JMP RSTPRM CDF /NOW BUSY OUT ALL BUFFERS OCCUPIED BY CODE TAD I (CDFPS /FIRST SEE IF OBJECT CODE RAN INTO BUFFER AREA TAD (-6211 /IN FIELD 1 / SPA / HLT /UNREACHABLE - LOADER ERROR SZA CLA /SKP IF HIT FIELD 1 JMP SETHKS /GO SET ^C HOOKS IF ALL BUFFERS FREE KILBUF, TAD I (BUFSTK /SEE IF CODE IN FIELD 1 IS ABOVE END OF THIS BUFFER DCA SAV1 TAD I SAV1 SNA /SKP IF BUFFER EXISTS HLT /UNREACHABLE - LOADER ERROR TAD (377 /OFFSET TO END OF BUFFER CLL CIA TAD I (PSSTRT /ONE LESS THAN FIRST WORD OF CODE SZL CLA /SKP IF IN THIS BUFFER JMP SETHKS /DONE, GO SET ^C HOOKS ISZ I (BUFSTK /POP BUFFER FROM FREE STACK JMP KILBUF /TRY NEXT ONE SETHKS, TAD (JMP I FSTOP1 /NOW SET ^C HOOKS DCA I (7600 TAD (JMP I FSTOP1 DCA I (7605 TAD I (BIPCCL /NOW SEE IF FIELD CONTAINING BATCH IS UNTOUCHED AND (70 /ISOLATE BATCH FIELD BITS (IF ANY) CIA TAD I (CDFIO /SUBTRACT FROM FIELD BITS IN CDF INSTR AND (100 /AC5 SET IF CDFIO LT SYSTEM SIZE CLL RTL /IF YES, SET JSW BIT 3 TAD (1000 /ALWAYS SET NON RESTARTABLE BIT DCA I (JSW /STORE THE JSW NOW DCA INBUF /CLEAR THE TTY INPUT BUFFER NOW JMS I (START /GO DO SOME STARTUP CODE TAD PRODL /SEE IF /S OR /V SWITCHES PASSED AND (44 SNA CLA /SKP IF YES JMP I (ILOOP1 /ELSE START THE INTERPRETER NOW TAD (4 /LOAD ERROR MESSAGE OVERLAY CIF JMS I (CALLF0 OVLOAD CIF /NOW CALL THE MESSAGE ROUTINE JMS I (CALLF0 FREESP JMP I (ILOOP1 /AND START THE INTERPRETER UP PARM1, CDFIO SAV1, SAVBUF CNT1, CDFIO-PSFLAG-1 PARM2, CDFIO SAV2, SAVBUF CNT2, CDFIO-PSFLAG-1 SAVBUF, ZBLOCK PSFLAG+1-CDFIO /DESCRIPTION OF OVERALYS /PTR TO BLOCK NUMBER;OFFSET TO OVERLAY OVDESC, INFO+4;14 /BASIC.AF INFO+4;3 /BASIC.SF INFO+4;0 /BASIC.FF INFO+5;0 /BASIC.UF 0 /TERMINATED BY ZERO WORD PAGE INEND= .-1 /DEFINE LAST LOCATION IN INPUT BUFFER /CONSOLE INPUT ROUTINE TTYGCH, 0 TTYLP, CDF 10 TAD I INPTR /SEE IF ANYTHING IN BUFFER ISZ INPTR SNA JMP PROMPT /GET ANOTHER LINE IF NOT CIF CDF JMP I TTYGCH /OTHERWISE RETURN LFLUSH, JMS CRLF1 /RETURN CR PROMPT, TAD (PMTBUF /NOW PRINT PROMPT DCA INPTR PRMLP, TAD I INPTR /GET A CHAR SNA JMP GETLIN /END OF PROMPT JMS PCH1 /PRINT IT ISZ INPTR JMP PRMLP GETLIN, TAD (INBUF /INITIALIZE PTR BAKFIN, DCA INPTR TTYIN, CIF CDF TAD I (HEIGHT /RESET HEIGHT FUDGE DCA I (HCTR JMS I (CALLF0 /GET A CHAR GCH DCA I INPTR /TENTATIVELY SAVE IN BUFFER TAD I INPTR SZA /IGNORE NULLS TAD (-32 SNA JMP TTYIN /IGNORE ^Z (CAN'T HAVE END OF FILE ON TTY) TAD (32-25 SNA JMP LFLUSH /DELETE LINE IF ^U TAD (25-177 SNA JMP BACKUP /RUBOUT CHAR IF RUBOUT TAD (177-15 SNA CLA JMP GOTCR /HANDLE END OF LINE IF CR TAD INPTR /SEE IF CHAR WILL FIT TAD (-INEND+2 /(WITH ROOM FOR CR AND NULL DELIMETER) SNA CLA JMP TTYIN /IGNORE IT IF NO TAD I INPTR /ECHO IT FIRST IF YES JMS PCH1 ISZ INPTR /BUMP PTR JMP TTYIN /GET ANOTHER CHAR /HANDLE RUBOUTS BACKUP, TAD INPTR /SEE IF AT LEFT MARGIN TAD (-INBUF SNA CLA JMP TTYIN /IGNORE RUBOUT IF YES TAD SCOPFG /TEST IF SCOPE TERMINAL SNA CLA JMP NOSCOP /JMP OF NOT TAD (10 /TRANSMIT BS,SP,BS TO ERASE CHAR IF SCOPE JMS PCH1 TAD (40 JMS PCH1 TAD (10 SKP NOSCOP, TAD (177&"\ /TRANSMIT BACKSLASH FOR OTHER TERMINALS JMS PCH1 STA /BACK UP PTR TAD INPTR JMP BAKFIN /HANDLE CR GOTCR, JMS CRLF1 /ECHO CR,LF FIRST TAD (15 /STORE CR IN BUFFER DCA I INPTR ISZ INPTR DCA I INPTR /MARK END OF BUFFER TAD (INBUF /RESET PTR DCA INPTR JMP TTYLP /RETURN FIRST CHAR INPTR, INBUF /INITIALLY BEGINNING OF INPUT BUFFER SCOPFG, 0 /SET NONZERO IF TERMINAL IS SCOPE CRLF1, 0 CDF /FIRST ZERO THE CONSOLE PRINT POSITION DCA I (TTYF+IOTPOS-IOTHDR TAD (15 /PRINT CR,LF JMS PCH1 TAD (12 JMS PCH1 JMP I CRLF1 PCH1, 0 CIF /PRINT CHAR JMS I (CALLF0 PCH JMP I PCH1 FREE2, .+2;0 /CONTINUATION OF DEFINE FREELIST .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 0;0 /LAST ENTRY HAS ZERO LINK PAGE /DISPATCH FOR FIELD 1 FUNCTIONS /ENTRY WITH AC = FUNCTION CODE F1DISP, TAD JMPF1 DCA .+1 HLT JMPF1, JMP I .+1 /DISPATCH TABLE FOR FIELD 1 FUNCTIONS READSF /0 READ RECORD FIELD TO SAC WRITSB /1 WRITE SAC TO RECORED FIELD LOCATE /2 LOCATE RECORD IN RANDOM ACCESS FILE WRTEOR /3 WRITE END OF RECORD IN FILE DEFSUB /4 DEFINE FIELDS IN RECORD DFSIZE /5 DEFINE TOTAL RECORD SIZE DEFPMT /6 DEFINE INPUT STATEMENT PROMPT STRING /DEFINE INPUT STATEMENT PROMPT DEFPMT, TAD (PMTBUF-1 /SET THE POINTERS DCA TXR TAD (SAC-1 DCA SXR STA CDF TAD I (SACLEN CDF 10 DCA STPCNT JMP DEFPGO /GO SET THE PROMPT STRING NOW DEFPLP, TAD TXR /SEE IF IT WILL FIT TAD (-PMTEND+1 SNA CLA JMP EOPDEF TAD I SXR /GET A CHAR DCA I TXR /STORE IN BUFFER DEFPGO, ISZ STPCNT JMP DEFPLP EOPDEF, DCA I TXR /MARK END OF STRING CIF CDF JMP I (SSMODE /RETURN IN SMODE PMTBUF, 77 /INITIALLY ? ZBLOCK 7 PMTEND, 0 /SETUP FILE TABLE POINTERS IN FIELD 1 SFN1, 0 CDF TAD I (IOTHDR /GET ADDR OF CURRENT FILE BLOCK CDF 10 DCA PRODL /SAVE IN TEMP TAD (IOHDR1 /SET POINTER TO FIELD 1 TABLE DCA PRODH TAD (IOTHDR-IOTFIL-1 /SET COUNT DCA STPCNT TAD PRODL /SETUP POINTERS NOW DCA I PRODH ISZ PRODL ISZ PRODH ISZ STPCNT JMP .-5 JMP I SFN1 /RETURN FREELS, .+2;0 /FREE LIST OF RECORD FIELD DESCRIPTORS .+2;0 /THREAD WORD;POSITIVE FIELD SIZE .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 .+2;0 FREE2;0 /LINK TO PART 2 OF LIST PAGE /OPCODE TO LOCATE A RECORD IN RANDOM ACCESS FILE LOCATE, JMS I (SFN1 /SETUP FILE POINTERS FOR FIELD 1 CIF /FIRST TEST IF FILE IS OPEN JMS I (CALLF0 IDLE /TAKE ERROR EXIT IF NOT CIF /NOW FIX FAC TO GET RECORD NUMBER JMS I (CALLF0 FIX23 CDF /TEST IF RECORD LT NUMBER OF RECORDS IN FILE TAD I IONRL1 /DO DOUBLE PRECISION SUBTRACT CLL CIA TAD I (ACL CLA CML RAL /GET BORROW TAD I IONRH1 CIA TAD I (ACH DCA EXPNDF /SAVE TO FLAG FILE EXPANSION IF VARIABLE FILE SNL /SKP IF FILE EXPANDED JMP NOXPND /ELSE DON'T UPDATE HIGHEST REC NO TAD I (ACL DCA I IONRL1 TAD I (ACH DCA I IONRH1 /UPDATE LAST RECORD NUMBER NOXPND, TAD I IORSZ1 /MULTIPLY RECORD NUMBER BY PHYSICAL REC SIZE SZA /ERROR IF NOT DIRECT ACCESS FILE JMS I (MULT23 /RESULT CHAR POSITION IN FILE IN PRODH;PRODL JMP BR-2 /JMP IF MULTIPLY OVERFLOWED (WAY TOO BIG) TAD (600 CLL CIA TAD PRODH /TEST IF CHAR POS GE 384*2**12 SZL CLA /SKP IF NO JMP BR-2 /ELSE BAD RECORD NUMBER TAD (600 /DIVIDE BY 384 (600 OCTAL) FOR BLOCK AND CHAR IN BLOCK JMS I (DIV23 /PRODH=REMAINDER, PRODL=QUOTIENT TAD PRODL /SEE IF PAST END OF FILE CLL CMA TAD I IOMAX1 SNL CLA JMP BR-2 /BAD RECORD NUMBER TAD PRODL /SEE IF FILE GROWTH CLL CMA TAD I IOLEN1 /COMPARE TO CURRENT NUMBER OF BLOCKS IN FILE SZL CLA /SKP IF IOTLEN LT NEW SIZE INCLUDING NEW BLOCK JMP NOGRTH /JMP IF NO (ALWAYS JMPS FOR FIXED SIZE FILES) TAD PRODL /UPDATE IOTLEN IAC DCA I IOLEN1 NOGRTH, TAD PRODL /GET BLOCK OFFSET TAD I IOLOC1 /COMPARE TO CURRENT BLOCK IN BUFFER CIA TAD I IOBLK1 SNA CLA /SKP IF NOT THERE JMP GOTBLK /OTHERWISE WE HAVE IT NOW CIF JMS I (CALLF0 /WRITE CURRENT BLOCK IF DIRTY WRBLK CIF JMS I (CALLF0 /NOW INIT BLOCK (TO RESET DIRTY BIT) BLINIT CDF TAD PRODL /POINT AT THE BLOCK NOW TAD I IOLOC1 /ADD TO BASE DCA I IOBLK1 TAD (210 /NOW CALL THE DRIVER TO READ THE BLOCK CIF JMS I (CALLF0 DRCALL CDF GOTBLK, TAD PRODH /GET READY TO CALCULATE BYTE POINTERS DCA PRODL /SET PRODH;PRODL TO CHAR IN BLOCK DCA PRODH TAD (3 /DIVIDE BY 3 FOR BYTE POINTER JMS I (DIV23 TAD PRODH /REMAINDER = 3/2 STATE RTR CLA /GET 2 BIT, INDICATING 3RD CHAR IN GRP TAD I IOHDR1 /SET THE ODD BIT IF NECESSARY AND (7777-200 SZL TAD (200 DCA I IOHDR1 /STORE HEADER BITS BACK TAD PRODL /NOW GET DOUBLE WORD POINTER CLL RAL /*2 TAD PRODH /ADD CHAR OFFSET TAD I IOBUF1 /ADD TO BASE OF BUFFER DCA I IOPTR1 /TO SET THE POINTER ILOOP1, CIF CDF /DONE, RETURN TO ILOOP JMP I (ILOOP CDF 10 CIF /TAKE ERROR EXIT IF OUT OF RANGE RECORD REQUESTED BR, JMS I (ERROR CIF CDF JMP I (EOFSET /SET END OF FILE NOW /DEFINE RECORD LENGTH (PART OF OPEN PROCESSING) DFSIZE, JMS I (SFN1 /SET ALL THE POINTERS CIF JMS I (CALLF0 /GET 12 BIT RECORD SIZE UNSFIX CLL /RANGE CHECK RECORD NUMBER SZA TAD (2 SNA SZL /SKP IF RECORD LEGAL JMP SZ-2 /ERROR IF GT 4095 CDF DCA I IORSZ1 /ALL SET, STORE SIZE IN IOTABLE DCA I IONRL1 DCA I IONRH1 /CLEAR LAST RECORD SEEN (FOR ^Z DURING FILE CREATION) JMP I (ILOOP1 /OK, RETURN CDF 10 CIF SZ, JMS I (ERROR /TAKE ERROR IF RECORD NOT GE 1 AND LE 4093 PAGE /READ A RECORD SUBFIELD TO SAC READSF, JMS SETUP /DO COMMON SETUP OPERATION DCA I (SACLEN /INITIALIZE TO NULL STRING JMP SUBGO /JMP TO TOP TEST THE LOOP COUNTER SUBRDL, CIF JMS I (CALLF0 /GET THE NEXT CHAR GETCH CDF TAD I (SACLEN /SEE IF CHAR WE GOT WILL FIT TAD (SACLIM SPA SNA CLA /SKP IF ROOM JMP ST1-2 /TAKE ERROR RETURN IF NOT TAD I (CHAR /GET CHAR FROM BRTS CDF 10 DCA I SACPT /STORE IN SAC CDF ISZ SACPT /BUMP SAC POINTER STA /INCR NEGATIVE SAC CHAR COUNT TAD I (SACLEN DCA I (SACLEN SUBGO, ISZ STPCNT /TEST RECORD FIELD COUNTER JMP SUBRDL /ITERATE JMP I (ILOOP1 /DONE, RETURN CDF 10 CIF /PRINT WARNING IF STRING TRUNCATED ST1, JMS I (ERROR JMP .+4 SBFLSH, CIF JMS I (CALLF0 /FLUSH REST IF FIELD GETCH ISZ STPCNT JMP SBFLSH JMP I (ILOOP1 /RETURN TO ILOOP /WRITE A RECORD SUBFIELD FROM SAC WRITSB, JMS SETUP /DO COMMON SETUP JMP WRITGO /JMP INTO LOOP WRITSA, CDF 10 TAD I SACPT /GET CHAR FROM SAC CDF ISZ SACPT SKP /SKP IN AND SEND IT WRITPD, TAD (40 /PAD FIELD WITH BLANK CIF JMS I (CALLF0 PUTCH /PUT CHAR OUT CDF STA /DECREMENT REMAINING RECORD SIZE TAD REMSIZ DCA REMSIZ WRITGO, TAD I (SACLEN /SEE IF ANY CHARS LEFT SNA CLA JMP NULSAC /NULL SAC, SEE IF FIELD ENDED ISZ I (SACLEN /BUMP COUNT NOP ISZ STPCNT /TEST FIELD COUNT JMP WRITSA /WRITE SAC IF MORE ROOM CDF 10 /ERROR IF FIELD TOO SHORT CIF SH, JMS I (ERROR /PRINT WARNING JMP I (ILOOP1 /--RETURN-- NULSAC, ISZ STPCNT /SEE IF MORE IN FIELD JMP WRITPD /PAD FIELD IF YES JMP I (ILOOP1 /--RETURN-- /WRITE END OF RECORD WRTEOR, JMS SETUP TAD REMSIZ /SET COUNT TO REMAINING RECORD SIZE CMA DCA STPCNT /SET COUNTER JMP EORGO /GO PAD THE REMAINDER OF RECORD EORPAD, TAD (40 CIF JMS I (CALLF0 /SEND OUT A BLANK PUTCH EORGO, ISZ STPCNT JMP EORPAD EORFIN, CIF JMS I (CALLF0 /NOW SEND THE CR/LF CRLFR CDF TAD I IOHDR1 /SEE IF VARIABLE LENGTH FILE AND (4 SNA CLA JMP I (ILOOP1 /JMP OUT IF NO TAD EXPNDF /SEE IF FILE EXPANDED WITH THIS RECORD SPA CLA /SKP IF THIS RECORD WAS GE HIGHEST SO FAR JMP I (ILOOP1 /NO, RETURN TAD (32 /YES, SEND OUT ^Z CIF JMS I (CALLF0 PUTCH JMP I (ILOOP1 /--RETURN-- /COMMON SETUP CODE FOR READ/WRITE TO RECORD SETUP, 0 CDF 10 TAD NXTFLD /SEE IF ANOTHER FIELD LEFT SNA JMP EOFLD /JMP IF NO DCA SXR /POINT AT ITS DESCRIPTOR TAD I NXTFLD /LINK TO NEXT ONE DCA NXTFLD TAD I SXR /GET SIZE IF THIS ONE EOFLD, CMA /SET STEP COUNTER TO -SIZE-1 DCA STPCNT CDF TAD I (IOTHDR /SET PTR TO HEADER WORD DCA IOHDR1 TAD (SAC /SET PTR TO SAC DCA SACPT JMP I SETUP /DONE PAGE /DEFINE SUBFIELD OPERATOR DEFSUB, TAD EOLPTR /SEE IF FIRST TIME THROUGH SZA CLA /SKP IF YES, DO INITIALIZATION JMP DEFGO /ELSE JUST DEFINE NEXT FIELD CIF JMS I (CALLF0 /BE SURE FILE OPENED IDLE TAD REMSIZ /BE SURE THIS IS DIRECT ACCESS FILE SNA CLA JMP BF-2 /JMP OUT IF NO, GIVE ERROR CIF JMS I (CALLF0 /NOW CLEAR ANY CURRENT DEFINES RTNDEF DEFGO, TAD FREHD /SEE IF ANY DESCRIPTOR ELEMENTS LEFT SNA JMP DF-2 /JMP OUT IF NO DCA SUBFPT /IF YES, SAVE PTR TO NEXT ONE TAD I SUBFPT /REMOVE FROM LIST DCA FREHD CIF /NOW GET SIZE OF THIS FIELD JMS I (CALLF0 UNSFIX DCA SXR /SAVE IT TAD SXR /TEST IF FITS IN CURRENT RECORD CLL CIA TAD REMSIZ SNL CLA /SKP IF YES JMP BF-2 /ELSE TAKE ERROR EXIT TAD SXR /REDUCE REMAINING LENGTH OF RECORD CIA TAD REMSIZ DCA REMSIZ TAD EOLPTR /SEE IF FIRST FIELD SZA CLA /SKP IF YES JMP NOTFST /ELSE SKIP INITIALIZATION CDF TAD I (IOTSUB DCA IOSUB1 TAD SUBFPT /INIT PTR TO FIELDS IN IOTABLE DCA I IOSUB1 CDF 10 JMP .+3 NOTFST, TAD SUBFPT /STORE LINK TO THIS DESCRIPTOR IN PREV ONE DCA I EOLPTR TAD SUBFPT /MAKE THIS ONE CURRENT DCA EOLPTR /AND NEGATE ONCE ONLY STATUS DCA I EOLPTR /MARK END OF LIST TAD SXR /STORE SIZE ISZ SUBFPT DCA I SUBFPT /IN THE DESCRIPTOR JMP I (ILOOP1 /--RETURN-- CDF 10 CIF BF, JMS I (ERROR /TAKE ERROR ABORT CDF 10 CIF DF, JMS I (ERROR /NO MORE ROOM FOR RECORD FIELD DEFINITIONS FREHD, FREELS /POINTER TO LIST OF AVALIABLE RECORD FIELD DESCRIPTORS /UTILITY ROUTINE TO MULTIPLY ACH;ACL BY AC /PRODUCT RETURNED IN PRODH;PRODL /SKIP RETURN IF RESULT LT 2**23 /ERROR RETURN OTHERWISE /(THIS ROUTINE SHOULD REALLY BE PART OF ARRAY SUBSCRIPT CALCULATION) MULT23, 0 DCA MULARG /SAVE MULTIPLIER DCA PRODH /CLEAR RESULT REGISTER DCA PRODL MULTLP, TAD MULARG /SEE IF ANYMORE TO MULTIPLY SNA JMP MOUT /RETURN IF NOT CLL RAR DCA MULARG /SHIFT AND STORE SNL /SKP IF SHOULD ADD THIS TIME JMP NOADD TAD I (ACL TAD PRODL DCA PRODL CML RAL TAD I (ACH TAD PRODH SPA SZL JMP MERR /TAKE ERROR RETURN IF OVERFLOW DCA PRODH NOADD, TAD I (ACL /SHIFT AC LEFT 1 CLL RAL DCA I (ACL TAD I (ACH RAL SPA SZL JMP MERR DCA I (ACH JMP MULTLP /DO NEXT BIT MOUT, ISZ MULT23 /SKIP RETURN IF NO OVERFLOW MERR, CLA CLL JMP I MULT23 /--RETURN-- MULARG, 0 /ROUTINE TO DIVIDE 23 BIT PRODUCT BY AC /12 BIT QUOTIENT TO PRODL, REMAINDER TO PRODH DIV23, 0 CLL CIA /NEGATE DIVISOR DCA DIVISR TAD (-15 /DO 13. STEP RESTORING DIVIDE DCA STPCNT JMP DIVIT /JMP INTO LOOP DIVLUP, TAD PRODH /SHIFT REMAINDER UP RAL DCA PRODH DIVIT, TAD PRODH /SEE IF GOES IN TAD DIVISR SMA /SKP IF NO DCA PRODH /UPDATE IF YES CLA TAD PRODL /SHIFT QUOT BIT IN RAL DCA PRODL ISZ STPCNT JMP DIVLUP /ITERATE JMP I DIV23 /--RETURN-- DIVISR, 0 PAGE ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// ////////////// OVERLAY 2- STRING FUNCTIONS ///////////////// ///////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////// FIELD 2 *2000 RELOC OVERLAY /VERSION NUMBER WORD FOR STRING OVERLAY VERSON^100+SUBVSF+6000 OVDISP, TAD PSACM1 DCA SACXR /ALWAYS SET SACXR UP FOR STRING FUNCTIONS JMS I (FBITGT /GET FUNCTION TYPE TAD JMPSF /BUILD JMP DISPATCH INLINE DCA .+1 HLT JMPSF, JMP I .+1 /JMP OFF THE SET 2 TABLE /JUMP TABLE FOR FUNCTION SET 2 ASC /FUNCTION BITS= 000 CHR / 020 DATE / 040 LEN / 060 POS / 100 SEG / 120 STR / 140 VAL / 160 FIXPT / 200 TRACE / 220 STRNEG / 240 CAPS / 260 KSTROK / 300 OCT / 320 BIN / 340 OCS / 360 /OCS$(O) RETURN OCTAL REPRESENTATION OF POSITIVE NUMBER LT 2^23 OCS, JMS I (FIX23 /FIX THE NUMBER TAD (-10 /RETURN 8. DIGITS DCA TEMP2 OCSLUP, TAD ACH /ISOLATE NEXT DIGIT RTL RTL AND (7 TAD (60 /MAKE ASCII JMS I (SACPUT /PUT IN SAC JMS I (AL1 /SHIFT LEFT JMS I (AL1 JMS I (AL1 ISZ TEMP2 JMP OCSLUP /DO NEXT DIGIT JMP I (SETLEN /SET LENGTH AND RETURN IN SMODE /OCT AND BIN FUNCTIONS OCT, TAD (6 /SET MASK TO 7 IF OCT(O$) BIN, IAC /SET MASK TO 1 IF BIN(B$) DCA AC0 JMS I PFACCLR /ZERO THE FAC TAD SACLEN /SEE IF NULL STRING SNA CLA JMP OBXIT /QUICK EXIT IF YES OBLUP, CDF 10 TAD I SACXR /GET A CHAR CDF DCA TEMP2 /SAVE IT TAD AC0 /MASK THE HIGH ORDER BITS CMA AND TEMP2 TAD (-60 /SEE IF LEGAL DIGIT SZA CLA JMP OBERR /RETURN AT ONCE IF NO TAD AC0 /NOW SETUP FOR SHIFT OBSHFT, DCA AC2 JMS I (AL1 /SHIFT FAC LEFT TAD AC2 /SHIFT MASK RIGHT CLL RAR SZA /SKP IF DONE JMP OBSHFT /ELSE DO ANOTHER TAD AC0 /NOW ISOLATE NEW BITS AND TEMP2 TAD ACL DCA ACL ISZ SACLEN /DECR COUNT JMP OBLUP /LOOP OBXIT, TAD (27 /NOW SET EXPONENT OF RESULT DCA ACX JMS I PFFNOR /FLOAT NUMBER JMP I PILOOP /EXIT OBERR, TAD SACXR /IF BAD CHAR, RETURN -(ITS INDEX IN STRING) CIA TAD PSACM1 JMP I (FLOATS /FLOAT IT AND RETURN PAGE /CHR$ FUNCTION /RETURNS 1 7 BIT CHAR FOR VALUE OF X CHR, JMS I PUNSFIX /FIX X TO 12 BIT INTEGER AND IOMASK /MASK TO 7 OR 8 BITS JMS I (SACPUT /PUT STRING IN SAC SETLEN, TAD SACXR /NOW COMPUTE -SAC LENGTH CIA TAD PSACM1 DCA SACLEN /SET IT JMP I (SSMODE /SET TO SMODE AND RETURN /ASC FUNCTION /RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC ASC, CDF 10 TAD I SACXR /GET FIRST CHAR OF STRING CDF JMP FLOATS /FLOAT RESULT INTO FAC AND RETURN /LEN FUNCTION /RETURNS LENGTH OF SAC IN FAC LEN, TAD SACLEN /LENGTH OF STRING IN SAC CIA /MAKE POSITIVE /ROUTINE TO FLOAT FAC AND RETURN FLOATS, DCA ACH /NUMBER TO BE FLOATED IN HORD DCA ACL /CLEAR LORD DCA AC1 /CLEAR FPP OVERFLOW TAD (13 /SET EXP TO 11 DCA ACX JMS I PFFNOR /NORMALIZE JMP I PILOOP /RETURN /KEY$ FUNCTION /RETURN CHAR STRING FOR SINGLE KEY STROKE ON VT52 /NO TERMINAL ECHO KSTROK, JMS KEYGCH /GET A CHAR TAD (-33 /TEST IF ESC SNA CLA /SKP IF NO JMS KEYGCH /ELSE GET ANOTHER CHAR TAD (-77 /SEE IF ? SNA CLA JMS KEYGCH /ELSE GET ANOTHER CHAR CLA /CLEAR CHAR FROM AC JMP SETLEN /GO SET LENGTH OF SAC AND EXIT KEYGCH, 0 JMS I (GCH /GET A SINGLE CHAR FROM CONSOLE DCA TEMP2 /SAVE IT TAD TEMP2 /NOW PUT IN SAC JMS I (SACPUT TAD TEMP2 /RETURN WITH CHAR JMP I KEYGCH /STR$ FUNCTION /RETURNS ASCII STRING FOR NUMBER IN FAC STR, JMS I (FFOUT /GET NUMBER INTO INTERMEDIATE BUFFER FIRST TAD XR1 CIA TAD (INTERB-1 DCA TEMP2 /SAVE COUNTER TAD (INTERB-1 DCA XR1 /POINT AT BUFFER STRLUP, TAD I XR1 /GET A CHAR TAD (-40 /CROCK TO DELETE BLANKS SNA /SKP IF NOT BLANK JMP .+3 /ELSE IGNORE CHAR TAD (40 /FIX CHAR JMS I (SACPUT ISZ TEMP2 JMP STRLUP /LOOP FOR MORE JMP SETLEN /DONE-SET LENGTH OF SAC AND RETURN /CAP$ FUNCTION /CONVERT SAC TO UPPER CASE CAPS, TAD SACLEN /SEE IF NULL STRING SNA JMP I (SSMODE /NOTHING TO DO DCA VALCNT /SET COUNT TAD PSACM1 /SETUP PTR DCA XR1 CDF 10 CAPSLP, TAD I SACXR /RANGE CHECK CHAR FOR LOWER CASE ALPHA TAD (-173 CLL TAD (173-141 SZL /SKP IF NOT LOWER CASE TAD (-40 /ELSE CONVERT TO UPPER CASE TAD (141 /RESTORE CHAR DCA I XR1 /PUT BACK IN SAC ISZ VALCNT JMP CAPSLP / CDF JMP I (SSMODE /--RETURN-- /VAL FUNCTION /RETURNS NUMBER IN FAC FOR STRING IN SAC VAL, STA TAD SACLEN DCA VALCNT /COUNT OF CHARS TO INPUT TAD (VALGET /ADDR OF PHONY INPUT ROUTINE DCA I (IGETCH /PUT IN INPUT ROUTINE IN PLACE OF KRB JMS I (FFIN /CALL FPP INPUT ROUTINE TAD (GETCH /NOW RESTORE REAL INPUT ADDR DCA I (IGETCH /RESTORE IN INPUT ROUTINE JMP I PILOOP /DONE VALGET, 0 ISZ VALCNT /TEST COUNT JMP .+3 /JMP IF NOT END OF SAC TAD O77 /ELSE RETURN AN EFFECTIVE DELIMITER TO FFIN JMP RTNCR CDF 10 TAD I SACXR /GET THE CHAR FROM SAC CDF RTNCR, DCA CHAR JMP I VALGET /RETURN WITH CHAR IN 'CHAR' VALCNT, 0 PAGE /DATE FUNCTION /RETURNS STRING OF THE FORM "DD-MMM-YY" IN SAC IF DATE IS PRESENT /RETURNS NULL STRING OTHERWISE DATE, TAD CDFIO /COPY CDF TO FIELD 17600 IN LINE DCA .+1 YEAREX, 0 TAD PSFLAG /GET TD8E BIT TO LINK CLL RAL SNL CLA TAD I (MDATE /IF ZERO LOOK AT MDATE IN N7600 SZL TAD I (MDATE-200 /ELSE LOOK AT N7400 CDF /DATE IS IN THE FORM MMM MDD DDD YYY SNA /SKP IF HAVE SYSTEM DATE JMP I (SETLEN /ELSE RETURN NULL STRING DCA DATEWD TAD I (BIPCCL /NOW GET YEAR EXTENSION AND (600 /IT'S IN THE 600 BITS CLL RTR RTR /SHIFT INTO PLACE DCA YEAREX /HOLD YEAR EXTENSION TAD DATEWD /NOW GET DAY OF MONTH AND (370 CLL RTR RAR JMS PUTN /PUT "DD-" IN SAC TAD (55 JMS SACPUT TAD DATEWD /ISOLATE MONTH AND O7400 CLL RTL RTL RTL TAD (MONTHS-2 DCA TEMP2 /POINT AT ASCII FOR THIS MONTH TAD I TEMP2 /GET THE FIRST CHAR JMS SACPUT /PUT IN SAC ISZ TEMP2 TAD I TEMP2 /GET THE NEXT CHAR RTR RTR RTR AND O77 /MASK TO 6BIT TAD (140 /CONVERT TO LOWER CASE JMS SACPUT TAD I TEMP2 /GET THE LAST CHAR AND O77 TAD (140 JMS SACPUT /STORE IT TAD (55 /SEND OUT "-" JMS SACPUT TAD DATEWD /FINALLY GET YEAR AND (7 TAD YEAREX /ADD TO EXTENSION BITS TAD O106 /ADD 70. FOR BASE YEAR JMS PUTN /PUT OUT "YY" JMP I (SETLEN /SET LENGTH AND RETURN IN SMODE PUTN, 0 ISZ NHIGH /BUMP HIGH ORDER DIGIT TAD (-12 /-10. SMA JMP .-3 /LOOP IF NOT REDUCED YET TAD (12+60 /CONVERT TO DECIMAL DIGIT DCA NLOW /HOLD MOMENTARILY TAD NHIGH /NOW GET HI ORDER DIGIT TAD (57 /MAKE 6BIT JMS SACPUT TAD NLOW /SEND OUT LOW DIGIT JMS SACPUT DCA NHIGH /CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!) JMP I PUTN SACPUT, 0 CDF 10 DCA I SACXR /STORE THE CHAR CDF JMP I SACPUT NHIGH, 0 NLOW, 0 MONTHS, TEXT /AJANAFEBAMARAAPRAMAYAJUNAJULAAUGASEPAOCTANOVADEC/ DATEWD= .-1 O106= MONTHS+2 /TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF TRACE, TAD ACH /GET HI MANTISSA OF ARG SNA CLA /SKP TO TURN TRACE ON TAD TRREST /ELSE RESTORE TRACE BYPASS INSTR IN LINE NUMBER ROUTINE DCA I (TRHOOK /BY NOP ING INSTRUCTION AT TRHOOK TRREST, JMP I PILOOP PAGE /SEG$ FUNCTION /RETURNS SEGMENT OF X$ BETWEEN Y AND Z /IF Y<=0,THEN Y TAKEN AS 1 /IF Y>LEN(X$),NULL STRING RETURNED /IF Z<=0,NULL STRING RETURNED /IF Z>LEN(X$),Z IS SET=LEN(X$) /IF Z0? SMA SZA CLA JMS I PUNSFIX /FIX IF POSITIVE SNA IAC /SET Y TO 1 IF Y.LE.0 DCA YARG TAD SACLEN /COMPARE YARG TO SACLEN CIA STL CIA TAD YARG SNL SZA CLA /SKP IF YARG.LOS.LEN(X$) JMP NULLST /NO-RETURN THE NULL STRING DCA INSAV /FAKE POINTER TO SCALAR #0 JMS I ARGPLK /GET ADDR OF Z JMS I PFFGET /LOAD Z INTO FAC ARGPLK, ARGPRE /LOC SKIPPED BY FPP SO WE PUT CONST HERE TAD ACH /HI MANTISSA OF Z SPA SNA CLA /IS Z<0? JMP NULLST /YES-RETURN THE NULL STRING JMS I PUNSFIX /NO-FIX Z STL TAD SACLEN /CALC Z-LEN(SAC) SNL /SKP IF Z.LO.LEN(SAC) CLA /ELSE TAKE LEN(SAC) CMA TAD SACLEN TAD YARG /NUMBER OF BYTES TO USE SMA JMP NULLST /NONE, RETURN NULL STRING DCA STRCNT TAD YARG /INDEX INTO STRING FOR SOURCE BYTES TAD (SAC-2 DCA XR2 /SET SOURCE XR TAD STRCNT DCA SACLEN /SET NEW LENGTH OF SAC NOW CDF 10 TAD I XR2 /NOW MOVE THE BYTES DCA I SACXR ISZ STRCNT JMP .-3 / CDF JMP I (SSMODE /--RETURN-- NULLST, CLA CLL DCA SACLEN /ZERO SAC JMP I (SSMODE /--RETURN-- YARG, 0 /POS FUNCTION /RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z POS, CLA CLL DCA INSAV /FAKE AS STRING CALL TO STRING 0 JMS I (STFIND /FIND Y$ TAD STRCNT /# OF CHARS IN Y$ SNA CLA /IS Y$ THE NULL STRING? JMP ONERET /YES-RETURN 1 AS POSITION TAD SACLEN /NO-# OF CHARS IN X$ SNA CLA /IS X$ THE NULL STRING? JMP ZRORET /YES-RETURN 0 TAD ACH /NO-GET HORD OF Z SPA SNA CLA /IS Z GT 0? PA, JMS I PERROR /NO-ILLEGAL ARGUMENT JMS I PUNSFIX /FIX Z DCA POSITN /USE IT AS POSITION TO START SEARCH TAD POSITN STL TAD SACLEN /COMPARE POSITION TO MAXIMUM LENGTH OF STRING SNL SZA CLA JMP PA /Z IS PAST END OF STRING-ERROR POSSET, TAD STRCNT CMA TAD POSITN /GET POSITION NOW CHECKING+SIZE IF Y$ TAD SACLEN /COMPARE AGAINST LENGTH OF STRING SMA SZA CLA /ANY MORE TO COME? JMP ZRORET /NO-SEARCH FAILS JMS I (BYTSET /SETUP BYTE LOAD ROUTINE TAD POSITN /SEARCH START POSITION IN X$ TAD (SAC-2 /ADD TO BASE OF SAC DCA SACXR TAD STRCNT /# OF CHARS IN Y$ DCA AC2 /COUNTER SRCLP, JMS I (LDB CIA CDF 10 TAD I SACXR /COMPARE CHARS CDF SNA CLA /DO THEY MATCH? JMP SCONTU /YES-CONTINUE MATCH TO NEXT CHAR IN X$ AND Y$ ISZ POSITN /BUMP POSITION TO BE CHECKED JMP POSSET /ITERATE SCONTU, ISZ AC2 /MORE CHARS IN Y$? JMP SRCLP /YES, ITERATE TAD POSITN /NO FOUND A MATCH JMP I (FLOATS ZRORET, JMS I PFACCLR /SEARCH FAILS-RETURN 0 JMP I PILOOP ONERET, CLA IAC JMP I (FLOATS /RETURN 1 POSITN, 0 PAGE /STRING ARITHMETIC INTERFACE /SETS UP BUFFERS AND CALLS STRING PACKAGE LOCATED IN FIELD 1 /STRING ARITH EXIT ROUTINE SEXIT, DCA SACLEN /STORE SAC LENGTH PASSED IN AC JMP SRETN /JMP TO FINISH OFF XSARITH,JMS SACTOA /MOVE SAC TO ABUF FIRST, TERMINATED BY A NULL TAD (BBUF-1 /MOVE ARG TO B BUFFER DCA XR1 TAD STRCNT SNA CLA JMP SGO SARMOV, JMS I (LDB CDF 10 DCA I XR1 CDF ISZ STRCNT JMP SARMOV SGO, CDF 10 DCA I XR1 / CDF JMS I (PWFECH /GET SUB-OPCODE TAD (JMP I SARVEC /CREATE JMP INLINE DCA .+2 CIF CDF 10 /LINKAGE TO FIELD 1 HLT /GETS DISPATCH TO ROUTINE /VECTOR OF STRING ARITH ENTRY POINTS SARVEC, SADD SSUB PSISUB, SISUB SMUL SDIV SIDIV /INT$(A$) FUNCTION FIXPT, JMS SACTOA /COPY ARG TO A BUFFER CIF CDF 10 JMP I (SINTEGR /JMP TO INT FUNCTION /STRING UNARY MINUS STRNEG, JMS SACTOA /COPY ARG TO THE A BUFFER CIF CDF 10 DCA I (BBUF /PASS NULL STRING IN B BUFFER JMP I PSISUB /JMP TO SUBTRACT ROUTINE /PRINT USING INIT AND OUTPUT XPUINI, TAD (FMTBUF-ABUF JMS SACTOA /MOVE SAC TO PATTERN REGISTER CDF 10 /NOW SET THE INIT FLAG STL RTL DCA I (UINIT JMP I PILOOP /RETURN TO ILOOP (RESETS DF) XPUEXE, TAD (BBUF-ABUF /LOAD B BUFFER WITH OUTPUT NUMBER STRING JMS SACTOA CIF CDF 10 TAD I (UINIT /ADVANCE STATE OF INIT FLAG CLL RAR DCA I (UINIT /THIS CLEARS INIT STATE ON SECOND OUTPUT JMP I (USING /JMP TO PRINT USING CODE NOW SRETN, TAD PSACM1 /RETURN HERE FOR FINAL STRING PROCESSING DCA SACXR /SETUP TO COPY RESULT INTO SAC TAD (SBUF-1 DCA XR1 TAD SACLEN SNA JMP I (SSMODE /DONE IF NULL STRING /SET INTERPRETER TO STRING MODE (IN CASE OF FUNCTION CALL) DCA STRCNT CDF 10 STRLP, TAD I XR1 DCA I SACXR ISZ STRCNT JMP STRLP / CDF JMP I (SSMODE /DONE, SET TO SMODE SACTOA, 0 TAD (ABUF-1 /SET POINTER TO STRING BUFFER IN FIELD 1 DCA XR1 /AC CONTAINS OFFSET IF CALL TO STORE IN B BUFFER TAD PSACM1 /INIT SACXR INCASE IF PRINT USING CALL DCA SACXR /(NORMAL STRING CALLS INIT IT FOR US) CDF 10 TAD SACLEN SNA CLA JMP SACNUL /JUST OUTPUT ZERO IF NULL STRING TAD I SACXR /GET A BYTE DCA I XR1 /MOVE CHAR TO BUFFER ISZ SACLEN JMP .-3 /ITERATE SACNUL, DCA I XR1 /STORE THE TERMINATING NULL CDF JMP I SACTOA /DONE PAGE RELOC *OVERLAY VERSON^100+SUBVEF+6000 /LINE NUMBER TRACE FEATURE /PRINT MESSAGE OF FORM %NNNNN% ON CONSOLE WHEN /NEW LINE ENCOUNTERED TPRINT, TAD (45 /PRINT LEADING % JMS I PPCH JMS PRTLNO /NOW PRINT BCD LINE NUMBER TAD O40 JMS I PPCH /PRINT A TRAILING SPACE TAD (45 /PRINT A TRAILING % JMS I PPCH JMS I (PCRLF /NOW A CR,LF JMP I PILOOP /--RETURN-- /PRINT 5 DIGIT BCD LINE NUMBER, SUPPRESSING LEADING ZEROES PRTLNO, 0 TAD O40 /FIRST PRINT LEADING SPACE JMS I PPCH TAD (SNA /INIT LZ SWITCH DCA MAKSWT TAD LINEHI /HANDLE DIGIT 1 RTR RTR JMS MAKED TAD LINEHI /DIGIT 2 JMS MAKED TAD LINELO /DIGIT 3 RTL RTL RAL JMS MAKED TAD LINELO /DIGIT 4 RTR RTR JMS MAKED TAD LINELO /ALWAYS PRINT LAST DIGIT AND O17 TAD (60 JMS I PPCH JMP I PRTLNO /DONE /ROUTINE TO UNPACK BCD DIGITS MAKED, 0 AND O17 /ISOLATE DIGIT MAKSWT, HLT /SKP/SNA SWITCH JMP I MAKED /RETURN IF SUPPRESSED TAD (60 /MAKE 7BIT JMS I PPCH /PRINT IT TAD (SKP /NOW RESET SWITCH DCA MAKSWT JMP I MAKED /DONE /ERROR MESSAGE PRINTER ERRORR, 0 TAD (ETAB /SET POINTER TO ERROR MESSAGE TABLE DCA EPTR ESRCH, TAD I EPTR /SEARCH FOR NEXT MESSAGE ISZ EPTR DCA EADDR /TENTATIVELY SET POINTER TO MESSAGE TAD I EPTR /GET COMPARISON ADDR ISZ EPTR SZA /FORCE EQUAL IF END OF LIST TAD I PERROR SZA CLA JMP ESRCH /TRY AGAIN IF NO MATCH TAD EPTR /NOW TEST IF FATAL ERROR TAD (-EFATAL SPA SNA CLA JMP NONFTL /JMP IF NO DCA ERRRTN /NOP OUT RETURN IF FATAL ERROR DCA I (XFLAG /FORCE PRINTING ENABLE DCA I (CTCNOP /DISABLE ^C, ^Q, AND ^S RECOGNITION TSF /FORCE TTY FLAG TO BE UP TLS TAD (77-45 /PRECEDE FATAL ERRORS WITH ? NONFTL, TAD (45 /PRECEDE WARNINGS WITH % DCA ETXTOV /SAVE THE CHAR TAD I (TTYF+IOTPOS-IOTHDR /SEE IF CONSOLE AT LEFT MARGIN SZA CLA JMS I (PCRLF /PRINT CRLF IF NOT TAD ETXTOV /NOW PRINT THE PREFIX CHAR JMS I PPCH TAD EADDR /ISOLATE BLOCK OFFSET AND O7400 CLL RTL RTL RAL /SHIFT TO AC8-11 TAD I (OVADD /ADD TO BASE OF THIS OVERLAY TAD (2 /ADD OFFSET TO MESSAGES WITHIN OVERLAY DCA ETXTOV /STORE INLINE JMS I (7607 /READ TEXT IN 0200 /1 BLOCK TXTHOL /TO HERE ETXTOV, 0 /FROM HERE HLT /UGH! TAD EADDR /NOW SETUP ABSOLUTE TEXT ADDR AND O377 TAD (TXTHOL DCA EADDR GOTMSG, JMS I (SCRIBE /WRITE IT NOW EADDR, 0 JMS I (SCRIBE /PRINT "AT LINE" ATLINE JMS PRTLNO /PRINT OFFENDING LINE NUMBER JMS I (PCRLF /FINISH OFF WITH CR,LF ERRRTN, JMP I ERRORR /RETURN FSTOPN, TAD (140 /FAKE A CALL TO INTERPRETER EXIT FUNCTION DCA INSAV JMP I (FUNC5I EPTR, 0 PAGE /ERROR MESSAGE MAPPING TABLE /CONTAINS RELATIVE CORE ADDR OF TEXT, FOLLOWED BY -CALLING ADDR /TERMINATED BY ZERO TO FORCE UNKNOWN ERROR MESSAGE IF NO MATCH /ERRORS PRECEEDING TAG "EFATAL" ARE WARNINGS ONLY ETAB, REXXX -RE-1 WEXXX -WE-1 DVXXX -DV-1 STXXX -ST-1 DIXXX -DI-1 DPXXX -DP-1 DMXXX -DM-1 OVSXX -OVS-1 DVSXX -DVS-1 ST1XX -ST1-1 SHXXX -SH-1 BRXXX -BR-1 ENXXX -EN-1 INXXX -IN-1 ONXXX -ON-1 ISXXX -IS-1 IFXXX -IF-1 EFATAL, FBXXX -FB-1 DFXXX -DF-1 GRXXX -GR-1 VRXXX -VR-1 SUXXX -SU-1 DEXXX -DE-1 OEXXX -OE-1 FMXXX -FM-1 FOXXX -FO-1 FO2XX -FO2-1 FNXXX -FN-1 SCXXX -SC-1 FIXXX -FI-1 DAXXX -DA-1 GSXXX -GS-1 SRXXX -SR-1 SWXXX -SW-1 PAXXX -PA-1 FCXXX -FC-1 CIXXX -CI-1 CLXXX -CL-1 DOXXX -DO-1 FEXXX -FE-1 BOXXX -BO-1 SLXXX -SL-1 O0XXX -O0-1 EMXXX -EM-1 IAXXX -IA-1 BCXXX -BC-1 CNXXX -CN-1 CFXXX -CF-1 BFXXX -BF-1 SZXXX -SZ-1 CCXXX -CC-1 NCXXX -NC-1 LMXXX -LM-1 QQXXX 0 ATLINE, TEXT / AT ^LINE@/ PAGE /ROUTINE TO EXPAND AND PRINT 6BIT ENCODED MESSAGES /CALL+1 POINTS TO MESSAGE, TERMINATED BY ZERO WORD SCRIBE, 0 TAD I SCRIBE /PICK UP ADDR OF MESSAGE DCA MSGPTR /POINT AT IT ISZ SCRIBE TAD (SNXTWD /INIT UNPACK COROUTINE DCA SPCH /FALL INTO UPPER CASE PRINT FOR FIRST CHAR GOTCRT, JMS SGCH /IF UPARROW SEEN, PRINT AS UPPER CASE SPRTCH, JMS I PPCH /PRINT IT SNXTCH, JMS SGCH /GET NEXT CHAR TAD (-136 /SEE IF UPARROW (CARET) SNA /SKP IF NO JMP GOTCRT /ELSE HANDLE SINGLE CAPITAL LETTER TAD (136-133 /SEE IF OPEN BRACKET SNA JMP GOTBRK /YES, HANDLE CAPITAL WORD CLL /SEE IF ALPHABETIC TAD (32 SZL /SKP IF NOT TAD O40 /ELSE CONVERT TO LOWER CASE TAD (133-32 /RESTORE CHAR JMP SPRTCH /GO PRINT IT GOTBRK, JMS SGCH /GET NEXT CHAR OF WORD TAD (-135 /SEE IF CLOSE BRACKET SNA JMP SNXTCH /YES, DO REST OF MESSAGE TAD (135 /NO, PRINT UPPER CASE JMS I PPCH JMP GOTBRK /ITERATE /CODE TO UNPACK 6BIT TEXT SGCH, 0 JMP I SPCH SPCH, .-1 AND O77 /IGNORE NULLS SNA JMP I SPCH /JMP IF NULL TAD O40 /ELSE UNPACK TO 7BIT AND O77 TAD O40 JMP I SGCH /RETURN TO CALLER SNXTWD, TAD I MSGPTR /LOOK AT NEXT WORD SNA /SKP IF NOT END OF MESSAGE JMP I SCRIBE /ELSE RETURN CLL RTR /SHIFT RIGHT RTR RTR JMS SPCH /RETURN CHAR TAD I MSGPTR /GET WORD AGAIN ISZ MSGPTR /BUMP POINTER JMS SPCH /SEND OUT JMP SNXTWD /LOOP MSGPTR, 0 /PRINT CR,LF PCRLF, 0 TAD O15 /CR JMS I PPCH TAD (12 /LF JMS I PPCH DCA I (TTYF+IOTPOS-IOTHDR /ZERO THE CONSOLE COLUMN COUNT NOW JMP I PCRLF /RETURN PAGE TXTHOL= . /AREA IN THIS OVERLAY WHERE TEXT IS READ IN /ROUTINE TO PRINT VERSION AND FREE SPACE MESSAGES FREESP, 0 JMS I PPSWAP /SWAP OUT OS/8 CDF 10 /PICK UP CD SWITCHES TAD I (CDOPT4 /GET CD OPTION BITS [MNO PQR STU VWX] CDF DCA ACH /SAVE THEM JMS I PPSWAP /KICK OUT OS/8 TAD ACH /SEE IF /V SET AND (4 SNA CLA /SKP IF YES JMP NOVER TAD I (VERLOC /PICK UP VERSION AND SUBVERSION DCA VERNP /PACKED NUMBER AND PATCH LEVEL JMS I (SCRIBE /PRINT IT VERMSG JMS I (PCRLF /FOLLOWED BY CRLF NOVER, TAD ACH /SEE IF /S SET AND (40 SNA CLA /SKP IF YES JMP I PILOOP /RETURN TO INTERPRETER IF NO TAD CDFPS /GET FIELD BITS OF CODE CLL RTR RTR AND (3 DCA AC0 TAD PSSTRT /COMBINE WITH ADDR AND (7774 TAD AC0 RTR RAR /SHIFT FIELD BITS TO AC0-2 XX= BUFAREA%10 TAD (-XX-1000 /SUBTRACT SPACE TAKEN BY BRTS THRU FIELD 1 DCA AC0 /SAVE IT TAD AC0 CLL RTL /GET INTEGER BITS FOR HOW MANY K RTL RTL AND (37 /MASK THEM DCA AC1 /SAVE THEM DCA AC2 DLP1, TAD AC1 /CONVERT TO DECIMAL TAD (-12 SPA JMP GOTQUO DCA AC1 ISZ AC2 JMP DLP1 GOTQUO, CLA TAD AC2 /GET TENS DIGIT SZA /SKP IF ZERO JMS PUTDG /OR PUT IT OUT TAD AC1 /DO UNITS JMS PUTDG TAD AC0 /GET FIRST FRACTION DIGIT AND (177 DCA AC0 TAD AC0 CLL RTR TAD AC0 CLL RTR CLL RTR AND O17 SNA /SKP IF NONZERO FRACTION JMP NOFRAC DCA AC0 TAD (56 /PRINT . JMS I (PCH TAD AC0 JMS PUTDG NOFRAC, JMS I (SCRIBE /PRINT "K FREE SPACE" SPCLFT JMS I (PCRLF JMP I PILOOP /RETURN TO INTERPRETER PUTDG, 0 TAD (60 JMS I (PCH JMP I PUTDG VERMSG, TEXT /B[RTS V]ERSION [@/ VERNP= .-1 0 SPCLFT, TEXT /K ^FREE ^SPACE@/ PAGE /ERROR MESSAGE TEXT STATEMENTS /A ^ FLAGS THE NEXT CHAR AS UPPER CASE /[WORD] DEFINES UPPER CASE WORD /ALL MESSAGES MUST BE FOLLOWED BY ONE AND ONLY ONE ZERO WORD *4400 RELOC 0 /ASSIGN RELATIVE ADDRESSES EPART1, FBXXX, TEXT /ATTEMPT TO [OPEN] AN ALREADY ^OPEN ^FILE@/ GRXXX, TEXT /R[ETURN] WITHOUT A [GOSUB]@/ VRXXX, TEXT /ATTEMPT TO [READ] ^VARIABLE ^LENGTH ^FILE@/ SUXXX, TEXT /SUBSCRIPT ^ERROR@/ DEXXX, TEXT /DEVICE ^DRIVER ^ERROR@/ OEXXX, TEXT /DRIVER ^ERROR WHILE ^OVERLAYING@/ FMXXX, TEXT /ATTEMPT TO ^FIX ^NEGATIVE ^NUMBER@/ FOXXX, TEXT /ATTEMPT TO ^FIX ^NUMBER > 4095@/ FNXXX, TEXT /ILLEGAL ^FILE #@/ SCXXX, TEXT /S[AC O]VERFLOW ON [CONCATENATE@/ FIXXX, TEXT /ATTEMPT TO USE ^UNOPENED ^FILE@/ DAXXX, TEXT /ATTEMPT TO [READ] ^PAST END OF [DATA] ^LIST@/ GSXXX, TEXT /TOO MANY NESTED [GOSUB]S OR ^FUNCTION ^CALLS@/ SRXXX, TEXT /ATTEMPT TO [READ] ^STRING FROM ^NUMERIC ^FILE@/ PAGE EPART2, SWXXX, TEXT /ATTEMPT TO [WRITE] ^STRING INTO ^NUMERIC ^FILE@/ PAXXX, TEXT /ILLEGAL ARG IN [POS]@/ FCXXX, TEXT 'O^S/8 ^ERROR WHILE [CLOSING] ^TENTATIVE ^FILE@' CIXXX, TEXT /I[NQUIRE] ^FAILURE IN [CHAIN]@/ CLXXX, TEXT /L[OOKUP] ^FAILURE IN [CHAIN]@/ INXXX, TEXT /I[NQUIRE] ^FAILURE IN [OPEN]@/ DOXXX, TEXT /NO MORE ^ROOM FOR ^DRIVERS@/ FEXXX, TEXT /F[ETCH] ^ERROR IN [OPEN]@/ BOXXX, TEXT /NO MORE ^FILE ^BUFFERS ^AVAILABLE@/ ENXXX, TEXT /L[OOKUP] OR [ENTER E]RROR IN [OPEN]@/ IFXXX, TEXT /ILLEGAL [DEV:FILENAME] ^SPECIFICATION@/ SLXXX, TEXT /STRING ^TOO ^LONG OR ^UNDEFINED@/ O0XXX, TEXT /NUMERIC OR [INPUT] ^OVERFLOW@/ EMXXX, TEXT /ATTEMPT TO RAISE ^NEGATIVE ^NUMBER TO A ^REAL ^POWER@/ PAGE EPART3, CCXXX, TEXT /EXECUTION ^ABORTED@/ IAXXX, TEXT /ILLEGAL ^ARGUMENT IN ^USER ^FUNCTION@/ BCXXX, TEXT /C[HAIN A]TTEMPTED WITH [BCOMP.SV] OR [BLOAD.SV M]ISSING@/ REXXX, TEXT /ATTEMPT TO [READ] ^PAST [EOF]@/ WEXXX, TEXT /ATTEMPT TO [WRITE] ^PAST [EOF]@/ DVXXX, TEXT /DIVISION BY 0@/ STXXX, TEXT /STRING ^TRUNCATION ON [INPUT]@/ DIXXX, TEXT /ILLEGAL ^CHAR IN ^NUMERIC ^STRING@/ DPXXX, TEXT /MORE THAN 1 ^DECIMAL ^POINT ^ENCOUNTERED@/ DMXXX, TEXT /ILLEGAL ^MINUS ^SIGN@/ OVSXX, TEXT /STRING ^ARITHMETIC ^OVERFLOW ^ERROR@/ DVSXX, TEXT /DIVIDE BY ^ZERO IN ^STRING ^ARITHMETIC@/ QQXXX, TEXT /??? [UNKNOWN ERROR] ???@/ PAGE PART4, CNXXX, TEXT /ATTEMPT TO [CHAIN] TO [.SV F]ILE NOT ON [SYS:@/ BRXXX, TEXT /BAD ^RECORD ^NUMBER IN [RANDOM ACCESS F]ILE@/ BFXXX, TEXT /ERROR IN [DEFINE RECORD S]TATEMENT@/ ST1XX, TEXT /STRING ^TRUNCATED DURING [RECORD READ]@/ SHXXX, TEXT /STRING ^TRUNCATED DURING [RECORD WRITE]@/ SZXXX, TEXT /ILLEGAL ^RECORD ^SIZE@/ CFXXX, TEXT /BAD [DEV:FILE.EX F]ORMAT IN [CHAIN S]TATEMENT@/ NCXXX, TEXT /BAD ^COMMAND ^LENGTH OR [CCL.SV] NOT FOUND@/ ONXXX, TEXT /O[N S]TATEMENT OUT OF RANGE@/ ISXXX, TEXT /IMAGINARY ^SQUARE ^ROOT@/ LMXXX, TEXT /ILLEGAL ARGUMENT IN [LOG] FUNCTION@/ DFXXX, TEXT /NO MORE ROOM FOR ^RECORD [DEFINES@/ FO2XX, TEXT /ATTEMPT TO ^FIX ^NUMBER > 2**23-1@/ PAGE RELOC FIELD 3 /LOAD FILES HERE ////////////////////////////////////////////////// ////////////////////////////////////////////////// ///////// OVERLAY 3-FILE MANIPULATING //////////// ///////// FUNCTIONS //////////// ////////////////////////////////////////////////// ////////////////////////////////////////////////// *OVERLAY VERSON^100+SUBVFF+6000 /VERSION WORD FOR FILES OVERLAY OVDISP, JMS I (FBITGT /GET FUNCTION TYPE TAD JMPFF /BUILD JMP INLINE DCA .+1 HLT JMPFF, JMP I .+1 /CALL FOR FILE MANIPULATING FUNCTIONS /JUMP TABLE FOR FILE FUNCTIONS CHAIN /FUNCTION BITS= 000 CLOSE / 020 OPENAF / 040 OPENAV / 060 OPENNF / 100 OPENNV / 120 FSTOP /INT. EXIT 140 CCL / 160 /CCL(C$) FUNCTION - PASS COMMAND STRING TO CCL CCL, TAD SACLEN /TEST COMMAND STRING LENGTH SZA TAD (CCLMAX SPA SNA CLA /SKP IF IN RANGE (ALLOWING TERMINATING NULL) JMP NC /ERROR JMS I PPSWAP /GET OS/8 JMS MOVCMD /SHUFFLE COMMAND TO SAFE PLACE IN FIELD 1 SAC-1 /FROM SAC BUFAREA-1 /TO BUFFER AREA ABOVE USR CIF 10 JMS I O7700 /LOCK USR IN 10 CLA IAC /LOOK UP "SYS:CCL.SV" CIF 10 JMS I O200 2 /LOOKUP CCLBLK, CCLNAM 0 NC, JMS I PERROR /FATAL ERROR IF NO FIND JMS I (PSWAP2 /DO THE ONCE ONLY EXIT CODE NOW /(THE CCL COMMAND WILL WIPE THE SAVED BATCH STATE) TAD I (JSW /KEEP ONLY THE BATCH SAVED STATE AND (400 TAD (2001 /SET JSW FOR USR IN CORE DCA I (JSW TAD CCLBLK /COPY BLOCK NUMBER INLINE DCA CHNBLK JMS MOVCMD /NOW MOVE THE COMMAND TO CD AREA BUFAREA-1 /FROM HERE 7577 /TO HERE CIF 10 /DO A RESET TO DELETE ANY TENTATIVE FILES JMS I O200 13 /RESET CIF 10 /NOW DO THE CHAIN JMS I O200 6 /CHAIN CHNBLK, 0 MOVCMD, 0 TAD I MOVCMD /GET SOURCE PTR ISZ MOVCMD DCA SACXR TAD I MOVCMD /GET TARGET PTR ISZ MOVCMD DCA XR1 TAD SACLEN /SET COUNTER DCA AC0 CDF 10 /DATA IN FIELD 1 CCLMOV, TAD I SACXR /GET A BYTE AND O177 /MASK TAD O200 /SET PARITY BIT DCA I XR1 /STORE IT ISZ AC0 JMP CCLMOV DCA I XR1 /STORE TERMINATING NULL CDF JMP I MOVCMD CCLNAM, FILENAME CCL.SV PAGE /FILE CLOSING ROUTINE CLOSE, TAD I IOTHND /SEE IF FILE IS IDLE SZA CLA /SKP IF YES, CLOSE IS A NOP TAD ENTNO /GET FILE # SNA CLA /IS IT TTY? JMP I PILOOP /YES-DON'T DO ANYTHING TAD I IOTRSZ /NO ^Z IF RANDOM ACCESS FILE (ALREADY HANDLED) SNA CLA JMS I PFTYPE /IS FILE NUMERIC? JMP NOCZ /YES-DON'T OUTPUT ^Z JMS I (FOTYPE /NO-IS FILE VARIABLE LENGTH? JMP NOCZ /NO-DON'T OUTPUT ^Z TAD (32 /YES JMS I PPUTCH /WRITE A ^Z IN FILE NOCZ, JMS I (WRBLK /WRITE LAST BLOCK IF IT HAS CHANGED JMS I (RTNDEF /RETURN ANY CURRENT RECORD DESCRIPTORS TO FREELIST NOW JMS I PPSWAP /RESTORE 17600 JMS I (FOTYPE /IS FILE FIXED LENGTH? JMP CLOSED /YES-NO NEED TO CLOSE THE FILE TAD I IOTLEN /NO-GET FILE LENGTH DCA CLENG /PUT IN CLOSE CALL TAD IOTFIL DCA FNAP /POINTER TO FILE NAME TAD I IOTHDR CLL RTL RTL RAL /GET DEVICE NUMBER INTO BITS 8-11 AND O17 /ISOLATE IT CIF 10 JMS I O7700 /CALL USR 4 /CLOSE FNAP, 0 /POINTER TO FILE NAME CLENG, 0 FC, JMS I PERROR /FILE CLOSING ERROR /FALL INTO BUFFER/HANDLER RELEASE ROUTINE CLOSED, STA /RETURN THIS BUFFER TO THE POOL TAD BUFSTK DCA BUFSTK TAD I IOTBUF DCA I BUFSTK /RELEASE HANDLER (MESSY) TAD I IOTHND /SEE IF CORESIDENT WITH SYS: TAD O200 SMA CLA JMP CRETN /JMP IF YES TAD (-MAXFIL /SEE IF ANY OTHER FILES USING DEVICE CORESIDENT DCA AC2 /WITH THIS FILE TAD (MAXFIL^IOTSIZ+TTYF+IOTHND-IOTHDR DCA AC0 /POINT AT HANDLER ENTRY FOR LAST FILE CHECKL, TAD AC2 /-# OF FILE WERE CHECKING TAD ENTNO /COMPARE TO CURRENT NUMBER SNA CLA /IS IT THIS ONE? JMP PSTCHK /YES-DON'T CHECK DRIVER TAD I AC0 /GET HANDLER ENTRY POINT FOR THIS FILE AND (7600 /ISOLATE PAGE BITS CIA /NEGATE TAD I IOTHND /COMPARE TO PAGE OF CURRENT FILE'S HANDLER AND (7600 SNA CLA /SAME DEVICE? JMP CRETN /YES-LEAVE DRIVER IN CORE PSTCHK, TAD AC0 /BUMP HANDLER EP PTR BACK TAD (-IOTSIZ DCA AC0 ISZ AC2 /ALL 4 CHECKED? JMP CHECKL /NO-CHECK THE NEXT 1 TAD I IOTHND /RETURN THE HANDLER TO THE POOL NOW TAD (-HAREA /GET PAGE OFFSET TO AC10,11 RTL RTL RTL AND (3 CMA DCA AC0 /SET SHIFT COUNT TAD I IOTHDR /SEE IF 2 PAGES BEING FREED AND O10 SNA CLA /SKP IF YES TAD (4 /ELSE JUST DO ONE BIT TAD (7763 STL RAR /SHIFT MASK DOWN ISZ AC0 JMP .-2 AND DMAP /NOW CLEAR THE BIT(S) DCA DMAP TAD (RESTBL /MARK ALL ENTRY POINTS GONZO DCA AC0 TAD I IOTHND /SAVE PAGE BITS OF HANDLER AND (7600 DCA AC2 TAD (-17 /DO 15. ENTRY POINTS DCA TEMP2 CDF 10 FREHND, TAD I AC0 /NOW MARK ENTRIES NONRESIDENT AND (7600 CIA TAD AC2 SNA CLA /SKP IF NOT CORESIDENT DCA I AC0 /ELSE CLEAR IT ISZ AC0 ISZ TEMP2 JMP FREHND CDF CRETN, DCA I IOTHND /MAKE THE FILE IDLE NOW DCA I IOTHDR /CLEAR DEVICE BITS TOO JMS I PPSWAP /REMOVE OS/8 JMP I PILOOP /RETURN TO ILOOP PAGE /CHAIN FUNCTION /INVOKES USR CHAIN OPERATION IF FILE EXTENSION IS .SV /OTHERWISE SETS UP CD AREA AND CHAINS TO BCOMP CHAIN, JMS I PPSWAP /RESTORE PG 17600 JMS I DNA2 /GET FILE NAME IN NAME AREA FROM CURRENT FILE 0201 /DEFAULT EXTENSION .BA CF, JMS I PERROR /ERROR IF ILLEGAL FILE NAME CIF 10 JMS I O7700 /CALL USR 10 /LOCK IN CORE TAD I IOTDEV DCA DNA1 /FIRST TWO CHARS OF DEV NAME TAD I IOTDEV+1 /LAST TWO CHARS DCA DNA2 CIF 10 JMS I O200 12 /INQUIRE DNA1, 0 DNA2, NAMEG CDIN, 0 CI, JMS I PERROR /ERROR TAD CDIN /GET ENTRY POINT OF DRIVER FOR CHAIN FILE SZA CLA /IS IT IN CORE? JMP DISIN /YES-NO NEED TO FETCH IT TAD DNA2 /NO-DEVICE # INTO AC CIF 10 JMS I O200 1 /FETCH HANDLER 7001 /INTO PAGE 7000 JMP CI /MAKE IT LOOK LIKE INQUIRE ERROR DISIN, TAD IOTFIL DCA STB /POINTER TO FILE NAME TAD DNA2 /GET DEVICE # CIF 10 JMS I O200 2 /LOOKUP STB, 0 /POINTER TO FILE NAME FLN, 0 CL, JMS I PERROR /LOOKUP ERROR TAD IOTFIL /POINT AT FILENAME EXTENSION TAD (3 DCA TEMP2 TAD I TEMP2 /SEE IF .SV EXTENSION TAD (-2326 SNA CLA JMP CICHAIN /JMP IF YES, DO USR CHAIN CDF 10 /ELSE TEST IF BCOMP AND BLOAD ARE BOTH ACCOUNTED FOR TAD I (INFO+2 /LOOK AT BLOAD BLOCK SZA CLA /FORCE ERROR IF NOT THERE TAD I (INFO+1 /LOOK AT BCOMP BLOCK SNA BC, JMS I PERROR /TAKE ERROR EXIT IF NOT BOTH THERE DCA CBLK /ALL SET, STORE BCOMP BLOCK INLINE TAD STB /GET STARTING BLOCK DCA I (INFO+14 /STARTING BLOCK IN CD AREA TAD FLN /FILE LENGTH CLL RTL RTL AND (7760 /PUT IN BITS 0-7 TAD DNA2 /COMBINE WITH DEVICE # DCA I (INFO+13 /PUT IN CD AREA TAD (40 /SET /G SWITCH FOR BLOAD TO RUN PROGRAM AFTER COMPILE DCA I (CDOPT3 /IN CD SWITHCES [ABC DEF GHI JKL] TAD CDFIO /PASS SIZE OF SYSTEM THROUGH THE = OPTION TO BCOMP CLL RTR RAR AND (7 DCA I (CDOPT6 /THIS PRESERVES BATCH IF POSSIBLE CDF JMS I (PSWAP2 /NOW EXEC DESTRUCTIVE EXIT CODE JMS I (7607 /READ FROM SYS: BCSIZ1+10 /4 BLOCKS TO FIELD 1 BCLOD1 /TO HERE CBLK, 0 /FROM HERE HLT /CRASH SYSTEM IF SYS FAILED CIF CDF 10 /NOW JMP INTO FIELD 1 JMP I (CCHAIN CICHAIN,STA /TEST IF OUR .SV FILE IS ON SYS: TAD DNA2 SZA CLA /SKP IF OK CN, JMS I PERROR /ERROR ABORT: CAN'T CHAIN OUTSIDE SYS: JMS I (PSWAP2 /NOW EXEC ONCE ONLY CLEAN UP ROUTINE TAD (MAGIC /SET MAGIC NUMBER INTO CD = OPTION TO BYPASS CDF 10 /INITIALIZATION LOOKUPS DCA I (7642 /FOR CHAINS TO PRE COMPILED PROGRAMS CDF TAD STB /COPY STARTING BLOCK INLINE DCA CHNSTB CIF 10 /NOW DO A RESET AND DELETE TENTATIVE FILES JMS I O200 13 /RESET CIF 10 /FLAG TENTATIVE FILE CLEANUP JMS I O200 6 /NOW DO THE CHAIN EXIT CHNSTB, HLT /FINAL ENTER/LOOKUP PROCESSING CLEANP, DCA I IOTPOS /ZERO COLUMN POINTER CMA /-1 TAD I IOTLOC /STARTING BLOCK-1 DCA I IOTBLK /CURRENT BLOCK #=STARTING BLOCK-1 TAD I IOTBUF DCA I IOTPTR /READ/WRITE POINTER AT BEGINNING OF BUFFER CIF 10 JMS I O200 /CALL TO USR 11 /USROUT JMS I PPSWAP /GET RID OF 17600 JMS I (BLZERO JMS I (NEXREC /DO A NEXREC TO READ IN FIRST FILE BLOCK JMP I PILOOP /DONE, LET'S GET THE HELL OUT OF HERE PAGE /FILE OPENING ROUTINE OPENAV, TAD (4 /ALPHANUMERIC,VARIABLE LENGTH OPENAF, IAC /ALPHANUMERIC,FIXED LENGTH JMP OPENNF OPENNV, TAD (4 /NUMERIC,VARIABLE LENGTH OPENNF, DCA AC0 /SAVE NEW HEADER WORD TAD ENTNO /IS FILE TTY? SNA CLA JMP I PILOOP /YES-DON'T DO ANYTHING TAD AC0 /IF NOT CONSOLE, SET HEADER WORD DCA I IOTHDR DCA I IOTRSZ /ASSUME NON RANDOM ACCESS FILE TAD I IOTHND /GET HANDLER ENTRY SZA CLA /IS FILE IDLE? FB, JMS I PERROR /ATTEMPT TO OPEN FILE ALREADY OPEN JMS I PPSWAP /RESTORE 17600 JMS I (NAMEG /GET FILE DEVICE NAME AND FILE NAME INTO WORDS 7-14 FROM SAC 0401 /DEFAULT EXTENSION IS .DA JMP IF /GIVE ERROR IF BAD FORMAT NAME CIF 10 JMS I O7700 /CALL TO USR 10 /LOCK USR IN CORE TAD I IOTDEV DCA DEVNA1 /DEVICE NAME INTO INQUIRE CALL TAD I IOTDEV+1 DCA DEVNA2 CIF 10 JMS I O200 /CALL TO USR 12 /INQUIRE DEVNA1, 0 /DEVICE NAME DEVNA2, 0 ENTRYN, 0 /ENTRY POINT JMP INERR /INQUIRE ERROR, GO RECOVER AND WARN USER TAD DEVNA2 /GET DEVICE # CLL RAR RTR /PUT INTO BITS 0-3 RTR TAD I IOTHDR DCA I IOTHDR /STORE IN HEADER WORD CDF 10 /GET INTO USR FIELD STA TAD DEVNA2 TAD I (USRDHT /INDEX INTO USR DEVICE HANDLER TABLE DCA AC0 TAD I AC0 /LOOK AT OUR DEVICE CDF CLL RAL SZL CLA TAD (2 /LOOK FOR 2 CONSECUTIVE PAGES IF BIG HANDLER TAD (4 DCA AC0 /SET INITIAL PAGE MASK IN CASE WE LOOK FOR SPACE SZL /STORE 2 PAGE BIT IN HEADER FOR SUBSEQUENT TAD O10 /RELEASE OF HANDLER PAGES TAD I IOTHDR DCA I IOTHDR TAD ENTRYN /GET DRIVER ADDRESS SZA /IS IT IN CORE? JMP DRIVRN /YES, NO NEED TO FETCH IT RAL /GET 2 PAGE ALLOWANCE BIT TO AC11 TAD (HAREA /POINT AT HANDLER AREA HSRCH, DCA FETPAG /SEARCH FOR A SLOT TAD AC0 AND DMAP /BITS OFF INDICATE AVIALABLE CORE SNA CLA JMP GOTPAG /JMP IF GOT IT TAD AC0 /ELSE MOVE WINDOW UP CLL RAR DCA AC0 SZL /SKP IF NOT PAST END OF FREE AREA DO, JMS I PERROR /ELSE TAKE ERROR EXIT TAD FETPAG TAD O200 JMP HSRCH /TRY AGAIN GOTPAG, TAD AC0 /BUSY OUT THE PAGES WE'RE USING TAD DMAP DCA DMAP TAD DEVNA2 /FETCH THE HANDLER BY NUMBER CIF 10 JMS I O200 /CALL TO USR 1 /FETCH FETPAG, 0 /DRIVER ADDRESS FE, JMS I PERROR /FETCH ERROR TAD FETPAG /NOW STORE THE HANDLER IN IOTABLE DRIVRN, DCA I IOTHND TAD I BUFSTK /SEE IF ANY FREE BUFFERS SNA BO, JMS I PERROR /TAKE ERROR EXIT IF NONE DCA I IOTBUF /ELSE STORE IT IN IOTAB ISZ BUFSTK /BUMP FREELIST PTR UP TAD I IOTHDR /GET HEADER WORD AND (4 /TEST VARIABLE LENGTH BIT SNA CLA /SKP IF NEW FILE BEING CREATED JMP FLOOK /DO A LOOKUP IF FIXED TAD (3 JMS I (ENTLOK /ENTER DCA I IOTMAX /MAXIMUM LENGTH IN WORD 7 DCA I IOTLEN /ZERO ACTUAL LENGTH JMP I (CLEANP /FINALIZE I/O TABLE ENTRY FLOOK, AC0002 JMS I (ENTLOK /LOOKUP DCA I IOTLEN /ACTUAL LENGTH TAD I IOTLEN DCA I IOTMAX /ALSO EQUALS MAXIMUM LENGTH JMP I (CLEANP /FINISH OFF INERR, CIF 10 JMS I O200 /DO A USROUT FIRST 11 IN, JMS I PERROR /GIVE ERROR WARNING SKP /SKP TO CLEAR THIS CHANNEL AND EXIT IF, JMS I PERROR /GIVE ERROR WARNING DCA I IOTHDR /CLEAR HEADER DCA I IOTHND /CLEAR HANDLER ENTRY JMP I PILOOP /EXIT PAGE /ROUTINE TO ENTER OR LOOKUP FILE /ENTRY AC = ENTER OR LOOKUP FUNCTION NUMBER /IF NON FILE STRUCTURED OUTPUT DEVICE, SETS UP FOR BLOCK ZERO /INITIALIZATION ON FIRST OUTPUT CALL /IF NON FILE STRUCTURED INPUT DEVICE, SETS UP FOR BLOCK ZERO /INITIALIZATION DURING FINAL OPEN PROCESSING INSTEAD ENTLOK, 0 DCA FNOM /FUNCTION NUMBER IN PLACE TAD IOTFIL /POINTER TO FILE NAME DCA STARTB /INTO CALL TAD I (DEVNA2 /DEVICE NUMBER CIF 10 JMS I O200 /CALL TO USR FNOM, 0 /ENTER OR LOOKUP STARTB, 0 FLEN, 0 JMP ENTERR /ENTER/LOOKUP ERROR, TAKE RECOVERY EXIT TAD STARTB /SEE IF EITHER BLOCK OR NEGATIVE LENGTH RETURNED SNA TAD FLEN /INDICATING FILE STRUCTURED DEVICE SZA CLA JMP FILSTU /JMP IF FILE STRUCTURED DEVICE TAD (20 /NO-FILE IS READ/WRITE ONLY TAD I IOTHDR DCA I IOTHDR /SET READ/WRITE ONLY BIT AC7776 /TEST IF ENTER OR LOOKUP TAD FNOM SNA CLA /SKP IF ENTER AND SET START BLOCK TO ZERO IAC /ELSE SET TO ONE FOR DEVICE INITIALIZATION FUDGE FILSTU, TAD STARTB /GET STARTING BLOCK # OF FILE DCA I IOTLOC /PUT IN I/O TABLE TAD FLEN /FILE LENGTH CIA /MAKE FILE LENGTH POSITIVE JMP I ENTLOK /RETURN ENTERR, CIF 10 /FIRST KICK OUT USR JMS I O200 11 /USROUT EN, JMS I PERROR /GIVE ENTER/LOOKUP ERROR WARNING JMS I PPSWAP /BRING OS/8 RESIDENT IN FOR HANDLER RELEASE JMP I (CLOSED /GO FINISH OFF /SUBROUTINE PSWAP2-RESTORE OS/8 RESIDENT MONITOR PRIOR TO EXIT FROM INTERPRETERTER /THIS IS DESTRUCTIVE CODE, AND ONCE THIS ROUTINE HAS BEEN EXECUTED /THERE IS NO PLACE TO GO BUT OUT. /HAS 3 FUNCTIONS: / 1) REMOVES CTRL/C HOOKS FROM SYS DRIVER / 2) RESTORES BATCH CONTROL WORDS TO N7774-N7777 / 3) IF SYS IS 2 PAGE HANDLER, RESTORES PAGE 27600 AND FIXES CDF'S IN 07600 PSWAP2, 0 TAD (4207 DCA I BOSPT1 /REMOVE CTRL/C HOOKS TAD (6213 DCA I (7605 TAD BOSPT1 DCA I (HICORE /FUDGE POINTER IN SWAP ROUTINE /IN CASE OF 2 PAGE SYSTEM HANDLER TAD PSFLAG /GET RESIDENT STATUS FLAG SMA CLA /SKP IF ROOM ALLOCATED FOR 2 PAGE HANDLER JMP NOT2PG /JMP IF NO DCA PSFLAG /CLEAR RESIDENT STATUS FLAG TAD (CDF 20 DCA I (P2CDF /PUT CDF 20 IN SWAP ROUTINE TAD (CDF 20 DCA I (P2CDF1 JMS I PPSWAP /MOVE DOWN PAGE 27600 AC7775 /TEST MAGIC LOCATION FOR A 3 TAD I (7612 SZA CLA JMP NOT2PG /DO NOTHING IF NOT 2 PAGE HANDLER TAD (7635 /ELSE SETUP MAGIC POINTER DCA AC0 HNDLP, TAD I AC0 /NOW RANGE CHECK CONTENTS OF THIS WORD TAD (-6300 CLL TAD (70 SNL CLA /SKP IF CIF CDF N0, N.NE.0 JMP NOPAT /ELSE TRY AGAIN TAD I AC0 /GET INSTRUCTION BACK AND (7707 TAD (20 /RESTORE FIELD 2 DCA I AC0 /PUT IT BACK NOPAT, ISZ AC0 /CONTINUE TO END OF PAGE JMP HNDLP NOT2PG, TAD I (JSW /SEE IF BATCH UNTOUCHED OR NOT AND (400 SNA CLA /SKP IF YES, NO NEED TO RESTORE PARAMETER WORDS TAD I (BIPCCL /SEE IF BATCH RUNNING RAL SMA CLA JMP I PSWAP2 /RETURN NOW IF NO TAD I (BIPCCL AND (70 /ISOLATE FIELD BITS TAD CDFO DCA .+3 /CDF TO HI CORE CDF 10 TAD I BOSPT1 /GET BATCH WORD HLT DCA I BOSPT2 /BACK INTO LOFTY STATE ISZ BOSPT1 ISZ BOSPT2 JMP .-6 CDFO, CDF JMP I PSWAP2 /WE ARE FINISHED, SO RETURN BOSPT1, 7600 BOSPT2, 7774 /ROUTINE FOR INTERPRETER EXIT FSTOP, JMS I PPSWAP JMS PSWAP2 CDF 10 TAD I (EDBLK /GET BLOCK NUMBER FOR EDITOR CDF SNA /SKP IF EDITOR WAS RUN JMP I (7605 /RETURN TO KBM IF NO EDITOR JMP I (EDREAD /JMP TO HIGHER CORE TO DO READ (EDITOR OVERLAYS HERE) /PASSING BLOCK IN AC PAGE /ROUTINE TO PARSE A FILE NAME OF THE FORM "DEVN:FILENM.EX" /CALL+1 = DEFAULT EXTENSION, ASSUMES DEFAULT DEVICE DSK: /RETURN TO CALL+2 IF BAD FILE NAME SYNTAX /RETURN TO CALL+3 IF GOT GOOD NAME NAMEG, 0 TAD I NAMEG /GET DEFAULT EXT ISZ NAMEG DCA EXT /SAVE IN BUFFER STA /SET SOME SWITCHES DCA COLSWT STA DCA DOTSWT TAD PSACM1 /SET POINTER TO SAC NOW DCA SACXR TAD (0423 /NOW GET DEFAULT DEVICE - DSK: DCA DEV TAD (1300 GOTDEV, DCA DEV+1 NAMLUP, TAD (-4 /SET A WORD COUNT DCA XR1 TAD (NAME /POINT AT NAME BUFFER DCA TEMP2 DCA NAME /ZERO OUT THE NAME NOW DCA NAME+1 DCA NAME+2 GETNAM, JMS NGCH /GET A CHAR ISZ XR1 /TEST COUNT SKP JMP I NAMEG /ERROR RETURN IF PAST FIELD SIZE TAD AC0 /OK, GET CHAR AND O77 /6 BITS CLL RTL RTL RTL /SHIFT LEFT DCA I TEMP2 /PUT IN BUFFER JMS NGCH /GET ANOTHER CHAR TAD AC0 AND O77 /6 BITS TAD I TEMP2 /ADD TO PREV ONE DCA I TEMP2 ISZ TEMP2 /UP TO NEXT WORD JMP GETNAM /DO NEXT WORD GOTCOL, ISZ COLSWT /SEE IF : SEEN YET JMP I NAMEG /YES, A BADDY TAD NAME+2 /SEE IF DEV GT 4 CHARS SNA CLA TAD NAME /ANY DEV THERE SNA JMP I NAMEG /NO, NO GOOD DCA DEV /OK, STORE IT TAD NAME+1 /AND THE NEXT WORD TOO JMP GOTDEV /GET FILE NOW GOTDOT, ISZ DOTSWT /SEE IF . SEEN YET JMP I NAMEG /YES, ERROR ISZ COLSWT /DISALLOW FURTHER : TOO NOP TAD (EXT /POINT AT EXTENSION FIELD NOW DCA TEMP2 DCA EXT /ZERO OUT THE DEFAULT EXTENSION AC7776 /ALLOW ONLY ONE WORD DCA XR1 JMP GETNAM /GET THE EXTENSION ALREADY EONAM, STA TAD IOTDEV /ALL SET, MOVE THE NAME INTO CURRENT IOTABLE DCA XR1 TAD (DEV-1 DCA XR2 TAD (-6 /6 WORDS DCA AC0 TAD I XR2 /GET A PAIR OF CHARS DCA I XR1 /AND STORE THEM ISZ AC0 JMP .-3 ISZ NAMEG /TAKE SUCCESSFUL RETURN JMP I NAMEG NGCH, 0 TAD SACLEN /SEE IF ANYTHING IN SAC SNA CLA JMP EONAM /END OF NAME IF NO ISZ SACLEN NOP CDF 10 TAD I SACXR /GET A CHAR CDF DCA AC0 /SAVE IT TAD AC0 TAD (-56 /CHECK IF . SNA CLA JMP GOTDOT /JMP IF YES CLL /NOW CHECK IF ALPHANUMERIC TAD AC0 TAD (-60 SMA TAD (60-72 SNA JMP GOTCOL /JMP IF HAPPENS TO BE : SMA TAD (72-101 SMA TAD (101-133 SNL CLA /SKP IF A-Z OR 0-9 JMP I NAMEG /ELSE WORNG CHAR JMP I NGCH COLSWT, 0 DOTSWT, 0 DEV, ZBLOCK 2 NAME, ZBLOCK 3 EXT, 0 PAGE ///////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////// /////////////// END OF OVERLAY AREA ///////////////////////////////// ///////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////// $