software: Added more and more

[pdp8.git] / sw / f4 / FRTSRC / rts.pa

/FORTRAN IV RUNTIME SYSTEM, V5A
/
/
/
/
/
/
/
//
/
/
/
/
/COPYRIGHT (C) 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/FORTRAN 4 RUNTIME SYSTEM - R.LARY
/AND NOW WITH DOUBLE PRECISION! - MKH
/RTS-8 SUPPORT ADDED 5/20/74 - RL
/LAST EDITED 5/19/74

XVERSN=5                /UPDATE WITH EVERY RELEASE!
XPATCH="A               /PATCH LEVEL A

/NOTES TO MAINTAINERS:

/THIS PROGRAM IS DESIGNED TO SUPPORT MANY DIFFERENT HARDWARE
/CONFIGURATIONS IN A MINIMAL AMOUNT OF SPACE.  IT ACHIEVES THIS GOAL
/BY "TAILORING" ITSELF AT INITIALIZATION TIME
/BASED ON A SURVEY OF ITS HARDWARE/SOFTWARE ENVIRONMENT.  THIS MAKES
/THIS PROGRAM DIFFICULT TO MODIFY UNLESS THE MODIFYING PROGRAMMER
/KNOWS WHAT IS GOING ON.  IT IS THEREFORE SUGGESTED THAT YOU READ THIS
/LISTING THOROUGHLY AND UNDERSTAND THE MAJOR ROUTINES BEFORE
/MAKING EVEN "TRIVIAL" CHANGES.

/ALL SYMBOLS BEGINNING WITH THE LETTER "Q" ARE ENTRIES IN THE
/HEADER BLOCK OF THE LOADER-IMAGE (.LD) FILE.

/ALL SYMBOLS BEGINNING WITH THE LETTER "Y" DENOTE THE BEGINNING OF
/A BLOCK OF CODE WHICH WILL BE REPLACED BY DIFFERENT CODE IF FRTS
/IS RUNNING IN THE BACKGROUND UNDER RTS-8.  THE REPLACEMENT CODE
/CAN BE FOUND IN THE TABLE "BKRLST".

/ALL SYMBOLS BEGINNING WITH THE LETTER "V" ARE DEFINED IN THE LOADER
/SYMBOL TABLE AND CANNOT BE MOVED WITHOUT CHANGING THE LOADER. ONLY
/A VERY FEW OF THESE SYMBOLS OCCUR IN PLACES OTHER THAN
/PAGE 200 OR THE FIRST LOCATION OF OTHER PAGES.

/CODE WHICH CONTAINS THE CHARACTER SEQUENCE "*K*" IN THE COMMENT FIELD
/IS PARTICULARLY SUBTLE/OBSCURE (THE "K" IS FOR "KLUDGE").  THE REST OF THE
/COMMENT SHOULD INDICATE WHAT IS GOING ON.
/
/
/ FIXES FOR V4  J.K.    1975
/
/ .SCALE FACTOR PRINTED BY P FORMAT OPERATOR
/ .FRTS /P
/ .RK8E HANDLER TO RUN WITH INTERRUPTS ON
/ .SLASH AT END OF FORMAT STATEMENT
/
/
/       CHANGES FOR OS/78 AND OS/8 V3D BY P.T.
/       .CHANGED THE VERSION NUMBER TO 5A
/       .FIXED THE FIELD OVERFLOW PROBLEM
/       .FIXED THE "K=K+1" PROBLEM
\f/DEFINITIONS:

AC7775= STA CLL RTL
AC7776= STA CLL RAL
AC4000= CLA STL RAR
AC3777= STA CLL RAR
AC2000= CLA STL RTR
AC0002= CLA STL RTL

/DEFINITIONS OF KE-8/E INSTRUCTIONS

MQL=    7421
MQA=    7501
CAM=    CLA MQL
SWP=    MQA MQL
SWAB=   7431
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
SGT=    6006

/DEFINITIONS OF FPP IOT'S

FPINT=  6551
FPICL=  6552
FPCOM=  6553
FPHLT=  6554
FPST=   6555
FPRST=  6556
\f/FPP OPCODES:

FLDA=   0000
FADD=   1000
FSUB=   2000
FDIV=   3000
FMUL=   4000
FADDM=  5000
FSTA=   6000
FMULM=  7000
                LONG=   400     /TWO-WORD ADDRESSING
                BASE=   200     /BASEPAGE ADDRESSING
                IND=    600     /INDIRECT ADDRESSING

FEXIT=  0000
FNORM=  0004
STARTF= 0005
STARTD= 0006
JAC=    0007
XTA=    0030
STARTE= 0050
LDX=    0100

JA=     1030
JNE=    1040
TRAP3=  3000

/OS8 EQUIVALENCES:

OS8SWS= 7643
OSJSWD= 7746
OS8DVT= 7647
OS8DCB= 7760
OS8DAT= 7666

/VARIOUS OTHER IOT'S:

LSF=    6661
LCF=    6662
LSE=    6663
LIE=    6665
LLS=    6666
LIF=    6667
\f/PAGE ZERO FOR FORTRAN IV RTS

        *0              /INTERRUPT STUFF
        0
        JMP I   .+1
        INTRPT
LPGET,  LPBUFR          /LINE PRINTER RING BUFFER FETCH POINTER
TOCHR,  0               /TELETYPE STATUS WORD
KBDCHR, 0               /KEYBOARD INPUT CHARACTER
POCHR,  0               /P.T. PUNCH COMPLETION FLAG
RDRCHR, 0               /P.T. READER STATUS
FMTPXR, 0               /XR USED TO INDEX FORMAT PARENTHESIS ARRAY
INXR,   INBUFR-1        /XR USED TO GET CHARS FROM INPUT LINE
XR,     0
XR1,    0

