Directory of image this file is from
This file as a plain text file
/ MSI - 1.3.2.5 PSEUDO-COMPUTER
/ PDP-8 INTERPRETER THERETO PERTAINING
/ BEGUN THIS ELEVENTH DAY OF AUGUST, IN THE YEAR
/ NINETEEN HUNDRED AND SEVENTY THREE OF THE COMMON ERA (ERROR)
/ VERSION 1.0 ESCAPED SOME TIME IN MARCH OF 1974
/ VERSION 1.1 INITIALLY RELEASED 8/9/74
/ VERSION 1.2 INITIALLY RELEASED 8/22/74
/ SPEED-UP MODS TO "INSFTC" AND "LODXI"
/ "SYSTEM" TESTS FUNCTION ARGUEMENT FOR VALIDITY (ERROR 30)
/ NEW "SYSTEM" - FUNCTIONS "GETSB" (STARTING BLOCK)
/ AND "BLOCKI" (BLOCK-INPUT)
/ "BLOCKO" (BLOCK-OUTPUT)
/ AN INITIAL "CAF"
/ A FUNCTION TO DETERMINE IF LOAD OR CHAIN
/ FIX TO "STO" INTO A LONG (>16) RESULT
/ VERSION 1.3 FIRST RELEASE 2/20/75
/ MASSIVE SPEED-UP REWRITE OF LOADER-CODE
/ OPEN, CLOSE, AND FINI SHARE CORE WITH
/ DIVXX, DIVAA, AND STOE
/ LOADER SHARES SPACE WITH THE NON-RESIDENT DRIVER AND
/ PART OF THE DEBUG CODE
/ FIX TO "LOD" FOR LONG (>16) OPERANDS
/ FIX TO "PUSHJ" FOR "COMPUTED"- CALLS
/ FIX ASCII READ TO GUARENTEE LAST BYTE IS BLANK OR VALID DATA
/ FIX "CHAIN" TO LEAVE OPEN FILES ALONE
/ FIX "READ" OF BLOCK ONE AFTER OPEN-19
/ FIX BINARY INPUT TO AVOID USE OF "BINFLG"
/ TEST FOR USE OF ZERO SUBSCRIPTS (ERROR 34)
/ TEST IN OPEN-"SYS" FOR REFERENCE TO NON-EXISTANT DEVICE (ERROR 33)
/ RESET PRINTER FLAG AFTER INITIAL "CAF"
/ FIX DIVAA (WHICH NEVER WORKED!) (AGAIN)
/ FIX "OPEN-ONLY" (2)
/ AVOID OS/8 OPEN ON NON-FILE DEVICES
/ "FIX "POPJ" UNDERFLOW TEST (ONE POP TOO MANY BEFORE)
/ VERSION 1.3.1 RELEASED 3/19/75
/ FIX: "BINOUT", "FSWORD"
/ FORCE OLD-STYLE "CHAIN" IN ABSENSE OF "/C"
/ SYSTEM (7,?) FORCES NEW-"CHAIN"
/ 1.3.1.1 4/9/75
/ FIX BUG IN SUBSCRIPTS TO BINARY VARIABLES
/ 1.3.1.2 5/8/75
/ FIX STORE INTO LONG DECIMAL (>16)
/ "CHAIN" FORCE CLEARS ON-ERROR ADDRESS
EJECT
/ 1.3.1.3 5/25/75
/ XMITAX AND LODAD MUST ATTACK ALL DECIMAL-DIGITS
/ 1.3.1.4 7/29/75
/ ERRORS DURING I/O MUST PUT BUFFER-PARAMETERS BACK WHERE THEY BELONG
/ 1.3.1.5 9/19/75
/ I/O ERRORS NOT POPPING STACK CORRECTLY
/ READ/WRITE MUST CLEAR -EOI- BIT
/ 1.3.1.6 12/01/75
/ FIX TRAP TO CATCH REFERENCES TO NON-EXISTANT E. D. N. ' S
/ PUT IN "CLEAR" OPCODE
/ 1.3.1.7 2/13/76
/ FIX "LODC" FOR CASE OF ALL BLANK SOURCE
/ 1.3.2.0 (8/17/76)
/ FIX READ-UP BUF IN "DMPBUF" (NOT READING LAST SECTOR)
/ 1.3.2.1 (8/20/76)
/ ADD "INPUT" AND "OUTPUT"
/ 1.3.2.2 (9/20/76)
/ RESET "CURBPT" FOR "INPUT" OR "OUTPUT"
/ 1.3.2.3 (9/22/76)
/ NEW SUBROUTINE ("TURNIO") TO RESET I/O DIRECTION
/ CALLED BY "DISPLAY", "ACCEPT", "INPUT" AND "OUTPUT"
/ 1.3.2.4 (10/27/76)
/ FIX "STFAD" TO DO REAL -CDF- (FOR RTS/8 OS/8 BACKGROUND)
/ 1.3.2.5 (8/5/77)
/ FIX "DISPLAY" TO DO CURSOR POSITIONING
/ FIX SINGLE-CHARACTER DISPLAY TO HANDLE 1 (CLEAR TO END-OF-SCREEN)
/ AND 2 (CLEAR TO END-OF-LINE)
EJECT
/ OVERLAY DEFINITIONS:
/ CORE AREA 1
/ SCRBLK+0 - DEBUG CODE
/ SCRBLK+1 - LOADER-CODE
/ NON-RESIDENT I/O DRIVERS
/ CORE AREA 2
/ SCRBLK+2 - "STOE" "DIVXX" "DIVAA" "LFTSIG"
/ SCRBLK+3 - "OPEN" "FINI" "CLOSE"
/ SCRBLK+4 AND 5 - STORE AREA USED FOR LOADER BUFFER DURING "CHAIN"
/ INDEX DEFINITIONS:
XR1=10
XR2=11
XR4=12
XR3=13 / 709'S SHALL RISE AGAIN
EJECT
/ DEFINE SOME OPCODES
IFNDEF DSKF <DSKF=6061> / VT8E SKIP ON KEYBOARD FLAG
IFNDEF DKRB <DKRB=6066> / VT8E READ KEYBOARD
IFNDEF LLS <LLS=6666> / LOAD PRINTER CHARACTER BUFFER
IFNDEF EAE <EAE=0>
IFNZRO EAE <
IFNDEF MUY <MUY=7405>
IFNDEF SWAB <SWAB=7431>
IFNDEF DLD <DLD=7643>
IFNDEF DPIC <DPIC=7573>
IFNDEF DST <DST=7445>
>
BLKINC=1 / SECTOR LENGTH OF BUFFER
SSLEN=200 / SUBROUTINE-STACK LENGTH
XRGLEN=21 / LENGTH OF AN X-REGISTER
XBUFWD=16 / BUFFER-HEADER LENGTH
BPLEN=400^BLKINC / TRUE LENGTH OF AN I/O BUFFER
DBGSLN=46 / LENGTH OF DEBUG SAVE-AREA
NUMBFS=10 / MAXIMUM NUMBER OF BUFFERS
LPTTOF=DRIVER+377 / "LPT" TOP-OF-FORM FLAG
SYSDRV=7607 / ADDRESS OF "SYS" DRIVER
LDFNMX=7+1 / (MAXIMUM LOADER FUNCTION-WORD)+1
/ FIELD ONE AND TWO DEFINITIONS
SCRBLK=40 / USE SELDOM USED SYSTEM-SCRATCH BLOCKS
/ BLOCKS 40-47 ARE USED ONLY BY -LOADER- AND -ABSLDR-
/ (PER T. R. S. 7/23/74)
BSEFLD=0 / BASE FIELD FOR INTERPRETER
IOFLD=10 / FIELD FOR I/O BUFFERS AND OTHER JUNQUE
USR=7700 / FIELD-ONE ENTRY TO OS/8 USER-SERVICE ROUTINE
OMU2OU=7600-21 / START OF MU2OU
FILBLK=OMU2OU-1 / CAN OVERLAY INITIALIZER BUT NOT "MU2OU"
SUBSTK=-XBUFWD^NUMBFS+FILBLK-200 / STACK FOR CALLS AND RETURNS
DBGSAV=SUBSTK-DBGSLN / SAVE-AREA FOR "DEBUG"
FSTBUF=DBGSAV-BPLEN / FIRST AVAILABLE BUFFER
LODBUF=DBGSAV-1000 / LOADER BUFFER
/ NOTE: THE BUFFER HEADER IS SEPERATE FROM THE BUFFER
/ COMMON STORAGE:
FIELD 0
*17
1325 / VERSION NUMBER
JMP I .+1 / NICE WAY BACK TO "DEBUG" ON BLOW-UP
DBG
AREG, ZBLOCK 10 / A-"REGISTERS"
BREG, ZBLOCK 10 / B-"REGISTERS"
/ "AREG" AND "BREG" MUST STAY TOGETHER AND IN THAT ORDER
BADSUB, ZERSUB / X-FER ADDRESS FOR ZERO-SUBSCRIPTS
BINFLG, 0 / =1 IF BINARY INDEXING, OR WANT TO TEST RECORD-LENGTH
CNT, 0 / ALL-PURPOSE COUNTER
CONDCD, 2 / CONDITION CODE, SET BY COMPARES
/ (INITIALIZED TO "EQUAL")
DN1, 0 / STORAGE FOR FIRST (OR ONLY) DESCRIPTOR-NUMBER
DN2, 0 / STORAGE FOR SECOND DESCRIPTOR-NUMBER
EFFAD1, ZBLOCK 2 / FIRST (OR ONLY) MEMORY-ADDRESS
EFFAD2, ZBLOCK 2 / SECOND MEMORY ADDRESS
EFFREG, 0 / POINTER TO REGISTER USED AS INDEX
FNTPNT, 0 / POINTER TO ACTIVE FILE ENTRY
IOERR, 0 / <> 0 IF ERROR-CODE MUST CALL "WRAPIO"
MA, ZBLOCK 2 / MEMORY-ADDRESS "REGISTER"
MSTPOP, 0 / IF NON-ZERO, MUST POP STACK ON ERRORS
NOSTOR, 0 / STORAGE-SUPPRESSION FLAG FOR INPUT
OPLEN1, 0 / LENGTH OF FIRST (OR ONLY) OPERAND
OPLEN2, 0 / LENGTH OF SECOND OPERAND
PCTR, 0 / PROGRAM-COUNTER (WORD-ADDRESS)
R1, 0 / UNTRAMMELED FIRST REGISTER-DESIGNATOR
R2, 0 / VIRGIN SECOND REGISTER DESIGNATOR
RBASE1, 0
RBASE2, 0
RPNT1, 0
RPNT2, 0 / REGISTER POINTERS
RTSUB, ZERSUB / RESET WORD FOR "BADSUB"
SGN1, 0
SGN2, 0
STEP, 0 / <> 0 IF IN STEP-MODE
STKPNT, SUBSTK / SUBROUTINE-STACK POINTER
TEMP1, 0
TEMP2, 0
TEMP3, 0
WPNT, 0
XRLEN, -XRGLEN+1 / LENGTH DOES NOT INC UDE SIGN-BYTE
EJECT
/ I/O TEMPORARIES
CURCTL, 0
/ 1/I-O,1/BIN-BCD,1/CLOSE-NOCLOSE
/ 1/EOI,1/NOFIL(OR DO-TRIM),1/FILE-ORIENTED DEVICE
/ 1/TTY,1/LPT,4/OS-8 EST-ORDINAL
/ IF BOTH "TTY" AND "LPT" ARE ONE, DEVICE IS "VT8E"
CURCHR, 0 / TRANSFER-ADDRESS FOR BYTE-PROCESSING ROUTINE
CURBLK, 0 / CURRENT BLOCK IN FILE
CURBPT, 0 / CURRENT OFFSET INTO BUFFER
BUFINC, 0 / VALUE FOR INCREMENT OF BLOCK POINTER
BUFLEN, 0 / LENGTH OF DATA-PART OF BUFFER
BUFLOC, 0 / FWA(BUFFER)
MAXBLK, 0 / LARGEST PERMISSABLE VALUE FOR "CURBLK"
MAXDAD, 0 / LARGEST USED VALUE FOR "CURBLK"
FSTBLK, 0 / STARTING DISK-ADDRESS OF FILE
FNAME, ZBLOCK 3 / OS/8 FILE-NAME
0 / OS/8 FILE-EXTENSION
*1
HLT / IN CASE OF STRANGE INTERRUPT
BKP, ZBLOCK 2
*200
STA / ENTRY FOR "RUN"
/ENTRY FOR "CHAIN"
CDF CIF IOFLD / INITIALIZER IS IN ANOTHER FIELD
JMP I (STRTUP / GO RUN LOADER AND OTHER INITIALIZATION
/ "RNI" - READY NEXT INSTRUCTION
TRACE,
NTRACE,
RNI, KSF / IS A KEY STUCK?
JMP BKINS / NO
KRS
AND (177 / CLEAR PARITY-BIT
TAD (-3
SNA CLA / IS IT A "CTL-C" ?
STOPR, JMP I (7600 / YES, GO QUIT
BKINS, JMP BKPRET / CHANGED TO "TAD STEP" IF WANT BREAKPOINT TESTING
SZA CLA
JMP I (DBG / THIS IS "STEP-MODE"
TAD PCTR
TAD BKP+1
SZA CLA
JMP BKPRET / P-COUNTER NOT SAME AS BREAKPOINT
TAD BKP
TAD INSFTC+1
SNA CLA
JMP I (DBG / GOT TO BREAKPOINT
EJECT
BKPRET,
IFNZRO EAE <SWAB> / INSURE MODE-B E. A. E.
JMS INSFTC / FETCH INSTRUCTION WORD
IFZERO EAE<
MQA
BSW
AND [77 / ISOLATE OPCODE BYTE
TAD (OPCDTB / CONVERT TO TABLE-POINTER
DCA OPCODE
MQA
AND [7
DCA R2 / ISOLATE SECOND REGISTER-DESIGNATOR
MQA
RTR
RAR
AND [7
>
IFNZRO EAE <
CLA SHL
6
TAD (OPCDTB
DCA OPCODE
SHL
3
DCA R2
SHL
3
>
DCA R1 / ISOLATE FIRST REGISTER-DESIGNATOR
CDF IOFLD
TAD I OPCODE
CDF BSEFLD
DCA OPPNT / FETCH INSTRUCTION PROCESSOR ADDRESS
JMP I OPPNT / USE IT
EJECT
/ "INSFTC" - FETCH INSTRUCTION WORD
/ THE WORD POINTED TO BY "PCTR" IS LOADED INTO THE MQ
/ "PCTR" IS THEN INCREMENTED BY ONE
INSFTC, 0
CDF 10 / REFERENCED AS INSFTC+1
TAD I PCTR
MQL
CDF BSEFLD
ISZ PCTR
JMP I INSFTC / NO FIELD OVERFLOW
TAD INSFTC+1
TAD [10
DCA INSFTC+1 / RESET "CDF"
JMP I INSFTC / EXIT
/ "FEWRDI" - SAME AS "FEWORD" WITH POST-INCREMENT OF "MA"
FEWRDI, 0
JMS STFAD
TAD I WPNT / GET THE DATUM
MQL
CDF BSEFLD
CLL CLA CML RTL / 2, WITH ZERO LINK
TAD MA+1
DCA MA+1 / ADD ONE WORD (TWO BYTES)
SZL
ISZ MA / PROPAGATE ANY CARRY
JMP I FEWRDI
/ "FEBYTE" - FETCH BYTE POINTED TO BY "MA", LEAVE BYTE IN THE MQ
FEBYTE, 0
JMS STFAD / SET UP FETCH-ADDRESS
TAD I WPNT / FETCH PROPER PDP-8 WORD
SNL / WHICH BYTE MIGHT WE BE WANTING?
BSW / THE HIGH-ORDER ONE
AND [77
MQL / ANSWER WANTS TO BE IN MQ
CDF BSEFLD
JMP I FEBYTE
EJECT
/ "FEBYTI" - SAME AS "FEBYTE" WITH POST-INCREMENT OF "MA"
FEBYTI, 0
JMS FEBYTE / DO ACTUAL FETCH
ISZ MA+1 / BUMP LOW-ORDER "MA"
JMP I FEBYTI / EXIT IF NO CARRY-OUT
ISZ MA / PROPAGATE THAT CARRY
JMP I FEBYTI
/ "MEFAD" - MOVE "EFFAD1" TO "MA"
MEFAD, 0
TAD EFFAD1
DCA MA
TAD EFFAD1+1
DCA MA+1
JMP I MEFAD
/ "STBYTE" - STORE BYTE AT "MA", BYTE PASSED IN THE MQ
STBYTE, 0
JMS STFAD / BY NOW, IT SHOULD BE PERFECTLY CLEAR WHAT THAT DOES!!
TAD I WPNT / FETCH OLD WORD
SNL / WHICH BYTE IS WANTED?
BSW / THE HIGH-ORDER ONE, NATURALLY
AND [7700 / PRESERVE THE PRESERVABLE BYTE
MQA / OR IN NEW BYTE
SNL
BSW / RETURN TO PROPER BYTE-ORDER
DCA I WPNT / RE-STORE IT
KCDF0, CDF BSEFLD
JMP I STBYTE
/ "STBYTI" - STORE BYTE, THEN INCREMENT "MA"
STBYTI, 0
JMS STBYTE / GO DO STORING
ISZ MA+1 / BUMP LOW-ORDER ADDRESS
JMP I STBYTI / EXIT IF NO CARRY
ISZ MA / PROPAGATE (OPEN)
JMP I STBYTI
EJECT
/ "STFAD" - SET FETCH (STORE) ADDRESS
STFAD, 0
TAD MA
RTL
AND (70
TAD KCDF0 / MANUFACTURE A PROPER FIELD CHANGER
DCA .+1 / PUT IT WHERE IT CAN DO SOME GOOD
HLT / EXECUTE THE FIELD-CHANGER
CLL CLA IAC
AND MA
RAR
TAD MA+1
RAR
DCA WPNT / DEVELOPE PROPER WORD-ADDRESS
/ NOTE: IF LINK IS ON, THE BYTE-ADDRESS WAS ODD (THAY!)
JMP I STFAD
OPCODE, 0
OPPNT, 0
PAGE
/ "EFFAD" - CALCULATE EFFECTIVE ADDRESS
/ DESCRIPTOR POINTER IS IN MQ, INDEX NUMBER IN AC
EFFAD, 0
DCA EFFREG
MQA
AND (1777
DCA DN1 / "DN1" IS COPY OF DESCRIPTOR
MQA
CLL RAL / 2 * ORDINAL
TAD DN1 / 3 * ORDINAL
TAD (DSCTAB-1
DCA XR4
CDF IOFLD
TAD I XR4
AND [17
DCA EFFAD1
TAD I XR4
DCA EFFAD1+1
TAD I XR4
CDF BSEFLD
DCA OPLEN1
TAD EFFREG
SNA / ARE WE INDEXED?
JMP EFOUT / NO
EJECT
TAD [AREG
DCA EFFREG / POINT TO PROPER A-REGISTER
CLL STA / SUBSCRIPTING IS ONE-ORIGIN
TAD I EFFREG
SNL / IS THIS A ZERO SUBSCRIPT?
JMP I BADSUB / YES, GO SCREAM
OKSUB, DCA TEMP1
MQA
SPA CLA / IS THIS DOUBLE-SUBSCRIPTING?
JMP DBLSUB / YES
TAD OPLEN1
CIA / LENGTH IS NEGATIVE
DCA TEMP2
TAD BINFLG
SNA CLA / IS THIS "BINARY" INDEXING?
JMP NOTBIN / NO
TAD TEMP1
CLL RAL / YES, MULTIPLY OFFSET BY TWO
SZL
ISZ EFFAD1 / TAKE CARE OF LARGE OFFSETS
JMP NOMULT / AVOID NEEDLESS MULTIPLY
NOTBIN, TAD OPLEN1
IAC
SZA CLA / IS LENGTH ONE?
JMP .+3 / NO GO DO MULTIPLY
TAD TEMP1 / IF LENGTH IS ONE, AVOID MULTIPLY
JMP NOMULT
JMS BMULT / MULTIPLY INDEX BY ITEM-LENGTH
TAD TEMP3 / RESULT OF MULTIPLY
NOMULT, CLL
TAD EFFAD1+1
DCA EFFAD1+1
SZL
ISZ EFFAD1 / ADD OFFSET TO BASE-ADDRESS
EFOUT, DCA BINFLG / CLEAR "BINARY"-INDEXING FLAG
JMP I EFFAD / EXIT
EJECT
/ "DBLSUB" - PROCESS DOUBLE-SUBSCRIPTS
DBLSUB, CLL
TAD TEMP1
TAD EFFAD1+1
DCA EFFAD1+1
SZL
ISZ EFFAD1 / SET PROPER BASE-ADDRESS
TAD EFFREG
TAD [BREG-AREG
DCA EFBREG / POINT TO PROPER B-REGISTER
TAD I EFBREG
CIA
TAD TEMP1
SMA
JMP I (BACKSB / BACKWARD SUBSCRIPT PAIR
DCA OPLEN1 / STORE OPERAND-LENGTH
JMP EFOUT
/ "TWOAD" - CALCULATE BOTH EFFECTIVE ADDRESSES
TWOAD, 0
JMS I [INSFTC / FETCH "DN-1"
MQA
DCA TWOTMP
JMS I [INSFTC
TAD R2
JMS EFFAD / DO ADDRESS-2
TAD DN1
DCA DN2
TAD EFFAD1
DCA EFFAD2
TAD EFFAD1+1
DCA EFFAD2+1
TAD OPLEN1
DCA OPLEN2 / MOVE PARAMETERS TO CORRECT SLOTS
TAD TWOTMP
MQL
TAD R1
JMS EFFAD / DO ADDRESS-1
JMP I TWOAD
EJECT
/ "XRSET" - SET POINTERS TO X-REG. DESIGNATOR PASSED IN AC
XRSET, EFFTMP, 0
DCA RBASE1
TAD RBASE1
CLL RTL ; RTL / 16 * ORDINAL
TAD RBASE1 / 17 * ORDINAL
TAD (XREG
DCA RBASE1 / FINAL POINTER TO SIGN OF X-REG
JMP I XRSET
/ "BMULT" - FORM TEMP3 = TEMP1 * TEMP2
BMULT, 0
TAD TEMP1
IFZERO EAE <
MQL
TAD (-14 / 12 DECIMAL
DCA EFFTMP
BMULLP, CLL RAL / MULTIPLY PARTIAL BY TWO
SWP
CLL RAL / SET UP NEXT MULTIPLIER BIT
SWP
SZL
TAD TEMP2 / ADD IN MULTIPLICAND, IF WANTED
ISZ EFFTMP
JMP BMULLP / LOOP FOR ALL TWELVE BITS
>
IFNZRO EAE <
MQL MUY / "MODE-B" MPY
TEMP3
CLA MQA
>
DCA TEMP3 / STORE RESULT
JMP I BMULT
EFBREG, 0
TWOTMP, 0
PAGE
/ "BRANCH" - NORMAL BRANCH
BRANCH, STA
/ "PUSHJ" - SUBROUTINE CALL
PUSHJ, DCA DASU / NICE PLACE TO STORE FLAG
CLA IAC / 1
DCA BINFLG / BINARY INDEXING
TAD (OKSUB
DCA BADSUB / NO SUBSCRIPT TEST ON "BRANCH"
JMS I [ONEAD / CALCULATE POTENTIAL BRANCH-ADDRESS
TAD RTSUB
DCA BADSUB / RE-ENABLE SUBSCRIPT TESTS (MAYBE)
TAD CONDCD
AND R2
SNA CLA
JMP I [RNI / NO BRANCH
ISZ DASU
JMP PUSHJ1 / IS THIS A "CALL"?
DOBRN, TAD R1
SZA CLA / WAS THIS A "COMPUTED GO-TO" ?
JMP CGOTO / YES
SETPCT, TAD EFFAD1
CLL RAR
MQL
TAD EFFAD1+1
RAR
DCA PCTR
MQA
CLL RTL
RAL
TAD (CDF 0
DCA I [INSFTC+1
JMP I [RNI / GO USE IT
CGOTO, TAD I EFFREG
SNA
JMP POPCHK / ZERO IS INVALID SUBSCRIPT
CLL
TAD OPLEN1 / MAXIMUM FOR SUBSCRIPT
SZL CLA
JMP POPCHK / SUBSCRIPT IS TOO BIG
JMS I [MEFAD
JMS I [FEWORD / FETCH LABEL DESCRIPTOR ORDINAL
/ GET HERE ALSO IF ERROR AND "ON ERROR" IS ON
/ THE DESCRIPTOR OF THE ERROR-LABEL IS IN THE MQ
ERRBRN, JMS I [EFFAD / RESOLVE IT TO AN ADDRESS
JMP SETPCT
EJECT
PUSHJ1, CLL
TAD STKPNT
TAD MAXSTK
SZL CLA / IS STACK OVERLY FULL?
JMP I (STKOVR / YES, GO GRIPE
TAD I [INSFTC+1
CDF IOFLD
DCA I STKPNT
ISZ STKPNT
TAD PCTR
DCA I STKPNT / STACK ADDRESS OF NEXT INSTRUCTION
CDF BSEFLD
ISZ STKPNT
JMP DOBRN / GO RESET P-COUNTER
/ "DASU" - DECIMAL ARITHMETIC SET-UP
DASU, 0
JMS I (X2SET / SET REGISTER POINTERS
TAD I RBASE1
DCA SGN1
TAD I RBASE2
DCA SGN2 / SET OPERAND-SIGNS
TAD RBASE1
DCA XR1 / OPERAND-1
TAD RBASE2
DCA XR2 / OPERAND-2
TAD RBASE1
DCA XR3 / RESULT
JMP I DASU
EJECT
/ "POPJ" - SUBROUTINE-RETURN
POPJ, TAD CONDCD
AND R2
SNA CLA
JMP I [RNI / NO NEED FOR BRANCH
TAD R1
SNA CLA
JMP .+4
TAD (SUBSTK
DCA STKPNT / MERELY NEED TO CLEAR STACK
JMP I [RNI
CLL
TAD STKPNT
TAD MINSTK
SNL CLA / ARE THERE DATA ON THE STACK?
JMP I (STKUND / NO, GO GRIPE
/ LINK WILL BE SET IF STKPNT.LE.SUBSTK+1
POPIT, STA
TAD STKPNT
DCA STKPNT
CDF IOFLD
TAD I STKPNT
DCA PCTR
STA
TAD STKPNT
DCA STKPNT
TAD I STKPNT
CDF BSEFLD
DCA I [INSFTC+1 / RESTORE "P" FROM THE STACK
JMP I [RNI
POPCHK, TAD DASU / WHICH HAS BEEN "ISZ'D" SINCE IT WAS LOADED
SNA CLA / IS THIS A COMPUTED CALL WHICH FAILED?
JMP I [RNI / NO
JMP POPIT / YES, FIX STACK AGAIN
EJECT
/ "XMITAA" - TRANSMIT ONE A-REGISTER TO ANOTHER
XMITAA, JMS I (A2SET / SET POINTERS
TAD I RBASE2
DCA I RBASE1 / DO THE MOVE
JMP I [RNI
/ "XMITBA" - TRANSMIT AN A-REGISTER TO A B-REGISTER
XMITBA, TAD R1
TAD (BREG
DCA RBASE1
TAD R2
TAD [AREG
DCA RBASE2 / SET THE POINTERS
TAD I RBASE2
DCA I RBASE1 / DO THE MOVE
JMP I [RNI
MAXSTK, -SUBSTK-SSLEN
MINSTK, -SUBSTK-1
PAGE
/ "CMPXX" - COMPARE TWO X-REGISTERS
CMPXX, JMS I (X2SET / SET X-REGISTER POINTERS
TAD I RBASE2
CLL CIA
TAD I RBASE1
SNA CLA / ARE SIGNS THE SAME?
JMP LNGCMP / YES, GO DO FULL COMPARE
/ IF SIGNS DIFFER, WE MUST TEST FOR +0 AND -0
CMPZCK, ISZ RBASE1
ISZ RBASE2
TAD I RBASE1
TAD I RBASE2
SZA CLA
JMP CMPTST / IF EITHER BYTE IS NON-ZERO...
/...RESULT DEPENDS STRICTLY ON THE SIGN
ISZ CNT
JMP CMPZCK / TEST ALL BYTES
JMP STEQL / -0 = +0
/ NOTE: LINK WAS SET AT CMPXX+3
CMPTST, CLA IAC / ASSUME "LOW" RESULT
SNL / WERE WE RIGHT? (IF LINK IS ON, WE WANT "LOW")
CLL RTL / NO, SET "HIGH"
DCA CONDCD
JMP I [RNI
LNGCMP, TAD CNT
CIA / LENGTH IS NEGATIVE
TAD RBASE1
DCA RPNT1
TAD CNT
CIA
TAD RBASE2
DCA RPNT2 / FIND HIGH-ORDER ENDS OF REGISTERS
EJECT
LNGCLP, TAD I RPNT1
CLL CIA
TAD I RPNT2
SNA CLA
JMP LGCNXT / BYTES ARE EQUAL
TAD I RBASE1
SZA CLA / ARE OPERANDS NEGATIVE?
CML / YES, REVERSE SENSE OF TEST
JMP CMPTST
LGCNXT, STA
TAD RPNT1
DCA RPNT1
STA
TAD RPNT2
DCA RPNT2
ISZ CNT
JMP LNGCLP / LOOP IF MORE BYTES
STEQL, CLL CLA CML RTL / 2: "EQUAL" CONDITION
JMP LNGCMP-2 / GO STORE RESULT
EJECT
/ "CMPAA" - COMPARE TWO A-REGISTERS
CMPAA, JMS I (A2SET / SET A-REGISTER POINTERS
TAD I RBASE2
CLL CIA
TAD I RBASE1 / COMPARE REGISTERS
SNA
JMP STEQL / EQUAL A-REGISTERS
RAL / PUT SIGN BIT IN LINK
JMP CMPTST
/ "CMPC" - COMPARE TWO BYTE STRINGS
CMPC, JMS I [TWOAD / DO TWO ADDRESS SETUP
JMS I [MVSU
CMPCLP, JMS FEOP1I / GET NEXT BYTE FROM STRING-1
MQA
DCA CMPTMP / SAVE IT
JMS FEOP2I / GET NEXT BYTE FROM STRING-2
MQA
CLL CIA
TAD CMPTMP
SZA CLA / COMPARE THESE BYTES
JMP CMPTST / GOT UNEQUAL; WHICH ORDER?
ISZ CNT
JMP CMPCLP / LOOP THROUGH ENTIRE STRINGS
JMP STEQL / THEY ARE EQUAL
EJECT
/ "FEOP1I" - GET NEXT STRING-1 BYTE
FEOP1I, 0
JMS I [MEFAD
JMS I [FEBYTE / FETCH BYTE
ISZ EFFAD1+1 / BUMP LOW-ORDER STRING-POINTER
JMP I FEOP1I / NO CARRY
ISZ EFFAD1 / PROPAGATE CARRY
JMP I FEOP1I
/ "STOP1I" - STORE BYTE INTO STRING ONE AND BUMP POINTERS
STOP1I, 0
TAD EFFAD1
DCA MA
TAD EFFAD1+1
DCA MA+1
JMS I (STBYTE
ISZ EFFAD1+1
JMP I STOP1I
ISZ EFFAD1
JMP I STOP1I
/ "FEOP2I" - GET NEXT STRING-2 BYTE
FEOP2I, 0
TAD EFFAD2
DCA MA
TAD EFFAD2+1
DCA MA+1
JMS I [FEBYTE / FETCH BYTE
ISZ EFFAD2+1 / BUMP LOW-ORDER
JMP I FEOP2I / EXIT ON NO CARRY
ISZ EFFAD2
JMP I FEOP2I
/ "FEWORD" - FETCH WORD POINTED TO BY "MA"
/ RESULT IS LEFT IN -MQ-
FEWORD, 0
JMS I (STFAD / SET UP ADDRESS FOR FETCH
TAD I WPNT / DO THE FETCH
MQL / SAVE DATUM IN A NICE WARM PLACE
CDF BSEFLD / RESET TO RIGHT FIELD (OR SHORTSTOP)
JMP I FEWORD
EJECT
/ "MULT10" - MULTIPLY (AC) BY 10
MULT10, 0
IFZERO EAE <
CLL RAL
DCA M10TMP / 2 * ARG
TAD M10TMP
CLL RAL / 4 * ARG
CLL RAL / 8 * ARG
TAD M10TMP / 10 * ARG
/ THREE SEPERATE ROTATES PREVENT BITS FROM END-ROUND PROPAGATING
>
IFNZRO EAE <
MQL MUY
(12
CLA MQA
>
JMP I MULT10
/ "ONEAD" - CALCULATE FIRST EFFECTIVE ADDRESS
ONEAD, 0
JMS I [INSFTC / FETCH "DN"
TAD R1
JMS I [EFFAD
JMP I ONEAD
CMPTMP, 0
M10TMP, 0
DECIMAL
TENTAB, -1000 ; -100 ; -10 / POWERS OF TEN (IN BINARY)
OCTAL
PAGE
/ "LOD" - LOAD A DECIMAL VARIABLE INTO AN X-REGISTER
LOD, STA / ALLOW ADDRESS RESET ON LONG (>16) FIELDS
JMS LDSTST / SET POINTERS AND MOVE COUNTER
TAD CNT
CMA / COUNT NEEDS TO BE ONE TOO LARGE
TAD XRLEN
DCA TEMP1 / CLEAR-COUNTER
TAD RPNT1
DCA XR1 / CLEAR-POINTER
/ NOTE: "CNT" CAN NEVER BE GREATER THAN "XRLEN"
LODLP, JMS I [FEBYTI / GET A BYTE
MQA
AND [37 / REMOVE ANY ZONE-BIT
TAD [-21 / REMOVE BIAS
SPA
CLA / MAKE BLANKS (AMONG OTHERS ZERO)
DCA I RPNT1 / STORE INTO REGISTER
STA
TAD RPNT1
DCA RPNT1 / UPDATE REGISTER POINTER
ISZ CNT
JMP LODLP
MQA
AND (40
CLL RAL
BSW / SIGN MUST BE ONE OR ZERO
DCA I RBASE1 / STORE REGISTER SIGN
/ NOW, CLEAR REST OF REGISTER
ISZ TEMP1
SKP
JMP I [RNI / DONE WHEN FINISHED CLEARING
DCA I XR1
JMP .-4
EJECT
/ "STO" - STORE X-REGISTER INTO A DECIMAL VARIABLE
STO, JMS LDSTST / GO DO SET UP
TAD CNT
CIA
TAD OPLEN1
SMA / NEED TO CLEAR LEFT END OF VARIABLE?
JMP STOLP-1 / NO
DCA TEMP1
TAD [21 / "0"
MQL
JMS I [STBYTI
ISZ TEMP1 / OUTPUT THE CLEAR-BYTE
JMP .-2
CLL CLA
STOLP, TAD I RPNT1
TAD [21
MQL / DO PRELIMINARY PROCESSING (RE-BIASING)
ISZ CNT
SKP / COUNT IS NOT YET AN EARL
JMP STSGN / GO PROCESS LAST BYTE
JMS I [STBYTI / STORE INTERMEDIATE BYTE
STA
TAD RPNT1
DCA RPNT1 / RESET REGISTER POINTER
JMP STOLP
STSGN, TAD I RBASE1 / GET SIGN
BSW
CLL RAR / FORM EITHER ZERO OR FOURTY
MQA / MERGE IN DATA-BYTE
MQL / PUT BACK IN MQ FOR "STBYTE"'S BENIFIT
JMS I [STBYTI / GO DO STORE
JMP I [RNI
EJECT
/ "LDSTST" - SET UP FOR X-REGISTER LOADS AND STORES
LDSTST, 0
DCA LDSKLG
JMS I [ONEAD / CALCULATE VARIABLE'S ADDRESS
TAD R2
JMS I [XRSET / SET REGISTER POINTER
TAD OPLEN1
DCA CNT / ASSUME VARIABLE IS SHORTER THAN REGISTER
TAD XRLEN
CLL CIA / LENGTH WAS COMPLEMENTED (AND IT WENT TO ITS HEAD)
TAD OPLEN1
SZL / WAS ASSUMPTION CORRECT? (LENGTH IS COMPLEMENTED!)
JMP LDST1 / YES
ISZ LDSKLG
CLL CLA CML / PREVENT ADDRESS RESET ON STORE
/ "CIA" WILL TOGGLE LINK (WHICH WANTS TO BE CLEAR)
CIA / MAKE EXCESS LENGTH POSITIVE
TAD EFFAD1+1
DCA EFFAD1+1
SZL
ISZ EFFAD1 / ADDRESS OF MOST SIGNIFICANT STRING-BYTE
TAD XRLEN
DCA CNT / RESET BYTE-COUNT
LDST1, CLL CLA
JMS I [MEFAD
TAD CNT
CIA / "CNT" IS NEGATIVE
TAD RBASE1
DCA RPNT1 / MOST-SIG. USEFUL X-REG. BYTE
JMP I LDSTST
LDSKLG, 0
/ "LDCTAB" - TRANSFER-VECTOR FOR "LODCAL"
LDCTAB, LOADER
LODRLP
RANAD1
LDCL3
OPEN1
BADREC
NOBUFS
EJECT
/ "MVCC" - MOVE ALPHA VARIABLE TO ALPHA VARIABLE
/ DATA IS LEFT-ADJUSTED WITH BLANK-FILL.
/ TRUNCATION (IF ANY) OCCURS ON THE RIGHT.
MVCC, JMS I [TWOAD / SET POINTERS TO VARIABLES
JMS MVSU / SET COUNTERS FOR MOVE
JMS I [FEOP2I
JMS I [STOP1I / MOVE THE DATA
ISZ CNT
JMP .-3
JMS BLFILL / BLANK-FILL IF NEEDED
JMP I [RNI
/ "BLFILL" - BLANK FILL RESULT-STRING (IF NEEDED)
BLFILL, 0
TAD TEMP1
SMA CLA / IS FILL NEEDED?
JMP I BLFILL / NO
CLA IAC
MQL
JMS I [STOP1I
ISZ TEMP1
JMP .-2 / STORE NEEDED BLANKS
JMP I BLFILL
/ "MVSU" - SET UP FOR MOVE-INSTRUCTIONS
MVSU, 0
TAD OPLEN2
DCA CNT / ASSUME DESTINATION IS LONGER...
TAD OPLEN2
CLL CIA
TAD OPLEN1
DCA TEMP1 / ...AND WILL NEED FILLING
SNL / WAS ASSUMPTION CORRECT? (LENGTHS ARE COMPLEMENTED)
JMP I MVSU / YES, EXIT
TAD OPLEN1
DCA CNT / CORRECT THE COUNT
JMP I MVSU
PAGE
/ "SUBXX" - SUBTRACT X-REGISTERS
SUBXX, JMS I (DASU / GO DO DECIMAL-ARITHMETIC SET-UP
TAD SGN2
RAR
CLA CML RAL
DCA SGN2 / COMPLEMENT SECOND OPERAND
SKP
/ "ADDXX" - ADD X-REGISTERS
ADDXX, JMS I (DASU / DO SET-UP
TAD SGN1
TAD SGN2
RAR
SNL CLA
JMP DOADD / SIGNS ARE ALIKE, MERELY ADD
TAD SGN1
SNA CLA / IS FIRST OPERAND THE NEGATIVE ONE?
JMP DOSUB / NO, GO DO SUBTRACT
TAD XR1
MQL
TAD XR2
DCA XR1
MQA
DCA XR2 / SWAP POINTERS
EJECT
/ COME HERE TO DO SUBTRACTION
DOSUB, TAD XR3
DCA SUBREG / SAVE RESULT-POINTER IN CASE OF NEEDED RECOMPLEMENT
DCA I RBASE1 / ASSUME POSITIVE RESULT
JMS DSUB
SNL / DO WE NEED TO RECOMPLEMENT?
JMP I [RNI / NO, THANK GOD!
TAD XRLEN
DCA CNT
CLL CLA IAC / 1, WITH ZERO LINK
DCA I RBASE1 / CORRECT RESULT SIGN
RECOMP, ISZ SUBREG / "SUBREG" STARTS POINTING AT SIGN-BYTE
RAL / PREVIOUS BORROW
TAD I SUBREG
CIA
CLL
SPA
TAD (12
DCA I SUBREG / DO RECOMPLEMENT
ISZ CNT
JMP RECOMP
JMP I [RNI
/ COME HERE TO DO ADDITION
DOADD, JMS DADD / GO DO THE ADD
JMP I [RNI
EJECT
/ "DSUB" - DO BYTE-BY-BYTE DECIMAL SUBTRACT
/ (XR3) _ (XR1) - (XR2)
/ IF LINK IS ON AT END OF OPERATION, OVERDRAFT OCCURED
DSUB, 0
CLL / NO PREVIOUS BORROW ON ENTRY
RAL / GET PREVIOUS BORROW
TAD I XR2
CIA
TAD I XR1 / DO SUBTRACTION
CLL
SPA / DID WE OVERDRAW?
TAD (12 / YES, RECOVER ANSWER AND GENERATE BORROW FLAG
DCA I XR3 / STORE RESULT
ISZ CNT
JMP DSUB+2
JMP I DSUB
/ "DADD" - FORM BYTE-BY-BYTE DECIMAL SUM
/ (XR3) _ (XR1) + (XR2)
/ IF LINK IS ON AT END OF OPERATION, OVERFLOW OCCURED
DADD, 0
CLL / NO PREVIOUS CARRY ON ENTRY
RAL / ACCESS PREVIOUS CARRY
TAD I XR1
TAD I XR2 / DO ADDITION
TAD (-12
CLL CML / SET CARRY FLAG ON SPECULATION
SPA / WAS THERE A CARRY?
TAD (12 / NO, RECOVER ANSWER AND CLEAR CARRY-FLAG
DCA I XR3
ISZ CNT
JMP DADD+2
JMP I DADD
EJECT
/ "DADCHK" - INSURE DISK BLOCK IS WITHIN FILE
DADCHK, 0
TAD MAXBLK
SNA / IS THIS A FILE-STRUCTURED DEVICE?
JMP I DADCHK / NO, IT IS THEREFORE OF INFINITE LENGTH
CLL CIA
TAD CURBLK
SZL CLA / IS ADDRESS WITHIN FILE?
JMP I (BADDAD / NO, GO GRIPE!!
JMP I DADCHK
/ "OBINW" - OUTPUT A BINARY WORD TO BUFFER
OBINW, 0
DCA SUBREG / SAVE THE WORD TO BE OUTPUT
TAD BUFLEN
CLL CIA
TAD CURBPT
SZL CLA / IS BUFFER OVERLY FULL?
JMS I [DMPBUF / YES, GO DUMP IT
TAD CURBPT
TAD BUFLOC
DCA TEMP2 / FORM-BUFFER POINTER
CDF IOFLD
TAD SUBREG / RECOVER HIDDEN DATUM
DCA I TEMP2 / OUTPUT IT
CDF BSEFLD
ISZ CURBPT
JMP I OBINW
EJECT
/ "READ" - RANDOM-READ
READ, TAD AREG+7
JMS I [IOINIT / SET UP I/O-DESCRIPTORS
TAD CURCTL
SPA CLA / IS THIS A TRANSITION FROM OUTPUT TO INPUT?
JMP READ2 / NO
TAD CURBPT
SPA SNA CLA / NO BUFFER DUMP IF BUFFER IS EMPTY
/ OPEN-19 FOLLOWED BY READ IN BLOCK ONE FAILS WITHOUT THIS TEST
JMP READ1
JMS I [DMPBUF / OUTPUT THIS BUFFER
READ1, CLL CLA CML RAR / 4000
TAD CURCTL
DCA CURCTL / TURN ON READ-BIT
READ2, JMS I (RANAD / GO EVALUATE DISK ADDRESS
STA / ENABLE RECORD-LENGTH TEST
JMP I (BININ1
/ "WRITE" - RANDOM-WRITE
WRITE, TAD AREG+7
JMS I [IOINIT / SET UP I/O POINTER-GOODIES
JMS I (RANAD
CLL CLA CMA RAR / 3777
AND CURCTL
DCA CURCTL / CLEAR READ-BIT
JMP I (BINOUT
SUBREG, 0
PAGE
/ "MVNN" - MOVE NUMERIC DATA TO NUMERIC DATA
/ DATA IS RIGHT-ADJUSTED WITH ZERO FILL
/ TRUNCATION (IF ANY) OCCURS ON THE LEFT
/ DATA IS COPIED VERBATUM
MVNN, JMS I [TWOAD / DO SET-UP OF POINTERS
TAD [21 / ZERO FILL
JMS DMVSU / GO DO MOVE SET-UP
JMS I [FEOP2I
JMS I [STOP1I
ISZ CNT
JMP .-3 / MOVE DATA
JMP I [RNI
/ "DMVSU" - SET UP FOR DECIMAL MOVES
DMVSU, 0
MQL / SET CLEAR-BYTE
JMS I [MVSU / SET POINTERS
TAD TEMP1
SMA CLA / IS DESTINATION LONGER?
JMP LNGSRC / NO
JMS I [MEFAD
JMS I [STBYTI
ISZ TEMP1
JMP .-2 / DO FILL
TAD MA
DCA EFFAD1
TAD MA+1
DCA EFFAD1+1 / RESET DESTINATION ADDRESS
JMP I DMVSU
LNGSRC, CLL
TAD EFFAD2+1
TAD TEMP1
DCA EFFAD2+1
SZL
ISZ EFFAD2 / GET PROPER LEFT END OF SOURCE
JMP I DMVSU
EJECT
/ "MVCN" - MOVE NUMERIC TO ALPHA
/ THE DESTINATION IS RIGHT-ADJUSTED WITH BLANK FILL.
/ IF THE SOURCE IS NEGATIVE, A "-" IS OUTPUT AS
/ THE FIRST SIGNIFICENT CHARACTER OF THE DESTINATION.
/ TRUNCATION (IF ANY) OCCURS ON THE LEFT
/ IF THE MINUS IS NEEDED, IT IS OUTPUT IN ANY CASE
MVCN, JMS I [TWOAD / FIND THE VARIABLES
TAD OPLEN2
CLL CMA / NEEDS TO BE POSITIVE AND ONE TOO SMALL
TAD EFFAD2+1
DCA MA+1
RAL
TAD EFFAD2
DCA MA / POINT TO RIGHTMOST BYTE
JMS I [FEBYTE
MQA
AND (40
DCA SGN1 / SAVE SOURCE SIGN
TAD EFFAD2
DCA MA
TAD EFFAD2+1
DCA MA+1
MVCN1, TAD MA
DCA EFFAD2
TAD MA+1
DCA EFFAD2+1 / SAVE ADDRESS OF CURRENT BYTE IN HOPES IT IS NON-ZERO
JMS I [FEBYTI / FETCH NEXT BYTE
MQA
AND [37
TAD [-1
SNA / IS CHARACTER A BLANK?
JMP .+4 / YES
TAD (-20
SZA CLA / IS IT A ZERO?
JMP .+5 / NO
ISZ OPLEN2
JMP MVCN1 / TRY SOME MORE, MAYBE
STA / SOURCE ALL ZEROS...
DCA OPLEN2 /...RESET LENGTH TO PASS ONE OF THEM
EJECT
TAD SGN1
JMS I (CNSU
MVCN2, JMS I [FEOP2I / GET A BYTE
MQA
AND [37
TAD [-1
SNA / IS THIS A BLANK?
TAD (20 / YES, MAKE IT A ZERO (EVENTUALLY)
IAC / RESTORE BYTE
MQL
JMS I [STOP1I
ISZ CNT
JMP MVCN2
JMP I [RNI
/ "STOC" - STORE X-REGISTER INTO ALPHA-VARIABLE
/ IF X IS NEGATIVE, A MINUS IS OUTPUT
/ AS THE MOST SIGNIFICANT BYTE OF RESULT.
/ TRUNCATION (IF ANY) OCCURS ON THE LEFT
/ THE MINUS (IF NEEDED) IS OUTPUT IN ANY CASE
STOC, JMS I [ONEAD / SET POINTERS TO ALPHA-VARIABLE
TAD R2
JMS I [XRSET / SET POINTER TO SOURCE-REGISTER
JMP I (LSIG / FIND LEFT-MOST NON-ZERO
STOCA, STA / WAS NONE
DCA OPLEN2
ISZ RPNT1 / SET UP TO STORE LONELY ZERO
STOCB, TAD I RBASE1
JMS I (CNSU
JMS I [MEFAD
STOC3, TAD I RPNT1
TAD [21 / RE-BIAS DIGIT
MQL
JMS I [STBYTI / STORE A BYTE
STA
TAD RPNT1
DCA RPNT1
ISZ CNT
JMP STOC3 / LOOP UNTIL DONE MOVE
JMP I [RNI
EJECT
/ "LODCH" - LOAD ASCII CHARACTER TO AN A-REGISTER
LODCH, TAD R2
TAD (DCA AREG
DCA .+5
JMS I [ONEAD / POINT TO PROPER BYTE
JMS I [MEFAD / SET UP ADDRESS
JMS I [FEBYTE / GET THE DATUM
MQA
HLT
JMP I [RNI
/ "STOCH" - STORE ALPHA CHARACTER FROM A-REGISTER
STOCH, TAD R2
TAD (TAD AREG
DCA .+3
JMS I [ONEAD / POINT TO CORRECT BYTE
JMS I [MEFAD
HLT
AND [77 / CLEAN OUT ANY JUNQUE
MQL
JMS I (STBYTE
JMP I [RNI
PAGE
/ "LODC" - LOAD AN ALPHA VARIABLE INTO AN X-REGISTER
/ ALPHA MAY CONTAIN ONLY DIGITS, "+"'S (WHICH ARE IGNORED),
/ "-"'S (WHICH TOGGLE "SGN1"), AND BLANKS (WHICH ARE IGNORED).
/ ANY OTHER CHARACTER GENERATES AN ERROR CONDITION
/ THE RESULT IS RIGHT-ADJUSTED WITH ZERO FILL.
/ TRUNCATION (IF ANY) OCCURS ON THE LEFT
LODC, JMS I [ONEAD / SET POINTERS TO ALPHA-FIELD
TAD EFFAD1
DCA EFFAD2
TAD EFFAD1+1
DCA EFFAD2+1
TAD OPLEN1
DCA OPLEN2 / POINTERS ARE NEEDED IN SECOND SLOTS
JMS I (CNTCHR / FIND TRUE LENGTH OF ALPHA
TAD R2
JMS I [XRSET / SET REGISTER POINTER
TAD XRLEN
DCA OPLEN1 / FOOL "MVSU"
TAD OPLEN2
SNA CLA / ALL BLANKS?
JMP I (CLRALL / GO CLEAR WHOLE X-REGISTER
JMS I [MVSU
TAD CNT
CIA
TAD RBASE1
DCA RPNT1 / LEFT-MOST USABLE REGISTER-BYTE
TAD RPNT1
DCA XR1 / (CLEARING-POINT) - 1
TAD SGN1
DCA I RBASE1 / SET SIGN-BYTE
TAD EFFAD1
DCA EFFAD2
TAD EFFAD1+1
DCA EFFAD2+1 / RESTORE FETCH-ADDRESS
DCA OPLEN2 / AVOID "ALPDIG"-S ODD EXIT
LODCLP, JMS ALPDIG / GET A CHARACTER
NOP / UNUSED EXIT
MQA
TAD [-21
DCA I RPNT1
STA
TAD RPNT1
DCA RPNT1 / RESET REGISTER POINTER
ISZ CNT
JMP LODCLP / FILL REGISTER
LODCCL, TAD TEMP1
SMA CLA / DO WE HAVE SOME BYTES TO ZERO?
JMP I [RNI / NO
DCA I XR1
ISZ TEMP1
JMP .-2 / ZERO THOSE BYTES WHICH DESERVE IT
JMP I [RNI
EJECT
/ "ALPDIG" - TEST FOR VALID NUMERICS
/ EXIT TO CALL+1 IF NO MORE DATA IN STRING
/ EXIT TO CALL+2 IF VALID DIGIT
/ BLANKS AND PLUSES ARE IGNORED
/ MINUS TOGGLES "SGN1"
/ ALL OTHER CHARACTERS ARE ERRORS
ALPDIG, 0
ISZ OPLEN2
SKP
JMP I ALPDIG / NO MORE DATA, TAKE "TAIN'T NUN" EXIT.
JMS I [FEOP2I / GET A CHARACTER
MQA
TAD [-1
SNA
JMP ALPDIG+1 / IGNORE BLANKS
TAD (-14+1
SNA
JMP ALPDIG+1 / IGNORE PLUSES (PLI)
TAD (-16+14
SZA
JMP .+6 / NOT MINUS
TAD SGN1
RAR
CML CLA RAL
DCA SGN1 / COMPLEMENT RESULT SIGN
JMP ALPDIG+1 / OTHERWISE IGNORE MINUSES (MINI)
TAD (-21+16
SPA / .GE. "0" ?
JMP I (ALPBAD / NO, IT IS TROUBLE
TAD (-33+21
SMA CLA / .LT. ":" ?
JMP I (ALPBAD / IT IS JUNQUE
ISZ ALPDIG / IS DIGIT, FIX UP EXIT...
JMP I ALPDIG / ... AND USE IT
EJECT
/ "MVNC" - MOVE FROM ALPHA-STRING TO NUMERIC-STRING
/ SAME CHARACTER RULES AS "LODC"
/ DATA IS STORED RIGHT-ADJUSTED WITH ZERO-FILL
/ TRUNCATION (IF ANY) TAKES PLACE ON THE LEFT
MVNC, JMS I [TWOAD / SET POINTERS
TAD EFFAD2
DCA TEMP2
TAD EFFAD2+1
DCA TEMP3 / SAVE POINTERS TO SOURCE-OPERAND
JMS I (CNTCHR / DETERMINE NUMBER OF DIGITS IN SOURCE
TAD TEMP2
DCA EFFAD2
TAD TEMP3
DCA EFFAD2+1 / RESTORE POINTERS TO SOURCE
TAD [21 / ZERO FILL
JMS I (DMVSU / SET POINTERS AND DO ANY REQUIRED FILL
TAD OPLEN2
SNA CLA / ALL BLANKS?
JMP I [RNI / YES
DCA OPLEN2 / FOOL "ALPDIG"; WE DO NOT NEED HIS END-OF-STRING
TAD SGN1
DCA SGN2 / SAVE FIRST-PASS SIGN FOR STORING
MVNC1, JMS ALPDIG / GET NEXT DIGIT
NOP / UNUSED EXIT FROM "ALPDIG"
ISZ CNT / HAS COUNT BECOME AN EARL
SKP / NEED PRE-INCREMENT TO GET LAST BYTE SEPERATELY
JMP .+3
JMS I [STOP1I / STORE IT
JMP MVNC1
TAD SGN2
BSW
CLL RAR / SIGN MUST BE "0" OR "40"
MQA
MQL / OR IT INTO LAST BYTE
JMS I [STOP1I / STORE LAST BYTE
JMP I [RNI
EJECT
/ "ADDAA" - ADD A-REGISTERS
ADDAA, JMS I (A2SET / SET POINTERS
TAD I RBASE1
TAD I RBASE2
DCA I RBASE1 / DO THE OPERATION
JMP I [RNI
/ "SUBAA" - SUBTRACT A-REGISTERS
SUBAA, JMS I (A2SET / SET POINTERS
TAD I RBASE2
CIA
TAD I RBASE1 / DO SUBTRACTION
DCA I RBASE1 / STORE RESULT
JMP I [RNI
PAGE
/ "LODB" - TRANSMIT A BINARY VARIABLE TO A B-REGISTER
LODB, TAD [BREG-AREG
/ "LODA" - TRANSMIT A BINARY VARIABLE TO AN A-REGISTER
LODA, TAD [AREG
JMS BINADR / CALCULATE EFFECTIVE ADDRESS
JMS I [FEWORD
MQA
DCA I RBASE2 / PUT IT IN PROPER REGISTER
JMP I [RNI
/ "STOA" - DEPOSIT AN A-REGISTER IN A BINARY VARIABLE
STOA, TAD [AREG
JMS BINADR / CALCULATE PROPER ADDRESS
TAD I RBASE2
MQL
JMS STWORD
JMP I [RNI
/ "STWORD" - REVERSE OF "FEWORD"
STWORD, 0
JMS I (STFAD
MQA
DCA I WPNT
CDF 0 / MUST RUN IN FIELD ZERO
JMP I STWORD
EJECT
/ "BINADR" - CALCULATE EFFECTIVE ADDRESS FOR BINARY OPCODES
BINADR, 0
TAD R2
DCA RBASE2 / SET POINTER TO RELEVANT REGISTER
CLA IAC / 1
DCA BINFLG / LET "EFFAD" KNOW OF "BINARY" INSTRUCTION
JMS I [ONEAD / CALCULATE EFFECTIVE ADDRESS
JMS I [MEFAD / PUT IN A USEFUL PLACE
JMP I BINADR
/ "LODBD" - LOAD A B-REGISTER FROM A DECIMAL VARIABLE
LODBD, TAD [BREG-AREG
/ "LODAD" - LOAD A-REGISTER FROM DECIMAL VARIABLE
/ "LODAD" AND "XMITAX" BOTH REVERSE NORMAL USAGE OF REG-1 AND REG-2
/ I.E., "RBASE1" IS SOURCE-POINTER AND "RBASE2" IS SINK-POINTER
LODAD, TAD [AREG
TAD R2
DCA RBASE2
JMS I [ONEAD / SET POINTER TO VARIABLE
EJECT
/ AT THIS POINT, WE HAVE PROPER LEFT-END OF VARIABLE AND LENGTH
LODAD1, JMS I [MEFAD / PUT ADDRESS IN "MA"
JMP .+3 / AVOID USELESS "MULTIPLY" AND CLEAR PARTIAL RESULT
LODAD2, TAD TEMP1
JMS I (MULT10 / MULTIPLY TEMPORARY BY 10
DCA TEMP1
JMS I [FEBYTI
MQA
AND [37 / CLEAN OUT POTENTIAL SIGN-BIT
TAD [-21
SPA
CLA / TURN BLANKS (AMONG OTHERS) TO ZEROS
TAD TEMP1
DCA TEMP1 / ADD INTO PARTIAL RESULT
ISZ OPLEN1
JMP LODAD2 / LOOP ON ALL USEFUL DIGITS
MQA
RAL
BSW / PUT SIGN IN LOW-ORDER BIT
LDASSG, RAR
CLA / PUT SIGN INTO LINK
TAD TEMP1
SZL
CIA / NEGATE ANSWER IF NEED BE
DCA I RBASE2 / STORE IN PROPER REGISTER
JMP I [RNI
EJECT
/ "XMITBX" - MOVE AN X-REGISTER TO A B-REGISTER
XMITBX, TAD [BREG-AREG
/ "XMITAX" - MOVE AN X-REGISTER TO AN A-REGISTER
XMITAX, TAD [AREG
TAD R1
DCA RBASE2 / SET BASE OF RESULT-REGISTER
TAD R2
JMS I [XRSET / SET BASE OF SOURCE-REGISTER
TAD RBASE1
TAD (20
DCA RPNT1 / SET MOVE POINTER
TAD (-20
DCA CNT
JMP .+3 / AVOID INITIAL MULTIPLY
XMABX1, TAD TEMP1
JMS I (MULT10 / MULTIPLY TEMP1 BY 10
DCA TEMP1
TAD I RPNT1
TAD TEMP1
DCA TEMP1 / ADD IN NEW BYTE
STA
TAD RPNT1
DCA RPNT1 / FIX UP POINTER
ISZ CNT
JMP XMABX1
TAD I RBASE1 / X-REGISTER SIGN
JMP LDASSG / GO SET RESULT SIGN
/ "CLEAR" - REPLICATE A(R2) THROUGHOUT A BYTE-STRING
CLEAR, JMS I [ONEAD / EVALUATE A STRING ADDRESS
JMS I [MEFAD / MOVE TO "MA"
TAD R2
TAD (TAD AREG
DCA .+1
HLT / GET A-REGISTER
AND [77 / TRIM TO SIX-BITS
MQL / REPLICATING BYTE
JMS I [STBYTI
ISZ OPLEN1
JMP .-2 / REPLICATE BYTE
JMP I [RNI
EJECT
/ "XCRLF" - ISSUE "CR" THEN "LF" ON PROPER DEVICE
XCRLF, 0
TAD (215
DCA TEMP1
JMS I (XOCHR / OUTPUT "CR"
TAD (212
DCA TEMP1
JMS I (XOCHR / OUTPUT "LF"
JMS I (OUTCTZ / GO SEE IF "TTY" OR "LPT"
JMP I XCRLF
/ "NEGAA" - TRANSMIT COMPLEMENT OF A-REGISTER TO ANOTHER
NEGAA, JMS I (A2SET / SET POINTERS
TAD I RBASE2
CIA
DCA I RBASE1 / MOVE THE COMPLEMENT
JMP I [RNI
/ "LDCL3" - DECIDE WHICH ERROR "OPEN" WAS GIVING
LDCL3, TAD R1
SNA CLA
JMP I (NOSYSF / "SYS" - OPEN, BUT NO NAME LEFT
JMP I (BADSDV / "SYS" - OPEN, SPECIFIED NON-EXISTENT DEVICE
PAGE
/ "XMITXA" - TRANSMIT AN A-REGISTER TO AN X-REGISTER
XMITXA, TAD R1
JMS I [XRSET / POINT AT PROPER X-REGISTER
STA
TAD XRLEN
DCA CNT / CLEAR-COUNTER
JMS I (XASTBD
TAD SGN1
DCA I RBASE1 / SET RESULT SIGN
CLL CLA IAC RTL / 4
TAD RBASE1
DCA RPNT1 / PLACE FOR FIRST RESULT-BYTE
ISZ RBASE1
DCA I RBASE1
ISZ CNT
JMP .-3 / CLEAR RESULT-REGISTER
CLL CLA CMA RTL / -3
DCA CNT / MOVE-COUNTER
JMS DIG10 / GET NEXT CONVERTED DIGIT
DCA I RPNT1 / STORE IT
STA
TAD RPNT1
DCA RPNT1 / UPDATE POINTER
ISZ CNT
JMP .-6
TAD TEMP1
DCA I RPNT1 / LAST DIGIT
JMP I [RNI
/ "DIG10" - RETURN NEXT DIGIT OF BINARY TO DECIMAL CONVERSION
/ NUMBER TO BE CONVERTED IS IN "TEMP1"
/ "TEMP2" POINTS TO PROPER SLOT IN POWER-OF-TEN TABLE
/ "TEMP3" AND AC CONTAIN RESULT ON EXIT
DIG10, 0
DCA TEMP3 / CLEAR CURRENT RESULT
TAD I TEMP2
CLL
TAD TEMP1
DCA TEMP1 / SUBTRACT OFF CURRENT POWER-OF-TEN
SNL / HAVE WE OVERDRAWN?
JMP .+3 / YES
ISZ TEMP3 / NO, BUMP COUNT...
JMP DIG10+2 / ...AND TRY SOME MORE
TAD I TEMP2
CIA
TAD TEMP1
DCA TEMP1 / REPAIR DAMAGE
ISZ TEMP2 / SET UP NEXT SLOT IN TEN-TABLE
TAD TEMP3 / EXIT WITH RESULT IN AC
JMP I DIG10
EJECT
/ "STOAD" - STORE AN A-REGISTER IN A DECIMAL VARIABLE
/ ANSWER IS STORED RIGHT-JUSTIFIED WITH ZERO-FILL
/ TRUNCATION (IF ANY) OCCURS ON THE RIGHT
STOAD, JMS I [ONEAD
TAD (-4
DCA OPLEN2
JMS I [MVSU / GO SET COUNTERS
TAD TEMP1
SMA CLA / NEED WE ZERO-FILL?
JMP .+6 / NO
TAD [21
MQL
JMS I [STOP1I
ISZ TEMP1
JMP .-2 / DO THE ZERO-FILL
JMS I (XASTBD / SET BIN-TO-DEC STOUGH
TAD SGN1
BSW
CLL RAR
DCA SGN1
CLL CLA IAC RTL /4
TAD CNT
TAD TEMP2
DCA TEMP2 / POINT TO PROPER POWER-OF-TEN
ISZ CNT
SKP
JMP STOAD2
STOAD1, JMS DIG10 / GET NEXT DECIMAL BYTE
TAD [21
MQL
JMS I [STOP1I
ISZ CNT
JMP STOAD1
STOAD2, TAD TEMP1
TAD [21
TAD SGN1
MQL
JMS I [STOP1I
JMP I [RNI
EJECT
/ "BINOUT" - PERFORM BINARY (OR LAST) WRITES (OR RITES)
BINOUT, CLL CLA / CAN GET HERE WITH DIRTY-OLD AC
JMS I (BINCHK / INSURE VALID FILE FOR BINARY USAGE
TAD CURCTL
AND [200
SNA CLA / DO WE WANT BLANK TRIM?
JMP .+3 / MAYBE WHITE SIDEWALLS?
JMS I (DBLNK / PULL TRAILING BLANKS
STA / NULL LINE, USE COUNT OF ONE
/ NOTE: IF WE GET HERE OPLEN1 IS 0
TAD OPLEN1
CLL CML RAR / GET WORD COUNT
DCA OPLEN1
RAR
DCA DIG10 / SAVE ODD-BYTE COUNT IN NITH PLATH
TAD OPLEN1
JMS I (OBINW / OUTPUT WORD-LENGTH
JMS I [FIXAD / SET UP ADDRESS
JMS I (FFWORD / WASTED WORD
CLL CLA / -AC- IS DIRTY
BINOLP, JMS I (FFWORD / GET A WORD
ISZ OPLEN1 / LAST ONE?
SKP / NO
JMP .+3 / YES, GO TEST FOR ODD LENGTH
JMS I (OBINW / OUTPUT THIS DATUM
JMP BINOLP / GOUM TRYUM SUMUM MOREUM (UGH!!)
MQL
TAD DIG10 / RECOVER ODD-BYTE FLAG
CLL RAL
MQA
SNL / IS THIS WORD FULL OF REAL DATA?
JMP .+3 / USER CLAIMS SO
/ HOWEVER, I SUSPECT IT IS FULL OF REAL CRAP!
AND [7700
IAC / SET LAST BYTE TO BLANK
JMS I (OBINW / OUTPUT LAST WORD
JMP I [IOWRAP
EJECT
/ "CLRALL" - 'LODC' WITH ALL-BLANK SOURCE
CLRALL, DCA I RBASE1
ISZ RBASE1
ISZ OPLEN1
JMP CLRALL / CLEAR MOST OF TARGET REGISTER
DCA I RBASE1 / LENGTH OMITS SIGN-BYTE
JMP I [RNI
PAGE
/ "LODBI" - LOAD B-REGISTER IMMEDIATE
LODBI, TAD [BREG-AREG
/ "LODAI" - LOAD A-REGISTER IMMEDIATE
/ THE SECOND WORD OF THE INSTRUCTION IS ENTERED INTO THE SPECIFIED
/ A-REGISTER. NOTE: THIS INSTRUCTION IS INDEXABLE.
/ (NOT(!!) SUBSCRIPTABLE)
LODAI, JMS IMMAD / CALCULATE EFFECTIVE OPERAND
MQA
DCA I RBASE2 / STORE RESULT
JMP I [RNI
/ "IMMAD" - ADD INDEX TO WORD AT P-COUNTER, LEAVE RESULT IN MQ
IMMAD, 0
TAD [AREG
TAD R2
DCA RBASE2 / POINT TO PROPER REGISTER
JMS I [INSFTC / GET NEXT WORD OF INSTRUCTION
TAD R1
SNA / IS INDEXING WANTED?
JMP I IMMAD / NO, EXIT
TAD [AREG
DCA RBASE1 / SET POINTER TO PROPER INDEX
MQA
TAD I RBASE1 / ADD IN THE INDEX
MQL
JMP I IMMAD
/ "STOAR" - STORE GIVEN A-REGISTER AT P-COUNTER PLUS SECOND WORD
/ OF INSTRUCTION (WITH INDEXING, IF ANY).
/ NOTE: ADDITION IS AFTER SECOND WORD IS FETCHED, I.E., "P"
/ POINTS TO THE NEXT INSTRUCTION
STOAR, JMS IMMAD / DO IMMEDIATE ADDRESS CALCULATION
JMS RELAD / CALCULATE PROPER EFFECTIVE ADDRESS
TAD I RBASE2 / FETCH DATUM
MQL
JMS I [STWORD / GO STORE IT
JMP I [RNI
EJECT
/ "RELAD" - CALCULATE P-RELATIVE ADDRESS
RELAD, 0
TAD I [INSFTC+1
RTR
RAR
AND [7 / LINK IS CLEAR (INSFTC+1) = 62X1
DCA MA
MQA
SPA
CML / SUPPRESS CARRY IF NEGATIVE OFFSET
TAD PCTR
SZL
ISZ MA
CLL RAL
DCA MA+1
TAD MA
RAL
DCA MA
JMP I RELAD
/ "JUMPR" - JUMP P-RELATIVE
/ IF INDEXED, EFFECTIVE ADDRESS IS OF BASE OF JUMP TABLE
JUMPR, JMS IMMAD / GO DO PARTIAL ADDRESS DECODE
TAD R2
AND CONDCD
SNA CLA
JMP I [RNI / JUMP CONDITION NOT MET
JMS RELAD / FINISH ADDRESS DECODE
TAD R1
SNA CLA / ARE WE INDEXING
JMP .+3 / NO
JMS I [FEWORD / GET JUMP TABLE ENTRY
JMS RELAD / RE-DECODE IT
TAD MA
DCA EFFAD1
TAD MA+1
DCA EFFAD1+1
JMP I [SETPCT
EJECT
/ GTFLEN - RETURN LENGTH OF FILE
/ FILE I. F. N. IS POINTED TO BY DESCRIPTOR
/ LENGTH IS RETURNED IN NEXT WORD
GTFLEN, JMS I [FEWRDI / GET I. F. N.
MQA
JMS I [IOINIT / GET PARAMETER BLOCK
TAD FSTBLK
CIA
TAD MAXBLK / CALCULATE LENGTH
MQL
JMS I [STWORD / STORE IT
JMP I [RNI
/ "RBINW" - READ BINARY WORD FROM BUFFER
RBINW, 0
TAD BUFLEN
CLL CIA
TAD CURBPT
SZL CLA / IS THERE DATA IN THE BUFFER?
JMS I (BUFFIL / NO, GO REFILL IT
TAD CURBPT
TAD BUFLOC
DCA TEMP2 / FORM BUFFER POINTER
CDF IOFLD
TAD I TEMP2 / GET A DATUM FROM BUFFER
ISZ CURBPT / UPDATE BUFFER-OFFSET
CDF BSEFLD
JMP I RBINW
/ "TOUTT" - TYPE CHARACTER PASSED IN -AC-
TOUTT, 0
TLS
TSF
JMP .-1
CLL CLA
JMP I TOUTT
EJECT
/ "CNSU" - SET UP FOR MVCN AND STOC
CNSU, 0
DCA SGN1 / SAVE SIGN
TAD SGN1
SZA CLA
STA
TAD OPLEN2
DCA OPLEN2 / CORRECT SOURCE LENGTH
CLA IAC / BLANK-FILL
JMS I (DMVSU / SET TO MOVE CHARACTERS
TAD SGN1
SNA CLA / IS THE SOURCE NEGATIVE?
JMP I CNSU / NO
TAD (16 / "-"
MQL
JMS I [STOP1I / OUTPUT THE "-"
ISZ CNT / COMPENSATE FOR IT
JMP I CNSU / EXIT
JMP I [RNI / MIGHTY SHORT SUMMER IN THESE HERE PARTS!!!
/ "X2SET" - SET POINTERS TO BOTH X-REGISTERS
X2SET, 0
TAD R2
JMS I [XRSET / SET POINTER-2
TAD RBASE1
DCA RBASE2 / MOVE TO CORRECT SLOT
TAD R1
JMS I [XRSET / SET POINTER-1
TAD XRLEN
DCA CNT / SET OPERAND LENGTH
JMP I X2SET
PAGE
/ "XMIT" - TRANSMIT DATA TO/FROM REAL WORLD
/ "XMIT" MUST TRANSLATE FROM "MINIBOL" INTERNAL 6-BIT
/ TO OS/8 ASCII AND VICE VERSA
/ IFN IS PASSED IN A(7)
XMITIT, JMS I [MEFAD
CLL CLA CML RTL / 2
TAD OPLEN1
DCA OPLEN1 / ACCOUNT FOR TWO WASTED BYTES
SZL
JMP I (BIOCNT / A ZERO LENGTH BUFFER, WHAT WON'T THEY THINK OF NEXT??
JMS I [FEWRDI / COMPENSATE FOR WASTED WORD
TAD CURCTL
RAL
SPA / BINARY OR BCD FILE?
JMP I (XMTBIN / BINARY
SZL / INPUT OR OUTPUT?
JMP I (XMTIN / INWARDS!
RAL
RTL
SMA CLA / DO WE WISH TO SUPPRESS TRAILING BLANKS?
JMP XMTOLP / NO
JMS DBLNK / GO DEBLANK LINE
JMP XODONE / NULL LINE
XMTOLP, JMS I [FEBYTI / GET NEXT BYTE
MQA
SNA
JMP XOINC / DROP NULL-BYTES (THUD!!)
TAD (-75
SNA / ODD INTERNAL FOR TAB?
TAD (211-75-237 / SET TO PRODUCE TRUE-TAB
TAD (237+75 / RE-BIAS ACCORDING TO THE ASCII
DCA TEMP1 / SET IN ARGUMENT SLOT FOR OUTPUTTING
JMS XOCHR / OUTPUT THE CHARACTER
XOINC, ISZ OPLEN1
JMP XMTOLP
XODONE, TAD NOCR
SNA CLA / DO WE WANT "CRLF"?
JMS I (XCRLF / OUTPUT THE CRLF
JMS I (OUTCTZ / GO SEE IF MAYBE "TTY" OR "LPT"
JMP I [IOWRAP / GO FINISH WORK
EJECT
/ "XOCHR" - PUTS (TEMP1) IN OS/8 FILE-BUFFER
XOCHR, 0
KSF / IS THERE A KEY STUCK?
JMP XONCC / NO
KRS
AND (177 / CLEAR PARITY BIT
TAD (-3
SNA CLA / IS THE CHARACTER A "CTL-C"?
JMP I (7600 / YES, GO DIE
XONCC, TAD CURBPT
TAD BUFLOC
DCA TEMP2 / POINT TO NEXT SLOT IN BUFFER
JMP I CURCHR / GO DO UNPACK
XOJMP, JMP XO1
JMP XO2
JMP XO3
XO1, TAD BUFLEN
CLL CIA
TAD CURBPT
SZL CLA / IS BUFFER OVERLY FULL?
JMS I [DMPBUF / YES, GO DUMP IT
XOCOUT, TAD TEMP1
ISZ CURCHR / SET UP NEXT CHARACTER
CDF IOFLD
DCA I TEMP2
CDF BSEFLD
JMP I XOCHR
XO2, ISZ TEMP2 / WANT TO STORE INTO SECOND WORD OF PAIR
JMP XOCOUT
XO3, TAD (XOJMP
DCA CURCHR / RESET FOR FIRST BYTE
CDF IOFLD
TAD TEMP1
AND (360
CLL RTL
RTL / GET UPPER 4-BITS OF THIRD WORD
TAD I TEMP2 / MERGE INTO FIRST WORD
DCA I TEMP2 / RE-STORE RESULT
ISZ TEMP2
TAD TEMP1
AND [17
BSW
CLL RTL / GET LOW-ORDER 4 BITS OF THIRD BYTE
TAD I TEMP2 / MERGE INTO SECOND WORD
ISZ CURBPT
ISZ CURBPT / UPDATE BUFFER POINTER
JMP XOCOUT+3 / GO STORE RESULT
EJECT
/ "DBLNK" - TRIM OFF TRAILING BLANKS, TRUE LINE LENGTH IS
/ IS LEFT IN "OPLEN1". EXIT IS TO 0(4) IF LINE IS TOTALLY BLANK
/ EXIT IS TO 1(4) IF SOME NON-BLANK.
DBLNK, 0
TAD OPLEN1
CLL CIA
TAD MA+1
DCA MA+1
SZL
ISZ MA / LWA+1 OF STRING
DBLNLP, CLL STA
TAD MA+1
DCA MA+1
SNL
STA
TAD MA
DCA MA / MOVE POINTER BACK A NOTCH
JMS I [FEBYTE
MQA
TAD [-1
SZA CLA / HAVE WE FOUND THAT ELUSIVE NON-BLANK?
JMP .+4 / YEP!
ISZ OPLEN1
JMP DBLNLP
JMP I DBLNK / NULL LINE
JMS I [MEFAD / RESET FETCH POINTER TO FRONT OF BUFFER
JMS I [FEWRDI / ACCOUNT FOR WASTED WORD
ISZ DBLNK / FIX UP EXIT
JMP I DBLNK
NOCR, 0 / FLAG GOVERNING OUTPUT OF "CRLF" AT END OF OPERATION
PAGE
/ "XMTIN" - COME HERE FOR BCD READS
XMTIN, RTL
SPA CLA / HAVE WE SEEN AN E.O.I. ON THIS FILE?
JMP I (ARPEOI / YUP!
TAD CURCTL
AND (40
SNA CLA / IS THIS THE "TTY"?
JMP XMTILP / NO
JMS I (BUFFIL / YES, GO REFILL BUFFER EACH AND EVERY TIME
TAD (XIJMP
DCA CURCHR / RESET INPUT CHARACTER POINTER
XMTILP, CLL CLA
JMS XICHR / GO GET NEXT CHARACTER FROM OS/8 BUFFER
MQA
TAD (-337
SMA
JMP XMTILP / TOO BIG TO BE GOOD
TAD (-334+337
SNA
JMP XMTILP / "\" IS LOST
XMTIOK, TAD (-237+334 / NOTE: THIS IS "75" (NEEDED FOR BELOW)
SPA SNA
JMP XMI1 / CHARACTER TOO SMALL TO BE PRINTABLE
MQL
XMITC, TAD NOSTOR
SPA CLA
JMP XMTILP / USER BUFFER ALREADY FULL?
JMS I [STBYTI
ISZ CNT / BUMP BYTE-COUNT
ISZ OPLEN1 / BUMP AVAILABLE BYTE COUNT
JMP XMTILP / GO BACK IF MORE ROOM
STA
DCA NOSTOR / USER BUFFER IS FULL
JMP XMTILP / GO FLUSH REST OF RECORD
EJECT
XMI1, CLA MQA
TAD (-215
SNA / IS THIS CARRIAGE-RETURN?
JMP I (XIEOL / YES
IAC
SZA / FORM-FEED?
JMP XINTFF / NO
TAD CURCHR
DCA TEMP3 / SAVE CHARACTER POINTER
TAD (FFFIN
DCA CURCHR
JMP XMITC-1 / STORE ZERO FOR F-F
XINTFF, TAD (-211+214
SNA / HOW ABOUT A TAB?
JMP XMTIOK / YES, GO OUTPUT A "75"
TAD [-232+211
SZA CLA / MAYBE A CTL-Z?
JMP XMTILP / NO, IGNORE IT, WHATEVER IT MAY BE.
SETEOF, TAD CURCTL
TAD [400
DCA CURCTL / SET E.O.I. BIT
TAD DN2
SNA
JMP I (ARPEOI / NO ERROR ADDRESS
MQL
JMS I [EFFAD / EVALUATE ERROR-ADDRESS
JMS I [WRAPIO
DCA IOERR
JMP I [SETPCT
/ FINISH FORM-FEED PROCESSING
FFFIN, TAD TEMP3
DCA CURCHR / RESTORE CHARACTER POINTER
JMP I (XIEOL / GO PHONEY UP A "CRLF"
EJECT
/ "XICHR" - FETCH NEXT CHARACTER FROM OS/8 BUFFER
XICHR, 0
TAD CURBPT
TAD BUFLOC
DCA TEMP2 / SET POINTER TO FIRST WORD OF PAIR
JMP I CURCHR / DISPATCH TO RIGHT PLACE
XIJMP, JMP XI1
JMP XI2
JMP XI3
XI1, TAD BUFLEN
CLL CIA
TAD CURBPT
SZL CLA / IS THERE DATA IN THE BUFFER?
JMS I (BUFFIL / NO, GO FILL IT
XIOUT, CDF IOFLD
ISZ CURCHR / SET UP NEXT BYTE
TAD I TEMP2 / GET WORD WITH BYTE
AND (177 / CLEAN OUT POTENTIAL JUNQUE
TAD [200 / INSURE PARITY BIT IS ON
CDF BSEFLD
MQL
JMP I XICHR
XI2, ISZ TEMP2 / LOOK AT SECOND WORD OF PAIR
JMP XIOUT
XI3, TAD (XIJMP
DCA CURCHR / RESET TO FETCH FIRST BYTE NEXT
CDF IOFLD
TAD I TEMP2
CLL RTR
RTR
AND (360 / GET HIGH-ORDER FOUR BITS
MQL
ISZ TEMP2
TAD I TEMP2
CLL RTR
BSW
AND [17 / GET LOW-ORDER FOUR BITS
MQA / MERGE IN THE HIGH-ORDER
ISZ CURBPT
ISZ CURBPT / DONE WITH CURRENT WORD-PAIR
JMP XIOUT+3 / GO PASS BACK RESULT
EJECT
/ "SYSJTB" - TRANSFER-VECTOR FOR "SYSTEM"
SYSJTB, SWITCH / 0
GTFLEN / 1
GETERN / 2
GETSB / 3
BLOCKI / 4
BLOCKO / 5
GETCHN / 6
NEWCHN / 7
PAGE
XMTBIN, SNL / READ OR WRITE?
JMP I (BINOUT / WRITE
/ COME HERE FOR BINARY-READS
RTL
SPA CLA
JMP I (ARPEOI / ALREADY SAW E. O. I.
BININ1, DCA BININF / SET/DISABLE RECORD LENGTH CHECK
JMS I (BINCHK / INSURE BINARY FILE ON FILE-STRUCTURED DEVICE
JMS I [FIXAD / ONLY PLACE WE REALLY WANT FRONT OF BUFFER
JMS I (RBINW / GET WORD-COUNT FROM FILE
SNA
JMP I (SETEOF / ZERO WORD-COUNT IS E. O. F.
SMA / WORD COUNT IS LIMITED TO 2047 (B. F. D.)
JMP I (WLR / OTHERWISE ALL HELL BREAKS LOSE!
DCA OPLEN2
TAD OPLEN1
CLL CML RAR
DCA OPLEN1 / CONVERT BUFFER-LENGTH TO WORD-COUNT
TAD BININF
SNA CLA / DO WE WISH TO TEST RECORD LENGTH ? ( RANDOM-READ)
JMP NORCHK / NOT PARTICULARLY
TAD OPLEN1
CIA
TAD OPLEN2
SZA CLA / WAS LENGTH AS EXPECTED?
JMP I (WLR / NO?!!?
NORCHK, JMS I [MVSU / GET COUNT SET
TAD OPLEN2
JMS I (FSWORD / STORE TRUE RECORD-LENGTH IN BUFFER
JMS I (RBINW / GET A WORD
JMS I (FSWORD / INPUT THE RECORD
ISZ CNT
JMP .-3
EJECT
TAD TEMP1
SMA CLA / DO WE NEED TO FILL BUFFER?
JMP FLSREC / RECORD IS LONGER THAN BUFFER, GO FLUSH REMNANT
TAD CURCTL
AND [200
SZA CLA / NO-FILL BUFFER?
JMP I [IOWRAP
TAD (0101 / BLANKITY-BLANK
JMS I (FSWORD
ISZ TEMP1
JMP .-3
JMP I [IOWRAP
FLSREC, TAD TEMP1
SNA
JMP I [IOWRAP / THE BUFFER LENGTH MATCHES THE RECORD LENGTH
CIA
DCA TEMP1 / NUMBER OF EXCESS WORDS
JMS I (RBINW
CLL CLA
ISZ TEMP1
JMP .-3 / SWALLOW THE EXCESS DATA
JMP I [IOWRAP
RANAD, 0
JMS I [ONEAD / FIND BUFFER ADDRESS
TAD EFFAD1
DCA REFAD
TAD EFFAD1+1
DCA REFAD+1 / SAVE BUFFER ADDRESS
TAD OPLEN1
DCA RBFLN / SAVE BUFFER CHARACTER-LENGTH
CLL CLA CML RTL / 2
DCA EFFAD1
TAD (RANCD^2
DCA EFFAD1+1 / SET TO RUN PHONEY CODE
TAD OPLEN1
CLL CML RAR / WORD-LENGTH OF RECORD (INCLUDING HEADER-WORD)
CIA / LENGTH IS NEGATIVE
DCA AREG / SET BUFFER-LENGTH
DCA R1 / THIS IS NOT A "COMPUTED-CALL"
STA
DCA MSTPOP / IF GET ERROR, MUST POP CALL-STACK
JMP I (PUSHJ1 / GO START PHONEY CODE
EJECT
/ NOTE: THE PHONEY CODE EXITS TO "RANAD1", WHICH PROCEEDS
/ WITH THE I/O. "IOWRAP" EXITS TO "RNI" WHICH EXECUTES THE
/ "POPJ" IN THE PHONEY CODE, THUS (FINALLY) RETURNING TO THE
/ REAL PHONEY CODE THAT THE DUMMY GENERATED.
/ FOLLOWING WHICH: BALL (A) FALLS, CAT (B) CHASES IT
/ SCARING MOUSE (C), WHICH.......
/ R. GOLDBERG (C. 1910)
RANAD1, TAD FSTBLK
TAD BREG
DCA BREG / GENERATE ABSOLUTE BLOCK NUMBER
TAD CURBPT
SPA CLA
JMP DORD / BUFFER IS EMPTY, MUST DO PHYSICAL I/O
TAD CURBLK
CIA
TAD BREG
SNA CLA / IS NEW RECORD IN THIS BLOCK?
JMP BUFOK / YES, NO NEED TO EXECUTE FOR REALLY I/O
TAD CURCTL
SMA CLA / HAVE WE WRITTEN INTO THIS BUFFER?
JMS I (BUFDMP / YES, GO OUTPUT IT
NOP / EXTRA EXIT
DORD, TAD BREG
DCA CURBLK / RESET BLOCK NUMBER
DCA BUFINC / PREVENT "BUFFIL" FROM MUCKIN' ABOUT
JMS I (BUFFIL / GO READ PROPER RECORD
BUFOK, TAD BREG+1
AND (377
DCA CURBPT / PROPER WORD IN BUFFER
TAD REFAD
DCA EFFAD1
TAD REFAD+1
DCA EFFAD1+1 / RESTORE BUFFER ADDRESS
CLL CLA CML RTL / 2
TAD RBFLN
DCA OPLEN1 / RESTORE PROPER BUFFER LENGTH
DCA DN2 / NO ERROR-ADDRESS FOR R/W
TAD CURCTL
AND (7377
DCA CURCTL / TURN OFF EOI-BIT
JMP I RANAD / ONWARDS!!
EJECT
BININF, 0
REFAD, ZBLOCK 2
RBFLN, 0
PAGE
/ "BUFDMP" - EMPTY CURRENT BUFFER TO OS/8 FILE
BUFDMP, 0
TAD CURBPT
SPA SNA CLA / WAS BUFFER EVER WRITTEN INTO?
JMP BDOUT / NO, THEREFORE, DO NOT WRITE IT
JMS I (DADCHK / IS FILE OVERLY FULL?
TAD CURBLK
DCA BD1+1
TAD BUFLOC
DCA BD1 / SET PARAMETERS FOR I/O DIRVER CALL
JMS I (CALDRV / GO INSURE DRIVER IS IN CORE, THEN USE IT
BLKINC^200 IOFLD 4000
BD1, 0
0
JMP I (WRTERR / GOT A NO-NO
ISZ BUFDMP / DID WRITE SOMETHING. FIX UP EXIT
BDOUT, TAD BUFLOC
DCA TEMP2 / RESET STORING POINTER
DCA CURBPT / RESET STORING OFFSET
JMP I BUFDMP
EJECT
DMPBUF, 0
JMS BUFDMP / EMPTY CURRENT BUFFER
JMP DMPNWT / WROTE NOTHING
TAD CURCTL
AND (20
SNA CLA / IS THIS "LPT"
JMP .+3 / NO
TAD I (LPTTOF
DCA TOF / SAVE LPT'S TOP-OF-FORM FLAG
CLA IAC BSW / 100
AND CURCTL
SNA CLA / FILE-STRUCTURED DEVICE?
JMP I DMPBUF / NO, GET OUTTA HERE!
TAD (BLKINC
DCA BUFINC / THERE IS DATA IN BUFFER
TAD (BLKINC
TAD CURBLK
DCA CURBLK / UPDATE DISK ADDRESS
DMPIT, TAD MAXDAD
CLL CIA
TAD CURBLK
SNA
JMP .+6 / IF ON LAST SECTOR, DO THE READ
SNL CLA / IS THIS THE NEW E. O. I.?
JMP .+4 / NO, GO READ UP NEXT BUFFER
TAD CURBLK
DCA MAXDAD / RESET E. O. I. POINTER
JMP I DMPBUF
TAD BUFLOC
DCA DB1
TAD CURBLK
DCA DB1+1 / SET I/O PARAMETERS
JMS I (CALDRV / GET DRIVER (IF NEEDED) AND USE IT
BLKINC^200 IOFLD
DB1, 0
0
JMP I (WRTERR
JMP I DMPBUF
DMPNWT, CLA IAC BSW / 100
AND CURCTL
SNA CLA / FILE-STRUCTURED DEVICE?
JMP I DMPBUF / NO, GO AWAY!!
JMP DMPIT / GO TEST FOR PRE-READ
EJECT
/ "BUFFIL" - REFILL CURRENT BUFFER FROM OS/8 DEVICE
BUFFIL, 0
TAD CURBLK
TAD BUFINC
DCA CURBLK / FIX UP BLOCK NUMBER
TAD (BLKINC
DCA BUFINC / BUFFER WILL SOON BE FULL
JMS I (DADCHK / IS ADDRESS WITHIN FILE?
TAD CURBLK
DCA BF1+1
TAD BUFLOC
DCA BF1 / SET UP ARGUMENTS FOR I/O DRIVER
JMS I (CALDRV / FIND AND CALL SAID DRIVER
BLKINC^200 IOFLD
BF1, 0
0
JMP READOI / DRIVER WAS UPSET
READOK, DCA CURBPT / RESET POINTER TO FRONT OF BUFFER
TAD BUFLOC
DCA TEMP2 / RESET FETCH POINTER
JMP I BUFFIL
READOI, SPA CLA
JMP I (RDERR / GOT "HARD" ERROR
JMP READOK / GOT "SOFT" ERROR, IGNORE IT
/ "CNTCHR" - COUNT VALID NUMERIC DIGITS
CNTCHR, 0
DCA SGN1 / CLEAR RESULT SIGN
DCA CNT
STA
TAD OPLEN2
DCA OPLEN2 / NEEDS TO BE ONE LESS THAN TRUE VALUE
JMS I (ALPDIG / GO GET A CHARACTER
JMP .+3 / RANNED OUT OF PIDDIES
ISZ CNT / BUMP COUNTER
JMP .-3
TAD CNT
CIA
DCA OPLEN2 / PUT NEGATED COUNT WHERE IT MIGHT DO SOME GOOD
JMP I CNTCHR
EJECT
/ "GETSB" - RETURN STARTING BLOCK OF A FILE
/ SYSTEM(3,B): B IS 2B1
/ B(1)=I. F. N. (SET BY USER BEFORE CALLING)
/ B(2)=STARTING BLOCK (RETURNED BY CALL)
GETSB, JMS I [FEWRDI / GET I. F. N.
MQA
JMS I [IOINIT / SET UP PARAMETER BLOCK
TAD FSTBLK
MQL
JMS I [STWORD / STORE STARTING-BLOCK
JMP I [RNI
/ "TCRLF" - SEND "CRLF" TO TTY
TCRLF, 0
TAD (215
JMS I [TOUTT
TAD (212
JMS I [TOUTT
JMP I TCRLF
TOF, 1 / PRINTER TOP-OF-FORM FLAG
/ INITIALIZED TO TOP-OF-FORM
PAGE
/ "SHLAA" - SHIFT A(R1) LEFT A(R2) PLACES
/ SHIFT IS END-OFF WITH ZERO-FILL
SHLAA, CLL CLA CMA RAL / -2
/ "SHRAA" - SHIFT A(R1) RIGHT A(R2) PLACES
/ SHIFT IS END-OFF WITH SIGN-EXTENSION
SHRAA, TAD (RSCD
DCA SHFTPT
JMS I (A2SET
TAD I RBASE2
SNA
JMP I [RNI / ZERO COUNT IS A NO-OP
CIA
DCA CNT
TAD I RBASE1
SHFTLP, JMP I SHFTPT
ISZ CNT
JMP .-2
DCA I RBASE1
JMP I [RNI
LSCD, CLL RAL
JMP SHFTLP+1
IFNZRO .-LSCD-2 <LSRSER, BARF>
RSCD, CLL
SPA
CML
RAR
JMP SHFTLP+1
EJECT
/ "ANDAA" - AND TWO A-REGISTERS
ANDAA, JMS I (A2SET / SET POINTERS TO A-REGISTERS
TAD I RBASE1
AND I RBASE2 / AND TOGETHER
DCA I RBASE1 / STORE RESULT
JMP I [RNI
/ "NOTAA" - INVERT AN A-REGISTER
NOTAA, JMS I (A2SET / SET POINTERS TO A-REGISTERS
TAD I RBASE2
CMA
DCA I RBASE1 / STORE RESULT
JMP I [RNI
SHFTPT, 0
EJECT
/ "LODXI" - LOAD X-REGISTER IMMEDIATE
LODXI, TAD R2
JMS I [XRSET / SET REGISTER POINTER
JMS I [INSFTC / GET SECOND WORD OF INSTRUCTION
MQA
AND (40
SZA CLA
IAC / SIGN MUST BE 0 OR 1
DCA I RBASE1
ISZ RBASE1
MQA
AND [17
TAD [-1
DCA I RBASE1 / LOW-ORDER BYTE
MQA
BSW
AND [17
TAD [-1
ISZ RBASE1
DCA I RBASE1 / NEXT-BYTE
CLL CLA CML RTL / 2
TAD XRLEN
DCA CNT / REMAINING BYTE-COUNT
ISZ RBASE1
DCA I RBASE1 / CLEAR REST OF REGISTER
ISZ CNT
JMP .-3
JMP I [RNI
EJECT
/ "XIEOL" - FINISH INPUTTING A BUFFER
XIEOL, TAD I (NOSTOR
SZA CLA / IS BUFFER ALREADY FULL?
JMP STCNT / YES, GO STORE THE COUNT
TAD CURCTL
AND [200
SNA CLA / IS "NO-FILL" BIT ON?
JMP DOFL / NO, GO DO BLANK FILL
TAD CNT
SZA CLA / IS COUNT ZERO?
JMP .+3
CLL CLA CMA RAL / -2
JMP DOFL-1 / NO NULL-LINES, CLEAR FIRST TWO BYTES
CLA IAC
AND MA+1
SNA CLA / IS NEXT AVAILABLE ADDRESS ODD?
JMP STCNT / NO, GO SET TOTAL COUNT
STA
DCA OPLEN1 / FORCE CLEAR THE ODD-BYTE IN WORD
/ LAST BYTE IN A WORD MUST BE BLANKED IF NOT ALREADY VALID
DOFL, CLA IAC
MQL / MINIBOL BLANK
JMS I [STBYTI
ISZ OPLEN1
JMP .-2 / FILL REST OF BUFFER WITH BLANKS
STCNT, TAD CNT
IAC / BUMP BEFORE TRUNCATING
CLL RAR / ACTUAL WORD COUNT OF RECORD
SNA
IAC / IF WORD COUNT IS ZERO, ASSUME A ONE
CIA / WANT COUNT NEGATED
MQL
JMS I [MEFAD / RESTORE POINTER TO FRONT OF BUFFER
JMS I [STWORD / STORE THE COUNT-WORD
/ FALL INTO "IOWRAP"
EJECT
/ "IOWRAP" - COMMON CLEAN-UP ROUTINE FOR I/O CODE.
IOWRAP, JMS WRAPIO
DCA IOERR
JMP I [RNI
WRAPIO, 0
TAD (CURCTL-1
DCA XR1
TAD I FNTPNT
DCA XR2
TAD (-XBUFWD
DCA CNT
TAD I XR1
CDF IOFLD
DCA I XR2
CDF BSEFLD
ISZ CNT
JMP .-5 / MOVE FILE PARAMETERS BACK INTO PLACE
DCA I (NOCR
DCA NOSTOR
DCA MSTPOP / CLEAR FLAGS
JMP I WRAPIO
PAGE
/ ERROR-LABELS. TO ADD NEW ERROR-CODES, PUT NEW "ISZ'S" AT FRONT
/ OF LIST, TOP ERROR IS HIGHEST NUMBER
ZERSUB, ISZ ERRNUM / ZERO SUBSCRIPT (34)
BADSDV, ISZ ERRNUM / DEVICE SPECIFIED ON EXECUTE LINE IS NON-EXISTANT (33)
NOLOD, ISZ ERRNUM / NO LOAD FILE (32)
LODERR, ISZ ERRNUM / BAD LOADER DATA (31)
BADSYS, ISZ ERRNUM / "SYSTEM" FUNCTION IS TOO BIG (30)
BADREC, ISZ ERRNUM / BAD RECORD-NUMBER (27)
WLR, ISZ ERRNUM / WRONG-LENGTH RECORD (26)
BACKSB, ISZ ERRNUM / BACKWARD DOUBLE SUBSCRIPTS (25)
BADBIN, ISZ ERRNUM / READ/WRITE ON NON-BINARY FILE,
/ OR ANY BINARY REF TO NON-FILE-STRUCTURED DEVICE (24)
UNIMOP, ISZ ERRNUM / UNIMPLEMENTED OPCODE (23)
OPENOW, ISZ ERRNUM / "OPEN" CALL ON ALREADY OPEN FILE (22)
NODRV, ISZ ERRNUM / NO DRIVER FOR OPEN CALL (21)
NOSYSF, ISZ ERRNUM / NO MORE FILES IN C-D LIST (20)
NOOF, ISZ ERRNUM / COULD NOT CREATE TENTATIVE FILE (17)
NOCLS, ISZ ERRNUM / COULD NOT CLOSE TENTATIVE FILE (16)
DIVB0, ISZ ERRNUM / TRIED TO DIVIDE BY ZERO (15)
BIOCNT, ISZ ERRNUM / BUFFER TOO SMALL (14)
WRTERR, ISZ ERRNUM / I/O ERROR WHILE WRITING BUFFER (13)
RDERR, ISZ ERRNUM / I/O ERROR WHILE READING BUFFER (12)
BADDAD, ISZ ERRNUM / DISK ADDRESS NOT WITHIN FILE (11)
NOFIL, ISZ ERRNUM / COULD NOT OPEN FILE (10)
NOBUFS, ISZ ERRNUM / RAN OUT OF I/O BUFFERS (7)
NOIOCD, ISZ ERRNUM / I/O OR "FINI" ON UNOPENED FILE (6)
ERROR, ISZ ERRNUM / BAD OPCODE (5)
STKOVR, ISZ ERRNUM / SUBROUTINE-CALL STACK OVERFLEW (4)
STKUND, ISZ ERRNUM / SUBROUTINE-CALL STACK UNDERFLOWED (3)
ALPBAD, ISZ ERRNUM / BAD ALPHA IN ALPHA TO NUMERIC CONVERSION (2)
ARPEOI, ISZ ERRNUM / ATTEMPT TO READ PAST THE END-OF-INFORMATION (1)
EJECT
CLL CLA / -AC- CAN BE DIRTY
TAD MSTPOP
SNA CLA / ARE WE DOWN A CALL-LEVEL?
JMP NOPOP / NO
STA
TAD STKPNT
DCA STKPNT
CDF IOFLD
TAD I STKPNT
DCA PCTR
STA
TAD STKPNT
DCA STKPNT
TAD I STKPNT
CDF BSEFLD
DCA I [INSFTC+1 / RESTORE P-COUNTER, IF DOWN A LEVEL
NOPOP, TAD IOERR
SZA CLA / WAS ERROR DURING I/O?
JMS I [WRAPIO / YES, PARAMETERS MUST BE PUT BACK
DCA IOERR / CLEAR FLAG
TAD ERRNUM
DCA OLDERR / SAVE ERROR-NUMBER
TAD ONERAD
SNA
JMP .+4
MQL
DCA ERRNUM / RE-CLEAR ERROR-NUMBER
JMP I (ERRBRN
JMS I [TCRLF / ERROR-MESSAGE MAY AS WELL START A NEW LINE
JMS EXTOUT
MERRN / "ERROR NUMBER "
TAD ERRNUM
JMS I (OCTOUT
DCA ERRNUM / RE-CLEAR ERROR NUMBER
JMP I (DBG / GO OFF TO DEBUG ROUTINE
EJECT
/ "EXTOUT" - PRINT TEXT STRINGS FROM TRIMMED ASCII
EXTOUT, 0
TAD I EXTOUT / GET STRING ADDRESS
ISZ EXTOUT
CLL RAL
DCA MA+1
RAL
DCA MA / PUT IN "INTERNAL" FORMAT
EXTLOP, JMS I [FEBYTI
MQA
SNA
JMP I EXTOUT / ZERO-BYTE IS END-OF-STRING
TAD (-40
SPA
TAD (100
TAD (240 / RECONSTRUCT REAL ASCII
JMS I [TOUTT
JMP EXTLOP
/ "STWRDI" - STORE WORD THEN INCREMENT "MA"
STWRDI, 0
JMS I [STWORD
CLL CLA CML RTL / 2
TAD MA+1
DCA MA+1
SZL
ISZ MA
JMP I STWRDI
/ "ONERR" - SET ADDRESS FOR "ON ERROR"
ONERR, TAD DN1
DCA ONERAD
JMP I [RNI
EJECT
/ "DATE" - PUT SYSTEM DATE IN A0(MM), A1(DD), AND A2(YY)
DATE, JMS I [MEFAD / SET UP FOR STORING
CDF 10
TAD I (7666 / GET SYSTEM/DATE WORD
DCA TEMP1 / STORE IT IN FIELD-0 TEMP
CDF 0
TAD TEMP1
BSW
RTR
AND [17 / MONTH
DCA AREG
TAD TEMP1
RAR
RTR
AND [37 / DAY
DCA AREG+1
TAD TEMP1
AND [7
TAD (106 / 70(DECIMAL) RE-BIAS YEAR
DCA AREG+2
JMP I [RNI
ERRNUM, 0
ONERAD, 0
OLDERR, 0
PAGE
/ "CHAIN" - LOAD NEXT LINK OF A CHAIN
CHAIN, STA
SKP
/ "RUN" - RUN NEXT LINK OF A CHAIN (DO CONDITIONAL CLEARS)
RUNNER, CLA IAC
DCA CHNFLG
JMS I [SYSDRV / RECOVER LOADER-OVERLAY
0200
DRIVER
SCRBLK+1
HLT
CIF 10
JMS I [USR / MARK NON-RESIDENT DRIVER AS MISSING
13
0 / PRESERVE ANY TENTATIVE FILES
TAD (SUBSTK
DCA STKPNT / FORCABLY CLEAR STACK
DCA I (ONERAD / TURN OFF "ON-ERROR"
JMP I (CHNCD / GO RUN LOADER-OVERLAY
OPEN, TAD KOPNST
DCA TEMP1
TAD WHTOVL
SNA CLA / IS PROPER OVERLAY ALREADY HERE?
JMP I TEMP1 / YES, GO USE IT
JMS I [SYSDRV / NO, GO GET IT
0200
KOPNST, OPNST
SCRBLK+3
HLT
DCA WHTOVL / MARK OPEN(ETC.) OVERLAY AS BEING RESIDENT
JMP I TEMP1
FINI, TAD (FINCD
JMP OPEN+1
CLOSER, TAD (CLSCD
JMP OPEN+1
EJECT
DIVXX, TAD (DXX
DCA TEMP1
TAD WHTOVL
SZA CLA / IS PROPER OVERLAY ALREADY HERE?
JMP I TEMP1 / YES, GO USE IT
JMS I [SYSDRV / NO, GO LOAD IT
0200
KSTE, STE
SCRBLK+2
HLT
STA
DCA WHTOVL / MARK DIVIDE (ETC.) OVERLAY AS RESIDENT
JMP I TEMP1
DIVAA, TAD (DAA
JMP DIVXX+1
STOE, TAD KSTE
JMP DIVXX+1
LSIG, TAD (LSIG+2
JMP DIVXX+1
JMS I (LFTSIG
JMP I (STOCB
JMP I (STOCA
/ "SVC2TB" - TRANSFER-VECTOR FOR "SVC2"
SVC2TB, ONERR / 0
CHAIN / 1
TRAP / 2
ERROR / 3
SYSTEM / 4
OPEN / 5
RUNNER / 6
ERROR / 7
EJECT
/ "SVC1" - ONE WORD SUPERVISOR CALL
SVC1, TAD R2
AND CONDCD
SNA CLA / IS CONDITION MET?
JMP I [RNI
TAD (SVC1TB
TAD R1
SVC12, DCA TEMP1
TAD I TEMP1
DCA TEMP1
JMP I TEMP1 / PERFORM THE HAPPY DISPATCH
/ "SVC2" - TWO WORD SUPERVISOR CALL
SVC2, JMS I [ONEAD / SET UP MEMORY-ADDRESS
TAD (SVC2TB
TAD R2
JMP SVC12
LODCAL, TAD (LDCTAB / LOADER SPECIAL-INSTRUCTION
TAD R2
JMP SVC12
SYSTEM, TAD AREG+6 / EXTENDED SVC2
CLL
TAD SYSMAX
SZL CLA / IS THIS A VALID FUNCTION-CODE?
JMP I (BADSYS / TOO BIG A NUMBER
JMS I [MEFAD / SET UP MEMORY-ADDRESS
TAD AREG+6
TAD (SYSJTB
JMP SVC12
SYSMAX, -10 / -(LARGEST "SYSTEM" OPTION) + 1
EJECT
CHNFLG, 0
WHTOVL, 0
PAGE
/ "FORMS" - IFN IN A(7), COUNT/FUNCTION IN A(6)
/ COUNT = 0, FORM-FEED
/ COUNT = -1, VERTICAL-TAB
/ COUNT = -2, LARGE-CHARACTERS
/ COUNT = -3, C-R WITH NO L-F
/ COUNT > 0, ISSUE "COUNT" CRLF'S (MODULO 64)
/ COUNT < -3, RESULTS ARE UNDEFINED
FORMS, TAD AREG+7
JMS I [IOINIT / WAKE UP I/O ROUTINES
JMS I [TURNIO / INSURE DATA GOES OUT (NOT IN)
TAD AREG+6
SPA SNA
JMP ODDFRM / WANT SPECIAL-CHARACTER
AND [77 / TAKE COUNT MODULO 64
CIA
DCA FCNT
JMS I (XCRLF
ISZ FCNT
JMP .-2
JMP I [IOWRAP / GO CLEAN UP
ODDFRM, TAD (FRMTBL+3
DCA TEMP2
TAD I TEMP2
DCA TEMP1
JMS I (XOCHR / GO OUTPUT SPECIAL CHARACTER
JMS I (OUTCTZ / GO SEE IF THIS IS, MAYBE, "LPT" OR "TTY"
JMP I [IOWRAP
EJECT
/ "MPYXX" - MULTIPLY X-REGISTERS
MPYXX, JMS I (DASU / GO DO SET-UP
TAD SGN1
TAD SGN2
AND MSGNMK / LOW-ORDER BIT IS ONLY ONE WANTED
DCA I RBASE1 / SET RESULT SIGN
TAD XR3
DCA RESREG / SAVE RESULT POINTER
TAD (TMPREG-1
DCA XR4
ISZ RESREG
TAD I RESREG
DCA I XR4 / MOVE MULTIPLICAND
DCA I RESREG / ZERO RESULT
ISZ CNT
JMP .-5
TAD (TMPREG-1
DCA XR4 / MULTIPLICAND POINTER
TAD XRLEN
DCA TEMP3 / OUTER LOOP COUNTER
TAD XR1
DCA TEMP1 / RESULT POINTER
MSGNMK, TAD XR2
DCA TEMP2 / MULTIPLIER POINTER
SKP / AVOID INITIAL "ISZ"
MPYLP, ISZ TEMP1 / EFFECTIVELY MULTIPLY MULTIPLIER BY TEN
TAD I XR4
CMA / WANT COUNT ONE TOO BIG
DCA MPYCNT / LOOP-COUNTER FOR THIS DIGIT
JMP MPYL1N / GO TEST COUNTER (IT COULD BE ZERO)
MPYLP1, TAD TEMP1
DCA XR1 / OPERAND-1 POINTER
TAD TEMP1
DCA XR3 / RESULT-POINTER
TAD TEMP2
DCA XR2 / OPERAND-2 POINTER
TAD TEMP3
DCA CNT / REMAINING-DIGIT COUNT
JMS I (DADD / ADD IN MULTIPLIER
MPYL1N, ISZ MPYCNT
JMP MPYLP1 / LOOP PER CURRENT MULTIPLIER DIGIT
ISZ TEMP3 / BUMP BYTE COUNT
JMP MPYLP
JMP I [RNI
EJECT
/ "MPYAA" - MULTIPLY TWO A-REGISTERS
MPYAA, JMS I (A2SET
TAD I RBASE1
DCA TEMP1
TAD I RBASE2
DCA TEMP2 / SET UP ARGS FOR MULTIPLY
JMS I (BMULT / GO DO MULTIPLY
TAD TEMP3
DCA I RBASE1 / STORE RESULT
JMP I [RNI
/ "SWITCH" - READ -USR- SWITCH-AREA INTO 3 WORD BINARY ARRAY
SWITCH, TAD (7643-1
DCA XR1 / SET FETCH POINTER
CLL CLA CMA RTL / -3
DCA CNT / SET LOOP-COUNT
CDF 10 / DATA ARE IN FIELD ONE
TAD I XR1
CDF 0
MQL
JMS I [STWRDI / STORE WORD
ISZ CNT
JMP .-6
JMP I [RNI
/ "LODAR" - LOAD A-REGISTER P-RELITIVE
LODAR, JMS I (IMMAD / DO IMMEDIATE ADDRESS CALCULATION
JMS I (RELAD / CALCULATE PROPER EFFECTIVE ADDRESS
JMS I [FEWORD / GET DATUM
MQA
DCA I RBASE2 / STORE IN REGISTER
JMP I [RNI
EJECT
/ "ORAA" - OR TWO A-REGISTERS TOGETHER
ORAA, JMS I (A2SET / SET POINTERS
TAD I RBASE1
MQL
TAD I RBASE2
MQA / PERFORM "OR"
DCA I RBASE1 / STORE THE RESULT
JMP I [RNI
FCNT, 0
MPYCNT, 0
RESREG, 0
/ "FRMTBL" - "FORMS" ODDBALL-CHARACTER-TABLE
/ NOTE: INDEXED BY NEGATIVE OR ZERO INDEX
FRMTBL, 001 / CR (NO LF) (FORMS(X,-3))
216 / CTL-N (LARGE CHARACTERS) (FORMS(X,-2))
213 / VERTICAL-TAB (FORMS(X,-1))
214 / FORM-FEED (FORMS(X,0))
/ "SVC1TB" - TRANSFER-VECTOR FOR "SVC1"
SVC1TB, ERROR / 0
DATE / 1
CLOSER / 2
TRACE / 3
NTRACE / 4
STOPR / 5
FINI / 6
FORMS / 7
PAGE
CALDRV, 0
JMS LDDRV / INSURE DRIVER IS IN CORE
TAD LDIOTM
IAC
DCA LDDRV / EXECUTION ADDRESS OF DRIVER
TAD CALDRV
DCA I LDIOTM / ARGUMENT ADDRESS
JMP I LDDRV / FAKE A "JMS"
/ "LDDRV" - ASCERTAIN IF DRIVER IS RESIDENT. LOAD IT IF NOT.
LDDRV, 0
CLL CLA
TAD CURCTL
AND [17 / OS/8 DEVICE-ORDINAL
SNA
JMP I (NODRV / WHAT DRIVER?
TAD (7647-1 / BASE OF DEVICE-RESIDENCY TABLE (DEVICES NUMBER FROM ONE)
DCA LDIOTM
CDF 10 / RESIDENCY TABLE IS IN FIELD ONE
TAD I LDIOTM
CDF BSEFLD
SNA / IS DRIVER RESIDENT?
JMP .+3 / NO, GO TRY TO GET IT
DCA LDIOTM / SAVE TRANSFER ADDRESS
JMP I LDDRV
CIF 10
JMS I [USR / LOCK -USR- INTO CORE (TO SAVE DISC-SWAPS)
10
EJECT
CIF 10
JMS I [200 / TELL -USR- TO FORGET ANY CURRENT DRIVER...
13
0 /...BUT REMEMBER ANY CURRENT TENTITIVE FILES
TAD (DRIVER+1 / ALLOW TWO-PAGE DRIVERS
DCA .+5
CIF 10
TAD CURCTL
JMS I [200 / FETCH DRIVER
1
0
JMP WHTDRV / NO SUCH ANIMAL ?!!?
TAD .-2
DCA LDIOTM / TRANSFER ADDRESS FOR DRIVER
CIF 10
JMS I [200 / DISMISS -USR-
11
TAD CURCTL
AND (20
TAD (-20
SZA CLA / IS THIS "LPT"
JMP I LDDRV / NO
TAD I (TOF / PRINTER TOP-OF-FORM FLAG
DCA I (LPTTOF / RESTORE FLAG IN DRIVER
JMP I LDDRV
WHTDRV, CIF 10 / CANNOT LEAVE -USR- HANGING AROUND, SO...
JMS I [200 /...DISMISS IT!!
11
JMP I (NODRV / NOW, GO SCREAM ABOUT NONEXISTENT DRIVER
LDIOTM, 0
EJECT
/ "A2SET" - SET POINTERS TO BOTH A-REGISTERS
A2SET, 0
TAD R1
TAD [AREG
DCA RBASE1
TAD R2
TAD [AREG
DCA RBASE2
JMP I A2SET
/ "XASTBD" - PRESET FOR BINARY-TO-DECIMAL
XASTBD, 0
TAD R2
TAD [AREG
DCA RBASE2 / FIND PROPER A-REGISTER
TAD I RBASE2
CLL
SPA / IS REGISTER POSITIVE?
CML CIA / NO, NEGATE IT AND SET LINK
DCA TEMP1
RAL
DCA SGN1
TAD (TENTAB
DCA TEMP2 / SET POINTER TO POWER-OF-TEN TABLE
JMP I XASTBD
DBG, JMS I [SYSDRV / GET REST OF DEBUG (OVER ANY NON-RESIDENT DRIVER)
200
DRIVER
SCRBLK
HLT
CIF 10
JMS I [USR / FORGET ANY CURRENT DRIVER
13
0 / SAVE ANY TENTATIVE FILES
JMP I (DBGST
EJECT
/ "GETERN" - RETURN LAST ERROR-CODE
/ INVOKED BY SYSTEM(2,CODE) WHERE CODE IS A B1 VARIABLE
GETERN, TAD I (OLDERR / GET ERROR-CODE
MQL
JMS I [STWORD / STORE IT WHERE USER WANTS IT
JMP I [RNI
/ "GETCHN" - RETURN LAST LOAD-MODE
/ 0=INITIAL LOAD, -1=CHAIN, +1=RUN
/ INVOKED BY SYSTEM(6,CODE) WHERE CODE IS A B1 VARIABLE
GETCHN, TAD I (CHNFLG / GET CHAIN-FLAG
JMP GETERN+1 / GO STORE IT
MERRN, TEXT /ERROR NUMBER /
MPEQ, TEXT /P = /
PAGE
/ "DEBUG" - HANDLE VARIOUS DEBUGGING FUNCTIONS
/ CONTROL-INPUT IS VIA "COMMANDER-CODY"
DBGST, CLL CLA
JMS I [TCRLF
JMS I (EXTOUT
MPEQ / "P = "
JMS PRTPC / GO PRINT P-COUNTER
JMS I [TCRLF
TAD (7577
DCA XR1
TAD (DBGSAV-1
DCA XR2
TAD (-DBGSLN
DCA CNT / SET UP TO SAVE OLD DECODE-AREA
CDF IOFLD
TAD I XR1
DCA I XR2
ISZ CNT
JMP .-3 / SAVE OLD "COMMANDER-CODY" STOUGH
EJECT
DBGLP, CDF BSEFLD / INSURE CORRECT FIELD
CIF 10
JMS I [USR / GO TALK TO THE COMMANDER
5
5200 / SPECIAL-MODE
0 / PRESERVE TENTATIVE FILES
TAD (DBGTBL
DCA TEMP1
TAD (7643
DCA DBGPNT
CLL CLA CMA RTL / -3
DCA DBGCT1
CDF 10
CLL CLA CMA RAR / 3777
AND I (7642
DCA R1
TAD I (7646
DCA R2
DBGLP1, TAD (-14
DCA DBGCT2
TAD I DBGPNT / NOTE: WE ARE IN FIELD ONE
DBGLP2, SPA
JMP I (GOTDBG / FOUND A LIVE BIT
CLL RAL
ISZ TEMP1
ISZ DBGCT2
JMP DBGLP2 / TRY SOME MORE IN THIS WORD
ISZ DBGPNT
ISZ DBGCT1
JMP DBGLP1 / TRY NEXT WORD
/ IF WE GET HERE, NO SLASHES ARE ON
TAD I (7642 / STILL IN FIELD ONE
SPA CLA / WAS "ALT-MODE" ON?
JMP PRTBYT
TAD R1
DCA EXAD
TAD R2
DCA EXAD+1 / RESET EXAMINATION ADDRESS
EJECT
PRTBYT, CDF BSEFLD
TAD EXAD
JMS OCTOUT
TAD EXAD+1
JMS I (OWDOUT / PRINT ADDRESS
TAD (240
JMS I [TOUTT / OUTPUT A SPACE
TAD EXAD
DCA MA
TAD EXAD+1
DCA MA+1 / SET FETCH ADDRESS
JMS I [FEBYTE / GET A BYTE
MQA
JMS I EXPNT / OUTPUT IT
ISZ EXAD+1
SKP
ISZ EXAD / SET UP NEXT ADDRESS
DBGCR, JMS I [TCRLF
JMP DBGLP
PRTOCH, TAD (OCTOUT
DCA EXPNT
JMP DBGLP
PRTHCH, TAD (HOUT
DCA EXPNT
JMP DBGLP
OCTOUT, 0 / TYPE OUT OCTAL BYTE PASSED IN AC
DCA TEMP2
TAD TEMP2
CLL RTR
RAR
AND [7
TAD [260
JMS I [TOUTT / OUTPUT HIGH-ORDER BYTE
TAD TEMP2
AND [7
TAD [260
JMS I [TOUTT / OUTPUT LOW-ORDER BYTE
JMP I OCTOUT
EJECT
/ "PRTPC" - PRINT P-COUNTER
PRTPC, 0
TAD I [INSFTC+1
RTR
RAR
AND [7
MQL
TAD PCTR
RAL
CLA MQA
RAL
JMS OCTOUT
TAD PCTR
CLL RAL
JMS I (OWDOUT
JMP I PRTPC
DBGPNT, 0
DBGCT1, 0
DBGCT2, 0
EXAD, ZBLOCK 2
EXPNT, OCTOUT
PAGE
DRIVER,
/ NON-RESIDENT DRIVER LOADS HERE
/ LOADER-CODE FOR MSI-1
/ BEFORE COMMING HERE, "CURCTL" AND "FNAME" MUST BE PRESET
LOADER, JMS I (LDDRV / INSURE PROPER DRIVER IS RESIDENT
TAD CURCTL / CONTAINS THE OS/8 DEVICE NUMBER
CIF 10
JMS I [USR / GO ATTEMPT TO OPEN FILE
2
LODOPE, FNAME / NOTE: "USR" OVERWRITES THIS WORD, HOWEVER,
/ THE OVERLAY IS RELOADED EACH TIME THROUGH
0
JMP I (NOLOD / NO SUCH FILE
TAD LODOPE
DCA LODBLK / STARTING ADDRESS OF FILE
STA
DCA BUFINC / BUFFER COUNTER (EMPTY BUFFER)
LODRLP, JMS LODWD / GET FUNCTION WORD
CLL
TAD (-LDFNMX
SZL / IS THIS A VALID FUNCTION?
JMP I (LODERR / NO!
TAD (LODTAB+LDFNMX / COMPENSATE FOR TEST
DCA TEMP1
TAD I TEMP1
DCA TEMP2 / GET TRANSFER ADDRESS
JMP I TEMP2 / GO USE IT
EJECT
/ SET DESCRIPTOR COUNT (UNUSED, FOR NOW)
LODR1, JMS LODWD / GET DESCRIPTOR COUNT
CLL CLA / SWALLOW IT
JMP LODRLP
/ LOAD A BLOCK OF DESCRIPTORS
LODR2, JMS LODWD
DCA CNT / -(NUMBER OF FOLLOWING DESCRIPTOR-TRIPLES)
JMS LODWD / 3 * (NUMBER OF FIRST DESCRIPTOR)
TAD (DSCTAB-1
DCA XR1 / (STARTING POINTER) - 1
LDR2LP, JMS LODWD
DCA TEMP1
JMS LODWD
DCA TEMP2
JMS LODWD
DCA TEMP3 / GET DESCRIPTOR-TRIPLE
CDF IOFLD / SET TO DESCRIPTOR FIELD
CLL CLA IAC RTL / 4
TAD TEMP1 / RELOCATE ADDRESS
DCA I XR1
TAD TEMP2
DCA I XR1
TAD TEMP3
DCA I XR1 / ENTER DESCRIPTOR INTO TABLE
CDF BSEFLD
ISZ CNT
JMP LDR2LP / LOAD ALL DESCRIPTORS IN THIS BLOCK
JMP LODRLP
EJECT
/ LOAD A BLOCK OF DATA (WHICH CAN BE INSTRUCTIONS)
LODR3, JMS LDADFX / SET BYTE COUNT AND ADDRESS
JMS LODWD
DCA TEMP1 / GET A PAIR OF BYTES TO LOAD
TAD TEMP1
BSW
AND [77 / ISOLATE HIGH-ORDER BYTE
MQL
JMS I [STBYTI / STORE IT
ISZ CNT / DONE WITH THIS STRING?
SKP / NO
JMP LODRLP / YES
TAD TEMP1
AND [77 / ISOLATE LOW-ORDER BYTE
MQL
JMS I [STBYTI / STORE IT
ISZ CNT / HAVE WE FINISHED THIS STRING YET?
JMP LODR3+1 / NO, GO LOAD SOME MORE
JMP LODRLP / YES, GO PROCESS MORE LOADER INPUT
/ CONDITIONAL-CLEAR
LODR4, JMS LDADFX / SET ADDRESS AND BYTE COUNT
/ MUST BE DONE EVEN IF IN "CHAIN" - EXTRA WORDS MUST BE SWALLOWED
TAD I (CHNFLG
SPA CLA / IS THIS A "CHAIN" - LOAD? ("RUN" DOESN'T COUNT)
JMP LODRLP / YES, AVOID CLEAR
SKP / NO, AVOID "LODR4"
/ UNCONDITIONAL-CLEAR
LODR5, JMS LDADFX / SET ADDRESS AND BYTE COUNT
TAD MA
BSW
AND [77 / ISOLATE CLEARING BYTE
MQL
JMS I [STBYTI / STORE A BYTE
ISZ CNT
JMP .-2 / CLEAR A HUNK OF CORE
JMP LODRLP / TRY MORE LOADER INPUT
EJECT
/ "LDADFX" - GET AND RELOCATE LOAD ADDRESS
/ ALSO, SET BYTE-COUNT WORD
LDADFX, 0
JMS LODWD
DCA CNT / SET BYTE-COUNTER
JMS LODWD
TAD (4 / RELOCATE BYTE-ADDRESS
DCA MA
JMS LODWD
DCA MA+1 / SET ADDRESS-POINTER
JMP I LDADFX
/ "LODWD" - GET NEXT WORD FROM LOADER-BUFFER
LODWD, 0
ISZ BUFINC / ANY DATA IN BUFFER?
JMP LDGVWD / YES, GO GIVE IT TO CALLER
JMS I (CALDRV / REFILL THE BUFFER
0400 IOFLD
LODBUF
LODBLK, 0
JMP I (RDERR / READ-ERROR
CLL CLA IAC RAL / 2
TAD LODBLK
DCA LODBLK / UPDATE DISK ADDRESS
TAD LODBLK-1
DCA CURBPT / RESET BUFFER-POINTER
TAD (-1000
DCA BUFINC / RESET BUFFER-COUNTER
LDGVWD, CDF IOFLD / GET TO BUFFER FIELD
TAD I CURBPT / GET DATUM
CDF BSEFLD / RETURN TO SIMULATOR FIELD
ISZ CURBPT / BUMP BUFFER POINTER
JMP I LODWD / EXIT
EJECT
LODTAB, LODERR
LODR1
LODR2
LODR3
LODR4
LODR5
LODR6
LODR7
PAGE
/ LOAD VARIABLE WITH SYSTEM-DATE
LODR6, TAD (DATER
DCA PCTR / SET TO RUN "DATE" META-CODE
/ "INSFTC"+1 IS ALREADY CORRECT
JMS I (LODWD
DCA TEMP1
JMS I (LODWD
CDF IOFLD
DCA I (CLRDSC+1
CLL CLA IAC RTL / 4
TAD TEMP1 / RELOCATE ADDRESS
DCA I (CLRDSC
CLL CLA CMA RAL / -2
DCA I (CLRDSC+2 / SET DESCRIPTOR FOR META-CODE
LDCDF0, CDF BSEFLD
JMP I [RNI / GO RUN "DATE" META-CODE
/ META-CODE FOR LOADING SYSTEM-DATE
DATER, ISVC1 10 7 / GET DATE
ISTOAD 0 / STORE "MM"
CLRDSC-DSCTAB%3
ILODAI 4
2
ISTOAD 40 1 / STORE "DD"
CLRDSC-DSCTAB%3
ILODAI 4
3
ISTOAD 40 2 / STORE "YY"
CLRDSC-DSCTAB%3
ILODCL 1 / RETURN TO REAL LOADER
EJECT
/ COME HERE FOR LAST RECORD
LODR7, JMS I (LODWD
TAD (4 / RELOCATE ADDRESS
DCA EFFAD1
JMS I (LODWD
DCA EFFAD1+1 / SET-UP TRANSFER ADDRESS
TAD LODSTP
DCA STEP / PASS ON "8" - FLAG
DCA LODSTP / CLEAR FOR FUTURE LOADS
TAD I (CHNFLG
SMA CLA / ARE WE CHAINING?
JMP I [SETPCT / NO, GO START USER JUNQUE
JMS I [SYSDRV / RECOVER USER-BUFFERS
0400 IOFLD
LODBUF
SCRBLK+4
HLT
JMP I [SETPCT / NOW, GO START USER JUNQUE
CHNCD, TAD LDCDF0
DCA I [INSFTC+1
TAD (CHNLOD
DCA PCTR / SET TO RUN CHAIN META-CODE
TAD DN1
DCA CHNOPN / SET POINTER TO CALLED FILE-NAME
TAD (2123
DCA I (OPPARM / (02) OPEN ONLY
TAD I (CHNFLG
DCA AREG / PASS CHAIN FLAG TO LOADER
TAD AREG
CHFX1, CLA / IS THIS A "CHAIN" ?
/ "SMA CLA" IF NEW-STYLE "CHAIN"
JMP RANRUN / NO, MUST BE "RUN"
JMS I [SYSDRV / SAVE CURRENT USER-BUFFERS
4400 IOFLD
LODBUF
SCRBLK+4
HLT
JMP I [RNI / GO LOAD CHAIN-LINK
EJECT
RANRUN, TAD (-20-NUMBFS
DCA CNT
TAD (FNT-1
DCA XR1
DCA I XR1
ISZ CNT
JMP .-2 / CLEAR F. N. T. AND B. R. T.
JMP I [RNI / GO RUN LOADER
/ MATA-CODE FOR "CHAIN"
/ I DOUBT THAT NAME (MUST BE A COMPUTER-SPY)
CHNLOD, IMVCC / MOVE NAME INTO PLACE
DOPNME-DSCTAB%3
CHNOPN, 0
/ META-CODE FOR "LOADER" INITIALIZATION
LOADR, ICMPAA 00 6
IJUMPR 1 / NO DEFAULT OPENS ON "CHAIN"
CHRST=LODRCL-.-1
CHFX2, 0 / "CHRST" IF NEW-STYLE "CHAIN"
ISVC2 0 5 / OPEN "LPT"
DOPDEV-DSCTAB%3
IADDAA 70 7 / 2
ISVC2 70 5 / OPEN "TTY" - INPUT
DOPDEV-DSCTAB%3
ILODAI 7
3
ISVC2 70 5 / OPEN "TTY" - OUTPUT
DOPDEV-DSCTAB%3
LODRCL, ISVC2 0 5 / OPEN ONLY ON BINARY (MAYBE WITH "SYS")
DOPEN-DSCTAB%3
ILODCL 0 / GO START REAL LOADER
EJECT
/ "DEFDEV" - OPEN-CALLS FOR DEFAULT I.F.N.'S
DEFDEV, 2132 / 09 (TRIM)
2127 / 06
2221 / 10
5564 / LST
6501
0101
5455 / .KL
2121 / 00
2130 / 07
2222 / 11
6565 / TTYIN
7252
5701
5455 / .KL
2132 / 09 (TRIM)
2131 / 08
2222 / 11
6565 / TTY
7201
0101
5455 / .KL
LODSTP, 0
PAGE
/ "OPEN" - ATTACH AN OS/8 I-O FILE
/ PARAMETER BLOCK:
/ D2, FUNCTION
/ 0 = OPEN-READ
/ 1 = OPEN-WRITE
/ 2 = GET FILE NAME ONLY ("SYS" MUST BE ALSO SET TO BE USEFUL)
/ 3 = OPEN EXISTING FILE FOR OUTPUT
/ ADD 4 FOR "SYS" - OPTION
/ ADD 8 FOR "NO-FILL"
/ ADD 16 FOR BINARY-FILE
/ D2, IFN TAKEN MODULO 16
/ D2, EFN
/ 0 = "SYS"
/ 1 = "DSK"
/ 2 = "DSK0"
/ 3 = "DSK1"
/ 4 = "DSK2"
/ 5 = "DSK3"
/ 6 = "DSK4"
/ 7 = "DSK5"
/ 8 = "DSK6"
/ 9 = "DSK7"
/ 10 = "LPT"
/ 11 = "TTY"
/ 12 = "DTA0"
/ 13 = "DTA1"
/ 14 = "PTR"
/ 15 = "PTP"
/ 16 = "VT8E"
/ A6, OS/8 FILE NAME
/ A2, OS/8 FILE EXTENSION
EJECT
OPNST, TAD (CLRDSC-1
DCA XR1
CDF IOFLD
TAD EFFAD1
DCA I XR1
TAD EFFAD1+1
DCA I XR1
TAD (-16
DCA I XR1 / PHONEY UP A DESCRIPTOR FOR THE META-CODE
CDF BSEFLD
CLL CLA CML RTL / 2
DCA EFFAD1
TAD (OPENCD^2
DCA EFFAD1+1 / SET TO RUN META-CODE SUBROUTINE
DCA R1 / NOT A "COMPUTED-CALL"
STA
DCA I (MSTPOP / SET "ERROR-POP" FLAG
JMP I (PUSHJ1 / GO DO HARD PART OF OPEN PROCESSING
EJECT
OPEN1, TAD (KILBUF
DCA [RNI / ANY ERRORS FOR A WHILE MUST DE-ALOCATE PHONEY-BUFFER
TAD AREG
TAD (FNT
DCA FNTPNT / SET POINTER INTO "FNT"
CLL CLA CML IAC RAL / 3
AND BREG
TAD (OPJTAB
DCA TEMP1
TAD I TEMP1
DCA TEMP2
DCA DOOPE
DCA CURBLK
DCA MAXBLK
DCA MAXDAD
DCA FSTBLK / CLEAN OUT SOME STUFF
TAD I FNTPNT
SZA CLA
JMP I (NOWOPE / FILE ALREADY OPEN???!!!???
CLA IAC BSW / 100
AND CURCTL
SNA CLA / IS THIS A CHARACTER DEVICE?
JMP I TEMP2 / YES, NO NEED FOR DRIVER
JMS I (LDDRV / GET PROPER DRIVER
STA
DCA DOOPE / INDICATE NEED FOR OS/8-OPEN CALL
JMP I TEMP2 / GO PROCESS OPEN FUNCTION
/ "OPEIN" - OPEN EXISTING FILE FOR INPUT
OPEIN, JMS FILOPN / OPEN THE FILE
TAD (XIJMP
DCA CURCHR
CLL CLA CML RAR / 4000
OPEFIN, TAD CURCTL
DCA CURCTL
TAD CURBLK
DCA FSTBLK / SET STARTING BLOCK
STA
DCA CURBPT / BUFFER IS EMPTY
TAD (RNI
DCA [RNI / RESET POINTER (WE HAVE SURVIVED THE "OPEN")
STA
TAD AREG+1
DCA I FNTPNT / SET POINTER TO PROPER F. N. T. - SLOT
JMP I [IOWRAP / GO FINISH WORK
EJECT
/ "OPOUT" - CREATE A TENTATIVE FILE FOR OUTPUT
OPOUT, ISZ DOOPE
JMP OPOUT1 / TEST NEED OF OS/8 - OPEN CALL
TAD (FNAME
DCA OPC1 / PUT FILE-NAME POINTER INTO CALL
TAD CURCTL
AND [17 / CLEAR UPPER BITS (-USR- WOULD TAKE THEM AS A FILE-LENGTH)
CIF 10
JMS I [USR / CREATE A TENTATIVE FILE
3
OPC1, 0
0
JMP I (NOOF / COULD NOT CREATE ONE
TAD OPC1
DCA CURBLK / STARTING BLOCK
TAD OPC1+1
CIA / LENGTH IS GIVEN COMPLEMENTED
TAD OPC1 / FORM LIMIT BLOCK
DCA MAXBLK
TAD CURBLK
DCA MAXDAD / AT START OF FILE
OPOUT1, TAD (XOJMP
DCA CURCHR
TAD (1000 / FORCE CLOSE-CALL IN "FINI"
JMP OPEFIN
EJECT
FILOPN, 0
ISZ DOOPE
JMP I FILOPN / WHO NEEDS "OPEN" ON CHARACTER DEVICES
TAD (FNAME
DCA FO1 / PUT POINTER TO FILE-NAME INTO CALL
TAD CURCTL
CIF 10
JMS I [USR / GO TRY TO FIND EXISTING FILE
2
FO1, 0
0
JMP I (NOFIL / FILE NOT THERE
TAD FO1
DCA CURBLK / STARTING BLOCK
TAD FO1+1
CIA
TAD CURBLK
DCA MAXBLK / MAXIMUM BLOCK
TAD MAXBLK
DCA MAXDAD / ON EXISTING FILES, THESE ARE EQUAL
JMP I FILOPN
DOOPE, 0
PAGE
FINCD, TAD AREG+7
JMS I [IOINIT
TAD CURCTL
AND (4060
SZA CLA
JMP TSTCLO / NO FURTHER OUTPUT ON "TTY", "LPT" OR INPUT-FILES
/ MUST, HOWEVER, ISSUE "CLOSE" ON TENTATIVE FILES LAST "READ"
CLL CLA CML RTR / 2000
AND CURCTL
SZA CLA / ASCII OR BINARY?
JMP FINBIN
TAD (214
DCA TEMP1
JMS I (XOCHR / "FORM-FEED"
TAD (232
DCA TEMP1 / "CTL-Z"
JMS I (XOCHR
TAD (FINDMP
DCA [DMPBUF
JMP .-4 / FILL REST OF BUFFER WITH NULLS
FINBIN, JMS I (OBINW / FILL REST OF BUFFER WITH ZERO-WORDS
/ NOTE: NEED, AT LEAST, ONE ZERO-WORD FOR E. O. I.
TAD (FINDMP
DCA [DMPBUF
JMP FINBIN
FINDMP, 0 / GETS ENTERED WITH A "JMS"
TAD (DMPBUF
DCA [DMPBUF / RESET POINTER
JMS I [DMPBUF / OUTPUT REST OF BUFFER
TSTCLO, TAD CURCTL
RTL
SMA CLA / DO WE NEED "CLOSE" - CALL ?
JMP RELBUF / NO
TAD FSTBLK
CIA
TAD MAXDAD
FINCLS, DCA FCL1 / PUT FILE LENGTH IN CALL
JMS I (LDDRV / INSURE DRIVER IS IN CORE
TAD CURCTL / OS/8 DEVICE-ORDINAL
CIF 10
JMS I [USR / ISSUE "CLOSE" CALL
4
FNAME
FCL1, 0
JMP I (NOCLS / CALL FAILED?!!?
EJECT
RELBUF, TAD FNTPNT
TAD (-FNT+1 / I. F. N. + 1
/ DONE THIS WAY TO USE THE SAME UNIT TRUNCATION ALGORITHM
/ AS "IOINIT"
CIA
DCA TEMP1 / SAVE FOR FUTURE COMPARISON
TAD (BRT
DCA TEMP2
TAD (-NUMBFS
DCA CNT
DCA I FNTPNT / CLEAR F. N. T. - SLOT
BUFREL, TAD I TEMP2
TAD TEMP1
SNA CLA / IS THIS BUFFER ASSIGNED TO THIS FILE?
DCA I TEMP2 / YES, REMOVE ASSIGNMENT
ISZ TEMP2
ISZ CNT
JMP BUFREL / LOOP THROUGH ALL BUFFERS
JMP I [RNI / DONE "FINI" -ING
/ "CLOSER" - HANDLE CLOSE CALL
/ I. F. N. IS PASSED IN A(7) LENGTH (IN BLOCKS) IS PASSED IN A(6)
CLSCD, TAD AREG+7
JMS I [IOINIT / SET UP I/O PARAMETERS
TAD AREG+6
JMP FINCLS
/ "KILBUF" - DE-ALLOCATED USELESS BUFFER AFTER OPEN FAILURE
KILBUF, CDF IOFLD
TAD I (BRTNDX
CDF BSEFLD
TAD (BRT
DCA TEMP1
DCA I TEMP1 / KILL MIS-ALLOCATED BUFFER
OPE2, TAD (RNI
DCA [RNI / RESET POINTER
DCA MSTPOP / CLEAR POP-STACK FLAG
JMP I [RNI
EJECT
NOWOPE, TAD TEMP2
TAD (-OPE2
SNA CLA
JMP OPE2 / ON "OPEN-ONLY" FILE MAY BE ALREADY OPEN
JMP I (OPENOW
/ "OPEOUT" - OPEN EXISTING FILE FOR OUTPUT
OPEOUT, JMS I (FILOPN / GO OPEN THE FILE
TAD (XOJMP
DCA CURCHR
JMP I (OPEFIN+2
OU2MU, -1 ; -1 ; -1 ; -1
-1 ; -1 ; -1 ; -1
-1 ; -1 ; -1 ; -1
-1 ; -1 ; -1
/ SET TO FLAG ERROR IF NON-EXISTANT DEVICE-TYPE
EJECT
/ "OPJTAB" - TRANSFER VECTOR FOR "OPEN"
OPJTAB, OPEIN
OPOUT
OPE2
OPEOUT
PAGE
XREG, ZBLOCK XRGLEN^10
TMPREG, ZBLOCK XRGLEN / MUST IMMEDIATELY FOLLOW "XREG"
FNT, ZBLOCK 20 / MUST IMMEDIATELY FOLLOW "TMPREG"
BRT, ZBLOCK NUMBFS / MUST IMMEDIATELY FOLLOW "FNT"
/ CURRENTLY UNIMPLEMENTED OPCODES
TRAP,
BREAKR,
JMP I .+1
UNIMOP
/ "IOINIT" - SET UP FOR I/O PROCESSORS
/ "IFN" IS PASSED IN -AC-
IOINIT, 0
AND [17 / TAKE I. F. N. MODULO 16
TAD (FNT
DCA FNTPNT / POINTER INTO THE F. N. T.
TAD I FNTPNT
SNA
JMP I (NOIOCD / FILE IS NOT OPEN?!?
DCA XR1
TAD (CURCTL-1
DCA XR2
TAD (-XBUFWD
DCA CNT
CDF IOFLD
TAD I XR1
CDF BSEFLD
DCA I XR2
ISZ CNT
JMP .-5 / MOVE BUFFER-PARAMETERS TO CANNONICAL LOCATIONS (BOOM!)
STA
DCA IOERR / ERRORS NEED I/O RECOVERY (FOR THIS OPERATION)
JMP I IOINIT
EJECT
/ "OUTCTZ" - OUTPUT A CNTL-Z THEN DUMP BUFFER
OUTCTZ, 0
TAD CURCTL
AND (60
SNA CLA / "LPT" OR "TTY" ?
JMP I OUTCTZ / NO, MERELY EXIT
TAD (232
DCA TEMP1
JMS I (XOCHR / GO OUTPUT THE CHARACTER
TAD (XOJMP
DCA CURCHR / RESET CHARACTER-DECODE POINTER
ISZ CURBPT / INSURE THAT SHORT RECORDS ARE OUTPUT
JMS I [DMPBUF / DUMP THE BUFFER
JMP I OUTCTZ
/ "NEGXX" - TRANSMIT THE COMPLEMENT OF ONE X-REGISTER TO ANOTHER
NEGXX, JMS I (X2SET / SET POINTERS
TAD I RBASE2
RAR
CML CLA RAL
DCA I RBASE1 / TRANSMIT COMPLEMENTED SIGN
ISZ RBASE1
ISZ RBASE2
TAD I RBASE2
DCA I RBASE1
ISZ CNT
JMP .-5
JMP I [RNI
EJECT
/ "CMPAAM" - COMPARE A-REGISTERS AS 12-BIT POSITIVE INTEGERS
CMPAAM, JMS I (A2SET / SET REGISTER POINTERS
TAD I RBASE1
CLL CIA
TAD I RBASE2
SNA CLA
JMP I (STEQL / REGISTERS ARE EQUAL
JMP I (CMPTST / GO SEE WHICH ORDER
PAGE
/ "ACCEPT" - NORMAL CHARACTERS TO STRING ARG, DELIMETER TO A(6)
ACCEPT, TAD AREG+7
JMS I [IOINIT / SET UP I/O PARAMETERS
CLL CLA CML RAR / 4000
JMS I [TURNIO / INSURE INWARD TRANSIT
JMS I [ONEAD
JMS I [MEFAD / SET UP STRING-ARGUMENT
ACPTLP, TAD CURCTL
AND (60
SNA / EITHER "TTY" OR "VT8E" (OR, GOD HELP US, "LPT")
JMP ANTTY / NONE OF THE ABOVE
TAD (-60
SNA CLA / IS THIS "VT8E"?
JMP VT8ACP / YES
/ NOTE: IF SOME FOOL TRIES TO ACCEPT FROM "LPT",
/ THE SYSTEM "LPT" - DRIVER WILL SCREAM
KSF
JMP .-1 / WAIT FOR A FLAG
KRB
JMS ACCTST / IS THIS AN "ACCEPT"-ABLE CHARACTER
MQA
JMS I [TOUTT / ECHO THE CHARACTER
JMP ANTTY1
VT8ACP, DSKF
JMP .-1 / WAIT FOR A KEY TO BE STUCK
DKRB
JMS ACCTST
MQA
DCA VT8BF
JMS I (CALDRV / GO ECHO TYPE-IN
4100 / WRITE ONE FIELD-ZERO PAGE
VT8BF
VT8BF, 0 / DRIVER SHOULD IGNORE BLOCK-NUMBER
232 / (^Z) DRIVER SHOULD NEVER GIVE ERROR-EXIT
/ SEND THE CHARACTER (AND A CTL-Z) TO BE DISPLAYED
JMP ANTTY1
EJECT
ANTTY, JMS I (XICHR / GET A CHARACTER
MQA
JMS ACCTST / CAN WE BELIEVE THIS CHARACTER
ANTTY1, MQA
TAD (-237 / UNBIAS THE CHARACTER
MQL
JMS I [STBYTI / PUT BYTE INTO STRING
ISZ OPLEN1
JMP ACPTLP
JMP ACDOUT / PASS BACK ZERO-DELIMETER IF STRING IS FULL
ACDEL, CLA MQA
TAD (-203
SNA CLA / ^C?
JMP I (7600 / YES, GO QUIT
MQA
TAD (-377
SNA / IS THIS A RUBOUT
TAD (40+200-377 / YES, OUTPUT A 40
TAD (-200+377
ACDOUT, DCA AREG+6 / STORE DELIMETER IN A(6)
JMP I [IOWRAP
ACCTST, 0
AND (177
TAD [200 / INSURE PARITY BIT IS SET
MQL
MQA
TAD (-337
SMA CLA
JMP ACDEL / CHARACTER IS TOO BIG
MQA
TAD (-237
SMA SZA CLA
JMP I ACCTST / REASONABLE CHARACTER
JMP ACDEL
EJECT
/ "BLOCKI" - INPUT A BLOCK FROM A DEVICE
/ SYSTEM(4,B) B(1) IS E. D. N., B(2) IS DISK BLOCK
/ B(3) IS PAGE(!) COUNT
/ THE REST IS BUFFER
BLOCKI, TAD (RDERR
DCA BERR / WANT TO SHOW "READ-ERROR" IF APPROPRIATE
DCA BFCT / WANT READ FUNCTION
JMP BLKIO
/ "BLOCKO" - SAME AS BLOCKI BUT WRITES TO THE DEVICE
/ INVOKED BY SYSTEM(5,B)
BLOCKO, TAD (WRTERR
DCA BERR / SET TO GIVE "WRITE-ERROR" IF NEED BE
CLL CLA CML RAR / 4000
DCA BFCT / WANT WRITE FUNCTION
BLKIO, JMS I [FEWRDI / GET E. D. N.
MQA
TAD (MU2OU
DCA TEMP1
CDF IOFLD
TAD I TEMP1
CDF BSEFLD
DCA CURCTL / SET PROPER DEVICE NUMBER
JMS I [FEWRDI / GET DISK ADDRESS
MQA
DCA BLOKI1+2 / PUT IN CALL
JMS I [FEWRDI / GET PAGE COUNT
TAD MA
AND (16
RTL
BSW / ISOLATE AND POSITION BUFFER DATA-FIELD
MQA / OR IN PAGE COUNT
BSW / GET BITS IN RIGHT PLACES
AND (3770 / INSURE NO SUPRISES (LIKE A WRITE)
TAD BFCT / SET READ/WRITE BIT
DCA BLOKI1 / PLACE FUNCTION-WORD IN CALL
TAD MA
CLL RAR
STA
AND MA+1
RAR
DCA BLOKI1+1 / WORD-ADDRESS OF BUFFER
EJECT
JMS I (CALDRV / DO ACTUAL INPUT/OUTPUT
BLOKI1, 0
0
0
JMP I BERR / OH! OH!
JMP I [RNI
BERR, 0
BFCT, 0
PAGE
/ "FIXAD" - SET UP ADDRESS FOR "FAST" FETCHES AND STORES
FIXAD, 0
TAD EFFAD1
CLL RAR
MQL
TAD EFFAD1+1
RAR
DCA MA / WORD ADDRESS
/ SZL
/ STA
/ DCA FSTBYT / BYTE-FLAG
/ SOME SUCH IS NEEDED LATER
MQA
CLL RTL
RAL
TAD (CDF 0
DCA FFLD / SET FIELD FOR WORD FETCH
TAD FFLD
DCA SFLD / FIELD FOR WORD-STORE
JMP I FIXAD
/ "FFWORD" - "FAST" WORD-FETCH
FFWORD, 0
FFLD, HLT / SET TO PROPER FIELD FOR WORD-FETCH
TAD I MA / GET WORD
CDF BSEFLD / RETRUN TO HOME COURT
ISZ MA
JMP I FFWORD / NO FIELD CHANGE
MQL / SAVE DATUM
TAD FFLD
TAD [10
DCA FFLD / FIX FIELD
MQA / RECOVER DATUM
JMP I FFWORD
/ "FSWORD" - "FAST" WORD STORE
FSWORD, 0
SFLD, HLT / SET TO PROPER DATA FIELD
DCA I MA / STORE DATUM
CDF BSEFLD / HOME JAMES!!
ISZ MA / FIX ADDRESS
JMP I FSWORD / NO FIELD CHANGE
TAD SFLD
TAD [10
DCA SFLD / FIX FIELD
JMP I FSWORD
EJECT
/ "BINCHK" - TEST FOR BINARY FILE-ORIENTED FILE
BINCHK, 0
TAD CURCTL
AND (2100
TAD (-2100
SNA CLA / MUST BE FILE-STRUCTURED DEVIC, OPENED FOR BINARY I/O
JMP I BINCHK
JMP I (BADBIN / FILE NOT VALID FOR BINARY I/O
/ "XMITXX" - TRANSMIT ONE X-REGISTER RO ANOTHER
XMITXX, JMS I (X2SET / SET POINTERS
TAD I RBASE2
DCA I RBASE1
ISZ RBASE1
ISZ RBASE2
ISZ CNT
JMP XMITXX+1 / TRANSMIT SIGN AND FIRST BYTES
TAD I RBASE2
DCA I RBASE1 / XRLEN DOES NOT ACCOUNT FOR THE SIGN-BYTE
JMP I [RNI
EDCNT, 37-130 / "X"
37-132 / "Z"
37-52 / "*"
0 / END-OF-TABLE
/ "OPPARM" - OPEN BLOCK FOR LOADER
OPPARM, 2127 ; 2122 ; 2121 ; ZBLOCK 4
/ FUN=6 (OPEN-ONLY "SYS") ("2122", OPEN-ONLY IF "CHAIN")
/ IFN=01
/ EDN=00
EJECT
/ "NEWCHN" - SET NEW-STYLE "CHAIN" MODE
/ IN THE NEW VERSION, FILES STAY PUT ACROSS "CHAIN" - CALLS
NEWCHN, JMS I (SYSDRV
0200
DRIVER / RECOVER LOADER-OVERLAY
SCRBLK+1
HLT
TAD (SMA CLA
DCA I (CHFX1
TAD (CHRST
DCA I (CHFX2
JMS I (SYSDRV
4200
DRIVER
SCRBLK+1
HLT
CIF 10
JMS I [USR
13
0 / MARK THE NON-RESIDENT DRIVER AS O. T. L.
JMP I [RNI
EJECT
/ TRUE START OF "XMIT"
XMIT, TAD AREG+7
JMS I [IOINIT / SET UP BUFFER-PARAMETERS
JMS I [ONEAD / EVALUATE USER-BUFFER ADDRESS
JMS I [INSFTC
MQA
DCA DN2 / E-O-F LABEL DESCRIPTOR
TAD R2
SNA / "INPUT" OR "OUTPUT"
JMP I (XMITIT / NO
RTR
CLA RAR / "INPUT" - BIT TO 2**11
JMS TURNIO / RESET I/O DIRECTION
JMP I (XMITIT
TURNIO, 0
MQL / SAVE NEW "I/O" - BIT
CLL CLA IAC BSW / 100
AND CURCTL
SZA CLA / FILE-ORIENTED DEVICE?
JMP I TURNIO / NO, IGNORE THIS REQUEST
CLL CLA CMA RAR / 3777
AND CURCTL / REMOVE OLD "I/O" - BIT
MQA / OR IN NEW BIT
DCA CURCTL / RESET FUNCTION-WORD
MQA
SMA CLA / INPUT OR OUTPUT?
TAD (XOJMP-XIJMP / OUTPUT
TAD (XIJMP
DCA CURCHR / RESET STEP-POINTER
DCA CURBPT / RESET BUFFER-POINTER
JMP I TURNIO
PAGE
/ "DISPLY" - PROCESS "DISPLAY" FUNCTION
/ IF((R2.AND.2).NE.0) A(5) IS X-POSITION, A(4) IS Y-POSITION
/ IF((R2.AND.1).NE.0) DISPLAY THE SINGLE ASCII-BYTE IN A(6)
DISPLY, TAD AREG+7
JMS I [IOINIT / SET UP THE BUFFER/DEVICE-PARAMETERS
JMS I [TURNIO / INSURE OUTBOUND DATA
CLL CLA CML RTL / 2
AND R2
SNA CLA / RESET CURSOR POSITION?
JMP DSPNPS / NO
TAD CURCTL
AND (40
SNA CLA / IS THIS THE TERMINAL?
JMP DSPNPS / NO
TAD AREG+4
SNA CLA / IS POSITIONING DESIRED AT THIS TIME?
JMP DSPNPS / NO
TAD (33
JMS I [TOUTT / ESCAPE
TAD ("Y
JMS I [TOUTT / PREPARE VT5X FOR POSITIONING
TAD AREG+4
TAD (37
JMS I [TOUTT / SEND LINE-NUMBER
TAD AREG+5
TAD (37
JMS I [TOUTT / SEND COLUMN-NUMBER
DSPNPS, CLL CLA IAC
AND R2
SZA CLA / SINGLE-CHARACTER DISPLAY?
JMP DISP1 / YES
JMS I [ONEAD / EVALUATE BUFFER-ADDRESS
DCA DN2 / CLEAR ERROR-ADDRESS
STA
DCA I (NOCR / NO -CRLF- AFTER "DISPLAY"
JMS I [MEFAD / MOVE BUFFER-POINTERS INTO PLACE
JMP I (XMTOLP / GO TRANSFER THE DATA
EJECT
/ COME HERE FOR SINGLE-CHARACTER DISPLAYS
DISP1, TAD CURCTL
AND (40
SNA CLA / TERMINAL?
JMP DISPO / NO
TAD AREG+6
SNA / NULL BYTE?
JMP DISPO / YES
TAD (-2
SMA SZA / ONE OR TWO?
JMP DISPO / NO
TAD ("K / 1 = CLEAR TO END-OF SCREEN, 2 = CLEAR TO END-OF-LINE
MQL / SAVE CLEAR-BYTE
TAD (33
JMS I [TOUTT / ESCAPE
MQA
JMS I [TOUTT / SEND CLEAR-BYTE
JMP I [IOWRAP
DISPO, CLL CLA
TAD AREG+6
DCA TEMP1 / SET UP FOR TRANSFER
JMS I (XOCHR / OUTPUT THE BYTE
JMS I (OUTCTZ / SEE IF BUFFER NEEDS TO BE FORCED OUT
JMP I [IOWRAP / ALL DONE
PAGE
/ DEFINE SOME PAGE-ZERO LITERAL POINTERS FOR THE
/ BENIFIT OF CODE LOADED INTO FIELD-1 AND EXECUTED FROM FIELD-0
RNIP=[RNI
TWOADP=[TWOAD
MVSUP=[MVSU
FBYTIP=[FEBYTI
SOP1IP=[STOP1I
FOP2IP=[FEOP2I
K21=[21
KAREG=[AREG
K260=[260
TOUTTP=[TOUTT
EFFADP=[EFFAD
TCRLFP=[TCRLF
K7=[7
XRSETP=[XRSET
MEFADP=[MEFAD
FWRDIP=[FEWRDI
SETPCP=[SETPCT
EJECT
FIELD IOFLD%10
*5600
OSTOE=. / LOAD-ADDRESS OF "STOE" OVERLAY
RELOC OPNST
/ "STOE" - STORE X(0) EDITED
/ EFFECTIVE SOURCE LENGTH IS LENGTH OF EDIT FIELD
/ EFFECTIVE (EDITED) SOURCE IS STORED (RIGHT-ADJUSTED)
/ TRUNCATION (IF ANY) OCCURS ON THE RIGHT
STE, JMS I TWOADP / FIND MEMORY ADDRESS
JMS I MVSUP / SET MOVE LENGTHS
JMS I (BLFILL / DO ANY NECESSARY BLANK-FILL
TAD OPLEN2
CLL CIA
TAD CNT / LINK IS SET HERE
TAD EFFAD2+1 / AND (MAYBE) CLEARED HERE
DCA EFFAD2+1
SNL
ISZ EFFAD2 / EFFECTIVE LEFT-END OF CONTROL-STRING
TAD CNT
DCA OPLEN2
TAD OPLEN2
CIA
DCA TEMP3 / NEED CONTROL-BYTE COUNT FOR "-"
DCA TEMP1
TAD EFFAD2
DCA MA
TAD EFFAD2+1
DCA MA+1
ECNTLP, JMS I FBYTIP / GET A CONTROL-STRING BYTE
MQA
DCA TEMP2
TAD (EDCNT-1
DCA XR1
TAD I XR1
SNA / IS THIS END OF TABLE?
JMP .+5 / YES, IGNORE BYTE IN COUNT
TAD TEMP2
SZA CLA / IS THIS THE DESIRED ENTRY?
JMP .-5 / NO, GO TRY SOME MORE
ISZ TEMP1 / BUMP CONTROL-BYTE COUNTER
ISZ CNT
JMP ECNTLP / COUNT DIGIT-CONTROL BYTES IN CONTROL-STRING
TAD TEMP1
TAD (XREG
DCA RPNT1 / EFFECTIVE HIGH-ORDER END OF SOURCE
TAD (-20
DCA SIGST / NO SIGNIFICANT CHARACTERS YET
TAD TEMP1
CIA
DCA CNT / SOURCE LENGTH
EJECT
STOE1, TAD OPLEN2
SPA CLA
JMP .+5 / HAVE VALID CONTROL-STRING BYTE
STOEBL, CLA IAC / HAVE NO CONTROL-CHARACTER
MQL
JMS I SOP1IP / STORE BLANK
JMP STOELP
JMS I FOP2IP
MQA
DCA TEMP1
TAD (EDTAB-1
DCA XR1
EDSLP, TAD I XR1
SNA / IS THIS END OF TABLE?
JMP STOE3 / YES, GO STORE LITERAL CHARACTER
TAD TEMP1
SZA CLA / IS TABLE ENTRY THE CURRENT CONTROL-BYTE?
JMP EDSLP / NO, TRY SOME MORE
TAD XR1
TAD (EDJTAB-EDTAB-1
DCA XR1
TAD I XR1
DCA TEMP1 / GET TRANSFER ADDRESS
JMP I TEMP1 / USE IT
STOE3, JMS I SOP1IP / STORE LITERAL BYTE
STOELP, ISZ OPLEN2
JMP STOE1
JMP I RNIP
EJECT
/ COME HERE FOR "X" IN CONTROL-STRING
EDX, TAD CNT
SMA CLA / IS THERE A SOURCE-BYTE LEFT?
JMP STOEBL / NO, GO OUTPUT A BLANK
TAD I RPNT1
SNA / IS IT A ZERO?
TAD SIGST / YES, GO THROUGH SIGNIFICANCE KLUDGERY
TAD K21 / REBIAS IT
MQL
JMS I SOP1IP / STORE IT
/ COME HERE (ALSO) FOR "Z" IN CONTROL-STRING
EDZ, TAD I RPNT1
SZA CLA / DO THIS START SIGNIFICANCE?
DCA SIGST / SURE DO
EDZ1, STA
TAD RPNT1
DCA RPNT1
ISZ CNT / UPDATE SOURCE-COUNTER
JMP STOELP
JMP STOELP / SKIP MATTERS NOT
/ COME HERE FOR ","
EDCOMA, TAD SIGST
SZA CLA / ANY SIG-BYTES YET?
JMP STOEBL / NO, GO STORE A BLANK
JMP STOE3 / YES, GO STORE THE COMMA
/ COME HERE FOR "."
EDDOT, DCA SIGST / PERIOD STARTS SIGNIFICANCE
JMP STOE3 / GO STORE THE DOT
EJECT
/ COME HERE FOR "*" IN CONTROL-STRING
EDSTAR, TAD SIGST
SNA CLA / HAS GOOD-STUFF STARTED YET?
JMP EDX / YES, GO STORE DIGIT IN ANY CASE, IT IS REAL
TAD I RPNT1
SZA CLA / DOES SIGNIFICANCE START HERE?
JMP .+3 / YES, GO DO IT
JMS I SOP1IP / NO, GO STORE THE "*"
JMP EDZ1 / GO FIX "RPNT1"
DCA SIGST
JMP EDX
/ COME HERE FOR "-" IN CONTROL-STRING
EDMIN, TAD OPLEN2
TAD TEMP3
SNA CLA / ARE WE AT FIRST CONTROL BYTE?
JMP .+5 / YES
TAD OPLEN2
IAC
SZA CLA / ARE WE AT LAST CONTROL-BYTE?
JMP STOE3 / NO GO STORE THE "-"
TAD I (XREG
SNA CLA / IS SOURCE NEGATIVE?
JMP STOEBL / NO, GO STORE A BLANK
JMP STOE3 / GO STORE "-"
SIGST, 0
RELOC
PAGE
RELOC OPNST+200
/ "DIVXX" - X(R1) _ X(R1) / X(R2)
DXX, JMS I (X2SET / POINT AT PROPER REGISTERS
TAD RBASE1
MQL
TAD RBASE2
DCA RBASE1
MQA
DCA RBASE2 / SWAP POINTERS
JMS LFTSIG / FIND LEFT-MOST NON-ZERO
SKP
JMP I (DIVB0 / DIVIDE BY ZERO?!!?
TAD I RBASE1
TAD I RBASE2
AND SGNMSK
DCA I RBASE2 / RESULT-SIGN (POINTERS ARE SWAPPED)
TAD RBASE2
DCA TEMP1
TAD XRLEN
DCA CNT
TAD (TMPREG-1
DCA XR1
ISZ TEMP1
TAD I TEMP1
DCA I XR1
DCA I TEMP1
ISZ CNT
JMP .-5 / MOVE DIVIDEND TO "TMPREG" AND CLEAR QUOTIENT
TAD XRLEN
CIA
TAD OPLEN2
MQL
MQA
TAD (TMPREG-1
DCA TEMP1 / STARTING BYTE OF DIVIDEND
MQA
TAD RBASE2
IAC
DCA TEMP2 / (STARTING BYTE OF QUOTIENT) + 1
MQA
CMA
DCA OPLEN1 / STEP-COUNTER (NEEDS TO BE ONE TOO BIG)
EJECT
/ NOW, DO THE DIVIDE
DIVLP, DCA TEMP3 / CLEAR CURRENT DIGIT
JMS DVSTUP / GO SET POINTERS FOR SUBTRACT
JMS I (DSUB / DO PARTIAL SUBTRACTION
ISZ TEMP3 / BUMP CURRENT DIGIT-COUNTER
SNL
JMP DIVLP+1 / NO OVERDRAUGHT YET
JMS DVSTUP / RESET POINTERS FOR ADDITION
JMS I (DADD / ADD BACK OVERDRAFT
STA
TAD TEMP1
DCA TEMP1 / SET UP FOR NEXT STEP OF DIVIDE
STA
TAD TEMP3 / COUNT IS ONE TOO BIG
DCA I TEMP2 / STORE CURRENT RESULT-BYTE
STA
TAD TEMP2
DCA TEMP2 / SET UP NEXT RESULT-BYTE
STA
TAD OPLEN2
DCA OPLEN2 / OPERATION LENGTH GROWS
ISZ OPLEN1
JMP DIVLP / LOOP SUFFICIENTLY
JMP I RNIP
DVSTUP, 0 / SET POINTERS FOR DIVIDE
TAD TEMP1
DCA XR1 / OPERAND-1 (TEMPORARY-DIVIDEND)
TAD TEMP1
DCA XR3 / RESULT (TEMPORARY-DIVIDEND)
TAD RBASE1
DCA XR2 / OPERAND-2 (DIVISOR)
TAD OPLEN2
DCA CNT / OPERATION BYTE-COUNT
JMP I DVSTUP
EJECT
/ "DIVAA" - A(R1) _ A(R1) / A(R2)
DAA, JMS I (A2SET
DCA TEMP1
TAD I RBASE2
SNA
JMP I (DIVB0 / DIVIDE BY THAT SILLY NUMBER? NEVER!!!
CLL CIA
DCA TEMP2
TAD I RBASE1
CLL
TAD TEMP2
SNL / HAVE WE GONE THROUGH ZERO YET?
JMP .+3 / YES, GO QUIT
ISZ TEMP1 / BUMP COUNTER
JMP .-5 / GO TRY SOME MORE
CLL CLA
TAD TEMP1
DCA I RBASE1 / STORE RESULT
JMP I RNIP
EDTAB, 37-130 / "X"
37-132 / "Z"
37-52 / "*"
37-55 / "-"
37-54 / ","
37-56 / "."
0 / END-OF-TABLE
EDJTAB, EDX / "X"
EDZ / "Z"
EDSTAR / "*"
EDMIN / "-"
EDCOMA / ","
EDDOT / "."
EJECT
/ "LFTSIG" - FIND LEFT-MOST SIGNIFICANT DIGIT OF X-REG
/ ENTER WITH "RBASE1" POINTING TO SIGN-BYTE
/ EXIT TO CALL+1, WITH "RPNT1" POINTING TO LEFT DIGIT AND
/ "OPLEN2" = -(NUMBER OF BYTES LEFT)
/ EXIT TO CALL+2 IF X-REG IS ALL ZERO
LFTSIG, 0
TAD XRLEN
SGNMSK, CIA / LENGTH IS NEGATIVE
TAD RBASE1
IAC
DCA RPNT1 / (LEFT-BYTE) + 1
TAD XRLEN
DCA OPLEN2 / BYTE COUNT
LFTS1, STA
TAD RPNT1
DCA RPNT1 / POINT AT NEXT BYTE
TAD I RPNT1
SZA CLA / IS THIS A NON-ZERO BYTE?
JMP I LFTSIG / YES
ISZ OPLEN2
JMP LFTS1 / LOOP IF MORE POSSIBLE BYTES
ISZ LFTSIG / SET UP FOR ERROR-EXIT
JMP I LFTSIG / DO IT
RELOC
PAGE
ODBG=. / LOAD-ADDRESS OF DEBUG OVERLAY
RELOC LOADER
/ COME HERE TO DISPATCH TO PROPER FUNCTION PROCESSOR
GOTDBG, CLL CLA / CAN GET HERE WITH DIRTY AC
/ GET HERE IN FIELD IOFLD
TAD I TEMP1
DCA TEMP2 / GET TRANSFER ADDRESS
CDF BSEFLD
JMP I TEMP2 / GO USE IT
EXBREG, TAD (BREG-AREG / PRINT B-REGISTER
EXAREG, TAD KAREG / PRINT A-REGISTER
TAD R2
DCA TEMP1
TAD I TEMP1 / GET PROPER DATUM
PRTWD, JMS I (OWDOUT
JMP I (DBGCR
EXCNCD, TAD CONDCD / PRINT CONDITION CODE
TAD K260 / FORMAT FOR PRINTING
JMS I TOUTTP / GO PRINT IT
JMP I (DBGCR
PRTDSC, TAD R2
CLL RAL / 2 * DN
TAD R2 / 3 * DN
TAD (DSCTAB-1
DCA XR1
CLL CLA CMA RTL / -3
DCA CNT
PTDSLP, CDF IOFLD
TAD I XR1 / FETCH DESCRIPTOR WORD
CDF BSEFLD
JMS I (OWDOUT / OUTPUT IT
TAD (240
JMS I TOUTTP / OUTPUT A SPACE
ISZ CNT
JMP PTDSLP
JMP I (DBGCR
EXPREG, JMS I (PRTPC
JMP I (DBGCR
EJECT
IN2EX, TAD R1 / CONVERT FROM MSI-1 ADDRESSES TO PDP-8
CLL RAR
DCA R1
TAD R2
RAR
DCA R2
JMP .+7
EX2IN, TAD R2 / CONVERT PDP-8 ADDRESSES TO MSI-1
CLL RAL
DCA R2
TAD R1
RAL
DCA R1
TAD R1
JMS I (OCTOUT / DISPLAY HIGH-ORDER BYTE
TAD R2
JMP PRTWD / GO DISPLAY LOW-ORDER
EXXREG, TAD R2 / PRINT AN X-REGISTER
AND K7
JMS I XRSETP / SET POINTER TO CORRECT REGISTER
TAD XRLEN
DCA CNT
EXXLP, TAD I RBASE1
TAD K260
JMS I TOUTTP / DISPLAY REGISTER ONE BYTE AT A TIME
ISZ RBASE1
ISZ CNT
JMP EXXLP
JMP I (DBGCR
HOUT, 0
TAD (237 / PRINT BYTE AS HOLLERITH
JMS I TOUTTP
JMP I HOUT
EJECT
GOER, TAD (7577
DCA XR2
TAD (DBGSAV-1
DCA XR1
TAD (-DBGSLN
DCA CNT
CDF IOFLD
TAD I XR1
DCA I XR2
ISZ CNT
JMP .-3 / RESTORE OLD COMMAND AREA
CDF BSEFLD
TAD R1
SZA CLA
JMP .+4
TAD R2
SNA CLA / NO ADDRESS GIVEN, GO BACK TO WORK
JMP I (BKPRET
TAD R1
DCA EFFAD1
TAD R2
DCA EFFAD1+1
JMP I SETPCP
EJECT
WLKSET, CLA IAC
DCA STEP / SET STEP-MODE FLAG
JMP WKBK
STBKP, TAD R1
CLL RAR
MQL
TAD R2
RAR
CIA
DCA BKP+1
MQA
CLL RTL
RAL
TAD (CDF 0
CIA
DCA BKP
DCA STEP / TURN OFF STEP MODE
WKBK, TAD (TAD STEP
DCA I (BKINS / TURN ON BREAKPOINT CHECKS
JMP I (DBGLP
RELOC
PAGE
RELOC LOADER+200
/ PRINT STRING AS OCTAL
STRPRT, CLL CLA CMA RAL / -2
/ PRINT STRING AS HOLLERITH
KARPRT, TAD (KSTR
DCA STPNT1
TAD R2 / DESCRIPTOR NUMBER
MQL
JMS I EFFADP / RESOLVE DESCRIPTOR ADDRESS
JMS I MEFADP / PUT IT WHERE IT WILL DO SOME GOOD
KCC / INSURE NO KEY-HIT YET
TAD (-32
DCA OPLEN2
PSTRLP, JMS I FBYTIP / GET ENTITY
MQA
JMP I STPNT1 / OUTPUT IT
ISZ OPLEN1
SKP
JMP I (DBGCR / DONE STRING
KSF / ANY KEY STUCK?
JMP .+3 / NO, PROCEED WITH PRINTING
KCC
JMP I (DBGCR / QUIT THIS SINFUL BEHAVIOR!
ISZ OPLEN2
JMP PSTRLP / LINE IS NOT YET FULL
JMS I TCRLFP / GO DO "CRLF"
JMP PSTRLP-2 / RESET COUNTER AND PROCEED
PRTLNK, CLA IAC / PRINT LOADER'S OPEN DESCRIPTOR
DCA R2
JMP KARPRT
EJECT
FILPRT, TAD FNTPNT / PRINT CURRENT I. F. N. AND FILE NAME
TAD (-FNT
JMS OWDOUT
TAD (240
JMS I TOUTTP / PUT OUT A SPACE
TAD (-10
DCA CNT
DCA MA
TAD (FNAME^2
DCA MA+1
FPTLP, JMS I FBYTIP
MQA
SNA
JMP .+4
TAD (-40
SPA
TAD (100
TAD (240
JMS I TOUTTP
ISZ CNT
JMP FPTLP
JMP I (DBGCR
FNTPRT, TAD R2 / PRINT SOME BUFFER PARAMETERS
TAD (FNT
DCA R1
TAD I R1
SNA
JMP I (DBGCR / NOTHING THERE TO PRINT
CLL RAL IAC / AUTO-INDEXING
DCA MA+1
RAL
TAD (2 / 2 OR 3
DCA MA
TAD (-XBUFWD
DCA CNT
FNTLP, JMS I FWRDIP
MQA
JMS OWDOUT
TAD (240
JMS I TOUTTP
ISZ CNT
JMP FNTLP
JMP I (DBGCR
EJECT
OSTR, JMS I (OCTOUT / PRINT BYTE AS OCTAL
JMP PSTRLP+3
IFNZRO .-OSTR-2 <OSKSER, BARF>
KSTR, TAD (237 / REBIAS ACCORDING TO ASCII
JMS I TOUTTP
JMP PSTRLP+3
JSTKPT, TAD R2 / PRINT CALL STACK ENTRY
CLL RAL IAC / (R2+1)*2
CIA
TAD STKPNT
DCA R1 / POINT AT FIRST WORD OF ENTRY
CDF IOFLD
TAD I R1
RTR
RAR
AND K7
MQL
ISZ R1
TAD I R1
RAL
CLA MQA
RAL
CDF BSEFLD
JMS I (OCTOUT
CDF IOFLD
TAD I R1
CDF BSEFLD
CLL RAL
JMS OWDOUT
JMP I (DBGCR
EJECT
OWDOUT, 0 / TYPE OCTAL WORD PASSED IN -AC-
DCA TEMP3
TAD TEMP3
BSW
JMS I (OCTOUT / OUTPUT HIGH-ORDER BYTE
TAD TEMP3
JMS I (OCTOUT / OUTPUT LOW-ORDER BYTE
JMP I OWDOUT
STPNT1, 0
RELOC
PAGE
/ "STRTUP" - INITIALIZATION CODE
/ OVERLAID BY SYSTEM TABLES
STRTUP, DCA MCHAIN / WAS WE CHAINED INTO? (IF SO AC=0)
/ IF NOT, AC=-1
CAF / MAKE ALL FLAGS FURL THEMSELVES
TAD (377
LLS / HOWEVER, GET "LPT" WAVING AGAIN
CLL CLA
TAD I (7666
SNA CLA / IS THERE A SYSTEM-DATE?
JMP NDT / NO?!!?
JMS I (USR / LOCK -USR- INTO CORE
10
ISZ MCHAIN / IF CHAINED INTO...
JMP .+5 / ..COMMANDER-CODY LAND IS ALREADY UP-SET
JMS I (200 / CALL COMMANDER-CODY
5
5200 / "SPECIAL" - MODE
CLL CLA / KILL MORIBUND FILES
TAD I (7600 / WE ARE RUNNING IN FIELD ONE
SZA CLA / IS THERE AN "OUTPUT" (OS/8 STYLE) FILE
JMP STRT2 / YES
TAD I (7611
CIA
TAD TXTMB
SNA CLA / IS FIRST FILE'S EXTENSION ".MB"?
JMP STRT1 / YES, EXECUTE IT
TAD (7600
DCA XR1 / SET UP FOR NAME-SETTING
TAD MINNAM
DCA I XR1
TAD MINNAM+1
DCA I XR1
TAD MINNAM+2
DCA I XR1 / "MINBOL"
TAD MINNAM+3
DCA I XR1 / EXTENSION
JMP STRT2
STRT1, TAD (14
DCA TSYSOF / SET POINTER TO TAKE FIRST "INPUT"-FILE AS EXECUTABLE
EJECT
STRT2, CLA IAC RAL / 2
AND I (7645
SNA CLA / IS "8" - FLAG ON?
JMP NO8 / NO BREAKPOINT TESTING
CDF BSEFLD
TAD (TAD STEP
DCA I (BKINS / TURN ON BREAKPOINT TESTING
CLA IAC
DCA I (LODSTP / SET TO FORCE STEP AFTER LOADING
CDF IOFLD
NO8, TAD I (7643
AND (1000
SNA CLA / "/C"
JMP NOC / NO
TAD (SMA CLA
CDF BSEFLD
DCA I (CHFX1
TAD (CHRST
DCA I (CHFX2 / FORCE NEW-STYLE CHAIN
CDF IOFLD
NOC, CLL CLA CMA RAL / -2
TAD TSYSOF / BYTE OFFSET TO DEVICE-NUMBER OF EXECUTABLE FILE
CLL RAR / WORD OFFSET
TAD (7600
DCA MCHAIN
CLA IAC
DCA I MCHAIN / FORCE DEVICE TO BE "SYS"
IKCD0, CDF BSEFLD
EJECT
TAD (LOADR
DCA I (PCTR
TAD IKCD0
DCA I (INSFTC+1 / SET TO RUN RESIDENT-LOADER
DCA I (AREG / ALLOW DEFAULT OPENS
CDF IOFLD
CLL CLA CML RTR / 2000
AND I (7645 / "Z" - FLAG
SNA CLA / LEGALIZE ZERO-SUBSCRIPTS?
JMP I (FINIT / NO
TAD (OKSUB
CDF BSEFLD
DCA I (BADSUB
TAD (OKSUB
DCA I (RTSUB / MAKE ZERO-SUBSCRIPTS LEGAL
CDF IOFLD
JMP I (FINIT / GO DO MORE INITIALIZATION
NDT, JMS I (USR / ISSUE "USER ERROR 1 AT XXXXX" AND DIE
7
1
EJECT
MCHAIN, 0
TSYSOF, 2
TXTMB, TEXT /MB/
MINNAM, TEXT /MINBOL/
PAGE
/ OVERLAID BY SYSTEM TABLES
FINIT, TAD (INITTB
DCA ININDX
/ NEED NORMAL INDIRECT AS XR'S WILL BE EATEN BY -USR-
TAD (MU2OU
DCA INTMP1 / SET TO INITIALIZE DEVICE-NUMBER TABLES
CDF 10
STUPLP, TAD I ININDX
ISZ ININDX
SNA / IS THIS THE END OF THE TABLE?
JMP STUPDN
DCA STUP1
TAD I ININDX
ISZ ININDX
DCA STUP1+1
DCA STUP1+2
JMS I (200 / GO SEE WHAT OS/8 SAYS ABOUT THIS DEVICE
12
STUP1, 0
0
0
JMP STUPNO / NO SUCH BEASTIE?
TAD I INTMP1
TAD STUP1+1 / OS/8 E. D. N.
DCA I INTMP1 / SET TO CONVERT INTERNAL TO EXTERNAL
/ WITH "LPT", "TTY" OR FILE-STRUCTURED BITS
TAD STUP1+1
TAD (OU2MU-1 / OS/8 NUMBERS FROM DEVICE 1
DCA INTMP2
TAD INTMP1
TAD (-MU2OU / CONVERT INDIRECT POINTER TO OFFSET
CDF BSEFLD / "OU2MU" IS WITH "FINI"
DCA I INTMP2 / SET TO CONVERT EXTERNAL TO INTERNAL
CDF IOFLD
STUPNO, ISZ INTMP1
JMP STUPLP / LOOP THROUGH WHOLE TABLE
EJECT
STUPDN, JMS I (200 / DISMISS "USR"
11
CDF BSEFLD
CLA CLL CML RTL
DCA I (CONDCD / START "EQUAL"
CDF IOFLD
TAD I (TSYSOF
DCA I (SYSOFF / SET COMMAND-LINE POINTER
CIF 0
JMS I (SYSDRV / WRITE OUT DEBUG-OVERLAY
4210
ODBG
SCRBLK
HLT
CIF 0
JMS I (SYSDRV / WRITE OUT LOADER-CODE
4200
LOADER
SCRBLK+1
HLT
CIF 0
JMS I (SYSDRV / WRITE OUT "DIVXX" AND "STOE"
4210
OSTOE
SCRBLK+2
HLT
CIF 0
JMS I (SYSDRV / WRITE OUT "OPEN" - OVERLAY
4200
OPNST
SCRBLK+3
HLT
CDF CIF BSEFLD
JMP I (RNI / GO RUN LOADER
INTMP1, 0
INTMP2, 0
ININDX, 0
EJECT
/ "INITTB" - TABLE TO FIND DEVICE-NUMBERS AT INITIALIZATION
INITTB, DEVICE SYS / (0)
DEVICE DSK / (1)
DEVICE DSK0 / (2)
DEVICE DSK1 / (3)
DEVICE DSK2 / (4)
DEVICE DSK3 / (5)
DEVICE DSK4 / (6)
DEVICE DSK5 / (7)
DEVICE DSK6 / (8)
DEVICE DSK7 / (9)
DEVICE LPT / (10)
DEVICE TTY / (11)
DEVICE DTA0 / (12)
DEVICE DTA1 / (13)
DEVICE PTR / (14)
DEVICE PTP / (15)
DEVICE VT8E / (16)
0 / END-OF-TABLE
PAGE
* OMU2OU
MU2OU, 100 / "SYS" (0)
100 / "DSK" (1)
100 / "DSK0" (2)
100 / "DSK1" (3)
100 / "DSK2" (4)
100 / "DSK3" (5)
100 / "DSK4" (6)
100 / "DSK5" (7)
100 / "DSK6" (8)
100 / "DSK7" (9)
020 / "LPT" (10)
040 / "TTY" (11)
100 / "DTA0" (12)
100 / "DTA1" (13)
000 / "PTR" (14)
000 / "PTP" (15)
060 / "VT8E" (16)
*20
/ OPCODE-TRANSLATION TABLE
OPCDTB, ERROR
BRANCH
PUSHJ
POPJ ; IPOPJ=.-OPCDTB-1^100
CMPXX ; ICMPXX=.-OPCDTB-1^100
CMPAA ; ICMPAA=.-OPCDTB-1^100
CMPC
LOD
LODA ; ILODA=.-OPCDTB-1^100
LODC
LODAD ; ILODAD=.-OPCDTB-1^100
LODB
LODBD
STO
STOA ; ISTOA=.-OPCDTB-1^100
STOC
STOAD ; ISTOAD=.-OPCDTB-1^100
STOE
XMITXX ; IXMTXX=.-OPCDTB-1^100
XMITAX
XMITBX ; IXMTBX=.-OPCDTB-1^100
XMITAA ; IXMTAA=.-OPCDTB-1^100
XMITBA ; IXMTBA=.-OPCDTB-1^100
XMITXA ; IXMTXA=.-OPCDTB-1^100
NEGXX
NEGAA
MVNN
MVNC
MVCN
MVCC ; IMVCC=.-OPCDTB-1^100
ADDXX
ADDAA ; IADDAA=.-OPCDTB-1^100
SUBXX ; ISUBXX=.-OPCDTB-1^100
SUBAA ; ISUBAA=.-OPCDTB-1^100
EJECT
MPYXX ; IMPYXX=.-OPCDTB-1^100
MPYAA ; IMPYAA=.-OPCDTB-1^100
DIVXX ; IDIVXX=.-OPCDTB-1^100
DIVAA
LODCH ; ILODCH=.-OPCDTB-1^100
LODCAL ; ILODCL=.-OPCDTB-1^100
BREAKR
LODXI ; ILODXI=.-OPCDTB-1^100
SVC1 ; ISVC1=.-OPCDTB-1^100
/ 0 = ERROR
/ 1 = DATE
/ 2 = CLOSE
/ 3 = TRACE
/ 4 = NO-TRACE
/ 5 = STOP
/ 6 = FINI
/ 7 = FORMS
SVC2 ; ISVC2=.-OPCDTB-1^100
/ 0 = ON ERROR
/ 1 = CHAIN
/ 2 = TRAP
/ 3 = ERROR
/ 4 = SYSTEM
/ 5 = OPEN
/ 6 = RUN
/ 7 = ERROR
EJECT
XMIT
JUMPR ; IJUMPR=.-OPCDTB-1^100
LODAI ; ILODAI=.-OPCDTB-1^100
STOAR ; ISTOAR=.-OPCDTB-1^100
LODBI
STOCH ; ISTOCH=.-OPCDTB-1^100
DISPLY
ACCEPT
ANDAA ; IANDAA=.-OPCDTB-1^100
ORAA ; IORAA=.-OPCDTB-1^100
NOTAA
SHLAA
SHRAA ; ISHRAA=.-OPCDTB-1^100
CLEAR
RNI
READ
WRITE
LODAR ; ILODAR=.-OPCDTB-1^100
CMPAAM
ERROR
/ "RANCD" - DO INITIAL PROCESSING FOR RANDOM-I/O
/ ENTER WITH BUFFER LENGTH IN A(0)
/ RECORD NUMBER IS IN X(0) (BY USER-CODE)
RANCD, IXMTXA 70 0
ILODXI 2
2121 / 0
ICMPXX 00 2
IJUMPR 4 / RECORD-NUMBERS MUST BE POSITIVE AND NON-ZERO
1
ILODCL 5 / COMPLAIN ABOUT BAD RECORD NUMBER
ILODXI 2
2122 / 1
ISUBXX 00 2 / RECORDS NUMBER FROM ONE
IMPYXX 00 7 / RELATIVE WORD-ADDRESS
IXMTXX 10 0 / SAVE A COPY
ILODAI 0 / SECTOR LENGTH
400 / 256 (10)
IXMTXA 70 0
IDIVXX 00 7 / RELATIVE BLOCK-NUMVER
IXMTBX 00 0 / CONVERT TO BINARY
IMPYXX 00 7
ISUBXX 10 0 / WORD-ADDRESS .MOD. 256
IXMTBX 10 1 / CONVERT TO BINARY
ILODCL 2 / GO DO I/O
IPOPJ 7 / GET BACK TO REAL PHONEY-CODE
/ "OPENCD" - DO HARD PART OF "OPEN" PROCESSING
/ ON ENTRY:
/ A(0) = DN OF PARAMETER-BLOCK
/ ON EXIT:
/ B(0) = FUNCTION CODE
/ A(0) = I. F. N.
/ FILE NAME IS IN "FNAME"
/ CURCTL, BUFLOC AND BUFLEN ARE SET
/ AND AS A BONUS:
/ A(6) = 0
/ A(7) = 1
OPENCD, ILODAI 7
1
ISUBAA 60 6 / CLEAR A(6)
IMVCC / GET USER PARAMETER-BLOCK
DOPBLK-DSCTAB%3
CLRDSC-DSCTAB%3 / "CLRDSC" IS SET BY "OPEN"
ILODAD 0 / FETCH FUNCTION FROM PARAMETER-BLOCK
DOPENW-DSCTAB%3
IXMTBA 00 0 / SAVE FUNCTIION-CODE
ILODAI 1
4
IANDAA 00 1 / GET "SYS" BIT
ICMPAA 00 6
IJUMPR 2 / JUMP IF BIT IS OFF
NOTSYS-.-1
ILODAR 1 / FETCH OFFSET INTO COMMANDER-CODY LAND
SYSOFF-.-1
ILODCH 10 2 / GET OS/8 E. D. N. BYTE
SYSDSC-DSCTAB%3
ICMPAA 20 6
IJUMPR 5
1
ILODCL 00 3 / ERROR NO MORE "SISSIES"
ILODA 20 0 / CONVERT TO MINIBOL-E. D. N.
DOU2MU-DSCTAB%3
ICMPAA 20 6
IJUMPR 6
1
ILODCL 10 3 / ERROR, BAD "SISSY"
ILODAI 2
3
ISTOAD 20 0 / PUT BACK IN PARAMETER-BLOCK
DOPENW-DSCTAB%3
EJECT
ILODAI 2 / STORE-SUBSCRIPT
7
IADDAA 10 7 / UPDATE FETCH-DESCRIPTOR
ILODAI 5 / FETCH-SUBSCRIPT LIMIT
16
OPSLP, ILODCH 10 3
SYSDSC-DSCTAB%3
ICMPAA 30 6
IJUMPR 5 / CONVERT "00" TO "01" (BLANKS)
2
ILODAI 3
-40
ILODAI 30 3 / CONVERT TO MSI-INTERNAL
41
ISTOCH 20 3
DOPECH-DSCTAB%3
IADDAA 10 7 / BUMP FETCH-INDEX
IADDAA 20 7 / BUMP STORE-INDEX
ICMPAA 20 5
IJUMPR 3 / LOOP FOR WHOLE NAME
OPSLP-.-1
IADDAA 10 7 / SET UP NEXT E. D. N. BYTE
ISTOAR 1 / SAVE "SYS" OFFSET
SYSOFF-.-1
IMVCC / RESET USER'S CALL-BLOCK
CLRDSC-DSCTAB%3
DOPBLK-DSCTAB%3
NOTSYS, ILODAI 1 / FETCH-POINTER
7
ILODAI 2 / STORE-POINTER
25
ILODAI 3 / STORE-POINTER LIMIT
34
OPNLP, ILODCH 10 4 / GET A NAME-CHARACTER
DOPECH-DSCTAB%3
ICMPAA 40 7
IJUMPR 5 / IS CHARACTER A BLANK?
2
ILODAI 4 / IF SO, SET TO PRODUCE -00-
-37
ILODAI 40 4 / RE-BIAS TO GET OS/8 SIX-BIT ASCII
37
ISTOCH 20 4 / STORE IN "FNAME"
DIOBLK-DSCTAB%3
IADDAA 10 7 / BUMP FETCH POINTER
IADDAA 20 7 / BUMP STORAGE-POINTER
ICMPAA 20 3
IJUMPR 3 / LOOP IF MORE TO DO
OPNLP-.-1
ILODAD 1 / GET FUNCTION CODE, AGAIN
DOPENW-DSCTAB%3
ILODAI 2
3
IXMTAA 30 2
IANDAA 20 1 / GET FUNCTION CODE
ISHRAA 10 3 / GET BINARY AND NO-FILL BITS
ILODAR 10 3 / BINARY AND NO-FILL BITS
MODBIT-.-1
ILODAI 4
2
ILODAD 40 0 / OPEN CALL I. F. N.
DOPENW-DSCTAB%3
IADDAA 40 7
ILODAD 40 4 / OPEN-CALL E. D. N.
DOPENW-DSCTAB%3
IADDAA 40 7 / UNIT NUMBERS START AT ZERO
ILODA 40 5 / OS/8 DEVICE-NUMBER
DMU2OU-DSCTAB%3 / WITH "TTY" AND "LPT" FLAG-BITS
IORAA 50 3 / MERGE IN BINARY AND NO-FILL BITS
ISTOA 5 / STORE IN "CURCTL"
DIOBLK-DSCTAB%3
ILODAI 1
2
ICMPAA 10 2
IJUMPR 2 / EXIT IF FUNCTION = 2
OPEXIT-.-1
EJECT
ILODAI 1
5
ISTOA 10 6 / SET BUFINC = 0
DIOBLK-DSCTAB%3
ILODAI 2
400
IADDAA 10 7
ISTOA 10 2 / BUFFER-LENGTH
DIOBLK-DSCTAB%3
IXMTAA 20 7 / B. R. T. SEARCH-POINTER
ILODAI 3 / B. R. T. SEARCH-LIMIT
NUMBFS
BUFFND, ILODA 20 4
DBRT-DSCTAB%3
ICMPAA 40 6
IJUMPR 2 / IS THIS SLOT AVAILABLE?
GOTBUF-.-1
IADDAA 20 7 / BUMP FETCH POINTER
ICMPAA 20 3
IJUMPR 3 / LOOP UNTIL DONE SEARCHING
BUFFND-.-1
ILODCL 6 / RANNED OUTTA BUFFERS
GOTBUF, IXMTAA 30 0
IADDAA 30 7
ISTOA 20 3 / STORE (IFN+1) IN B. R. T. - SLOT
DBRT-DSCTAB%3
ISUBAA 20 7 / WANT DISPLACEMENT INTO B. R. T.
ISTOAR 2 / SAVE B. R. T. - OFFSET
BRTNDX-.-1
ILODAI 4
400
IMPYAA 20 4 / GET WORD-DISPLACEMENT
ILODAI 4
FSTBUF
ISUBAA 40 2 / FIRST WORD OF BUFFER
IADDAA 10 7
ISTOA 10 4 / STORE IN "BUFLOC"
DIOBLK-DSCTAB%3
ILODAI 2
XBUFWD
IMPYAA 20 3 / XBUFWD * (IFN+1)
ILODAI 1
10
ISTOA 10 6 / ZERO "MAXBLK"
DIOBLK-DSCTAB%3
ILODAI 1
FILBLK
ISUBAA 10 2 / FWA (FILE CONTROL BLOCK)
OPEXIT, ILODCL 4 / WE ARE DONE OPENED
IPOPJ 7 / GO BACK TO USER-CODE
SYSOFF, 2 / SUBSCRIPT INTO COMMAND-DECODER AREA
MODBIT, 0000 / -(-FILL),-BINARY
0200 / -FILL,-BINARY
2000 / -(-FILL),BINARY
2200 / -FILL,BINARY
OPEBLK, ZBLOCK 10
BRTNDX, 0
DBGTBL, EXAREG / "A" PRINT "A"-REGISTER
EXBREG / "B" PRINT "B"-REGISTER
EXCNCD / "C" PRINT CONDITION-CODE
PRTDSC / "D" PRINT A DESCRIPTOR
IN2EX / "E" TRANSLATE INTERNAL ADDRESS TO EXTERNAL
FILPRT / "F" PRINT FILE PARAMETERS
GOER / "G" RESTART PROGRAM
PRTHCH / "H" PRINT BYTES AS HOLLERITH
EX2IN / "I" TRANSLATE EXTERNAL ADDRESS TO INTERNAL
JSTKPT / "J" PRINT CALL-STACK ENTRY
KARPRT / "K" PRINT STRING AS CHARACTERS
PRTLNK / "L" PRINT CHAIN-LINK NAME
DBGLP / "M"
FNTPRT / "N" PRINT A HUNK OF THE F. N. T.
PRTOCH / "O" PRINT BYTES AS OCTAL
EXPREG / "P" PRINT P-COUNTER
DBGLP / "Q"
DBGLP / "R"
STRPRT / "S" PRINT STRING IN OCTAL
STBKP / "T" SET TRAP (BREAKPOINT)
DBGLP / "U"
DBGLP / "V"
WLKSET / "W" SET "WALK" (STEP)
EXXREG / "X" PRINT X-REGISTER
DBGLP / "Y"
DBGLP / "Z"
DBGLP / "0"
DBGLP / "1"
DBGLP / "2"
DBGLP / "3"
DBGLP / "4"
DBGLP / "5"
DBGLP / "6"
DBGLP / "7"
DBGLP / "8"
DBGLP / "9"
EJECT
DSCTAB, ZBLOCK 3
DSCFLD=IOFLD^2%10
BFLD=BSEFLD^2%10
DOPEN, OPPARM%4000+BFLD / MUST BE FIRST DESCRIPTOR
OPPARM^2
-16
DOPNME, OPPARM%4000+BFLD / POINT AT NAME IN LOADER
/ "OPEN" - BLOCK
OPPARM^2+6
-10
DOPENW, OPEBLK%4000+DSCFLD / POINTS TO LOCAL COPY OF PARAMETER-BLOCK
OPEBLK^2
-2
DOPECH, OPEBLK%4000+DSCFLD
OPEBLK^2
-1
DOPBLK, OPEBLK%4000+DSCFLD
OPEBLK^2
-16
DIOBLK, CURCTL%4000+BFLD
CURCTL^2
-1
DMU2OU, MU2OU%4000+DSCFLD
MU2OU^2
-1
DOU2MU, OU2MU%4000+BFLD
OU2MU^2
-1
EJECT
CLRDSC, 0
0
-1
DBRT, BRT%4000+BFLD
BRT^2
-1
SYSDSC, 3 / POINTS TO COMMANDER-CODY LAND
7600-4000^2
-1
DOPDEV, DEFDEV%4000+BFLD
DEFDEV^2
-16
ZBLOCK 17^3+DSCTAB-.
USRDSC%4000+DSCFLD / MUST BE DESCRIPTOR #17(8)
USRDSC^2
-6
USRDSC, ZBLOCK 3 / FIRST USER DESCRIPTOR
$