--- /dev/null
+/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
projects / pdp8.git / blobdiff