*16
VEOFSW, 0               /USED BY "EOFCHK" TO STORE VARIABLE ADDRESS
        0               /*K* MUST BE IN AUTO - XR
T,      0               /TEMPORARY
DFLG,   0               /0 = F.P., 1 = D.P.
INST,   0               /CURRENT INSTRUCTION WORD

/IOH PAGE ZERO LOCATIONS

RWFLAG, 0               /READ/WRITE FLAG
FMTTYP, 0               /TYPE OF CONVERSION BEING DONE
EOLSW,  0               /EOL SW ON INPUT - CHAR POS ON OUTPUT
N,      0               /REPEAT FACTOR
W,      0               /FIELD WIDTH
D,      0               /NUMBER OF PLACES AFTER DECIMAL POINT

DATCDF, 0               /SUBROUTINE TO CHANGE DATA FIELD
DATAF,  0               /CONTAINS VARIOUS CDF'S
        JMP I   DATCDF  /RETURN

ERR,    ERROR           /POINTER TO ERROR ROUTINE
FATAL,  0               /FATAL ERROR FLAG - 0=FATAL
MCDF,   MAKCDF

/FPP PARAMETER TABLE LOCATIONS:

APT,    0               /VARIOUS FIELD BITS FOR FPP
PC,     DPTEST          /FPP PROGRAM COUNTER
XRBASE, 0               /FPP INDEX REGISTER ARRAY ADDRESS
BASADR, 0               /FPP BASE PAGE ADDRESS
ADR,    0               /ADDRESS TEMPORARY
ACX,    0
ACH,    0               /*** FLOATING ACCUMULATOR ***
ACL,    0
EAC1,   0
EAC2,   0               /** FOR EXTENDED PRECISION OPTION **
EAC3,   0
\f/FLOATING POINT PACKAGE LOCATIONS

AC0,    0
AC1,    0               /FLOATING AC OVERFLOW WORD
AC2,    0               /OPERAND OVFLOW WORD
OPX,    0
OPH,    0               /*** FLOATING OPERAND REGISTER ***
OPL,    0

/RTS I/O CONVERSION SYSTEM LOCATIONS

FMTBYT, 0               /FORMAT BYTE POINTER
IFLG,   0               /I FOEMAT FLAG
GFLG,   0               /G FORMAT FLAG
EFLG,   0               /E FORMAT FLAG - SOMETIMES ON FOR G FMT
OD,     0
SCALE,  0
PFACT,  0               /P-SCALE FACTOR
PFACTX, 0               /TEMP FOR PFACT
ACI,    0               /INTEGERIZED FAC FROM "FFIX" SUBR
CHCH,   0
FMTNUM, 0               /CONTAINS ACCUMULATED NUMERIC VALUE
CTCINH, 0               /^C INHIBIT FLAG
LOGUNT, 0               /DSRN POINTER - ONLY USED FROM ONE PAGE!
PTTY,   TTY             /POINTER TO TTY HANDLER - USED BY LDDSRN
        0               / SO FORMS CONTROL WILL WORK ON UNIT 0
FPNXT,  ICYCLE          /USED AS INTERPRETER ADDRESS IF NO FPP

/DSRN IMAGE

HAND,   0               /HANDLER ENTRY POINT
HCODEW, 0               /HANDLER LOAD ADDR & FIELD + IOFFLG + FORMS CTL FLG
BADFLD, 0               /BUFFER ADDRESS AND FIELD
CHRPTR, 0               /ACTUALLY A WORD POINTER
CHRCTR, 0               /COUNTER - RANGES FROM -3 TO -1
STBLK,  0               /STARTING BLOCK OF FILE
RELBLK, 0               /CURRENT RELATIVE BLOCK NUMBER
TOTBLK, 0               /LENGTH OF FILE
FFLAGS, 0               /FILE FLAGS:
                        /BIT 0 - "HAS BEEN WRITTEN" FLAG
                        /BITS 1-2 - FORMATTED/UNFORMATTED FLAGS
                        /BIT 11 - "END-FILED" FLAG

BUFFLD, 0               /ROUTINE TO SET DF TO BUFFER FIELD
BUFCDF, HLT
        JMP I   BUFFLD

FADD1,  FADD+LONG       /FPP CODE TO ADD 1.0 TO FAC
        ONE             /AND FALL INTO STORE CODE
FGPBF,  0               /THESE THREE WORDS ARE USED
BIOPTR, 0               /TO FETCH AND STORE FLOATING POINT NUMBERS
        FEXIT           /FROM RANDOM MEMORY
        PAGE
\f/STARTUP CODE

FTEMP2, ISZ     .+3     /ALSO USED AS I/O F.P. TEMPORARY
        CDF CIF 10
        JMP I   .+1
VDATE,  RTSLDR          /USED TO STORE OS/8 DATE

/RTS ENTRY POINTS - "VERSION INDEPENDENT"

VUERR,  JMP I   (USRERR /USER ERROR
                        /** LOADER MUST DEFINE #ARGER AS VARGER-1 **
VARGER, JMS I   ERR     /LIBRARY ARGUMENT ERROR
VRENDO, ISZ     RWFLAG  /END OF I/O LIST
VRFSV,  JMP I   GETLMN  /I/O LIST ARG ENTRY - COROUTINE WITH GETLMN
VBAK,   JMP I   (BKSPC  /"BACKSPACE" ROUTINE
VENDF,  JMP I   (ENDFL  /"END FILE" ROUTINE
VREW,   JMP I   (RWIND  /"REWIND" ROUTINE
VDEF,   JMP I   (DFINE  /"DEFINE FILE" ROUTINE
VWUO,   AC4000          /UNFORMATTED WRITE
VRUO,   JMP I   (RWUNF  /UNFORMATTED READ
VWDAO,  AC4000          /DIRECT ACCESS WRITE
VRDAO,  JMP I   (RWDACC /DIRECT ACCESS READ
VWRITO, AC4000          /FORMATTED (ASCII) WRITE
VREADO, JMP I   (RWASCI /FORMATTED (ASCII) READ
VSWAP,  JMP I   (SWAP   /OVERLAY PROCESSOR
VEXIT,  TRAP3;  CALXIT  /"STOP" ROUTINE - ENTERED IN FPP MODE
V8OR12, 0;0             /0;1 IF CPU IS A PDP-12
VBACKG, JMP I   (NULLJB /BACKGROUND JOB DISPATCHER
        0
        CDF CIF 0       /USED BY ROUTINE "ONQB" IN LIBRARY
        JMS I   .-2
        JMP     VBACKG

/IOH GET VARIABLE ROUTINE.
/THIS ROUTINE MAKES THE FORMATTED I/O PROCESSOR AND THE USER'S
/PROGRAM CO-ROUTINES (DEF(COROUTINE)= 2 ROUTINES EACH THINKING THE OTHER
/ IS A SUBROUTINE).  ON ENTRY FAC=INPUT NUMBER
/IF I/O IS A READ, ON RETURN FAC=OUTPUT NUMBER IF I/O IS A WRITE.

GETLMN, 0
VRETRN, JMP I   [RETURN /SHORT ROUTINE FOR ALL THOSE COMMENTS, NO?
\f/INTERRUPT DRIVEN I/O HANDLERS

LPT,    0               /RING-BUFFERED - LP08 OR LS8E
        AND     [377    /JUST IN CASE
LPTSNA, SNA
        JMP I   (IOERR  /CANNOT BE USED FOR INPUT
YLPT,   IOF
        DCA I   LPPUT
        TAD     LPGET
        CIA
        TAD     LPPUT
        SZA CLA         /IS LPT QUIET?
        JMP     .+3     /NO
        TAD I   LPPUT
        LLS             /YES - START 'ER UP
        CLA IAC
        LIE             /ENABLE LPT INTERRUPTS
        TAD     LPPUT   /1 IN AC, REMEMBER?
        DCA     LPPUT
        TAD I   LPPUT
        SPA
        JMP     .-3     /NEGATIVE NUMBERS ARE BUFFER LINKS
        SZA CLA         /ANY ROOM LEFT IN BUFFER?
        JMS I   (HANG
        LPUHNG          /WAIT FOR LINE PRINTER
        ION             /TURN INTERRUPTS BACK ON
        JMP I   LPT     /RETURN

LPPUT,  LPBUFR

PTP,    0               /PAPER TAPE PUNCH HANDLER
YPTP,   SNA
        JMP I   (IOERR  /INPUT IS ERROR
        DCA     LPT     /SAVE CHAR
        IOF
        TAD     POCHR   /IF PUNCH IS NOT IDLE,
        SZA CLA         /WE DISMISS JOB
        JMS I   (HANG
        PPUHNG          /WAIT FOR PUNCH INTERRUPT
        TAD     LPT
        PLS             /OUTPUT CHAR
        DCA     POCHR   /SET FLAG NON-ZERO
        ION
        JMP I   PTP

/*K* THE FOLLOWING ADDRESSES GET FALLEN INTO & MUST BE SMALL

        IFNZRO  PPUHNG&7000     <__ERROR__>
        IFNZRO  TTUHNG&7000     <__ERROR__>
        IFNZRO  KBUHNG&7000     <__ERROR__>
        IFNZRO  RDUHNG&7000     <__ERROR__>
        IFNZRO  LPUHNG&7000     <__ERROR__>
\f/INTERRUPT-DRIVEN PTR AND TELETYPE HANDLER

PTR,    0               /CRUDE READER HANDLER
YPTR,   SZA CLA
        JMP I   (IOERR  /OUTPUT ILLEGAL TO PTR
        IOF
        RFC             /START READER
        JMS I   (HANG
        RDUHNG          /HANG UNTIL COMPLETE
        TAD     RDRCHR  /GET CHARACTER
        ION
        JMP I   PTR     /RETURN

TTY,    0               /BUFFERS 2 CHARS ON OUTPUT, 1 ON INPUT
YTTY,   IOF             /DELICATE CODE AHEAD
        SNA             /INPUT OR OUTPUT?
        JMP     KBD     /INPUT
        DCA     LPT     /OUTPUT - SAVE CHAR
        TAD     TOCHR   /GET TTY STATUS
        SMA SZA CLA     /G.T. 0 MEANS A CHAR IS BACKED UP
        JMS I   (HANG
        TTUHNG          /WAIT FOR LOG JAM TO CLEAR
        TAD     TOCHR   /NO CHAR BACKED UP - SEE IF TTY BUSY
        CLL RAL         /"BUSY" FLAG IN LINK - INTERRUPTS ARE OFF!
        CLA CML RAR     /COMPLEMENT OF BUSY IN SIGN
        TAD     LPT     /GET CHAR
        SPA             /IF TTY NOT BUSY,
        TLS             /OUTPUT CHAR
        DCA     TOCHR   /STORE POS OR NEG, BACKED UP OR BUSY
TTYRET, ION             /TURN INTERRUPTS BACK ON
        JMP I   TTY     /AND LEAVE
\fKBD,   TAD     KBDCHR  /HAS A CHARACTER BEEN INPUT?
        SNA CLA
        JMS I   (HANG
        KBUHNG          /NO - RUN BACKGROUND UNTIL ONE IS
        TAD     KBDCHR  /GET CHARACTER
        DCA     LPT
        DCA     KBDCHR  /CHEAR CHARACTER BUFFER
        TAD     LPT
        JMP     TTYRET  /RETURN WITH INTERRUPTS ON

KILFPP, FPHLT           /BRING FPP TO A SCREECHING HALT
        ISZ     .-1
        JMP     .-1     /WAIT FOR IT TO STOP
        FPICL           /CLEAN UP MESS HALT HAS MADE IN FPP
BEEORC, SZL             /^C OR ^B?
        JMP I   (7600   /^C - HIYO SILVER, AWAY!
        KCC             /CLEAR KBD FLAG ON ^B
CTLBER, JMS I   ERR     /*** THIS MAY BE DANGEROUS! **
        PAGE
\f/INTERRUPT SERVICE ROUTINES

INTRPT, DCA     INTAC
        RAR
        DCA     INTLNK
VINT,   JMP     .+4     /** MUST BE AT 403 **
        IFNZRO  VINT-403        <___ CHANGE LOADER!!!>
        0
        CDF CIF 0       /USER INTERRUPT ROUTINE GOES HERE
        JMS I   .-2

        FPINT           /CHECK FOR FPP DONE
        JMP     LPTEST
FPUHNG, JMP     DISMIS  /ALWAYS GOES TO RESTRT

VDISMS, JMP     DISMIS  /FOR USE BY USERS
        JMP     DISMIS
        JMP     DISMIS

LPTEST, LSF
        JMP     NOTLPT
LPTLCF, LCF             /CLEAR FLAG
        TAD I   LPGET
        SNA CLA         /CHECK FOR SPURIOUS INTERRUPT
JMPDIS, JMP     DISMIS  /GO AWAY IF SO
        DCA I   LPGET   /ZERO CHAR JUST OUTPUT
        ISZ     LPGET
        TAD I   LPGET
        SPA
        DCA     LPGET   /TAKE CARE OF BUFFER LINKS
        SNA
        TAD I   LPGET   /MAKE SURE CHAR IS IN AC
        SZA             /IS THERE A CHARACTER?
        LLS             /YES - PRINT IT
        CLA
        LSF             /CHECK FOR IMMEDIATE FLAG
LPUHNG, JMP     DISMIS  /NO - MAYBE RESTART PROGRAM
        JMP     LPTLCF  /YES - LOOP

NOTLPT, TSF             /CHECK TTY
        JMP     NOTTTY
        TCF             /CLEAR FLAG
        TAD     TOCHR   /GET TTY STATUS
        SMA SZA         /IF THERE IS A CHARACTER WAITING,
        TLS             /OUTPUT IT.
        SMA SZA CLA     /CHANGE "WAITING" TO "BUSY",
        STL RAR         /"BUSY" TO "IDLE".
        DCA     TOCHR
TTUHNG, JMP     DISMIS
\f/KBD AND PTP INTERRUPTS

NOTTTY, KSF
        JMP     NOTKBD
        TAD     [200
        KRS             /USE KRS TO FORCE PARITY BIT
        DCA     KBDCHR  /AND ALSO SO THAT ^C WILL STILL BE IN BUFFER IN OS/8
        TAD     KBDCHR
        TAD     (-202   /CHECK FOR ^C OR ^B
        CLL RAR
        SNA CLA
        JMP     CTCCTB  /YUP - TAKE SOME DRASTIC ACTION
        KCC             /DATA CHARACTER - CLEAR FLAG
KBUHNG, JMP     DISMIS

CTCCTB, TAD     CTCINH
        SNA CLA         /ARE WE IN A HANDLER?
        JMP     NOTINH  /NO
        TAD     INTLNK
        CLL RAL         /YES - RETURN WITH INTERRUPTS OFF
        TAD     INTAC   /TRUST IN GOD AND RTS
        RMF
        JMP I   0

NOTKBD, PSF
        JMP     NOTPTP
        PCF             /P.T. PUNCH INTERRUPT - CLEAR FLAG
        DCA     POCHR   /CLEAR SOFTWARE FLAG
PPUHNG, JMP     DISMIS

NOTPTP, RSF
        JMP     LPTERR
        TAD     [200
        RRB             /GET RDR CHAR
        DCA     RDRCHR
RDUHNG, JMP     DISMIS

LPTERR, LSE             /TEST FOR LP08 ERROR FLAG
        SKP
        LIF             /DISABLE LP08 INTERRUPTS IF ERROR FLAG ON
DISMIS, TAD     INTLNK
        CLL RAL
        TAD     INTAC   /RESTORE AC AND LINK
        RMF
        ION
        JMP I   0       /RETURN FROM THE INTERRUPT

INTAC,  0
INTLNK, 0
\f/BACKGROUND INITIATE/TERMINATE ROUTINE

HANG,   0               /ALWAYS CALLED WITH INTERRUPTS OFF!
        TAD I   HANG    /GET POINTER TO UNHANGING LOCATION
        DCA     UNHANG
        RDF             /GET FIELD CALLED FROM
        TAD     HCIDF0
        DCA     HNGCDF  /SAVE FOR RETURN
HCIDF0, CDF CIF 0
        TAD     (JMP RESTRT     /CHANGE THE "JMP DISMIS" AT THAT LOC
        DCA I   UNHANG  /TO A "JMP RESTRT"
        TAD     BACKLK
        CLL RAL
        TAD     BACKAC  /SET UP BACKGROUND AC AND LINK
BAKCIF, CIF 0
BAKCDF, CDF 0
        ION
        JMP I   BACKPC  /INITIATE BACKGROUND

/       COME HERE WHEN THE HANG CONDITION HAS GONE AWAY

RESTRT, TAD     JMPDIS  /RESTORE THE UNHANG LOCATION
        DCA I   UNHANG
        TAD     INTAC   /SUSPEND THE BACKGROUND
        DCA     BACKAC
        TAD     INTLNK
        DCA     BACKLK
        TAD     0
        DCA     BACKPC
        RIB
        AND     [70
        TAD     HCIDF0
        DCA     BAKCIF
        RIB
        JMS I   MCDF    /*K* OK SINCE BACKGROUND DOESN'T USE MAKCDF
        DCA     BAKCDF
        ISZ     HANG
HNGCDF, HLT
        JMP I   HANG    /INTERRUPTS ARE OFF - RETURN

NOTINH, TAD     JMPDIS  /IN CASE WE WERE HUNG, WE DON'T WANT
        DCA I   UNHANG  /TO GET "UNHUNG" OUT OF THE ERROR ROUTINE!
        JMP I   (KILFPP /KILL FPP AND GO TO EXIT OR ERROR

UNHANG, 0
BACKAC, 0
BACKLK, 0
BACKPC, VBACKG
VHANG=  HANG
        IFNZRO  VHANG-0524      <__ CHANGE LOADER!>
        PAGE
\f/I-O CONVERSION ROUTINES - STARTUP CODE

RWASCI, JMS I   [RWINIT /"READ(N,FMT)" OR "WRITE(N,FMT)"
        2000            /"FORMATTED" BIT
        JMS I   [FETPC  /GET ADDRESS OF FORMAT STMT
        DCA     FMTDF
        JMS I   [FETPC
        DCA     FMTADR
        DCA     FMTTYP
        DCA     PFACT   /CLEAR SCALE FACTOR
        JMS I   [GETLMN /EXIT TO MAIN PROGRAM TO GET 1ST VARIABLE

        TAD     (FMTPDL-1
FMTSET, DCA     FMTPXR  /STORE NEW FORMAT PUSHDOWN POINTER
        TAD I   FMTPXR
        DCA     FMTBYT  /GET NEW BYTE POINTER (NOTE-FMTPDL CONTAINS A 0)
\f/MAIN FORMAT DECODING LOOP

FMTFLP, TAD     FMTBYT
        DCA     FMPBYT  /SAVE CURRENT BYTE PTR FOR PARENTHESES HACK
FMTDLP, DCA     FMTNUM  /ZERO ACCUMULATED NUMBER
FMTCLP, JMS     FMTGCH  /GET A CHARACTER
        ISZ     FMTBYT  /BUMP BYTE POINTER
        JMS I   [CHTYPE /CLASSIFY CHAR
        1234;   FMTDIG  /DIGIT
        -42;    DBLQOT  /"
        -44;    ABORTO  /$
        -55;    FMINUS  /-
        -56;    FMTPER  /.
        -57;    SLASH   //
        -54;    COMMA   /,
        -50;    LPAREN  /(
        -51;    RPAREN  /)
        -47;    KWOTE   /'
        -40;    FMTCLP  /SPACE
        0               /ANYTHING ELSE

        TAD     FMTTYP
        SZA CLA         /CHECK THAT WE DO NOT HAVE A FIELD OUTSTANDING
        JMP I   (FMTERR /IF WE DO - ERROR
        TAD     CHCH    /GET FIELD CHARACTER
        DCA     FMTTYP
        TAD     FMTNUM
        SNA             /IF REPEAT COUNT WAS MISSING OR ZERO
        IAC             /MAKE IT ONE
        CMA
        DCA     N       /STORE -(REPEAT COUNT +1)
        DCA     W       /CLEAR WIDTH INITIALLY
        ISZ     FMTNUM  /PRECLUDE "FORMAT ERROR" ON X,P, OR H FORMATS
        TAD     FMTTYP
        AND     [7      /IS THE CHARACTER P, X, OR H?
        SNA CLA         /IF SO, DON'T WAIT
COMMA,  JMS I   (DOFMT  /EXECUTE THE STORED FIELD SPECIFICATION
        JMP     FMTFLP  /BACK FOR MORE

FMTADR, 0               /ADDRESS OF FORMAT
\fFMTGCH,        0               /GET CHARACTER FROM FORMAT
        JMS     FMTGAD  /GET WORD CONTAINING CHAR AND L/R SWITCH
        CDF 0
        JMS I   (FMTGLR /EXTRACT CHARACTER
        JMP I   FMTGCH

FMTGAD, 0               /SUBR TO GET A WORD FROM A CHARACTER OFFSET
        TAD     FMTBYT  /GET OFFSET
        CLL RAR
        CLL
        TAD     FMTADR  /COMPUTE BASE ADDR + [OFFSET/2]
        DCA     D
        RAL
        TAD     FMTDF
        JMS I   MCDF    /SET UP PROPER DATA FIELD
        DCA     .+1
        HLT
        TAD     FMTBYT
        RAR
        CLA             /LEAVE L/R SWITCH IN LINK
        TAD I   D
        JMP I   FMTGAD  /RETURN WITH WORD IN AC

FMTDF,  0               /FIELD OF 1ST CHAR OF FORMAT IN BITS 9-11

FMTDIG, TAD     FMTNUM  /DIGIT PROCESSOR
        CLL RTL
        TAD     FMTNUM
        CLL RAL         /MULTIPLY FMTNUM BY 10
        TAD     CHCH    /ADD IN THE DIGIT
        JMP     FMTDLP  /STORE IT BACK AND CONTINUE
\f/PARENTHESIS AND DIGIT ROUTINES

LPAREN, TAD     FMTPXR
        TAD     (2-FMTPDL
        SZA             /ARE WE AT PARENTHESIS LEVEL 1?
        JMP     .+3     /NO
        TAD     FMPBYT  /YES - STORE A POINTER TO THE FIRST DIGIT OF THE
        DCA I   (FMTPDL-2       /GROUP COUNT PRECEDING THIS PAREN
                        /AS THE LOOP POINTER FOR LEVEL 1
        TAD     [7
        SPA CLA         /PUSHDOWN OVERFLOW?
FPOERR, JMS I   ERR     /YES
        AC7775
        TAD     FMTPXR
        DCA     FMTPXR  /BUMP PARENTHESIS PUSHDOWN POINTER
        TAD     FMTBYT
        DCA I   FMTPXR  /SAVE BYTE POINTER
        TAD     FMTNUM
        SNA
        IAC             /NO GROUP COUNT MEANS COUNT = 1
        CIA
        DCA I   FMTPXR  /SAVE LOOP COUNT
        DCA I   (FMTPDL-1       /INITIAL GROUP COUNT IS INFINITE!
RPLOOP, AC7776  /COME HERE ON RIGHT PAREN ALSO
        TAD     FMTPXR  /BACK UP FORMAT PDL POINTER
        JMP     FMTSET  /RESTORE FMTBYT FROM TOP OF LIST

FMPBYT, 0

RPAREN, JMS I   (DOFMT  /EXECUTE PREVIOUS SPEC IF ANY
        TAD     FMTPXR
        TAD     (2-FMTPDL       /IS THIS THE FINAL RIGHT PAREN?
        SNA CLA
        JMS I   [ENDREC /YES - CHECK FOR END OF FORMAT
        ISZ I   FMTPXR  /BUMP COUNT
        JMP     RPLOOP  /DIDN'T OVERFLOW - LOOP TO BYTE AFTER (
        ISZ     FMTPXR  /POP UP PARENTHESES STACK
        JMP     FMTFLP  /CONTINUE PAST RIGHT PAREN
        PAGE
\f/QUOTE AND HOLLERITH FORMAT PROCESSORS

KWOTE,  TAD     MINUS5  /APOSTROPHE PROCESSOR
DBLQOT, TAD     (-42    /QUOTE PROCESSOR
        DCA     KWODEL  /SAVE TERMINATOR
        JMS     DOFMT   /PROCESS PRECEDING FIELD , IF ANY
        SKP
KWOTLP, JMS     FMTHCV  /PROCESS ONE CHARACTER
        JMS I   [FMTGCH /GET THE NEXT FORMAT CHAR
        TAD     KWODEL
        SZA CLA         /IS IT THE TERMINATOR?
        JMP     KWOTLP  /NO - PROCESS IT AND CONTINUE
        ISZ     FMTBYT  /BUMP OVER TERMINATOR
        JMS I   [FMTGCH
        TAD     KWODEL
        SNA CLA         /IS THIS ANOTHER TERMINATOR?
        JMP     KWOTLP  /TWO TERMINATORS PRINT AS ONE
        JMP I   (FMTFLP /OTHERWISE GO BACK TO FORMAT LOOP

HFMT,   JMS     MORE    /MORE CHARACTERS?
        JMS     FMTHCV  /YES - PROCESS ONE
        JMP     HFMT    /AND LOOP

FMTHCV, 0               /ROUTINE COMMON TO H AND QUOTED FORMATS
        TAD     RWFLAG  /PROCESSES ONE CHAR IN OR OUT OF THE FORMAT
H7700,  SMA CLA         /IN OR OUT?
        JMP     FMTHIN  /IN
        JMS I   [FMTGCH /OUT - GET THE CHAR
        JMS I   [FMTOUT /PRINT IT
        JMP     FMTHCR  /RETURN
FMTHIN, JMS I   [FMTIN  /INPUT - GET THE CHAR FROM THE INPUT LINE
        DCA     W       /SAVE IT
        JMS I   (FMTGAD
        SZL             /WHICH SIDE?
        JMP     FHRGHT  /RIGHT SIDE
        AND     [77     /LEFT - KEEP RIGHT CHAR
        DCA     MORE
        TAD     W
        CLL RTL
        RTL
        RTL
        TAD     MORE    /ADD NEW CHAR IN ON THE LEFT
        JMP     .+3
FHRGHT, AND     H7700   /KEEP THE CHAR ON THE LEFT
        TAD     W       /ADD NEW CHAR IN ON THE RIGHT
        DCA I   D       /RESTORE ALTERED WORD
        CDF 0
FMTHCR, ISZ     FMTBYT  /BUMP BYTE POINTER
        JMP I   FMTHCV

KWODEL, 0               /MUST BE UNIQUE!
\fMORE,  0               /SUBR TO BUMP REPEAT COUNT AND EXIT ON OVFLO
        ISZ     N
        JMP I   MORE
DOFRTN, DCA     FMTTYP  /INDICATE NO SPECIFICATION COLLECTED
        JMP I   DOFMT   /RETURN FROM "DOFMT"

DOFMT,  0               /ROUTINE TO PROCESS A FORMAT SPECIFICATION
        TAD     FMTNUM  /GET THE CURRENT NUMBER
        DCA     D       /STORE IT AS DECIMAL POINT SPEC
        DCA     IFLG
        DCA     EFLG
        DCA     GFLG    /ZERO CONVERSION FLAGS
        TAD     FMTTYP
        SNA CLA         /ANY SPECIFICATION WAITING?
        JMP I   DOFMT   /NO - JUST RETURN
        TAD     W
        TAD     D       /IF THERE WAS NO W OR D SPECIFICATION,
        SNA CLA
        JMP     FMTERR  /ITS AN ERROR
        TAD     FMTTYP
        JMS I   [CHTYPE /YES - WHICH ONE?
        -30;    XFMT    /X
        -24;    TFMT    /T
        -20;    PFMT    /P
        -14;    LFMT    /L
        -11;    IFMT    /I
        -10;    HFMT    /H
        -7;     GFMT    /G
        -6;     FFMT    /F
MINUS5, -5;     EFMT    /E
        -4;DF,  EFMT    /D - EQUIVALENT TO E IF NO D.P. FPP
        -2;BF,  FFMT    /B - EQUIVALENT TO F IF NO D.P. FPP
        -1;     AFMT    /A
        0               /NONE OF THE ABOVE - ERROR
FMTERR, JMS I   ERR
\fENDREC,        0               /ROUTINE TO END A LINE AND MAYBE THE I/O
        JMS I   [EOLINE
        CLA IAC
        AND     RWFLAG  /LO BIT OF RWFLAG IS "I/O LIST EXHAUSTED" FLAG
        SNA CLA         /SKIP IF NO MORE ELEMENTS IN I/O LIST
        JMP I   ENDREC
        JMP I   [ENDIO  /NOW FINISH UP AND LEAVE

SLASH,  JMS     DOFMT   /EXECUTE THE FIELD SPEC IF ANY
        JMS I   [EOLINE /TERMINATE CURRENT LINE
        JMP I   (FMTFLP

PFMT,   CLA CMA
        TAD     FMTNUM
        ISZ     MINFLG  /P FORMAT - CHECK FOR NEGATIVE SCALE
        CIA
        DCA     PFACT
        STA             /FALL INTO CODE TO CLEAR MINFLG
        DCA     MINFLG  /SET FLAG ON MINUS
        JMP     DOFRTN

FMINUS, JMS     DOFMT   /EXECUTE PRECEDING SPEC
        DCA     MINFLG  /CLEAR MINUS FLAG
        JMP I   (FMTFLP

MINFLG, -1

FMTPER, TAD     FMTNUM  /PERIOD PROCESSOR
        DCA     W       /STORE WIDTH
        JMP I   (FMTFLP

ABORTO, JMS     DOFMT   /$ - SPECIAL HACK TO ALLOW PROMPTS
        DCA     EOLSW   /FAKE BEGINNING OF LINE
        DCA I   (TTYLF  /INHIBIT LF BEFORE NEXT TTY INPUT
        JMP I   [ENDIO  /GO AWAY
        PAGE
\fCHTYPE,        0               /ROUTINE TO CLASSIFY CHARACTERS
        DCA     CHCH    /SAVE CHAR
        JMP     CHLOOP+1
CDIGIT, TAD     CHCH    /CHECK FOR DIGIT
        TAD     (-72
        CLL
        TAD     [12
        SZL             /IS CHAR A DIGIT?
        JMP     JMPOUT  /YES
CHLOOP, ISZ     CHTYPE  /SKIP OVER ADDRESS
        CLA
        TAD I   CHTYPE
        ISZ     CHTYPE
        SMA             /END OF LIST?
        JMP     JMPOTX  /MAYBE - JUMP WITH CODE IN AC
        TAD     CHCH
        SZA CLA         /DOES CHAR MATCH CHAR ON LIST?
        JMP     CHLOOP  /NO - KEEP LOOKING
JMPOUT, DCA     CHCH    /ZERO CHAR
        TAD I   CHTYPE
        DCA     CHTYPE  /SET UP TO RETURN INDIRECTLY
JMPOTX, SZA CLA         /IS THIS THE END?
        JMP     CDIGIT  /NO - GO CHECK FOR DIGIT
        JMP I   CHTYPE  /GO TO SPECIFIED ADDRESS


SKPOUT, 0               /ROUTINE USED BY DATA-HANDLING SPECIFICATIONS
        JMS I   [MORE   /CHECK FOR REPEAT COUNT EXHAUSTED
        TAD     RWFLAG
        CLL RAR
        SZA CLA         /IF OUTPUT,
        ISZ     SKPOUT  /SKIP RETURN
        SZL CLA         /IF END OF I/O LIST,
        JMS I   [ENDREC /DON'T RETURN AT ALL - GO AWAY
        JMP I   SKPOUT
\f/A FORMAT PROCESSOR

AINPUT, TAD     (4040
        DCA     ACH
        TAD     (4040
        DCA     ACL     /INITIALIZE LOW-ORDER WORDS TO BLANKS
AINPTL, JMS     GADR
        SZL             /LEFT OR RIGHT?
        JMP     AINPTR  /RIGHT
        JMS I   [FMTIN
        STL RTL         /INPUT CHAR GOES IN HIGH-ORDER
        RTL             /WITH BLANK IN LOW-ORDER
        RTL
        JMP     AINPTC
AINPTR, JMS I   [FMTIN
        TAD I   FMTGLR  /COMBINE INPUT CHAR AND OLD LEFT HALF
        TAD     [-40    /DELETE PREVIOUS RIGHT-HALF SPACE
AINPTC, DCA I   FMTGLR  /STORE WORD
        ISZ     W
        JMP     AINPTL  /LOOP AROUND WIDTH
ANXT,   JMS I   [GETLMN /GET NEXT ELEMENT
AFMT,   TAD     D
        CIA
        DCA     W       /SAVE FIELD WODTH AS A COUNT
        JMS I   [SKPOUT /CHECK FOR REPEAT COUNT OVFLO AND I/O DIR
        JMP     AINPUT
AOTPUT, JMS     GADR    /OUTPUT - GET ADDRESS OF BYTE
        TAD I   FMTGLR
        JMS     FMTGLR  /GET BYTE
        JMS I   [FMTOUT /PRINT IT
        ISZ     W
        JMP     AOTPUT  /LOOP ON WIDTH
        JMP     ANXT

FMTGLR, 0               /SUBR TO EXTRACT A CHAR FROM A WORD
        SZL
        JMP     .+4     /RIGHT HALF
        RTR
        RTR
        RTR             /LEFT HALF - ROTATE INTO RIGHT HALF
        AND     [77
        JMP I   FMTGLR

GADR,   0               /BYTE ADDRESS ROUTINE FOR A FORMAT PROCESSOR
        TAD     D
        TAD     W       /FORM BYTE OFFSET IN THE RANGE 0 THRU D-1
        CLL RAR
        TAD     (ACX
        DCA     FMTGLR
        JMP I   GADR    /LEAVE WITH L/R FLAG IN LINK
\f/"STOP" ROUTINE - TERMINATES JOB

CALXIT, TAD     EXDVNO
        CIA
        DCA     ACI     /GO THROUGH THE FORTRAN UNIT NUMBERS.
        DCA I   (ENDFLS /*K* TURN "ENDFL" INTO A SUBROUTINE
        JMS I   (LDDSRN /IF WE FIND A UNIT WHICH IS BEING USED
        SNA CLA         /AND HAS NOT BEEN ENDFILED,
        JMP     XITISZ  /WE WILL DUMP THE CURRENT BUFFER (IF IT
        CLA IAC         /IS A FORMATTED OUTPUT FILE) AND
        AND     FFLAGS  /END-FILE IT
        SNA CLA
        JMS I   (ENDFL
XITISZ, ISZ     EXDVNO
        JMP     CALXIT
LPTTWT, TAD I   LPGET   /WAIT FOR LINE PRINTER AND TELETYPE TO
        TAD     TOCHR   /GO QUIET.
        SZA CLA
        JMP     LPTTWT
        ISZ     CLNADR  /SET UP TO CLOSE OUTPUT FILES
PDPXIT, IOF             /ENTER HERE FROM 7605
        CDF 0           /TO PROTECT CLODS WITH PDP 8/E'S
        JMS I   (7607
        0210
        7400            /READ IN CLEANUP ROUTINE
        37              /AND OS/8 PAGE 17600
        JMP     .-5     /AYEEEE!! SYSTEM DEVICE GONZO!
        CDF CIF 10
        JMP I   CLNADR  /CLOSE TENTATIVE FILES AND EXIT
CLNADR, CLNUP
EXDVNO, -11

ARGLD,  0               /ROUTINE TO GET VALUE OF AN ARG
        JMS I   [FETPC
        AND     [7      /THROW AWAY OPCODE (JA)
        TAD     FLDTM2
        DCA     FGPBF
        JMS I   [FETPC  /CONSTRUCT AN FPP INSTRUCTION
        DCA     BIOPTR
        JMS I   [FPGO
        FGPBF
        JMP I   ARGLD

FLDTM2, FLDA+LONG
        FTEMP2
        FEXIT
        PAGE
\f/SUBROUTINE TO OPEN A UNIT FOR I/O

RWINIT, 0
        DCA     RWFLAG  /DIRECTION IN AC ON ENTRY
        AC7776
        AND I   RWINIT  /IF CALLED FROM BACKSPACE, REWIND OR ENDFILE
        SZA CLA         /UNIT NUMBER IS IN FAC
        JMS I   [ARGLD  /OTHERWISE, GET UNIT NUMBER
        JMS I   [FFIX
        TAD     ACI
        CLL CMA
        TAD     [12
        SZL CLA         /CHECK DEVICE NUMBER IN RANGE 0-9
        JMS     LDDSRN  /LOAD DSRN ENTRY INTO PAGE 0
        SNA CLA         /IS UNIT INITIALIZED?
UNTERR, JMS I   ERR     /NO - ERROR
        TAD     RWFLAG
        SPA             /IF WE ARE WRITEING FOR THE FIRST TIME
        TAD     FFLAGS  /ON A UNIT WHICH WAS BEING READ,
        CMA RAL         /WE MUST BUMP THE RELATIVE BLOCK NUMBER DOWN
        SNL SMA CLA     /ONE BECAUSE OF A PHILOSOPHICAL DIFFERENCE
        JMS I   (RD2WR  /BETWEEN READ AND WRITE
        TAD I   RWINIT
        TAD     RWFLAG  /OR THE I/O TYPE AND
        CMA
        AND     FFLAGS  /DIRECTION BITS INTO THE FLAG WORD
        TAD I   RWINIT
        TAD     RWFLAG
        DCA     FFLAGS
        TAD     FFLAGS
        CMA RTL
        SNL SMA CLA     /IT IS ILLEGAL TO ACCESS A FILE IN
        JMP     UNTERR  /FORMATTED AND UNFORMATTED MODES
        ISZ     RWINIT
        TAD     ACI
        CLL RAL
        TAD     ACI
        TAD     (DATABL-4
        DCA     XR      /STORE POINTER INTO DIRECT-ACCESS TABLE
        JMP I   RWINIT
\f/REWIND AND END FILE

RWIND,  JMS     RWINIT  /GET THE DSRN ENTRY
        0               /DON'T PLAY WITH MODES
        AC2000
        TAD     FFLAGS
        SNA CLA         /IF FORMATTED OUTPUT FILE AND NOT EOF'D
        JMS     DMPBUF  /DUMP LAST BUFFER AS A FAVOR
ATLDMK, CLA IAC
        AND     FFLAGS  /KILL ALL FLAG BITS
        DCA     FFLAGS  /EXCEPT "END-FILED" BIT
        TAD     BADFLD
        AND     [7400
        DCA     CHRPTR
        AC7775
        DCA     CHRCTR  /INITIALIZE BUFFER POINTERS
        DCA     RELBLK  /AND RELATIVE BLOCK #
        JMP I   [ENDIO  /RESTORE DSRN AND EXIT

ENDFL,  JMS     RWINIT  /*K* USED AS A SUBROUTINE BY CALXIT
        1               /GET DSRN, SET "END FILE" FLAG
        TAD     FFLAGS  /IF THE FILE IS UNFORMATTED,
        CMA RAL         /OR WAS NOT OUTPUT ONTO,
        SNL SMA CLA     /THEN ENDFILE DOES NOTHING.
        JMS     DMPBUF  /ELSE DUMP THE FINAL BUFFER
        AC3777
        AND     FFLAGS  /CLEAR WRITE BIT SO WE WILL NOT TRY
SETTOT, DCA     FFLAGS  /ANYTHING ON A SUBSEQUENT ENDFILE
        TAD     RELBLK  /SET NEW LENGTH OF FILE IN CASE ITS TENTATIVE,
        DCA     TOTBLK  /AND SO WE WON'T READ PAST EOF.
ENDIO,  JMS     INITMV  /SET UP DSRN POINTERS
        TAD I   XR1
        DCA I   XR      /STORE BACK THE DSRN ENTRY
        ISZ     T       /FOR THIS LOGICAL UNIT
        JMP     .-3
        DCA     VEOFSW  /CLEAR EOFSW AT END OF EVERY READ
ENDFLS, JMP I   [RETURN /RETURN TO THE CALLING PROGRAM
        JMP I   ENDFL   /*K* OR RETURN TO CALXIT

INITMV, 0               /ROUTINE TO SET UP STUFF
ICDF0,  CDF 0
        TAD     LOGUNT
        DCA     XR
        TAD     (HAND-1
        DCA     XR1
        TAD     (-11
        DCA     T
        JMP I   INITMV
\f/ROUTINE TO DUMP CURRENT OUTPUT BUFFER WITH ^Z AT THE END

DMPBUF, 0
        ISZ     EOLSW   /FORCE COLUMN 1 SWITCH OFF
        TAD     (7712   /OUTPUT A LINE FEED
        JMS I   [FMTOUT
        TAD     HAND    /IF THE FILE IS BEING OUTPUT VIA
        SMA CLA         /AN OS/8 HANDLER,
        JMP     CLREOL  /WE MUST TERMINATE THE BUFFER PROPERLY.
        TAD     (32
CTZLP,  TAD     Z7700   /OUTPUT A ^Z AND FILL BUFFER WITH ZEROES.
        JMS I   [FMTOUT /NEGATIVE NUMBERS TURN INTO CONTROL CHARS
        TAD     CHRPTR
        AND     [377
        TAD     CHRCTR  /FILL THE BUFFER UNTIL CHRPTR POINTS TO
        IAC             /A BLOCK BOUNDARY AND CHRCTR = -3
Z7700,  SMA CLA         /WE ARE THEN AT BUFFER-END
        JMP     CTZLP
CLREOL, DCA     EOLSW   /RESET TO BEGINNING OF LINE
        JMP I   DMPBUF  /RETURN

/ROUTINE TO MOVE THE PROPER DSRN ENTRY INTO PAGE 0

LDDSRN, 0
        TAD     ACI     / READ/WRITE INIT SINGS THIS SONG,
        CLL RTL         / (DOO DAH, DOO DAH,)
        RAL             / DSRN ENTRIES 9 WORDS LONG
        TAD     ACI     / (OH, DEE DOO DAH DAY).

        SNA                     /DEVICE NUMBER 0 IS SPECIAL -
        TAD     (PTTY+11-DSRN   /IT'S ALWAYS THE TELETYPE
        TAD     (DSRN-12
        DCA     LOGUNT
        JMS     INITMV  /SET UP FOR MOVE
        TAD I   XR
        DCA I   XR1     /PUT DSRN ENTRY IN PAGE 0
        ISZ     T
        JMP     .-3
        TAD     BADFLD
        AND     [70
        TAD     ICDF0
        DCA     BUFCDF  /SAVE BUFFER FIELD AS A CDF
        TAD     HAND
        JMP I   LDDSRN
        PAGE
\f/BACKSPACE ROUTINE - WORKS ON BINARY OR ASCII FILES

BKSPC,  JMS I   [RWINIT
        0               /GET THE DSRN ENTRY WITHOUT ALTERING MODE
        TAD     HAND
        SMA CLA
        JMP I   [UNTERR /UNIT MUST BE BLOCK ORIENTED
        AC2000
        AND     FFLAGS
        SZA CLA         /IS FILE FORMATTED?
        JMP     BKASCI  /YES - PAIN IN NECK
        JMS     BMPBLK  /UNFORMATTED FILE - REREAD LAST BLOCK
        TAD     CHRPTR
        TAD     [377
        DCA     T
        JMS     BUFFLD  /SET DATA FIELD TO FIELD OF BUFFER
        TAD I   T       /LOOK AT LAST WORD IN BUFFER
        CIA             /REGARD IT AS THE NUMBER OF BLOCKS/RECORD
        TAD     RELBLK
        DCA     RELBLK  /RELBLK POINTS TO FIRST BLOCK OF PREV. REC
        JMP I   [ENDIO

BMPBLK, 0               /SUBR TO BUMP BLOCK # BACK AND READ
        CMA CLL         /AC MAY NOT BE 0 ON ENTRY
        TAD     RELBLK
        DCA     RELBLK  /BUMP BLOCK BACK
        SNL
        JMP I   (ATLDMK /BACKSPACED TOO FAR - CALL IT QUITS
        DCA     CHRPTR  /ZERO CHRPTR TO FORCE A READ FROM MASSIO
        JMS I   [MASSIO /READ A BLOCK
        JMP I   BMPBLK

/****   NULL JOB GOES HERE FOR LACK OF A BETTER PLACE ****

NULLJB, TAD     N2525
NULLLP, ISZ     N2525   /PUT THE FAMOUS "POLY BASIC PATTERN"
        JMP     NULLLP  /IN THE AC LIGHTS
        ISZ     NUMISZ
        JMP     NULLLP
        CML CMA RAR
        DCA     N2525
        TAD     [-4
        DCA     NUMISZ
        JMP I   (VBACKG /GOT SOMETHING MORE USEFUL TO DO?
N2525,  2525
NUMISZ, -4
\f/BACKSPACE FOR FORMATTED FILES

BKLORD, TAD I   CHRPTR
        ISZ     CHRPTR
        NOP
        AND     [177    /GET 7 BITS
        TAD     (-15    /COMPARE WITH C.R. - SINCE WE SKIPPED
        SNA CLA         /THE FIRST ONE THIS WILL BELONG TO THE PREVIOUS
        JMP I   [ENDIO  /LINE AND WE WILL BE DONE (HAH!)
BKASCI, JMS I   (MASBMP /A COMPLICATED MESS - FIRST BUMP THE 
        SKP             /CHARACTER POINTER BACK TWO PLACES
        JMP     BKGTCH  /AND THEN FETCH A CHARACTER.  THIS WILL IGNORE
        TAD     BADFLD  /THE LAST CHAR READ/WRITTEN (WHICH SHOULD
        AND     [7400   /BE A CARRIAGE RETURN).
        CIA
        TAD     CHRPTR
        CLL RAR
        SZA CLA         /TEST WHETHER WE HAVE TO READ AN OLD BUFFER
        JMP     BKNORD  /NO
        TAD     CHRCTR  /SAVE POSITION IN CURRENT DOUBLEWORD
        DCA     GETCH3
        DCA     CHRPTR
        AC4000          /IF WE ARE BACKSPACING AN OUTPUT FILE,
        TAD     FFLAGS  /WE MUST SAVE THE INFORMATION IN THE
        SPA             /CURRENT BUFFER BY WRITING IT OUT.
        JMP     .+4
        DCA     FFLAGS  /ALSO CHANGE THE UNIT TO AN INPUT FILE
        AC4000          /(RWINIT TAKES CARE OF SWITCHING BACK TO OUTPUT)
        JMS I   [MASSIO
        CLA IAC         /WE DON'T WANT THE LAST BLOCK READ/WRITTEN,
        JMS     BMPBLK  /THAT'S IN CORE - WE WANT THE ONE
        TAD     GETCH3  /BEFORE THAT.
        DCA     CHRCTR
        TAD     CHRCTR
        TAD     (401
        SKP             /COMPUTE WORD POINTER FROM CHAR POINTER
BKNORD, STA
        TAD     CHRPTR
        DCA     CHRPTR  /BUMP WD PTR BACK 1
BKGTCH, JMS I   (MASBMP /NOW GET A CHARACTER - THIS LOOKS A LOT
        JMP     BKLORD  /LIKE THE INPUT ROUTINE
        JMS     GETCH3
        JMP     BKLORD+1
\fGETCH3,        0               /COMMON CODE BETWEEN BACKSPACE AND INPUT
        TAD I   CHRPTR
        AND     [7400
        DCA     BMPBLK  /HANDY TEMPORARY
        ISZ     CHRPTR
        TAD I   CHRPTR
        AND     [7400
        CLL RTR
        RTR             /COMBINE TWO 4-BIT QUANTITIES
        TAD     BMPBLK  /INTO A CHARACTER
        CLL RTR
        RTR
        JMP I   GETCH3

DATABL, ZBLOCK  33      /DIRECT ACCESS TABLE
        PAGE
\f/I,E,F,AND G FORMAT CONVERSIONS

IFMT,   TAD     D
        DCA     W       /SET WIDTH PROPERLY
        DCA     D       /FOR SCALING PURPOSES
        STA
        DCA     IFLG
        JMP     FFMT

GFMT,   STA
        DCA     GFLG    /SET G AND E FLAGS

EFMT,   STA
        DCA     EFLG    /SET E FLAG
        JMP     FFMT

IGEF,   JMS I   [GETLMN /MAIN LOOP FOR CONVERSIONS - SKIPPED 1ST TIME
FFMT,   TAD     D
        DCA     OD      /SAVE COUNT OF POST-D.P. DIGITS
        TAD     IFLG
        SNA CLA         /APPLY THE P-SCALE FACTOR
        TAD     PFACT   /ONLY IF THE FORMAT IS NOT I
        DCA     PFACTX
        DCA     SCALE   /DON'T LOOK FOR TROUBLE
        JMS I   [SKPOUT /CHECK IF MORE AND TEST DIRECTION
        JMP I   (IGEFIN /INPUT
        STA
        DCA I   [FFNEG  /USE NEGATE ROUTINE HEADER AS SIGN FLAG
        TAD     EFLG
        CLL RAL
        CLL RAL         /0 IF NOT E, -4 IF E
        TAD     W       /THIS PROVIDES FOR THE EXP. FIELD (IF E FMT)
        DCA     OW      /OR THE 4 TRAILING SPACES (IF G FMT)
        TAD     ACH
        SNA
        JMP     SKPSHT  /AC IS ZERO - SKP A LOT OF SHT
        SPA CLA
        JMS I   [FFNEG  /AC<0 - NEGATE IT AND SET FLAG (CLEVER)
SCALUP, DCA     SCALE
        TAD     ACX
        SMA SZA CLA     /AC<1.0?
        JMP     GT1     /NO
        JMS I   [FPGO   /YES - MULTIPLY BY 10.0
        FMUL10
        STA
        TAD     SCALE   /BUMP POWER OF TEN
        JMP     SCALUP
\f/I,G,E,F, OUTPUT CONVERSIONS - NUMBER IS NOW =>1.0

GT1,    JMS I   (SCALDN /NOW DECREASE IT TO THE INTERVAL [0,1)
        JMS I   [FPGO   /SAVE IT AWAY
        FSTTMP
        TAD     [7
        JMS     OSCALE
        JMS I   [FPGO   /USE IT TO ROUND THE NUMBER TO BE OUTPUT
        FADTMP
        JMS I   (SCALDN /WE COULD HAVE ROUNDED FROM .999... TO 1.000...
SKPSHT, TAD     GFLG    /ENTER HERE IF NUM WAS 0 - SCALE=0
        SNA CLA
        JMP     NOTG    /NOT G FORMAT
        TAD     SCALE   /G FORMAT - TEST FOR OUT OF F FORMAT RANGE
        TAD     PFACTX
        CIA CLL         /F FORMAT RANGE IS [.1,10**(D VALUE))
        TAD     OD
        SNL
        JMP     USEE    /IF OUT OF BOUNDS USE E FORMAT (FLAG IS SET)
        DCA     OD      /REDUCE D VALUE BY SCALE FACTOR
        DCA     EFLG    /TO RETAIN CORRECT # OF SIG. DIGITS
USEE,   CLA
        JMP     NOTG

/SET UP TO PRINT DIGITS


DIGCNT, 0
        TAD     PFACTX  /COMPUTE EXPONENT JUST IN CASE E FORMAT
        CIA
        TAD     SCALE
        DCA     FMTNUM
        TAD     EFLG
        SNA CLA         /NOW COMPUTE THE NUMBER OF DIGITS BEFORE THE D.P.
        TAD     SCALE   /TAKE SCALE FACTOR INTO ACCOUNT IF NOT E FORMAT
        TAD     PFACTX  /TAKE P FACTOR INTO ACCOUNT IF NOT I OR F/G
        DCA     SCALE   /STORE THE NUMBER OF DIGITS BEFORE THE D.P.
        TAD I   [FFNEG  /INCREASE NUMBER OF LEADING BLANKS BY 1
        SPA CLA         /IF THE NUMBER IS POSITIVE. THIS DEPENDS ON
        ISZ     OW      /THIS LOCATION BEING BELOW 4000.
        TAD     SCALE   /GET THE NUMBER OF PRE-D.P. DIGITS (AS NEGATIVE #)
        SPA SNA
        CLA IAC         /IF NONE, PRINT A 0 SO COUNT AS 1
        TAD     OD      /REDUCE THE WIDTH BY THIS NUMBER
        CMA
        TAD     OW      /REDUCE IT AGAIN BY THE POST-D.P. DIGIT COUNT
        CIA
        TAD     IFLG    /AND AGAIN BY 1 FOR THE D.P. (IF NOT I FORMAT)
        JMP I   DIGCNT
OW,     0
\f/I,G,E,F FORMAT - ROUTINE TO SCALE ROUNDING FACTOR

OSCALE, 0               /SUBR TO SCALE .5 THE CORRECT # OF TIMES
        DCA     NPLCS   /MAX IN AC ON ENTRY
        DCA     ACX
        AC2000          /FORM A FLOATING 0.5 IN ORDER
        DCA     ACH     /TO ROUND THE NUMBER BEFORE PRINTING.
        DCA     ACL
        TAD     EFLG    /FIGURE OUT HOW TO SCALE IT -
        SNA CLA         /THE THEORY IS THAT IT SHOULD BE SCALED
        TAD     SCALE   /DOWN BY THE NUMBER OF SIGNIFICANT
        DCA     T       /PRINTING DIGITS.  THIS CAN BE
        TAD     SCALE   /EXPRESSED AS:
        CIA CLL         /(P FACTOR) * (NOT (G FMT PRINTING AS F))
        TAD     OD      / + (SCALE FACTOR) * (NOT E FMT) + (D VALUE).
        SZL CLA         /THE SCALE FACTOR IS < 0 FOR
        TAD     GFLG    /NUMBERS < .1, WHICH REDUCES
        SNA CLA         /THE # OF SIG. DIGITS VIA LEADING ZEROS.
        TAD     PFACTX  /IF THERE ARE < 0 SIG. DIGITS
        TAD     T       /IT DOESN'T MATTER WHAT WE DO
        TAD     OD      /SINCE THE NUMBER WILL PRINT AS
        SMA             /0.00000 ANYWAY.
        CMA             /IF THERE ARE >NPLCS SIG. PRINTING DIGITS
        TAD     NPLCS   /THE ROUNDING GETS MEANINGLESS SO MAKE
        SPA             /THE EXCESS DIVISIONS DIVIDES BY 2 INSTEAD
        DCA     ACX     / OF BY 10.  THIS FUDGE WORKS QUITE WELL
        CIA             /FOR NUMBERS OF UP TO NPLCS+2
        TAD     NPLCS   /SIGNIFICANT DIGITS.
        CIA
        DCA     T
        JMP     .+3
FDIVLP, JMS I   [FPGO   /SCALE THE .5 DOWN THE CORRECT NUMBER OF TIMES
        FDIV10
        ISZ     T
        JMP     FDIVLP
        JMP I   OSCALE
NPLCS,  0
ONE,    1;2000;0
        PAGE
\f/I,G,E,F OUTPUT CONVERSION - ACTUAL OUTPUT SECTION

OUTNUM, SMA             /CHECK FOR FIELD OVERFLOW
        JMP     ASTSK1  /YES - PRINT *******
        JMS     OBLNKS  /PRINT LEADING BLANKS - AC IS NOT 0!
                        /***IMPORTANT - OBLNKS CLEARS AC1 ***
        AC7775
        ISZ I   [FFNEG  /IF SIGN IS NEGATIVE,
        JMS     DIGIT   /OUTPUT A MINUS SIGN
        CLA             /OTHERWISE OUTPUT NOTHING
        TAD     ACX
        SNA             /ALIGN THE FAC MANTISSA INTO A DOUBLEWORD
        JMS I   [AL1    /FRACTION IN THE RANGE [.1,1)
        IAC             /THIS INVOLVES SHIFTING THE MANTISSA
        CMA             /RIGHT BY (-ACX-1) PLACES
        SMA             /WHERE A NEGATIVE NUMBER MEANS A LEFT SHIFT.
        JMS I   [ACSR
        CLA
        TAD     ACL     /NOW MOVE THE FAC DOWN A WORD SO THAT
        DCA     AC1     /WHEN WE MULTIPLY BY 10 THE OVERFLOW APPEARS
        TAD     ACH     /IN THE HIGH-ORDER WORD
        DCA     ACL
        TAD     SCALE
        SPA SNA         /DO WE HAVE DIGITS TO THE LEFT OF THE D.P.?
        JMP     PRZERO  /NO - PRINT A ZERO THERE
        JMS     DIGITS  /YES - PRINT THEM
PRDCPT, TAD     IFLG
        SZA CLA
        JMP I   (IGEF   /IF I FORMAT, WE'RE DONE NOW
        AC7776
        JMS     DIGIT   /OTHERWISE PRINT DECIMAL POINT
        TAD     SCALE
        SMA CLA         /CHECK WHETHER WE NEED TO PRINT LEADING ZEROS
        JMP     NOLZRO  /NO
        TAD     SCALE
        DCA     T
LZLOOP, STA CLL
        TAD     OD      /BUMP D VALUE DOWN BY ONE
        SNL             /IF IT GOES NEGATIVE,
        JMP     NOMOAC  /WE'VE RUN OUT OF FIELD WIDTH
        DCA     OD      
        JMS     DIGIT   /PRINT A ZERO
        ISZ     T       /UNTIL THE COUNT (OR THE WIDTH) RUNS OUT
        JMP     LZLOOP
NOLZRO, TAD     OD
        SZA             /IF THERE ARE ANY DIGITS YET TO BE PRINTED,
        JMS     DIGITS  /PRINT THEM
\f/I,G,E,F OUTPUT CONVERSION - FINISH UP

NOMOAC, CLA
        TAD     EFLG
        SNA CLA         /E FORMAT?
        JMP     CHKG    /NO - CHECK FOR G FORMAT OUTPUT AS F
        JMS     EXPFLD
        JMP I   (IGEF
EXPFLD, 0
        TAD     (5
        JMS I   [FMTOUT /OUTPUT "E"
        TAD     FMTNUM  /GET EXPONENT
        CLL
        SPA
        CML CIA         /SEPARATE INTO MAGNITUDE AND SIGN
        DCA     FMTNUM  /SAVE MAGNITUDE
        RTL
        TAD     (-5     /PRINT + OR -
        JMS     DIGIT
        DCA     T       /INITIALIZE QUOTIENT OF DIVISION
DVELP,  TAD     FMTNUM  /SUBTRACT 10 FROM EXPONENT
        TAD     [-12
        SPA             /DID IT GO NEGATIVE?
        JMP     PRNTXP  /YES - DONE
        DCA     FMTNUM  /NO - STORE IT BACK
        ISZ     T       /BUMP QUOTIENT
        JMP     DVELP   /LOOP
PRNTXP, CLA
        TAD     T
        TAD     [-12
        SMA CLA
        JMP     ASTSK3
        TAD     T
        JMS     DIGIT
        TAD     FMTNUM
        JMS     DIGIT   /PRINT TWO DIGITS OF EXPONENT
        JMP I   EXPFLD

CHKG,   TAD     GFLG
        SNA             /WAS IT G FORMAT?
        JMP I   (IGEF   /NO - F OR I - DONE
        DCA     EFLG    /RE-SET EFLG SINCE WE ZEROED IT BEFORE
        TAD     (-5
        JMS     OBLNKS  /OUTPUT 4 BLANKS
        JMP I   (IGEF   /DONE WITH G FORMAT OUTPUT

PRZERO, CLA             /COME HERE IF NO SIG. DIGITS LEFT OF D.P.
        JMS     DIGIT   /PRINT A ZERO
        JMP     PRDCPT  /CONTINUE

ASTSK3, AC0002
        JMP     .+3
ASTSK1, CLA             /CLEAR THE AC
        TAD     W       /GET THE FIELD WIDTH
        JMS I   [ASTRSK
        JMP I   (IGEF
\f/I,G,E,F OUTPUT CONVERSION - OUTPUT SUBROUTINES

OBLNKS, 0               /SUBROUTINE TO PRINT A STRING OF BLANKS
        DCA     AC1     /MUST LEAVE AC1 ZERO ON EXIT SO THAT
        JMP     .+3     /FAC LEFT SHIFT WON'T SHIFT IN GARBAGE LATER ON
        TAD     [40
        JMS I   [FMTOUT /OUTPUT A BLANK
        ISZ     AC1
        JMP     .-3     /LOOP
        JMP I   OBLNKS  /RETURN

DIGITS, 0               /ROUTINE TO OUTPUT A STRING OF DECIMAL DIGITS
        CIA
        DCA     T
DGLOOP, TAD     AC1
        DCA     AC2     /COPY AC INTO OPERAND FOR ADDITION LATER ON
        TAD     ACL
        DCA     OPL
        DCA     ACH     /CLEAR "OVERFLOW WORD"
        JMS I   [AL1
        JMS I   [AL1    /FAC=FAC*4
        DCA     OPH
        JMS I   [OADD
        JMS I   [AL1    /FAC=ORIGINAL FAC*10
        TAD     ACH     /GET OVERFLOW
        JMS     DIGIT   /PRINT IT
        ISZ     T       /LOOP FOR SPECIFIED NUMBER
        JMP     DGLOOP
        JMP I   DIGITS  /RETURN

DIGIT,  0               /ROUTINE TO OUTPUT A DIGIT
        TAD     [60
        JMS I   [FMTOUT /TRIVIAL, ISN'T IT?
        JMP I   DIGIT
        PAGE
\f/I,G,E,F INPUT CONVERSION

IGEFIN, STA             /OD CONTAINS SCALING IF NO D.P. IN INPUT
        DCA     DPSW    /INITIALIZE D.P. SW
        STA
        DCA     INESW   /DITTO EXPONENT SWITCH
        TAD     W
        CMA
        DCA     FMTNUM  /GET CHAR COUNT
INERSM, DCA     ACX     /RE-ENTER HERE AFTER SEEING "E"
        DCA     ACH     /CLEAR FLOATING AC
        DCA     ACL
        STA
        JMP     INMINS  /SET SIGN PLUS

INGCH,  JMS I   [FMTIN  /GET A CHAR
        JMS I   [CHTYPE /CLASSIFY IT
        1234;   IDIGIT  /DIGIT
        -56;    INDCPT  /.
        -53;    INLOOP  /+
        -55;    INMINS  /-
        -5;     INE     /E
        -40;    IBLDIG  /BLANK - TREAT LIKE 0 IN FORTRAN STANDARD
        -54;    INEONM  /,
        0               /OTHER - ERROR
INER,   JMS I   ERR

INDCPT, DCA     OD      /ZERO COUNT OF DIGITS AFTER D.P.
        ISZ     DPSW    /TEST AND SET D.P. SWITCH
        JMP     INER    /WHOOPS - TWO D.P.S IN A NUMBER
        JMP     INLOOP  /KEEP GOING

IBLDIG, TAD     EOLSW   /SINCE THE BLEEPING STANDARD DOESN'T COVER
        SZA CLA         /TELETYPE I/O, WE KEEP SOME COOL BY IGNORING
        JMP     INLOOP  /BLANKS CREATED BY EARLY LINE TERMINATION.

IDIGIT, TAD     CHCH
        DCA     DGT+1   /SAVE THE DIGIT
        JMS I   [FPGO   /FORM 10*FAC + DIGIT IN FAC
        ACMDGT
        TAD     DPSW
        SNA CLA
        ISZ     OD      /BUMP DIGIT COUNT IF D.P. SEEN
        JMP     INLOOP
\fINMINS,        DCA I   [FFNEG  /SET SIGN NEGATIVE

INLOOP, ISZ     FMTNUM
        JMP     INGCH   /LOOP UNTIL WIDTH EXHAUSTED
INEONM, ISZ I   [FFNEG  /CHECK IF SIGN NEGATIVE
        JMS I   [FFNEG  /YES - NEGATE
        ISZ     INESW   /SEE IF "E" SEEN
        JMP     FIXUPE  /YES - WE HAVE EXPONENT, NOT NUMBER
        TAD     PFACTX  /NO "E" SEEN - SCALE USING P FACTOR

SCALIN, TAD     OD      /GET SCALING FACTOR
        STL
        SNA
        JMP I   (IGEF   /NO SCALING NECESSARY
        SMA
        CIA CLL         /AC CONTAINS MAGNITUDE, LINK CONTAINS SIGN
        DCA     OD
        RTL
        RAL             /AC CONTAINS 0 IF DIVIDE, 4 IF MULTIPLY
        TAD     (FDIV10
        DCA     IGEFOP
        JMS I   [FPGO   /MULTIPLY OR DIVIDE BY 10.0
IGEFOP, 0
        ISZ     OD
        JMP     IGEFOP-1/MULT OR DIV APPROPRIATE NUMBER OF TIMES
        JMP I   (IGEF   /RETURN FOR MORE

INE,    ISZ     INESW   /SEE IF THIS IS THE SECOND "E"
        JMP     INER    /YES - ERROR
        ISZ     DPSW    /FORCE DP SW ON (TO INHIBIT D.P. AFTER E)
        TAD     OD      /USE SCALE FACTOR ONLY IF D.P. SEEN
        DCA     SCALE   /SAVE SCALE FACTOR
        ISZ I   [FFNEG
        JMS I   [FFNEG  /GET SIGN OF NUMBER CORRECT
        JMS I   [FPGO   /SAVE IT TEMPORARILY
        FSTTM2
        JMP     INERSM  /GO COLLECT EXPONENT

FIXUPE, JMS I   [FFIX
        TAD     ACI     /GET EXPONENT
        CIA
        TAD     SCALE   /ADD IN EXPONENT TO D.P. SCALE FACTOR
        DCA     OD
        JMS I   [FPGO   /GET NUMBER BACK IN FAC
        FLDTM2
        JMP     SCALIN

DPSW,   0
DGT,    13;0;0;0;0;0
NOTG,   JMS I   (DIGCNT
        DCA     SCALDN
        TAD     IFLG
        SNA CLA
        JMP     NOTI
        TAD     SCALE
        TAD     (-7
        SPA CLA
NOTI,   TAD     SCALDN
        JMP I   (OUTNUM
\fSCALDN,        0               /SUBROUTINE TO SCALE THE FAC LESS THAN 1.0
        TAD     ACX
        SPA SNA CLA     /IS THE FAC => 1.0?
        JMP I   SCALDN  /NO - WE'RE DONE
        JMS I   [FPGO   /DIVIDE BY TEN
        FDIV10
        ISZ     SCALE   /BUMP POWER OF TEN
        0               /BACKUP FOR WIDTH
        JMP     SCALDN+1        /LOOP

ASTRSK, 0
        CIA
        DCA     T
        TAD     (52
        JMS I   [FMTOUT
        ISZ     T
        JMP     .-3
        JMP I   ASTRSK  /GET NEXT ELEMENT

INESW,  0               /"E SEEN" SWITCH ON INPUT
        PAGE
\f/L AND X FORMATS , T FORMAT INPUT

TFMTIN, JMS I   [FMTIN  /FORCE INPUT BUFFER NON-EMPTY
        CLA             /BY FETCHING AND WASTING A CHARACTER
        TAD     (INBUFR
        DCA     INXR
        DCA     EOLSW   /SET TO BEGINNING OF LINE
        JMP     XFMT
XFMTIN, JMS I   [FMTIN
H7600,  7600            /WASTE AN INPUT CHAR
XFMT,   JMS I   [MORE   /ANY MORE CHARS?
        TAD     RWFLAG  /YES - IN OR OUT?
        SMA CLA
        JMP     XFMTIN  /IN
TPPLBL, TAD     [40     /HERE WITH AC=13 TO OVERPRINT ON T OUTPUT
        JMS I   [FMTOUT /OUT
        JMP     XFMT

LINGCH, JMS I   [FMTIN
        JMS I   [CHTYPE /GET AND CLASSIFY CHARACTER
        -40;    LINLP   /BLANK
        -24;    LINTRU  /T
        -6;     LINFLS  /F
        0               /OTHER - ERROR
        JMP I   (INER

LINTRU, TAD     (4001
LINFLS, CLL RAR         /PUT EITHER 0.0 OR 1.0 IN THE FAC
        DCA     ACH
        DCA     ACL
        RAL
        DCA     ACX
LINLP,  ISZ     W
        JMP     LINGCH  /LOOP ON FIELD WIDTH

LNXT,   JMS I   [GETLMN /GET NEXT ELEMENT FOR I/O
LFMT,   TAD     D
        CMA
        DCA     W       /SAVE WIDTH AS A COUNT
        JMS I   [SKPOUT /IN OR OUT?
        JMP     LINFLS  /IN
        CLA IAC
        TAD     W
        JMS I   (OBLNKS /OUTPUT W-1 BLANKS
        TAD     ACH
        SZA CLA
        TAD     (16
        TAD     (6      /NON-ZERO IS TRUE, ZERO FALSE
        JMS I   [FMTOUT /OUTPUT T OR F
        JMP     LNXT    /NEXT VICTIM
\f/T FORMAT OUTPUT AND RANDOM SUBROUTINES

TFMT,   TAD     D
        CIA
        DCA     N       /USE N TO FAKE OUT "X" FMT ROUTINE
        TAD     RWFLAG
        SMA CLA
        JMP     TFMTIN  /INPUT
        TAD     N
        TAD     EOLSW   /COMPARE DESIRED POSITION WITH CURRENT ONE
        SPA
        JMP     TPBLNK  /AFTER - SPACE TO IT
        JMS     EOLINE  /OUTPUT CR AND ZERO EOLSW
        JMS I   [MORE   /KLUDGE FOR "T1" FORMAT
        TAD     (13     /FAKE X FORMAT INTO PRINTING
        JMP     TPPLBL  /A + AND (N-1) SPACES
TPBLNK, DCA     N       /SAVE DIFFERENCE BETWEEN POSITIONS
        JMP     XFMT    /GO SPACE OUT

EOLINE, 0               /SUBROUTINE TO TERMINATE I/O LINE
        TAD     RWFLAG  /CAUTION - AC LO-ORDER BITS MAY NOT BE 0
        SPA CLA         /INPUT OR OUTPUT?
        JMP     EOOUTL  /OUTPUT
        JMS I   [FMTIN  /FORCE INPUT BUFFER NON-EMPTY
        CLA
        TAD     (INBUFR-1
        DCA     INXR    /SET XR TO NEGATIVE WORD AT THE
        JMP     .+3     /BEGINNING OF THE INPUT BUFFER
EOOUTL, TAD     (7715
        JMS I   [FMTOUT /OUTPUT A CARRIAGE RETURN
        DCA     EOLSW   /CLEAR EOLSW FOR INPUT AND OUTPUT
        JMP I   EOLINE
\f/ROUTINE TO MOVE A HANDLER INTO FIELD 0

GETHND, 0               /HANDLER CODE WORD IN AC ON ENTRY
        DCA     HCW     /SAVE HANDLER CODE WORD
        TAD     [7774
        AND     HCW     /KNOCK OUT ION AND FORMS CTL BITS
        CIA
        SZA             /IF HANDLER IS NOT RESIDENT,
        TAD     HKEY    /SEE IF THE HANDLER IS ALREADY
        SNA CLA         /IN THE HANDLER AREA IN FIELD 0
        JMP     HINF0   /YES
        TAD     HCW     /NO - PUT IT THERE
        AND     [70
        TAD     HCDF0
        DCA     HNDCDF  /GET CDF TO FIELD IN WHICH HANDLER RESIDES
        TAD     HCW
        AND     H7600
        TAD     (-1     /GET POINTER TO HANDLER ADDRESS
        DCA     XR1     /IN THAT FIELD
        TAD     (HPLACE-1
        DCA     XR      /ALSO TO HANDLER AREA IN FIELD 0
        TAD     [7400   /SET UP COUNT OF 7400
        DCA     HKEY    /INDEPENDENT OF HANDLER SIZE
HNDCDF, HLT
        TAD I   XR1
HCDF0,  CDF 0
        DCA I   XR      /MOVE HANDLER INTO HANDLER AREA
        ISZ     HKEY
        JMP     HNDCDF
        TAD     [7774
        AND     HCW
        DCA     HKEY    /SET NEW KEY CODE WORD
HINF0,  CLA IAC
        AND     HCW
        SNA CLA         /INTERRUPTS ALLOWED?
YHIOF,  IOF             /NO - TOO BAD
        ISZ     CTCINH  /INHIBIT ^C DURING HANDLER CALL
        JMP I   GETHND
HKEY,   0
HCW,    0
        PAGE
\f/CHARACTER INPUT ROUTINE - LINE AT A TIME

FMTIN,  0
        TAD     EOLSW
        SNA             /END OF LINE ALREADY FOUND?
        TAD I   INXR    /NO - GET CHAR FROM LINE BUFFER
        SPA             /TIME TO READ A NEW LINE?
        JMP     READLN  /YES
        SNA             /END OF LINE?
        JMP     INEOL   /YES - SET INDICATOR
        AND     [77     /CONVERT TO SIXBIT
        JMP I   FMTIN   /RETURN WITH IT
INEOL,  TAD     [40
UNPKLN, DCA     EOLSW   /SET EOL INDICATOR TO A BLANK
        JMP     FMTIN+1 /AND RETURN BLANKS FROM HERE ON IN
READLN, DCA     EOLSW   /USE EOLSW AS A COUNT SO IT WINDS UP 0
        TAD     HAND
        TAD     (-TTY
        SNA CLA         /IS IT TELETYPE INPUT?
        STA             /YES - SET TTY FLAG
        DCA     TTYFLG
        JMS     ECHO
TTYLF,  12              /ECHO LF IF TTY INPUT
        TAD     [12     /TTYLF IS ZEROED BY ABORTO
        DCA     TTYLF

READLP, CLA
        TAD     HAND
        SPA CLA         /CHARACTER ORIENTED DEVICE?
        JMP     MASSIN  /NO - UNPACK CHAR FROM BUFFER
        JMS I   HAND    /GET A CHARACTER
GOTCHR, AND     [177    /STRIP OFF PARITY
        JMS I   [CHTYPE /CLASSIFY IT
        -15;    INCRET  /CARRIAGE RETURN
        -177;   RUBOUT  /RUBOUT
        -11;    INTAB   /TAB
        -25;    CTRLU   /^U
        -32;    INEOF   /^Z
        0               /ANYTHING ELSE
        TAD     CHCH
        TAD     [-40
        SMA             /IF CHARACTER IS >37,
        JMS     INPUTC  /STORE IT AND ECHO IT IF TTY
        JMP     READLP
\f/CHARACTER INPUT ROUTINE - SPECIAL CHARACTER HANDLERS

INTAB,  JMS     INPUTC  /TAB - INSERT (AND ECHO) BLANKS
        TAD     INXR
        AND     [7
        SZA CLA         /UNTIL A COLUMN MULTIPLE OF 8 IS REACHED
        JMP     INTAB
        JMP     READLP

RUBOUT, TAD     EOLSW
        CIA
        TAD I   (INBUFR /IGNORE RUBOUTS IF LINE EMPTY
        AND     TTYFLG
        SNA CLA
        JMP     READLP  /OR IF NON-TTY INPUT
        JMS     ECHO
        134             /ECHO A BACKSLASH
IBAKUP, STA
        TAD     INXR
        DCA     INXR    /BACK UP LINE POINTER
        STA
        TAD     EOLSW
        DCA     EOLSW   /AND CHAR COUNTER
        JMP     READLP

INEOF,  TAD     VEOFSW  /CHECK SWITCH SET BY "CHKEOF" LIBRARY ROUTINE
        SNA             /WAS HE EXPECTING AN EOF?
EOFERR, JMS I   ERR     /NO
        JMS I   MCDF
        DCA     .+1
        HLT             /CDF TO FIELD OF INDICATOR VARIABLE
        AC2000
        DCA I   VEOFSW+1        /SET VARIABLE TO .5
        CDF 0           /FALL INTO CARRIAGE RETURN CODE

INCRET, DCA I   INXR    /CARRIAGE RETURN - ZERO OUT REST OF LINE
        SKP
CTRLU,  STA             /SNEAKY, SNEAKY!
        TAD     (INBUFR
        DCA     INXR    /RESET XR TO FETCH LINE CHARS
        JMS     ECHO
        15              /ECHO THE C.R.
        JMP     UNPKLN  /BACK TO FETCH FIRST CHAR

INPUTC, 0               /ROUTINE TO STORE AND ECHO A CHAR
        TAD     [40
        DCA     INTMP
        JMS     ECHO
INTMP,  0               /ECHO CHAR IF TTY INPUT
        TAD     INTMP
        DCA I   INXR    /STORE CHAR IN LINE BUFFER
        ISZ     EOLSW
        JMP I   INPUTC  /RETURN IF NO OVERFLOW
        JMP     IBAKUP  /IGNORE CHAR IF OVERFLOW
\fECHO,  0               /ROUTINE TO ECHO CHAR IF TTY INPUT
        TAD I   ECHO    /GET CHAR
        AND     TTYFLG
        SZA             /SHOULD WE ECHO?
        JMS I   HAND    /YES
        JMP I   ECHO    /RETURN TO CHARACTER - ITS SMALL
TTYFLG, 0

/CHARACTER INPUT ROUTINE - MASS STORAGE SECTION

MASSIN, JMS     MASBMP  /GET BUFFER FIELD AND CHAR NUMBER
        JMP     INLORD  /CHAR 1 OR 2 - STRAIGHTFORWARD
        JMS I   (GETCH3 /USE COMMON SUBROUTINE
        JMP     MASICM  /GO TO COMMON CODE

INLORD, JMS I   [MASSIO /CHECK IF WE SHOULD READ IN A BUFFERLOAD
        JMS     BUFFLD  /SET FIELD OF BUFFER
        TAD I   CHRPTR
MASICM, ISZ     CHRPTR  /GET THE CHAR (IN LOW 8 BITS) AND BUMP PTR
        NOP             /WATCH END OF FIELD FUNNYBUSINESS!
        CDF 0           /RESET DATA FIELD
        JMP     GOTCHR  /GO EXTRACT SEVEN BIT CHARACTER

MASBMP, 0
        JMS     BUFFLD  /SET TO BUFFER'S DATA FIELD
        ISZ     CHRCTR  /BUMP CHAR COUNTER
        JMP I   MASBMP  /CHAR 1 OR 2 - NO SWEAT
        AC7775
        DCA     CHRCTR  /CHAR 3 - RESET CHAR CTR
        AC7776
        TAD     CHRPTR  /BUMP BACK CHAR PTR
        DCA     CHRPTR
        ISZ     MASBMP
        JMP I   MASBMP  /SKIP RETURN
        PAGE
\f/CHARACTER OUTPUT ROUTINE

FMTOUT, 0
        TAD     [40     /FIRST CONVERT SIXBIT TO ASCII
        SMA             /CTL CHARS COME IN NEGATIVE
        AND     [77
        TAD     (240
        DCA     OCHAR   /SAVE ASCII CHAR (WITHOUT PARITY BIT)
        TAD     EOLSW
        SZA CLA
        JMP     NOT1ST  /FIRST CHAR IS DECODED FOR FORMS CONTROL
        AC0002          /CHECK TO SEE IF THIS UNIT
        AND     HCODEW  /SHOULD RECEIVE FORMS CONTROL
        SZA CLA
        JMP     LFPLCH  /NO - JUST PRINT A LINE FEED AND THE CHAR
        TAD     OCHAR
        JMS I   [CHTYPE /CLASSIFY CONTROL CHAR
        -261;   OUTFFX  /1 - TOP OF FORM
        -260;   OUT2LF  /0 - DOUBLE SPACE
        -253;   NOLF    /+ - OVERPRINT
        0               /ANYTHING ELSE - SINGLE SPACE
        JMP     OUTLF

OUTFFX, TAD     HAND
        TAD     (-TTY   /IF HANDLER IS TTY OUTPUT TWO LINE FEEDS
        SZA CLA         /INSTEAD OF A FORM FEED
        JMP     OUTFF
OUT2LF, TAD     [12
        DCA     OCHAR   /SET 2ND CHAR TO LINE FEED
LFPLCH, STA
        DCA     EOLSW   /SET SWITCH FOR 2ND CHAR
        TAD     OCHAR
        DCA     CHCH    /SAVE CHARACTER AWAY
OUTLF,  AC7776
OUTFF,  TAD     F214    /SUBSTITUTE THE APPROPRIATE FORM CONTROL
        DCA     OCHAR   /FOR THE CHARACTER
NOT1ST, TAD     HAND
        SPA CLA         /CHARACTER ORIENTED DEVICE?
        JMP     MASOUT  /NO - PACK CHAR INTO BUFFER
        TAD     OCHAR
        JMS I   HAND    /OUTPUT CHAR
NOLF,   ISZ     EOLSW   /BUMP CHAR CTR
        JMP I   FMTOUT  /NO - RETURN
        TAD     CHCH    /AHA - ANOTHER CHARACTER SHOULD BE OUTPUT
        JMP     OUTFF+1 /GO TO IT
\f/CHARACTER OUTPUT - MASS STORAGE OUTPUT

MASOUT, JMS I   (MASBMP /GET BUFFER FIELD AND CHAR NUMBER
        JMP     OULORD  /CHAR 1 OR 2 - STRAIGHTFORWARD
        JMS     OSUBR   /CHAR 3 - PACK FIRST HALFBYTE
        JMS     OSUBR   /PACK SECOND HALFBYTE
        AC4000
        JMS     MASSIO  /CHECK IF WE SHOULD DUMP THE BUFFER
MASOCM, CDF 0
        JMP     NOLF    /GO RETURN OR REENTER

OULORD, TAD     OCHAR
        DCA I   CHRPTR  /STORE CHAR, ZAPPING HIGH-ORDER BITS
        ISZ     CHRPTR  /BUMP CHAR PTR
F214,   214             /GUARD AGAINST OVFLO
        JMP     MASOCM  /RETURN

OSUBR,  0               /ROUTINE TO PACK A HALFBYTE
        TAD     OCHAR
        CLL RTL
        RTL             /SHIFT CHAR 4 LEFT
        DCA     OCHAR
        TAD I   CHRPTR  /CLEAR OUT ANY RESIDUE
        AND     [377    /FROM HIGH-ORDER OF BUFFER WORD
        DCA I   CHRPTR  /IN CASE WE ARE WRITING AFTER A BACKSPACE.
        TAD     OCHAR
        AND     [7400   /GET 4 BITS
        TAD I   CHRPTR
        DCA I   CHRPTR  /ADD INTO HIGH-ORDER OF BUFFER WORD
        ISZ     CHRPTR  /BUMP POINTER
        200             /OVERFLOW!
        JMP I   OSUBR

MASSIO, 0               /SUBROUTINE TO READ/WRITE BUFFER IF NECESSARY
        CDF 0
        TAD     BUFCDF  /ADD BUFFER CDF TO R/W BIT IN AC
        TAD     (-6001  /TAKE AWAY CDF, LEAVE BIT 4 ON
        DCA     IOCTL   /STORE I/O CONTROL WORD
        TAD     CHRPTR
        AND     [377
        SZA CLA         /SEE IF POINTER IS AT BUFFER BOUNDARY
        JMP I   MASSIO  /YES - RETURN DOING NOTHING
        TAD     RELBLK
        TAD     STBLK   /STORE BLOCK # IN HANDLER CALL
        DCA     BLOCK
        TAD     BADFLD
        AND     [7400
        DCA     BUFFER  /STORE BUFFER ADDRESS IN HANDLER CALL
\f/CHARACTER OUTPUT - BUFFER I/O ROUTINE CONTINUED

        TAD     TOTBLK
        CIA CLL
        TAD     RELBLK
        SZL CLA         /CHECK FOR FILE OVERFLOW
IOVFLO, JMS I   ERR     /YES - ERROR
        TAD     HCODEW
        JMS I   (GETHND /GET HANDLER INTO FIELD 0
        JMS I   HAND    /CALL HANDLER
IOCTL,  0
BUFFER, 0
BLOCK,  0
        SMA CLA         /HANDLER ERROR - ABORT
        SKP             /IF NOT EOF
IOERR,  JMS I   ERR
        JMS I   (RECOVR /CLEAR ANY FLAGS SET BY OS8 HANDLER
        ISZ     RELBLK  /BUMP RELATIVE BLOCK NUMBER
        TAD     BUFFER
        DCA     CHRPTR  /RESET CHAR PTR
        JMP I   MASSIO  /RETURN
/FPP CODE FOR I/O CONVERSION

FDIV10, FDIV+LONG
        TEN
        FEXIT
OCHAR,  0               /*** NEEDED FOR PADDING ***
FMUL10, FMUL+LONG       /FMUL10 MUST BE AT FDIV10+4
        TEN
        FEXIT

FWTOBL, FSUB+LONG
        ONE
        FDIV+LONG
        FLTG85
        FEXIT
        PAGE
\f/UNFORMATTED (BINARY) INPUT-OUTPUT

RWUNF,  JMS I   [RWINIT /"READ(N)" OR "WRITE(N)"
        1000            /"UNFORMATTED" BIT
        TAD     SZLCLA  /ENABLE SEQUENCE CHECKING
UNFIO,  DCA     SEQCHK  /*** SET SEQCHK TO "SZL CLA" OR "CLA"
        DCA     RECCTR  /ENTER HERE FROM DIRECT ACCESS
        TAD     HAND
        SMA CLA         /CHECK FOR MASS-STORAGE HANDLER
        JMP I   [UNTERR /NO - ERROR
        JMS I   [GETLMN /GET FIRST VARIABLE
        TAD     RWFLAG
        SPA CLA
RSETBP, TAD     (125    /INITIALIZE COUNT TO -86 FOR WRITE,
        CMA             /-1 FOR READ
        DCA     CHRCTR
        TAD     BADFLD
        AND     [7400
        DCA     BIOPTR  /INITIALIZE BUFFER POINTER
        TAD     BADFLD
        AND     [70
        IAC
        CLL RTR         /AC BIT 0 NOW ON
        TAD     RWFLAG  /AC BIT 0 CONTAINS COMP. OF R/W FLAG
        CLL RAR         /AC=(.NOT.RW)*2000+BUFFER FIELD
        TAD     (FSTA+LONG      /AC=(FSTA OR FLDA) + BUFFLD
        DCA     FGPBF
        JMP     UIOVLP  /SKIP FIRST VARIABLE FETCH/STORE
BFINCR, JMS I   [FPGO
        FGPBF           /LOAD OR STORE A BUFFER ENTRY
        ISZ     BIOPTR
        ISZ     BIOPTR  /INCREASE BUFFER POINTER
        ISZ     BIOPTR
        JMS I   [GETLMN /GET A VARIABLE FROM THE CALLING PROGRAM
UIOVLP, TAD     RWFLAG
        CLL RAR         /LOWORDER BIT OF RWFLAG = END LIST FLAG
        SZL CLA
        JMP     ENDUIO  /NO MORE VARIABLES - TERMINATE
        ISZ     CHRCTR  /BUMP COUNTER
        JMP     BFINCR  /ROOM IN BUFFER - MOVE VARIABLE
        JMS     UDOIO   /GET A NEW BUFFER
        JMP     RSETBP  /RESET BUFFER POINTERS AND COUNTERS

ENDUIO, TAD     RWFLAG  /COME HERE WHEN I/O LIST EXHAUSTED
        SPA CLA         /WRITE?
        JMS     UDOIO   /YES - WRITE OUT THE LAST BUFFER
        JMP I   [ENDIO  /RESTORE DSRN ENTRY AND QUIT

RECCTR, 0
\f/DIRECT-ACCESS I/O

RWDACC, JMS I   [RWINIT /"READ(N'R)" OR "WRITE(N'R)"
        1000            /DIRECT ACCESS IS UNFORMATTED I/O
        TAD I   XR
        DCA     T       /GET BLOCKS/RECORD FACTOR FROM D.A. TABLE
        JMS I   [ARGLD  /GET RECORD NUMBER
        JMS I   [FFIX   /CONVERT TO INTEGER
        TAD     T
        TAD     ACI
        ISZ     T       /MULTIPLY RECORD NUMBER BY BLOCKS/RECORD
        JMP     .-2     /TO GET RELATIVE BLOCK NUMBER
        DCA     RELBLK
        TAD I   XR
        SNA             /THIS LOC SHOULD NOT BE ZERO!
DAERR,  JMS I   ERR
        DCA     FGPBF   /IT SHOULD BE AN FSTA + THE FIELD
        TAD I   XR      /IN WHICH THE CONTROL VARIABLE IS
        DCA     BIOPTR  /STORED. THE NEXT WORD IS THE ADDRESS
        JMS I   [FPGO   /OF THE CONTROL VARIABLE IN THAT FIELD
        FADD1           /ADD 1 TO RECORD # AND STORE IN CONTROL VAR
        TAD     DUMPIT  /*K* "DCA T" SAME AS "CLA" HERE
        JMP     UNFIO   /NOW GO DO A REGULAR BINARY READ/WRITE

UDOIO,  0
        ISZ     RECCTR  /BUMP NUMBER OF RECORDS TRANSFERRED
        TAD     BADFLD
        AND     [7400
        TAD     [377    /FORM POINTER TO LAST WORD IN BUFFER
        DCA     BIOPTR
        TAD     RECCTR
        JMS     BUFFLD
        DCA I   BIOPTR  /FOR WRITE, PUT RECORD NUMBER IN 256TH WORD
UDOIOL, DCA     CHRPTR
        AC4000
        AND     RWFLAG
        JMS I   [MASSIO /DO I/O (CHRPTR=0 TO FORCE I/O)
        JMS     BUFFLD
        TAD     RECCTR
        CMA STL         /FOR READ, CHECK THE INPUT
        TAD I   BIOPTR  /SEQUENCE NUMBER TO MAKE SURE IT IS
        CDF 0           /NO LARGER THAN THE ONE WE EXPECT.
SEQCHK, SZL CLA         /*K* IF IT IS LARGER THIS IMPLIES THAT WE
        JMP I   UDOIO   /ARE STILL IN THE MIDDLE OF THE LAST
        JMP     UDOIOL  /RECORD AND SO WE READ AGAIN.
\f/DEFINE FILE PROCESSOR

DFINE,  JMS I   [RWINIT /SET UP A POINTER INTO THE D.A. TABLE
        1000            /DIRECT ACCESS I/O IS UNFORMATTED
        JMS I   [ARGLD  /GET NUMBER OF RECORDS
        JMS I   [FFIX
        TAD     ACI
        CIA
DUMPIT, DCA     T       /SAVE IT FOR MULTIPLY
        JMS I   [ARGLD  /GET THE NUMBER OF WORDS/RECORD
        JMS I   [FPGO   /CONVERT WORDS TO BLOCKS
        FWTOBL
        JMS I   [FFIX   /CONVERT TO INTEGER
        ISZ     ACI
        TAD     ACI     /MULTIPLY THE NUMBER OF BLOCKS/RECORD
        ISZ     T       /BY THE NUMBER OF RECORDS
        JMP     .-2
        DCA     RELBLK  /TO GET THE FILE LENGTH IN BLOCKS
        TAD     ACI
        CIA
        DCA I   XR      /STORE NUMBER OF BLOCKS/RECORD
        JMS I   [ARGLD  /GET POINTER TO CONTROL VARIABLE
        TAD     FGPBF
        TAD     (FSTA-FLDA      /CHANGE A LOAD TO A STORE
        DCA I   XR      /SAVE "FSTA CONTROL-VARIABLE"
        TAD     BIOPTR
        DCA I   XR
        TAD     TOTBLK
        CMA CLL
        TAD     RELBLK  /MAKE SURE WE HAVE ROOM FOR THE FILE
SZLCLA, SZL CLA
DFERR,  JMS I   ERR     /WE DON'T
        AC7776
        AND     FFLAGS
        IAC             /FORCE "END-FILED" BIT FOR CLOSE
        JMP I   (SETTOT /SET LENGTH AND EXIT
        PAGE
\f/SWAPPER AND ERROR ROUTINE

SWAP,   JMS I   [FETPC  /SWAPPER CALLING SEQUENCE:
        DCA     T       /       TRAP3 SWAP
        TAD     T       /       ADDR OVLY*4000000+LVL*100000+ENTRYADR
        AND     [7
        TAD     (JA
        DCA     STRTUP  /STORE JA TO ENTRY POINT
        JMS I   [FETPC
        DCA     STRTUP+1
        TAD     T
        AND     [70
        CLL RAR         /FORM 4*LVL
        TAD     (OVLYTB /INDEX INTO LEVEL TABLE
        DCA     ADR
        TAD     T
        AND     [7400
        DCA     T       /T CONTAINS OVERLAY NUMBER IN BITS 0-3
        CDF 0           /WATCH D.F.!
        TAD I   ADR
        TAD     T       /SEE IF THIS OVERLAY IS IN CORE
        SNA CLA
        JMP     ITSIN   /YES - DON'T LOAD
        TAD     T
        CIA
        DCA I   ADR     /MARK THIS OVERLAY IN CORE (OPTIMIST)
        ISZ     ADR
        TAD I   ADR
        AND     [7400
        DCA     OVADR   /SAVE INITIAL OVERLAY LOAD ADDRESS
        TAD I   ADR
        AND     [70
        DCA     OVIOW   /AND FIELD
        ISZ     ADR
        TAD I   ADR     /GET STARTING BLOCK OF THIS LEVEL
        DCA     OVBLK
        ISZ     ADR
        TAD I   ADR
        DCA     OVLEN   /STORE LENGTH OF OVERLAY IN BLOCKS
OVADLP, TAD     T       /LEVEL STARTING BLOCK +
        SNA             /(OVERLAY #) * (OVERLAY LENGTH)
        JMP     LOADOV  /= OVERLAY STARTING BLOCK
        TAD     [7400
        DCA     T
        TAD     OVBLK
        TAD     OVLEN
        DCA     OVBLK
        JMP     OVADLP
\f/SWAPPER - CONTINUED

LOADLP, DCA     OVLEN   /STORE UPDATED OVERLAY LENGTH
        TAD     OVIOW   /GET LAST READ CONTROL WORD
        RAL
        AND     [7400   /CONVERT BLOCK COUNT TO WORD COUNT
        TAD     OVADR   /INCREMENT OVERLAY LOAD ADDRESS (LINK = 0)
        DCA     OVADR
        RTL
        RTL             /USE THE CARRY
        TAD     OVIOW   /TO INCREMENT THE LOAD FIELD IF NECESSARY
        AND     [70
        DCA     OVIOW   /OVIOW CONTAINS ONLY THE LOAD FIELD NOW

LOADOV, TAD     OVADR
        CIA             /LOTSA CALCULATIONS HERE - OS/8 HANDLERS
        SNA             /CAN'T READ MORE THAN 15 BLOCKS AT A TIME
        TAD     [7400   /AND CANNOT READ OVER FIELD BOUNDARIES
        CLL RTL
        RTL             /SO WE MUST BREAK UP THE OVERLAY READ
        CMA CML RAL     /INTO SEVERAL SMALL READS OF MAXIMAL LENGTH.
        TAD     OVLEN   /THE NUMBER OF BLOCKS TO READ IS GIVEN BY:
        CMA             /MINIMUM(B,L,15)
        SMA             /WHERE B IS THE # OF BLOCKS LEFT IN THIS FIELD
        CLA             /AND L IS THE # OF BLOCKS LEFT IN THE OVERLAY
        TAD     OVLEN   /AND 15 IS THE # OF BLOCKS A HANDLER CAN READ
        DCA     T       /       ANSWER IN T
        TAD     T
        CLL RTR
        RTR
        RTR             /TURN NUMBER OF BLOCKS INTO 0S/8 BLOCK COUNT
        TAD     OVIOW
        DCA     OVIOW   /ADD FIELD BITS AND STORE AS I/O CONTROL WD
        TAD     OVHCDW  /GET OVERLAY HANDLER CODE WORD
        JMS I   (GETHND /LOAD HANDLER INTO FIELD 0
        JMS I   OVHND
OVIOW,  0
OVADR,  0
OVBLK,  0
OVERR,  JMS I   ERR     /WHOOPS - OVERLAY READ ERROR
        JMS     RECOVR  /CLEAR ANY NASTY FLAGS LEFT BY HANDLER
        TAD     T
        TAD     OVBLK
        DCA     OVBLK   /UPDATE BLOCK NUMBER
        TAD     T
        CIA
        TAD     OVLEN   /BUMP DOWN RECORD COUNT
        SZA             /SEE IF WE ARE DONE
        JMP     LOADLP  /NO - PREPARE FOR NEXT READ
\f/OVERLAY IN CORE - EXECUTE IT

ITSIN,  JMS I   [FPGO   /START UP FPP
        STRTUP          /AND JA TO ENTRY POINT

TRAP5I,
TRAP6I,
TRAP7I,
FPAUSE,
FPPERR, JMS I   ERR     /SHOULD NEVER GET HERE

STRTUP, 0;0             /JA ENTRY
OVLEN,  0
OVHND,  0               /SET BY LOADER
OVHCDW, 0               /SET BY LOADER

RECOVR, 0               /ROUTINE TO CLEAN UP ANY FLAGS
        DCA     CTCINH  /LEFT ON BY SLOPPY OS/8 HANDLERS.
YRCOVR, NOP
        NOP
        NOP
        NOP             /RIGHT NOW I DON'T KNOW OF ANY.
        NOP
        NOP
        NOP
        NOP
        ION
        JMP I   RECOVR

FSTTMP, FSTA+LONG
        FTEMP
        FEXIT

TEN,    4;2400;0;0;0;0  /10.0D0
FLTG85, 7;2520;0        /85.0
        PAGE
\f/INPUT BUFFER - CONTAINS STARTUP CODE

INBUFR, -206            /LENGTH
        0               /INPUT LINE BUFFER - FIRST A LITTLE PADDING,

/RTS EXECUTION INITIALIZATION - IN INPUT BUFFER

FPSTRT, 6601            /CLEAR DF32 FLAG
        PCF             /HSP FLAG
        RRB             /HSR FLAG
PP7600, 7600            /CLEAR READER CHAR
        6135            /CLEAR KW12 OR DK8-EP EVENT FLAGS
        CLA
        6132            /STOP KW12 CLOCKS
        6134            /DISABLE KW12 INTERRUPTS
        6530            /CLEAR AD8-EA FLAGS
        6050            /CLEAR VC8/E FLAG
        6500            /DISABLE XY8/E INTERRUPTS
        STA
        6130            /DISABLE DK8-EP INTERRUPTS
        CLA             /LEAVE SPACE FOR ADDITIONAL CLEARS
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        NOP
        DCA     EOLSW
LDPROG, JMS I   [FPGO   /START UP FPP OR PSEUDO-FPP
        STSWAP
HLTNOP, NOP             /SET TO HLT IF /H SPECIFIED,
        JMP     PRTCR   /SKP IF /P SPECIFIED
        TAD     .-1
        DCA     LDPROG  /BYPASS LOADING ON STARTUP
        TAD     PCHWD   /HLT
        DCA I   (PDPXIT+1
\f/ROUTINE TO PUNCH RTS+PROGRAM ON FORTRAN UNIT 9 (UNCOMMENTED)

PPTR,   TAD     P11
PCKSUM, DCA     ACI
        JMS I   (LDDSRN
        SMA CLA
        JMP I   [UNTERR
        JMP     LDRTLR
FLDLP,  DCA     PPTR
        DCA     PCKSUM
        TAD     (100
        JMS     SIXOUT
        JMS     SIXOUT
        TAD     FLD
        AND     [70
JFMOUT, JMS I   [FMTOUT /*K* ONLY WORKS FOR FIELD 0-3
        TAD     (100
        JMS     SIXOUT
        JMS     SIXOUT
FLD,    CDF 0
        TAD I   PPTR
        CDF 0
        JMS     PCHWD
        ISZ     PPTR
P11,    11
        ISZ     PCTR
        JMP     FLD
        TAD     PCKSUM
        JMS     PCHWD
        TAD     FLD
        TAD     (10
        DCA     FLD
LDRTLR, TAD     PP7600
        DCA     ACH
        TAD     [200
        JMS     SIXOUT
        ISZ     ACH
        JMP     .-3
        ISZ     FCNT
        JMP     FLDLP
        TAD     (6000
        DCA     FFLAGS
        DCA I   (ENDFLS /*K* SAME KLUDGE AS CALXIT
        JMS I   (ENDFL
        DCA I   (PDPXIT+1       /WIPE HALT SO WE CAN RETURN TO OS/8
        JMP I   (PDPXIT-1
\fPCHWD, HLT
        DCA     ACH
        TAD     ACH
        RTR
        RTR
        RTR
        AND     [77
        JMS     SIXOUT
        TAD     ACH
        AND     [77
        JMS     SIXOUT
        JMP I   PCHWD

SIXOUT, 0
        DCA     T
        CLA IAC
        DCA     EOLSW
        TAD     PCKSUM
        TAD     T
        DCA     PCKSUM
        TAD     T
        TAD     (-300
        JMS I   [FMTOUT
        JMP I   SIXOUT

PCTR,   200             /DON'T PUNCH 07600!
FCNT,   0
\fPRTCR, TAD     (215
        JMS I   PTTY    /PRINT CARRIAGE RETURN
        TAD     JFMOUT
        DCA I   (ERRENB /ENABLE ERROR TRACEBACK
        JMS I   [FPGO
        STJUMP          /NOW JUMP TO THE NEWLY-LOADED CODE
STSWAP, TRAP3           /TRAP3
        SWAP
        0
        .+1
        TRAP3
        HLTNOP
        PAGE
STJUMP, 0
        0
        ZBLOCK  INBUFR+210-.    /PAD OUT TO END OF BUFFER
\f/OVERLAY AND DSRN TABLES

        *.-4    /FIRST ENTRY IN OVLYTB ONLY NEEDED TO LOAD MAIN PGM

OVLYTB, ZBLOCK  40      /OVERLAY TABLE

DSRN,   PTR;    ZBLOCK  10
        PTP;    ZBLOCK  10
        LPT;    ZBLOCK  10
        TTY;    0;0
        1234            /*K* PREVENT PROBLEM IN
        ZBLOCK  5       /RWINIT INVOLVING WRITE
                        /AFTER READ ON TELETYPE
        ZBLOCK  55

        ZBLOCK  12      /FORMAT PARENTHESIS PUSHDOWN LIST
FMTPDL, 0               /GUARD WORD
        PAGE
\f/SOFTWARE FLOATING POINT ROUTINES WHICH ARE USED
/EVEN IF FLOATING HARDWARE IS PRESENT

/** MUST NOT DESTROY FAC! **

FFIX,   0               /ROUTINE TO FIX FAC
        STA             /ANSWER IS RETURNED IN ACI
TADACX, TAD     ACX     /ABS(FAC) MUST BE LESS THAN 2048
        CLL             /DETERMINE IF FAC EXPONENT IS
        TAD     (-13    /BETWEEN 1 AND 14
        SNA
        JMP     FIXBIG  /14 IS A SPECIAL CASE
EAEFIX, DCA     ACI
        SZL
        JMP     FIXDNE  /EXP GT 14 OR LT 1 - RETURN 0
        TAD     ACH
        JMP     FIXISZ
FIXLP,  CLL             /0 IN LINK
        SPA             /IS IT LESS THAN 0?
        CML             /YES-PUT A 1 IN LINK
        RAR             /SCALE RIGHT
FIXISZ, ISZ     ACI     /DONE YET?
        JMP     FIXLP   /NO
FIXDNE, DCA     ACI     /RETURN WITH ANSWER IN ACI
        JMP I   FFIX    /RETURN

FIXBIG, TAD     ACL     /IF EXP IS 14 WE MUST SHIFT AC FRACTION
        RAL             /LEFT ONE PLACE TO INTEGERIZE IT.
        CLA
        TAD     ACH
        RAL
        JMP     FIXDNE  /STORE ANSWER AND RETURN

SETB,   TAD     DATAF
        DCA I   (BASCDF /SET BASE PAGE LOCATION
        TAD     ADR
        DCA     BASADR
        JMP I   FPNXT
\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 HIGH ORDER MANTISSA
        CLL
        SPA             /PROPAGATE SIGN
        CML
        RAR             /SHIFT RIGHT 1, PROPAGATING SIGN
        DCA     ACH     /STORE BACK
        TAD     ACL     /GET LOW ORDER
        RAR             /SHIFT IT
        DCA     ACL     /STORE BACK
        ISZ     ACX     /INCREMENT EXPONENT
        NOP
        ISZ     AC0     /DONE?
        JMP     LOP1    /NO-LOOP
        RAR
        DCA     AC1     /SAVE 1 BIT OF OVERFLOW
        JMP I   ACSR    /YES-RETN-AC=L=0
/
/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
\fOADD,  0               /ADD OPERAND TO FAC
        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.

FETPC,  0
        ISZ     PC
        JMP     PCCDF   /NO FIELD BUMP
        ISZ     APT     /BUMP FIELD FOR FPP RESTART (IN CASE FPP EXISTS)
FPC10,  10              /PROTECTION FOR ISZ
        TAD     PCCDF
        TAD     FPC10
        DCA     PCCDF
PCCDF,  HLT
        TAD I   PC
        JMP I   FETPC

EEPUT,  STL             /EXTENDED PRECISION STORE
EEGET,  DCA     ADR     /EXTENDED PRCISION FETCH
        TAD     [-6
        DCA     DATCDF
        SNL
        AC2000          /SET UP "TAD ACX" OR "DCA ACX"
        TAD     TADACX
        DCA     EEINST
EELOOP, SNL             /LINK=1 MEANS STORE
        TAD I   ADR
EEINST, HLT
        SZL
        DCA I   ADR
        ISZ     ADR
        SKP
        JMS I   (DFBUMP
        ISZ     EEINST
        ISZ     DATCDF
        JMP     EELOOP
        JMP I   FPNXT

FSTTM2, FSTA+LONG
        FTEMP2
        FEXIT
/
FTEMP,  ZBLOCK  6
/
        PAGE
\f/RUN-TIME SYSTEM ERROR LIST

ERRLST, VARGER; ARGMSG
        UERR;   UMSG
        FPOERR; FPOMSG
        FMTERR; FMTMSG
        UNTERR; UNTMSG
        CTLBER; CTLBMS
        INER;   INMSG
        IOVFLO; IOVMSG
        IOERR;  IOMSG
        DAERR;  DAMSG
        FPPERR; FPPMSG
        OVERR;  OVMSG
        EOFERR; INEMSG
        FPOVER; OFLMSG
        DFERR;  DFMSG
        -1;     DV0MSG  /BY ELIMINATION
\f/RTS ERROR MESSAGES

ARGMSG, TEXT    /BAD ARG/
UMSG,   TEXT    /USER ERROR/
FPOMSG, TEXT    /PARENS TOO DEEP/
FMTMSG, TEXT    /FORMAT ERROR/
UNTMSG, TEXT    /UNIT ERROR/
INMSG,  TEXT    /INPUT ERROR/
OVMSG,  TEXT    /OVERLAY /
        *.-1
IOMSG,  TEXT    %I/O ERROR%
DAMSG,  TEXT    /NO DEFINE FILE/
FPPMSG, TEXT    /FPP ERROR/
INEMSG, TEXT    /EOF ERROR/
DV0MSG, TEXT    /DIVIDE BY 0/
DFMSG,  TEXT    /D.F. TOO BIG/
IOVMSG, TEXT    /FILE  /
        *.-1
OFLMSG, TEXT    /OVERFLOW/
CTLBMS, TEXT    /^B/

USRERR, TAD     ERRFLG  /USER ERROR - OPTIONALLY NON-FATAL
        DCA     FATAL
UERR,   JMS I   ERR     /PRINT MESSAGE
        JMP I   [RETURN /IF NON-FATAL, CONTINUE PROCESSING
ERRFLG, 0               /SET TO NON-ZERO IF /E SWITCH SPECIFIED

TRPPRT, TRAP3           /CODE WHICH IS LOADED INTO PROGRAM PROLOGUES
        PRTNAM          /BY THE ERROR TRACEBACK ROUTINE
        PAGE
\fMAKCDF,        0               /ROUTINE TO MAKE A CDF FROM AC9-11
        RTL
        RAL
        AND     [70
        TAD     ERCDF   /STRAIGHTFORWARD ENOUGH, ISN'T IT?
        JMP I   MAKCDF

RD2WR,  0               /ROUTINE CALLED WHEN SWITCHING
        STA             /FROM READ TO WRITE. (CALLED ONLY ONCE!)
        TAD     RELBLK  /BUMP BLOCK # BACK FROM "NEXT BUFFER'S BLOCK #"
        DCA     RELBLK  /TO "THIS BUFFER'S BLOCK #".
        TAD     CHRCTR  /HOWEVER, IF WE ARE AT THE VERY END OF A
        IAC             /BUFFER, WRITE ROUTINE EXPECTS US TO
        SZA CLA         /BE AT THE BEGINNING OF THE NEXT BUFFER,
        JMS I   [MASSIO /SO RE-READ THIS BUFFER AND SET POINTERS
        JMP I   RD2WR

/RUN-TIME-SYSTEM ERROR ROUTINE

ERROR,  0
ERCDF,  CDF 0
        CLA
        TAD     (ERRLST-2
        DCA     XR
ERRLP,  ISZ     XR      /SEARCH ERROR LIST FOR CALLING ADDRESS
        TAD I   XR      /ERROR LIST CONTAINS
        CMA
        SZA             /CALLING ADDRESSES AND
        TAD     ERROR   /CORRESPONDING MESSAGES
        SZA CLA
        JMP     ERRLP
        TAD I   XR
        DCA I   (FMTADR
        DCA I   (FMTDF
        TAD     PTTY
        DCA     HAND    /QUICK FUDGE FOR TTY OUTPUT
        DCA     HCODEW  /TO SET CARRIAGE CONTROL
        AC4000
        DCA     RWFLAG
        JMS I   [EOLINE /TYPE CARRET AND SET EOLSW
        DCA     FMTBYT  /INITIALIZE MESSAGE PTR
ERPTLP, JMS I   [FMTOUT /OUTPUTS LF FIRST TIME
        JMS I   [FMTGCH /GET CHAR USING FORMAT ROUTINES
        ISZ     FMTBYT
        SZA
        JMP     ERPTLP  /LOOP UNTIL 0 CHAR
\f/PRINT ROUTINE NAME AND LINE NUMBER

PRTNAM, TAD     [40
ERRENB, JMP I   E7605   /*K* IN CASE INITIALIZATION OR /P GET ERRORS
/               PREVIOUS LINE REPLACED WITH:
/       JMS I   [FMTOUT /OUTPUT A BLANK(LF ON EXTRA LINES)
        JMS I   [FPGO   /START UP FPP
        GTNMPT          /GET POINTER TO NAME IN FAC
        TAD     ACH
        DCA I   (FMTDF  /SET UP FORMAT GET CHARACTER ROUTINE
        TAD     ACL     /TO GET CHARACTERS OF ROUTINE NAME
        DCA I   (FMTADR
        DCA     FMTBYT
        TAD     [-6
        DCA     ISN     /6 CHARACTER NAME
PRTNML, JMS I   [FMTGCH
        SNA
        TAD     [40     /AVOID PRINTING RANDOM @S
        JMS I   [FMTOUT /GET AND PRINT A CHARACTER
        ISZ     FMTBYT
        ISZ     ISN
        JMP     PRTNML
        TAD     [40
        JMS I   [FMTOUT /SEPARATE THE NAME BY A SPACE
        TAD     [-4     /FROM THE LINE NUMBER.
        DCA     ISN
PTLNLP, TAD     ISN+1
        CLL RTL
        RAL
        DCA     ISN+1   /PRINT LINE NUMBER IN OCTAL
        TAD     ISN+1   /BECAUSE THAT IS THE WAY IT APPEARS
        RAL             /IN THE FORTRAN PROGRAM LISTING
        AND     [7
        JMS I   (DIGIT
        ISZ     ISN
        JMP     PTLNLP

        JMS I   [EOLINE /OUTPUT FINAL CR
        TAD     FATAL
        SNA CLA         /FATAL ERROR?
        JMP     TRCBAK  /YES - GIVE FULL TRACEBACK
        DCA     FATAL   /"NON-FATAL" FLAG MUST BE SET EACH TIME
        JMP I   ERROR
TRCBAK, JMS I   [FPGO   /START UP FPP
        UP1LEV          /MOVE UP TO CALLING ROUTINE
                        /FPP CODE DOES A "TRAP3 PRTNAM"
ISN,    0;0
\f/FPP CODE FOR ERROR ROUTINE

GTNMPT, STARTD
        XTA     0       /LOAD LINE NUMBER FROM XR 0
        FSTA+LONG
        ISN             /STORE AWAY
        FLDA+BASE 10    /LOAD POINTER TO PROLOGUE
        FSUB+LONG
        THREE           /NAME IS 3 LOCATIONS BEFORE PROLOGUE
        STARTF          /FOR NON-FPP VERSION
THREE,  FEXIT;3         /*K* DEPENDS ON FACT THAT FEXIT=0

UP1LEV, STARTD
        FLDA+BASE 11    /GET THE UPWARD POINTER
        JNE
        NOTMN           /ZERO MEANS MAIN PROGRAM
        TRAP3
E7605,  7605            /GO AWAY IF MAIN PROGRAM
NOTMN,  FSTA+BASE 0
        LDX     1
        2               /WE WILL STORE A "TRAP3 PRTNAM"
        FLDA+LONG       /IN THE FIFTH LOCATION OF THE PROLOGUE,
        TRPPRT
        FSTA+IND 0+10   /WHERE THE FIRST 4 LOCS WERE A SETX AND SETB.
        FLDA+BASE 0     /GET THE PROLOGUE ADDRESS AGAIN
        JAC             /JUMP TO IT.

ACMDGT, FMUL+LONG
        TEN
        FSTA+LONG
        FTEMP
        FLDA+LONG
        DGT             /GET UNNORMALIZED DIGIT INTO AC
        FNORM           /NORMALIZE IT
FADTMP, FADD+LONG
        FTEMP
        FEXIT
LPBUFR, ZBLOCK  4
        LPBUF2
        PAGE
\fHPLACE,        /ZBLOCK 400     /HANDLER SWAP AREA

/VARIOUS INITIALIZATION STUFF OVERLAYING THE RTS HANDLER AREA

QLHDR,  0               /SHOULD BE A 2 FOR A LOADER IMAGE
QRTSWP, ZBLOCK  2       /INITIAL SWAP ARGS TO LOAD USER MAIN
QHGHAD, ZBLOCK  2       /HIGHEST ADDRESS USED
QVERNO, 0               /LOADER VERSION #
QDPFLG, 0               /"PROGRAM USES D.P." FLAG
QUSRLV, ZBLOCK  40      /USER OVERLAY INFO

/EAE OVERLAY TO FIX AND FLOAT

EFXFLT, RELOC   EAEFIX

FIXEAE, CMA
        DCA     FIXSH   /SHIFT COUNT BETWEEN 0 AND 12
        SZL
        JMP     FIX0    /NOT INTEGERIZABLE
        TAD     ACH
        ASR
FIXSH,  0
FIX0,   DCA     ACI
        JMP I   FFIX

FXFLTC= .-FIXEAE
        RELOC
\f/SUBR TO DETERMINE MACHINE SIZE - RETURNS NUMBER OF
/BANKS IN AC.
/MUST RUN IN FIELD 0.

CORE,   0
        TAD     C6203
        RDF
        DCA     CORRET
CORELP, CDF 0           /NEEDED FOR PDP-8L
        TAD I   C7777
        AND     COR70   /IF BITS 6-8 OF LOCATION 7777 ARE NOT ZERO,
        CLL RTR         /THEY SPECIFY THE LAST FIELD OF CORE
        RAR             /WHICH WE SHOULD USE.
        SZA
        JMP     CORRET  /SO RETURN THAT AMOUNT
        TAD TRYFLD      /GET FLD TO TST
        CLL RTL
        RAL
        AND     COR70   /MASK USEFUL BITS
        TAD     CORELP
        DCA     COR706  /SET UP CDF TO FLD
COR706, 0
        TAD I   CORLOC  /SAV CURRENT CONTENTS
        NOP             /HACK FOR PDP-8
        DCA     .-3
        TAD     .-2     /7000 IS A GOOD PATTERN
        DCA I   CORLOC
COR70,  70              /HACK FOR PDP-8.,NO-OP
        TAD I   CORLOC  /TRY TO READ BK 7000
CO7400, 7400            /HACK FOR PDP-8,.NO-OP
        TAD     CO7400  /GUARD AGAINST WRAP AROUND
        TAD     CORLOC+1        /TAD 1400
        SZA CLA
        JMP     .+5     /NON EXISTENT FLD EXIT
        TAD     COR706  /RESTORE CONTENS DESTROYED
        DCA I   CORLOC
        ISZ     TRYFLD /TRY NXT HIGHER FLD
        JMP     CORELP
        STA
        TAD     TRYFLD
CORRET, 0
        JMP I   CORE
CORLOC, CO7400          /ADR TO TST IN EACH FLD
        1400            /7000+7400+1400=0
TRYFLD, 1               /CURRENT FLD TO TST
C6203,  6203
C7777,  7777

DPTEST, STARTE          /EXECUTED BY FPP DURING INITIALIZATION
        FEXIT           /CHECK WHETHER DOUBLE PRECISION ENABLED
\f/TABLE OF MODIFICATIONS TO MAKE TO FRTS FOR BACKGROUND OPERATION
/UNDER RTS-8.  FORMAT OF TABLE IS: POINTER TO FIRST WORD OF BLOCK - 1
/ (0 TERMINATES) FOLLOWED BY LIST OF REPLACEMENT WORDS (0 TERMINATES).

BKRLST, YLPT-1          /LINE PRINTER OUTPUT ROUTINE
        RELOC   YLPT
        LLS
        CLA             /DON'T DO RING-BUFFERING - JUST "OUTPUT" CHAR.
        JMS     CTCBCK  /CHECK FOR ^C OR ^B
        JMP I   LPT
FJCTCT, JMS     CTCBCK  /COME HERE FROM INTERPRETED FPP JUMPS
        JMP I   FPNXT   /CHECK FOR ^C,^B AND RETURN TO INTERPRETER
        RELOC
        0

        YPTP-1          /PAPER-TAPE PUNCH ROUTINE
        CLA             /ALL PAPER-TAPE I/O ILLEGAL
        0
        YPTR-1          /PAPER TAPE READER ROUTINE
        CLA             /ALL PAPER-TAPE I/O ILLEGAL
        0

        YTTY-1          /TELETYPE INPUT/OUTPUT ROUTINE
        RELOC   YTTY
        SNA
        JMP     KBDRTS  /AC=0 MEANS INPUT
        TSF
        JMP     .-1     /HANG UNTIL OUTPUT BUFFER NOT FULL
        TLS
        CLA
        JMS     CTCBCK  /CHECK FOR ^C OR ^B TYPED
        JMP I   TTY
KBDRTS, KSF
        JMP     .-1     /HANG UNTIL CHAR RECEIVED
        JMS     CTCBCK  /CHECK FOR ^C OR ^B
        KRB
        AND     KB177   /STRIP PARITY
        TAD     KB177
        IAC             /NOW FORCE PARITY BIT ON (177+1=200)
        JMP I   TTY

CTCBCK, .               /*K* CAN'T BE 0!
        KRS             /PEEK AT NEXT CHAR IN BUFFER
        AND     KB177
        TAD     KBM2
        CLL RAR
        SNA CLA         /IS IT ^C OR ^B?
        KSF             /AND IS IT REALLY PENDING?
        JMP I   CTCBCK  /NO - JUST RETURN WITH AC=0
        JMP     BEEORC  /TERMINATE JOB - LINK HAS ^C/^B FLAG
KB177,  177
KBM2,   -2
        RELOC
        0
\f/CONTINUATION OF TABLE OF RTS-8 OVERLAYS TO FRTS

        YHIOF-1         /"GET OS/8 HANDLER" ROUTINE
        NOP             /ELIMINATE "IOF" INSTRUCTION
        0

        YRCOVR-1        /"RECOVER FROM OS/8 HANDLER" ROUTINE
        RELOC   YRCOVR
        JMP I   RECOVR  /SHORT-CIRCUIT PORTION OF ROUTINE WHICH DOES
        RELOC           /AN "ION"
        0

        YFJMP-1         /FPP INTERPRETER - SUCCESSFUL JUMP SECTION
        FJCTCT          /TEST FOR ^C OR ^B TYPED BEFORE
        0               /RETURNING TO THE INTERPRETER

        0               /** LIST TERMINATOR **
\f/ERROR MESSAGES FOR RUN-TIME LOADER - IN HANDLER BUFFER
/*K* CANNOT LOAD BELOW HPLACE+200 AS HPLACE-HPLACE+177 ARE DESTROYED BY HEADER!

        IFNZRO  .-HPLACE-200&4000       <__ERROR__>

NOLI,   TEXT    /NOT A LOADER IMAGE/
NONMSG, TEXT    /NO NUMERIC SWITCH/
FILMSG, TEXT    /FILE ERROR/
SYSMSG, TEXT    /SYSTEM DEVICE ERROR/
TOOMCH, TEXT    /MORE CORE REQUIRED/
TOMNYH, TEXT    /TOO MANY HANDLERS/
LIOEMS, TEXT    /CAN'T READ IT!/
NODPMS, TEXT    /CAUTION - NO DP/
XVERMS, TEXT    /FRTS V/
        *.-1
        XVERSN&70^7+XVERSN+4060         /VERSION NUMBER IN SIXBIT
        XPATCH&77^100+40                /PATCH LEVEL
        TEXT    /     /
        PAGE
\f/FPP INTERPRETER STARTUP ROUTINE

FPPINT= .               /FOR FPP OVERLAY
RETURN, JMP I   FPNXT   /RETURN DOES SOMETHING DIFFERENT IF FPP PRESENT

FPGO,   0
FPGCDF, CDF 0           /NECESSARY?
        CLA
        TAD     PC
        DCA     SAVPC   /ALLOW ONE LEVEL OF RECURSIVENESS
        TAD I   (PCCDF
        DCA     SPCCDF
        STA
        TAD I   FPGO
        DCA     PC
        ISZ     FPGO
        TAD     FPGCDF  /FPGO STARTS UP THE FPP FROM FIELD 0 ONLY
        DCA I   (PCCDF
        JMP I   FPNXT

EXIT,   TAD     SAVPC
        DCA     PC
        TAD     SPCCDF
        DCA I   (PCCDF  /RESTORE OLD PC
        JMP I   FPGO    /RETURN TO PDP-8 CODE
SAVPC,  0
SPCCDF, 0

FPXTA,  TAD     [27     /XR TO AC - NORMALIZE IF FLOATING MODE
        DCA     ACX
        JMS     DATCDF
        TAD I   ADR
CLFAC,  DCA     ACL
        TAD     ACL
        SPA CLA         /SIGN-EXTEND 12-BIT WORD
        STA             /INTO FAC FRACTION
        DCA     ACH
NRMFAC, DCA     AC1     /CLEAR OVERFLOW WORD
        TAD     DFLG
        SPA SNA CLA     /UNLESS WE ARE IN D.P.I. MODE,
        JMS I   NORMX   /NORMALIZE THE FAC
        JMP I   FPNXT
\f/MISCELLANEOUS JUMP CLASS INSTRUCTIONS

JSA,    TAD     ADR
        DCA     PUTM
        TAD     DATAF
        DCA     JSCDF   /SET UP LOC TO SAVE PC IN
        AC0002
        TAD     ADR
        DCA     ADR     /BUMP ADDRESS BY 2
        RTL
        RTL
        TAD     DATAF
        DCA     DATAF   /INCLUDING DATA FIELD
JSAR,   TAD I   (PCCDF  /JSA/JSR COMMON CODE
        CLL RTR
        RAR
        ISZ     PC      /BUMP PC BEFORE STORING
        SKP
        IAC             /INCLUDING FIELD BITS
        TAD     (JA-2620        /FORM "JA" INSTRUCTION
JSCDF,  HLT
        DCA I   PUTM
        ISZ     PUTM
        SKP
        JMS I   (DFBUMP /BUMP TARGET ADDRESS
        TAD     PC
        DCA I   PUTM
        JMP I   (DOJMP  /NOW JUMP TO DESTINATION

JSR,    CLA CLL IAC
        TAD     BASADR
        DCA     PUTM
        RTL
        RTL
        TAD I   (BASCDF /SET JSCDF&PUTM TO BASE PAGE LOC +1
        DCA     JSCDF
        JMP     JSAR

FPJAC,  TAD     ACL
        DCA     ADR
        TAD     ACH
        JMS I   MCDF
        DCA     DATAF
        JMP I   (DOJMP

SPCATX, TAD     ACL
        SKP
FPLDX,  JMS I   [FETPC
        JMS     DATCDF
        DCA I   ADR     /SET XR TO NEXT INST WD
        JMP I   FPNXT
\f/MORE INDEX REGISTER & AC-TO-MEMORY INSTRUCTIONS

ADDX,   JMS I   [FETPC
        JMS     DATCDF
        TAD I   ADR     /ADD NEXT INST WD TO XR
        JMP     FPLDX+1

ATX,    TAD     DFLG    /ATX WORKS DIFFERENTLY IN D.P.I. MODE
        SMA SZA CLA
        JMP     SPCATX
        JMS I   NORMX   /FAC MAY NOT BE NORMALIZED
        JMS I   [FFIX
        TAD     ACI
        JMP     FPLDX+1

OPMEM,  DCA     AD1     /GENERAL AC-TO-MEMORY INTERPRETER
        TAD     AD1
        DCA     AD2
        RDF
        CLL RTR
        RAR
        TAD     KLUDGM  /FORM FSTA X INSTRUCTION
        DCA     PUTM
        AC2000
        AND     INST    /TURN OP 5 TO OP 1,
        SZA CLA
        TAD     [3000   /     OP 7 TO OP 4.
        TAD     [3000
        TAD     PUTM    /STICK IN FIELD BITS
        DCA     OPM
        JMS I   [FPGO
        KLUDGM
        JMP I   FPNXT

KLUDGM, FSTA+LONG
        FTEMP           /SAVE AC
OPM,    0
AD1,    0               /PERFORM OP
PUTM,   0
AD2,    0               /STORE RESULT
        FLDA+LONG
        FTEMP           /RESTORE AC
        FEXIT

NORMX,  FFNOR           /*K* CHANGED TO EFFNOR IF EAE
        PAGE
\f/MAIN INTERPRETER LOOP

NEGFAC, JMS I   [FFNEG

ICYCLE, CLA
        JMS I   [FETPC  /GET INST
        DCA     INST
        TAD     INST
        CLL RTL
        RTL
        SMA             /SKIP IF BASEPAGE ADDRESSING
        JMP     LONGI
        AND     [7
        TAD     BASJMP
        DCA     OPJMP   /SAVE OPCODE CALL ADDRESS
        TAD     INST    /DATA FIELD IS STILL SET UP
        SZL             /SO IS LINK (WITH INSTRUCTION BIT 3)
        JMP     BPAGEI  /INDIRECT ADDRESSING
        CLL RAL
        TAD     INST    /MULTIPLY BASE OFFSET BY 3
        TAD     [200    /ELIMINATE ANY
        AND     (777    /HIGH ORDER BITS
IMFUDJ, CLL             /CLL IAC IF D.P. INTEGER MODE
        TAD     BASADR  /ADD IN BASE PAGE ORIGIN
BASCDF, HLT             /CDF TO BASE PAGE FIELD
        SZL
        JMS     DFBUMP  /BUMP DF IF ADDITION OVERFLOWED
OPJCLL, CLL
OPJMP,  HLT             /JMP I EXECUTIONROUTINE

BPAGEI, AND     [7
        DCA     ADR
        TAD     ADR
        CLL CML RAL
        TAD     ADR     /FORM 3*OFFSET+1
        TAD     BASADR
        DCA     ADR
        RTL
        RTL
        TAD     BASCDF  /FORM PROPER CDF
        DCA     ADDRLO
ADDRLO, HLT             /EXECUTE IT
        TAD I   ADR     /GET FIELD BITS OF REAL ADDRESS
        DCA     ADDRHI  /FROM 2D WORD OF BASE PAGE LOC
        ISZ     ADR
        SKP
        JMS     DFBUMP  /WATCH FOR FIELD OVERFLOW
        TAD I   ADR     /GET LOW-ORDER ADDRESS FROM 3D WORD
        JMP     INDEX   /NOW GO DO INDEXING (IF ANY)
\f/COME HERE IF BIT 4 OF INSTRUCTION IS OFF

LONGI,  AND     [7
        SNL             /TEST BIT 3 OF INSTRUCTION
        JMP I   (SPECAL /SPECIAL INSTRUCTION
        TAD     BASJMP
        DCA     OPJMP
        TAD     INST
        DCA     ADDRHI  /HIGH-ORDER ADDRESS BITS IN INST WD
        JMS I   [FETPC  /NEXT INST WORD CONTAINS LOW-ORDER ADDRESS
INDEX,  DCA     ADDRLO
        TAD     INST
        AND     [70
        SNA             /IS XR NUMBER 0?
        JMP     NOINDX  /YES - NO INDEXING
        JMS     DCDIDX  /GET XR VALUE (MAYBE INCREMENTED)
        AC7775
        TAD     DFLG    /GET -3 IF F, -2 IF D, -6 IF E MODE
        DCA     DCDIDX
        TAD     ADDRLO
XRADLP, CLL
        TAD I   T
        SZL
        ISZ     ADDRHI
        ISZ     DCDIDX  /ADD THE XR IN THE PROPER NUMBER OF TIMES
        JMP     XRADLP
        DCA     ADDRLO
NOINDX, TAD     ADDRHI
        JMS I   MCDF
        DCA     ADDRHI  /TURN HIGH-ORDER ADDRESS INTO A CDF
ADDRHI, HLT             /AND EXECUTE IT
        TAD     ADDRLO
        JMP     OPJCLL  /GO EXECUTE THE INSTRUCTION

DFBUMP, 0               /BUMP DATA FIELD
        DCA     DFTMP   /SAVE AC
        RDF
        TAD     (CDF 10
        DCA     .+1
        HLT
        TAD     DFTMP   /RESTORE AC
        JMP I   DFBUMP
DFTMP,  0
\fDCDIDX,        0
        CLL RTR
        RAR
        TAD     XRBASE  /ADD IN BASE ADDRESS OF XR ARRAY
XRCDF,  HLT             /CDF TO XR ARRAY FIELD
        SZL
        JMS     DFBUMP  /OR MAYBE NEXT FIELD
        DCA     T       /SAVE POINTER TO XR
        TAD     INST
        AND     DCD100
        SZA CLA         /INCREMENT BIT ON?
        ISZ I   T       /YES - BUMP XR
DCD100, 100             /** PROTECTION
        JMP I   DCDIDX

BASJMP, JMP I   JMPTB1  /JMP I JMPTB2 FOR D.P. MODE

JMPTB1, FFGET           / F MODE (FLOATING POINT)
        FFADD
        FFSUB
        FFDIV
        FFMPY
        OPMEM   /FADDM
        FFPUT
        OPMEM   /FMULM

        DDGET           / D MODE ( DOUBLE PRECISION INTEGER)
        DDADD
        DDSUB
        DDDIV
        DDMPY
        OPMEM   /DADDM
        DDPUT
        OPMEM   /DMULM

        EEGET           / E MODE ( 6 WD FLOATING POINT)
        FFADD
        FFSUB
        FFDIV
        FFMPY
        OPMEM
        EEPUT
        OPMEM
        PAGE
\f/MORE I CYCLE

SPECAL, SNA
        JMP     XRINST  /OPCODE 0 HAS MANY MANSIONS
        TAD     SPECOP
        DCA     SPCJMP  /GET OPCODE JUMP ADDRESS
        JMS I   [FETPC
        DCA     ADR
        TAD     INST    /ALL OF THESE ARE TWO-WORD INSTRUCTIONS
        JMS I   MCDF    /SO FORM THE ADDRESS NOW
        DCA     DATAF
        CDF 0
        TAD     INST
SPCJMP, HLT

XRINST, TAD     INST
        AND     (7770
        CDF 0
        SNA CLA         /IF SUB-OPCODE IS ZERO,
        JMP     OPERAT  /DECODE SUB-SUB-OPCODE
        TAD     INST
        AND     [7
        CLL
        TAD     XRBASE
        DCA     ADR     /COMPUTE INDEX REGISTER ADDRESS
        RTL
        RTL
        TAD I   (XRCDF
        DCA     DATAF
XJCOMN, TAD     INST
        CLL RTR
        RAR
        AND     [77     /GET OPCODE - HIGH ORDER 2 BITS ARE 0
OXCOMN, TAD     (JMP I SP2
        DCA     .+1     /EXECUTE APPROPRIATE JUMP
        HLT

OPERAT, TAD     INST
        CIA
        JMP     OXCOMN

SETX,   TAD     DATAF   /SET XR0 LOC
        DCA I   (XRCDF
        TAD     ADR
        DCA     XRBASE
        JMP I   FPNXT
\f/JUMP DECODER

JUMPS,  AND     (100    /INSTRUCTION IN AC
        CLL RTR         /20 IN AC IF NOT COND. JUMP
        SZA             /IF NOT COND. JUMP, DECODE FURTHER
        JMP     XJCOMN
        TAD     INST
        AND     [70
        CLL RTR
        RAR
        TAD     (CNDSKT
        DCA     T       /INDEX INTO CONDITIONAL SKIP TABLE
        TAD I   T
        DCA     CNDSKP
        TAD     ACH
        SZA
        JMP     CNDSKP
        TAD     ACL
        SZA CLA         /IF HIGH ORDER ZERO, AC MIGHT BE UNNORMALIZED.
        IAC             /USE LOW ORDER ON 0/NOT 0 BASIS
CNDSKP, HLT             /TEST AC
        JMP I   FPNXT   /FAILED - DON'T JUMP

DOJMP,  STA CLL
        TAD     ADR
        DCA     PC
        SNL
        TAD     (-10
        TAD     DATAF
        CDF 0
        DCA I   (PCCDF  /ADDRESS-1 TO PC
        JMP I   .+1
YFJMP,  ICYCLE          /** CHANGED IF RUNNING UNDER RTS-8

JXN,    AND     [70     /GET XR FIELD
        JMS I   (DCDIDX /GET XR VALUE WITH INCREMENTING
        TAD I   T
        SNA CLA         /ZERO?
        JMP I   FPNXT   /YES
        JMP     DOJMP   /JUMP ON INDEX NON-ZERO, RIGHT?

CNDSKT, SZA CLA         /JEQ
        SPA CLA         /JGE
        SMA SZA CLA     /JLE
        SKP CLA         /JA
        SNA CLA         /JNE
        SMA CLA         /JLT
        SPA SNA CLA     /JGT
        JMP     TSTALN  /JAL

TSTALN, CLA
        TAD     ACX
        TAD     (-27
        SPA SNA CLA
        JMP I   FPNXT
        JMP     DOJMP
\f/OPCODE TABLES

SPECOP, JMP I   SPECOP  /SPECIAL OPCODE TABLE
        JUMPS
        JXN
        TRAP3I
        TRAP4I
        TRAP5I
        TRAP6I
        TRAP7I

        FPJAC
        STRTD
        STRTF
        NRMFAC
        NEGFAC
        CLFAC
        FPAUSE
SP2,    EXIT
        ALN
        ATX
        FPXTA
        ICYCLE  /NOP
        STRTE
        ICYCLE  /UNDEF OP
        ICYCLE  /"
        FPLDX
        ADDX
        SETX
        SETB
        JSA
        JSR
        PAGE
\f/MISCELLANEOUS OPCODE ROUTINES

TRAP3I,
TRAP4I, AC0002
        TAD     DATAF
        DCA     .+1     /FORM CDF CIF N
        HLT             /EXECUTE IT
        TAD     INST
        SMA CLA         /TRAP4 JMS'S TO ITS TARGET ADDRESS,
        JMP I   ADR     /TRAP3 JMP'S TO IT
        JMS I   ADR
        JMP I   FPNXT

ALN,    TAD     ACX     /ALIGN SIMULATOR
        DCA     OPX     /SAVE EXPONENT IN CASE WE'RE IN D.I. MODE
        TAD     DFLG
        SMA SZA CLA
        DCA     ACX     /ZERO EXP IF D.I. MODE
        JMS     DATCDF  /SET TO XR FIELD
        TAD     INST
        AND     [7
        TAD     DFLG    /IF WE'RE IN FLOATING POINT MODE,
        SNA CLA         /AND DOING AN "ALN 0",
        TAD     [27     /ALIGN UNTIL EXPONENT = 23
        SNA
        TAD I   ADR     /OTHERWISE ALIGN UNTIL EXPONENT = XR VALUE
        CDF 0
        CIA
        TAD     ACX
        CMA             /FORM DIFFERENCE - 1
        SPA             /IF EXPONENT IS LARGER THEN DESIRED EXPONENT,
        JMP     ALNSHL  /SHIFT LEFT
        JMS I   [ACSR   /OTHERWISE SHIFT RIGHT
ALNXIT, TAD     DFLG
        SPA SNA CLA     /IF DOUBLE INTEGER MODE,
        JMP I   FPNXT
        TAD     OPX     /ALIGNMENT LEAVES THE EXPONENT UNCHANGED
        DCA     ACX
        JMP I   FPNXT
ALNSHL, DCA     T       /STORE SHIFT COUNT
        SKP             /SHIFT LEFT ONE LESS THAN COUNT
        JMS I   [AL1BMP
        ISZ     T
        JMP     .-2
        JMP     ALNXIT  /GO TO COMMON CODE
\f/ARG FETCH SUBROUTINES AND MODE CHANGE OPERATORS

DARGET, 0
        DCA     ADR
        TAD     DARGET
        DCA     ARGET
        DCA     ACX
        JMP     ARGET2  /FAKE OUT FLOATING POINT ROUTINE

ARGET,  0               /SUBROUTINE TO FETCH ARG FOR ADD, SUBT, ETC.
        DCA     ADR     /STORE ADDRESS OF OPERAND
        TAD I   ADR     /PICK UP EXPONENT
        ISZ     ADR     /MOVE POINTER TO HI MANTISSA WD
        SKP
        JMS I   (DFBUMP
ARGET2, DCA     OPX
        TAD I   ADR     /PICK IT UP
        DCA     OPH     /STORE
        ISZ     ADR     /MOVE PTR. TO LO MANTISSA WD.
        SKP
        JMS I   (DFBUMP /WATCH THOSE FIELD TRANSITIONS!
        TAD I   ADR     /PICK IT UP
        DCA     OPL     /STORE IT
        CDF 0
        JMP I   ARGET   /RETURN

STRTE,  TAD     DFLG    /START EXTENDED PRECISION MODE
        SPA CLA
        JMP     .+4     /CLEAR EXTENDED FAC
        DCA     EAC1    /IF NOT ALREADY IN E MODE
        DCA     EAC2
        DCA     EAC3
        AC7775
        DCA     DFLG
        JMP     DFECMN

STRTD,  CLA IAC         /START DOUBLE PRECISION INTEGER MODE
STRTF,  DCA     DFLG    /START FLOATING POINT MODE
        TAD     DFLG
DFECMN, TAD     (CLL
        DCA I   (IMFUDJ /SET D.P.I FUDGE TO "CLL" OR "CLL IAC"
        TAD     DFLG
        SPA
        CMA             /CHANGE -3 FOR E MODE TO +2
        CLL RTL
        RAL
        TAD     (JMPTB1&177+5600
        DCA I   (BASJMP
        JMP I   FPNXT
\f/DOUBLE PRECISION INTEGER OPERATORS

DDSUB,  JMS     DARGET
        JMS I   (OPNEG
        SKP
DDADD,  JMS     DARGET
        DCA     AC1     /CLEAR OVERFLOW JUSTINCASE
        JMS I   [OADD
        JMP I   FPNXT

FFGET,  DCA     ADR     /GET A FLOATING POINT NUMBER
        TAD I   ADR
        DCA     ACX     /SAVE EXPONENT
        ISZ     ADR
        JMP     .+3     /NO FIELD OVERFLOW
        JMS I   (DFBUMP /BUMP DATA FIELD
DDGET,  DCA     ADR     /SUAVE - ENTRY POINT FOR D.P. INTEGER GET
        TAD I   ADR
        DCA     ACH
        ISZ     ADR
        SKP
        JMS I   (DFBUMP
        TAD I   ADR
        DCA     ACL
        JMP I   FPNXT

FFPUT,  DCA     ADR     /STORE A FLOATING POINT NUMBER
        TAD     ACX     /GET FAC AND STORE IT
        DCA I   ADR     /AT SPECIFIED ADDRESS
        ISZ     ADR
        JMP     .+3
        JMS I   (DFBUMP
DDPUT,  DCA     ADR     /ENTRY FOR D.P. INTEGER PUT
        TAD     ACH
        DCA I   ADR
        ISZ     ADR
        SKP
        JMS I   (DFBUMP
        TAD     ACL
        DCA I   ADR
        JMP I   FPNXT
        PAGE
\fFPPKG= .               /FOR EAE OVERLAY

/23-BIT FLOATING PT INTERPRETER
/W.J. CLOGHER, MODIFIED BY R.LARY FOR FORTRAN

LPBUF2, ZBLOCK  16
        LPBUF3

AL1BMP, 0               /*K* UTILITY SUBROUTINE - USED BY INTERPRETER
        STA
        TAD     ACX
        DCA     ACX
        JMS I   [AL1
        JMP I   AL1BMP

/FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
DDMPY,  JMS I   (DARGET
        SKP
FFMPY,  JMS I   (ARGET  /GET OPERAND
        JMS     MDSET   /SET UP FOR MPY-OPX IN AC ON RETN.
        TAD     ACX     /DO EXPONENT ADDITION
        DCA     ACX     /STORE FINAL EXPONENT
        DCA     MDSET   /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
        DCA     ACL     /LOW ORDER
        TAD     MDSET   /HIGH ORDER
        DCA     ACH
        TAD     ACH     /DO WE NEED TO NORMALIZE?
        RAL
        SMA     CLA
        JMS     AL1BMP  /YES-DO IT FAST
        TAD     AC1
        SPA CLA         /CHECK OVERFLOW WORD
        ISZ     ACL     /HIGH BIT ON - ROUND RESULT
        JMP     MDONE
        ISZ     ACH     /LOW ORDER OVERFLOWED - INCREMENT HIGH ORDER
        TAD     ACH
        SPA             /CHECK FOR OVERFLOW TO 4000 0000
        JMP I   (SHR1   /WE HANDLE A SIMILIAR CASE IN FLOATING DIVIDE
        CLA
\fMDONE, DCA     AC1     /ZERO OVERFLOW WD(DO I NEED THIS???)
        ISZ     MSIGN   /SHOULD RESULT BE NEGATIVE?
        SKP             /NO
        JMS I   [FFNEG  /YES-NEGATE IT
        TAD     ACH
        SNA CLA         /A ZERO AC MEANS A ZERO EXPONENT
        DCA     ACX
        TAD     DFLG
        SMA SZA CLA     /D.P. INTEGER MODE?
        TAD     ACX     /WITH ACX LESS THAN 0?
        SNA
        JMP I   FPNXT   /NO - RETURN
        CMA
        JMS I   [ACSR   /UN-NORMALIZE RESULT
        JMP I   FPNXT   /RETURN
\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
        CLA CLL CMA RAL /SET SIGN CHECK TO -2
        DCA     MSIGN
        TAD     OPH     /IS OPERAND NEGATIVE?
        SMA     CLA
        JMP     .+3     /NO
        JMS I   (OPNEG  /YES-NEGATE IT
        ISZ     MSIGN   /BUMP SIGN CHECK
        TAD     OPL     /AND SHIFT OPERAND LEFT ONE BIT
        CLL     RAL
        DCA     OPL
        TAD     OPH
        RAL
        DCA     OPH
        DCA     AC1     /CLR. OVERFLOW WORF OF FAC
        TAD     ACH     /IS FAC NEGATIVE
        SMA     CLA
        JMP     LEV     /NO-GO ON
        JMS I   [FFNEG  /YES-NEGATE IT
        ISZ     MSIGN   /BUMP SIGN CHECK
        NOP             /MAY SKIP
LEV,    TAD     OPX     /EXIT WITH OPERAND EXPONENT IN AC
        JMP I   MDSET
MSIGN,  0
\f/24 BIT BY 12 BIT MULTIPLY.  MULTIPLIER IS IN OPL
/MULTIPLICAND IS IN ACH AND ACL
/RESULT LEFT IN MDSET,AC2, AND AC1

MP24,   0
        TAD     (-14    /SET UP 12 BIT COUNTER
        DCA     OPX
        TAD     OPL     /IS MULTIPLIER=0?
        SZA
        JMP     MPLP1   /NO-GO ON
        DCA     AC1     /YES-INSURE RESULT=0
        JMP I   MP24    /RETURN
MPLP,   TAD     OPL     /SHIFT A BIT OUT OF LOW ORDER
MPLP1,  RAR             /OF MULTIPLIER AND INTO LINK
        DCA     OPL
        SNL             /WAS IT A 1?
        JMP     MPLP2   /NO - 0 - JUST SHIFT PARTIAL PRODUCT
        TAD     AC2     /YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
        TAD     ACL     /LOW ORDER
        DCA     AC2
        CML RAL         /*K* NOTE THE "SNL" 5 WORDS BACK!
        TAD     ACH     /HI ORDER
MPLP2,  TAD     MDSET
        RAR             /NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
        DCA     MDSET
        TAD     AC2
        RAR
        DCA     AC2
        TAD     AC1
        RAR             /OVERFLOW TO AC1
        DCA     AC1
        ISZ     OPX     /DONE ALL 12 MULTIPLIER BITS?
        JMP     MPLP    /NO-GO ON
        JMP I   MP24    /YES-RETURN
        PAGE
\f/DIVIDE-BY-ZERO ROUTINE - MUST BE AT BEGINNING OF PAGE

DBAD,   ISZ     FATAL   /DIVIDE BY 0 NON-FATAL
        JMS I   ERR     /GIVE ERROR MSG
        TAD     DBAD
        DCA     ACX     /RETURN A VERY LARGE POSITIVE NUMBER
        AC2000
        JMP     FD

/FLOATING DIVIDE - USES DIVIDE-AND-CORRECT METHOD

DDDIV,  JMS I   (DARGET
        SKP
FFDIV,  JMS I   (ARGET  /GET OPERAND
        JMS I   (MDSET  /GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
        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     OPL
        SNA CLA
        JMP     DVL2    /AVOID MULTIPLYING BY 0
        TAD     (-15    /SET COUNTER FOR 12 BIT MULTIPLY
        DCA     DV24    /TO MULTIPLY QUOT. OF DIV. BY 
        JMP     DVLP1   /LOW ORDER OF OPERAND (OPL)

/DIVIDE ROUTINE - (ACH,ACL)/OPH = ACL REMAINDER REM  (AC2=0)

DV24,   0
        TAD     ACH     /CHECK THAT DIVISOR IS .GT. DIVIDEND
        TAD     OPH     /DIVISOR IN OPH (NEGATIVE)
        SZL     CLA     /IS IT?
        JMP     DBAD    /NO-DIVIDE OVERFLOW
        TAD     (-15    /YES-SET UP 12 BIT LOOP
        DCA     AC2
        JMP     DV1     /GO BEGIN DIVIDE
DV2,    TAD     ACH     /CONTINUE SHIFT OF FAC LEFT
        RAL
        DCA     ACH     /RESTORE HI ORDER
        TAD     ACH     /NOW SUBTRACT DIVISOR FROM HI ORDER
        TAD     OPH     /DIVIDEND
        SZL             /GOOD SUBTRACT?
        DCA     ACH     /YES-RESTORE HI DIVIDEND
        CLA             /NO-DON'T RESTORE--OPH.GT.ACH
DV1,    TAD     ACL     /SHIFT FAC LEFT 1 BIT-ALSO SHIFT
        RAL             /1 BIT OF QUOT. INTO LOW ORD OF ACL
        DCA     ACL
        ISZ     AC2     /DONE 12 BITS OF QUOT?
        JMP     DV2     /NO-GO ON
        JMP I   DV24    /YES-RETN W/AC2=0
\f/DIVIDE ROUTINE CONTINUED

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     DV24    /DONE ALL BITS?
        JMP     MP12L   /NO-LOOP BACK
        CLL CIA         /YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
        DCA     ACL     /NEGATE AND STORE
        CML     RAL     /PROPAGATE CARRY
        TAD     AC2     /NEGATE HI ORDER PRODUCT
        STL CIA 
        TAD     ACH     /COMPARE WITH REMAINDER OF FIRST DIV.
        SZL             /WELL?
        JMP     DVOPS   /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
        DCA     ACH     /OK - DO (REM - (Q*OPL)) / OPH
DVL3,   JMS     DV24    /DIVIDE BY OPH (HI ORDER OPERAND)
DVL1,   TAD     AC1     /GET QUOT. OF FIRST DIV.
        SMA             /IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT
        JMP     FD      /NO-ITS NORMALIZED-DONE
SHR1,   CLL
        ISZ     ACL     /ROUND AND SHIFT RIGHT ONE
        SKP
        IAC             /DOUBLE PRECISION INCREMENT
        RAR
        DCA     ACH     /STORE IN FAC
        TAD     ACL     /SHIFT LOW ORDER RIGHT
        RAR
        DCA     ACL     /STORE BACK
        ISZ     ACX     /BUMP EXPONENT
        NOP
        TAD     ACH
        JMP     DVL1+1  /IF FRACT WAS 77777777 WE MUST SHIFT AGAIN
FD,     DCA     ACH     /STORE HIGH ORDER RESULT
        JMP I   (MDONE  /GO LEAVE DIVIDE

DVL2,   DCA     ACL     /COME HERE IF LOW-ORDER QUO=0
        JMP     DVL3    /SAVE SOME TIME
\f/ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
/REMAINDER OF THE FIRST DIVIDE IS LESS THAN QUOT*OPL

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
        SNA             /IS IT ZERO?
DVOP2,  DCA     ACL     /YES-MAKE WHOLE THING ZERO
        DCA     ACH
        JMS     DV24    /DIVIDE EXTENDED REM. BY HI DIVISOR
        TAD     ACL     /NEGATE THE RESULT
        CLL CMA IAC
        DCA     ACL
        SNL             /IF QUOT. IS NON-ZERO, SUBTRACT
        CMA             /ONE FROM HIGH ORDER QUOT.
        JMP     DVL1    /GO TO IT

LPBUF3, ZBLOCK  12
        LPBUF4
        PAGE
\f/"OPNEG" MUST BE AT 0 ON PAGE

OPNEG,  0               /ROUTINE TO NEGATE OPERAND
        TAD     OPL     /GET LOW ORDER
        CLL CIA         /NEGATE AND STORE BACK
        DCA     OPL
        CML     RAL     /PROPAGATE CARRY
        TAD     OPH     /GET HI ORDER
        CLL CIA         /NEGATE AND STORE BACK
        DCA     OPH
        JMP I   OPNEG
/
/FLOATING SUBTRACT AND ADD
/
FFSUB,  JMS I   (ARGET  /PICK UO THE OP.
        JMS     OPNEG   /NEGATE OPERAND
        SKP
FFADD,  JMS I   (ARGET  /PICK UP OPERAND
        TAD     OPH     /IS OPERAND = 0
        SNA     CLA
        JMP I   FPNXT   /YES-DONE
        TAD     ACH     /NO-IS FAC=0?
        SNA     CLA
        JMP     CLROFL  /CLEAR OUT THE OVERFLOW BITS
        TAD     ACX     /NO-DO EXPONENT CALCULATION
        CLL CIA
        TAD     OPX
        SMA     SZA     /WHICH EXP. GREATER?
        JMP     FACR    /OPERANDS-SHIFT FAC
        CIA             /FAC'S-SHIFT OPERAND=DIFFRNCE+1
        TAD     (-30
        SMA             /TEST FOR INSIGNIFICANCE
        JMP     OPINSG  /YES - ANSWER IS FAC
        TAD     (30
        JMS     OPSR
        JMS I   [ACSR   /SHIFT FAC ONE PLACE RIGHT
DOADD,  TAD     OPX     /SET EXPONENT OF RESULT
        DCA     ACX
        JMS I   [OADD   /DO THE ADDITION
        JMS     FFNOR   /NORMALIZE RESULT
        JMP I   FPNXT   /RETURN
FACR,   TAD     (-30
        SMA             /TEST FOR INSIGNIFICANCE
        JMP     ACINSG  /YES - ANSWER IS OPR
        TAD     (30
        JMS  I  [ACSR   /SHIFT FAC = DIFF.+1
        JMS     OPSR    /SHIFT OPR. 1 PLACE
        JMP     DOADD   /DO ADDITION

OPINSG, CLA
        JMP I   FPNXT
\f/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
        CLL             /TO LINK
        SPA
        CML             /WITH HI MANTISSA IN AC
        RAR             /SHIFT IT RIGHT, PROPAGATING SIGN
        DCA     OPH     /STORE BACK
        TAD     OPL
        RAR
        DCA     OPL     /STORE LO ORDER BACK
        ISZ     OPX     /INCREMENT EXPONENT
        NOP     
        ISZ     AC0     /DONE ALL SHIFTS?
        JMP     LOP2    /NO-LOOP
        RAR             /SAVE 1 BIT OF OVERFLOW
        DCA     AC2     /IN AC2
        JMP I   OPSR    /YES-RETN.

FFNOR,  0               /ROUTINE TO NORMALIZE THE FAC
        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, CLA CLL CML RTR /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)
        JMS I   [AL1BMP /SHIFT AC LEFT AND BUMP ACX DOWN
        JMP     NORMLP  /GO BACK AND SEE IF NORMALIZED
ZEXP,   DCA     ACX
FFNORR, DCA     AC1     /DONE W/NORMALIZE - CLEAR AC1
        JMP I   FFNOR   /RETURN

ACINSG, CLA             /COME HERE IF AC IS INSIGNIFICANT ON ADDITION
        DCA     ACH
        DCA     ACL
        JMP     DOADD-1 /FAKE AN ADD WITH OPR=0

LPBUF4, ZBLOCK  40
        LPBUFE
CLROFL, DCA     AC1     /CLEAR  THE FLOATING AC OVERFLOW WORD
        DCA     AC2     /CLEAR THE OPERAND OVERFLOW WORD
        JMP     DOADD   /FAC=0;   DO THE ADD
        PAGE
\f/PAGE 7400 UNUSED RIGHT NOW

LPBUFE, ZBLOCK  177
        LPBUFR
        FIELD 1
\f