X-Git-Url: http://gitweb.hachti.de/?a=blobdiff_plain;f=sw%2Fos8%2Fv3d%2Fsources%2Fextensions%2Fdectapes%2Fdectape1%2Fbrts.pa;fp=sw%2Fos8%2Fv3d%2Fsources%2Fextensions%2Fdectapes%2Fdectape1%2Fbrts.pa;h=05b6f3bbd7ef433b7486cc6f51ca308309d81640;hb=81e70d488b71bf995c459ca3a02c025993460ffa;hp=0000000000000000000000000000000000000000;hpb=07ec0278333ed187ac242dedcff13c56cf1b0b91;p=pdp8.git diff --git a/sw/os8/v3d/sources/extensions/dectapes/dectape1/brts.pa b/sw/os8/v3d/sources/extensions/dectapes/dectape1/brts.pa new file mode 100644 index 0000000..05b6f3b --- /dev/null +++ b/sw/os8/v3d/sources/extensions/dectapes/dectape1/brts.pa @@ -0,0 +1,5985 @@ +/OS8 BASIC RUNTIME SYSTEM, V5A +/ +/ +/ +/ +/ +/ +/ +/ +/ +/ +/ +/COPYRIGHT (C) 1972, 1973, 1974, 1975 +/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 ANT OTHER +/COPIES THEREOF, MAY NOT BR 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 +/EQUIPMRNT COROPATION. +/ +/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 4-MAY-77 REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY +/ +/ + VERSON= 5 /VERSION OF BRTS + /VERSION LOCATED AT TAG "VERLOC" AND VERLOC+1 + /VERLOC = 260+VERSON + /VERLOC+1 = 300+SUBVER (01 = A) + SUBVER= 01 /SUBVERSION OF BRTS + SUBVAF= 01 /SUBVERSION OF BASIC.AF OVERLAY + SUBVSF= 01 /SUBVERSION OF BASIC.SF OVERLAY + SUBVFF= 01 /SUBVERSION OF BASIC.FF OVERLAY + /FIRST WORD OF EACH OVERLAY CONTAINS + /60+VERSON IN LEFT HALF AND SUBVERSION OF OVERLAY + /IN RIGHT HALF. + MDATE= 7666 /CONTAINS OS/8 DATE IN FIELD 1 + BIPCCL= 7777 /CONTAINS YEAR EXTENSION BITS + SCOPWD= 7726 /WORD CONTAINING SCOPE FLAG IN 200 BIT + EDBLK= 7604 /CONTAINS BLOCK NUMBER OF EDITOR + WIDTH= 120 /WIDTH OF PRINTER + COLWID= 16 /WIDTH OF ONE PRINT COLUMN + SACLIM= 120 /DEFINE WIDTH OF STRING ACCUMULATOR + OVERLAY=3400 /ADDRESS OF START OF 5 PAGE OVERLAY BUFFER + + + +/ASSEMBLY INSTRUCTIONS +/ .R PAL8 +/ *BRTS 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 + + *6 +USECON, 0 /USE CONSTANT GENERATED BY "USE" STATEMENT +FSTOP1, FSTOPI /POINTER TO RTS EXIT ROUTINE USED + /BY ^C HOOKS IN SYSTEM HANDLER. + /IF THIS IS MOVED, BLOAD MUST BE ALTERED + + *10 +SACXR, 15 /INDEX REGISTER FOR STRING ROUTINES +XR1, VCHECK +XR2, 0 +XR3, 0 +XR4, 4 /INDEX REGISTERS +XR5, 0 +DATAXR, 0 /POINTER FOR IN-CORE DATA LIST +SPINNR, 2713 /AT RUNTIME,THIS LOCATION IS SPUN FOR RND SEED + + *20 + +/COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY +/A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR +/TO THE BRTS LOAD + +CDFIO, 6211 /* 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 (TD8E) + /BIT 1 SET IF ROM TD8E HANDLER NOT NEEDING CDF CHANGES + /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 +BMAP, 0 /MAP OF FILE BUFFERS + + *37 +/FLOATING POINT PACKAGE LOCATIONS. THE FOLLOWING 21 LOCATIONS ARE USED +/FOR VARIOUS PURPOSES BY THE FLOATING POINT PACKAGE. THOSE WITH DOUBLE +/LABELS ARE USED BY BRTS AS TEMPORARIES WHEN NOT CALLING THE PACKAGE. +/THE SECOND TAG IS THE ONE USED BY THE FLOATING POINT PACKAGE,THE FIRST +/IS USED BY BRTS. + +FF, 0 /SPECIAL MODE FLIP-FLOP +TEMP1, +AC0, 0 +AC1, 0 +TEMP3, +AC2, 0 +TM, +TEMP4, 6201 +ACX, 0 /FAC-EXPONENT +ACH, 0 /FAC-HIGH ORDER MANTISSA +ACL, 0 /FAC-MANTISSA LOW +TEMP5, +OPX, 0 +TEMP6, +OPH, 0 +TEMP7, +OPL, 0 +DSWIT, 0 /SWITCH USED BY INPUT ROUTINE +CHAR, 215 /TERMINATOR OF LAST INPUT +TEMP10, 0 /LOC NEEDED BY FPP + + DECEXP= TEMP10 + + /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 +TEMP2, 0 + + /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 + + IOTSIZ= 15 /CURRENT SIZE OF IO TABLE + + /THE FORMAT OF THE HEADER WORD IS AS FOLLOWS + /BITS USAGE + /0-3 OS/8 DEVICE NUMBER + /4-5 3 FOR 2 CHARACTER UNPACKING COUNT + /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 +IOTMAX, TTYF+7 / DEVICE / (FILE MAXIMUM LENGTH) +IOTPOS, TTYF+10 / NAME / (POSITION OF PRINT HEAD) +IOTFIL, TTYF+11 / +/ TTYF+12 / FILE +/ TTYF+13 / NAME +/ TTYF+14 / .EX + +IOTDEV= IOTMAX + *200 + + /FETCH NEXT PSEUDO WORD + +PWFECH, JMP START1 /START ONCE ONLY CODE IN TTY BUFFER + 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, VCHECK /SET DF TO FIELD OF PSEUDO-CODE + TAD I INTPC /GET NEXT WORD OF CODE + CDF 0 /SET DATA FIELD BACK TO INTERPRETER FIELD + JMP I PWFECH /RETURN +O7770, 7770 + +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 [XPRINT /CALL TO TTY DRIVER + NOP + TAD INSAV + AND [7400 /STRIP TO OPCODE BITS + CLL RTL + RTL + RAL /OPCODE NOW IN BITS 8-11 + TAD O7770 /SUBTRACT 10 + SMA /IS OPCODE <10? + JMP SCASE /CALL TO INSTRUCTION COMMON TO SMODE AND AMODE + DCA TEMP1 /YES-SAVE THE OFFSET + TAD MODESW /WHICH MODE? + SZA CLA + JMP SMODE /STRING MODE + TAD TEMP1 /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, . /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 + . /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 + + FFADD /FAC_C(A)+FAC OPCODE 0 + FFSUB /FAC_FAC-C(A) OPCODE 1 + FFMPY /FAC_FAC*C(A) OPCODE 2 + FFDIV /FAC_FAC/C(A) OPCODE 3 + FFGET /FAC_C(A) OPCODE 4 + FFPUT /C(A)_FAC OPCODE 5 + FFSUB1 /FAC_C(A)-FAC OPCODE 6 + FFDIV1 /FAC_C(A)/FAC OPCODE 7 +/ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE +SEP1, LS1I /S1_C(A) OPCODE 10 + LS2I /S2_C(A) OPCODE 11 + FJOCI /IF TRUE,PC_C(PC,PC+1) OPCODE 12 + JEOFI /IF EOF,PC_C(PC,PC+1) OPCODE 13 + LINEI /LINE NUMBER OPCODE 14 + ARRAYI /ARRAY INST OPCODE 15 + ILOOP /NOP OPCODE 16 + OPERI /OPERATE INST OPCODE 17 + + +SMODE, TAD TEMP1 /INST OFFSET + TAD JMSSI /BUILD JMP OFF STRING TABLE + DCA SDIS /PUT IN LINE + CLL /STRING SCALAR TABLE + JMS I STFINL /SET UP ARGUMENT ADDRESS +SDIS, . /CALL STRING ROUTINE REQUESTED + + +/JUMP TABLE FOR SMODE INSTRUCTIONS +/ A "/*" IN THE COMMENT MEANS THAT THAT OPCODE IS NOT USED,SO WE +/USE THE SLOT FOR REGULAR STORAGE + + SCON1 /SAC_SAC&C(A$) + SCOMP /IF SAC .NE. C(A$),PC_PC+2 + SREAD /C(A$)_DEVICE +INTPC, . /* INTERPRETER PC + SLOAD /SAC_C(A$) + SSTORE /C(A$)_SAC +STFINL, STFIND /* LINK TO STRING FINDING ROUTINE +JMSSI, JMP I .+1 /* DISPATCH JUMP FOR SMODE INSTRUCTIONS + /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 TEMP1 /SAVE + TAD TEMP1 + CLL RAL /*2 + TAD TEMP1 /PTR*3 + TAD SCSTRT /MAKE 12 BIT ADDR +SCALDF, 1000 /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER) + JMP I ARGPRE /RETURN + +/ROUTINE TO ZERO FAC + +FACCLR, -4 +L7600, 7600 /CLA + DCA ACX /ZERO EXPONENT + DCA ACL /ZERO LOW MANTISSA + DCA ACH /ZERO HIGH MANTISSA + JMP I FACCLR + + /STRING ACCUMULATOR USED BY STRING OPCODES AND FUNCTIONS + /CONTAINS ONE 6BIT CHAR PER WORD + +START1, +SAC, OSR + SZA CLA + NOP /A HLT PLACED HERE WILL ALLOW YOU TO STOP + /MACHINE BEFORE RUNTIME SYSTEM STARTS BY + /SETTING SWITCH REGISTER + TLS /SET TTY FLAG + ISZ SPINNR /SPIN RANDOM NUMBER SEED + NOP /WHILE WAITING FOR INITIALIZING TLS + TSF /FLAG UP YET? + JMP .-3 /NO + TAD CDFIO + DCA I PS1L /SET UP CDFS IN PSWAP + TAD CDFIO + DCA I PS2L + JMS I PFUDSC /SWAP 17600 IN IF NOT ALREADY IN AND SAVE SCOPE FLAG + JMS I CDFPSU + TAD SCALDF /SET PROG NOT RESTARTABLE BIT + DCA I L7746 /TELL USR TO SAVE 1000-1777 + TAD PINFO /POINTER TO INFO TABLE IN 17600 + DCA XR1 + TAD POVTAB /POINTER TO BLOCK TABLE IN OVERLAY DRIVER + DCA XR2 + TAD FACCLR /WE HAVE TO GET 4 BLOCK NUMBERS + DCA TEMP1 +OVML, CDF 10 + TAD I XR1 /GET BLOCK NUMBER FOR THIS OVERLAY FROM INFO AREA + CDF + DCA I XR2 /PUT IN TABLE IN OVERLAY DRIVER + ISZ TEMP1 /DONE? + JMP OVML /NO + JMS I [PSWAP /SWAP 17600 BACK TO HIGH CORE NOW + JMP I .+1 + START3 /CONTINUE THE INITIALIZING CODE IN INTERMEDIATE BUFFER +L7746, 7746 +PINFO, 7607 +POVTAB, ARITHA-1 +PS1L, P1CDF +PS2L, P1CDF1 +PFUDSC, FUDSC + + PAGE + +FUDSC, 0 + TAD PSFLAG /TEST WHERE 17600 IS LOCATED + SMA CLA + TAD [200 /IF NOT TD8E USE 7600 + TAD [7400 /IF TD8E USE 7400 + DCA I PHICORE /STORE FOR SWAPPER + CLA IAC + AND PSFLAG + SNA CLA /SKP IF PAGE 17600 IS ALREADY IN + JMS I [PSWAP /ELSE BRING IT IN + CDF 10 + TAD I PSCOPW + CDF + AND [200 /GET SCOPE BIT FROM RES MONITOR + DCA I PSCOPF + TAD I PHEIGHT + DCA I PHCTR /NOW INITIALIZE THE SCREEN HEIGHT COUNTER + JMP I FUDSC /RETURN +PHEIGHT,HEIGHT +PHCTR, HCTR +PSCOPW, SCOPWD +PSCOPF, SCOPFG +PHICOR, HICORE + *SAC+SACLIM+1 /ORIGIN PAST SAC+ONE GUARD CHAR + + /JUMP ON CONDITION + +FJOCI, TAD INSAV /GET JUMP INSTRUCTION + AND [17 /MASK OFF JUMP CONDITION + SNA /IS IT GOSUB? + JMP I (GOSUB /YES-PUSH PC ON STACK THEN JUMP + TAD FSTOPI /BASE TAD FOR BUILD OF TAD INSTRUCTION + DCA .+1 /PUT IN LINE + . /GET PROPER SKIP + DCA .+2 /PUT IN LINE + TAD ACH /GET HIGH ORDER FAC + . /SKIP INSTRUCTION + JMP SUCJMP /CONDITION TRUE-JUMP +JFAIL, JMS I [PWFECH /CONDITION FALSE-DON'T JUMP,BUT BUMP PC + JMP I [ILOOP /DONE + +/JUMP ON END OF FILE + +JEOFI, JMS I [IDLE /SEE IF FILE OPEN + TAD I IOTHDR /1ST WORD OF I/O TABLE ENTRY + CLL RTR /GET EOF BIT IN LINK + SNL CLA /EOF? + JMP JFAIL /NO-DON'T JUMP + /YES, FALL INTO JUMP ROUTINE + +SUCJMP, JMS I [PWFECH /GET WORD FOLLOWING JUMP INS. + DCA I INTPCL /STORE AS NEW PC + 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 + JMP I [ILOOP /NEXT INSTUCTION + +K7554, 7554 /MUST PRECEDE SKIP TABLE + +/SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS + +K7600, 7600 /UNCONDITIONAL (CLA) + SMA CLA /JPA + SZA CLA /JNA + SMA SZA CLA /JPA JNA + SPA CLA /JMA + SNA CLA /JZA + SPA SNA CLA /JMA JZA + JMP I JFORL /FORLOOP JUMP ROUTINE + +JFORL, JFOR +INTPCL, INTPC + 0000;0 /MARK BEGINNING OF GOSUB STACK +GSTCK, 6000;0 + 6000;0 + 6000;0 + 6000;0 + 6000;0 + 6000;0 + 6000;0 + 6000;0 + 6000;0 + 0 /MARK THE END OF THE GOSUB STACK + /CALL TO DEVICE DRIVER FOR FILE I/O. ASSUMES ARGS HAVE BEEN SET UP + +DRCALL, 0 + DCA DRARG1 /FUNCTION WORD INTO DRIVER CALL +CDFINL, CDF /DF TO CURRENT FIELD + TAD I IOTBUF /GET BUFFER ADDRE FROM I/O TABLE ENTRY + DCA DRARG2 /PUT IN DRIVER CALL + TAD I IOTBLK /GET BLOCK NUMBER FROM I/O TABLE + DCA DRARG3 /PUT IN DRIVER CALL + TAD I IOTHND /GET DRIVER ENTRY + DCA DRIVER /SAVE + JMS I DRIVER /CALL DRIVER +DRARG1, 0 /FUNCTION CONTROL WORD +DRARG2, 0 /BUFFER ADDRESS +DRARG3, 0 /BLOCK # + SMA CLA /DEVICE ERROR-IS IT FATAL? + JMP I DRCALL /ALLS WELL +DE, JMS I [ERROR /FATAL +DRIVER, 0 + +/CALL TO INTERPRETER EXITING ROUTINE + +FSTOPN, JMS I [XPRINT /ON NORMAL EXITS,WE MUST EMPTY RING BUFFER + JMP .-1 /FIRST +FSTOPI, TAD K7554 + DCA INSAV /FAKE A CALL TO BASIC.FF FUNCTION 6 + JMP I .+1 /CALL OVERLAY + FUNC5I + +/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 + /ARRAY INSTRUCTIONS +/ARRAY INSTRUCTIONS WORK BY FINDING THE ADDRESS OF THE ARGUMENT FROM THE ARRAY SYMBOL +/TABLE,THEN CALLING THE APPROPRIATE FLOATING POIN PACKAGE ROUTINE. + +ARRAYI, TAD MODESW /WHICH MODE? + SZA CLA + JMP SARRAY /SMODE + TAD INSAV /GET ARRAY INSTRUCTION + AND K0037 /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, . /CHANGE DF TO ARRAY TABLE FIELD (SET BY START) + 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 TEMP3 /SAVE + TAD S1 /GET SUBSCRIPT 1 + CLL CMA /SET UP 12 BIT COMPARE + TAD TEMP3 /DIMENSION 1 +1 + SNL CLA /S1 TOO BIG? +SU, JMS I [ERROR /YES-SUBSCRIPT OUT OF BOUNDS ERROR + DCA TEMP6 /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 + DCA ARJMP /SAVE DIM2+1 + TAD S2 /GET SUBSCRIPT 2 + CLL CMA /SAVE 12 BIT COMPARE + TAD ARJMP + SNL CLA /S2 BIGGER THAN DIM2? + JMP SU /YES + 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 TEMP5 /SAVE + RAL /CARRY TO BIT 11 + TAD TEMP6 /HORD OF S1+(DIM1+1)*S2 + DCA TEMP6 /SAVE + TAD TEMP5 /LORD OF S1+(DIM1+1)*S2 + CLL RAL /*2 + DCA TEMP7 /LORD OF [S1+(DIM1+1)*S2]*2 + TAD TEMP6 /HORD OF S1+(DIM1+1)*S2 + RAL /*2 + DCA TEMP3 /HORD OF [S1+(DIM1+1)*S2]*2 + CLL + TAD TEMP5 /LORD OF S1+(DIM1+1) + TAD TEMP7 /LORD OF [S1+(DIM1+1)*S2] + DCA TEMP7 /LORD OF 3*[S1+(DIM1+1)*S2] + RAL /CARRY TO BIT 11 + TAD TEMP6 /HORD OF [S1+(DIM1+1)*S2)*2 + TAD TEMP3 /HORD OF S1+(DIM1+1)*S2 + DCA TEMP6 /HORD OF 3*[S1+(DIM1+1)*S2] + CLL + TAD TEMP7 /INDEX TO ELEMENT + TAD TEMP2 /AC POINTS TO CORRECT ARRAY ELEMENT + DCA XR1 /SAVE POINTER + RAL /CARRY TO BIT 11 + TAD TEMP6 /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 + TAD INSAV /GET ARRAY INSTRUCTION AGAIN + AND [340 /MASK OFF ARRAY OPCODE + CLL RTR + RTR + RAR /SLIDE TO BITS 9-11 + TAD JMPI2 /AND USE AS INDEX INTO JUMP TABLE + DCA ARJMP /PUT JUMP IN LINE OF CODE + IAC + DCA FF /PUT FPP IN "SPECIAL MODE" +ADFC, . /CHANGE DF TO DF OF ARRAY ELEMNT + TAD XR1 /AC POINTS TO ARRAY ELEMENT +ARJMP, . /PERFORM THE REQUIRED OPERATION + NOP /FPP SOMETIMES RETURNS TO CALL+2 + JMP I [ILOOP /DONE + +/ARRAY JUMP TABLE + +AJT, FFSUB1 /FAC=A(S1,S2)-FAC OPCODE 0 + FFADD /FAC=FAC+A(S1,S2) OPCODE 1 + FFSUB /FAC=FAC-A(S1,S2) OPCODE 2 + FFMPY /FAC=FAC*A(S1,S2) OPCODE 3 + FFDIV /FAC=FAC/A(S1,S2) OPCODE 4 + FFGET /FAC=C(A(S1,S2) OPCODE 5 +FPUTLL, FFPUT /C(A(S1,S2)=FAC OPCODE 6 + FFDIV1 /FAC=A(S1,S2)/FAC OPCODE 7 + /STRING ARRAY DISPATCH + +SARRAY, TAD INSAV /GET INSTRUCTION + AND [340 /ISOLATE ARRAY OPCODE + CLL RTR + RTR /AND SLIDE IT OVER FOR AN OFFSET + RAR + TAD JMPISA /BUILD A JUMP TO STRING INSTRCUTION + DCA SAD /AND PUT IN LINE + STL /TELL SFIND TO USE ARRAY TABLE + JMS I STFILK /SET UP ARGUMENT ADDRESS +SAD, . /EXECUTE INSTRCUTION + +/STRING ARRAY JUMP TABLE +/USED WHEN ARRAYI CALLED IN SMODE +/ A "/*" IN THE COMMENT MEANS THAT OPCODE IS UNDEFINED AND THE SLOT +/IN THE TABLES IS USED FOR NORMAL STORAGE + +JMPISA, JMP I .+1 /DISPATCH JUMP FOR STRING ARRAY INSTRUCTIONS + + SCON1 /SAC_SAC&C(A$(S1)) + SCOMP /SKIP IF SAC=C(A$(S1)) + SREAD /A$(S1)_DEVICE +K0037, 37 /* +STFILK, STFIND /* LINK TO STRING FINDING ROUTINE + SLOAD /SAC_C(A$(S1)) + SSTORE /C(A$(S1))_SAC +JMPI2, JMS I AJT /* DISPATCH JUMP FOR ARRAY INST + /ROUTINE TO PUT ONE WORD IN FILE BUFFER IN FIELD 1 + +BCPUT, 0 + DCA TEMP6 /SAVE AC + JMS I [IDLE /CHECK IF FILE OPEN + TAD I IOTPTR /GET READ/WRITE POINTER + DCA TEMP7 /SAVE + TAD ENTNO /GET FILE # + SZA CLA /IF TTY,BUFFER FIELD IS 0 + CDF 10 + TAD TEMP6 /GET WORD TO STORE AGAIN + DCA I TEMP7 /STORE IT IN BUFFER +CDF0, CDF + TAD I IOTHDR /HEADER WORD + AND (7737 /TURN OFF BLOCK WRITTEN BIT + TAD (40 /TURN IT ON AGAIN + DCA I IOTHDR + JMP I BCPUT /RETURN + + PAGE + /TELETYPE DRIVING ROUTINE +/2 ENTRY POINTS-XPUTCH PUTS A CHARCTER IN THE RING BUFFER +/ XPRINT TYPES A CHARACTER IF POSSIBLE +/ AND RETURNS TO CALL+1 IF THERE +/ ARE MORE CHARCTERS IN THE BUFFER,CALL+2 +/ IF THE BUFFER IS EMPTY +/THE IDEA IS THE PLACE CALLS TO XPRINT AT VARIOUS POINTS IN THE INTER- +/PRETER AND THUS KEEP THE TTY BUSY WITHOUT WASTING THE TIME WAITING FOR +/THE TTY FLAG. THE SUCCESS OF THIS SCHEME DEPENDS HEAVILY ON THE NUMBER +/AND PLACEMENT OF THE CALLS TO XPRINT. + +XPUTCH, 0 + DCA CHRSAV /SAVE THE CHARACTER +XPUT1, ISZ SPINNR /SPIN RANDOM # SEED + JMS XPRINT /START A CHAR IF POSSIBLE + NOP + TAD BCNT /GET THE NUMBER OF AVAILABLE SLOTS + SNA CLA /ARE THERE ANY? + JMP XPUT1 /NO-TRY TO RPINT 1 AND FREE UP A SPACE +PUTCHR, TAD CHRSAV /GET CHARACTER AGAIN + DCA I BUFIN /PUT CHARACTER IN RING BUFFER + ISZ BUFIN /BUMP BUFEER POINTER OF INPUT + CLA CLL CMA /-1 IN AC + TAD BCNT /DECREMENT AVAILABLE SLOT COUNT + DCA BCNT + TAD BUFIN /GET BUFFER INPUT POINTER + TAD MBEND /SUBTRACT ADDR OF END OF BUFFER + SPA SNA CLA /PAST EDN OF BUFFER? + JMP I XPUTCH /NO-RETURN + TAD BSTRTA /YES-RESET INPUT POINTER TO BEGINNING OF BUFFER + DCA BUFIN + JMP I XPUTCH /RETURN + +BUFIN, BSTRT /POINTER TO NEXT SLOT FOR BUFFER INPUT +BUFOUT, BSTRT /POINTER TO NEXT CHARACTER TO BE PRINTED +BSTRTA, BSTRT /ADDR OF START OF TTY BUFFER +BCNT, 30 /# OF AVAILABLE SLOTS IN BUFFER (40 INITIALLY) +CHRSAV=TEMP1 +MBEND, -BEND /-ADDR OF END OF RING BUFFER +MCTRLC, -3 +M50, -30 +MXON, -21+3 +MXOFF, -23+21 +XFLAG, 0 + + +XPRINT, 0 + KSF /IS KEYBOARD FLAG UP? + JMP NOCC /NO-NO CHANCE FOR A CTRL/C + KRB /YES-GET THE CHAR IN KEYBOARD BUFFER + AND [177 /GET RID OF PARAITY + TAD MCTRLC /IS IT CTRL/C + SNA + JMP I FSTOP1 /YES-ABORT TO EDITOR + TAD MXON + SZA + JMP .+3 + DCA XFLAG + JMP NOCC+3 + TAD MXOFF + SZA CLA + JMP NOCC + ISZ XFLAG + JMP XPRINT+1 +NOCC, TAD XFLAG + SZA CLA + JMP XPRINT+1 + TAD BCNT /# OF AVAILABLE SLOTS IN BUFFER + TAD M50 /IS BUFFER EMPTY? + SNA CLA + JMP RECP2 /YES-RETURN TO CALL+2 + TSF /NO-TTY FLAG UP YET? + JMP I XPRINT /NO-GO ABOUT YOUR BUSINESS + TAD I BUFOUT /GET NEXT CHARACTER +/*****************************************************************: +/N.B. BECAUSE OF THE ABOVE INSTRUCTION,THE DF MUST BE SET TO THE +/INTERPRETER FIELD WHENEVER XPRINT IS CALLED. WATCH YOUR HOOK PLACEMENT! +/****************************************************************: + JMS I (PCH /TYPE THE CHAR + ISZ BUFOUT /BUMP BUFFER OUTPUT POINTER + TAD BUFOUT /GET OUTPUT POINTER + TAD MBEND /SUBTRACT END OF BUFFER + SPA SNA CLA /IS OUTPUT POINTER PAST END? + JMP BOUTRS /NO-FREE UP A SPOT + TAD BSTRTA /YES-RESET POINTER TO BEGINNING + DCA BUFOUT +BOUTRS, ISZ BCNT /INCREMENT # OF FREE SLOTS (WE JUST PRINTED ONE) + JMP I XPRINT /RETURN + +RECP2, ISZ XPRINT /BUMP RETURN + JMP I XPRINT /RETURN TO CALL+2 FOR EMPTY BUFFER + + +/TELETYPE RING BUFFER + +BSTRT, "B /START OF BUFFER + "R + "T + "S + " + "V +VERLOC, 260+VERSON + 300+SUBVER + 0215 + 0212 +VEREND, 0212 +VCHECK, 0 + CDF 10 + TAD I N7644 + CDF 0 + AND XR4 + SNA CLA + JMP I VCHECK + TAD XR1 + DCA BUFIN + TAD SACXR + DCA BCNT + JMP I VCHECK +BEND, +N7644, 7644 + + /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 KC240 /IF TRACE IS ON,FAKE CALL + DCA INSAV /TO FUNC2,#12 + JMP I .+1 + FUNC2I /DISPATCH TO TRACE FUNCTION + +/INTERMEDIATE TTY BUFFER +/USED TO BUFFER OUTPUT FROM FPP BEFORE WE PUT IT +/IN BASIC FORMAT FOR TRANSPORTATION TO THE TTY RING +/BUFFER + +KC240, 240 /STOPPER TO MARK BEGINNING OF BUFFER +INTERB, +START3, TAD CDFPS /CDF FOR PSEUDO-CODE + DCA I [CDFPSU /PUT IN-LINE TO ILOOP + TAD PSSTRT /START OF PSEUDO-CODE + DCA I INTPCK /PUT INTO PC + JMS I [FACCLR /ZERO FAC + TAD CDFIO /CDF FOR SYMBOL TABLE FIELD + DCA I STDFL /PUT IN LINE FOR STRING FUNCTIONS +FPPTM5, TAD CDFIO /CDF FOR SYMBOL TABLES + DCA I ATABDL /PUT IN LINE FOR ARRAY CALCULATIONS + TAD CDFIO /CDF FOR SCALAR TABLE +FPPTM4, DCA I SCALDL /PUT IN LINE FOR ARGPRE + TAD CDFIO + DCA I DLCDFL /DATA FIELD FOR DATA LIST +FPPTM3, TAD DLSTRT + DCA DATAXR /DO A RESTORE IN INCORE DATA LIST + JMP I .+1 /CONTINUE INITAILIZATION CODE IN TTY INPUT BUFFER +FPPTM2, START4 +ATABDL, ATABDF +STDFL, STDF +FPPTM1, /FLOATING POINT TEMPORARY +INTPCK, INTPC +DLCDFL, DLCDF +SCALDL, SCALDF + + 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 + TSF /WAIT FOR PREV CHAR + JMP .-1 + TLS /TYPE THE CURRENT ONE + AND [177 /MASK TO 7BIT + TAD (-15 /TEST IF LINE FEED WILL BE SENT NEXT + SZA CLA + JMP I PCH /RETURN IF NOT + ISZ HCTR /TEST SCREEN HEIGHT IF LF + JMP I PCH /RETURN IF NOT AT BOTTOM OF SCREEN + TAD HEIGHT + DCA HCTR /RESET HEIGHT COUNTER NOW + TAD DELAY + SNA /TEST FOR ZERO DELAY + JMP I PCH /RETURN IF SO + DCA DCTR /ELSE SET DELAY COUNTER +DLOOP, ISZ PSWAP /NOW EXEC INNER LOOP 4096 TIMES (USUALLY) + JMP .-1 + KSF /TEST IF KEY STRUCK + SKP + JMP I PCH /RETURN AT ONCE IF YES + ISZ DCTR /TEST DELAY TIMER + JMP DLOOP /REITERATE + JMP I PCH /NOW ALLOW PRINTING TO CONTINUE + + /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 + . /DISPATCH TO PROPER OPERATE ROUTINE + +JMPI3, JMP I .+1 /JUMP TO OPERATE ROUTINE CALLED FOR + + /OPERATE JUMP TABLE + + FUNC3I /CALL RESIDENT FUNCTION OPCODE 0 + SPFUNC /SPECIAL FUNCTIONS OPCODE 1 + SFN /SET FILE NUMBER OPCODE 2 + FNEGI /NEGATE FAC OPCODE 3 + RETRNI /GOSUB RETURN OPCODE 4 + RESTOR /RESTORE DEVICE OPCODE 5 + LSUB1I /LOAD S1 FROM FAC OPCODE 6 + LSUB2I /LOAD S2 FROM FAC OPCODE 7 +MSPACE, 20 /THIS OPCODE NOT DEFINED,SO WE PUT A CONST HERE + READI /READ DEVICE OPCODE 11 + WRITEI /WRITE DEVICE OPCODE 12 + SWRITE /STRING WRITE OPCODE 13 + FUNC5I /CALL FILE FUNCTION OPCODE 14 + FUNC4I /CALL USER FUNCTION OPCODE 15 + FUNC1I /CALL FUNCTIONS 1 OPCODE 16 + FUNC2I /CALL FUNCTIONS 2 OPCODE 17 + /ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE) +/WHERE N IS THE HIGH CORE FIELD + +PSWAP, 0 + TAD KK7600 /POINTER TO 17600 AND COUNTER + DCA TEMP1 + 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 TEMP4 /SAVE IT +P2CDF, CDF 10 + TAD I TEMP1 /GET WORD FROM 17600 +P1CDF1, HLT /DF TO HI CORE AGAIN + DCA I TEMP2 /PUT 17600 WORD IN HI CORE +P2CDF1, CDF 10 + TAD TEMP4 /GET SAVED HI CORE WORD + DCA I TEMP1 /AND PUT IN 17600 + ISZ TEMP2 /BUMP HI CORE POINTER +KK7600, 7600 /CLA + ISZ TEMP1 /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 + + IFNZRO EAE < + + /TEMPORARY INCLUSION FOR FFOUT + + /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 + > + PAGE + /LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY + +LSUB2I, ISZ DCASUB + JMP LSUB1I +LS2I, ISZ DCASUB +LS1I, JMS I [FACSAV /PRESERVE FAC + JMS I ARGPRL /GET ARG POINTER INTO AC + JMS I [FFGET /LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN) +LSUB1I, JMS I [FACSAV /SAVE THE FAC + JMS I [UNSFIX /GET INT(FAC) +DCASUB, DCA S1 /SET RESULT AS SUBSCRIPT 1 + JMS I [FACRES /RESTORE FAC + TAD DCAS1 + DCA DCASUB /FUDGE INSTR BACK + JMP I [ILOOP /NEXT INSTRCUTION +DCAS1, DCA S1 +ARGPRL, ARGPRE + +/JMP DISPATCH FOR FUNC1 CALLS + +JMSI4, JMS I .+1 /CALL FOR CANNED FUNCTION SET 1 + +/JUMP TABLE FOR FUNCTION CALL 1 + + ATAN /FUNCTION BITS= 0 + COS / 1 + EXPON1 / 2 + EXPON / 3 + INT / 4 + LOG / 5 + SGN / 6 + SIN / 7 + RND / 10 + FROOT / 11 + +/JUMP FOR FUNC2 DISPATCH + +JMSI5, JMP I .+1 /JMP OFF THE SET 2 TABLE + +/JUMP TABLE FOR FUNCTION SET 2 + + ASC /FUNCTION BITS= 0 + CHR / 1 + DATE / 2 + LEN / 3 + POS / 4 + SEG / 5 + STR / 6 + VAL / 7 + ERRORR / 10 +/ERRORR MUST BE FUNCTION #10,ELSE "ERROPC" MUST CHANGE + TRACE / 11 + TPRINT / 12 +/TPRINT MUST BE #12 OR TRHOOK+1 MUST CHANGE + +/DISPATCH FOR FUNC5 CALLS + +JMPFIL, JMP I .+1 /CALL FORR FILE MANIPULATING FUNCTIONS + +/JUMP TABLE FOR FILE FUNCTIONS + + CHAIN /FUNCTION BITS= 0 + CLOSE / 1 + OPENAF / 2 + OPENAV / 3 + OPENNF / 4 + OPENNV / 5 + FSTOP /INT. EXIT 6 + +/ERROR CALL FOR USER FUNCTIONS-USER FUNCTION SHOULD "JMS I (IA" + +IA, JMS I [ERROR + /FUNCTION OVERLAY DRIVER + +FUNC4I, JMS I [XPRINT /PURGE TTY RING BUFFER + JMP .-1 /BEFORE CALLING USER FUNCTION + IAC /LOOK FOR OVERLAY FLAG=3 +FUNC5I, IAC /LOOK FOR OVERLAY FLAG=2 +FUNC2I, IAC /LOOK FOR OVERLAY FLAG=1 +FUNC1I, DCA TEMP1 /LOOK FOR OVERLAY FLAG=0 + CDF /DF TO THIS FIELD + TAD TEMP1 /GET OVERLAY # AGAIN + CIA /NEGATE + TAD OVRLAY /COMPARE AGAINST OVERLAY FLAG + SNA CLA /IS THE ONE WE WANT ALREADY RESIDENT? + JMP OVDNE /YES-JUST JUMP TO FUNCTION + TAD TEMP1 /NO-GET NUMBER OF OVERALY DESIRED + TAD OATADI /USE AS OFFSET TO BUILD STARTING BLOCK TAD + DCA TEMP2 /POINTS TO PROPER STARING BLOCK # + TAD I TEMP2 /GET STARTING BLOCK FOR THIS OVERLAY + DCA OVADD /PUT IN DRIVER CALL + JMS I L7607 /CALL SYSTEM HANDLER + 0500 /OVERLAY 3400-4600 + 3400 +OVADD, . /STARTING BLOCK # OF OVERLAY +OE, JMS I [ERROR /I/O ERROR + TAD TEMP1 + DCA OVRLAY /CHANGE RESIDENT FLAG +OVDNE, TAD [SAC-1 /ENTER STRING FUNCTIONS WITH SACXR SET UP + DCA SACXR + TAD TEMP1 /FUNCTION # + TAD JMSTAD /BUILD A TAD OF THE PROPER DISPATCH JMS + DCA .+2 /PUT IN LINE + JMS I [FBITGT /GET # OF FUNCTION DESIRED + . /BUILD JUMP OFF JUMP TABLE +FUJUMP, DCA .+1 /PUT JUMP IN LINE + . /GO TO DESIRED FUNCTION + JMP I [ILOOP /DONE + +OATADI, ARITHA +L7607, 7607 +OVRLAY, 0 /# OF CURRENTLY RESIDENT OVERLAY + /0=ARITHMETIC,1=STRING,2=FILE,3=USER + +/OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS +/INITIALIZED BY LOADER + +ARITHA, . /STARTING BLOCK OF ARITHMETIC OVERLAY +STRNGA, . /STARTING BLOCK OF STRING OVERLAY +FILEFA, . /STARTING BLOCK OF FILE OVERLAY +USRA, . /STARTING BLOCK OF USER FUNCTIONS + +JMSTAD, TAD I TADTAB + +TADTAB, JMSI4 + JMSI5 + JMPFIL + JMSUSR + + /CALL FOR RESIDENT FUNCTION + +FUNC3I, JMS I [FBITGT /ISOLATE FUNCTION # + TAD JMSI7 /MAKE A JUMP OFF JUMP TABLE + JMP FUJUMP /PUT THE JUMP IN LINE AND EXECUTE IT + +JMSI7, JMP I .+1 + +/JUMP TABLE FOR RESIDENT FUNCTIONS + + XABSVL /FUNCTION BITS= 0 + COMMA / 1 + CRFUNC / 2 + ILOOPF / 3 + TAB / 4 + PNT / 5 + USE / 6 + + + *1557 /****N.B.**** + /THIS TABLE CANNOT BE MOVED!!!! + +/JUMP DISPATCH FOR USER ROUTINES +JMSUSR, JMS I .+1 + +/JUMP TABLE FOR USER FUNCTIONS + ILOOPF /USER FUNCTION 1 + ILOOPF / 2 + ILOOPF / 3 + ILOOPF / 4 + ILOOPF / 5 + ILOOPF / 6 + ILOOPF / 7 + ILOOPF / 8 + ILOOPF / 9 + ILOOPF / 10 + ILOOPF / 11 + ILOOPF / 12 + ILOOPF / 13 + ILOOPF / 14 + ILOOPF / 15 + ILOOPF / 16 + + PAGE + /SPECIAL FUNCTIONS + +SPFUNC, JMS I [FBITGT /ISOLATE FUNCTION BITS + TAD JMPI6 /MAKE A JUMP OFF SPECIAL FUNCTION TABLE + DCA .+1 /PUT IN LINE + . + +JMPI6, JMP I .+1 /JUMP TO SPECIAL FUNCTION ROUTINE + +/SPECIAL FUNCTION JUMP TABLE + + SETF /SET FSWITCH 0 + FRANDM /RANDOMIZE 1 + FSTOPN /LEAVE INTERPRETER 2 + SRLIST /STRING READ FROM DATA LIST 3 + CSFN /SET FILE # TO TTY 4 + RDLIST /READ DATA LIST 5 + AMODE /SWITCH TO A MODE 6 + SSMODE /SWITCH TO S MODE 7 + /SUBROUTINE UNSFIX-UNSIGNED INTEGER FIX ROUTINE. FIXS A POSITIVE 12 BIT +/NUMBER OUT OF FAC MANTISSA AND LEAVES RESULT IN AC.RESULT IS AN UNSIGNED, +/12 BIT INTEGER + +UNSFIX, 0 + CDF 0 + TAD ACL /LOW MANTISSA + CLL RAL /HI BIT OF LO MANTISSA TO LINK + CLA + TAD ACH /HIGH MANTISSA + SPA /IS NUMBER POSITIVE? +FM, JMS I [ERROR /NO-BOO!!! + RAL /SHIFT THE SIGN BIT OUT AND THE MANTISSA OVER, + DCA ACH /MAKING 12 BITS OF MANTISSA AND BINARY POINT BEFORE BIT 0 + TAD ACX /GET EXPONENT + SPA SNA CLA /IS X>1? + JMP I UNSFIX /NO-FIX IT TO 0 + TAD ACX /YES-GET EXPONENT + TAD [-14 /SET BINARY POINT AT 12 + SNA /DONE ALREADY? + JMP UNSOUT /YES + SMA /NO-IS # TOO BIG? +FO, JMS I [ERROR /YES + DCA ACX /NO-STORE COUNT + TAD ACH /HI MANTISSA +UNSLP, CLL RAR /SCALE RIGHT + ISZ ACX /DONE? + JMP UNSLP /NO + JMP I UNSFIX /YES-RETURN + +UNSOUT, TAD ACH /ANSWER IN AC + JMP I UNSFIX + +/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 (7435 /CLEAR EOF BIT,BUFFER WRITTEN BIT,AND CHAR # + 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 TEMP1 /NO-SAVE OPERAND POINTER + TAD TEMP1 /N + CLL RAL /2N + TAD TEMP1 /3N (3 WORDS/ENTRY) + TAD STSTRT /ADD BASE ADR OF STRING TABLE +STCOM, DCA XR2 /POINTER TO THIS ENTRY IN STRING TABLE +STDF, . /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 -(MAX LENGTH OF STRING) + DCA STRMAX /SAVE + SNL /ARRAY ELEMENT? + JMP STRCDF /NO-SKIP THIS SUBSCRIPT CALCULATION + TAD S1 /GET SUBSCRIPT + CLL CMA /SET UP 12 BIT COMPARE + TAD I XR2 /GET DIMENSION + SNL CLA /IS S1>DIMENSION? + JMP I (SU /YES + TAD STRMAX /NO-GET ELEMENT LENGTH + CIA /MAKE POSITIVE + CLL IAC /ROUND OFF TO NEAREST MULTIPLE OF 2 + CLL RAR / DIVIDE BY TWO (COUNT/2=WORD COUNT) + CLL IAC /ADD A WORD FOR HEADER + DCA TEMP3 /# 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 TEMP6 /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 +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 + 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 + + /PNT(X) + /SEND 7BIT CHAR TO THE CURRENT FILE + +PNT, JMS I [UNSFIX /FIX X + AND [177 /STRIP TO 7 ASCII BITS + TAD [200 /FORCE CHANNEL 8 + JMS I [PUTCH /PUT IN FILE BUFFER + JMP I [ILOOP /DONE + + PAGE + /ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER +/AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER + +SFN, JMS I [UNSFIX /FIX FAC TO GET FILE # +CSFN, DCA ENTNO /IF ENTRY IS HERE,FILE #=0 (TTY) + TAD ENTNO + STL + TAD (-4 /IS RESULT A LEGAL FILE #? + SNL SZA CLA +FN, JMS I [ERROR /NO-ERROR + TAD ENTNO /PICK UP FILE NUMBER + CLL RTL + RTL + CIA + TAD ENTNO + CIA /MULTIPLY BY SIZE OF IOTABLE + IFNZRO IOTSIZ-15 <__ASSEMBLY ERROR__> + TAD (TTYF /ADD TO BASE + DCA XR1 /STORE IN TEMP + TAD (IOTHDR-1 /NOW POINT AT PAGE 0 AREA + DCA XR2 + TAD (-IOTSIZ+3 /SETUP ALL BUT LAST 3 + DCA TEMP2 + TAD XR1 + DCA I XR2 + ISZ XR1 + ISZ TEMP2 + JMP .-4 /SET UP THE POINTERS NOW + JMP I [ILOOP /--RETURN-- + /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 I (SUCJMP /EXEC AS NORMAL GOTO NOW + + /GOSUB RETURN + +RETRNI, STA + TAD GSP + DCA GSP /POP STACK + TAD I GSP /GET PC + DCA I (INTPC + STA + TAD GSP /POP STACK + DCA GSP + TAD I GSP + SMA +GR, JMS I [ERROR /FATAL ERROR IF NO RETURN + DCA I [CDFPSU + JMP I (JFAIL /BUMP PC PAST ADDR WORD AND CONTINUE + +GSP, GSTCK /GOSUB STACK POINTER + + /FOR-LOOP JUMP ROUTINE + /ENTER WITH AC = HORD + +JFOR, SNA /IS FAC=0? + JMP I (JFAIL /YES-DO NOT JUMP + TAD FSWITC /ADD FSWITCH + SPA CLA /ARE SIGN BIT=FSWITCH? + JMP I (JFAIL /NO-DO NOT JUMP + JMP I (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 + /ROUTINE TO RESET CHARACTER NUMBER TO 1 + +CNOCLR, 0 + TAD I IOTHDR + AND [7477 /SET CHAR BITS TO 0 + DCA I IOTHDR + JMP I CNOCLR /RETURN + + /ROUTINE TO ZERO THE CURRENT I/O BUFFER + +BLZERO, 0 + STA + TAD I IOTBUF + DCA XR1 /POINT INTO THE BUFFER + TAD [7400 + DCA CNOBML /SET COUNT TO 400 WORDS + TAD (232 /INSERT A ^Z IN THE BUFFER FIRST + CDF 10 + DCA I XR1 + ISZ CNOBML + JMP .-2 /LOOP FOR THE REST + CDF + JMP I BLZERO /--RETURN-- + + /BUMP 3 FOR 2 CHAR NUMBER FOR CURRENT FILE + +CNOBML, 0 + TAD I IOTHDR /HEADER WORD + TAD [100 /ADD 1 TO THE COUNT BITS + DCA I IOTHDR + JMP I CNOBML /DONE + /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 + SNA + TAD I SACXR /NO GET IT + 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 + +SRLIST, JMS I (DLREAD /FIRST READ NEG BYTE COUNT + DCA STRCNT /STORE IT + STL /SET LINK MEANS USE PHONY DATA LIST BYTE LOAD + SKP /SKP INTO STRING LOAD ROUTINE +SLOAD, CLL /CLEAR LINK TO USE NORMAL LOAD BYTE ROUTINE + DCA SACLEN /CLEAR SAC LENGTH COUNTER + SZL + TAD (DRGCH-LDB /USE PHONY LOAD BYTE +SCON1, TAD (LDB /USE REAL LDB FOR CONCATENATE + DCA SCLDB + TAD STRCNT + SNA CLA + JMP I [ILOOP /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 SCLDB /GET A BYTE + DCA I SACXR /STORE IT + 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 [ILOOP /--RETURN-- + +SCLDB, 0 + + /ROUTINE TO GET A BYTE FROM THE DATA LIST + +DRGCH, 0 + TAD SACLEN /TEST FOR EVEN OR ODD + CLL RAR + SZL CLA + JMP CHR2 /SECOND CHAR + JMS I (DLREAD /FIRST CHAR, READ ANOTHER WORD + DCA DRCHR + TAD DRCHR + CLL RTR + RTR + RTR /SHIFT RIGHT + SKP +CHR2, TAD DRCHR /GET SECOND CHAR + AND [77 /MASK TO 6BIT + JMP I DRGCH /RETURN + +DRCHR, 0 + +/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 + +/SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS +/OF TEMP3 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN TEMP6 +/AND THE LOW RESULT IN THE AC + +MPY, 0 + DCA TEMP10 + DCA TEMP6 + TAD [-14 + DCA TEMP5 +MP12LP, TAD TEMP3 + RAR + DCA TEMP3 + TAD TEMP6 + SNL + JMP .+3 /12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2 + CLL + TAD TEMP10 + RAR + DCA TEMP6 + ISZ TEMP5 + JMP MP12LP + TAD TEMP3 /LORD OF (DIM1+1)*S2 IN AC + RAR /HORD OF (DIM1+1)*S2 IN TEMP6 + 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 SPINNR /USE SPINNR FOR NEW SEED FOR RND(X) + STL RAL /MAKE SURE SEED IS ODD + DCA RSEED + JMP I [ILOOP /DONE +RSEED, 2713 + +/SUBROUTINE CR,LF + +CRLFR, 0 + TAD [215 + JMS I [PUTCH + TAD (212 + 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 + +/ROUTINE TO RESTORE THE FAC FROM FP TEMP + +FACRES, 0 + JMS I [FFGET /GET FAC + INTERB + JMP I FACRES /RETURN + + PAGE + /STRING STORE + +SSTORE, TAD SACLEN + SNA + JMP I (SSTEX /EXIT IF NULL STRING IN SAC + DCA TEMP1 /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 + TAD I SACXR /PICK UP SAC BYTE + JMS I (DPB /STORE IT + ISZ TEMP1 + JMP .-3 + JMP I (SSTEX /--RETURN-- + + /STRING READ FROM FILE TO MEMORY + +SREAD, JMS I [GETCH /GET CHAR FROM FILE + TAD CHAR + TAD [-215 /IS IS CR? + SNA + JMP I (SSTEX /YES, EXIT + TAD (3 /IS IT LF? + SNA CLA + JMP SREAD /YES, IGNORE IT + TAD I (BYTCNT /SEE IF THIS CHAR WILL FIT + TAD STRMAX + SMA CLA + JMP ST /NO, SOFT ERROR + TAD CHAR /YES, STORE IT + JMS I (DPB + JMP SREAD +ST, JMS I [ERROR + TAD [215 /FAKE OUT INPUT ROUTINE + DCA CHAR + 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 (-WIDTH + 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, TAD I SACXR + TAD (240 + AND [77 + TAD (240 /CONVERT TO 8BIT + 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 (" /YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION + JMS I [PUTCH + IAC + DCA COMMAS /SET COMMA SWITCH + TAD (-4 + DCA TEMP2 + TAD I IOTPOS /GET NUMBER OF CHARS PRINTED SO FAR +COMLOP, TAD (-COLWID + SPA /PAST THIS ONE? + JMP SLOVER /YES-SLIDE PRINT HEAD TO START OF NEXT + SNA /EXACTLY ON A COLUMN? + JMP I [ILOOP /YES-DONE + ISZ TEMP2 /ALL MARKERS CHECKED YET? + JMP COMLOP /NO-DO NEXT + CLA /FALL INTO CR ROUTINE TO RESET COL TO 0 + +/CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING +/PRINT STATEMENTS) + +CRFUNC, TAD I IOTHDR + CLL RTR + SNL CLA /SKP IF EOF IS SET + JMS I [FTYPE /SKP IF FILE IS ASCII + JMP I [ILOOP /WE DON'T WANT TO OUTPUT CLFR + JMS I [CRLFR /DO AS WE ARE TOLD + JMP I [ILOOP /NEXT INST + + /TAB FUNCTION + +TAB, JMS I [UNSFIX /FIX X TO INTEGER + CIA /NEGATE + TAD I IOTPOS /COMPARE DESIRED COLUMN TO REAL COLUMN + IAC /BUMP BY 1 (WORD 7=COL #-1) + 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 (" /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 + +/ROUTINE TO CALL ERROR ROUTINE BY FAKING A FUNC2 CALL TO FUNCTION #10 + +ERROR, 0 + CLA CLL IAC /ENTRY AC RANDOM + AND PSFLAG /TEST IF OS/8 17600 RESIDENT + SZA CLA /SKP IF NOT + JMS I [PSWAP /ELSE FORCE IT OUT (THESE ERRORS ARE FATAL) + TAD (7607 + DCA INSAV /FAKE A FUNC CALL TO FUNC2 #10 + JMP I (FUNC2I +XERRRET,JMP I ERROR /RETURN TO CALLER IF NON FATAL ERROR + + /FLOATING NEGATE + +FNEGI, JMS I [FFNEG /CALL NEGATE ROUTINE + JMP I [ILOOP /RETURN TO ILOOP + +NUMBUF, ZBLOCK 6 /6 DIGIT BUFFER USED BY FFOUT + + PAGE + /INCREMENT AND LOAD 6BIT BYTE FROM MEMORY + +LDB, 0 + JMS BUMP /INCREMENT POINTER AND SET DF + TAD I BYTPTR /PICK UP BYTE + CDF + ISZ BYTSWT /TEST HALFWORD SWITCH + JMP .+4 + CLL RTR + RTR + RTR + AND [77 /MASK TO 6BIT + JMP I LDB /RETURN WITH CHAR IN AC + + /INCREMENT AND DEPOSIT BYTE IN MEMORY + +DPB, 0 + AND [77 /MASK TO 6BIT NOW + DCA BYTE + JMS BUMP /INCREMENT POINTER AND SET DF + TAD [77 /GET MASK + ISZ BYTSWT /SKP IF PTR BUMPED + CMA CML /ELSE PRESERVE LEFT HALF + AND I BYTPTR /ZERO OUT TARGET BYTE + DCA I BYTPTR + TAD BYTE /GET BYTE + SZL + JMP .+4 /JMP IF NO SHIFT + CLL RTL + RTL + RTL + TAD I BYTPTR + DCA I BYTPTR /STORE BYTE + CDF + ISZ BYTCNT /TALLY NUMBER OF BYTES STORED + JMP I DPB /--RETURN-- + + /BUMP BYTE POINTER + +BUMP, 0 + TAD BYTSWT /BUMP LOW ORDER BIT + CLL CMA + DCA BYTSWT + ISZ BYTSWT /SKP IF NO CARRY + ISZ BYTPTR /ELSE BUMP WORD PTR + JMP BYTCDF /JMP OUT IF FIELD NOT CROSSED + TAD [10 + TAD BYTCDF + DCA BYTCDF /PROPAGATE CARRY INTO CDF INSTR +BYTCDF, 0 /GETS SET BY BYTSET TO TARGET FIELD + JMP I BUMP /RETURN WITH A CLEAR LINK + + /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 + IAC + DCA BYTSWT /SET LOW ORDER BIT TO CARRY NEXT TIME + 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 +BYTSWT, 0 +BYTE, 0 + /SUBROUTINE BUFCHK-CHECKS THE POSITION OF THE BUFFER POINTER FOR +/THE DEVICE WHOSE I/O TABLE ENTRY IS IN WORKING AREA. RETURNS TO CALL+1 +/IF THE POINTER IS AT THE END AND CHAR NUMBER IS 1 (LAST +/AVAILABLE CHAR 3 HAS BEEN USED),CALL+2 IF THE POINTER IS AT THE +/END BUT THE CHAR # IS NOT 1 (THERE IS 1 CHAR 3 LEFT), CALL+3 +/IF THERE IS 1 WORD LEFT IN BUFFER,CALL+4 IF MORE THAN 1 LEFT. + +BUFCHK, 0 + TAD ENTNO /GET DEVICE # + SNA CLA /IS IT TTY? + TAD (62-400 /YES-CHECK FOR A BUFFER 60 WORDS LONG + TAD [400 /NO-CHECK FOR A BUFFER 400 WORDS LONG + TAD I IOTBUF /ADD LENGTH TO BUFFER ADDRESS + CIA /-ADDR OF END OF BUFFER + TAD I IOTPTR /CHECK AGAINST CURRENT POINTER + SNA /IS POINTER AT END OF BUFFER? + JMP EBC /AT END-CHECK THE CHAR # + ISZ BUFCHK + ISZ BUFCHK /NO-BUMP RETURN + IAC + SNA CLA /WAS POINTER AT LAST WORD? + JMP I BUFCHK /YES-RETURN TO CALL+3 + ISZ BUFCHK /NO + JMP I BUFCHK /RETURN TO CALL+4 + +EBC, JMS I [CHARNO /GET CHAR # + JMP I BUFCHK /IT WAS 1-RETURN TO CALL+1 + NOP /IT WAS 3-RETURN TO CALL+2 + ISZ BUFCHK /IT WAS 2-RETURN TO CALL+2 + JMP I BUFCHK + +/SUBROUTINE PACKCH-PACKS ASCII CHARS,3 FOR 2, INTO BUFFER FOR THE +/DEVICE IN WORK AREA. CALL WITH THE CHARACTER IN THE AC + +PACKCH, 0 + DCA TEMP1 /SAVE + JMS I [CHARNO /DETERMINE CHARACTER NUMBER + SKP /1 + JMP CHAR3P /3 + TAD TEMP1 /1 OR 2-GET CHAR AGAIN + JMS I [WRITFL /STORE IN BUFFER + JMS I (CNOBML /BUMP CHARACTER NUMBER + JMP I PACKCH /DONE + +CHAR3P, AC7776 + TAD I IOTPTR /BACK BUFFER POINTER UP TO POINT TO CHAR 1 + DCA I IOTPTR + TAD TEMP1 /CHAR + CLL RTL + RTL /SLIDE LEFT HALF INTO BITS 0-3 + DCA TEMP1 /SAVE + TAD TEMP1 + JMS COMBNE /ISOLATE LEFT HALF,COMBINE WITH CHAR1,AND PUT IN FILE + TAD TEMP1 /CHAR AGAIN + CLL RTL + RTL /SLIDE RIGHT HALF INTO BITS 0-3 + JMS COMBNE /ISOLATE RIGHT HALF,COMBINE WITH CHAR 2,AND PUT IN FILE + JMS I [CNOCLR /CLEAR THE CHARACTER NUMBER (RESET IT TO 1) + JMP I PACKCH /DONE + +COMBNE, 0 + AND [7400 /ISOLATE HALF IN QUESTION + DCA TEMP2 /SAVE + JMS I (BCGET /GET A WORD FROM FILE BUFFER IN FIELD 1 + AND [377 /FLUSH ANY SLUSH IN BITS 0-3 + TAD TEMP2 /COMBINE + JMS I [WRITFL /PUT IN BUFFER + JMP I COMBNE /RETURN + + PAGE + /ROUTINE TO READ WORD FROM FILE BUFFER AND BUMP POINTER + +READFL, 0 + JMS I (FOTYPE /IS FILE VARIABLE LENGTH + SKP +VR, JMS I [ERROR /YES-IT IS AN ERROR TO TRY AND READ IT + TAD I IOTHDR /CHECK IF MORE THERE + CLL RTR /EOF BIT TO LINK + SNL CLA /EOF? + JMP .+3 /NO-CONTINUE +RE, JMS I [ERROR /YES-ATTEMPT TO READ BEYOND EOF + JMP I [ILOOP /NOT FATAL-RETURN TO I LOOP + JMS BCGET /GET WORD FROM FILE BUFFER + ISZ I IOTPTR /BUMP POINTER + JMP I READFL /DONE + +/ROUTINE TO WRITE AC IN FILE BUFFER AND INCREMENT POINTER + +WRITFL, 0 + JMS I (BCPUT /STORE AC IN FILE BUFFER + ISZ I IOTPTR /BUMP POINTER + TAD I IOTHDR /GET FILE HEADER WORD + CLL RTR /EOF BIT TO LINK + SNL CLA /WAS FILE PAST END? + JMP I WRITFL /NO-RETURN +WE, JMS I [ERROR /YES-ATTEMPT TO WRITE PAST END OF FILE + JMP I [ILOOP /NON-FATAL RETURN TO ILOOP + +/ROUTINE TO GET ONE WORD FROM FILE BUFFER IN FIELD 1 + +BCGET, 0 + JMS I [IDLE /CHECK IF FILE OPEN + TAD I IOTPTR /GET READ WRITE POINTER + DCA WRITFL /SAVE + TAD ENTNO /GET FILE # + SZA CLA /IF TTY,BUFFER FIELD IS 0 + CDF 10 /DF TO BUFFER FIELD + TAD I WRITFL /GET WORD FROM BUFFER + CDF + JMP I BCGET /RETURN + /SUBROUTINE UNPACK-UNPACKS ASCII, 3 FOR 2 ,FROM THE FILE IN THE I/O +/WORKING AREA. RETURNS WITH THE CHAR IN CHAR. + +UNPACK, 0 + JMS I [CHARNO /GET CHAR # + SKP /1 + JMP CHAR3U /3 + JMS I (CNOBML /BUMP CHAR NUMBER + JMS READFL /GET CHAR AGAIN +U123C, AND [177 /STRIP OFF 7 BITS + SNA + JMP UNPACK+1 /ZERO + TAD [200 + DCA CHAR /SAVE + TAD CHAR + TAD (-232 /IS IT CTRL/Z? + SNA CLA + JMP I [EOFSET /YES-SET EOF BIT + JMP I UNPACK /RETURN + +CHAR3U, JMS I [CNOCLR /RESET CHAR # TO 1 + AC7776 + TAD I IOTPTR + DCA I IOTPTR /BACK BUFFER POINTER UP 2 + JMS READFL /GET LEFT HALF OF CHAR + AND [7400 + DCA XR5 /SAVE + JMS READFL /GET NEXT WORD WITH RIGHT HALF + AND [7400 /ISOLATE RIGHT HALF + CLL RTR + RTR /SLIDE RIGHT HALF OVER + TAD XR5 /COMBINE WITH LEFT HALF + CLL RTR + RTR /MOVE TO BITS 4-11 + JMP U123C /REJOIN MAINLINE + /READ FUNCTION-GETS NUMBERS INTO VARIABLES + +READI, JMS I [FTYPE /SKP IF FILE IS ASCII + JMP RIMAGE /READ NUMERIC IMAGE + JMS I (FFIN /READ ASCII INTO NUMBER + JMP I [ILOOP /--RETURN-- +RIMAGE, JMS I [BUFCHK /YES-CHECK BUFFER POINTER + NOP /PAST END-NEXT RECORD + NOP /AT END-NEXT RECORD + JMS I [NEXREC /ONLY 1 WORD LEFT-IT IS UNUSED IN NUMERIC FMT + JMS READFL /GET WORD FROM FILE + DCA ACX /STORE AS EXPONENT + JMS READFL /GET WORD FROM FILE + DCA ACH /STORE AS HIGH MANTISSA + JMS READFL /GET WORD FROM FILE + DCA ACL /STORE AS LOW MANTISSA + JMP I [ILOOP /DONE + +/ROUTINE TO FETCH ASCII CHARACTERS FROM FILE BUFFER + +GETCH, 0 + JMS I [FTYPE /IS FILE ASCII? +SR, JMS I [ERROR /NO-ERROR + TAD ENTNO + SZA CLA + JMP NTTY + TAD TCHAR + TAD [-215 + SNA CLA + JMS I [DRCALL +NTTY, JMS I [BUFCHK /NO-CHECK STATUS OF BUFFER + JMS I [NEXREC /LAST CHAR READ-NEXT RECORD + NOP /CHAR 3 NOT USED YET +TCHAR, 215 /NOP: CHAR 2 AND 3 LEFT + JMS UNPACK /UNPACK CHAR FROM BUFFER + TAD ENTNO + SZA CLA + JMP I GETCH /RETURN + TAD CHAR + DCA TCHAR + JMP I GETCH + +/SUBROUTINE CHARNO-RETURNS TO CALL+1 IF CHAR #=1,CALL+2 IF 3,CALL+3 +/IF 2 + +CHARNO, 0 + TAD I IOTHDR /HEADER + AND (300 /ISOLATE CHAR # + CLL RTL + RTL /CHAR # TO BITS 0,1 + SMA SZA /IS IT 2? + ISZ CHARNO /YES-BUMP RETURN + SZA CLA /IS IT 2 OR 3? + ISZ CHARNO /YES-BUMP RETURN + JMP I CHARNO /RETURN + + PAGE + /WRITE FUNCTION-PUTS NUMBERS IN FILE BUFFERS + +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 TEMP10 /SAVE + TAD (INTERB-1 + DCA SACXR /NOW POINT SACXR INTO BUFFER + TAD TEMP10 /GET COUNT OF CHARS TO BE PRINTED + CIA + TAD I IOTPOS /ADD TO PRINT HEAD POSITION + TAD (-WIDTH /COMPARE AGAINST "72" + 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 PUTCH /PUT ON DEVICE + ISZ TEMP10 /BUMP COUNTER + JMP CPLOOP /NEXT + TAD O240 + JMS PUTCH /SEND OUT A SPACE AFTER NUMBER + JMP WDONE /TAKE COMMON EXIT +WIMAGE, JMS I [BUFCHK /FILE IS NUMERIC-CHECK BUFFER STATUS +O240, 240 /PAST END-NEW RECORD (AND INST SERVES AS NOP) +O210, 0210 /AT END-NEW RECORD (AND SERVES AS NOP) + JMS I [NEXREC /ONE WORD LEFT-DON'T USE IT + 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 + /ROUTINE TO PUT ASCII CHARS IN FILE BUFFER. IGNORES RUBOUTS. + +PUTCH, 0 + DCA TEMP1 /SAVE CHAR + TAD TEMP1 /GET CHAR AGAIN + TAD (-377 + SNA CLA /IS IT A RUBOUT? + JMP I PUTCH /YES-RETURN + JMS I [FTYPE /IS FILE NUMERIC? +SW, JMS I [ERROR /YES-ERROR + ISZ I IOTPOS /BUMP COULMN NUMBER + TAD ENTNO /GET ENTRY # + SNA CLA /IS IT TTY? + JMP TOUT /YES-JUST PUT CHARS IN RING BUFFER + JMS I [BUFCHK /NO-IS BUFFER FULL? + JMS I [NEXREC /YES-NEXT RECORD +O40, 40 /THERE IS A CHAR 3 LEFT (AND IS A NOP) +O20, 20 /THERE IS A CHAR 2 AND 3 LEFT (AND IS A NOP) + TAD TEMP1 /GET CHAR AGAIN + JMS I [PACKCH /PUT IN BUFFER + JMP I PUTCH /RETURN + +TOUT, TAD TEMP1 /GET CHAR + JMS I [XPUTCH /PUTCH CHAR IN OUTPUT BUFFER FOR TTY + JMP I PUTCH /RETURN + /SUBROUTINE NEXREC-WRITES THIS BUFFER IN FILE,THEN READS IN NEXT BUFFER +/IF POSSIBLE,ELSE SETS EOF BIT. IF DEVICE IS READ OR WRITE ONLY +/IT JUST READS OR WRITES A BLOCK,WHICHEVER IS APPROPRIATE + +NEXREC, 0 + TAD I IOTHDR /GET HEADER + AND O20 /GET READ/WRITE ONLY BIT + SNA CLA /IS IT ON? + JMP FILSTR /NO-DEVICE IS FILE STRUCTURED + JMS I (FOTYPE /YES-IS IT INPUT OR OUTPUT FILE? + JMP RONLY + JMS WRBLK +RWONC, ISZ I IOTBLK + JMS BLINIT /INIT FILE TABLE ENTRIES + JMP I NEXREC /DONE + +RONLY, JMS BLREAD + JMP RWONC + +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 O210 /"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 O40 /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 (7437 /SET CHAR # TO 1 AND CLEAR BLOCK WRITTEN BIT + DCA I IOTHDR + JMP I BLINIT + +/ROUTINE TO SAVE THE FAC IN FP TEMP + +FACSAV, 0 + JMS I [FFPUT /STORE FAC + INTERB /USE INTERMEDIATE BUFFER FOR TEMP STORAGE + JMP I FACSAV /RETURN + + PAGE + + + + + + +///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// +//////////// OVERLAY BUFFER 3400-4600 //////////////////// +//////////// CONTAINS FUNCTION OVERLAYS //////////////////// +//////////// AT RUN TIME //////////////////// +///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// + + + ///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// +////////////// OVERLAY 1-ARITHMETIC FUNCTIONS /////////////// +///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// + + *OVERLAY + + + +/INTEGER FUNCTION +/RANGE=ALL X + +INT, VERSON^100+SUBVAF+6000 /INITIALLY CONTAINS VERSION OF ARITH OVERLAY + 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 TEMP3 /FLAG FOR NEGATIVE + DCA TEMP5 /ZERO LORD MASK + CLL CML RAR + DCA TEMP4 /INITIALIZE HORD MASK TO 4000 + TAD ACX + CIA /- COUNT + DCA TEMP2 +MASKL, TAD TEMP4 + CLL CML RAR /ROTATE 1'S THROUGH 3 WORD MASK + DCA TEMP4 / + TAD TEMP5 /UNTIL THERE IS A COUNT OF ZERO + RAR + DCA TEMP5 + ISZ TEMP2 /DONE? + JMP MASKL /NO + TAD ACH /YES-MASK HORD + AND TEMP4 + DCA ACH + TAD ACL /MASK LORD + AND TEMP5 + DCA ACL + TAD TEMP3 /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 TEMP3 + JMS I [FACCLR /FLUSH FAC + TAD TEMP3 /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 + + /EXPONENTIATION FUNCTION +/IF B=0,A^B=1 +/IF A=0 AND B>0,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 + JMS I [FFPUT /SET UP RUNNING PRODUCT IN CASE OF + FPPTM4 /MULTIPLIES + 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 I (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 INT /GET INT(B) + JMS I (MULLIM /TEST EXPONENT OF RESULT TO LIMIT LARGE MULTIPLY LOOPS + JMS I (FFSUB /INT(B)-B + FPPTM3 + TAD ACH /IS INT(B)-B=0? + SZA CLA + JMP I (USELOG /NO-USE LOGS + JMS I [FFGET /NO-USE REPETITIVE MULTIPLY + FPPTM3 /GET B AGAIN + TAD ACH + DCA EXPON /SAVE SIGN OF B + JMS I (ABSVAL /!B! + JMS I [FFPUT /USE ABS(B) AS MULTIPLY COUNT + FPPTM3 +EMLOOP, JMS I [FFGET /GET B + FPPTM3 + JMS I (FFSUB /B-1 + ONE + JMS I [FFPUT /SAVE NEW COUNT + FPPTM3 + TAD ACH + SNA CLA /IS COUNT ZERO YET + JMP I (EMDONE /YES-MULTIPLIES ARE DONE + JMS I [FFGET /NO-GET RUNNING PRODUCT + FPPTM4 + JMS I (FFMPY /MULTIPLY BY A + FPPTM5 + JMS I [FFPUT /SAVE NEW RUNNING PRODUCT + FPPTM4 + JMP EMLOOP + +RET0, JMS I [FACCLR /RETURN WITH 0 IN FAC + JMP I [ILOOP + + PAGE + EMDONE, JMS I [FFGET /GET RUNNING PRODUCT + FPPTM4 + TAD I EXPONK /GET SIGN OF B + SMA CLA /WAS IT -? + JMP I [ILOOP /NO-A^B=A*A*A*...*A + JMS I FIDVP /YES-INVERT + ONE + JMP I [ILOOP /A^B=1/A:A*A*...*A + +RETRN1, JMS I [FFGET + ONE /SET FAC TO 1 + JMP I [ILOOP + +USELOG, TAD I EXPONK /SIGN OF A + SPA CLA /A<0? +EM, JMS I [ERROR /YES-PRINT A MESSAGE + JMS I [FFGET /LOAD A + FPPTM5 + JMS I FFLOGL /LOG(A) + JMS I FMPYLV /B*LOG(A) + FPPTM3 + JMS I FFEXPL /EXP(B*LOG(A)) + JMP I [ILOOP /DONE + + +FFEXPL, EXPON1 +FFLOGL, LOG +FMPYLV, FFMPY +EXPONK, EXPON +FIDVP, FFDIV1 + +/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 + 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 + 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 ACH + SNA + JMP I FROOT /ZERO FAC-NORMALIZED!-RETN. SAME + SPA CLA + JMS I [FFNEG /TAKE ROOT OF ABSOL VALUE + 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 FROOT /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 + *SGN+14 +FROOT, 0 + 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 FROOT /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 + JMP I FROOT /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 TEMP1,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 TEMP1,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 + +MULLIM, 0 + TAD ACX /CHECK IF NUMBER OF MULTIPLIES IS TOO LARGE + SPA + CLA /RETURN IF EXPONENT IS NEGATIVE (WE'LL USE LOGS) + TAD (-4 /ONLY A ROUGH ROUGH LIMIT ON THE EXPONENT + SPA SNA CLA /SKP IF NUMBER GT 15 APPROX + JMP I MULLIM /NO, CONTINUE + JMP I (USELOG /YES, USE LOG INSTEAD + + 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 + *4500 + + /******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 + /RANDOM NUMBER GENERATOR + +RND, 0 + TAD I (RSEED /GET SEED + DCA TEMP3 /PUT IN MULTIPLY OPERAND + TAD (73 + JMS I [MPY /MULTIPLY SEED BY 73 + DCA I (RSEED /USE LOW ORDER 12 BITS AS NEW SEED + TAD I (RSEED /LOW ORDER OF PRODUCT ALSO SERVES + CLL RAR /AS RANDOM NUMBER + DCA ACH /SET SIGN TO 0 AND STORE AS HORD + DCA ACX + RAR + DCA ACL /USE 12 BITS AS MANTISSA + DCA AC1 /CLEAR FPP OVERFLOW + JMS I [FFNOR /AND NORMALIZE + JMP I [ILOOP /DONE + + 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 ("- /PRINT MINUS SIGN + SKP +OKPOS, TAD (240 /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 (". + 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 ("E /PRINT E + DCA I XR1 +/ CLL + TAD DECEXP /TAKE ABS(DECEXP) + SPA + CML CIA + DCA DECEXP + RTL /CONVERT "+" TO "-" IF NEGATIVE + TAD ("+ + 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 (". /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 (". /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 ("0 /ADD IN 0 + DCA I XR1 /STORE IN BUFFER + JMP I PUTD + + 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 INTIGER BITS + /DDDD ARE LT 10. + /DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10. + +CVTNUM, 0 + DCA AC1 /CLEAR OVERFLOW WORD + SKP /SKP IN AND CLEAR DECIMAL EXPONENT +ADJDEC, TAD DECEXP + DCA DECEXP /STORE UPDATED DECIMAL EXPONENT +NORML, TAD ACH /SEE IF FRACTION IS NORMALIZED + RAL + SPA CLA + JMP NORMED /JMP IF YES + JMS I (AL1 /SHIFT AC LEFT 1 BIT + STA + TAD ACX /COMPENSATE BINARY EXPONENT + DCA ACX + JMP NORML /TRY AGAIN +NORMED, TAD ACX /RANGE CHECK BINARY EXPONENT NOW + SMA SZA + JMP DIVCHK /JMP IF NUMBER GE 1 + TAD O4 + DCA ACX /INCREASE BINARY EXP TOWARDS ZERO + JMS AR1 /SHIFT 4 BITS RIGHT + JMS AR1 /MAX RELATIVE ERROR WILL BE LT 15*2^-34 PER MULTIPLY + JMS AR1 + JMS AR1 + JMS MPY10 /NOW MULTIPLY BY 10. + STA /DECREASE DECIMAL EXPONENT + JMP ADJDEC /RENORMALIZE AND TRY AGAIN + +DIVCHK, TAD (-5 /SEE IF EXP GT 4 + SPA + JMP INRANG /JMP IF NOT, NUMBER MAY BE IN RANGE +DIVGO, CLA CLL + TAD (-40 /SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE) + DCA AC2 /(THE LEN ELEKMAN TECHNIQUE) + /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 + IAC /NOW INCREASE DECIMAL EXPONENT + JMP ADJDEC + +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 MPY10 /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-- + + /MULTIPLY ACH,,ACL,,AC1 BY 10. + +MPY10, 0 + TAD ACH + DCA OPH /COPY AC TO OP + TAD ACL + DCA OPL + TAD AC1 + DCA AC2 + JMS I (AL1 /N*2 + JMS I (AL1 /N*4 + JMS I (OADD /N*5 + JMS I (AL1 /N*10. + JMP I MPY10 + + /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 + IFZERO EAE < + +/FLOATING POINT INPUT ROUTINE + +FFIN, 0 + CLA CMA + DCA I FDVPT /INITIALIZE PERIOD SWITCH TO -1 + CMA /SET SIGN SWITCH TO -1 + DCA SIGNF + CDF /DF TO PACKAGE FIELD + DCA DSWIT /ZERO CONVERSION SWITCH +DECONV, DCA ACX /ZERO OUT THE FAC! + DCA ACL +P200, 200 + DCA ACH +DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT. +DECON, JMS GCHR /GET A CHAR.FROM TTY. + JMP FFIN1 /TERMINATOR- + ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH + ISZ DNUMBR /BUMP # OF DIGITS-# IS STORED IN + JMS I FMPYLL /"FMPY TEN" + TEN + JMS I [FFPUT /"FPUT I TM3PT" + FPPTM1 + JMS I [FFGET /"FGET TP" + TP + JMS I [FFNOR /"FNOR" + JMS I FADDLL /"FADD I TM3PT" + FPPTM1 + JMP DECON /GO ON +FFIN1, ISZ I FDVPT /HAVE WE HAD A PERIOD YET? + JMP FIGO2 /YES-GO ON + ISZ TP1 /NO-IS THIS A PERIOD? + ISZ TP1 + SKP CLA + JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT. + /AND GO CONVERT REST + DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF + /DIGITS AFTER DECIMAL POINT. +FIGO2, ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?) + JMS I FFNEGP /YES-NEGATE IT + CLA CMA /RESET SIGN SWITCH FOR EXP. + DCA SIGNF + TAD CHAR /NO-WAS THE TERMINATOR AN 'E'? + TAD KME + SNA CLA +GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT + JMP EDON /END OF EXPONENT + TAD TM /GOT DIG. OF EXP-STORED IN TP1 + CLL RTL /MULT. ACCUMULATED EXP BY 10 + TAD TM + CLL RAL + TAD TP1 /ADD DIGIT + JMP GETE /CONTINUE + EDON, TAD TM /GET EXPONENT + ISZ SIGNF /WAS EXPONENT NEGATIVE? + CMA IAC /YES-NEGATE IT + CMA IAC /AND CALC. DNUMBR - EXPON. + TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN + CLL CMA IAC + SPA /RESULT POSITIVE? + CLL CMA CML IAC /NO-MAKE POS. AND SET LINK + CMA /NEGATE FOR COUNTER + DCA DNUMBR /AND STORE + RAL /LINK=1-DIV;=0-MUL. # BY TEN + TAD MDV /FORM CORRECT INSTRUCTION + DCA SIGNF /AND STORE FOR EXECUTION +FCNT, ISZ DNUMBR /DONE ALL OPERATIONS? + JMP SIGNF /NO + JMP I FFIN /YES-RETURN +SIGNF, 0 /NO- MUL OR DIV. MANTISSA + TEN /BY TEN + JMP FCNT /GO ON +FFNEGP, FFNEG +DNUMBR, 0 +KME, -305 +MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER +FMPYLL, FFMPY +FDVPT, FFDIV /!!!!!!!!!!!!!!!!! +FADDLL, FFADD + +KK12, 12 +TP, 13 +TP1, 0 + 0 +TEN, 4 + 2400 + 0 + /ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT +/OR A TERMINATOR. +/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT +/THIS ROUTINE MUST NOT MODIFY THE MQ!! +GCHR, 0 + DCA TM /STORE ACCUMULATED EXPONENT (MAYBE) + JMS INPUT /GET A CHAR FROM TTY. + TAD CHAR /PICK IT UP + TAD PLUS /WAS IT PLUS SIGN? + SNA + JMP DECON1 /YES-GET ANOTHER CHAR. + TAD MINUS /NO WAS IT MINUS SIGN? + SZA CLA + JMP .+3 + DCA SIGNF /YES-FLIP SWITCH +DECON1, JMS INPUT /GET A CHAR. + TAD CHAR + TAD K7506 /SEE IF ITS A DIGIT + CLL + TAD KK12 + DCA TP1 /STORE FOR LATER + SZL /DIGIT? + ISZ GCHR /YES-RETN. TO CALL+2 + JMP I GCHR /NO-RETN. TO CALL+1 +K7506, 7506 +/ +/INPUT ROUTINE-IGNORES LEADING SPACES +/ +INPUT, 0 + JMS I IGETCH /USE OUR ROUTINE TO GET CHAR + TAD DSWIT /GET TERMINATOR + SZA CLA /VALID INPUT YET? + JMP IOUT /YES-CONTINUE + TAD CHAR /NO-GET CHAR + TAD M240 /COMPARE AGAINST SPACE + SZA /SKP IF SPACE + TAD (240-212 /COMPARE TO LF + SNA CLA /IS IT A SPACE OR LF? + JMP INPUT+1 /YES-IGNORE IT +IOUT, JMP I INPUT /RETURN +IGETCH, GETCH /POINTER TO GET CHAR ROUTINE + /ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL) +M240, -240 +PLUS, -253 +MINUS, 253-255 +/ +/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 +/ +/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 ARGETL /GO PICK UP OPERAND + CDF + JMS I FFNEGA /NEGATE FAC + TAD FFSUB1 /AND GO ADD + JMP I SUB0P +FFNEGA, FFNEG +SUB0P, 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 ARGETL /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 FFDP + TAD KFD1 + DCA I MDSETP + JMP I MD1P /GO SET UP AND DIVIDE + +MD1P, MD1 +ARGETL, ARGET +MDSETP, MDSET +FFDP, FFDIV +KFD1, FFD1 + /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 ARGETK /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 OPNEGP /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 FFNEGK /YES-NEGATE IT + ISZ TM /BUMP SIGN CHECK + NOP /MAY SKIP +LEV, TAD OPX /EXIT WITH OPERAND EXPONENT IN AC + JMP I MDSET + +FFNEGK, FFNEG +OPNEGP, OPNEG +ARGETK, ARGET + +/ +/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 DVOPSP /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV. + CLL /OK-DO (REM-(Q*OPL))/OPH + DCA ACH /FIRST STORE ADJUSTED PRODUCT + JMS I DV24P /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 FDDONP /GO LEAVE DIVIDE + +FDDONP, FDDON /END OF FLTG. DIV. ROUTINE +DV24P, DV24 /ROUTINE TO DO A 24X12BIT DIVIDE +DVOPSP, DVOPS /ROUTINE TO ADJUST QUOT OF FIRST DIV. +/ +/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 DV24P /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 + + 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 MDSETK /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 FFNEGR /YES-NEGATE IT + JMP I FFMPY /RETURN +SHLFT, CMA /SUBTRACT 1 FROM EXP. + TAD ACX + DCA ACX + JMS I AL1PTR /SHIFT FAC LEFT 1 BIT + JMP MDONE+1 /DONE. +AL1PTR, AL1 +/ +/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 KKM12 /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 FD1P /GO ON +FD1P, FD1 /POINTER TO REST OF DIVIDE ROUTINE +/ +/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 MDSETK /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 KM13 /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 DVOVR /NO-DIVIDE OVERFLOW + TAD KM13 /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 +FFNEGR, FFNEG +MDSETK, MDSET +KKM12, -14 +KM13, -15 +DVOVR, DV + + PAGE + / +/FLOATING ADD +/ +FFADD, 0 + JMS I [PATCHF /WHICH MODE FO CALL? + TAD I FFADD /CALLED BY USER-GET ADDR. OF OPR. + JMS I ARGETP /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 + TAD ACX /NO-DO EXPONENT CALCULATION + CLL CMA IAC + TAD OPX + SMA SZA /WHICH EXP. GREATER? + JMP FACR /OPERANDS-SHIFT FAC + CMA IAC /FAC'S-SHIFT OPERAND=DIFFRNCE+1 + 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 FNORP /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 DBAD1P /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 ARGETP /PICK UO THE OP. + JMS OPNEG /NEGATE OPERAND + TAD FFSUB /JMP INTO FLTG. ADD +SUB0, DCA FFADD /AFTER SETTING UP RETURN + JMP FAD1 +ARGETP, ARGET + *6135 +/ +/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. +DBAD1P, DBAD1 +FNORP, FFNOR + > + 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 + / + TM= TEMP4 + / +/FLOATING POINT INPUT ROUTINE +/ + PAGE +FFIN, 0 + CLA CMA + DCA PRSW /INITIALIZE PERIOD SWITCH TO -1 + CMA /SET SIGN SWITCH TO -1 + DCA SIGNF + CDF /CHANGE TO DF OF PACKAGE + DCA DSWIT /ZERO CONVERSION SWITCH +DECONV, DCA ACX /ZERO OUT THE FAC! + DCA ACL + DCA ACH +DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT. +DECON, JMS GCHR /GET A CHAR.FROM TTY. + JMP FFIN1 /TERMINATOR- + ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH + ISZ DNUMBR /BUMP # OF DIGITS + DCA TP1 /STORE IT IN FORM EASILY FLOATIBLE + JMS I FMPYLL /MULTIPLY # BY 10 + TEN + JMS I [FFPUT /STORE IT AWAY + FPPTM1 + JMS I [FFGET /GET NEW DIGIT + TP + JMS I [FFNOR /FLOAT IT + JMS I FADDLL /ADD IT TO THE ACCUMULATED # + FPPTM1 + JMP DECON /GO ON +FFIN1, ISZ PRSW /HAVE WE HAD A PERIOD YET? + JMP FIGO2 /YES-GO ON + TAD K2 /NO-IS THIS A PERIOD? + SNA CLA + JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT. + /AND GO CONVERT REST + DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF + /DIGITS AFTER DECIMAL POINT. +FIGO2, CLA MQL /0 TO MQ FOR LATER MULTIPLY + ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?) + JMS I FFNEGP /YES-NEGATE IT + SWAB + CMA /RESET SIGN SWITCH FOR EXP. + DCA SIGNF + TAD CHAR /NO-WAS THE TERMINATOR AN 'E'? + TAD KME + SNA CLA +GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT + JMP EDON /END OF EXPONENT + MUY /GOT DIGIT OF EXP-MULT ACCUMULATED + K12 /EXPONENT BY TEN AND ADD DIGIT + JMP GETE /CONTINUE + EDON, ISZ SIGNF /WAS EXPONENT NEGATIVE? + DCM /YES-NEGATE IT + CLA CLL /CLEAR AC AND LINK + TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN + SAM /SUBTRACT FROM EXPONENT + CLL + SPA /RESULT POSITIVE? + CLL CMA CML IAC /NO-MAKE POS. AND SET LINK + CMA /NEGATE FOR COUNTER + DCA DNUMBR /AND STORE + RAL /LINK=1-DIV;=0-MUL. # BY TEN + TAD MDV /FORM CORRECT INSTRUCTION + DCA FINST /AND STORE FOR EXECUTION +FCNT, ISZ DNUMBR /DONE ALL OPERATIONS? + JMP FINST /NO + JMP I FFIN /YES-RETURN +FINST, 0 /NO- MUL OR DIV. MANTISSA + TEN /BY TEN + JMP FCNT /GO ON +FFNEGP, FFNEG +PRSW, 0 +DNUMBR, 0 +SIGNF, 0 +K2, 2 +KME, -305 +MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER +FMPYLL, FFMPY + FFDIV /!!!!!!!!!!!!!!!!! +FADDLL, FFADD + +K12, 12 +TP, 13 +TP1, 0 + 0 +TEN, 4 + 2400 + 0 + /ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT +/OR A TERMINATOR. +/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT +/THIS ROUTINE MUST NOT MODIFY THE MQ!! +GCHR, 0 + JMS INPUT /GET A CHAR FROM TTY. + TAD CHAR /PICK IT UP + TAD PLUS /WAS IT PLUS SIGN? + SNA + JMP DECON1 /YES-GET ANOTHER CHAR. + TAD MINUS /NO WAS IT MINUS SIGN? + SZA CLA + JMP .+3 + DCA SIGNF /YES-FLIP SWITCH +DECON1, JMS INPUT /GET A CHAR. + TAD CHAR + TAD K7506 /SEE IF ITS A DIGIT + CLL + TAD K12 + SZL /DIGIT? + ISZ GCHR /YES-RETN. TO CALL+2 + JMP I GCHR /NO-RETN. TO CALL+1 +K7506, 7506 +PLUS, -253 +MINUS, 253-255 +/ +/ +/INPUT ROUTINE-IGNORES LEADING SPACES +/ +INPUT, 0 + JMS I IGETCH /USE OUR ROUTINE TO GET CHAR + TAD DSWIT /GET TERMINATOR + SZA CLA /VALID INPUT YET? + JMP IOUT /YES-CONTINUE + TAD CHAR /NO-GET CHAR + TAD M240 /COMPARE AGAINST SPACE + SZA + TAD (240-212 /IS IT AN LF? + SNA CLA /IS IT A SPACE OR LF? + JMP INPUT+1 /YES-IGNORE IT +IOUT, JMP I INPUT /RETURN +M240, -240 +IGETCH, GETCH /ALTERED BY VAL FUNCITON TO PICK FROM SAC +/ +/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 SUBTRACT-USES FLOATING ADD +/FSW1!! +FFSUB1, 0 + JMS I [PATCHF /WHICH MODE? + TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP + JMS I ARGETL /PICK UP ARGUMENT + CDF + JMS I FFNEGA /NEGATE FAC! + TAD FFSUB1 + JMP I SUB0P +FFNEGA, FFNEG +SUB0P, 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 ARGETL /(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 FFDP /NORMAL DIVIDE ROUTINE + TAD FD1 + DCA I MDSETP + JMP I MD1P /GO ARRANGE OPERANDS + +MD1P, MD1 +ARGETL, ARGET +MDSETP, MDSET +FFDP, FFDIV +FD1, FFD1 + + +/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 + / +/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) + PAGE +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 +ARGETK, ARGET +DVOFL, DV + +/ +/ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE +/ +MDSET, 0 + JMS I ARGETK /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 +/ + *5722 +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 DVOFL /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 DVOPSP /YES-ADJUST FIRST DIVIDE + DVI /NO-DO Q*OPL*2**-12/OPH + OPL + SZL CLA /DIV ERROR? + JMP I DVOFL /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. + +DVOPSP, DVOPS +DBAD, CAM + DCA ACX /ZERO EXPONENT + JMP DBAD1 /GO ZERO MANTISSA + /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. +/ + PAGE +FFADD, 0 + JMS I [PATCHF /WHICH MODE OF CALLING + TAD I FFADD /CALLED DIRECTLY BY USER + JMS I ARGETP /PICK UP ARGUMENTS + JMP I PATCHK /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 ADDPCL /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 +ARGETP, ARGET +/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 ARGETP + 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 DVOVR /YES + DCM /NO-ADJUST HI QUOT (MAYBE) + JMP I DVLP1P /GO BACK +DVLP1P, DVLP1 +DVOVR, DV +ADDPCL, ADDPCH +PATCHK, PTCHAD + > + 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 + IFZERO EAE < + NOP + NOP + > + + 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 +/ + *6215 +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 + + *6241 +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 + > + / +/FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF +/ + *6347 +A, +FFSQ, 0 + JMS I TMPY /CALL MULTIPLY TO MULTIPLY + ACX /FAC BY ITSELF + JMP I FFSQ /DONE +TMPY, FFMPY +/ +/ 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 + + PAGE + + *OVERLAY+3000 + + +/TELETYPE "DRIVER"-WHEN CALLED,GRABS CHARACTERS FROM THE +/TELETYPE UNTIL A CR IS SENT OR THE BUFFER IS FULL. ASSUMES TTY ENTRY +/IS IN I/O WORK AREA. + +TTYDRI, 0 + JMP LFLUSH+1 +IO, JMS I [ERROR +LFLUSH, JMS I [CRLFR /PRINT A CR,LF + TAD K277 /PRINT A ? SIGNIFYING WAIT FOR INPUT + JMS I [XPUTCH + TAD I IOTBUF /BUFFER ADDRESS + DCA I IOTPTR /INITIALIZE POINTER TO START OF BUFFER + JMS I [CNOCLR /INITIALIZE CHAR # TO 1 +TTYIN, JMS I [XPRINT /EMPTY TTY BUFFER BEFORE AWAITING INPUT + JMP .-1 + TAD I (HEIGHT /ALWAYS RESET SCREEN HIEGHT ON INPUT + DCA I (HCTR + TAD K5252 /DESIGN INTO AC +KSFA, KSF /CHAR READY? + JMP SPIN /NO-DIDDLE WHILE WE WAIT + CLA CLL /FLUSH SPINNER OUT OF AC + TAD [200 /FORCE PARITY BIT + KRS /GET CHAR + DCA CHAR /SAVE + TAD CHAR + JMS I [XPUTCH /ECHO IT + KCC /CLEAR KEYBOARD FLAG AND SET READER RUN + TAD CHAR + TAD MCTRLU /IS IT CTRL/U? + SNA CLA + JMP LFLUSH /YES-START AGAIN + TAD CHAR /NO + TAD CRUBOT /IS IT RUBOUT? + SNA + JMP BACKUP /YES-BACK UP BUFFER POINTER + TAD MCR /NO-IS IT CR? + SNA CLA + JMP CR /YES-DONE + TAD CHAR + JMS I [PACKCH /PACK CHAR IN BUFFER + JMS I [BUFCHK /BUFFER FULL? + JMP IO /YES-ERROR + NOP /NO-CHAR 3 LEFT + NOP /NO-2 AND 3 LEFT + JMP TTYIN /NO-NEXT CHAR +MCTRLU, -225 +MCR, 377-215 +CRUBOT, -377 +K5252, 5252 +K277, 277 + +BACKUP, TAD I IOTPTR /BUFFER POINTER + CIA /NEGATE + TAD I IOTBUF /COMPARE AGAINST START OF BUFFER + SNA CLA /BUFFER EMPTY? + JMP TTYIN /YES-THERE IS NOTHING TO RUBOUT + TAD SCOPFG /TEST IF CONSOLE IS A SCOPE + SNA CLA + JMP NOSCOP /JMP IF NOT + TAD (10 + JMS I [XPUTCH /PRINT BS,SP,BS TO RUBOUT IF SCOPE + TAD (40 + JMS I [XPUTCH + TAD (10 + SKP +NOSCOP, TAD K334 + JMS I [XPUTCH /ECHO "\" + JMS I [CHARNO /GET CHAR # OF NEXT CHAR (LAST #+1) + JMP C1B /1 + JMP C3B /3 + JMS I [CNOCLR /IT WAS 2-MAKE IT 1 +PBACK, CLA CMA /-1 + TAD I IOTPTR /BACK UP BUFFER POINTER + DCA I IOTPTR + JMP TTYIN /NEXT CHAR +K334, 334 + +C1B, TAD I IOTHDR + AND [7477 + TAD [200 /IT WAS 1-MAKE IT 3 + DCA I IOTHDR + JMP TTYIN /NO NEED TO BACK UP POINTER + +C3B, TAD I IOTHDR + AND [7477 + TAD [100 /IT WAS 3,MAKE IT 2 + DCA I IOTHDR + JMP PBACK /BACK UP POINTER + + +CR, JMS I [CRLFR /ECHO A CR,LF + TAD K4 + TAD TTYDRI /BUMP DRIVE RETURN TO NORMAL + DCA TTYDRI + TAD CHAR + JMS I [PACKCH /PACK CHAR IN BUFFER + TAD I IOTBUF + DCA I IOTPTR /INITAILZE BUFFER POINTERS + JMS I [CNOCLR + JMP I TTYDRI /RETURN +K4, 4 + + +SPIN, ISZ SPINNR /SPIN RANDOM # SEED + SKP + CMA CML RAL /MARCH TO THE LEFT + JMP KSFA /CHECK FOR CHAR YET +SCOPFG, 0 /GETS SET TO SCOPE FLAG BY STARTUP CODE + /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 + +/DATA LIST READ (NUMERIC) + +RDLIST, JMS I (DLREAD /FETCH WORD FROM LIST + DCA ACX /STORE AS EXPONENT + JMS I (DLREAD + DCA ACH /HIGH MANTISSA + JMS I (DLREAD + DCA ACL /LOW MANTISSA + JMP I [ILOOP + +/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 + + PAGE + /LAST PAGE OF BRTS-CONTAINS SAC,I/O TABLE, AND SOME MISCELLANEOUS CODE + +/TELETYPE INPUT BUFFER (74. CHARACTERS LONG) +/THIS BUFFER CONTAINS ONCE ONLY START CODE WHEN LOADED + +TTYBUF, +START4, TAD CDFPS /DF FOR BOTTOM OF PSEUDO-CODE + TAD MCDF1 /COMPARE TO A CDF 10 + SZA CLA /DO THEY MATCH? + JMP I [ILOOP /NO-ALL BUFFERS ARE FREE-START INTERPRETER + TAD PSSTRT + CLL CMA + TAD [400 + SNL CLA /IS START OF PSEUDO-CODE BELOW 400 + JMP CHKB2 /NO-CHECK FOR 1000 + TAD [17 /YES-SET ALL BUFFERS BUSY + JMP BAS +CHKB2, TAD PSSTRT + CLL CMA + TAD C1000 + SNL CLA /IS START OF PSEUDO-CODE BELOW 1000 + JMP CHKB3 /NO-CHECK 1400 + TAD C16 /YES-ONLY BUFFER 1 IS AVAILABLE + JMP BAS +CHKB3, TAD PSSTRT + CLL CMA + TAD C1400 + SNL CLA /IS START OF CODE BELOW 1400? + JMP CHKB4 /YES-CHECK 2000 + TAD C14 /YES-ONLY BUFFER 1 AND 2 AVAILABLE + JMP BAS +CHKB4, TAD PSSTRT + CLL CMA + TAD K2000 + SNL CLA /IS CODE START BELOW 2000? + JMP I [ILOOP /NO-START INTERPRETER-ALL BUFFER FREE + TAD [10 /YES-BUFFERS 1,2, AND 3 AVAILABLE +BAS, DCA BMAP + JMP I [ILOOP /START INTERPRETER + 0 +MCDF1, -6211 +K2000, 2000 +C14, 14 +C16, 16 +C1000, 1000 +C1400, 1400 + ZBLOCK 10 +TTYEND, 0 + *OVERLAY+3277 + +//////////////////////////////////////////////////////////////// +/////// I/O TABLE 5 13-WORD ENTRIES //////////////////////////// +//////////////////////////////////////////////////////////////// + +TTYF, 1 /TELETYPE ENTRY-FILE IS ASCII + TTYBUF /BUFFER ADDRESS + 0 /CURRENT BLOCK IN BUFFER + TTYBUF /READ WRITE POINTER + TTYDRI /HANDLER ENTRY + ZBLOCK 10 +FILE1, ZBLOCK 15 /FILE #1 +FILE2, ZBLOCK 15 /FILE #2 +FILE3, ZBLOCK 15 /FILE #3 +FILE4, ZBLOCK 15 /FILE #4 + + PAGE + /CROSS FIELD LITERAL EQUATES + + PGETCH= [GETCH + PILOOP= [ILOOP + PPUTCH= [PUTCH + PSACM1= [SAC-1 + PXPUTCH= [XPUTCH + PXPRINT= [XPRINT + PFFNOR= [FFNOR + PFFGET= [FFGET + PFFPUT= [FFPUT + PUNSFIX= [UNSFIX + PERROR= [ERROR + PFACCLR= [FACCLR + PIDLE= [IDLE + PPSWAP= [PSWAP + PFTYPE= [FTYPE + USR= [200 + O200= [200 + O400= [400 + O100= [100 + O10= [10 + O17= [17 + O7400= [7400 + O77= [77 + O215= [215 + O7700= [7700 + M215= [-215 + ///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// +////////////// OVERLAY 2- STRING FUNCTIONS ///////////////// +///////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////// + + FIELD 1 + *2000 + RELOC OVERLAY + + /VERSION NUMBER WORD FOR STRING OVERLAY + + VERSON^100+SUBVSF+6000 + +/CHR$ FUNCTION +/RETURNS 1 6BIT CHAR STRING FOR THE VALUE OF X + +CHR, JMS I PUNSFIX /FIX X TO 12 BIT INTEGER + AND O77 /MASK TO 6BIT + DCA I (SAC /AND PUT INTO SAC + CMA + DCA SACLEN /SET SAC LENGTH TO 1 + JMP I (SSMODE /SET TO SMODE AND RETURN + +/ASC FUNCTION +/RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC + +ASC, TAD I (SAC /GET FIRST CHAR OF STRING + 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 TEMP2 /CLEAR FPP OVERFLOW + TAD (13 /SET EXP TO 11 + DCA ACX + JMS I PFFNOR /NORMALIZE + JMP I PILOOP /RETURN + + + +/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 SACLEN + TAD SACLEN /NOW SAVE COUNTER + DCA TEMP2 + TAD (INTERB-1 + DCA XR1 /POINT AT BUFFER +STRLUP, TAD I XR1 /GET A CHAR + AND O77 /MASK TO 6BIT + TAD (-40 /CROCK TO DELETE BLANKS + SZA + JMP .+3 + ISZ SACLEN /IGNORE THE BLANK + JMP .+3 + TAD (40 + DCA I SACXR /STORE IN SAC + ISZ TEMP2 + JMP STRLUP /LOOP FOR MORE + JMP I (SSMODE /DONE-RETURN IN SMODE + +/VAL FUNCTION +/RETURNS NUMBER IN FAC FOR STRING IN SAC + +VAL, 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 PGETCH /NOW RESTORE REAL INPUT ADDR + DCA I (IGETCH /RESTORE IN INPUT ROUTINE + JMP I PILOOP /DONE + +VALGET, 0 + TAD VALCNT /TEST NUMBER OF CHARS LEFT + SNA CLA + JMP EOVAL /NONE + ISZ VALCNT /ELSE BUMP + NOP + TAD I SACXR /GET A BYTE + TAD (240 + AND O77 + TAD (240 /CONVERT TO 8BIT + SKP +EOVAL, TAD O215 + DCA CHAR + JMP I VALGET /RETURN WITH CHAR IN 'CHAR' + +VALCNT, 0 + + PAGE + / DATE FUNCTION +/ RETURNS STRING OF THE FORM "MM/DD/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 + DCA DATEWD /STORE (DATE IS NOT A CLOSED SUBROUTINE) + CDF /DATE IS IN THE FORM MMM MDD DDD YYY + TAD DATEWD /PICK UP DATE + SZA CLA + TAD (-10 /RETURN 8. BYTES IF NOT NULL DATE + DCA SACLEN /SET SAC LENGTH + 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 ISOLATE MONTH + AND O7400 + CLL RTL + RTL + RAL + JMS PUTN /PUT "MM/" INTO THE SAC + TAD DATEWD /NOW GET DAY OF MONTH + AND (370 + CLL RTR + RAR + JMS PUTN /PUT "DD/" IN SAC + TAD DATEWD /FINALLY GET YEAR + AND (7 + TAD YEAREX /ADD TO EXTENSION BITS + TAD (106 /ADD 70. FOR BASE YEAR + JMS PUTN /PUT OUT "YY/" (EXTRA SLASH WILL BE IGNORED) + JMP I (SSMODE /RETURN IN STRING MODE + +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 + DCA I SACXR + TAD NLOW /SEND OUT LOW DIGIT + DCA I SACXR + TAD (57 + DCA I SACXR /SEND OUT "/" + DCA NHIGH /CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!) + JMP I PUTN +NHIGH, 0 +NLOW, 0 +DATEWD, 0 + /TRACE FUNCTION PRINTER. WHEN TRACE IS ENABLED,THIS ROUTINE +/PRINTS THE LINE # EACH TIME IT IS STORED + +TPRINT, JMS I (LMAKE /MAKE LINE # INTO FIVE DIGITS + TAD ("% + JMS I PXPUTCH /PRINT "%" + TAD (" + JMS I PXPUTCH /PRINT A SPACE + TAD (DIG1-1 /ADDR OF FIRST DIGIT-1 + DCA XR5 /IN XR5 +IGS, TAD I XR5 /GET DIGIT OF LINE NUMBER + DCA TCHR /SAVE IT + TAD (-"0 + TAD TCHR /COMPARE IT TO 0 + SNA CLA /IS IT A 0? + JMP IGS /YES-IGNORE LEADING ZEROES +PREST, TAD TCHR /NO-GET CHAR AGAIN + TAD M215 + SNA CLA /IS IT A CR? + JMP TDONE /YES-LINE NUMBER IS PRINTED + TAD TCHR /NO-GET CHAR A THIRD TIME + JMS I PXPUTCH /TYPE IT + TAD I XR5 /GET NEXT CHAR + DCA TCHR + JMP PREST /AND LOOP +TDONE, TAD (" + JMS I PXPUTCH /FOLLOW LINE # WITH A SPACE + TAD ("% + JMS I PXPUTCH /TYPE ANOTHER "%" + TAD (215 + JMS I PXPUTCH /TYPE,CR,LF + TAD (212 + JMS I PXPUTCH + JMS I PXPRINT /EMPTY RING BUFFER OF TRACE NUMBER + JMP .-1 + JMP I PILOOP /DONE +TCHR, 0 + + PAGE + /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 HOOKL /BY NOP ING INSTRUCTION AT TRHOOK +TRREST, JMP I PILOOP + +HOOKL, TRHOOK + +/ERROR ROUTINE + +ERRORR, JMS I PXPRINT /PURGE TTY RING BUFFER + JMP .-1 /BEFORE PRINTING ERROR + TAD ETABA /ADDR OF ERROR TABLE + DCA XR4 /POINTS INTO ERROR TABLE +FERRLP, TAD I XR4 /GET 2 CHAR ERROR CODE + DCA TEMP1 /SAVE + TAD TEMP1 + CLL RTR + RTR + RTR + AND O77 /STRIP TO 6 BIT + TAD K0300 /MAKE 8 BIT (LETTERS ONLY ALLOWED) + DCA ESTRNG /PUT IN MESSAGE + TAD TEMP1 /2 CHAR CODE AGAIN + AND O77 /SECOND CHAR + TAD K0300 /MAKE LETTER + DCA ESTRNG+1 /PUT IN MESSAGE + TAD I XR4 /GET ERROR CODE +1 + TAD I PERROR /COMPARE AGAINST RETURN ADDR + SZA CLA /MATCH? + JMP FERRLP /NO-TRY NEXT ONE + JMS LMAKE /MAKE THE LINE # INTO DECIMAL DIGITS + TAD ESTRA /ADDR OF MESSAGE + DCA XR5 +ETLOP, TAD I XR5 /GET MESSAGE CHAR + SPA /DONE? (MESSAGE ENDNS WITH - NUMBER + JMP FATCHK /YES-DETERMINE ERROR TYPE + JMS I PXPUTCH /NO-PUT CHAR IN RING BUFFER + JMP ETLOP + +FATCHK, CLA + TAD MFATAL /-ADDR OF FATAL ERRORS + TAD XR4 /ADDR OF THIS ERROR + SMA CLA /FATAL ERROR? + JMP I ERRETN /NO-NEXT INST + JMP I STOPI /YES-TERMINATE RUN + +ERRETN, XERRRET +STOPI, FSTOPN + +MAKED, 0 + AND O17 /ISOLATE BCD DIGIT + TAD K260 /MAKE ASCII DIGIT + JMP I MAKED + +K260, 260 +K0300, 300 + /SUBROUTINE LMAKE-MAKES THE CURRENT LINE NUMBER INTO FIVE DIGITS +/STARTING AT DIG1 + +LMAKE, 0 + TAD LINEHI /YES:GET HI LINE # + JMS MAKED /GET DIGIT 2 + DCA DIG2 /PUT IN MESSAGE + TAD LINEHI + CLL RTR + RTR + JMS MAKED /GET DIGIT 1 + DCA DIG1 /AND PUT IN MESSAGE + TAD LINELO /DOGOTS 3,4, AND 5 + JMS MAKED /GET DIGIT 5 + DCA DIG5 + TAD LINELO + CLL RTR + RTR + JMS MAKED /GET DIGIT 4 + DCA DIG4 /AND PUT IN MESSAGE + TAD LINELO + CLL RAL + RTL + RTL + JMS MAKED /GET DIGIT 3 + DCA DIG3 /MESSAGE NOW COMPLETE + JMP I LMAKE + /ERROR MESSAGE + +EMESS, 215 + 212 +ESTRNG, 0000 + 0000 + " + "A + "T + " + "L + "I + "N + "E + " +DIG1, 0 +DIG2, 0 +DIG3, 0 +DIG4, 0 +DIG5, 0 + 215 + 212 +ESTRA, EMESS-1 /MINUS NUMBER TO END ABOVE MESSAGE + /ERROR TABLE /ENTRY FORMAT- 2 CHAR 6-BIT ERROR CODE (LETTERS ONLY) +/ -(ADDR OF CALL)-1 + +ETABA, ETAB-1 +MFATAL, -EFATAL +ETAB, 0602 /FB + -FB-1 /ATTEMPT TO OPEN AN ALREADY OPEN FILE + 0722 /GR + -GR-1 /RETURN WITHOUT A GOSUB + 2622 /VR + -VR-1 /ATTEMPT TO READ VARIABLE LENGTH FILE + 2325 /SU + -SU-1 /SUBSCRIPT ERROR + 0405 /DE + -DE-1 /DEVICE DRIVER ERROR + 1705 /OE + -OE-1 /DRIVER ERROR WHILE OVERLAYING + 0615 /FM + -FM-1 /ATTEMPT TO FIX MINUS NUMBER + 0617 /FO + -FO-1 /ATTEMPT TO FIX NUMBER >4095 + 0616 /FN + -FN-1 /ILLEGAL FILE # + 2303 /SC + -SC-1 /ATTEMPT TO OVERFLOW SAC ON CONCATENATE + 0611 /FI + -FI-1 /ATTEMPT TO CLOSE OR USE UNOPENED FILE + 0401 /DA + -DA-1 /ATTEMPT TO READ PAST END OF DATA LIST + 0723 /GS + -GS-1 /TOO MANY NESTED GOSUBS + 2322 /SR + -SR-1 /ATTEMPT TO READ STRING FROM NUMERIC FILE + 2327 /SW + -SW-1 /ATTEMPT TO WRITE STRING INTO NUMERIC FILE + 2001 /PA + -PA-1 /ILLEGAL ARG IN POS + 0603 /FC + -FC-1 /OS/8 ERROR WHILE CLOSING TENTATIVE FILE + 0311 /CI + -CI-1 /INQUIRE FAILURE IN CHAIN + 0314 /CL + -CL-1 /LOOKUP FAILURE IN CHAIN + 1116 /IN + -IN-1 /INQUIRE FAILURE IN OPEN + 0417 /DO + -DO-1 /NO MORE ROOM FOR DRIVERS + 0605 /FE + -FE-1 /FETCH ERROR IN OPEN + 0217 /BO + -BO-1 /NO MORE FILE BUFFERS AVAILABLE + 0516 /EN + -EN-1 /ENTER ERROR IN OPEN + 1106 /IF + -IF-1 /ILLEGAL DEV:FILENAME SPECIFICATION + 2314 /SL + -SL-1 /STRING TOO LONG OR UNDEFINED + 1726 /OV + -O0-1 /NUMERIC OR INPUT OVERFLOW + 1415 /LM + -LM-1 /ATTEMPT TO TAKE LOG OF NEG # OR 0 + 0515 /EM + -EM-1 /ATTEMPT TO EXPONENTIATE A NEG NUMBER TO A REAL ROWER + 1101 /IA + -IA-1 /ILLEGAL ARGUMENT IN USER FUNCTION + 0330 /CX + -CX-1 /ILLEGAL FILENAME EXTENSION IN A CHAIN STATEMENT +/*********************************************************** +EFATAL, /ERRORS BEFORE THIS LABEL ARE FATAL +/******************************************************* + 2205 /RE + -RE-1 /ATTEMPT TO READ PAST EOF + 2705 /WE + -WE-1 /ATTEMPT TO WRITE PAST EOF + 0426 /DV + -DV-1 /ATTEMPT TO DIVIDE BY 0 + 2324 /ST + -ST-1 /STRING TRUNCATION ON INPUT + 1117 /IO + -IO-1 /TTY INPUT BUFFER OVERFLOW + T= . + *ETAB + *T +/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 + TAD I XR2 /NOW MOVE THE BYTES + DCA I SACXR + ISZ STRCNT + JMP .-3 + JMP I PILOOP /--RETURN-- +NULLST, CLA CLL + DCA SACLEN /ZERO SAC + JMP I PILOOP /--RETURN-- +YARG, 0 + + PAGE + /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 TEMP3 /COUNTER +SRCLP, JMS I (LDB + CIA + TAD I SACXR /COMPARE CHARS + 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 TEMP3 /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 + RELOC + +////////////////////////////////////////////////// +////////////////////////////////////////////////// +///////// OVERLAY 3-FILE MANIPULATING //////////// +///////// FUNCTIONS //////////// +////////////////////////////////////////////////// +////////////////////////////////////////////////// + + *3400 + + /FILE CLOSING ROUTINE + + VERSON^100+SUBVFF+6000 /VERSION WORD FOR FILES OVERLAY + +ANDPTR, ANDLST +ANDLST, 7776 /MASKS FOR CLEARING BUFFER AND HANDLER STATUS BITS + 7775 + 7773 + 7767 + +CLOSE, TAD ENTNO /GET FILE # + SNA CLA /IS IT TTY? + JMP I PILOOP /YES-DON'T DO ANYTHING + JMS I PIDLE /SEE IF FILE OPEN + 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 (232 /YES + JMS I PPUTCH /WRITE A ^Z IN FILE +NOCZ, JMS I (WRBLK /WRITE LAST BLOCK IF IT HAS CHANGED + 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, . /POINTER TO FILE NAME +CLENG, . +FC, JMS I PERROR /FILE CLOSING ERROR +CLOSED, TAD I IOTBUF /GET BUFFER ADDRESS + CLL RTL + RTL /BUFFER NUMBER INTO AC + RAL /BITS 10,11 + AND (3 /STRIP + TAD ANDPTR /USE AS INDEX INTO MASKS + DCA TEMP1 + TAD BMAP /BUFFER STATUS MAP + AND I TEMP1 /CLEAR THE BIT FOR THIS BUFFER + DCA BMAP + TAD I IOTHDR /HEADER WORD + AND O7400 /STRIP HEADER TO DEVICE # ONLY + DCA I IOTHDR + TAD MM4 /-4 + DCA TEMP3 /USE AS COUNTER +CHECKL, TAD TEMP3 /GET 3 OF FILE TO CHECK + TAD (W0PTR /MAKE POINTER TO PROPER W0 HEADER + DCA TEMP1 /SAVE POINTER + TAD TEMP3 /-# 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 TEMP1 /GET HEADER WORD FOR THE FILE OF INTEREST + AND O7400 /ISOLATE DEVICE # + CIA /NEGATE + TAD I IOTHDR /COMPARE TO CURRENT DEVICE # + SNA CLA /SAME DEVICE? + JMP CRETN /YES-LEAVE DRIVER IN CORE +PSTCHK, ISZ TEMP3 /ALL 4 CHECKED? + JMP CHECKL /NO-CHECK THE NEXT 1 + TAD I IOTHDR + AND O10 /GET HANDLER LENGTH BIT + SZA CLA /TWO PAGES? + JMP TPREL /YES-FREE BOTH PAGES + TAD I IOTHND /THIS IS THE ONLY FILE USING HANDLER THEN + CLL RTL + RTL /SLIDE BITS 4,5 OF HANDLER PAGE TO AC BITS 10,11 + RAL + AND (3 /ISOLATE HANDLER BUFFER NUMBER + TAD ANDPTR /MAKE POINTER TO PROPER AND MASK +RELCOM, DCA TEMP1 + TAD DMAP /DRIVER PAGE MAP + AND I TEMP1 /CLEAR HANDLER PAGE BIT + DCA DMAP +CRETN, DCA I IOTHND /SET FILE AS IDLE + JMS I PPSWAP /GET RID OF 17600 AGAIN + JMP I PILOOP /DONE + +TPREL, TAD I IOTHND /ONLY FILE USING HANDLER + CLL RTL + RTL /ISOLATE HANDLER BUFFER NUMBER + RAL + AND (3 + TAD (ANDLS2 /USE AS INDEX TO AND MASK + JMP RELCOM + +W0PTR, FILE1 + FILE2 /FILE TABLE ENTRIES + FILE3 + FILE4 + +MM4, +ANDLS2, 7774 + 7701 + +/CODE TO READ IN COMPILER AND START IT +/THIS CODE GETS MOVED TO FIELD 1 AND EXECUTED FROM +/LOC 2001-2013 IN FIELD 1 + +CREAD, CDF 10 + CIF 0 + 4613 /"JMS I L7607K" + 3700 /31 PAGES + 0 /0-7577 +CBLK, 7617 /STARTING BLOCK OF COMPILER + HLT /SYSTEM ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT + CIF 0 + 5612 /"JMP I .+1"-START THE COMPILER + 7001 /STARTING ADDR OF COMPILER +K7607K, 7607 + /LESS THAN THE DESIRED VALUE + +EXTCHK, 0 /SKIP RETURN IF CURRENT + AC0002 + IAC + TAD IOTFIL /IS .SV + DCA EXTEMP /JUST A TEMP + TAD I EXTEMP /GET EXTENSION + TAD (-2326 + SNA CLA /IS IT .SV? + ISZ EXTCHK /YES: SKIP + JMP I EXTCHK +EXTEMP, 0 + + PAGE + /CHAIN FUNCTION +/SETS UP COMMAND DECODER AREA,THEN CHAINS TO BCOMP.SV + +CHAIN, JMS I PXPRINT /EMPTY TTY RING BUFFER + JMP .-1 + JMS I PPSWAP /RESTORE PG 17600 + JMS I DNA2 /GET FILE NAME IN NAME AREA FROM CURRENT FILE + 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 USR + 12 /INQUIRE +DNA1, 0 /DEVICE NAME +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 USR + 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 USR + 2 /LOOKUP +STB, 0 /POINTER TO FILE NAME +FLN, 0 +CL, JMS I PERROR /LOOKUP ERROR + TAD STB /GET STARTING BLOCK + CDF 10 + DCA I (7620 /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 (7617 /PUT IN CD AREA + TAD O100 /SET R SWITCH + DCA I (7644 + TAD I (7605 /STARTING BLOCK OF COMPILER + SNA /(IS THIS A CORE IMAGE? + JMP CICHAIN /YES: HANDLE SOMEWHAT DIFFERENTLY + CDF + DCA I (CBLK /INTO COMPILER READ CODE + CDF + JMS I (EXTCHK /SKP IF EXTENSION .SV + SKP + JMP CX /ERROR IF IT IS + JMS I (PSWAP2 /NOW EXEC DESTRUCTIVE EXIT CODE + CDF 10 + JMP I (CSMOVE /MOVE THE COMPILER READ TO FIELD 1 AND EXECUTE IT + +CICHAIN,CDF + JMS I (EXTCHK /SKP IF EXTENSION IS .SV +CX, JMS I PERROR /ERROR IF NOT + JMS I (PSWAP2 /NOW EXEC ONCE ONLY CLEAN UP ROUTINE + TAD STB + DCA CHNSTB + CIF 10 /NOW DO A RESET AND DELETE TENTATIVE FILES + JMS I USR + 13 /RESET + CIF 10 /FLAG TENTATIVE FILE CLEANUP + JMS I USR + 6 +CHNSTB, HLT + /FILE LOOKUP + +FLOOK, AC0002 + JMS I (ENTLOK /LOOKUP + DCA I IOTLEN /ACTUAL LENGTH + TAD I IOTLEN + DCA I IOTMAX /ALSO EQUALS MAXIMUM LENGTH +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 USR /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 + + /ROUTINE FOR INTERPRETER EXIT + +FSTOP, KSF /IS THE KEYBOARD FLAG SET? + JMP NOCTC /NO-THERE IS NO CHANGE ^C SENT US HERE + TAD O200 /YES-FORCE PARITY BIT + KRB /GET CHARACTER + TAD (-203 /COMPARE AGAINST ^C + SZA CLA /WAS IT ^C? + JMP NOCTC /NO-THIS IS A NORMAL EXIT + TSF + JMP .-1 + TAD ("^ /YES -ECHO ^ + TLS + CLA + TSF + JMP .-1 + TAD ("C /ECHO "C" + TLS +NOCTC, TSF + JMP .-1 + JMP I (MEXIT + + 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 I IOTHDR /SET UP HEADER WORD + TAD ENTNO /IS FILE TTY? + SNA CLA + JMP I PILOOP /YES-DON'T DO ANYTHING + 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 + 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 USR /CALL TO USR + 12 /INQUIRE +DEVNA1, . /DEVICE NAME +DEVNA2, . +ENTRYN, 0 /ENTRY POINT +IN, JMS I PERROR /INQUIRE ERROR + TAD DEVNA2 /GET DEVICE # + CLL RAR + RTR /PUT INTO BITS 0-3 + RTR + TAD I IOTHDR + DCA I IOTHDR /STORE IN HEADER WORD + TAD ENTRYN /GET DRIVER ADDRESS + SZA /IS IT IN CORE? + JMP I (DRIVRN /YES-NO NEED TO FETCH IT + TAD DMAP /NO-GET MAP OF DRIVER PAGES + CLL RAR /PAGE 7000 BIT IN LINK + SNL /IS PAGE 7000 FREE? + JMP FREE70 /YES + CLL RAR /NO-7200 BIT TO LINK + SNL /IS PAGE 7200 FREE? + JMP FREE72 /YES + CLL RAR /NO-7400 BIT TO LINK + SZL CLA /IS PAGE 7400 FREE? +DO, JMS I PERROR /NO-NO MORE ROOM FOR DRIVERS + TAD O7400 /YES-LOAD HANDLER INTO 7400 + DCA FETPAG /SET UP IN FETCH CALL + TAD (4 /SET BIT 9 TO SHOW PAGE 7400 OCCUPIED + JMP DFETCH /FETCH DRIVER + +FREE70, CLL RAR /PAGE 7200 BIT TO LINK + SNL CLA /IS 7200 FREE? + IAC /YES-THERE IS ROOM FOR A TWO PAGE HANDLER + TAD (7000 + DCA FETPAG /SET UP FETCH TO USE PAGE 7000 + CLL CLA CML RTL /TURN ON BIT 10 + DCA TPH /SAVE IN TWO PAGE SET WORD + IAC /SET BIT 11 TO SHOW PAGE 7000 OCCUPIED + JMP DFETCH /FETCH HANDLER + +FREE72, CLL RAR /7400 BIT TO LINK + SNL CLA /IS 7400 PAGE FREE? + IAC /YES-THEN THERE IS ROOM FOR A 2 PAGE HANDLER + TAD (7200 + DCA FETPAG /SET ADDRESS IN FETCH CALL + TAD (4 + DCA TPH /IF TWO PAGE LOADED,SET BIT 9 ALSO + AC0002 /TURN ON BIT 10 TO SHOW PAGE 7200 OCCUPIED +DFETCH, TAD DMAP /TURN ON PAGE BIT FOR WHERE BUFFER WILL BE LOADED + DCA DMAP + TAD DEVNA2 /DEVICE # IN AC + CIF 10 + JMS I USR /CALL TO USR + 1 /FETCH +FETPAG, . /DRIVER ADDRESS +FE, JMS I PERROR /FETCH ERROR + CDF 10 + CLA CMA + TAD I (37 /GET ADDR OF HANDLER INFO TABLE + TAD DEVNA2 /USE THE DEVICE # AS AN INDEX INTO THAT TABLE + DCA TEMP1 /SAVE POINTER + TAD I TEMP1 /GET THE INFO WORD FOR THE HANDLER JUST FETCHED + CDF + SMA CLA /IS HANDLER 2 PAGES LONG? + JMP DRAP /NO MAP IS COMPLETE + TAD TPH /YES-UPDATE DRIVER MAP TO INCLUDE + TAD DMAP /SECOND PAGE OF TWO PAGE HANDLERS + DCA DMAP + TAD O10 + TAD I IOTHDR /SET 2 PAGE BIT IN HEADER WORD + DCA I IOTHDR +DRAP, TAD FETPAG /HANDLER ENTRY ADDRESS + JMP I (DRIVRN /PAGE ESCAPE + +TPH, 0 + /ROUTINE TO MOVE THE COMPILER READER INTO FIELD 1 AND START IT + +CSMOVE, TAD (CREAD-1 + DCA XR1 /POINTES TO COMPILER STARTING CODE + TAD (-13 + DCA TEMP1 /COUNTER + TAD (2000 + DCA XR2 /MOVE TO LOC 2001 IN FIELD 1 + CDF + TAD I XR1 /GET WORD OF CODE + CDF 10 + DCA I XR2 /MOVE IT + ISZ TEMP1 /DONE? + JMP .-5 /NO + CIF 10 /YES-START IT + JMS I (2000 + + PAGE + DRIVRN, DCA I IOTHND /DRIVER ENTRY INTO I/O TABLE + TAD BMAP /GET BUFFER MAP + CLL RAR /BUFF1 BIT TO LINK + SNL /IS IT FREE? + JMP B1 /YES-ASSIGN BUFF1 + RAR /BUFF2 BIT TO LINK + SNL /IS IT FREE? + JMP B2 /YES-ASSIGN BUFF2 + RAR /BUFF3 BIT TO LINK + SNL /IS IT FREE + JMP B3 /YES-ASSIGN BUFF3 + RAR /NO-BUFF4 BIT TO LINK + SZL CLA /IS IT FREE? +BO, JMS I PERROR /NO-NO MORE BUFFERS AVAILABLE + TAD (1400 + DCA I IOTBUF /SET BUFFER ADDRESS TO 1400 + TAD O10 /SET BUFF4 BIR IN MAP + JMP BUFASS + +B3, CLA + TAD (1000 + DCA I IOTBUF /SET BUFFER ADDRESS TO 1000 + TAD (4 + JMP BUFASS /SET BUFF3 BIT IN MAP + +B2, CLA + TAD O400 + DCA I IOTBUF /SET BUFF ADDRESS TO 400 + CLL CML CLA RTL /SET BUFF2 BIT IN MAP + JMP BUFASS + +B1, CLA + DCA I IOTBUF /SET BUFF ADDRESS TO 0000 + CLA IAC /TURN ON BUFF1 BIT IN MAP + BUFASS, TAD BMAP + DCA BMAP /UPDATE BUFFER ASSIGNMENT MAP + TAD I IOTHDR /GET HEADER WORD + CLL RTR + RAR /FIXED,VARIABLE BIT TO LINK + SNL CLA /IS IT FIXED? + JMP I (FLOOK /YES-DO A LOOKUP + TAD (3 /NO-DO AN ENTER + JMS ENTLOK /ENTER + DCA I IOTMAX /MAXIMUM LENGTH IN WORD 7 + DCA I IOTLEN /ZERO ACTUAL LENGTH + JMP I (CLEANP /FINALIZE I/O TABLE ENTRY + +MEXIT, CLA + JMS I PPSWAP + JMS I (PSWAP2 /RESTORE PG 27600 + CDF 10 + TAD I (EDBLK /GET BLOCK # FOR EDITOR + CDF + SNA /SHALL WE CALL THE EDITOR? + JMP I (7600 /NOkJUST CALL OS/8 + DCA EBLK /YES-PUT THE BLOCK # IN DRIVER CALL + JMS I (7607 /CALL SYS DRIVER + 2100 /READ 8 BLOCKS + 0 /INTO 0-3377 +EBLK, . /BLOCK # OF EDITOR + HLT /SYS ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT + JMP I .+1 /START THE EDITOR + 3212 + 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 USR /CALL TO USR +FNOM, . /ENTER OR LOOKUP +STARTB, . +FLEN, . +EN, JMS I PERROR /ENTER ERROR + TAD STARTB /FILE STARTING BLOCK # + SZA CLA /IS IT NON-ZERO? + JMP FILSTU /YES-DEVICE IS FILE STRUCTURED + TAD FLEN /NO-GET FILE LENGTH + SZA CLA /IS IT EMPTY? + JMP FILSTU /NO-DEVICE IS FILE STRUCTURED + TAD (20 /NO-FILE IS READ/WRITE ONLY + TAD I IOTHDR + DCA I IOTHDR /SET READ/WRITE ONLY BIT + TAD FNOM + CLL RAR + SNL CLA + IAC +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 + /SUBROUTINE P2SWAP-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 27774-27777 +/ 3) IF SYS=TD/8E,RESTORES PAGE 27600 AND RETURNS CDFS TO PAGE 07600 + +PSWAP2, 0 + TAD (4207 + DCA I (7600 /REMOVE CTRL/C HOOKS + TAD (6213 + DCA I (7605 + TAD (7600 + DCA I (HICORE /FUDGE POINTER IN SWAP ROUTINE (IN CASE IT WAS TD8E) + TAD PSFLAG /GET RESIDENT STATUS FLAG + SPA CLA /IS THIS TD8/E SYS? + JMS I (PSWP2P /YES-RESTORE PAGE 27600 AND PAGE 07600 + TAD CDFIO + DCA .+3 /CDF TO HI CORE + CDF 10 + TAD I BOSPT1 /GET BATCH WORD + CDF 10 + DCA I BOSPT2 /BACK INTO LOFTY STATE + ISZ BOSPT1 + ISZ BOSPT2 + JMP .-6 + CDF + JMP I PSWAP2 /YES-WE ARE FINISHED,SO RETURN +BOSPT1, 7600 +BOSPT2, 7774 + + PAGE + /PARSE A FILENAME OF THE FORM "DEVN:FILENM.EX" IN THE SAC + /DSK: AND A NULL EXTENSION ARE THE DEFAULTS + /THE END OF THE SAC IS USED AS A WORK AREA + /IF SYNTAX IS CORRECT, THE NAME IS PACKED INTO + /THE FILENAME FIELD OF THE CURRENT FILE + /OTHERWISE A FATAL ERROR IS RETURNED + /ENTERED WITH OS/8 SWAPPED IN + + WKAREA= SAC+16 /DEFINE SCRATCH AREA + +NAMEG, 0 + TAD SACLEN + TAD (16 /COMPARE STRING LENGTH TO 16 + SPA CLA +IF, JMS I PERROR /TOO MANY CHARS IN "DEV:FILENM.EX" + TAD SACLEN + DCA TEMP2 /STRING LENGTH COUNTER + TAD PSACM1 + DCA SACXR + TAD (DSK-1 /FIRST USE THE DEFAULT DEVICE + JMS DEVFUD +NCG, TAD I SACXR /GET CHAR FROM SAC + DCA TEMP1 /SAVE + TAD TEMP1 + TAD (-72 /IS IT A COLON? + SNA + JMP CAD /YES-CHARS SO FAR=DEVICE NAME + TAD (14 /NO-IS IT A PERIOD? + SNA CLA + JMP SSAD /YES-NEXT TWO CHARS=EXTENSION + TAD TEMP1 /NO-GET CHAR AGAIN + DCA I XR2 /STORE IN WORK AREA + ISZ TEMP4 /BUMP COUNT FOR CURRENT SECTION +NCGS, ISZ TEMP2 /END OF STRING YET? + JMP NCG /NO-NEXT CHAR + TAD TEMP4 /YES-GET CHAR COUNT FOR THIS SECTION (NAME) + TAD (-6 + SMA SZA CLA /IS IT >6? + JMP IF /YES-TOO MANY CHARACTERS IN FILE NAME + TAD (WKAREA-1 /NO-ADDRESS OF SCRATCH NAME BLOCK + DCA XR1 + STA /-1 + TAD IOTDEV /ADDRESS OF FINAL NAME BLOCK-1 + DCA XR2 + TAD (-6 /MOVE 6 WORDS + DCA TEMP2 +MML, TAD I XR1 + CLL RTL + RTL + RTL + TAD I XR1 + DCA I XR2 /MOVE NAME WORD FROM SCRATCH AREA TO FINAL DEST + ISZ TEMP2 /DONE? + JMP MML /NO + JMP I NAMEG /YES-RETURN + +CAD, TAD TEMP4 /GET CHAR COUNT FOR THIS SECTION + TAD (-4 /COMPARE AGAINST 4 + SMA SZA CLA /TOO MANY CHARS? + JMP IF /YES-DEVICE NAME TOO LONG + TAD (WKAREA-1+4 + JMS DEVFUD /CLEAR BUF AND GET NAME FROM FILE FIELD THIS TIME + JMP NCGS + +SSAD, TAD TEMP4 /COUNT FOR THIS SECTION (FILE NAME) + TAD (-6 + SMA SZA CLA /TOO MANY? + JMP IF /YES-FILE NAME TOO LONG + DCA TEMP4 /NO-CLEAR COUNT + TAD DSK + TAD TEMP2 /COMPARE AGAINST # OF CHARS LEFT + SPA SNA CLA + JMP IF /TOO MANY CHARS IN EXTENSION + TAD (WKAREA-1+12 + DCA XR2 + JMP NCGS + +DEVFUD, 0 + DCA XR1 /POINT AT LOC OF DEV: + TAD (WKAREA-1 + DCA XR2 /POINT AT START OF WORK AREA + TAD (-10 + DCA TEMP4 + TAD (-4 + DCA TEMP3 + TAD I XR1 /GET A DEVICE NAME BYTE + DCA I XR2 /STORE IN WORK AREA DEVICE FIELD + ISZ TEMP3 + JMP .-3 /ITERATE + DCA I XR2 /NOW CLEAR REST OF FILE NAME + ISZ TEMP4 + JMP .-2 /ITERATE + TAD (WKAREA-1+4 /POINT XR2 AT FILENAME FIELD + DCA XR2 + JMP I DEVFUD /RETURN WITH TEMP4 CLEAR + +DSK, 4;23;13;0 /6BIT DEFAULT DEVICE NAME "DSK" + /SUBROUTINE TO RESTORE PAGE 27600 OF TD8/E DRIVER +/AND READJUST THE CDFS IN FIELD 0 + +PSWP2P, 0 + TAD PSFLAG + RTL + SNL CLA /BIT 1 SET MEANS PHONEY TD8E + JMP .+3 + DCA PSFLAG + JMP I PSWP2P + 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 + TAD (6223 + DCA I (7642 + TAD (6222 + DCA I (7721 + TAD (6222 /RESTORE CDFS IN PAGE 07600 + DCA I (7727 + JMP I PSWP2P /RETURN + + PAGE + + + + FIELD 0 + + + + + + + + + + + + + + +///////////////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////////////// +/////////////// END OF OVERLAY AREA ///////////////////////////////// +///////////////////////////////////////////////////////////////////// +///////////////////////////////////////////////////////////////////// + + $ + <:STTYF, 1+1"E0;' +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +J +P> +