[pdp8.git] / sw / os8 / v3d / sources / extensions / dectapes / dectape1 / brts.pa

/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.
/
/
/
/
/
/
\f/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<BRTS.PA/W
/       .R ABSLDR
/       *BRTS$                  (THEN SAVE AS SHOWN BELOW)
/

/WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE
/CORE LAYOUT IS AS FOLLOWS:
/
/BRTS IS AT 0-6777
/OVERLAY BASIC.AF IS AT 3400-4577
/OVERLAY BASIC.SF IA AT 12000-13177
/OVERLAY BASIC.FF IS AT 13400-14577
/
/TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC,
/ASSEMBLE THIS SOURCE IN A 12K OR MORE MACHINE,THEN
/PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS
/
/.R ABSLDR
/*BRTS$
/.SAVE SYS:BRTS 0-6777
/
/.SAVE SYS:BASIC.AF 3400-4577
/
/.SAVE SYS:BASIC.SF 12000-13177
/
/.SAVE SYS:BASIC.FF 13400-14577
/
/THE BASIC RUN-TIME SYSTEM IS CONDITIONALIZED TO TAKE ADVANTAGE
/OF THE PDP-8/E KE8/E EAE OPTION.
/NORMALLY,THE SYSTEM IS ASSEMBLED SUCH THAT IT WILL RUN ON ANY
/PDP-8 OR PDP-12. TO TAKE ADVANTAGE OF THE ADDITIONAL HARDWARE,SET
/THE SWITCH EAE=1 IF THE SYSTEM INCLUDES A KE8/E EAE.
/YOU MAY DO THIS BY CONCATENATING TTY: ONTO BRTS.PA AS FOLLOWS
/.PAL EABRTS<TTY:,SYS:BRTS.PA/W
/EAE=1
/^Z
/^Z
/.   BINARY IS CREATED...
/NOW EABRTS IS LOADED INSTEAD OF BRTS
/TO GET A LISTING, USE THE /J SWITCH TO INHIBIT THE FPP CODE YOU
/ARE NOT USING (EAE ON A NON EAE ASSEMBLY FOR EXAMPLE)

/EAE=0          /USE STANDARD FLOATING POINT PACKAGE
/EAE=1          /USE EAE FLOATING POINT PACKAGE
/
/V4 FIXES
/.EAE ADD FOR NUMS <.00001 TO 0
/.FILE INPUT FROM TTY
/.OUTPUT OF NUMS > 80,000
/.STRING FETCH WHEN COUNT IS IN ONE FLD &
/   TEXT IS IN THE NEXT
\f       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 <EAE=0>

        /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

\f/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

\f/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
\f       *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
\f       /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
\f/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
\f       *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
\f/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
\f/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
\f       /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
\f/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
\f/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

\f       /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
\f       /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
\f/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
\f       /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
\f       /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

\f/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
\f/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
\f/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!
\f/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
\f/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--
\f       /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
\f/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
\f       /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
\f       /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
\f
/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
\f/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
\f       /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
\f       /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--

\f/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
\f       /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
\f/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
\f
/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
\f/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
\f/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
\f/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
\f/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
\f/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
\f/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
\f/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
\f





/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////  OVERLAY BUFFER  3400-4600  ////////////////////
////////////  CONTAINS FUNCTION OVERLAYS ////////////////////
////////////  AT RUN TIME                ////////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////


\f/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// 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

\f/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
\fEMDONE,        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
\f       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
\f       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
        >
\f       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
        >
\f/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
\f/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
\f/******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
\f/******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
\f/******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
\f       *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
\f/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
\f       /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--
\f       /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
\f       /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
\f       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
\fEDON,  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
\f/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
\f       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
\f/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
\f/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
\f       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)
\f/
/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
\f/
/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.
\f/
/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
\f       *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
        >
\f       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
        \f/
/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
\fEDON,  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
\f/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
/
\f       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

\f
/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
\f/
/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
\f
        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
\f


/
/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
\f/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
\f       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
\f/
/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
        >
\f       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
\f       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
        >
\f/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
\f       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
        >
\f/
/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

\f       *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
\f/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
\f/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
\f        *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
\f       /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
\f/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// 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
\f


/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
\f
/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
\f/      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
\f/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
\f/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
\f/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
\f/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
\f/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
\f       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 Z<Y,NULL STRING IS RETURNED

SEG,    CLA IAC
        DCA     MODESW  /RETURN IN STRING MODE
        TAD     ACH     /IS Y>0?
        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
\f       /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
\f       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
\f       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
\f/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
\f       /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
\f       /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
\f       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
\f/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
\fDRIVRN,        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
\fBUFASS,        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
\fENTLOK,        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
\f/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
\f       /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
\f       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"
\f/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
\f


        FIELD 0














/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////// END OF OVERLAY AREA /////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////

        $
\f<:STTYF,       1\e+1"E0;'
J<S\13PRINT\13\e;R-5DI[XPRINT\e>
J<S\13SACPTR\13\e;R-6DI[SAC-1\e>
J<S\13PUTCHL\13\e;R-6DI[PUTCH\e>
J<S\13ILOOPL\13\e;R-6DI[ILOOP\e>
J<S\13INTL\13\e;R-4DI[UNSFIX\e>
J<S\13CDFPSL\13\e;R-6DI[CDFPSU\e>
J<S\13ERROR\13\e;R-5DI[ERRDIS\e>
J<S\13FBITS\13\e;R-5DI[FBITGT\e>
J<S\13PWFECL\13\e;R-5DI[PWFECH\e>
J<S\13MPYLNK\13\e;R-6DI[MPY\e>
J<S\13XPUT\13\e;R-4DI[XPUTCH\e>
J<S\13FIDLE\13\e;R-5DI[IDLE\e>
J<S\13DEVCAL\13\e;R-6DI[DRCALL\e>
J<S\13WRITFW\13\e;R-6DI[WRITFL\e>
J<S\13STHINL\13\e;R-6DI[STHINI\e>
J<S\13LDHINL\13\e;R-6DI[LDHINI\e>
J<S\13STH\13\e;R-3DI[STHL\e>
J<S\13LDH\13\e;R-3DI[LDHL\e>
J<S\13FACSAL\13\e;R-6DI[FACSAV\e>
J<S\13FACREL\13\e;R-6DI[FACRES\e>
J<S\13FGETL\13\e;R-5DI[FFGET\e>
J<S\13FPUTL\13\e;R-5DI[FFPUT\e>
J<S\13FNORL\13\e;R-5DI[FFNOR\e>
J<S\13FCLR\13\e;R-4DI[FACCLR\e>
J<S\13FNEGL\13\e;R-5DI[FFNEG\e>
J<S\13FLOATL\13\e;R-6DI[FFLOAT\e>
J<S\13GETCHL\13\e;R-6DI[GETCH\e>
J<S\13EOFSEL\13\e;R-6DI[EOFSET\e>
J<S\13BSWL\13\e;R-4DI[BSWP\e>
J<S\13PACKL\13\e;R-5DI[PACKCH\e>
J<S\13CNOCLL\13\e;R-6DI[CNOCLR\e>
J<S\13BUFCHL\13\e;R-6DI[BUFCHK\e>
J<S\13FTYPL\13\e;R-5DI[FTYPE\e>
J<S\13CHRNOL\13\e;R-6DI[CHARNO\e>
J<S\13NEXREL\13\e;R-6DI[NEXREC\e>
J<S\13CRLF\13\e;R-4DI[CRLFR\e>
J<S\13VALLK\13\e;R-5DI[VALGET\e>
J<S\13PATCHP\13\e;R-6DI[PATCHF\e>
J<S\13P1SWAP\13\e;R-6DI[PSWAP\e>
J<S\13LDHRST\13\e;R-6DI[LRESET\e>
J<S\13STHRST\13\e;R-6DI[SRESET\e>
P>
\f