File: BRTS.PA of Tape: OS8/OS8-V3D/al-4759c-sa-os8-ext-1
(Source file text)
/OS8 BASIC RUNTIME SYSTEM, V5A
/
/
/
/
/
/
/
/
/
/
/
/COPYRIGHT (C) 1972, 1973, 1974, 1975
/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
/
/
/
/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
/SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
/SION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE, OR ANT OTHER
/COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
/TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
/AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
/SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
/
/
/THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
/EQUIPMRNT COROPATION.
/
/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
/SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
/
/
/
/
/
/
/AUGUST 19, 1972
/
/R.G. BEAN, 1972
/SHAWN SPILMAN, 1973
/ J.K.,1975
/JR 21-APR-77 ADDED EXTENDED DATE CODE, CLEANED UP LISTING
/JR 26-APR-77 TIGHTENED UP STRING ROUTINES
/JR 28-APR-77 ADD SOURCE FIX FOR SEVERAL KNOWN BUGS
/JR 4-MAY-77 REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY
/
/
VERSON= 5 /VERSION OF BRTS
/VERSION LOCATED AT TAG "VERLOC" AND VERLOC+1
/VERLOC = 260+VERSON
/VERLOC+1 = 300+SUBVER (01 = A)
SUBVER= 01 /SUBVERSION OF BRTS
SUBVAF= 01 /SUBVERSION OF BASIC.AF OVERLAY
SUBVSF= 01 /SUBVERSION OF BASIC.SF OVERLAY
SUBVFF= 01 /SUBVERSION OF BASIC.FF OVERLAY
/FIRST WORD OF EACH OVERLAY CONTAINS
/60+VERSON IN LEFT HALF AND SUBVERSION OF OVERLAY
/IN RIGHT HALF.
MDATE= 7666 /CONTAINS OS/8 DATE IN FIELD 1
BIPCCL= 7777 /CONTAINS YEAR EXTENSION BITS
SCOPWD= 7726 /WORD CONTAINING SCOPE FLAG IN 200 BIT
EDBLK= 7604 /CONTAINS BLOCK NUMBER OF EDITOR
WIDTH= 120 /WIDTH OF PRINTER
COLWID= 16 /WIDTH OF ONE PRINT COLUMN
SACLIM= 120 /DEFINE WIDTH OF STRING ACCUMULATOR
OVERLAY=3400 /ADDRESS OF START OF 5 PAGE OVERLAY BUFFER
/ASSEMBLY INSTRUCTIONS
/ .R PAL8
/ *BRTS<BRTS.PA/W
/ .R ABSLDR
/ *BRTS$ (THEN SAVE AS SHOWN BELOW)
/
/WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE
/CORE LAYOUT IS AS FOLLOWS:
/
/BRTS IS AT 0-6777
/OVERLAY BASIC.AF IS AT 3400-4577
/OVERLAY BASIC.SF IA AT 12000-13177
/OVERLAY BASIC.FF IS AT 13400-14577
/
/TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC,
/ASSEMBLE THIS SOURCE IN A 12K OR MORE MACHINE,THEN
/PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS
/
/.R ABSLDR
/*BRTS$
/.SAVE SYS:BRTS 0-6777
/
/.SAVE SYS:BASIC.AF 3400-4577
/
/.SAVE SYS:BASIC.SF 12000-13177
/
/.SAVE SYS:BASIC.FF 13400-14577
/
/THE BASIC RUN-TIME SYSTEM IS CONDITIONALIZED TO TAKE ADVANTAGE
/OF THE PDP-8/E KE8/E EAE OPTION.
/NORMALLY,THE SYSTEM IS ASSEMBLED SUCH THAT IT WILL RUN ON ANY
/PDP-8 OR PDP-12. TO TAKE ADVANTAGE OF THE ADDITIONAL HARDWARE,SET
/THE SWITCH EAE=1 IF THE SYSTEM INCLUDES A KE8/E EAE.
/YOU MAY DO THIS BY CONCATENATING TTY: ONTO BRTS.PA AS FOLLOWS
/.PAL EABRTS<TTY:,SYS:BRTS.PA/W
/EAE=1
/^Z
/^Z
/. BINARY IS CREATED...
/NOW EABRTS IS LOADED INSTEAD OF BRTS
/TO GET A LISTING, USE THE /J SWITCH TO INHIBIT THE FPP CODE YOU
/ARE NOT USING (EAE ON A NON EAE ASSEMBLY FOR EXAMPLE)
/EAE=0 /USE STANDARD FLOATING POINT PACKAGE
/EAE=1 /USE EAE FLOATING POINT PACKAGE
/
/V4 FIXES
/.EAE ADD FOR NUMS <.00001 TO 0
/.FILE INPUT FROM TTY
/.OUTPUT OF NUMS > 80,000
/.STRING FETCH WHEN COUNT IS IN ONE FLD &
/ TEXT IS IN THE NEXT
AC4000= CLA STL RAR
AC2000= CLA STL RTR
AC0002= CLA STL RTL
AC7775= CLL STA RTL
AC7776= CLL STA RAL
AC3777= CLL STA RAR
AC5777= CLL STA RTR
IFNDEF EAE <EAE=0>
/PAGE 0 LOCATIONS
*6
USECON, 0 /USE CONSTANT GENERATED BY "USE" STATEMENT
FSTOP1, FSTOPI /POINTER TO RTS EXIT ROUTINE USED
/BY ^C HOOKS IN SYSTEM HANDLER.
/IF THIS IS MOVED, BLOAD MUST BE ALTERED
*10
SACXR, 15 /INDEX REGISTER FOR STRING ROUTINES
XR1, VCHECK
XR2, 0
XR3, 0
XR4, 4 /INDEX REGISTERS
XR5, 0
DATAXR, 0 /POINTER FOR IN-CORE DATA LIST
SPINNR, 2713 /AT RUNTIME,THIS LOCATION IS SPUN FOR RND SEED
*20
/COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY
/A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR
/TO THE BRTS LOAD
CDFIO, 6211 /* CDF FOR I/O TABLE AND SYMBOL TABLES
SCSTRT, 0 /* POINTER TO START OF SCALAR SYMBOL TABLE
ARSTRT, 0 /* POINTER TO START OF ARRAY SYMBOL TABLE-1
STSTRT, 0 /* POINTER TO START OF STRING SYMBOL TABLE-1
SASTRT, 0 /* POINTER TO START OF STRING ARRAY TABLE-1
CDFPS, 0 /* CDF FOR START OF PSEUDO-CODE
PSSTRT, 0 /* POINTER TO START OF PSEUDO CODE-1
DLSTOP, 0 /* POINTER TO TOP OF DATA LIST
DLSTRT, 0 /* POINTER TO BOTTOM OF INCORE DATA LIST-1
PSFLAG, 0 /* OS/8 SWAPPING FLAGS WORD
/BIT 0 SET IF OS/8 SAVED IN N7400 INSTEAD OF N7600 (TD8E)
/BIT 1 SET IF ROM TD8E HANDLER NOT NEEDING CDF CHANGES
/BIT 11 SET IF 17600 IS IN 17600. BIT 11 TOGGLED BY
/PSWAP ROUTINE
/SYSTEM REGISTERS
SACLEN, 0 /LENGTH OF STRING IN SAC
S1, 0 /SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!)
S2, 0 /SUBSCRIPT 2 (MUST BE PRECEEDED BY S1!)
DMAP, 0 /MAP OF DRIVER PAGES
BMAP, 0 /MAP OF FILE BUFFERS
*37
/FLOATING POINT PACKAGE LOCATIONS. THE FOLLOWING 21 LOCATIONS ARE USED
/FOR VARIOUS PURPOSES BY THE FLOATING POINT PACKAGE. THOSE WITH DOUBLE
/LABELS ARE USED BY BRTS AS TEMPORARIES WHEN NOT CALLING THE PACKAGE.
/THE SECOND TAG IS THE ONE USED BY THE FLOATING POINT PACKAGE,THE FIRST
/IS USED BY BRTS.
FF, 0 /SPECIAL MODE FLIP-FLOP
TEMP1,
AC0, 0
AC1, 0
TEMP3,
AC2, 0
TM,
TEMP4, 6201
ACX, 0 /FAC-EXPONENT
ACH, 0 /FAC-HIGH ORDER MANTISSA
ACL, 0 /FAC-MANTISSA LOW
TEMP5,
OPX, 0
TEMP6,
OPH, 0
TEMP7,
OPL, 0
DSWIT, 0 /SWITCH USED BY INPUT ROUTINE
CHAR, 215 /TERMINATOR OF LAST INPUT
TEMP10, 0 /LOC NEEDED BY FPP
DECEXP= TEMP10
/SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE
MODESW, 0 /0 FOR ARTHIMETIC MODE,1 FOR STRING MODE
INSAV, 0 /CURRENT PSEUDO-INSTRUCTION BEING EXECUTED
LINEHI, 0 /HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED
LINELO, 0 /LOW ORDER BITS OF CURRENT LINE NUMBER
STRMAX, 0 /MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING
STRCNT, 0 /- # OF CHARACTERS IN CURRENT STRING
STRPTR, 0 /POINTER TO SIZE WORD OF CURRENT OPERAND STRING
TEMP2, 0
/I/O TABLE POINTER AREA-THIS BLOCK HOLDS POINTERS TO THE I/O TABLE
/ENTRY FOR THE CURRENT FILE.THE POINTERS ARE CHANGED EVERY TIME AN
/SFN IS EXECUTED. A TAD I OFF ONE OF THE POINTERS WILL GET THE INFORMATION
/NOTED IN THE COMMENT FOR THE CURRENT I/O DEVICE
/THIS BLOCK IS INITIALIZED FOR TTY
IOTSIZ= 15 /CURRENT SIZE OF IO TABLE
/THE FORMAT OF THE HEADER WORD IS AS FOLLOWS
/BITS USAGE
/0-3 OS/8 DEVICE NUMBER
/4-5 3 FOR 2 CHARACTER UNPACKING COUNT
/6 SET IF BUFFER HAS BEEN MODIFIED AND NEEDS TO BE WRITTEN
/7 SET IF NOT FILE STRUCTURED DEVICE
/8 SET IF HANDLER IS 2 PAGES LONG
/9 SET IF VARIABLE LENGTH (OUTPUT) FILE
/10 SET IF EOF
/11 SET IF ASCII FILE, CLEAR IF NUMERIC IMAGE FILE
ENTNO, 0 /ENTRY NUMBER NOW IN AREA
IOTHDR, TTYF /HEADER WORD
IOTBUF, TTYF+1 /BUFFER ADDRESS
IOTBLK, TTYF+2 /CURRENT BLOCK IN BUFFER
IOTPTR, TTYF+3 /READ\WRITE POINTER
IOTHND, TTYF+4 /HANDLER ENTRY POINT
IOTLOC, TTYF+5 /FILE STARTING BLOCK #
IOTLEN, TTYF+6 /ACTUAL FILE LENGTH
IOTMAX, TTYF+7 / DEVICE / (FILE MAXIMUM LENGTH)
IOTPOS, TTYF+10 / NAME / (POSITION OF PRINT HEAD)
IOTFIL, TTYF+11 /
/ TTYF+12 / FILE
/ TTYF+13 / NAME
/ TTYF+14 / .EX
IOTDEV= IOTMAX
*200
/FETCH NEXT PSEUDO WORD
PWFECH, JMP START1 /START ONCE ONLY CODE IN TTY BUFFER
ISZ INTPC /BUMP PSEUDO-CODE PROGRAM COUNTER
JMP CDFPSU /NO-SKIP;JUST GET NEXT PSEUDO-CODE WORD
TAD CDFPSU /SKIP MEANS WE HAVE TO INCREMENT PS-CODE FIELD
TAD [10
DCA CDFPSU
CDFPSU, VCHECK /SET DF TO FIELD OF PSEUDO-CODE
TAD I INTPC /GET NEXT WORD OF CODE
CDF 0 /SET DATA FIELD BACK TO INTERPRETER FIELD
JMP I PWFECH /RETURN
O7770, 7770
SSMODE, IAC /SET INTERPRETER TO STRING MODE
AMODE, DCA MODESW /SET INTERPRETER TO ARITH MODE
/FALL BACK INTO I-LOOP
/BRTS I-LOOP
ILOOP, CLA CLL /FLUSH
DCA FF /PUT FPP IN SI MODE
JMS PWFECH /GET NEXT PSEUDO-INSTRUCTION
DCA INSAV /SAVE FOR LATER
JMS I [XPRINT /CALL TO TTY DRIVER
NOP
TAD INSAV
AND [7400 /STRIP TO OPCODE BITS
CLL RTL
RTL
RAL /OPCODE NOW IN BITS 8-11
TAD O7770 /SUBTRACT 10
SMA /IS OPCODE <10?
JMP SCASE /CALL TO INSTRUCTION COMMON TO SMODE AND AMODE
DCA TEMP1 /YES-SAVE THE OFFSET
TAD MODESW /WHICH MODE?
SZA CLA
JMP SMODE /STRING MODE
TAD TEMP1 /ARITHMETIC MODE-GET OFFSET
TAD JMSI /MAKE JMS TO FP PACKAGE ROUTINE
DCA .+2 /PUT IN LINE
JMS ARGPRE /SET UP ARGUMENT FROM SYMBOL TABLE
ILOOPF, . /JMS TO THE FLOATING POINT PACKAGE ROUTINE
NOP /FPP SOMETIMES RETURNS TO CALL+2
JMP ILOOP /DONE
SCASE, TAD JMPI /JUST DISPATCH TO ROUTINE CALLED FOR
DCA .+1
. /JUMP TO APPROPRIATE ROUTINE
JMSI, JMS I SEP1 /JMS USED FOR CALLS TO FPP BY AMODE INST
JMPI, JMP I SEP1 /JMP USED TO CALL ROUTINES COMMON TO AMODE AND SMODE
/JUMP TABLE FOR AMODE INSTRUCTIONS
FFADD /FAC_C(A)+FAC OPCODE 0
FFSUB /FAC_FAC-C(A) OPCODE 1
FFMPY /FAC_FAC*C(A) OPCODE 2
FFDIV /FAC_FAC/C(A) OPCODE 3
FFGET /FAC_C(A) OPCODE 4
FFPUT /C(A)_FAC OPCODE 5
FFSUB1 /FAC_C(A)-FAC OPCODE 6
FFDIV1 /FAC_C(A)/FAC OPCODE 7
/ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE
SEP1, LS1I /S1_C(A) OPCODE 10
LS2I /S2_C(A) OPCODE 11
FJOCI /IF TRUE,PC_C(PC,PC+1) OPCODE 12
JEOFI /IF EOF,PC_C(PC,PC+1) OPCODE 13
LINEI /LINE NUMBER OPCODE 14
ARRAYI /ARRAY INST OPCODE 15
ILOOP /NOP OPCODE 16
OPERI /OPERATE INST OPCODE 17
SMODE, TAD TEMP1 /INST OFFSET
TAD JMSSI /BUILD JMP OFF STRING TABLE
DCA SDIS /PUT IN LINE
CLL /STRING SCALAR TABLE
JMS I STFINL /SET UP ARGUMENT ADDRESS
SDIS, . /CALL STRING ROUTINE REQUESTED
/JUMP TABLE FOR SMODE INSTRUCTIONS
/ A "/*" IN THE COMMENT MEANS THAT THAT OPCODE IS NOT USED,SO WE
/USE THE SLOT FOR REGULAR STORAGE
SCON1 /SAC_SAC&C(A$)
SCOMP /IF SAC .NE. C(A$),PC_PC+2
SREAD /C(A$)_DEVICE
INTPC, . /* INTERPRETER PC
SLOAD /SAC_C(A$)
SSTORE /C(A$)_SAC
STFINL, STFIND /* LINK TO STRING FINDING ROUTINE
JMSSI, JMP I .+1 /* DISPATCH JUMP FOR SMODE INSTRUCTIONS
/ARGPRE-ROUTINE TO TRANSLATE OPERAND FIELD INTO 12 BIT POINTER
/INTO SCALAR TABLE FOR USE IN FPP CALLS.
ARGPRE, 0
TAD INSAV /GET INSTRUCTION
AND [377 /STRIP TO OPERAND FIELD
DCA TEMP1 /SAVE
TAD TEMP1
CLL RAL /*2
TAD TEMP1 /PTR*3
TAD SCSTRT /MAKE 12 BIT ADDR
SCALDF, 1000 /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER)
JMP I ARGPRE /RETURN
/ROUTINE TO ZERO FAC
FACCLR, -4
L7600, 7600 /CLA
DCA ACX /ZERO EXPONENT
DCA ACL /ZERO LOW MANTISSA
DCA ACH /ZERO HIGH MANTISSA
JMP I FACCLR
/STRING ACCUMULATOR USED BY STRING OPCODES AND FUNCTIONS
/CONTAINS ONE 6BIT CHAR PER WORD
START1,
SAC, OSR
SZA CLA
NOP /A HLT PLACED HERE WILL ALLOW YOU TO STOP
/MACHINE BEFORE RUNTIME SYSTEM STARTS BY
/SETTING SWITCH REGISTER
TLS /SET TTY FLAG
ISZ SPINNR /SPIN RANDOM NUMBER SEED
NOP /WHILE WAITING FOR INITIALIZING TLS
TSF /FLAG UP YET?
JMP .-3 /NO
TAD CDFIO
DCA I PS1L /SET UP CDFS IN PSWAP
TAD CDFIO
DCA I PS2L
JMS I PFUDSC /SWAP 17600 IN IF NOT ALREADY IN AND SAVE SCOPE FLAG
JMS I CDFPSU
TAD SCALDF /SET PROG NOT RESTARTABLE BIT
DCA I L7746 /TELL USR TO SAVE 1000-1777
TAD PINFO /POINTER TO INFO TABLE IN 17600
DCA XR1
TAD POVTAB /POINTER TO BLOCK TABLE IN OVERLAY DRIVER
DCA XR2
TAD FACCLR /WE HAVE TO GET 4 BLOCK NUMBERS
DCA TEMP1
OVML, CDF 10
TAD I XR1 /GET BLOCK NUMBER FOR THIS OVERLAY FROM INFO AREA
CDF
DCA I XR2 /PUT IN TABLE IN OVERLAY DRIVER
ISZ TEMP1 /DONE?
JMP OVML /NO
JMS I [PSWAP /SWAP 17600 BACK TO HIGH CORE NOW
JMP I .+1
START3 /CONTINUE THE INITIALIZING CODE IN INTERMEDIATE BUFFER
L7746, 7746
PINFO, 7607
POVTAB, ARITHA-1
PS1L, P1CDF
PS2L, P1CDF1
PFUDSC, FUDSC
PAGE
FUDSC, 0
TAD PSFLAG /TEST WHERE 17600 IS LOCATED
SMA CLA
TAD [200 /IF NOT TD8E USE 7600
TAD [7400 /IF TD8E USE 7400
DCA I PHICORE /STORE FOR SWAPPER
CLA IAC
AND PSFLAG
SNA CLA /SKP IF PAGE 17600 IS ALREADY IN
JMS I [PSWAP /ELSE BRING IT IN
CDF 10
TAD I PSCOPW
CDF
AND [200 /GET SCOPE BIT FROM RES MONITOR
DCA I PSCOPF
TAD I PHEIGHT
DCA I PHCTR /NOW INITIALIZE THE SCREEN HEIGHT COUNTER
JMP I FUDSC /RETURN
PHEIGHT,HEIGHT
PHCTR, HCTR
PSCOPW, SCOPWD
PSCOPF, SCOPFG
PHICOR, HICORE
*SAC+SACLIM+1 /ORIGIN PAST SAC+ONE GUARD CHAR
/JUMP ON CONDITION
FJOCI, TAD INSAV /GET JUMP INSTRUCTION
AND [17 /MASK OFF JUMP CONDITION
SNA /IS IT GOSUB?
JMP I (GOSUB /YES-PUSH PC ON STACK THEN JUMP
TAD FSTOPI /BASE TAD FOR BUILD OF TAD INSTRUCTION
DCA .+1 /PUT IN LINE
. /GET PROPER SKIP
DCA .+2 /PUT IN LINE
TAD ACH /GET HIGH ORDER FAC
. /SKIP INSTRUCTION
JMP SUCJMP /CONDITION TRUE-JUMP
JFAIL, JMS I [PWFECH /CONDITION FALSE-DON'T JUMP,BUT BUMP PC
JMP I [ILOOP /DONE
/JUMP ON END OF FILE
JEOFI, JMS I [IDLE /SEE IF FILE OPEN
TAD I IOTHDR /1ST WORD OF I/O TABLE ENTRY
CLL RTR /GET EOF BIT IN LINK
SNL CLA /EOF?
JMP JFAIL /NO-DON'T JUMP
/YES, FALL INTO JUMP ROUTINE
SUCJMP, JMS I [PWFECH /GET WORD FOLLOWING JUMP INS.
DCA I INTPCL /STORE AS NEW PC
TAD INSAV /GET JUMP INSTRUCTION
AND [340 /MASK OFF DESTINATION FIELD
CLL RTR /SLIDE OVER
TAD CDFINL /MAKE A CDF INSTRUCTION
DCA I [CDFPSU /AND SET NEW PC INSTRUCTION FIELD
JMP I [ILOOP /NEXT INSTUCTION
K7554, 7554 /MUST PRECEDE SKIP TABLE
/SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS
K7600, 7600 /UNCONDITIONAL (CLA)
SMA CLA /JPA
SZA CLA /JNA
SMA SZA CLA /JPA JNA
SPA CLA /JMA
SNA CLA /JZA
SPA SNA CLA /JMA JZA
JMP I JFORL /FORLOOP JUMP ROUTINE
JFORL, JFOR
INTPCL, INTPC
0000;0 /MARK BEGINNING OF GOSUB STACK
GSTCK, 6000;0
6000;0
6000;0
6000;0
6000;0
6000;0
6000;0
6000;0
6000;0
0 /MARK THE END OF THE GOSUB STACK
/CALL TO DEVICE DRIVER FOR FILE I/O. ASSUMES ARGS HAVE BEEN SET UP
DRCALL, 0
DCA DRARG1 /FUNCTION WORD INTO DRIVER CALL
CDFINL, CDF /DF TO CURRENT FIELD
TAD I IOTBUF /GET BUFFER ADDRE FROM I/O TABLE ENTRY
DCA DRARG2 /PUT IN DRIVER CALL
TAD I IOTBLK /GET BLOCK NUMBER FROM I/O TABLE
DCA DRARG3 /PUT IN DRIVER CALL
TAD I IOTHND /GET DRIVER ENTRY
DCA DRIVER /SAVE
JMS I DRIVER /CALL DRIVER
DRARG1, 0 /FUNCTION CONTROL WORD
DRARG2, 0 /BUFFER ADDRESS
DRARG3, 0 /BLOCK #
SMA CLA /DEVICE ERROR-IS IT FATAL?
JMP I DRCALL /ALLS WELL
DE, JMS I [ERROR /FATAL
DRIVER, 0
/CALL TO INTERPRETER EXITING ROUTINE
FSTOPN, JMS I [XPRINT /ON NORMAL EXITS,WE MUST EMPTY RING BUFFER
JMP .-1 /FIRST
FSTOPI, TAD K7554
DCA INSAV /FAKE A CALL TO BASIC.FF FUNCTION 6
JMP I .+1 /CALL OVERLAY
FUNC5I
/USE FUNCTION-TAKES WORD FOLLOWING CALL AND STUFFS IT IN USECON FOR
/USE A BUFFER POINTER FOR USER SUBROUTINE
USE, JMS I [PWFECH /GET NEXT WORD FROM PSEUDO-CODE STREAM
DCA USECON /STORE IN PAGE 0 SLOT
JMP I [ILOOP /RETURN
PAGE
/ARRAY INSTRUCTIONS
/ARRAY INSTRUCTIONS WORK BY FINDING THE ADDRESS OF THE ARGUMENT FROM THE ARRAY SYMBOL
/TABLE,THEN CALLING THE APPROPRIATE FLOATING POIN PACKAGE ROUTINE.
ARRAYI, TAD MODESW /WHICH MODE?
SZA CLA
JMP SARRAY /SMODE
TAD INSAV /GET ARRAY INSTRUCTION
AND K0037 /MASK OFF ARRAY OPERAND
CLL RTL /MULTIPLY BY 4 (ENTRY LENGTH)
TAD ARSTRT /MAKE POINTER INTO ARRAY TABLE
DCA XR1 /POINTS TO ARRAY FOR THIS OPERATION
ATABDF, . /CHANGE DF TO ARRAY TABLE FIELD (SET BY START)
TAD I XR1 /GET POINTER TO FIRST ARRAY ELEMENT
DCA TEMP2 /SAVE FOR LATER
TAD I XR1 /GET DF FOR VARIABLE
DCA ADFC /PUT IN LINE AT END OF ROUTINE
TAD I XR1 /GET ARRAY DIMENSION 1
DCA TEMP3 /SAVE
TAD S1 /GET SUBSCRIPT 1
CLL CMA /SET UP 12 BIT COMPARE
TAD TEMP3 /DIMENSION 1 +1
SNL CLA /S1 TOO BIG?
SU, JMS I [ERROR /YES-SUBSCRIPT OUT OF BOUNDS ERROR
DCA TEMP6 /CLEAR TEMPORARY
TAD I XR1 /GET DIMENSION 2
SNA /IS SECOND DIMENSION 0?(ARRAY UNIDIMENSIONAL)
JMP ADCALC /YES-DON'T CHECK S2 FOR OUT OF BOUNDS
DCA ARJMP /SAVE DIM2+1
TAD S2 /GET SUBSCRIPT 2
CLL CMA /SAVE 12 BIT COMPARE
TAD ARJMP
SNL CLA /S2 BIGGER THAN DIM2?
JMP SU /YES
TAD S2 /MULTIPLY DIM1+1 BY S2
JMS I [MPY /12 BY 12 MULTIPLY ROUTINE
ADCALC, CLL
TAD S1 /LORD OF S1+(DIM1+1)*S2
DCA TEMP5 /SAVE
RAL /CARRY TO BIT 11
TAD TEMP6 /HORD OF S1+(DIM1+1)*S2
DCA TEMP6 /SAVE
TAD TEMP5 /LORD OF S1+(DIM1+1)*S2
CLL RAL /*2
DCA TEMP7 /LORD OF [S1+(DIM1+1)*S2]*2
TAD TEMP6 /HORD OF S1+(DIM1+1)*S2
RAL /*2
DCA TEMP3 /HORD OF [S1+(DIM1+1)*S2]*2
CLL
TAD TEMP5 /LORD OF S1+(DIM1+1)
TAD TEMP7 /LORD OF [S1+(DIM1+1)*S2]
DCA TEMP7 /LORD OF 3*[S1+(DIM1+1)*S2]
RAL /CARRY TO BIT 11
TAD TEMP6 /HORD OF [S1+(DIM1+1)*S2)*2
TAD TEMP3 /HORD OF S1+(DIM1+1)*S2
DCA TEMP6 /HORD OF 3*[S1+(DIM1+1)*S2]
CLL
TAD TEMP7 /INDEX TO ELEMENT
TAD TEMP2 /AC POINTS TO CORRECT ARRAY ELEMENT
DCA XR1 /SAVE POINTER
RAL /CARRY TO BIT 11
TAD TEMP6 /COMBINE TO MAKE TOTAL # OF FIELD OVERLAPS
CLL RTL
RAL /SLIDE OVERLAPS TO FIELD BITS (6-8)
TAD ADFC /ADD ANY CHANGE IN DATA FIELD TO CDF
DCA ADFC /PUT ABSOLUTE CDF IN LINE
TAD INSAV /GET ARRAY INSTRUCTION AGAIN
AND [340 /MASK OFF ARRAY OPCODE
CLL RTR
RTR
RAR /SLIDE TO BITS 9-11
TAD JMPI2 /AND USE AS INDEX INTO JUMP TABLE
DCA ARJMP /PUT JUMP IN LINE OF CODE
IAC
DCA FF /PUT FPP IN "SPECIAL MODE"
ADFC, . /CHANGE DF TO DF OF ARRAY ELEMNT
TAD XR1 /AC POINTS TO ARRAY ELEMENT
ARJMP, . /PERFORM THE REQUIRED OPERATION
NOP /FPP SOMETIMES RETURNS TO CALL+2
JMP I [ILOOP /DONE
/ARRAY JUMP TABLE
AJT, FFSUB1 /FAC=A(S1,S2)-FAC OPCODE 0
FFADD /FAC=FAC+A(S1,S2) OPCODE 1
FFSUB /FAC=FAC-A(S1,S2) OPCODE 2
FFMPY /FAC=FAC*A(S1,S2) OPCODE 3
FFDIV /FAC=FAC/A(S1,S2) OPCODE 4
FFGET /FAC=C(A(S1,S2) OPCODE 5
FPUTLL, FFPUT /C(A(S1,S2)=FAC OPCODE 6
FFDIV1 /FAC=A(S1,S2)/FAC OPCODE 7
/STRING ARRAY DISPATCH
SARRAY, TAD INSAV /GET INSTRUCTION
AND [340 /ISOLATE ARRAY OPCODE
CLL RTR
RTR /AND SLIDE IT OVER FOR AN OFFSET
RAR
TAD JMPISA /BUILD A JUMP TO STRING INSTRCUTION
DCA SAD /AND PUT IN LINE
STL /TELL SFIND TO USE ARRAY TABLE
JMS I STFILK /SET UP ARGUMENT ADDRESS
SAD, . /EXECUTE INSTRCUTION
/STRING ARRAY JUMP TABLE
/USED WHEN ARRAYI CALLED IN SMODE
/ A "/*" IN THE COMMENT MEANS THAT OPCODE IS UNDEFINED AND THE SLOT
/IN THE TABLES IS USED FOR NORMAL STORAGE
JMPISA, JMP I .+1 /DISPATCH JUMP FOR STRING ARRAY INSTRUCTIONS
SCON1 /SAC_SAC&C(A$(S1))
SCOMP /SKIP IF SAC=C(A$(S1))
SREAD /A$(S1)_DEVICE
K0037, 37 /*
STFILK, STFIND /* LINK TO STRING FINDING ROUTINE
SLOAD /SAC_C(A$(S1))
SSTORE /C(A$(S1))_SAC
JMPI2, JMS I AJT /* DISPATCH JUMP FOR ARRAY INST
/ROUTINE TO PUT ONE WORD IN FILE BUFFER IN FIELD 1
BCPUT, 0
DCA TEMP6 /SAVE AC
JMS I [IDLE /CHECK IF FILE OPEN
TAD I IOTPTR /GET READ/WRITE POINTER
DCA TEMP7 /SAVE
TAD ENTNO /GET FILE #
SZA CLA /IF TTY,BUFFER FIELD IS 0
CDF 10
TAD TEMP6 /GET WORD TO STORE AGAIN
DCA I TEMP7 /STORE IT IN BUFFER
CDF0, CDF
TAD I IOTHDR /HEADER WORD
AND (7737 /TURN OFF BLOCK WRITTEN BIT
TAD (40 /TURN IT ON AGAIN
DCA I IOTHDR
JMP I BCPUT /RETURN
PAGE
/TELETYPE DRIVING ROUTINE
/2 ENTRY POINTS-XPUTCH PUTS A CHARCTER IN THE RING BUFFER
/ XPRINT TYPES A CHARACTER IF POSSIBLE
/ AND RETURNS TO CALL+1 IF THERE
/ ARE MORE CHARCTERS IN THE BUFFER,CALL+2
/ IF THE BUFFER IS EMPTY
/THE IDEA IS THE PLACE CALLS TO XPRINT AT VARIOUS POINTS IN THE INTER-
/PRETER AND THUS KEEP THE TTY BUSY WITHOUT WASTING THE TIME WAITING FOR
/THE TTY FLAG. THE SUCCESS OF THIS SCHEME DEPENDS HEAVILY ON THE NUMBER
/AND PLACEMENT OF THE CALLS TO XPRINT.
XPUTCH, 0
DCA CHRSAV /SAVE THE CHARACTER
XPUT1, ISZ SPINNR /SPIN RANDOM # SEED
JMS XPRINT /START A CHAR IF POSSIBLE
NOP
TAD BCNT /GET THE NUMBER OF AVAILABLE SLOTS
SNA CLA /ARE THERE ANY?
JMP XPUT1 /NO-TRY TO RPINT 1 AND FREE UP A SPACE
PUTCHR, TAD CHRSAV /GET CHARACTER AGAIN
DCA I BUFIN /PUT CHARACTER IN RING BUFFER
ISZ BUFIN /BUMP BUFEER POINTER OF INPUT
CLA CLL CMA /-1 IN AC
TAD BCNT /DECREMENT AVAILABLE SLOT COUNT
DCA BCNT
TAD BUFIN /GET BUFFER INPUT POINTER
TAD MBEND /SUBTRACT ADDR OF END OF BUFFER
SPA SNA CLA /PAST EDN OF BUFFER?
JMP I XPUTCH /NO-RETURN
TAD BSTRTA /YES-RESET INPUT POINTER TO BEGINNING OF BUFFER
DCA BUFIN
JMP I XPUTCH /RETURN
BUFIN, BSTRT /POINTER TO NEXT SLOT FOR BUFFER INPUT
BUFOUT, BSTRT /POINTER TO NEXT CHARACTER TO BE PRINTED
BSTRTA, BSTRT /ADDR OF START OF TTY BUFFER
BCNT, 30 /# OF AVAILABLE SLOTS IN BUFFER (40 INITIALLY)
CHRSAV=TEMP1
MBEND, -BEND /-ADDR OF END OF RING BUFFER
MCTRLC, -3
M50, -30
MXON, -21+3
MXOFF, -23+21
XFLAG, 0
XPRINT, 0
KSF /IS KEYBOARD FLAG UP?
JMP NOCC /NO-NO CHANCE FOR A CTRL/C
KRB /YES-GET THE CHAR IN KEYBOARD BUFFER
AND [177 /GET RID OF PARAITY
TAD MCTRLC /IS IT CTRL/C
SNA
JMP I FSTOP1 /YES-ABORT TO EDITOR
TAD MXON
SZA
JMP .+3
DCA XFLAG
JMP NOCC+3
TAD MXOFF
SZA CLA
JMP NOCC
ISZ XFLAG
JMP XPRINT+1
NOCC, TAD XFLAG
SZA CLA
JMP XPRINT+1
TAD BCNT /# OF AVAILABLE SLOTS IN BUFFER
TAD M50 /IS BUFFER EMPTY?
SNA CLA
JMP RECP2 /YES-RETURN TO CALL+2
TSF /NO-TTY FLAG UP YET?
JMP I XPRINT /NO-GO ABOUT YOUR BUSINESS
TAD I BUFOUT /GET NEXT CHARACTER
/*****************************************************************:
/N.B. BECAUSE OF THE ABOVE INSTRUCTION,THE DF MUST BE SET TO THE
/INTERPRETER FIELD WHENEVER XPRINT IS CALLED. WATCH YOUR HOOK PLACEMENT!
/****************************************************************:
JMS I (PCH /TYPE THE CHAR
ISZ BUFOUT /BUMP BUFFER OUTPUT POINTER
TAD BUFOUT /GET OUTPUT POINTER
TAD MBEND /SUBTRACT END OF BUFFER
SPA SNA CLA /IS OUTPUT POINTER PAST END?
JMP BOUTRS /NO-FREE UP A SPOT
TAD BSTRTA /YES-RESET POINTER TO BEGINNING
DCA BUFOUT
BOUTRS, ISZ BCNT /INCREMENT # OF FREE SLOTS (WE JUST PRINTED ONE)
JMP I XPRINT /RETURN
RECP2, ISZ XPRINT /BUMP RETURN
JMP I XPRINT /RETURN TO CALL+2 FOR EMPTY BUFFER
/TELETYPE RING BUFFER
BSTRT, "B /START OF BUFFER
"R
"T
"S
"
"V
VERLOC, 260+VERSON
300+SUBVER
0215
0212
VEREND, 0212
VCHECK, 0
CDF 10
TAD I N7644
CDF 0
AND XR4
SNA CLA
JMP I VCHECK
TAD XR1
DCA BUFIN
TAD SACXR
DCA BCNT
JMP I VCHECK
BEND,
N7644, 7644
/LINE NUMBERS
LINEI, TAD INSAV /GET INSTRUCTION
DCA LINEHI /SAVE
JMS I [PWFECH /GET WORD FOLLOWING LINE # INST
DCA LINELO /SAVE AS LOW ORDER LINE #
TRHOOK, JMP I [ILOOP /RETURN TO I-LOOP
TAD KC240 /IF TRACE IS ON,FAKE CALL
DCA INSAV /TO FUNC2,#12
JMP I .+1
FUNC2I /DISPATCH TO TRACE FUNCTION
/INTERMEDIATE TTY BUFFER
/USED TO BUFFER OUTPUT FROM FPP BEFORE WE PUT IT
/IN BASIC FORMAT FOR TRANSPORTATION TO THE TTY RING
/BUFFER
KC240, 240 /STOPPER TO MARK BEGINNING OF BUFFER
INTERB,
START3, TAD CDFPS /CDF FOR PSEUDO-CODE
DCA I [CDFPSU /PUT IN-LINE TO ILOOP
TAD PSSTRT /START OF PSEUDO-CODE
DCA I INTPCK /PUT INTO PC
JMS I [FACCLR /ZERO FAC
TAD CDFIO /CDF FOR SYMBOL TABLE FIELD
DCA I STDFL /PUT IN LINE FOR STRING FUNCTIONS
FPPTM5, TAD CDFIO /CDF FOR SYMBOL TABLES
DCA I ATABDL /PUT IN LINE FOR ARRAY CALCULATIONS
TAD CDFIO /CDF FOR SCALAR TABLE
FPPTM4, DCA I SCALDL /PUT IN LINE FOR ARGPRE
TAD CDFIO
DCA I DLCDFL /DATA FIELD FOR DATA LIST
FPPTM3, TAD DLSTRT
DCA DATAXR /DO A RESTORE IN INCORE DATA LIST
JMP I .+1 /CONTINUE INITAILIZATION CODE IN TTY INPUT BUFFER
FPPTM2, START4
ATABDL, ATABDF
STDFL, STDF
FPPTM1, /FLOATING POINT TEMPORARY
INTPCK, INTPC
DLCDFL, DLCDF
SCALDL, SCALDF
PAGE
/VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE)
HEIGHT, 0 /NEGATIVE SCREEN HEIGHT
DELAY, 0 /NEGATIVE DELAY VALUE
IFNZRO HEIGHT-1200 <__FIX SET COMMAND__>
HCTR, 0 /HEIGHT COUNTER INITIALIZED BY SET
DCTR, 0 /DELAY COUNTER INITIALIZED BY SET
/LOW LEVEL ROUTINE TO TYPE A CHAR
PCH, 0
TSF /WAIT FOR PREV CHAR
JMP .-1
TLS /TYPE THE CURRENT ONE
AND [177 /MASK TO 7BIT
TAD (-15 /TEST IF LINE FEED WILL BE SENT NEXT
SZA CLA
JMP I PCH /RETURN IF NOT
ISZ HCTR /TEST SCREEN HEIGHT IF LF
JMP I PCH /RETURN IF NOT AT BOTTOM OF SCREEN
TAD HEIGHT
DCA HCTR /RESET HEIGHT COUNTER NOW
TAD DELAY
SNA /TEST FOR ZERO DELAY
JMP I PCH /RETURN IF SO
DCA DCTR /ELSE SET DELAY COUNTER
DLOOP, ISZ PSWAP /NOW EXEC INNER LOOP 4096 TIMES (USUALLY)
JMP .-1
KSF /TEST IF KEY STRUCK
SKP
JMP I PCH /RETURN AT ONCE IF YES
ISZ DCTR /TEST DELAY TIMER
JMP DLOOP /REITERATE
JMP I PCH /NOW ALLOW PRINTING TO CONTINUE
/OPERATE CLASS INSTRUCTIONS
OPERI, TAD INSAV /GET OPERATE INSTRUCTION
AND [17 /MASK OFF OPERATE OPCODE
TAD JMPI3 /BUILD JUMP OFF OPERATE JUMPTABLE
DCA .+1 /STORE THE JUMP IN LINE
. /DISPATCH TO PROPER OPERATE ROUTINE
JMPI3, JMP I .+1 /JUMP TO OPERATE ROUTINE CALLED FOR
/OPERATE JUMP TABLE
FUNC3I /CALL RESIDENT FUNCTION OPCODE 0
SPFUNC /SPECIAL FUNCTIONS OPCODE 1
SFN /SET FILE NUMBER OPCODE 2
FNEGI /NEGATE FAC OPCODE 3
RETRNI /GOSUB RETURN OPCODE 4
RESTOR /RESTORE DEVICE OPCODE 5
LSUB1I /LOAD S1 FROM FAC OPCODE 6
LSUB2I /LOAD S2 FROM FAC OPCODE 7
MSPACE, 20 /THIS OPCODE NOT DEFINED,SO WE PUT A CONST HERE
READI /READ DEVICE OPCODE 11
WRITEI /WRITE DEVICE OPCODE 12
SWRITE /STRING WRITE OPCODE 13
FUNC5I /CALL FILE FUNCTION OPCODE 14
FUNC4I /CALL USER FUNCTION OPCODE 15
FUNC1I /CALL FUNCTIONS 1 OPCODE 16
FUNC2I /CALL FUNCTIONS 2 OPCODE 17
/ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE)
/WHERE N IS THE HIGH CORE FIELD
PSWAP, 0
TAD KK7600 /POINTER TO 17600 AND COUNTER
DCA TEMP1
TAD PSFLAG /GET SWAPPING FLAGS
RAR
CML RAL /TOGGLE THE INPLACE BIT
DCA PSFLAG /STORE IT BACK
TAD HICORE /PICK UP ADDR OF HIGH CORE
DCA TEMP2 /POINTER TO HIGH CORE
P1CDF, HLT /DF TO HI CORE
TAD I TEMP2 /GET WORD FROM HI CORE
DCA TEMP4 /SAVE IT
P2CDF, CDF 10
TAD I TEMP1 /GET WORD FROM 17600
P1CDF1, HLT /DF TO HI CORE AGAIN
DCA I TEMP2 /PUT 17600 WORD IN HI CORE
P2CDF1, CDF 10
TAD TEMP4 /GET SAVED HI CORE WORD
DCA I TEMP1 /AND PUT IN 17600
ISZ TEMP2 /BUMP HI CORE POINTER
KK7600, 7600 /CLA
ISZ TEMP1 /BUMP 17600 POINTER AND CHECK FOR DONE
JMP P1CDF /NO DONE-MOVE NEXT WORD
CDF
JMP I PSWAP /DONE-RETURN
HICORE, 0 /POINTS TO LOCATION OF 17600 SAVE AREA
IFNZRO EAE <
/TEMPORARY INCLUSION FOR FFOUT
/ADD OP TO FAC
OADD, 0
CLL
TAD AC2
TAD AC1
DCA AC1 /ADD GUARD BITS
RAL
TAD OPL
TAD ACL
DCA ACL /ADD LOW ORDER BITS
RAL
TAD OPH
TAD ACH
DCA ACH /ADD HIGH ORDER BITS
JMP I OADD
/SHIFT FAC LEFT 1 BIT
AL1, 0
TAD AC1
CLL RAL
DCA AC1
TAD ACL
RAL
DCA ACL
TAD ACH
RAL
DCA ACH
JMP I AL1
>
PAGE
/LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY
LSUB2I, ISZ DCASUB
JMP LSUB1I
LS2I, ISZ DCASUB
LS1I, JMS I [FACSAV /PRESERVE FAC
JMS I ARGPRL /GET ARG POINTER INTO AC
JMS I [FFGET /LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN)
LSUB1I, JMS I [FACSAV /SAVE THE FAC
JMS I [UNSFIX /GET INT(FAC)
DCASUB, DCA S1 /SET RESULT AS SUBSCRIPT 1
JMS I [FACRES /RESTORE FAC
TAD DCAS1
DCA DCASUB /FUDGE INSTR BACK
JMP I [ILOOP /NEXT INSTRCUTION
DCAS1, DCA S1
ARGPRL, ARGPRE
/JMP DISPATCH FOR FUNC1 CALLS
JMSI4, JMS I .+1 /CALL FOR CANNED FUNCTION SET 1
/JUMP TABLE FOR FUNCTION CALL 1
ATAN /FUNCTION BITS= 0
COS / 1
EXPON1 / 2
EXPON / 3
INT / 4
LOG / 5
SGN / 6
SIN / 7
RND / 10
FROOT / 11
/JUMP FOR FUNC2 DISPATCH
JMSI5, JMP I .+1 /JMP OFF THE SET 2 TABLE
/JUMP TABLE FOR FUNCTION SET 2
ASC /FUNCTION BITS= 0
CHR / 1
DATE / 2
LEN / 3
POS / 4
SEG / 5
STR / 6
VAL / 7
ERRORR / 10
/ERRORR MUST BE FUNCTION #10,ELSE "ERROPC" MUST CHANGE
TRACE / 11
TPRINT / 12
/TPRINT MUST BE #12 OR TRHOOK+1 MUST CHANGE
/DISPATCH FOR FUNC5 CALLS
JMPFIL, JMP I .+1 /CALL FORR FILE MANIPULATING FUNCTIONS
/JUMP TABLE FOR FILE FUNCTIONS
CHAIN /FUNCTION BITS= 0
CLOSE / 1
OPENAF / 2
OPENAV / 3
OPENNF / 4
OPENNV / 5
FSTOP /INT. EXIT 6
/ERROR CALL FOR USER FUNCTIONS-USER FUNCTION SHOULD "JMS I (IA"
IA, JMS I [ERROR
/FUNCTION OVERLAY DRIVER
FUNC4I, JMS I [XPRINT /PURGE TTY RING BUFFER
JMP .-1 /BEFORE CALLING USER FUNCTION
IAC /LOOK FOR OVERLAY FLAG=3
FUNC5I, IAC /LOOK FOR OVERLAY FLAG=2
FUNC2I, IAC /LOOK FOR OVERLAY FLAG=1
FUNC1I, DCA TEMP1 /LOOK FOR OVERLAY FLAG=0
CDF /DF TO THIS FIELD
TAD TEMP1 /GET OVERLAY # AGAIN
CIA /NEGATE
TAD OVRLAY /COMPARE AGAINST OVERLAY FLAG
SNA CLA /IS THE ONE WE WANT ALREADY RESIDENT?
JMP OVDNE /YES-JUST JUMP TO FUNCTION
TAD TEMP1 /NO-GET NUMBER OF OVERALY DESIRED
TAD OATADI /USE AS OFFSET TO BUILD STARTING BLOCK TAD
DCA TEMP2 /POINTS TO PROPER STARING BLOCK #
TAD I TEMP2 /GET STARTING BLOCK FOR THIS OVERLAY
DCA OVADD /PUT IN DRIVER CALL
JMS I L7607 /CALL SYSTEM HANDLER
0500 /OVERLAY 3400-4600
3400
OVADD, . /STARTING BLOCK # OF OVERLAY
OE, JMS I [ERROR /I/O ERROR
TAD TEMP1
DCA OVRLAY /CHANGE RESIDENT FLAG
OVDNE, TAD [SAC-1 /ENTER STRING FUNCTIONS WITH SACXR SET UP
DCA SACXR
TAD TEMP1 /FUNCTION #
TAD JMSTAD /BUILD A TAD OF THE PROPER DISPATCH JMS
DCA .+2 /PUT IN LINE
JMS I [FBITGT /GET # OF FUNCTION DESIRED
. /BUILD JUMP OFF JUMP TABLE
FUJUMP, DCA .+1 /PUT JUMP IN LINE
. /GO TO DESIRED FUNCTION
JMP I [ILOOP /DONE
OATADI, ARITHA
L7607, 7607
OVRLAY, 0 /# OF CURRENTLY RESIDENT OVERLAY
/0=ARITHMETIC,1=STRING,2=FILE,3=USER
/OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS
/INITIALIZED BY LOADER
ARITHA, . /STARTING BLOCK OF ARITHMETIC OVERLAY
STRNGA, . /STARTING BLOCK OF STRING OVERLAY
FILEFA, . /STARTING BLOCK OF FILE OVERLAY
USRA, . /STARTING BLOCK OF USER FUNCTIONS
JMSTAD, TAD I TADTAB
TADTAB, JMSI4
JMSI5
JMPFIL
JMSUSR
/CALL FOR RESIDENT FUNCTION
FUNC3I, JMS I [FBITGT /ISOLATE FUNCTION #
TAD JMSI7 /MAKE A JUMP OFF JUMP TABLE
JMP FUJUMP /PUT THE JUMP IN LINE AND EXECUTE IT
JMSI7, JMP I .+1
/JUMP TABLE FOR RESIDENT FUNCTIONS
XABSVL /FUNCTION BITS= 0
COMMA / 1
CRFUNC / 2
ILOOPF / 3
TAB / 4
PNT / 5
USE / 6
*1557 /****N.B.****
/THIS TABLE CANNOT BE MOVED!!!!
/JUMP DISPATCH FOR USER ROUTINES
JMSUSR, JMS I .+1
/JUMP TABLE FOR USER FUNCTIONS
ILOOPF /USER FUNCTION 1
ILOOPF / 2
ILOOPF / 3
ILOOPF / 4
ILOOPF / 5
ILOOPF / 6
ILOOPF / 7
ILOOPF / 8
ILOOPF / 9
ILOOPF / 10
ILOOPF / 11
ILOOPF / 12
ILOOPF / 13
ILOOPF / 14
ILOOPF / 15
ILOOPF / 16
PAGE
/SPECIAL FUNCTIONS
SPFUNC, JMS I [FBITGT /ISOLATE FUNCTION BITS
TAD JMPI6 /MAKE A JUMP OFF SPECIAL FUNCTION TABLE
DCA .+1 /PUT IN LINE
.
JMPI6, JMP I .+1 /JUMP TO SPECIAL FUNCTION ROUTINE
/SPECIAL FUNCTION JUMP TABLE
SETF /SET FSWITCH 0
FRANDM /RANDOMIZE 1
FSTOPN /LEAVE INTERPRETER 2
SRLIST /STRING READ FROM DATA LIST 3
CSFN /SET FILE # TO TTY 4
RDLIST /READ DATA LIST 5
AMODE /SWITCH TO A MODE 6
SSMODE /SWITCH TO S MODE 7
/SUBROUTINE UNSFIX-UNSIGNED INTEGER FIX ROUTINE. FIXS A POSITIVE 12 BIT
/NUMBER OUT OF FAC MANTISSA AND LEAVES RESULT IN AC.RESULT IS AN UNSIGNED,
/12 BIT INTEGER
UNSFIX, 0
CDF 0
TAD ACL /LOW MANTISSA
CLL RAL /HI BIT OF LO MANTISSA TO LINK
CLA
TAD ACH /HIGH MANTISSA
SPA /IS NUMBER POSITIVE?
FM, JMS I [ERROR /NO-BOO!!!
RAL /SHIFT THE SIGN BIT OUT AND THE MANTISSA OVER,
DCA ACH /MAKING 12 BITS OF MANTISSA AND BINARY POINT BEFORE BIT 0
TAD ACX /GET EXPONENT
SPA SNA CLA /IS X>1?
JMP I UNSFIX /NO-FIX IT TO 0
TAD ACX /YES-GET EXPONENT
TAD [-14 /SET BINARY POINT AT 12
SNA /DONE ALREADY?
JMP UNSOUT /YES
SMA /NO-IS # TOO BIG?
FO, JMS I [ERROR /YES
DCA ACX /NO-STORE COUNT
TAD ACH /HI MANTISSA
UNSLP, CLL RAR /SCALE RIGHT
ISZ ACX /DONE?
JMP UNSLP /NO
JMP I UNSFIX /YES-RETURN
UNSOUT, TAD ACH /ANSWER IN AC
JMP I UNSFIX
/RESTORE ROUTINE
RESTOR, TAD ENTNO /GET CURRENT FILE #
SNA CLA /IS IT 0?
JMP RESDLS /YES-RESTORE DATA LIST
JMS I (WRBLK /NO-WRITE CURRENT BUFFER
STA /-1
TAD I IOTLOC /STARTING BLOCK-1
DCA I IOTBLK /SET CURRENT BLOCK #
TAD I IOTBUF /GET BUFFER ADDRESS
DCA I IOTPTR /USE IT TO RESET READ\WRITE POINTER
TAD I IOTHDR /GET HEADER WORD
AND (7435 /CLEAR EOF BIT,BUFFER WRITTEN BIT,AND CHAR #
DCA I IOTHDR
JMS I [NEXREC /READ FIRST BLOCK INTO BUFFER
JMP I [ILOOP /DONE
RESDLS, TAD DLSTRT /ADDRESS OF START OF INCORE DATA LIST
DCA DATAXR /USE IT TO RESET DATA LIST POINTER
JMP I [ILOOP /THATS ALL!
/SUBROUTINE STFIND-WHEN CALLED,IF LINK=1 STRING ARRAY TABLE IS
/USED,IF LINK=0 STRING SYMBOL TABLE IS USED. RETURNS WITH AC SET
/TO CDF OF OPERAND STRING,STRPTR POINTING TO THE FIRST WORD
/IN THE STRING, AND THE MAX LENGTH OF THE STRING IS IN STRMAX. ALSO,
/THE ACTUAL LENGTH OF THE STRING IS IN STRCNT
STFIND, 0
SZL /IS THIS AN ARRAY INST?
JMP SAFIND /YES-POINTER IS INTO ARRAY TABLE
TAD INSAV /GET INST AGAIN
AND [377 /ISOLATE OPERAND POINTER
DCA TEMP1 /NO-SAVE OPERAND POINTER
TAD TEMP1 /N
CLL RAL /2N
TAD TEMP1 /3N (3 WORDS/ENTRY)
TAD STSTRT /ADD BASE ADR OF STRING TABLE
STCOM, DCA XR2 /POINTER TO THIS ENTRY IN STRING TABLE
STDF, . /DF TO THAT OF SYMBOL TABLES (SET BY START)
TAD I XR2 /GET POINTER TO STRING
DCA STRPTR
TAD I XR2 /GET CDF FOR OPERAND STRING
DCA STRCDF /SAVE
TAD I XR2 /GET -(MAX LENGTH OF STRING)
DCA STRMAX /SAVE
SNL /ARRAY ELEMENT?
JMP STRCDF /NO-SKIP THIS SUBSCRIPT CALCULATION
TAD S1 /GET SUBSCRIPT
CLL CMA /SET UP 12 BIT COMPARE
TAD I XR2 /GET DIMENSION
SNL CLA /IS S1>DIMENSION?
JMP I (SU /YES
TAD STRMAX /NO-GET ELEMENT LENGTH
CIA /MAKE POSITIVE
CLL IAC /ROUND OFF TO NEAREST MULTIPLE OF 2
CLL RAR / DIVIDE BY TWO (COUNT/2=WORD COUNT)
CLL IAC /ADD A WORD FOR HEADER
DCA TEMP3 /# OF WORDS IN EACH ARRAY ELEMENT
TAD S1 /GET SUBSCRIPT
JMS I [MPY /S1*ELEMENT LENGTH (ASSUMES LINK UNCHANGED ON RETURN)
TAD STRPTR /ARRAY OFFSET+POINTER TO A(0)
DCA STRPTR /FINAL STRING POINTER
RAL /CARRY TO BIT 11
TAD TEMP6 /ADD TO ACCUMLATED OVERLAPS FROM MULTIPLY
CLL RTL
RAL /PUT OVERLAP # INTO BITS 6-8
TAD STRCDF /ADD TO CDF IF NECESSARY
DCA STRCDF /SAVE AGAIN
STRCDF, 0 /DF TO STRING FIELD
TAD I STRPTR
CDF
DCA STRCNT /STORE -(CURRENT LENGTH OF STRING)
TAD STRCDF /CDF TO OPERAND IN AC
DCA I (SSTEX /SETUP STRING STORE EXIT DF HERE
JMS I (BYTSET /ENTER FUNCTIONS WITH BYTE POINTERS SETUP
JMP I STFIND /RETURN
SAFIND, TAD INSAV /GET INST
AND (37 /ISOLATE OPERAND POINTER
CLL RTL /4N (4 WORDS/ENTRY)
TAD SASTRT /USE STRING ARRAY TABLE
STL /SET LINK FOR ARRAY INST
JMP STCOM /RETURN TO SUBROUTINE MAINLINE
/PNT(X)
/SEND 7BIT CHAR TO THE CURRENT FILE
PNT, JMS I [UNSFIX /FIX X
AND [177 /STRIP TO 7 ASCII BITS
TAD [200 /FORCE CHANNEL 8
JMS I [PUTCH /PUT IN FILE BUFFER
JMP I [ILOOP /DONE
PAGE
/ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER
/AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER
SFN, JMS I [UNSFIX /FIX FAC TO GET FILE #
CSFN, DCA ENTNO /IF ENTRY IS HERE,FILE #=0 (TTY)
TAD ENTNO
STL
TAD (-4 /IS RESULT A LEGAL FILE #?
SNL SZA CLA
FN, JMS I [ERROR /NO-ERROR
TAD ENTNO /PICK UP FILE NUMBER
CLL RTL
RTL
CIA
TAD ENTNO
CIA /MULTIPLY BY SIZE OF IOTABLE
IFNZRO IOTSIZ-15 <__ASSEMBLY ERROR__>
TAD (TTYF /ADD TO BASE
DCA XR1 /STORE IN TEMP
TAD (IOTHDR-1 /NOW POINT AT PAGE 0 AREA
DCA XR2
TAD (-IOTSIZ+3 /SETUP ALL BUT LAST 3
DCA TEMP2
TAD XR1
DCA I XR2
ISZ XR1
ISZ TEMP2
JMP .-4 /SET UP THE POINTERS NOW
JMP I [ILOOP /--RETURN--
/GOSUB
GOSUB, TAD I GSP
SMA CLA
GS, JMS I [ERROR /ERROR IF STACK OVERFLOW
TAD I [CDFPSU /ELSE GET CDF INSTR
DCA I GSP
ISZ GSP
TAD I (INTPC
DCA I GSP /STORE INT PC
ISZ GSP
JMP I (SUCJMP /EXEC AS NORMAL GOTO NOW
/GOSUB RETURN
RETRNI, STA
TAD GSP
DCA GSP /POP STACK
TAD I GSP /GET PC
DCA I (INTPC
STA
TAD GSP /POP STACK
DCA GSP
TAD I GSP
SMA
GR, JMS I [ERROR /FATAL ERROR IF NO RETURN
DCA I [CDFPSU
JMP I (JFAIL /BUMP PC PAST ADDR WORD AND CONTINUE
GSP, GSTCK /GOSUB STACK POINTER
/FOR-LOOP JUMP ROUTINE
/ENTER WITH AC = HORD
JFOR, SNA /IS FAC=0?
JMP I (JFAIL /YES-DO NOT JUMP
TAD FSWITC /ADD FSWITCH
SPA CLA /ARE SIGN BIT=FSWITCH?
JMP I (JFAIL /NO-DO NOT JUMP
JMP I (SUCJMP /YES-DO JUMP
/ROUTINE TO INITIALIZE FSWITCH
SETF, AC4000
AND ACH /ISOLATE SIGN OF MANTISSA
DCA FSWITC /STORE IN FSWITCH
JMP I [ILOOP /DONE
FSWITC, 0
/ROUTINE TO RESET CHARACTER NUMBER TO 1
CNOCLR, 0
TAD I IOTHDR
AND [7477 /SET CHAR BITS TO 0
DCA I IOTHDR
JMP I CNOCLR /RETURN
/ROUTINE TO ZERO THE CURRENT I/O BUFFER
BLZERO, 0
STA
TAD I IOTBUF
DCA XR1 /POINT INTO THE BUFFER
TAD [7400
DCA CNOBML /SET COUNT TO 400 WORDS
TAD (232 /INSERT A ^Z IN THE BUFFER FIRST
CDF 10
DCA I XR1
ISZ CNOBML
JMP .-2 /LOOP FOR THE REST
CDF
JMP I BLZERO /--RETURN--
/BUMP 3 FOR 2 CHAR NUMBER FOR CURRENT FILE
CNOBML, 0
TAD I IOTHDR /HEADER WORD
TAD [100 /ADD 1 TO THE COUNT BITS
DCA I IOTHDR
JMP I CNOBML /DONE
/STRING COMPARE
/COMPARE SAC WITH MEMORY, BLANK EXTENDING THE
/SHORTER STRING ON THE RIGHT
SCOMP, DCA MODESW /SET INTERPRETER TO ARITH MODE NOW
JMS I [FACCLR /TENTATIVELY ASSUME EQUAL (FAC = 0)
SCOMLP, TAD STRCNT /IS THE MEMORY STRING EMPTY NOW?
SNA CLA
TAD L40 /PAD WITH SPACE IF YES
SNA
JMS I (LDB /LOAD NEXT BYTE IF NOT
DCA TEMP2
TAD SACLEN /NOW IS THE SAC EMPTY
SNA CLA
TAD L40 /YES, PAD IT
SNA
TAD I SACXR /NO GET IT
CLL CIA /COMPARE TO MEMORY
TAD TEMP2
SZA CLA
JMP SNEQ /JMP IF NOT EQUAL, L=SENSE OF COMPARE
TAD STRCNT /IS MEMORY STRING DONE
SZA CLA
ISZ STRCNT /NO, BUMP COUNT
L40, 40 /EFFECTIVE NOP
TAD SACLEN /IS THE SAC EMPTY
SZA CLA
ISZ SACLEN /NO BUMP COUNT
TAD SACLEN /GET SAC REMAINDER (SKP IF IS JUST ZERO)
TAD STRCNT /ADD ARG REMAINDER
SZA CLA
JMP SCOMLP /LOOP IF BOTH NOT EMPTY
JMP I [ILOOP /OTHERWISE EQUAL
SNEQ, STA RAR
DCA ACH /STORE SIGN BIT
JMP I [ILOOP /--RETURN--
PAGE
/STRING DATA LIST READ, STRING LOAD AND STRING CONCATENATE
SRLIST, JMS I (DLREAD /FIRST READ NEG BYTE COUNT
DCA STRCNT /STORE IT
STL /SET LINK MEANS USE PHONY DATA LIST BYTE LOAD
SKP /SKP INTO STRING LOAD ROUTINE
SLOAD, CLL /CLEAR LINK TO USE NORMAL LOAD BYTE ROUTINE
DCA SACLEN /CLEAR SAC LENGTH COUNTER
SZL
TAD (DRGCH-LDB /USE PHONY LOAD BYTE
SCON1, TAD (LDB /USE REAL LDB FOR CONCATENATE
DCA SCLDB
TAD STRCNT
SNA CLA
JMP I [ILOOP /NOTHING TO DO IF NULL STRING
TAD SACLEN /COMPUTE OFFSET INTO SAC
CIA
TAD [SAC-1
DCA SACXR /TO STORE AFTER END OF PREV STRING
SEGCOM, JMS I SCLDB /GET A BYTE
DCA I SACXR /STORE IT
STA
TAD SACLEN /NOW BUMP SIZE OF SAC
DCA SACLEN
TAD SACLEN /CHECK IF ROOM LEFT
TAD (SACLIM
SPA CLA
SC, JMS I [ERROR /FATAL ERROR IF SAC OVERFLOW
ISZ STRCNT
JMP SEGCOM /ITERATE IF MORE
JMP I [ILOOP /--RETURN--
SCLDB, 0
/ROUTINE TO GET A BYTE FROM THE DATA LIST
DRGCH, 0
TAD SACLEN /TEST FOR EVEN OR ODD
CLL RAR
SZL CLA
JMP CHR2 /SECOND CHAR
JMS I (DLREAD /FIRST CHAR, READ ANOTHER WORD
DCA DRCHR
TAD DRCHR
CLL RTR
RTR
RTR /SHIFT RIGHT
SKP
CHR2, TAD DRCHR /GET SECOND CHAR
AND [77 /MASK TO 6BIT
JMP I DRGCH /RETURN
DRCHR, 0
/ROUTINE TO SET EOF BIT IN I/O ENTRY
EOFSET, TAD I IOTHDR /HEADER
CLL RTR /EOF BIT TO LINK
STL RTL /SET LINK
/PUT LINK IN EOF BIT
DCA I IOTHDR /STORE IN I/O TABLE ENTRY
JMP I [ILOOP /EOF BIT SET-ABORT TO ILOOP
/SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS
/OF TEMP3 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN TEMP6
/AND THE LOW RESULT IN THE AC
MPY, 0
DCA TEMP10
DCA TEMP6
TAD [-14
DCA TEMP5
MP12LP, TAD TEMP3
RAR
DCA TEMP3
TAD TEMP6
SNL
JMP .+3 /12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2
CLL
TAD TEMP10
RAR
DCA TEMP6
ISZ TEMP5
JMP MP12LP
TAD TEMP3 /LORD OF (DIM1+1)*S2 IN AC
RAR /HORD OF (DIM1+1)*S2 IN TEMP6
JMP I MPY /RETURN
/ROUTINE TO CHECK IF FILE IDLE
IDLE, 0
TAD I IOTHND /GET HANDLER ENTRY
SNA CLA /IS IT EMPTY?
FI, JMS I [ERROR /YES-USER TRIED TO DO SOMETHING TO AN UNOPEN FILE
JMP I IDLE /NO-RETURN
/ROUTINE TO READ NEXT WORD IN DATALIST INTO AC
DLREAD, 0
TAD DATAXR /DATA LIST POINTER
CLL CMA /SET UP 12 BIT COMPARE
TAD DLSTOP /ADDR OF END OF DATA LIST
SNL CLA /POINTER AT END OF LIST?
DA, JMS I [ERROR /YES
DLCDF, . /NO-DF TO DATA LIST
TAD I DATAXR /FETCH WORD FROM DATA LIST
CDF
JMP I DLREAD /DONE
/RANDOMIZE STATEMENT
FRANDM, TAD SPINNR /USE SPINNR FOR NEW SEED FOR RND(X)
STL RAL /MAKE SURE SEED IS ODD
DCA RSEED
JMP I [ILOOP /DONE
RSEED, 2713
/SUBROUTINE CR,LF
CRLFR, 0
TAD [215
JMS I [PUTCH
TAD (212
JMS I [PUTCH /PRINT A CR,AND LF
DCA I IOTPOS /ZERO NUMBER OF CHARS PRINTED SO FAR
JMP I CRLFR
/SUBROUTINE FOTYPE
/RETURNS TO CALL+1 IF FILE FIXED LENGTH,CALL+2 IF VARIABLE
FOTYPE, 0
TAD I IOTHDR /GET HEADER
AND (4 /ISOLATE TYPE BIT
SZA CLA /IS IT FIXED LENGTH?
ISZ FOTYPE /NO-BUMP RETURN
JMP I FOTYPE /RETURN
/ABS(X) FUNCTION
XABSVL, JMS ABSVAL /NEGATE FAC IF NEGATIVE
JMP I [ILOOP /--RETURN--
/SUBROUTINE TO TAKE ABS VALUE OF FAC
ABSVAL, 0
TAD ACH
SPA CLA /IS FAC<0?
JMS I [FFNEG /YES-NEGATE IT
JMP I ABSVAL /RETURN
/ROUTINE TO RESTORE THE FAC FROM FP TEMP
FACRES, 0
JMS I [FFGET /GET FAC
INTERB
JMP I FACRES /RETURN
PAGE
/STRING STORE
SSTORE, TAD SACLEN
SNA
JMP I (SSTEX /EXIT IF NULL STRING IN SAC
DCA TEMP1 /SET COUNT
TAD SACLEN /SEE IF WILL FIT
CIA
TAD STRMAX
SMA SZA CLA /SKP IF LEN.LE.MAX LEN
SL, JMS I [ERROR /ERROR IF TARGET STRING TOO SMALL
TAD I SACXR /PICK UP SAC BYTE
JMS I (DPB /STORE IT
ISZ TEMP1
JMP .-3
JMP I (SSTEX /--RETURN--
/STRING READ FROM FILE TO MEMORY
SREAD, JMS I [GETCH /GET CHAR FROM FILE
TAD CHAR
TAD [-215 /IS IS CR?
SNA
JMP I (SSTEX /YES, EXIT
TAD (3 /IS IT LF?
SNA CLA
JMP SREAD /YES, IGNORE IT
TAD I (BYTCNT /SEE IF THIS CHAR WILL FIT
TAD STRMAX
SMA CLA
JMP ST /NO, SOFT ERROR
TAD CHAR /YES, STORE IT
JMS I (DPB
JMP SREAD
ST, JMS I [ERROR
TAD [215 /FAKE OUT INPUT ROUTINE
DCA CHAR
JMP I (SSTEX /SET STRING SIZE AND EXIT
/STRING WRITE FROM SAC TO DEVICE
SWRITE, DCA COMMAS
TAD SACLEN /SEE IF NULL STRING
SNA
JMP I [ILOOP /RETURN IF SO
CIA
TAD I IOTPOS /ADD TO NUMBER OF CHARS PRINTED SO FAR
TAD (-WIDTH
SMA SZA CLA /SKP IF LE WIDTH OF LINE
JMS I [CRLFR /ELSE RESET CARRAIGE
TAD SACLEN
DCA STRCNT /SET LOOP COUNTER
TAD [SAC-1
DCA SACXR /POINT AT SAC
SWRLP, TAD I SACXR
TAD (240
AND [77
TAD (240 /CONVERT TO 8BIT
JMS I (PUTCH
ISZ STRCNT
JMP SWRLP /ITERATE IF MORE
JMP I [ILOOP /--RETURN--
/COMMA FUNCTION (KNOWN ONLY TO COMPILER FOR FORMATTING PRINT
/STATEMENTS)
COMMA, JMS I [FTYPE /SKP IF FILE IS ASCII
JMP I [ILOOP /NO-COMMA FUNCTION IS A NOP
TAD COMMAS /GET COMMA SWITCH
SNA CLA /WAS LAST THING PRINTED A COMMA?
JMP .+3 /NO-WE ARE OK
TAD (" /YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION
JMS I [PUTCH
IAC
DCA COMMAS /SET COMMA SWITCH
TAD (-4
DCA TEMP2
TAD I IOTPOS /GET NUMBER OF CHARS PRINTED SO FAR
COMLOP, TAD (-COLWID
SPA /PAST THIS ONE?
JMP SLOVER /YES-SLIDE PRINT HEAD TO START OF NEXT
SNA /EXACTLY ON A COLUMN?
JMP I [ILOOP /YES-DONE
ISZ TEMP2 /ALL MARKERS CHECKED YET?
JMP COMLOP /NO-DO NEXT
CLA /FALL INTO CR ROUTINE TO RESET COL TO 0
/CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING
/PRINT STATEMENTS)
CRFUNC, TAD I IOTHDR
CLL RTR
SNL CLA /SKP IF EOF IS SET
JMS I [FTYPE /SKP IF FILE IS ASCII
JMP I [ILOOP /WE DON'T WANT TO OUTPUT CLFR
JMS I [CRLFR /DO AS WE ARE TOLD
JMP I [ILOOP /NEXT INST
/TAB FUNCTION
TAB, JMS I [UNSFIX /FIX X TO INTEGER
CIA /NEGATE
TAD I IOTPOS /COMPARE DESIRED COLUMN TO REAL COLUMN
IAC /BUMP BY 1 (WORD 7=COL #-1)
SMA /IS X>=CURRENT COLUMN?
JMP I [ILOOP /YES-THEN DO NOTHING
/FALL INTO SPACE OUT ROUTINE
SLOVER, DCA COLCNT /-# OF COLUMNS TO NEXT MARKER
JMS I [FTYPE /IS FILE NUMERIC?
JMP I [ILOOP /YES-THIS IS A NOP
TAD (" /GET SPACE
JMS I [PUTCH /PRINT IT
ISZ COLCNT /THERE YET?
JMP .-3 /NO-TYPE ANOTHER SPACE
JMP I [ILOOP /YES-DONE
COMMAS, 1 /SET TO 1 IF LAST PRINT WAS A COMMA MOVE
COLCNT, 0
/ROUTINE TO CALL ERROR ROUTINE BY FAKING A FUNC2 CALL TO FUNCTION #10
ERROR, 0
CLA CLL IAC /ENTRY AC RANDOM
AND PSFLAG /TEST IF OS/8 17600 RESIDENT
SZA CLA /SKP IF NOT
JMS I [PSWAP /ELSE FORCE IT OUT (THESE ERRORS ARE FATAL)
TAD (7607
DCA INSAV /FAKE A FUNC CALL TO FUNC2 #10
JMP I (FUNC2I
XERRRET,JMP I ERROR /RETURN TO CALLER IF NON FATAL ERROR
/FLOATING NEGATE
FNEGI, JMS I [FFNEG /CALL NEGATE ROUTINE
JMP I [ILOOP /RETURN TO ILOOP
NUMBUF, ZBLOCK 6 /6 DIGIT BUFFER USED BY FFOUT
PAGE
/INCREMENT AND LOAD 6BIT BYTE FROM MEMORY
LDB, 0
JMS BUMP /INCREMENT POINTER AND SET DF
TAD I BYTPTR /PICK UP BYTE
CDF
ISZ BYTSWT /TEST HALFWORD SWITCH
JMP .+4
CLL RTR
RTR
RTR
AND [77 /MASK TO 6BIT
JMP I LDB /RETURN WITH CHAR IN AC
/INCREMENT AND DEPOSIT BYTE IN MEMORY
DPB, 0
AND [77 /MASK TO 6BIT NOW
DCA BYTE
JMS BUMP /INCREMENT POINTER AND SET DF
TAD [77 /GET MASK
ISZ BYTSWT /SKP IF PTR BUMPED
CMA CML /ELSE PRESERVE LEFT HALF
AND I BYTPTR /ZERO OUT TARGET BYTE
DCA I BYTPTR
TAD BYTE /GET BYTE
SZL
JMP .+4 /JMP IF NO SHIFT
CLL RTL
RTL
RTL
TAD I BYTPTR
DCA I BYTPTR /STORE BYTE
CDF
ISZ BYTCNT /TALLY NUMBER OF BYTES STORED
JMP I DPB /--RETURN--
/BUMP BYTE POINTER
BUMP, 0
TAD BYTSWT /BUMP LOW ORDER BIT
CLL CMA
DCA BYTSWT
ISZ BYTSWT /SKP IF NO CARRY
ISZ BYTPTR /ELSE BUMP WORD PTR
JMP BYTCDF /JMP OUT IF FIELD NOT CROSSED
TAD [10
TAD BYTCDF
DCA BYTCDF /PROPAGATE CARRY INTO CDF INSTR
BYTCDF, 0 /GETS SET BY BYTSET TO TARGET FIELD
JMP I BUMP /RETURN WITH A CLEAR LINK
/BYTE LOAD/STORE INITIALIZE ROUTINE
BYTSET, 0
TAD SSTEX /GET FIELD OF STRING
DCA BYTCDF /STORE INLINE
TAD STRPTR /NOW GET ADDR OF COUNT WORD
DCA BYTPTR /STORE
IAC
DCA BYTSWT /SET LOW ORDER BIT TO CARRY NEXT TIME
DCA BYTCNT /CLEAR DEPOSITED BYTE COUNT
TAD [SAC-1
DCA SACXR /ALWAYS RETURN WITH SAC POINTER SET UP
JMP I BYTSET /--RETURN--
/STRING STORE EXIT ROUTINE
SSTEX, 0 /GETS SET BY STFIND TO DF OF STRING
TAD BYTCNT /ENTER WITH POSITIVE LENGTH IN COUNT
CIA
DCA I STRPTR /STORE IN STRING
JMP I [ILOOP /--RETURN-- (ILOOP RESETS DF)
BYTCNT, 0
BYTPTR, 0
BYTSWT, 0
BYTE, 0
/SUBROUTINE BUFCHK-CHECKS THE POSITION OF THE BUFFER POINTER FOR
/THE DEVICE WHOSE I/O TABLE ENTRY IS IN WORKING AREA. RETURNS TO CALL+1
/IF THE POINTER IS AT THE END AND CHAR NUMBER IS 1 (LAST
/AVAILABLE CHAR 3 HAS BEEN USED),CALL+2 IF THE POINTER IS AT THE
/END BUT THE CHAR # IS NOT 1 (THERE IS 1 CHAR 3 LEFT), CALL+3
/IF THERE IS 1 WORD LEFT IN BUFFER,CALL+4 IF MORE THAN 1 LEFT.
BUFCHK, 0
TAD ENTNO /GET DEVICE #
SNA CLA /IS IT TTY?
TAD (62-400 /YES-CHECK FOR A BUFFER 60 WORDS LONG
TAD [400 /NO-CHECK FOR A BUFFER 400 WORDS LONG
TAD I IOTBUF /ADD LENGTH TO BUFFER ADDRESS
CIA /-ADDR OF END OF BUFFER
TAD I IOTPTR /CHECK AGAINST CURRENT POINTER
SNA /IS POINTER AT END OF BUFFER?
JMP EBC /AT END-CHECK THE CHAR #
ISZ BUFCHK
ISZ BUFCHK /NO-BUMP RETURN
IAC
SNA CLA /WAS POINTER AT LAST WORD?
JMP I BUFCHK /YES-RETURN TO CALL+3
ISZ BUFCHK /NO
JMP I BUFCHK /RETURN TO CALL+4
EBC, JMS I [CHARNO /GET CHAR #
JMP I BUFCHK /IT WAS 1-RETURN TO CALL+1
NOP /IT WAS 3-RETURN TO CALL+2
ISZ BUFCHK /IT WAS 2-RETURN TO CALL+2
JMP I BUFCHK
/SUBROUTINE PACKCH-PACKS ASCII CHARS,3 FOR 2, INTO BUFFER FOR THE
/DEVICE IN WORK AREA. CALL WITH THE CHARACTER IN THE AC
PACKCH, 0
DCA TEMP1 /SAVE
JMS I [CHARNO /DETERMINE CHARACTER NUMBER
SKP /1
JMP CHAR3P /3
TAD TEMP1 /1 OR 2-GET CHAR AGAIN
JMS I [WRITFL /STORE IN BUFFER
JMS I (CNOBML /BUMP CHARACTER NUMBER
JMP I PACKCH /DONE
CHAR3P, AC7776
TAD I IOTPTR /BACK BUFFER POINTER UP TO POINT TO CHAR 1
DCA I IOTPTR
TAD TEMP1 /CHAR
CLL RTL
RTL /SLIDE LEFT HALF INTO BITS 0-3
DCA TEMP1 /SAVE
TAD TEMP1
JMS COMBNE /ISOLATE LEFT HALF,COMBINE WITH CHAR1,AND PUT IN FILE
TAD TEMP1 /CHAR AGAIN
CLL RTL
RTL /SLIDE RIGHT HALF INTO BITS 0-3
JMS COMBNE /ISOLATE RIGHT HALF,COMBINE WITH CHAR 2,AND PUT IN FILE
JMS I [CNOCLR /CLEAR THE CHARACTER NUMBER (RESET IT TO 1)
JMP I PACKCH /DONE
COMBNE, 0
AND [7400 /ISOLATE HALF IN QUESTION
DCA TEMP2 /SAVE
JMS I (BCGET /GET A WORD FROM FILE BUFFER IN FIELD 1
AND [377 /FLUSH ANY SLUSH IN BITS 0-3
TAD TEMP2 /COMBINE
JMS I [WRITFL /PUT IN BUFFER
JMP I COMBNE /RETURN
PAGE
/ROUTINE TO READ WORD FROM FILE BUFFER AND BUMP POINTER
READFL, 0
JMS I (FOTYPE /IS FILE VARIABLE LENGTH
SKP
VR, JMS I [ERROR /YES-IT IS AN ERROR TO TRY AND READ IT
TAD I IOTHDR /CHECK IF MORE THERE
CLL RTR /EOF BIT TO LINK
SNL CLA /EOF?
JMP .+3 /NO-CONTINUE
RE, JMS I [ERROR /YES-ATTEMPT TO READ BEYOND EOF
JMP I [ILOOP /NOT FATAL-RETURN TO I LOOP
JMS BCGET /GET WORD FROM FILE BUFFER
ISZ I IOTPTR /BUMP POINTER
JMP I READFL /DONE
/ROUTINE TO WRITE AC IN FILE BUFFER AND INCREMENT POINTER
WRITFL, 0
JMS I (BCPUT /STORE AC IN FILE BUFFER
ISZ I IOTPTR /BUMP POINTER
TAD I IOTHDR /GET FILE HEADER WORD
CLL RTR /EOF BIT TO LINK
SNL CLA /WAS FILE PAST END?
JMP I WRITFL /NO-RETURN
WE, JMS I [ERROR /YES-ATTEMPT TO WRITE PAST END OF FILE
JMP I [ILOOP /NON-FATAL RETURN TO ILOOP
/ROUTINE TO GET ONE WORD FROM FILE BUFFER IN FIELD 1
BCGET, 0
JMS I [IDLE /CHECK IF FILE OPEN
TAD I IOTPTR /GET READ WRITE POINTER
DCA WRITFL /SAVE
TAD ENTNO /GET FILE #
SZA CLA /IF TTY,BUFFER FIELD IS 0
CDF 10 /DF TO BUFFER FIELD
TAD I WRITFL /GET WORD FROM BUFFER
CDF
JMP I BCGET /RETURN
/SUBROUTINE UNPACK-UNPACKS ASCII, 3 FOR 2 ,FROM THE FILE IN THE I/O
/WORKING AREA. RETURNS WITH THE CHAR IN CHAR.
UNPACK, 0
JMS I [CHARNO /GET CHAR #
SKP /1
JMP CHAR3U /3
JMS I (CNOBML /BUMP CHAR NUMBER
JMS READFL /GET CHAR AGAIN
U123C, AND [177 /STRIP OFF 7 BITS
SNA
JMP UNPACK+1 /ZERO
TAD [200
DCA CHAR /SAVE
TAD CHAR
TAD (-232 /IS IT CTRL/Z?
SNA CLA
JMP I [EOFSET /YES-SET EOF BIT
JMP I UNPACK /RETURN
CHAR3U, JMS I [CNOCLR /RESET CHAR # TO 1
AC7776
TAD I IOTPTR
DCA I IOTPTR /BACK BUFFER POINTER UP 2
JMS READFL /GET LEFT HALF OF CHAR
AND [7400
DCA XR5 /SAVE
JMS READFL /GET NEXT WORD WITH RIGHT HALF
AND [7400 /ISOLATE RIGHT HALF
CLL RTR
RTR /SLIDE RIGHT HALF OVER
TAD XR5 /COMBINE WITH LEFT HALF
CLL RTR
RTR /MOVE TO BITS 4-11
JMP U123C /REJOIN MAINLINE
/READ FUNCTION-GETS NUMBERS INTO VARIABLES
READI, JMS I [FTYPE /SKP IF FILE IS ASCII
JMP RIMAGE /READ NUMERIC IMAGE
JMS I (FFIN /READ ASCII INTO NUMBER
JMP I [ILOOP /--RETURN--
RIMAGE, JMS I [BUFCHK /YES-CHECK BUFFER POINTER
NOP /PAST END-NEXT RECORD
NOP /AT END-NEXT RECORD
JMS I [NEXREC /ONLY 1 WORD LEFT-IT IS UNUSED IN NUMERIC FMT
JMS READFL /GET WORD FROM FILE
DCA ACX /STORE AS EXPONENT
JMS READFL /GET WORD FROM FILE
DCA ACH /STORE AS HIGH MANTISSA
JMS READFL /GET WORD FROM FILE
DCA ACL /STORE AS LOW MANTISSA
JMP I [ILOOP /DONE
/ROUTINE TO FETCH ASCII CHARACTERS FROM FILE BUFFER
GETCH, 0
JMS I [FTYPE /IS FILE ASCII?
SR, JMS I [ERROR /NO-ERROR
TAD ENTNO
SZA CLA
JMP NTTY
TAD TCHAR
TAD [-215
SNA CLA
JMS I [DRCALL
NTTY, JMS I [BUFCHK /NO-CHECK STATUS OF BUFFER
JMS I [NEXREC /LAST CHAR READ-NEXT RECORD
NOP /CHAR 3 NOT USED YET
TCHAR, 215 /NOP: CHAR 2 AND 3 LEFT
JMS UNPACK /UNPACK CHAR FROM BUFFER
TAD ENTNO
SZA CLA
JMP I GETCH /RETURN
TAD CHAR
DCA TCHAR
JMP I GETCH
/SUBROUTINE CHARNO-RETURNS TO CALL+1 IF CHAR #=1,CALL+2 IF 3,CALL+3
/IF 2
CHARNO, 0
TAD I IOTHDR /HEADER
AND (300 /ISOLATE CHAR #
CLL RTL
RTL /CHAR # TO BITS 0,1
SMA SZA /IS IT 2?
ISZ CHARNO /YES-BUMP RETURN
SZA CLA /IS IT 2 OR 3?
ISZ CHARNO /YES-BUMP RETURN
JMP I CHARNO /RETURN
PAGE
/WRITE FUNCTION-PUTS NUMBERS IN FILE BUFFERS
WRITEI, JMS I [FTYPE /SKP IF FILE IS ASCII
JMP WIMAGE /ELSE DO IMAGE WRITE
JMS I (FFOUT /CONVERT INTERNAL TO ASCII
TAD XR1
CIA
TAD (INTERB-1 /CALCULATE NUMBER OF CHARS STORED IN BUFFER
DCA TEMP10 /SAVE
TAD (INTERB-1
DCA SACXR /NOW POINT SACXR INTO BUFFER
TAD TEMP10 /GET COUNT OF CHARS TO BE PRINTED
CIA
TAD I IOTPOS /ADD TO PRINT HEAD POSITION
TAD (-WIDTH /COMPARE AGAINST "72"
SMA SZA CLA /WILL THE NUMBER FIT ON THIS LINE?
JMS I [CRLFR /NO-ISSUE A CR,LF
CPLOOP, TAD I SACXR /GET CHAR FROM INTERMEDIATE BUFFER
JMS PUTCH /PUT ON DEVICE
ISZ TEMP10 /BUMP COUNTER
JMP CPLOOP /NEXT
TAD O240
JMS PUTCH /SEND OUT A SPACE AFTER NUMBER
JMP WDONE /TAKE COMMON EXIT
WIMAGE, JMS I [BUFCHK /FILE IS NUMERIC-CHECK BUFFER STATUS
O240, 240 /PAST END-NEW RECORD (AND INST SERVES AS NOP)
O210, 0210 /AT END-NEW RECORD (AND SERVES AS NOP)
JMS I [NEXREC /ONE WORD LEFT-DON'T USE IT
TAD ACX /EXPONENT
JMS I [WRITFL /WRITE IN BUFFER
TAD ACH /HIGH MANTISSA
JMS I [WRITFL /WRITE IN BUFFER
TAD ACL /LOW MANTISSA
JMS I [WRITFL /WRITE IN BUFFER
WDONE, DCA I (COMMAS /CLEAR COMMA SWITCH
JMP I [ILOOP /WRITE IS DONE
/ROUTINE TO PUT ASCII CHARS IN FILE BUFFER. IGNORES RUBOUTS.
PUTCH, 0
DCA TEMP1 /SAVE CHAR
TAD TEMP1 /GET CHAR AGAIN
TAD (-377
SNA CLA /IS IT A RUBOUT?
JMP I PUTCH /YES-RETURN
JMS I [FTYPE /IS FILE NUMERIC?
SW, JMS I [ERROR /YES-ERROR
ISZ I IOTPOS /BUMP COULMN NUMBER
TAD ENTNO /GET ENTRY #
SNA CLA /IS IT TTY?
JMP TOUT /YES-JUST PUT CHARS IN RING BUFFER
JMS I [BUFCHK /NO-IS BUFFER FULL?
JMS I [NEXREC /YES-NEXT RECORD
O40, 40 /THERE IS A CHAR 3 LEFT (AND IS A NOP)
O20, 20 /THERE IS A CHAR 2 AND 3 LEFT (AND IS A NOP)
TAD TEMP1 /GET CHAR AGAIN
JMS I [PACKCH /PUT IN BUFFER
JMP I PUTCH /RETURN
TOUT, TAD TEMP1 /GET CHAR
JMS I [XPUTCH /PUTCH CHAR IN OUTPUT BUFFER FOR TTY
JMP I PUTCH /RETURN
/SUBROUTINE NEXREC-WRITES THIS BUFFER IN FILE,THEN READS IN NEXT BUFFER
/IF POSSIBLE,ELSE SETS EOF BIT. IF DEVICE IS READ OR WRITE ONLY
/IT JUST READS OR WRITES A BLOCK,WHICHEVER IS APPROPRIATE
NEXREC, 0
TAD I IOTHDR /GET HEADER
AND O20 /GET READ/WRITE ONLY BIT
SNA CLA /IS IT ON?
JMP FILSTR /NO-DEVICE IS FILE STRUCTURED
JMS I (FOTYPE /YES-IS IT INPUT OR OUTPUT FILE?
JMP RONLY
JMS WRBLK
RWONC, ISZ I IOTBLK
JMS BLINIT /INIT FILE TABLE ENTRIES
JMP I NEXREC /DONE
RONLY, JMS BLREAD
JMP RWONC
FILSTR, JMS WRBLK /WRITE THE CURRENT BLOCK IF IT HAS BEEN CHANGED
JMS BLINIT /INIT FILE TABLE ENTRIES
ISZ I IOTBLK /BUMP BLOCK #
TAD I IOTLOC /STARTING BLOCK
CIA /NEGATE
TAD I IOTBLK /SUBTRACT FROM CURRENT BLOCK FOR FILE LENGTH
CLL CMA /SET UP CURRENT FILE LENGTH FOR 12 BIT COMPARE
TAD I IOTLEN /COMPARE TO ACTUAL LENGTH
SNL CLA /IS IT > CURRENT LENGTH?
JMP LASTB /YES-EXTEND THE FILE IF IT IS OUTPUT
JMS BLREAD /READ IN THE NEXT RECORD
JMP I NEXREC /RETURN
LASTB, JMS I (FOTYPE /IS FILE FIXED LENGTH?
JMP I [EOFSET /YES-SET EOF FLAG
TAD I IOTLEN /NO-GET ACTUAL LENGTH
CLL CMA
TAD I IOTMAX /MAXIMUM LENGTH
SNL CLA /IS ACTUAL LENGTH >= MAXIMUM LENGTH?
JMP I [EOFSET /YES-SET EOF BITS
ISZ I IOTLEN /NO-BUMP ACTUAL LENGTH
JMP I NEXREC /RETURN WITHOUT READING NEXT RECORD
/ROUTINE TO READ 2 PAGES FROM DEVICE
BLREAD, 0
JMS I (BLZERO
TAD O210 /"READ 2 PAGES"
JMS I [DRCALL /HANDLER CALL
JMP I BLREAD
/ROUTINE TO WRITE 2 PAGES ONTO DEVICE
WRBLK, 0
TAD I IOTHDR /GET FILE HEADER
AND O40 /GET FILE WRITTEN BIT
SNA CLA /HAS THIS BLOCK BEEN CHANGED?
JMP I WRBLK /NO-RETURN
TAD (4210 /"WRITE 2 PAGES"
JMS I [DRCALL /CALL TO DEVICE HANDLER
JMS I (BLZERO
JMP I WRBLK
/ROUTINE TO INITIALIZE I/O TABLE ENTRIES AFTER READ OR WRITE
BLINIT, 0
TAD I IOTBUF
DCA I IOTPTR /INIT READ/WRITE POINTER
TAD I IOTHDR
AND (7437 /SET CHAR # TO 1 AND CLEAR BLOCK WRITTEN BIT
DCA I IOTHDR
JMP I BLINIT
/ROUTINE TO SAVE THE FAC IN FP TEMP
FACSAV, 0
JMS I [FFPUT /STORE FAC
INTERB /USE INTERMEDIATE BUFFER FOR TEMP STORAGE
JMP I FACSAV /RETURN
PAGE
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
//////////// OVERLAY BUFFER 3400-4600 ////////////////////
//////////// CONTAINS FUNCTION OVERLAYS ////////////////////
//////////// AT RUN TIME ////////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// OVERLAY 1-ARITHMETIC FUNCTIONS ///////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
*OVERLAY
/INTEGER FUNCTION
/RANGE=ALL X
INT, VERSON^100+SUBVAF+6000 /INITIALLY CONTAINS VERSION OF ARITH OVERLAY
JMS I [FFPUT /SAVE X
FPPTM1
TAD ACX /GET EXPONENT
SMA SZA CLA /IS EXP<0?
JMP INSC /NO-GO ON
TAD ACH /YES
SPA CLA /IS X<0?
JMP M1R /YES-INT=-1
JMS I [FACCLR /YES-RETURN A 0
JMP I INT
INSC, TAD ACH /GET HI MANTISSA
SMA CLA /IS IT <0?
JMP INTPOS /NO-USE FAC AS IS
JMS I [FFNEG /YES-NEGATE FAC (MAKE IT POS)
IAC /AND SET FLAG
INTPOS, DCA TEMP3 /FLAG FOR NEGATIVE
DCA TEMP5 /ZERO LORD MASK
CLL CML RAR
DCA TEMP4 /INITIALIZE HORD MASK TO 4000
TAD ACX
CIA /- COUNT
DCA TEMP2
MASKL, TAD TEMP4
CLL CML RAR /ROTATE 1'S THROUGH 3 WORD MASK
DCA TEMP4 /
TAD TEMP5 /UNTIL THERE IS A COUNT OF ZERO
RAR
DCA TEMP5
ISZ TEMP2 /DONE?
JMP MASKL /NO
TAD ACH /YES-MASK HORD
AND TEMP4
DCA ACH
TAD ACL /MASK LORD
AND TEMP5
DCA ACL
TAD TEMP3 /NEG FLAG
SNA CLA /WAS ORIGINAL NUMER <0?
JMP I INT /NO-DONE
JMS I [FFPUT /SAVE INT(X)
FPPTM2
JMS I (FFADD /-INT(X)+(X)
FPPTM1
TAD ACH /SAVE HORD
DCA TEMP3
JMS I [FACCLR /FLUSH FAC
TAD TEMP3 /WAS INT(X)=X?
SNA CLA
JMP JUSNEG /YES-JUST NEGATE INT(X)
JMS I (FFADD /NO-ADD 1
ONE
JUSNEG, JMS I (FFADD /GET INT(X)
FPPTM2
JNEG, JMS I [FFNEG /AND NEGATE (INT(5.3)=-6)
JMP I INT /DONE
M1R, JMS I [FFGET /LOAD FAC WITH 1
ONE
JMP JNEG /JUST NEGATE AND RETURN
ONE, 1
2000
0
/EXPONENTIATION FUNCTION
/IF B=0,A^B=1
/IF A=0 AND B>0,A^B=0
/IF A=0 AND B<0,DIVIDE BY ZERO ERROR MESSAGE RESULTS AND A^B=0
/IF B=INTEGER > 0, A^B=A*A*A*.......*A
/IF B=INTEGER < 0, A^B=1/A*A*A*.......*A
/IF B=REAL AND A>0, A^B=EXP(B*LOG(A))
/IF B=REAL AND A<0, A FATAL ERROR RESULTS
EXPON, 0
JMS I [FFPUT /SAVE A
FPPTM5
JMS I [FFPUT /SET UP RUNNING PRODUCT IN CASE OF
FPPTM4 /MULTIPLIES
TAD ACH /HI ORDER OF A
DCA EXPON /SAVE IT
DCA INSAV /POINTER TO B IN SYMBOL TABLE
JMS I ARGPLL /FIND B
JMS I [FFGET /GET B
ARGPLL, ARGPRE /LOC SKIPPED BY FPP,SO WE USE IT FOR CONSTANT
CDF
TAD ACH /HI ORDER OF B
SNA /IS B=0?
JMP I (RETRN1 /YES A^B=1
SMA CLA /IS B<0?
JMP .+4 /NO
TAD EXPON /YES-GET HI ORDER A
SNA CLA /IS A=0?
JMP I (DV /YES-DIVIDE BY ZERO ERROR
TAD EXPON /B>0. IS A=0?
SNA CLA
JMP RET0 /YES A^B=0
JMS I [FFPUT /SAVE B
FPPTM3
JMS INT /GET INT(B)
JMS I (MULLIM /TEST EXPONENT OF RESULT TO LIMIT LARGE MULTIPLY LOOPS
JMS I (FFSUB /INT(B)-B
FPPTM3
TAD ACH /IS INT(B)-B=0?
SZA CLA
JMP I (USELOG /NO-USE LOGS
JMS I [FFGET /NO-USE REPETITIVE MULTIPLY
FPPTM3 /GET B AGAIN
TAD ACH
DCA EXPON /SAVE SIGN OF B
JMS I (ABSVAL /!B!
JMS I [FFPUT /USE ABS(B) AS MULTIPLY COUNT
FPPTM3
EMLOOP, JMS I [FFGET /GET B
FPPTM3
JMS I (FFSUB /B-1
ONE
JMS I [FFPUT /SAVE NEW COUNT
FPPTM3
TAD ACH
SNA CLA /IS COUNT ZERO YET
JMP I (EMDONE /YES-MULTIPLIES ARE DONE
JMS I [FFGET /NO-GET RUNNING PRODUCT
FPPTM4
JMS I (FFMPY /MULTIPLY BY A
FPPTM5
JMS I [FFPUT /SAVE NEW RUNNING PRODUCT
FPPTM4
JMP EMLOOP
RET0, JMS I [FACCLR /RETURN WITH 0 IN FAC
JMP I [ILOOP
PAGE
EMDONE, JMS I [FFGET /GET RUNNING PRODUCT
FPPTM4
TAD I EXPONK /GET SIGN OF B
SMA CLA /WAS IT -?
JMP I [ILOOP /NO-A^B=A*A*A*...*A
JMS I FIDVP /YES-INVERT
ONE
JMP I [ILOOP /A^B=1/A:A*A*...*A
RETRN1, JMS I [FFGET
ONE /SET FAC TO 1
JMP I [ILOOP
USELOG, TAD I EXPONK /SIGN OF A
SPA CLA /A<0?
EM, JMS I [ERROR /YES-PRINT A MESSAGE
JMS I [FFGET /LOAD A
FPPTM5
JMS I FFLOGL /LOG(A)
JMS I FMPYLV /B*LOG(A)
FPPTM3
JMS I FFEXPL /EXP(B*LOG(A))
JMP I [ILOOP /DONE
FFEXPL, EXPON1
FFLOGL, LOG
FMPYLV, FFMPY
EXPONK, EXPON
FIDVP, FFDIV1
/SGN FUNCTION
SGN, 0
TAD ACH /GET HIGH MANTISSA
SNA /IS X=ZERO?
JMP I [ILOOP /YES-THEN LEAVE IT ALONE
SPA CLA /IS X>0?
JMP .+3 /NO
IAC /YES-SET FAC=1
SKP
CMA /NO-SET FAC=-1
DCA ACX /SET UP FLOAT
JMS I [FFLOAT /FLOAT VALUE OF SGN FUNCTION
JMP I [ILOOP /DONE
IFZERO EAE <
/FLOATING SQUARE ROOT
/USES A HARDWARE TYPE ALGORITHM FOR BINARY SQUARE ROOTS
/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES-P 409
/
FROOT, 0
CLA CLL CML RTR /SET RESULT TO 2000;0000
DCA AN1
DCA AN2
CDF /DF TO PACKAGE FIELD
TAD KM22 /SET COUNTER FOR DEVELOPING 22 BITS OF RESULT
DCA AC2 /ALREADY HAVE 1
TAD ACH
SNA
JMP I FROOT /ZERO FAC-NORMALIZED!-RETN. SAME
SPA CLA
JMS I [FFNEG /TAKE ROOT OF ABSOL VALUE
TAD ACX /GET EXPONENT OF FAC
SPA /IF NEGATIVE-MUST PROPAGATE SIGN
CML
RAR /DIVIDE EXP. BY 2
DCA ACX /STORE IT BACK
SZL /INCREMENT EXP. IF ORIGINAL EXP
ISZ ACX /WAS ODD
NOP
SNL /DO A PRE-SHIFT FOR EVEN EXPONENTS
JMS I AL1K /SO FIRST BIT PAIR IS 10 NOT 01
CLA CLL CMA RAL /SET COUNTER FOR DETECTING A
DCA ZCNT /ZERO REMAINDER
CLA CLL CML RTR /SET UP POSITION OF TRIAL BIT
RTR /FOR FIRST PASS THRU LOOP
DCA OPH
DCA OPL
TAD K6000 /GET A FAST FIRST BIT-WE KNOW
TAD ACH /THIS WILL WORK SINCE # IS NORMALIZED
DCA ACH /IF # IS A POWER OF TWO, AND A PERFECT
TAD ACH /SQUARE-WE ARE DONE HERE!
SNA /WELL IS IT?
TAD ACL /COULD BE-CHECK LOW ORDER
SNA CLA
JMP DONE /WHOOPPEE-WE WIN BIG.
JMP LOP01 /NOPE-LOOP DON'T SHIFT FIRST TIME
SLOOP, TAD OPH /SHIFT TRIAL BIT 1 PLACE
CLL RAR /TO THE RIGHT
DCA OPH /AND STORE BACK
TAD OPL
RAR
DCA OPL
JMS I AL1K /SHIFT FAC LEFT 1 PLACE
LOP01, TAD OPL /ADD TRIAL BIT TO`ANSWER
TAD AN2 /SO FAR
CLL CMA IAC /NEGATE IT
TAD ACL /AND ADD TO FAC (REMAINDER SO FAR)
SNA /IS RESULT ZERO?
ISZ ZCNT /YES-INCREMENT COUNTER
DCA TM /STORE RESULT IN TEMPORARY
CML RAL /ADD CARRY TO HIGH ORDER FOR SUBTRACT
TAD OPH /ADD TRIAL BIT
TAD AN1 /ADD RESULT SO FAR (HI ORDER)
CLL CMA IAC /AND SUBTRACT FROM HI ORDER FAC
TAD ACH
SNL /RESULT NEGATIVE?
JMP GON /YES-NEXT RESULT BIT IS 0
SZA /NO-IS HI ORDER RESULT=0?
JMP LOP02 /NO-GO ON
ISZ ZCNT /YES-WAS LOW ORDER =0?
JMP .+3 /NO-GO ON
CMA /YES-REM.=0-SET COUNTER SO
DCA AC2 /LOOKS LIKE WE'RE DONE
LOP02, DCA ACH /STORE HIGH ORDER REM. IN FAC
TAD TM /STORE LO ORDER REM. IN FAC
DCA ACL
TAD OPL /TRIAL BIT SHIFTED LEFT 1 IS
CLL RAL /RESULT BIT-ADD IT TO ROOT DEVELOPED
TAD AN2 /SO FAR
DCA AN2
TAD OPH
RAL
TAD AN1
DCA AN1
GON, CLA CLL CMA RAL /RESET COUNTER FOR ZERO REM.
DCA ZCNT
ISZ AC2 /DONE ALL 23 RESULT BITS?
JMP SLOOP /NO-GO ON
DONE, TAD AN1 /YES-STORE ANSWER IN FAC
DCA ACH /ITS NORMALIZED ALREADY
TAD AN2
DCA ACL
JMP I FROOT /AND RETURN
K6000, 6000
ZCNT, 0
AL1K, AL1
AN1, 0
AN2, 0
KM22, -26
PAGE
>
IFNZRO EAE <
/
/FLOATING SQUARE ROOT
/USES MODIFIED HARDWARE ALGORITHM FOR BINARY SQUARE ROOTS
/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES; P-409
*SGN+14
FROOT, 0
CLA CLL CML RTR /SET RESLT TO 2000,0000
DCA OPL
DCA OPH
SWAB /MODE B OF EAE-ALSO DOES MQL
CDF
DCA RBCNT /CLR. SHIFT COUNTER
TAD KM22
DCA AC2 /SET COUNTER FOR 23 BITS OF RESULT
TAD ACX /GET EXPONENT OF FAC
ASR /DIVIDE BY 2
1
DCA ACX /STORE IT BACK
DPSZ /INCREMENT EXP. IF ORIG. EXP
ISZ ACX /WAS ODD
NOP
MQA /DETERMINE WHETHER TO DO A
CLL RAL /PRE-SHIFT FOR EVEN EXPONENTS.
CML RAL
DCA RKNT /STORE BIT-0 OR 1 SHIFT CNT
CLL CML RTR /SET UP FIRST TRIAL BIT
RTR
DCA AC1
DCA AC0 /STORE AWAY
DCA ACNT /ZERO COUNTER
DLD /GET THE FAC
ACH
SWP /GET IN RIGHT ORDER
SNA /IS IT ZERO? (HI ORD=0)
JMP I FROOT /YES-ROOT = 0
SPA /NEGATIVE?
DCM /YES-TAKE ABSOL. VALUE
SHL /SHIFT # 1 BIT IF EXP WAS EVEN
RKNT, 0 /SO FIRST BIT PAIR IS 10 NOT 01
TAD K6000 /SUBTRACT 2000-KNOW FIRST BIT
DPSZ /IS 1(NORMALIZED)-DONE??
JMP LOP1 /NO-WE MUST LOOP
JMP DONE /YES-AN EASY ONE!!!
LOOP, DLD /GET THE FAC
ACH
SHL /SHIFT FAC APPROPRIATELY
1
LOP1, DST /MUST STOR BACK IN CASE RESLT
ACH /BIT IS 0
DLD /GET TRIAL BIT
AC0
ASR /SHIFT THE BIT APPROPRIATELY
ACNT, 0
ISZ ACNT /SHIFT 1 MORE NEXT TIME
DAD /ADD IN RESULT SO FAR
OPH
DCM /NEGATE IT
ISZ RBCNT /BUMP COUNTER FOR RESLT BIT
DAD /DO THE SUBTRACT
ACH
SNL /RESULT NEGATIVE?
JMP GON /YES-NEXT RESULT BIT = 0
DPSZ /NO-DID WE GET A ZERO REMAINDER?
JMP NOTZRO /NOPE
ZREM, CMA /YES-SET SO LOOKS LIKE WE'RE DONE
DCA AC2
NOTZRO, DST /GOOD SUBTR.-MODIFY FAC
ACH /ITS NOT CHANGED BY BAD SUBTRACT
CAM /CLEAR EVERYTHING
RTR
ASR /SHIFT RESLT BIT TO RIGHT PLACE
RBCNT, 0
DAD /ADD IT TO THE RESULT SO FAR
OPH /WE APPEND IT TO RIGHT OF LAST
DST /BIT
OPH /STORE IT BACK
GON, ISZ AC2 /DONE 23 BITS?
JMP LOOP /NO-GO ON
DONE, DLD /YES-GET RESULT-ITS NORMALIZED
OPH
DCA ACH /STORE HIGH ORDER BACK
SWP
DCA ACL /STORE LOW ORDER BACK
JMP I FROOT /RETURN
KM22, -26
K6000, 6000
PAGE
>
/23-BIT EXTENDED FUNCTIONS
/1-31-72 R BEAN
/******SINE******
SIN, 0
JMS NHNDLE /IF X<0,NEGATE X AND SET NFLAG
JMS I (FFMPY /X*2/PI
TOVPI
JMS FRACT /SAVE X IN TEMP1,THE INTEGER PART OF X IN NUM,AND GET FRACTIONAL PART IN FAC
TAD NUM /GET INTEGER PART OF (2/PI)*X
AND (3 /ISOLATE BITS 10,11
TAD JMPISN
DCA .+1 /MAKE JUMP TO ARGUMENT REDUCING ROUTINE
JMP . /AND ADJUST ARG ACCORDING TO QUADRANT OF X
JMPISN, JMP I .+1
POLYSN /X IN QUAD1,SIN(X)=SIN(X)
QUAD2 /X IN QUAD2,SIN(X)=SIN(1-X)
QUAD3 /X IN QUAD3,SIN(X)=SIN(-X)
QUAD4 /X IN QUAD4,SIN(X)=SIN(X-1)
QUAD2, JMS I (FFSUB1 /1-X
ONE
JMP POLYSN /CALCULATE SIN(1-X)
QUAD3, JMS I [FFNEG /-X
JMP POLYSN /CALCULATE SIN(-X)
QUAD4, JMS I (FFSUB /X-1
ONE
POLYSN, JMS I [FFPUT /SAVE X
FPPTM1
JMS I (FFSQ /U=X**2
JMS I [FFPUT /SAVE U
FPPTM2
JMS I (FFMPY /A7*U
SINA7
JMS I (FFADD /A5+A7*U
SINA5
JMS I (FFMPY /A5*U+A7*U**2
FPPTM2
JMS I (FFADD /A3+A5(U)+A7(U**2)
SINA3
JMS I (FFMPY /A3(U)+A5(U**2)+A7(U**3)
FPPTM2
JMS I (FFADD /A1+A3(U)+A5(U**2)+A7(U**3)
SINA1
JMS I (FFMPY /A1(X)+A3(X**3)+A5(X**5)+A7(X**7)
FPPTM1
JMS NCHK /IF NFLAG IS SET,SET SIN(X)=-SIN(X)
JMP I SIN /FAC=SIN(X)
/******COSINE******
/USES SIN ROUTINE TO CALCULATE COS(X)
COS, 0
JMS I (FFADD /COS(X)=SIN(PI/2+X)
PIOV2
JMS SIN
JMP I COS /RETURN
/ROUTINE TO SEPERATE THE INTEGER AND FRACTIONAL PARTS OF FAC
/ORIGINAL FAC IS SAVED IN TEMP1,THE INTEGER PORTION OF FAC IS
/SAVED AT NUM,AND THE FRACTIONAL FORTION OF THE FAC IS LEFT IN THE FAC
FRACT, 0
JMS I [FFPUT /SAVE X
FPPTM1
JMS I (FFIX /INTEGER PORTION OF X
TAD ACX
DCA NUM /SAVE FIXED FORTION OF X
JMS I [FFLOAT /FAC=FLOAT(FIX(X))
JMS I (FFSUB1 /FAC=X-INT(X)=FRACTION (X)
FPPTM1
JMP I FRACT /RETURN
/ROUTINE TO CHECK IF FAC<0; IF IT IS,FAC IS NEGATED AND NFLAG IS
/SET TO 1
NHNDLE, 0
TAD ACH /FETCH HIGH ORDER MANTISSA
SMA CLA /IS IT <0?
JMP NFLGST /NO-CLEAR NFLAG
JMS I [FFNEG /YES-NEGATE FAC
IAC /AND SET NFLAG
NFLGST, DCA NFLAG
JMP I NHNDLE
/ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0
NCHK, 0 /LOC ALSO USED FOR TEMP STORAGE
TAD NFLAG
SZA CLA /IS NFLAG=0?
JMS I [FFNEG /NO-NEGATE FAC
JMP I NCHK /YES-RETURN
NUM=NCHK
/******EXPONENTIAL******
EXPON1, 0 /LOC USED FOR TEMP STORAGE BY SIN,ARCTAN
JMS I (FFMPY /Y=XLOG2(E)
LOG2E
JMS FRACT /GET FRACTIONAL PART OF Y
JMS I (FFMPY /(FRACTION(Y))*(LN2/2)
LN2OV2
JMS I [FFPUT /SAVE Y
FPPTM1
JMS I (FFSQ /Y**2
JMS I (FFADD /B1+Y**2
EXPB1
JMS I (FFDIV1 /A1/(B1+Y**2)
EXPA1
JMS I (FFADD /A0+A1/(B1+Y**2)
EXPA0
JMS I (FFSUB /A0-Y+A1/(B1+Y**2)
FPPTM1
JMS I [FFPUT /SAVE
FPPTM2
JMS I [FFGET /GET Y
FPPTM1
ISZ ACX /MULT. BY 2=2Y
NOP
JMS I (FFDIV /2Y/(A0-Y+A1/(B1+Y**2))
FPPTM2
JMS I (FFADD /1+2Y/(AO-Y+A1/(B1+Y**2))
ONE
JMS I (FFSQ /[1+2Y/(A0-Y+A1/(B1+Y**2))]**2=EXP(Y)
TAD NUM
TAD ACX /EXP(X)=(2**N)(EXPY)
DCA ACX
JMP I EXPON1 /FAC=EXPON(X)
NFLAG=EXPON1
/CONSTANT THAT WOULDN'T FIT ELSEWHERE
TOVPI, 0 /.6366198
2427
6302
MULLIM, 0
TAD ACX /CHECK IF NUMBER OF MULTIPLIES IS TOO LARGE
SPA
CLA /RETURN IF EXPONENT IS NEGATIVE (WE'LL USE LOGS)
TAD (-4 /ONLY A ROUGH ROUGH LIMIT ON THE EXPONENT
SPA SNA CLA /SKP IF NUMBER GT 15 APPROX
JMP I MULLIM /NO, CONTINUE
JMP I (USELOG /YES, USE LOG INSTEAD
PAGE
/******ARC TANGENT******
ATAN, 0
JMS I NHNDLL /IF X<0,SET NFLAG AND NEGATE
JMS I [FFPUT /SAVE X
FPPTM1
JMS I FSUBM /X-1
ONE
TAD ACH /GET HI MANTISSA
SPA CLA /WAS X>1?
JMP ARGPOL /NO-CLEAR GT1FLG
JMS I [FFGET /YES-ATAN(X)=PI/2-ATAN(1/X)
ONE
JMS I FDIVM /1/X
FPPTM1
JMS I [FFPUT
FPPTM1
IAC /SET GT1FLG
ARGPOL, DCA GT1FLG
JMS I [FFGET /GET X OR 1/X
FPPTM1
JMS I FSQRM /Y**2
JMS I [FFPUT /SAVE
FPPTM2
JMS I FADDM /Y**2+B3
ATANB3
JMS I FDIV1M /A3/(Y**2+B3)
ATANA3
JMS I FADDM /B2+A3/(Y**2+B3)
ATANB2
JMS I FADDM /Y**2+B2+A3/(Y**2+B3)
FPPTM2
JMS I FDIV1M /A2/(Y**2+B2+A3/(Y**2+B3))
ATANA2
JMS I FADDM /B1+A2/(Y**2+B2+A3/(Y**2+B3))
ATANB1
JMS I FADDM /Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))
FPPTM2
JMS I FDIV1M /A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
ATANA1
JMS I FADDM /B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
ATANB0
JMS I FMPYM /ATAN(Y)=X*(B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))))
FPPTM1
TAD GT1FLG /WAS X>1?
SNA CLA
JMP NGT /NO-TEST IF X<0?
JMS I FSUB1M /ATAN(X)=PI/2-ATAN(1/X)
PIOV2
NGT, JMS I NCHKL /IF NFLAG SET,NEGATE FAC
JMP I ATAN /FAC=ATAN(X)
NHNDLL, NHNDLE
NCHKL, NCHK
/******NAPERIAN LOGARITHM******
GTFLG=ATAN
LOG, 0
TAD ACH
SPA SNA /X<0 OR X=0?
JMP I ARTRAP /YES-TAKE ILLEGAL ARGUMENT TRAP
CLL RTL
SNA /NO-HORD=2000?
TAD ACX /YES-EXP=1?
CMA IAC
IAC
SNA
TAD ACL /YES-LORD=0?
SZA CLA
JMP POLYNL /NO-ARG IS LEGAL AND NOT 1
DCA ACX
DCA ACL
LTRPRT, DCA ACH
JMP I LOG /YES-LOG(1)=0
POLYNL, TAD ACX
DCA GTFLG /SAVE EXPONENT FOR LATER
DCA ACX /ISOLATE MANTISSA IN FAC
JMS I [FFPUT /SAVE F
FPPTM1
JMS I FADDM /F+SQR(.5)
SQRP5
JMS I [FFPUT /SAVE
FPPTM2
JMS I [FFGET
FPPTM1
JMS I FSUBM /F-SQR(.5)
SQRP5
JMS I FDIVM /Z=F+SQR(.5)/F-SQR(.5)
FPPTM2
JMS I [FFPUT
FPPTM1
JMS I FSQRM /Z**2
JMS I [FFPUT
FPPTM2
JMS I FMPYM /C5(Z**2)
LOGC5
JMS I FADDM /C3+C5(Z**2)
LOGC3
JMS I FMPYM /C3(Z**2)+C5(Z**4)
FPPTM2
JMS I FADDM /C1+C3(Z**2)+C5(Z**4)
LOGC1
JMS I FMPYM /C1(Z)+C3(Z**3)+C5(Z**5)
FPPTM1
JMS I FSUBM /C1(Z)+C3(Z**3)+C5(Z**5)-1/2=LOG2(F)
ONEHAF
JMS I [FFPUT /SAVE LOG2(F)
FPPTM2
TAD GTFLG /I
DCA ACX /SET UP FLOAT
JMS I [FFLOAT
JMS I FADDM /I+LOG2(F)
FPPTM2
JMS I FMPYM /[I+LOG2(F)]*LOGE(2)=LOGE(X)
LN2
JMP I LOG /FAC=LN(X)
GT1FLG=LOG
FMPYM, FFMPY
FADDM, FFADD
FDIVM, FFDIV
FDIV1M, FFDIV1
FSUBM, FFSUB
FSUB1M, FFSUB1
FSQRM, FFSQ
ARTRAP, LM
/CONSTANTS USED BY VARIOUS FUNCTIONS
SINA1, 1 /1.5707949
3110
3747
SINA3, 0 /-.64592098
5325
1167
SINA5, 7775 /.07948766
2426
2466
SINA7, 7771 /-.004362476
5610
3164
PIOV2, 1 /1.5707963
3110
3756
LOG2E, 1 /1.442695
2705
2434
LN2OV2, 7777 /.34657359
2613
4415
EXPB1, 6 /60.090191
3602
7054
EXPA1, 12 /-601.80427
5514
3104
EXPA0, 4 /12.015017
3001
7301
ATANB0, 7776 /.17465544
2626
6157
ATANA1, 2 /3.7092563
3553
1071
ATANB1, 3 /6.762139
3303
670
ATANA2, 3 /-7.10676
4344
5267
ATANB2, 2 /3.3163354
3241
7554
ATANA3, 7777 /-.26476862
5703
4040
ATANB3, 1 /1.44863154
2713
3140
SQRP5, 0 /.7071068
2650
1170
LOGC1, 2 /2.8853913
2705
2440
LOGC3, 0 /.9614706
3661
566
LOGC5, 0 /.59897865
2312
5525
ONEHAF, 0 /.5
2000
0
LN2, 0 /.6931472
2613
4415
*4500
/******FIX******
/ROUTINE TO FIX ANY FLOATING NUMBER IN FAC BETWEEN -2047 AND +2047 TO
/A TWELVE BIT INTEGER AND LEAVE RESULT IN EXP (LOC 44)
FFIX, 0
CLA
TAD ACX /FETCH EXPONENT
SZA SMA /IS NUMBER <1?
JMP .+3 /NO-CONTINUE ON
FTRPRT, CLA
JMP FIXDNE+1 /YES-FIX IT TO ZERO
TAD (-13 /SET BINARY POINT AT 11
SNA /PLACES TO RIGHT OF CURRENT POINT?
JMP FIXDNE /NO-NUMBER IS ALREADY FIXED THEN.
SMA /YES-IS NUMBER TOO LARGE TO FIX?
JMP I (FO /YES-TAKE OVERFLOW TRAP
DCA ACX /NO-SET SCALE COUNT
FIXLP, CLL /0 IN LINK
TAD ACH /GET HIGH MANTISSA
SPA /IS IT <0?
CML /YES-PUT A 1 IN LINK
RAR /SCALE RIGHT
DCA ACH /SAVE
ISZ ACX /DONE YET?
JMP FIXLP /NO
FIXDNE, TAD ACH /YES-ANSWER IN AC
DCA ACX /RETURN WITH ANSWER IN 44
JMP I FFIX /RETURN
/******FLOAT******
/ROUTINE TO FLOAT ANY INTEGER IN EXP (LOC 44) INTO FAC
FFLOAT, 0
TAD ACX
DCA ACH /PUT NUMBER IN HI MANTISSA
DCA ACL /CLEAR LOW MANTISSA
TAD (13 /11(10) INTO EXPONENT
DCA ACX
JMS I [FFNOR /NORMALIZE
JMP I FFLOAT /RETURN
/RANDOM NUMBER GENERATOR
RND, 0
TAD I (RSEED /GET SEED
DCA TEMP3 /PUT IN MULTIPLY OPERAND
TAD (73
JMS I [MPY /MULTIPLY SEED BY 73
DCA I (RSEED /USE LOW ORDER 12 BITS AS NEW SEED
TAD I (RSEED /LOW ORDER OF PRODUCT ALSO SERVES
CLL RAR /AS RANDOM NUMBER
DCA ACH /SET SIGN TO 0 AND STORE AS HORD
DCA ACX
RAR
DCA ACL /USE 12 BITS AS MANTISSA
DCA AC1 /CLEAR FPP OVERFLOW
JMS I [FFNOR /AND NORMALIZE
JMP I [ILOOP /DONE
PAGE
/FLOATING POINT OUTPUT ROUTINE
/CONVERT INTERNAL NUMBER TO ASCII
/EXIT WITH CHAR STRING IN 'INTERB'
/XR1 = POINTER TO LAST CHAR STORED
FFOUT, 0
TAD (INTERB-1
DCA XR1 /SET POINTER TO ASCII BUFFER
TAD ACH /SEE IF FAC NEGATIVE
SMA CLA
JMP OKPOS /JMP IF POSITIVE
JMS I [FFNEG /TAKE ABS VALUE IF NEGATIVE
TAD ("- /PRINT MINUS SIGN
SKP
OKPOS, TAD (240 /PRINT SPACE IF POSITIVE
DCA I XR1
TAD ACH /SEE IF NUMBER IS ZERO
SNA CLA
JMP ZERXIT /SPECIAL CASE IF SO
JMS I (CVTNUM /CALL ROUTINE TO UNPACK TO BASE 10
TAD (NUMBUF-1
DCA XR2 /POINT XR2 AT DIGIT BUFFER
TAD (5 /TEST FORMAT TO USE
TAD DECEXP
CLL
TAD (-4
SNL
JMP SMLFMT /JMP IF .0NNNNNN TO .0000NNNNNN
TAD (-7
SZL CLA
JMP REGFMT /JMP IF .NNNNNN TO NNNNNN
/OTHERWISE USE E FORMAT N.NNNNNE+NNN OR N.NNNNNE-NNN
TAD I XR2 /GET DIGIT TO LEFT OF POINT
JMS PUTD /PUT IT OUT
TAD (".
DCA I XR1 /NOW SEND OUT DECIMAL POINT
TAD (-5
DCA AC2 /DO 5 MORE DIGITS
TAD I XR2 /PICK UP DIGIT
JMS PUTD /CONVERT TO ASCII AND STORE
ISZ AC2
JMP .-3 /LOOP FOR MORE
TAD ("E /PRINT E
DCA I XR1
/ CLL
TAD DECEXP /TAKE ABS(DECEXP)
SPA
CML CIA
DCA DECEXP
RTL /CONVERT "+" TO "-" IF NEGATIVE
TAD ("+
DCA I XR1
JMS IDIV /PRINT 3 DIGITS OF EXPONENT NOW
-144
JMS IDIV
-12
TAD DECEXP
JMS PUTD
JMP I FFOUT /ALL DONE --RETURN--
/HANDLE .0NNNNNN TO .0000NNNNNN
SMLFMT, DCA AC0 /STORE NUMBER OF LEADING ZEROES
TAD (". /PUT OUT DECIMAL POINT
DCA I XR1
JMS PUTD /SEND A 0
ISZ AC0
JMP .-2 /LOOP FOR LEADING 0'S
/GENERAL NON E FORMAT .NNNNNN TO NNNNNN
REGFMT, TAD (-7
DCA AC1 /INIT COUNT OF NONZERO DIGITS
TAD (NUMBUF+6
DCA AC2 /POINT AT END OF DIGIT BUFFER
SHRINK, STA /DECREMENT DIGIT POINTER
TAD AC2
DCA AC2
ISZ AC1 /REDUCE SIGNIFICANT DIGIT COUNT
TAD DECEXP
IAC
TAD AC1
SMA CLA
JMP PRTLP /JMP OUT IF NOT TO RIGHT OF DECIMAL POINT
TAD I AC2 /ELSE LOOK AT DIGIT
SNA CLA
JMP SHRINK /DISCARD IT IF ZERO
PRTLP, STA
TAD DECEXP
DCA DECEXP /SEE IF DIGIT TO BE PRINTED FOLLOWS DP
AC0002
TAD DECEXP
SZA CLA
JMP NODP /NO
TAD (". /YES, PRINT DP
DCA I XR1
NODP, TAD I XR2 /PICK UP DECIMAL DIGIT
JMS PUTD /PUT OUT
ISZ AC1
JMP PRTLP /JMP IF MORE DIGITS TO PRINT
JMP I FFOUT /--RETURN--
ZERXIT, JMS PUTD
JMP I FFOUT /--RETURN--
/DIVIDE DECEXP BY -DIVISOR IN CALL+1
IDIV, 0
DCA AC1 /CLEAR QUOTIENT
IDIVLP, TAD DECEXP
TAD I IDIV
SPA
JMP IDVOUT /JMP OUT IF LESS THAN DIVISOR
DCA DECEXP /ELSE UPDATE IT
ISZ AC1 /TALLY QUOTIENT
JMP IDIVLP /ITERATE
IDVOUT, CLA
TAD AC1 /GET QUOT AS NEXT DIGIT
JMS PUTD /PUT OUT
ISZ IDIV
JMP I IDIV
/CONVERT NUMBER IN AC TO ASCII DIGIT
/MUST NOT TOUCH THE LINK
PUTD, 0
TAD ("0 /ADD IN 0
DCA I XR1 /STORE IN BUFFER
JMP I PUTD
PAGE
/CONVERT NUMBER IN FAC TO FORMAT N.NNNNNE NNN
/DECIMAL EXPONENT RETURNED AS SIGNED NUMBER IN DECEXP
/6 DIGITS STORED IN NUMBUF AS BINARY 0-9
/FIRST REDUCES MANTISSA TO FORM 0DD DDF FFF FFF...
/BY SUCCESSIVE MULTIPLIES OR DIVIDES BY 10. FOLLOWED BY
/RENORMALIZATIONS UNTIL INTIGER BITS
/DDDD ARE LT 10.
/DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10.
CVTNUM, 0
DCA AC1 /CLEAR OVERFLOW WORD
SKP /SKP IN AND CLEAR DECIMAL EXPONENT
ADJDEC, TAD DECEXP
DCA DECEXP /STORE UPDATED DECIMAL EXPONENT
NORML, TAD ACH /SEE IF FRACTION IS NORMALIZED
RAL
SPA CLA
JMP NORMED /JMP IF YES
JMS I (AL1 /SHIFT AC LEFT 1 BIT
STA
TAD ACX /COMPENSATE BINARY EXPONENT
DCA ACX
JMP NORML /TRY AGAIN
NORMED, TAD ACX /RANGE CHECK BINARY EXPONENT NOW
SMA SZA
JMP DIVCHK /JMP IF NUMBER GE 1
TAD O4
DCA ACX /INCREASE BINARY EXP TOWARDS ZERO
JMS AR1 /SHIFT 4 BITS RIGHT
JMS AR1 /MAX RELATIVE ERROR WILL BE LT 15*2^-34 PER MULTIPLY
JMS AR1
JMS AR1
JMS MPY10 /NOW MULTIPLY BY 10.
STA /DECREASE DECIMAL EXPONENT
JMP ADJDEC /RENORMALIZE AND TRY AGAIN
DIVCHK, TAD (-5 /SEE IF EXP GT 4
SPA
JMP INRANG /JMP IF NOT, NUMBER MAY BE IN RANGE
DIVGO, CLA CLL
TAD (-40 /SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE)
DCA AC2 /(THE LEN ELEKMAN TECHNIQUE)
/MAX RELATIVE ERROR WILL BE LT 9*2^-34. PER DIVIDE
DVLOOP, TAD ACH /SEE IF GE 10.
TAD (5400
SMA
DCA ACH /UPDATE IF YES
CML STA RAL
DCA AC0 /SAVE LOW ORDER BIT
JMS I (AL1 /SHIFT MANTISSA NOW
ISZ AC0 /STORE BIT NOW
ISZ AC1
ISZ AC2 /BUMP COUNT
JMP DVLOOP /ITERATE
TAD ACH /NOW ZERO OUT REMAINDER
AND [377
DCA ACH
IAC /NOW INCREASE DECIMAL EXPONENT
JMP ADJDEC
INRANG, DCA AC2 /SET SHIFT COUNTER
SKP
JMS AR1 /SHIFT FAC RIGHT
ISZ AC2
JMP .-2 /LEAVE EFFECTIVE BINARY POINT RIGHT OF ACH BIT 4
TAD ACH /ACH = 0DD DDF FFF FFF (D=DECIMAL DIGIT BITS)
TAD (5400 /SEE IF DDDD GE 10
SMA CLA
JMP DIVGO /DIVIDE AGAIN (NORMALIZATION WILL WORK)
CLL
TAD AC1 /NOW ROUND BY ADDING 0.000005
TAD (4761
DCA AC1
IAC /ADD 24761 TO LOW BITS
RAL
TAD ACL
DCA ACL
SZL
ISZ ACH
TAD ACH
TAD (5400 /SEE IF CARRY INTO 9.XXX...
SZA CLA
JMP CVT10 /JMP IF NO
TAD [200 /ELSE SET TO 1.00000
DCA ACH
DCA ACL
DCA AC1
ISZ DECEXP /AND BUMP DECIMAL EXPONENT
O4, 4 /EFFECTIVE NOP
/NOW CONVERT TO DECIMAL DIGITS
CVT10, TAD (-6 /DO 6 DIGITS
DCA AC0
TAD (NUMBUF-1
DCA XR3
JMP CVTGO /FIRST DIGIT IS ALREADY IN
CVTLP, TAD ACH /ZERO OUT PREV DIGIT
AND [177
DCA ACH
JMS MPY10 /MULTIPLY BY 10.
CVTGO, TAD ACH /GET DIGIT FROM 0DD DDF FFF FFF
RTL
RTL
RTL
AND [17
DCA I XR3 /STORE IT
ISZ AC0
JMP CVTLP /LOOP IF MORE
JMP I CVTNUM /--RETURN--
/MULTIPLY ACH,,ACL,,AC1 BY 10.
MPY10, 0
TAD ACH
DCA OPH /COPY AC TO OP
TAD ACL
DCA OPL
TAD AC1
DCA AC2
JMS I (AL1 /N*2
JMS I (AL1 /N*4
JMS I (OADD /N*5
JMS I (AL1 /N*10.
JMP I MPY10
/SHIFT FAC RIGHT 1 BIT
AR1, 0
TAD ACH
CLL RAR
DCA ACH
TAD ACL
RAR
DCA ACL
TAD AC1
RAR
DCA AC1
JMP I AR1 /DONE
PAGE
IFZERO EAE <
/FLOATING POINT INPUT ROUTINE
FFIN, 0
CLA CMA
DCA I FDVPT /INITIALIZE PERIOD SWITCH TO -1
CMA /SET SIGN SWITCH TO -1
DCA SIGNF
CDF /DF TO PACKAGE FIELD
DCA DSWIT /ZERO CONVERSION SWITCH
DECONV, DCA ACX /ZERO OUT THE FAC!
DCA ACL
P200, 200
DCA ACH
DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT.
DECON, JMS GCHR /GET A CHAR.FROM TTY.
JMP FFIN1 /TERMINATOR-
ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH
ISZ DNUMBR /BUMP # OF DIGITS-# IS STORED IN
JMS I FMPYLL /"FMPY TEN"
TEN
JMS I [FFPUT /"FPUT I TM3PT"
FPPTM1
JMS I [FFGET /"FGET TP"
TP
JMS I [FFNOR /"FNOR"
JMS I FADDLL /"FADD I TM3PT"
FPPTM1
JMP DECON /GO ON
FFIN1, ISZ I FDVPT /HAVE WE HAD A PERIOD YET?
JMP FIGO2 /YES-GO ON
ISZ TP1 /NO-IS THIS A PERIOD?
ISZ TP1
SKP CLA
JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT.
/AND GO CONVERT REST
DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF
/DIGITS AFTER DECIMAL POINT.
FIGO2, ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?)
JMS I FFNEGP /YES-NEGATE IT
CLA CMA /RESET SIGN SWITCH FOR EXP.
DCA SIGNF
TAD CHAR /NO-WAS THE TERMINATOR AN 'E'?
TAD KME
SNA CLA
GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT
JMP EDON /END OF EXPONENT
TAD TM /GOT DIG. OF EXP-STORED IN TP1
CLL RTL /MULT. ACCUMULATED EXP BY 10
TAD TM
CLL RAL
TAD TP1 /ADD DIGIT
JMP GETE /CONTINUE
EDON, TAD TM /GET EXPONENT
ISZ SIGNF /WAS EXPONENT NEGATIVE?
CMA IAC /YES-NEGATE IT
CMA IAC /AND CALC. DNUMBR - EXPON.
TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN
CLL CMA IAC
SPA /RESULT POSITIVE?
CLL CMA CML IAC /NO-MAKE POS. AND SET LINK
CMA /NEGATE FOR COUNTER
DCA DNUMBR /AND STORE
RAL /LINK=1-DIV;=0-MUL. # BY TEN
TAD MDV /FORM CORRECT INSTRUCTION
DCA SIGNF /AND STORE FOR EXECUTION
FCNT, ISZ DNUMBR /DONE ALL OPERATIONS?
JMP SIGNF /NO
JMP I FFIN /YES-RETURN
SIGNF, 0 /NO- MUL OR DIV. MANTISSA
TEN /BY TEN
JMP FCNT /GO ON
FFNEGP, FFNEG
DNUMBR, 0
KME, -305
MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER
FMPYLL, FFMPY
FDVPT, FFDIV /!!!!!!!!!!!!!!!!!
FADDLL, FFADD
KK12, 12
TP, 13
TP1, 0
0
TEN, 4
2400
0
/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
/OR A TERMINATOR.
/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
/THIS ROUTINE MUST NOT MODIFY THE MQ!!
GCHR, 0
DCA TM /STORE ACCUMULATED EXPONENT (MAYBE)
JMS INPUT /GET A CHAR FROM TTY.
TAD CHAR /PICK IT UP
TAD PLUS /WAS IT PLUS SIGN?
SNA
JMP DECON1 /YES-GET ANOTHER CHAR.
TAD MINUS /NO WAS IT MINUS SIGN?
SZA CLA
JMP .+3
DCA SIGNF /YES-FLIP SWITCH
DECON1, JMS INPUT /GET A CHAR.
TAD CHAR
TAD K7506 /SEE IF ITS A DIGIT
CLL
TAD KK12
DCA TP1 /STORE FOR LATER
SZL /DIGIT?
ISZ GCHR /YES-RETN. TO CALL+2
JMP I GCHR /NO-RETN. TO CALL+1
K7506, 7506
/
/INPUT ROUTINE-IGNORES LEADING SPACES
/
INPUT, 0
JMS I IGETCH /USE OUR ROUTINE TO GET CHAR
TAD DSWIT /GET TERMINATOR
SZA CLA /VALID INPUT YET?
JMP IOUT /YES-CONTINUE
TAD CHAR /NO-GET CHAR
TAD M240 /COMPARE AGAINST SPACE
SZA /SKP IF SPACE
TAD (240-212 /COMPARE TO LF
SNA CLA /IS IT A SPACE OR LF?
JMP INPUT+1 /YES-IGNORE IT
IOUT, JMP I INPUT /RETURN
IGETCH, GETCH /POINTER TO GET CHAR ROUTINE
/ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL)
M240, -240
PLUS, -253
MINUS, 253-255
/
/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
/
PATCHF, 0
SZA /IS AC EMPTY
JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
TAD FF /YES-GET SPECIAL MODE FLIP-FLOP
SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0
RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND
JMP I PATCHF /RETURN
PAGE
/
/INVERSE FLOATING SUBTRACT-USES FLOATING ADD
/!!FSW1!!-THIS IS OP-FAC
/
FFSUB1, 0
JMS I [PATCHF /WHICH MODE?
TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP.
JMS I ARGETL /GO PICK UP OPERAND
CDF
JMS I FFNEGA /NEGATE FAC
TAD FFSUB1 /AND GO ADD
JMP I SUB0P
FFNEGA, FFNEG
SUB0P, SUB0
/
/INVERSE FLOATING DIVIDE
/FSWITCH=1
/THIS IS OP/FAC
/
FFDIV1, 0
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFDIV1 /CALLED BY USER-GET ADDR.
JMS I ARGETL /PICK UP OPERAND
TAD ACL /SWAP THE FAC AND OPERAND
DCA OPL /THERE IS A POINTER TO OPL
TAD I AC2 /IN AC2 LEFT FROM ARGET SUBR.
DCA ACL
TAD ACX /MIGHT AS WELL SUBTRACT THE
CLL CMA IAC /EXPONENTS HERE (SAVES A WORD)
TAD OPX /THEN ZERO OPX SO WILL NOT
DCA ACX /MESS UP WHEN ITS DONE AGAIN
DCA OPX /LATER (SEE DIV. ROUTINE)
TAD ACH
DCA AC2 /NOW SWAP HIGH ORDER MANTISSAS
TAD OPH
DCA ACH
TAD AC2
DCA OPH
CDF /DF TO PACKAGE FIELD
TAD FFDIV1 /NOW KLUDGE UP A SUBROUTINE LINKAGE
DCA I FFDP
TAD KFD1
DCA I MDSETP
JMP I MD1P /GO SET UP AND DIVIDE
MD1P, MD1
ARGETL, ARGET
MDSETP, MDSET
FFDP, FFDIV
KFD1, FFD1
/MDSET-SETS UP SIGNS FOR MULTIPLY AND DIVIDE
/ALSO SHIFTS OPERAND ONE BIT TO THE LEFT.
/EXIT WITH EXPONENT OF OPERAND IN AC FOR EXPONENT
/CALCULATION-CALLED WITH ADDRESS OF OPERAND IN AC AND
/DATA FIELD SET PROPERLY FOR OPERAND.
/
MDSET, 0
JMS I ARGETK /GET ARGUMENT
MD1, CDF /DF TO PACKAGE FIELD
CLA CLL CMA RAL /SET SIGN CHECK TO -2
DCA TM
TAD OPH /IS OPERAND NEGATIVE?
SMA CLA
JMP .+3 /NO
JMS I OPNEGP /YES-NEGATE IT
ISZ TM /BUMP SIGN CHECK
TAD OPL /AND SHIFT OPERAND LEFT ONE BIT
CLL RAL
DCA OPL
TAD OPH
RAL
DCA OPH
DCA AC1 /CLR. OVERFLOW WORF OF FAC
TAD ACH /IS FAC NEGATIVE
SMA CLA
JMP LEV /NO-GO ON
JMS I FFNEGK /YES-NEGATE IT
ISZ TM /BUMP SIGN CHECK
NOP /MAY SKIP
LEV, TAD OPX /EXIT WITH OPERAND EXPONENT IN AC
JMP I MDSET
FFNEGK, FFNEG
OPNEGP, OPNEG
ARGETK, ARGET
/
/CONTINUATION OF FLOATING DIVIDE ROUTINE
/
FD1, TAD AC2 /NEGATE HI ORDER PRODUCT
CLL CMA IAC
TAD ACH /COMPARE WITH REMAINDER OF FIRST DIV.
SNL /WELL?
JMP I DVOPSP /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
CLL /OK-DO (REM-(Q*OPL))/OPH
DCA ACH /FIRST STORE ADJUSTED PRODUCT
JMS I DV24P /DIVIDE BY OPH (HI ORDER OPERAND)
DVL1, TAD AC1 /GET QUOT. OF FIRST DIV.
SMA /IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT
JMP FD /NO-ITS NORMALIZED-DONE
CLL
ISZ ACL
SKP
IAC
RAR
DCA ACH /STORE IN FAC
TAD ACL /P@ LOW ORDER RIGHT
RAR
DCA ACL /STORE BACK
ISZ ACX /BUMP EXPONENT
NOP
TAD ACH
JMP DVL1+1
FD, DCA ACH /STORE HIGH ORDER RESULT
JMP I FDDONP /GO LEAVE DIVIDE
FDDONP, FDDON /END OF FLTG. DIV. ROUTINE
DV24P, DV24 /ROUTINE TO DO A 24X12BIT DIVIDE
DVOPSP, DVOPS /ROUTINE TO ADJUST QUOT OF FIRST DIV.
/
/CONTINUATION OF ROUTINE TO ADJUST QUOT. OF FIRST DIV.
/DBAD1 IS ONLY EXECUTED ON DIVIDE OVERFLOW-OTHERWISE THE
/ROUTINE STARTS AT DVOP2
/
DBAD1, DCA ACX /DIVIDE OVERFLO-ZERO ALL
DVOP2, SNA /IS IT ZERO?
DCA ACL /YES-MAKE WHOLE THING ZERO
DCA ACH
JMS I DV24P /DIVIDE EXTENDED REM. BY HI DIVISOR
TAD ACL /NEGATE THE RESULT
CLL CMA IAC
DCA ACL
SNL /IF QUOT. IS NON-ZERO, SUBTRACT
CMA /ONE FROM HIGH ORDER QUOT.
JMP DVL1 /GO TO IT
PAGE
/FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
FFMPY, 0
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFMPY /CALLED BY USER-GET OPERAND ADDR.
JMS I MDSETK /SET UP FOR MPY-OPX IN AC ON RETN.
TAD ACX /DO EXPONENT ADDITION
DCA ACX /STORE FINAL EXPONENT
DCA DV24 /ZERO TEM STORAGE FOR MPY ROUTINE
DCA AC2
TAD ACH /IS FAC=0?
SNA CLA
DCA ACX /YES-ZERO EXPONENT
JMS MP24 /NO-MULTIPLY FAC BY LOW ORDER OPR.
TAD OPH /NOW MULTIPLY FAC BY HI ORDER MULTIPLIER
DCA OPL
JMS MP24
TAD AC2 /STORE RESULT BACK IN FAC
RTZRO, DCA ACL /LOW ORDER
TAD DV24 /HIGH ORDER
DCA ACH
TAD ACH /DO WE NEED TO NORMALIZE?
RAL
SMA CLA
JMP SHLFT /YES-DO IT FAST
MDONE, DCA AC1 /NO-ZERO OVERFLOW WD(DO I NEED THIS???)
ISZ FFMPY /BUMP RETURN POINTER
ISZ TM /SHOULD RESULT BE NEGATIVE?
JMP I FFMPY /NOPE-RETN.
JMS I FFNEGR /YES-NEGATE IT
JMP I FFMPY /RETURN
SHLFT, CMA /SUBTRACT 1 FROM EXP.
TAD ACX
DCA ACX
JMS I AL1PTR /SHIFT FAC LEFT 1 BIT
JMP MDONE+1 /DONE.
AL1PTR, AL1
/
/24 BIT BY 12 BIT MULTIPLY. MULTIPLIER IS IN OPL
/MULTIPLICAND IS IN ACH AND ACL
/RESULT LEFT IN DV24,AC2, AND AC1
MP24, 0
TAD KKM12 /SET UP 12 BIT COUNTER
DCA OPX
TAD OPL /IS MULTIPLIER=0?
SZA
JMP MPLP1 /NO-GO ON
DCA AC1 /YES-INSURE RESULT=0
JMP I MP24 /RETURN
MPLP, TAD OPL /SHIFT A BIT OUT OF LOW ORDER
MPLP1, RAR /OF MULTIPLIER AND INTO LINK
DCA OPL
SNL /WAS IT A 1?
JMP MPLP2 /NO-0-JUST SHIFT PARTIAL PRODUCT
CLL /YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
TAD AC2
TAD ACL /LOW ORDER
DCA AC2
RAL /PROPAGATE CARRY
TAD ACH /HI ORDER
MPLP2, TAD DV24
RAR /NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
DCA DV24
TAD AC2
RAR
DCA AC2
RAR /1 BIT OF OVERFLOW TO AC1
DCA AC1
ISZ OPX /DONE ALL 12 MULTIPLIER BITS?
JMP MPLP /NO-GO ON
JMP I MP24 /YES-RETURN
/
/PART OF DIVIDE ROUTINE-FFDIV MUST BE AT LOC. 6722
MP12L, DCA OPL /STORE BACK MULTIPLIET
TAD AC2 /GET PRODUCT SO FAR
SNL /WAS MULTIPLIER BIT A 1?
JMP .+3 /NO-JUST SHIFT THE PARTIAL PRODUCT
CLL /YES-CLEAR LINK AND ADD MULTIPLICAND
TAD ACL /TO PARTIAL PRODUCT
RAR /SHIFT PARTIAL PRODUCT-THIS IS HI ORDER
DCA AC2 /RESULT-STORE BACK
DVLP1, TAD OPL /SHIFT A BIT OUT OF MULTIPLIER
RAR /AND A BIT OR RESLT. INTO IT (LO ORD. PROD.)
ISZ FFMPY /DONE ALL BITS?
JMP MP12L /NO-LOOP BACK
CLL CMA IAC /YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
DCA ACL /NEGATE AND STORE
CML RAL /PROPAGATE CARRY
JMP I FD1P /GO ON
FD1P, FD1 /POINTER TO REST OF DIVIDE ROUTINE
/
/FLOATING DIVIDE ROUTINE
/USES THE METHOD OF TRIAL DIVISION BY HI ORDER
FFDIV, 0 /(USED AS A TEM. BY I/O ROUTINES)
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFDIV /CALLED BY USER-GET ARG. ADDR.
JMS I MDSETK /GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
FFD1, CMA IAC /NEGATE EXP. OF OPERAND
TAD ACX /ADD EXP OF FAC
DCA ACX /STORE AS FINAL EXPONENT
TAD OPH /NEGATE HI ORDER OP. FOR USE
CLL CMA IAC /AS DIVISOR
DCA OPH
JMS DV24 /CALL DIV.--(ACH+ACL)/OPH
TAD ACL /SAVE QUOT. FOR LATER
DCA AC1
TAD KM13 /SET COUNTER FOR 12 BIT MULTIPLY
DCA FFMPY /TO MULTIPLY QUOT. OF DIV. BY
JMP DVLP1 /LOW ORDER OF OPERAND (OPL)
/
/END OF FLOATING DIVIDE-FUDGE SOME
/STUFF THEN JUMP INTO MULTIPLY
/
FDDON, TAD FFDIV /STORE RETN. ADDR. IN MULT ROUTINE
DCA FFMPY
JMP MDONE /GO CLEAN UP
/
/DIVIDE ROUTINE--24 BITS IN ACH,ACL ARE DIVIDED BY 12 BITS
/IN OPH. OPH IS ASSUMED NEGATIVE AND .GT. ACH IN ABSOLUTE VALUE
/ELSE-DIVIDE OVERFLOW--WE RETURN NORMALLY WITH QUOTIENT
/IN ACL AND REM. IN ACH. (AC2=0 ON RETN.)
/
DV24, 0
TAD ACH /CHECK THAT DIVISOR IS .GT. DIVIDEND
TAD OPH /DIVISOR IN OPH (NEGATIVE)
SZL CLA /IS IT?
JMP I DVOVR /NO-DIVIDE OVERFLOW
TAD KM13 /YES-SET UP 12 BIT LOOP
DCA AC2
JMP DV1 /GO BEGIN DIVIDE
DV2, TAD ACH /CONTINUE SHIFT OF FAC LEFT
RAL
DCA ACH /RESTORE HI ORDER
TAD ACH /NOW SUBTRACT DIVISOR FROM HI ORDER
TAD OPH /DIVIDEND
SZL /GOOD SUBTRACT?
DCA ACH /YES-RESTORE HI DIVIDEND
CLA /NO-DON'T RESTORE--OPH.GT.ACH
DV1, TAD ACL /SHIFT FAC LEFT 1 BIT-ALSO SHIFT
RAL /1 BIT OF QUOT. INTO LOW ORD OF ACL
DCA ACL
ISZ AC2 /DONE 12 BITS OF QUOT?
JMP DV2 /NO-GO ON
JMP I DV24 /YES-RETN W/AC2=0
FFNEGR, FFNEG
MDSETK, MDSET
KKM12, -14
KM13, -15
DVOVR, DV
PAGE
/
/FLOATING ADD
/
FFADD, 0
JMS I [PATCHF /WHICH MODE FO CALL?
TAD I FFADD /CALLED BY USER-GET ADDR. OF OPR.
JMS I ARGETP /PICK UP OPERAND
FAD1, CDF /DF TO PACKAGE FIELD
TAD OPH /IS OPERAND = 0
SNA CLA
JMP DONA /YES-DONE
TAD ACH /NO-IS FAC=0?
SNA CLA
JMP DOADD /YES-DO ADD
TAD ACX /NO-DO EXPONENT CALCULATION
CLL CMA IAC
TAD OPX
SMA SZA /WHICH EXP. GREATER?
JMP FACR /OPERANDS-SHIFT FAC
CMA IAC /FAC'S-SHIFT OPERAND=DIFFRNCE+1
JMS OPSR
JMS ACSR /SHIFT FAC ONE PLACE RIGHT
DOADD, TAD OPX /SET EXPONENT OF RESULT
DCA ACX
JMS OADD /DO THE ADDITION
JMS I FNORP /NORMALIZE RESULT
DONA, ISZ FFADD /BUMP RETURN
JMP I FFADD /RETURN
FACR, JMS ACSR /SHIFT FAC = DIFF.+1
JMS OPSR /SHIFT OPR. 1 PLACE
JMP DOADD /DO ADDITION
/
/OPERAND SHIFT RIGHT-ENTER WITH POSITIVE COUNT-1
/IN AC
OPSR, 0
CMA /- (COUNT+1) TO SHIFT COUNTER
DCA AC0
LOP2, TAD OPH /GET SIGN BIT
RAL /TO LINK
CLA
TAD OPH /GET HI MANTISSA
RAR /SHIFT IT RIGHT, PROPAGATING SIGN
DCA OPH /STORE BACK
TAD OPL
RAR
DCA OPL /STORE LO ORDER BACK
RAR /SAVE 1 BIT OF OVERFLOW
DCA AC2 /IN AC2
ISZ OPX /INCREMENT EXPONENT
NOP2, NOP
ISZ AC0 /DONE ALL SHIFTS?
JMP LOP2 /NO-LOOP
JMP I OPSR /YES-RETN.
/
/SHIFT FAC LEFT 1 BIT
/
AL1, 0
TAD AC1 /GET OVERFLOW BIT
CLL RAL /SHIFT LEFT
DCA AC1 /STORE BACK
TAD ACL /GET LOW ORDER MANTISSA
RAL /SHIFT LEFT
DCA ACL /STORE BACK
TAD ACH /GET HI ORDER
RAL
DCA ACH /STORE BACK
JMP I AL1 /RETN.
/
/SHIFT FAC RIGHT-ENTER WITH COUNT-1 IN AC (POSITIVE)
/
ACSR, 0
CMA /AC CONTAINS COUNT-1
DCA AC0 /STORE COUNT
LOP1, TAD ACH /GET SIGN BIT OF MANTISSA
RAL /SET UP SIGN PROPAGATION
CLA
TAD ACH /GET HIGH ORDER MANTISSA
RAR /SHIFT RIGHT`1, PROPAGATING SIGN
DCA ACH /STORE BACK
TAD ACL /GET LOW ORDER
RAR /SHIFT IT
DCA ACL /STORE BACK
RAR
DCA AC1 /SAVE 1 BIT OF OVERFLOW
ISZ ACX /INCREMENT EXPONENT
NOP1, NOP
ISZ AC0 /DONE?
JMP LOP1 /NO-LOOP
JMP I ACSR /YES-RETN-AC=L=0
/
/DIVIDE OVERFLOW-ZERO ACX,ACH,ACL
/
DBAD, CLA CLL /NECESSARY SO WE DON'T GET OVRFLO AGAIN
JMP I DBAD1P /GO ZERO ALL
/
/FLOATING SUBTRACT
/
FFSUB, 0
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFSUB /CALLED BY USER-GET ADDR. OF OP
JMS I ARGETP /PICK UO THE OP.
JMS OPNEG /NEGATE OPERAND
TAD FFSUB /JMP INTO FLTG. ADD
SUB0, DCA FFADD /AFTER SETTING UP RETURN
JMP FAD1
ARGETP, ARGET
*6135
/
/FLOATING NEGATE
/
FFNEG, 0 /(USED AS A TEM. BY OUTPUT ROUTINE)
TAD ACL /GET LOW ORDER FAC
CLL CMA IAC /NEGATE IT
DCA ACL /STORE BACK
CML RAL /ADJUST OVERFLOW BIT AND
TAD ACH /PROPAGATE CARRY-GET HI ORD
CLL CMA IAC /NEGATE IT
DCA ACH /STORE BACK
JMP I FFNEG
/
/NEGATE OPERAND
/
OPNEG, 0
TAD OPL /GET LOW ORDER
CLL CMA IAC /NEGATE AND STORE BACK
DCA OPL
CML RAL /PROPAGATE CARRY
TAD OPH /GET HI ORDER
CLL CMA IAC /NEGATE AND STORE BACK
DCA OPH
JMP I OPNEG
/
/ADD OPERAND TO FAC
/
OADD, 0
CLL
TAD AC2 /ADD OVERFLOW WORDS
TAD AC1
DCA AC1
RAL /ROTATE CARRY
TAD OPL /ADD LOW ORDER MANTISSAS
TAD ACL
DCA ACL
RAL
TAD OPH /ADD HI ORDER MANTISSAS
TAD ACH
DCA ACH
JMP I OADD /RETN.
DBAD1P, DBAD1
FNORP, FFNOR
>
IFNZRO EAE <
/EAE FLOATING POINT PACKAGE
/FOR PDP8/E WITH KE8-E EAE
/
/W.J. CLOGHER
/
/DEFINITIONS OF EAE INSTRUCTIONS
SWP= 7521
CAM= 7621
MQA= 7501
MQL= 7421
SGT= 6006
SWAB= 7431
SWBA= 7447
SCA= 7441
MUY= 7405
DVI= 7407
NMI= 7411
SHL= 7413
ASR= 7415
LSR= 7417
ACS= 7403
SAM= 7457
DAD= 7443
DLD= 7663
DST= 7445
DPIC= 7573
DCM= 7575
DPSZ= 7451
/
TM= TEMP4
/
/FLOATING POINT INPUT ROUTINE
/
PAGE
FFIN, 0
CLA CMA
DCA PRSW /INITIALIZE PERIOD SWITCH TO -1
CMA /SET SIGN SWITCH TO -1
DCA SIGNF
CDF /CHANGE TO DF OF PACKAGE
DCA DSWIT /ZERO CONVERSION SWITCH
DECONV, DCA ACX /ZERO OUT THE FAC!
DCA ACL
DCA ACH
DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT.
DECON, JMS GCHR /GET A CHAR.FROM TTY.
JMP FFIN1 /TERMINATOR-
ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH
ISZ DNUMBR /BUMP # OF DIGITS
DCA TP1 /STORE IT IN FORM EASILY FLOATIBLE
JMS I FMPYLL /MULTIPLY # BY 10
TEN
JMS I [FFPUT /STORE IT AWAY
FPPTM1
JMS I [FFGET /GET NEW DIGIT
TP
JMS I [FFNOR /FLOAT IT
JMS I FADDLL /ADD IT TO THE ACCUMULATED #
FPPTM1
JMP DECON /GO ON
FFIN1, ISZ PRSW /HAVE WE HAD A PERIOD YET?
JMP FIGO2 /YES-GO ON
TAD K2 /NO-IS THIS A PERIOD?
SNA CLA
JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT.
/AND GO CONVERT REST
DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF
/DIGITS AFTER DECIMAL POINT.
FIGO2, CLA MQL /0 TO MQ FOR LATER MULTIPLY
ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?)
JMS I FFNEGP /YES-NEGATE IT
SWAB
CMA /RESET SIGN SWITCH FOR EXP.
DCA SIGNF
TAD CHAR /NO-WAS THE TERMINATOR AN 'E'?
TAD KME
SNA CLA
GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT
JMP EDON /END OF EXPONENT
MUY /GOT DIGIT OF EXP-MULT ACCUMULATED
K12 /EXPONENT BY TEN AND ADD DIGIT
JMP GETE /CONTINUE
EDON, ISZ SIGNF /WAS EXPONENT NEGATIVE?
DCM /YES-NEGATE IT
CLA CLL /CLEAR AC AND LINK
TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN
SAM /SUBTRACT FROM EXPONENT
CLL
SPA /RESULT POSITIVE?
CLL CMA CML IAC /NO-MAKE POS. AND SET LINK
CMA /NEGATE FOR COUNTER
DCA DNUMBR /AND STORE
RAL /LINK=1-DIV;=0-MUL. # BY TEN
TAD MDV /FORM CORRECT INSTRUCTION
DCA FINST /AND STORE FOR EXECUTION
FCNT, ISZ DNUMBR /DONE ALL OPERATIONS?
JMP FINST /NO
JMP I FFIN /YES-RETURN
FINST, 0 /NO- MUL OR DIV. MANTISSA
TEN /BY TEN
JMP FCNT /GO ON
FFNEGP, FFNEG
PRSW, 0
DNUMBR, 0
SIGNF, 0
K2, 2
KME, -305
MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER
FMPYLL, FFMPY
FFDIV /!!!!!!!!!!!!!!!!!
FADDLL, FFADD
K12, 12
TP, 13
TP1, 0
0
TEN, 4
2400
0
/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
/OR A TERMINATOR.
/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
/THIS ROUTINE MUST NOT MODIFY THE MQ!!
GCHR, 0
JMS INPUT /GET A CHAR FROM TTY.
TAD CHAR /PICK IT UP
TAD PLUS /WAS IT PLUS SIGN?
SNA
JMP DECON1 /YES-GET ANOTHER CHAR.
TAD MINUS /NO WAS IT MINUS SIGN?
SZA CLA
JMP .+3
DCA SIGNF /YES-FLIP SWITCH
DECON1, JMS INPUT /GET A CHAR.
TAD CHAR
TAD K7506 /SEE IF ITS A DIGIT
CLL
TAD K12
SZL /DIGIT?
ISZ GCHR /YES-RETN. TO CALL+2
JMP I GCHR /NO-RETN. TO CALL+1
K7506, 7506
PLUS, -253
MINUS, 253-255
/
/
/INPUT ROUTINE-IGNORES LEADING SPACES
/
INPUT, 0
JMS I IGETCH /USE OUR ROUTINE TO GET CHAR
TAD DSWIT /GET TERMINATOR
SZA CLA /VALID INPUT YET?
JMP IOUT /YES-CONTINUE
TAD CHAR /NO-GET CHAR
TAD M240 /COMPARE AGAINST SPACE
SZA
TAD (240-212 /IS IT AN LF?
SNA CLA /IS IT A SPACE OR LF?
JMP INPUT+1 /YES-IGNORE IT
IOUT, JMP I INPUT /RETURN
M240, -240
IGETCH, GETCH /ALTERED BY VAL FUNCITON TO PICK FROM SAC
/
/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
/
PATCHF, 0
SZA /IS AC EMPTY
JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
TAD FF /YES-GET SPECIAL MODE FLIP-FLOP
SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0
RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND
JMP I PATCHF /RETURN
/
PAGE
/
/FLOATING SUBTRACT-USES FLOATING ADD
/FSW1!!
FFSUB1, 0
JMS I [PATCHF /WHICH MODE?
TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP
JMS I ARGETL /PICK UP ARGUMENT
CDF
JMS I FFNEGA /NEGATE FAC!
TAD FFSUB1
JMP I SUB0P
FFNEGA, FFNEG
SUB0P, SUB0
/
/FLOATING DIVIDE
/FSWITCH=1
/THIS IS OP/FAC
/
FFDIV1, 0
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFDIV1 /CALLED BY USER-GET ADDR.
JMS I ARGETL /(INTERP.)-GET OPRND.-ADDR. IN AC
CDF /CDF TO FIELD OF PACKAGE
TAD ACH /SWAP FAC AND OPRND-OPH IN MQ!
DCA OPH /STORE ACH IN OPH
TAD ACX /GET EXP OF FAC
SWP /OPH TO AC, ACX TO MQ
DCA ACH /STORE OPH IN ACH
TAD OPX /STORE OPX IN ACX
DCA ACX
TAD OPL /OPL TO MQ, ACX TO AC
SWP
DCA OPX /STORE ACX IN OPX
TAD ACL
DCA OPL /STORE ACL IN OPL
TAD OPH /OPH TO MQ FOR LATER
SWP
DCA ACL /STORE OPL IN ACL
TAD FFDIV1 /SET UP SO WE RETN TO
DCA I FFDP /NORMAL DIVIDE ROUTINE
TAD FD1
DCA I MDSETP
JMP I MD1P /GO ARRANGE OPERANDS
MD1P, MD1
ARGETL, ARGET
MDSETP, MDSET
FFDP, FFDIV
FD1, FFD1
/PATCH TO EAE ADD ROUTINE
ADDPCH, 0
TAD AC1
TAD RB4000
DPSZ
JMP ADDP1
CLL CML RTR
ISZ ACX
NOP
ADDP1, TAD RB4000
JMP I ADDPCH
RB4000, 4000
/
PTCHAD, CDF
TAD OPH
SNA CLA /OPERAND ZERO
JMP I JADON /YES
TAD ACH /FAC ZERO
SZA CLA
JMP I JFAD1 /NO
TAD OPX
DCA ACX
TAD OPH
DCA ACH
TAD OPL
DCA ACL
JMP I JADON
JADON, ADON
JFAD1, FAD1
/
/FLOATING MULTIPLY--DOES 4 SINGLE MULTIPLIES WITH EAE
/THIS USES THE FACT THAT IF AC IS NON-ZERO WHEN YOU DO
/A MUY INSTR, THE AC IS ADDED TO RESULT OF THE MULTIPLY.
/(IN THE LOW ORDER, NATCHERLY)
PAGE
FFMPY, 0
JMS I [PATCHF /WHICH MODE?
TAD I FFMPY /CALLED BY USER-GET ADDRESS
JMS MDSET /SET UP FOR MULT
CLA MUY /MULTIPLY-LOW ORDER FAC STILL IN MQ
OPH /THIS IS PRODUCT OF LOW ORDERS
MQL /ZAP LOW ORDER RESULT-INSIGNIFICANT
TAD ACH /GET LOW ORDER(!) OF FAC
SWP MUY /TO MQ-HIGH ORD. RESLT OF LAST MPY
OPL /TO AC-WILL BE ADDED TO RESLT-THIS
DST /IS PRODUCT-LOW ORD FAC,HI ORD OP
AC0 /STORE RESULT
DLD /HIGH ORDER FAC TO MQ, OPX TO AC
ACL
TAD ACX /ADD FAC EXPONENT-GET SUM OF EXPS.
DCA ACX /STORE RESULT
MUY /MUL. HIGH ORDER FAC BY LOW ORD OP.
OPH /HIGH ORDER FAC WAS IN MQ
DAD /ADD IN RESULT OF SECOND MULTIPLY
AC0
DCA ACH /STORE HIGH ORDER RESULT
TAD ACL /GET HIGH ORDER FAC
SWP /SEND IT TO MQ AND LOW ORD. RESULT
DCA AC0 /OF ADD TO AC-STORE IT
RAL /ROTATE CARRY TO AC
DCA ACL /STORE AWAY
MUY /NOW DO PRODUCT OF HIGH ORDERS
OPL /FAC HIGH IN MQ, OP HIGH IN OPL
DAD /ADD IN THE ACCUMULATED #
ACH
SNA /ZERO?
JMP RTZRO /YES-GO ZERO EXPONENT
NMI /NO-NORMALIZE (1 SHIFT AT MOST!)
DCA ACH /STORE HIGH ORDER RESULT
CLA SCA /GET STEP CNTR-DID WE NEED A SHIFT?
SNA CLA
JMP SNCK /NO-JUST CHECK SIGN
CLA CMA /YES-MUST DECREASE EXP. BY 1
TAD ACX
RTZRO, DCA ACX /STORE BACK
TAD AC0
SPA CLA /IS HIGH ORDER OF OVERFLO WD. 1?
DPIC /YES-ADD 1 TO LOW ORDER-STILL IN MQ
SNCK, ISZ MSIGN /RESULT NEGATIVE?
JMP MPOS /NO-GO ON
TAD ACH /YES-GET HIGH ORDER BACK
DCM /LOW ORDER STILL IN MQ-NEGATE
DCA ACH /STORE HIGH ORDER BACK
MPOS, SWP /LOW ORDER TO AC
DCA ACL /STORE AWAY
ISZ FFMPY /BUMP RETURN
JMP I FFMPY /RETIRN
MSIGN, 0
ARGETK, ARGET
DVOFL, DV
/
/ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE
/
MDSET, 0
JMS I ARGETK /GET OPERAND (ADDR. IN AC)
CDF /CHANGE TO DATA FIELD OF PACKAGE
MD1, CLA CLL CMA RAL /MAKE A MINUS TWO
DCA MSIGN /AND STORE IN MSIGN.
TAD OPL /GET LOW ORDER MANTISSA OF OP.
SWP /GET INTO RIGHT ORDER ( OPH IN MQ)
SMA /NEGATIVE?
JMP .+3 /NO
DCM /YES-NEGATE IT
ISZ MSIGN /BUMP SIGN COUNTER
SHL /SHIFT OPRND LEFT 1 TO AVOID OVRFLO
1
DST /STORE BACK-OPH CONTAINS LOW ORDER
OPH / OPL CONTAINS HIGH ORDER
DLD /GET THE MANTISSA OF THE FAC
ACH
SWP /MAKE IT CORRECT ORDER
SMA /NEGATIVE?
JMP FPOS /NO
DCM /YES-NEGATE IT
ISZ MSIGN /BUMP SIGN COUNTER (MAY SKIP)
NOP
FPOS, DST /STORE BACK-ACH CONTAINS LOW ORDER
ACH / ACL CONTAINS HIGH ORDER
JMP I MDSET /RETURN
/
/FLOATING DIVIDE
/
*5722
FFDIV, 0
JMS I [PATCHF /WHICH MODE?
TAD I FFDIV /CALLED BY USER-GET ARG. ADDRESS
JMS MDSET /GET ARG. AND SET UP SIGNS
FFD1, DVI /DIVIDE-ACH AND ACL IN AC,MQ
OPL /THIS IS HI (!) ORDER DIVISOR
DST /QUOT TO AC0,REM TO AC1
AC0
SZL CLA /DIVIDE ERROR?
JMP I DVOFL /YES-HANDLE IT
TAD OPX /DO EXPONENT CALCULATION
CMA IAC /EXP. OF FAC - EXP. OF OP
TAD ACX
DCA ACX
DPSZ /IS QUOT = 0?
SKP /NO-GO ON
DCA ACX /YES-ZERO EXPONENT
DVLP, MUY /NO-THIS IS Q*OPL*2**-12
OPH
DCM /NEGATE IT
TAD AC1 /SEE IF GREATER THAN REMAINDER
SNL
JMP I DVOPSP /YES-ADJUST FIRST DIVIDE
DVI /NO-DO Q*OPL*2**-12/OPH
OPL
SZL CLA /DIV ERROR?
JMP I DVOFL /YES
DVLP1, TAD AC0 /NO-GET QUOT OF FIRST DIV.
SMA /NEGATIVE?
JMP .+5 /NO-REMEMBER-QUOT OF 2ND DIV. IN MQ
LSR /YES-MUST SHIFT IT RIGHT 1
1
ISZ ACX /ADJUST EXPONENT
NOP
ISZ MSIGN /SHOULD SIGN BE MINUS?
SKP /NO
DCM /YES-DO IT
DBAD1, DCA ACH /STORE IT BACK
SWP
DCA ACL
ISZ FFDIV
JMP I FFDIV /BUMP RETN. AND RETN.
DVOPSP, DVOPS
DBAD, CAM
DCA ACX /ZERO EXPONENT
JMP DBAD1 /GO ZERO MANTISSA
/FLOATING ADDITION-IN ORDER NOT TO LOSE BITS, WE DO NOT
/SHIFT BOTH NUMBERS RIGHT 1 BIT BEFORE ADD-ONLY SHIFTS DONE
/ARE TO ALIGN EXPONENTS.
/
PAGE
FFADD, 0
JMS I [PATCHF /WHICH MODE OF CALLING
TAD I FFADD /CALLED DIRECTLY BY USER
JMS I ARGETP /PICK UP ARGUMENTS
JMP I PATCHK /CHECK FOR ADDITION BY ZERO
FAD1, TAD OPX /PICK UP EXPONENT OF OPERAND
MQL /SEND IT TO MQ FOR SUBTRACT
TAD ACX /GET EXPONENT OF FAC
SAM /SUBTRACT-RESULT IN AC
SPA /NEGATIVE RESULT?
CMA IAC /YES-MAKE IT POSITIVE
DCA CNT /STORE IT AS A SHIFT COUNT
TAD CNT /COUNT TOO BIG?(CAN'T BE ALIGNED)
TAD M27
SPA SNA CLA
CMA /NO-OK
DCA AC0 /YES-MAKE IT A LOAD OF LARGEST #
DLD /GET ADDRESSES TO SEE WHO'S SHIFTED
ADDRS
SGT /WHICH EXP GREATER(GT FLG SET
/BY SUBTR. OF EXPS.)
SWP /OPERAND'S-SHIFT THE FAC
DCA SHFBG /STORE ADDRESS OF WHO GETS SHIFTED
SWP /GET ADDRESS OF OTHER (0 TO MQ)
DCA DADR /THIS ONE JUST GETS ADDED
SGT /WHICH EXPONENT WAS GREATER?
JMP .+3 /FAC'S - DO NOTHING
TAD OPX /OPERAND'S-PUT FINAL EXP. IN ACX
DCA ACX
DLD /GET THE LARGER # TO AC,MQ
DADR, 0
SWP /PUT IN THE RIGHT ORDER
ISZ AC0 /COULD EXPONENTS BE ALIGNED?
JMP LOD /NO-JUST LEAVE LARGER IN AC,MQ
DST /YES-STORE THIS TEMPORARILY
AC0 /(IF ONLY FAC STORAGE WAS REVERSED)
DLD /GET THE SMALLER #
SHFBG, 0
SWP /PUT IT IN RIGHT ORDER
ASR /DO THE ALIGNMENT SHIFT
CNT, 0
DAD /ADD THE LARGER #
AC0
DST /STORE RESULT
AC0
SZL /OVERFLOW?(L NOT = SIGN BIT)
CMA /NOTE-WE DIDN'T SHIFT BOTH RIGHT 1
SMA CLA
JMP NOOV /NOPE
CLA CLL CML RAR /MAYBE-SEE IF 2 #S HAD SAME SIGN
AND ACH
TAD OPH
SMA CLA /SIGNS ALIKE?
JMP OVRFLO /YES-OVERFLOW
NOOV, JMS I ADDPCL /JUMP TO PATCH FOR THIS ROUTINE
LOD, NMI /NORMALIZE (LOW ORDER STILL IN MQ)
DCA ACH /STORE FINAL RESULT
SWP /GET AND STORE LOW ORDER
DCA ACL
SCA /GET SHIFT COUNTER(# OF NMI SHIFTS)
CMA IAC /NEGATE IT
TAD ACX /AND ADJUST FINAL EXPONENT
DCA ACX
ADON, ISZ FFADD /BUMP RETURN PAST ADDRESS
JMP I FFADD /RETURN
OVRFLO, TAD AC1 /OVERFLOW-GET HIGH ORDER RESLT BACK
ASR /SHIFT IT RIGHT 1
1
TAD KK4000 /REVERSE SIGN BIT
DCA ACH /AND STORE
SWP
DCA ACL /STORE LOW ORDER
ISZ ACX /BUMP EXPONENT
NOP
JMP ADON /DONE
KK4000, 4000
M27, -27
ADDRS, OPH
ACH
ARGETP, ARGET
/FLOATING SUBTRACT-USES FLOATING ADD
/FSW0!!
FFSUB, 0
JMS I [PATCHF /WHICH MODE?
TAD I FFSUB /CALLED BY USER-GET ADDRESS OF OP.
JMS I ARGETP
CDF
TAD OPL /OPH IS IN MQ!
SWP /PUT IT IN RIGHT ORDER
DCM /NEGATE IT
DCA OPH /STORE BACK
MQA
DCA OPL
TAD FFSUB /GO TO ADD
SUB0, DCA FFADD
JMP FAD1-1
/
/FLOATING NEGATE--NEGATE FLOATING AC
/
FFNEG, 0
SWAB /MUST BE MODE B
DLD /GET MANTISSA
ACH
SWP /CORRECT ORDER PLEASE!
DCM /NEGATE IT
DCA ACH /RESTORE
SWP /SEND 0 TO MQ
DCA ACL
JMP I FFNEG
/
/CONTINUATION OF DIVIDE ROUTINE
/WE ARE ADJUSTING THE RESULT OF THE
/FIRST DIVIDE.
/
DVOPS, CMA IAC
DCA AC1 /ADJUST REMAINDER
TAD OPL /WATCH FOR OVERFLOW
CLL CMA IAC
TAD AC1
SNL
JMP DVOP1 /DON'T ADJUST QUOT.
DCA AC1
CMA
TAD AC0
DCA AC0 /REDUCE QUOT BY 1
DVOP1, CLA CLL
TAD AC1 /GET REMAINDER
SNA /ZERO?
CAM /YES-ZERO EVERYTHING
DVI /NO
OPL
SZL CLA /DIV. OVERFLOW?
JMP I DVOVR /YES
DCM /NO-ADJUST HI QUOT (MAYBE)
JMP I DVLP1P /GO BACK
DVLP1P, DVLP1
DVOVR, DV
ADDPCL, ADDPCH
PATCHK, PTCHAD
>
PAGE
/ARGUMENT PICK UP ROUTINE-ENTER WITH DATA FIELD SET TO EITHER
/FLTG. DATA FIELD OR FLTG. INSTR. FIELD.
/ADDRESS OF OPERAND IS IN THE AC ON ENTRY.
/ON RETURN, THE`AC IS CLEAR
/
ARGET, 0
DCA AC2 /STORE ADDRESS OF OPERAND
TAD I AC2 /PICK UP EXPONENT
DCA OPX
JMS ISZAC2 /MOVE POINTER TO HORD,WATCH FOR FIELD OVERLAP
TAD I AC2 /PICK IT UP
IFZERO EAE <
NOP
NOP
>
IFNZRO EAE <
SWAB /OPH INTO MQ BECAUSE EAE ROUTINES
MQA /EXPECT TO FIND IT THERE
>
DCA OPH /STORE
JMS ISZAC2 /MOVE POINTER TO LORD,WATCHING FOR OVERLAP
TAD I AC2 /PICK IT UP
DCA OPL /STORE IT
JMP I ARGET /RETURN
IFZERO EAE <
/
/ROUTINE TO NORMALIZE THE FAC
/
FFNOR, 0
TAD ACH /GET THE HI ORDER MANTISSA
SNA /ZERO?
TAD ACL /YES-HOW ABOUT LOW?
SNA
TAD AC1 /LOW=0, IS OVRFLO BIT ON?
SNA CLA
JMP ZEXP /#=0-ZERO EXPONENT
NORMLP, AC2000 /NOT 0-MAKE A 2000 IN AC
TAD ACH /ADD HI ORDER MANTISSA
SZA /HI ORDER = 6000
JMP .+3 /NO-CHECK LEFT MOST DIGIT
TAD ACL /YES-6000 OK IF LOW=0
SZA CLA
SPA CLA /2,3,4,5,ARE LEGAL LEFT MOST DIGS.
JMP FFNORR /FOR NORMALIZED #-(+2000=4,5,6,7)
JMP FNLP /JUMP SO FFGET AND PUT ARE ORGED RIGHT
FFNORR, DCA AC1 /DONE W/NORMALIZE-CLEAR AC1
JMP I FFNOR /RETURN
AL1P, AL1
>
IFNZRO EAE <
/
/ROUTINE TO NORMALIZE THE FAC
/
*6215
FFNOR, 0
CDF /CHANGE D.F. TO FIELD OF PACKAGE
SWAB /FORCE MODE B
DLD /PICK UP MANTISSA
ACH
SWP /PUT IT IN CORRECT ORDER
NMI /NORMALIZE IT
SNA /IS THE # ZERO?
DCA ACX /YES-INSURE ZERO EXPONENT
DCA ACH /STORE HIGH ORDER BACK
SWP /STORE LOW ORDER BACK
DCA ACL
CLA SCA /STEP COUNTER TO AC
CMA IAC /NEGATE IT
TAD ACX /AND ADJUST EXPONENT
DCA ACX
JMP I FFNOR /RETURN
>
/FLOATING GET
*6241
FFGET, 0
JMS I [PATCHF /WHICH MODE OF CALL
TAD I FFGET /CALLED BY USER-GET ADDR. OF OP
JMS ARGET /PICK UP OPERAND
TAD OPX
DCA ACX /LOAD THE OPERAND INTO FAC
TAD OPL
DCA ACL
TAD OPH
DCA ACH
ISZ FFGET
CDF
JMP I FFGET /RETN. TO CALL +2
/
/FLOATING PUT
/
FFPUT, 0
JMS I [PATCHF /WHICH MODE OF CALL?
TAD I FFPUT /CALLED BY USER-GET OPR. ADDR
DCA FFGET /STORE IN A TEMP
TAD ACX /GET FAC AND STORE IT
DCA I FFGET /AT SPECIFIED ADDRESS
JMS ISZFGT /BUMP POINTER,WATCHING FOR FIELD OVERLAP
TAD ACH
DCA I FFGET
JMS ISZFGT
TAD ACL
DCA I FFGET
ISZ FFPUT /BUMP RETN.
CDF
JMP I FFPUT /RETN. TO CALL+2
/ROUTINES TO BUMP ARGET AND FPUT POINTERS AND INCREMENT THE
/DATA FIELD IF THE POINTER CROSSES A FIELD BOUNDARY
ISZFGT, 0
ISZ FFGET /BUMP POINTER
JMP I ISZFGT /NO SKIP MEANS JUST RETURN
SKP /SKIP MEANS WE HAVE TO INCREMENT DATA FIELD
NEWCDF, DCA ISZFGT /THIS INST EXECUTED ONLY BY ISZAC2
RDF /GET THE DATA FIELD
TAD CDF10 /BUMP BY 1 AND MAKE A CDF
DCA .+1 /PUT IN LINE
.
JMP I ISZFGT /RETURN
CDF10, CDF 10
ISZAC2, 0
ISZ AC2 /BUMP POINTER
JMP I ISZAC2 /NOTHING HAPPENED
TAD ISZAC2 /NEED NEW DF. GET RETURN ADDR
JMP NEWCDF /AND BUMP DF
IFZERO EAE <
/
/ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
/REMAINDER OF THE FIRST`DIVIDE IS LESS THAN QUOT*OPL
/USED BY FLTG. DIVIDE ROUTINE
/
DVOPS, CMA IAC /NEGATE AND STORE REVISED REMAINDER
DCA ACH
CLL
TAD OPH
TAD ACH /WATCH FOR OVERFLOW
SNL
JMP DVOP1 /OVERFLOW-DON'T ADJUST QUOT. OF 1ST DIV.
DCA ACH /NO OVERFLOW-STORE NEW REM.
CMA /SUBTRACT 1 FROM QUOT OF
TAD AC1 /FIRST DIVIDE
DCA AC1
DVOP1, CLA CLL
TAD ACH /GET HI ORD OF REMAINDER
JMP I DVOP2P /GO ON
DVOP2P, DVOP2
FNLP, CLL CML CMA /-1
TAD ACX /SUBTR. 1 FROM EXPONENT
DCA ACX
JMS I AL1P /SHIFT FAC LEFT 1
JMP NORMLP /GO BACK AND SEE IF NORMALIZED
ZEXP, DCA ACX
JMP FFNORR
>
/
/FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF
/
*6347
A,
FFSQ, 0
JMS I TMPY /CALL MULTIPLY TO MULTIPLY
ACX /FAC BY ITSELF
JMP I FFSQ /DONE
TMPY, FFMPY
/
/ ERROR TRAPS
O0, JMS I [ERROR /OVERFLOW
DV, JMS I [ERROR /DIVISION ERROR
JMS I [FACCLR /RETURN 0 IN FAC
JMP I [ILOOP
LM, JMS I [ERROR /ILLEGAL ARGUMENT
PAGE
*OVERLAY+3000
/TELETYPE "DRIVER"-WHEN CALLED,GRABS CHARACTERS FROM THE
/TELETYPE UNTIL A CR IS SENT OR THE BUFFER IS FULL. ASSUMES TTY ENTRY
/IS IN I/O WORK AREA.
TTYDRI, 0
JMP LFLUSH+1
IO, JMS I [ERROR
LFLUSH, JMS I [CRLFR /PRINT A CR,LF
TAD K277 /PRINT A ? SIGNIFYING WAIT FOR INPUT
JMS I [XPUTCH
TAD I IOTBUF /BUFFER ADDRESS
DCA I IOTPTR /INITIALIZE POINTER TO START OF BUFFER
JMS I [CNOCLR /INITIALIZE CHAR # TO 1
TTYIN, JMS I [XPRINT /EMPTY TTY BUFFER BEFORE AWAITING INPUT
JMP .-1
TAD I (HEIGHT /ALWAYS RESET SCREEN HIEGHT ON INPUT
DCA I (HCTR
TAD K5252 /DESIGN INTO AC
KSFA, KSF /CHAR READY?
JMP SPIN /NO-DIDDLE WHILE WE WAIT
CLA CLL /FLUSH SPINNER OUT OF AC
TAD [200 /FORCE PARITY BIT
KRS /GET CHAR
DCA CHAR /SAVE
TAD CHAR
JMS I [XPUTCH /ECHO IT
KCC /CLEAR KEYBOARD FLAG AND SET READER RUN
TAD CHAR
TAD MCTRLU /IS IT CTRL/U?
SNA CLA
JMP LFLUSH /YES-START AGAIN
TAD CHAR /NO
TAD CRUBOT /IS IT RUBOUT?
SNA
JMP BACKUP /YES-BACK UP BUFFER POINTER
TAD MCR /NO-IS IT CR?
SNA CLA
JMP CR /YES-DONE
TAD CHAR
JMS I [PACKCH /PACK CHAR IN BUFFER
JMS I [BUFCHK /BUFFER FULL?
JMP IO /YES-ERROR
NOP /NO-CHAR 3 LEFT
NOP /NO-2 AND 3 LEFT
JMP TTYIN /NO-NEXT CHAR
MCTRLU, -225
MCR, 377-215
CRUBOT, -377
K5252, 5252
K277, 277
BACKUP, TAD I IOTPTR /BUFFER POINTER
CIA /NEGATE
TAD I IOTBUF /COMPARE AGAINST START OF BUFFER
SNA CLA /BUFFER EMPTY?
JMP TTYIN /YES-THERE IS NOTHING TO RUBOUT
TAD SCOPFG /TEST IF CONSOLE IS A SCOPE
SNA CLA
JMP NOSCOP /JMP IF NOT
TAD (10
JMS I [XPUTCH /PRINT BS,SP,BS TO RUBOUT IF SCOPE
TAD (40
JMS I [XPUTCH
TAD (10
SKP
NOSCOP, TAD K334
JMS I [XPUTCH /ECHO "\"
JMS I [CHARNO /GET CHAR # OF NEXT CHAR (LAST #+1)
JMP C1B /1
JMP C3B /3
JMS I [CNOCLR /IT WAS 2-MAKE IT 1
PBACK, CLA CMA /-1
TAD I IOTPTR /BACK UP BUFFER POINTER
DCA I IOTPTR
JMP TTYIN /NEXT CHAR
K334, 334
C1B, TAD I IOTHDR
AND [7477
TAD [200 /IT WAS 1-MAKE IT 3
DCA I IOTHDR
JMP TTYIN /NO NEED TO BACK UP POINTER
C3B, TAD I IOTHDR
AND [7477
TAD [100 /IT WAS 3,MAKE IT 2
DCA I IOTHDR
JMP PBACK /BACK UP POINTER
CR, JMS I [CRLFR /ECHO A CR,LF
TAD K4
TAD TTYDRI /BUMP DRIVE RETURN TO NORMAL
DCA TTYDRI
TAD CHAR
JMS I [PACKCH /PACK CHAR IN BUFFER
TAD I IOTBUF
DCA I IOTPTR /INITAILZE BUFFER POINTERS
JMS I [CNOCLR
JMP I TTYDRI /RETURN
K4, 4
SPIN, ISZ SPINNR /SPIN RANDOM # SEED
SKP
CMA CML RAL /MARCH TO THE LEFT
JMP KSFA /CHECK FOR CHAR YET
SCOPFG, 0 /GETS SET TO SCOPE FLAG BY STARTUP CODE
/SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC
FBITGT, 0
TAD INSAV
CLL RTR
RTR /PUT FUNCTION BITS IN BITS 8-11
AND [17 /MASK THEM OFF
JMP I FBITGT /RETURN
/DATA LIST READ (NUMERIC)
RDLIST, JMS I (DLREAD /FETCH WORD FROM LIST
DCA ACX /STORE AS EXPONENT
JMS I (DLREAD
DCA ACH /HIGH MANTISSA
JMS I (DLREAD
DCA ACL /LOW MANTISSA
JMP I [ILOOP
/SUBROUTINE FTYPE-RETURNS TO CALL+1 IF FILE NUMERIC,CALL+2 IF ASCII
FTYPE, 0
TAD I IOTHDR /GET HEADER
CLL RAR /TYPE TO LINK
SZL CLA /IS IT NUMERIC?
ISZ FTYPE /NO-BUMP RETURN
JMP I FTYPE /RETURN
PAGE
/LAST PAGE OF BRTS-CONTAINS SAC,I/O TABLE, AND SOME MISCELLANEOUS CODE
/TELETYPE INPUT BUFFER (74. CHARACTERS LONG)
/THIS BUFFER CONTAINS ONCE ONLY START CODE WHEN LOADED
TTYBUF,
START4, TAD CDFPS /DF FOR BOTTOM OF PSEUDO-CODE
TAD MCDF1 /COMPARE TO A CDF 10
SZA CLA /DO THEY MATCH?
JMP I [ILOOP /NO-ALL BUFFERS ARE FREE-START INTERPRETER
TAD PSSTRT
CLL CMA
TAD [400
SNL CLA /IS START OF PSEUDO-CODE BELOW 400
JMP CHKB2 /NO-CHECK FOR 1000
TAD [17 /YES-SET ALL BUFFERS BUSY
JMP BAS
CHKB2, TAD PSSTRT
CLL CMA
TAD C1000
SNL CLA /IS START OF PSEUDO-CODE BELOW 1000
JMP CHKB3 /NO-CHECK 1400
TAD C16 /YES-ONLY BUFFER 1 IS AVAILABLE
JMP BAS
CHKB3, TAD PSSTRT
CLL CMA
TAD C1400
SNL CLA /IS START OF CODE BELOW 1400?
JMP CHKB4 /YES-CHECK 2000
TAD C14 /YES-ONLY BUFFER 1 AND 2 AVAILABLE
JMP BAS
CHKB4, TAD PSSTRT
CLL CMA
TAD K2000
SNL CLA /IS CODE START BELOW 2000?
JMP I [ILOOP /NO-START INTERPRETER-ALL BUFFER FREE
TAD [10 /YES-BUFFERS 1,2, AND 3 AVAILABLE
BAS, DCA BMAP
JMP I [ILOOP /START INTERPRETER
0
MCDF1, -6211
K2000, 2000
C14, 14
C16, 16
C1000, 1000
C1400, 1400
ZBLOCK 10
TTYEND, 0
*OVERLAY+3277
////////////////////////////////////////////////////////////////
/////// I/O TABLE 5 13-WORD ENTRIES ////////////////////////////
////////////////////////////////////////////////////////////////
TTYF, 1 /TELETYPE ENTRY-FILE IS ASCII
TTYBUF /BUFFER ADDRESS
0 /CURRENT BLOCK IN BUFFER
TTYBUF /READ WRITE POINTER
TTYDRI /HANDLER ENTRY
ZBLOCK 10
FILE1, ZBLOCK 15 /FILE #1
FILE2, ZBLOCK 15 /FILE #2
FILE3, ZBLOCK 15 /FILE #3
FILE4, ZBLOCK 15 /FILE #4
PAGE
/CROSS FIELD LITERAL EQUATES
PGETCH= [GETCH
PILOOP= [ILOOP
PPUTCH= [PUTCH
PSACM1= [SAC-1
PXPUTCH= [XPUTCH
PXPRINT= [XPRINT
PFFNOR= [FFNOR
PFFGET= [FFGET
PFFPUT= [FFPUT
PUNSFIX= [UNSFIX
PERROR= [ERROR
PFACCLR= [FACCLR
PIDLE= [IDLE
PPSWAP= [PSWAP
PFTYPE= [FTYPE
USR= [200
O200= [200
O400= [400
O100= [100
O10= [10
O17= [17
O7400= [7400
O77= [77
O215= [215
O7700= [7700
M215= [-215
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// OVERLAY 2- STRING FUNCTIONS /////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
FIELD 1
*2000
RELOC OVERLAY
/VERSION NUMBER WORD FOR STRING OVERLAY
VERSON^100+SUBVSF+6000
/CHR$ FUNCTION
/RETURNS 1 6BIT CHAR STRING FOR THE VALUE OF X
CHR, JMS I PUNSFIX /FIX X TO 12 BIT INTEGER
AND O77 /MASK TO 6BIT
DCA I (SAC /AND PUT INTO SAC
CMA
DCA SACLEN /SET SAC LENGTH TO 1
JMP I (SSMODE /SET TO SMODE AND RETURN
/ASC FUNCTION
/RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC
ASC, TAD I (SAC /GET FIRST CHAR OF STRING
JMP FLOATS /FLOAT RESULT INTO FAC AND RETURN
/LEN FUNCTION
/RETURNS LENGTH OF SAC IN FAC
LEN, TAD SACLEN /LENGTH OF STRING IN SAC
CIA /MAKE POSITIVE
/ROUTINE TO FLOAT FAC AND RETURN
FLOATS, DCA ACH /NUMBER TO BE FLOATED IN HORD
DCA ACL /CLEAR LORD
DCA TEMP2 /CLEAR FPP OVERFLOW
TAD (13 /SET EXP TO 11
DCA ACX
JMS I PFFNOR /NORMALIZE
JMP I PILOOP /RETURN
/STR$ FUNCTION
/RETURNS ASCII STRING FOR NUMBER IN FAC
STR, JMS I (FFOUT /GET NUMBER INTO INTERMEDIATE BUFFER FIRST
TAD XR1
CIA
TAD (INTERB-1
DCA SACLEN
TAD SACLEN /NOW SAVE COUNTER
DCA TEMP2
TAD (INTERB-1
DCA XR1 /POINT AT BUFFER
STRLUP, TAD I XR1 /GET A CHAR
AND O77 /MASK TO 6BIT
TAD (-40 /CROCK TO DELETE BLANKS
SZA
JMP .+3
ISZ SACLEN /IGNORE THE BLANK
JMP .+3
TAD (40
DCA I SACXR /STORE IN SAC
ISZ TEMP2
JMP STRLUP /LOOP FOR MORE
JMP I (SSMODE /DONE-RETURN IN SMODE
/VAL FUNCTION
/RETURNS NUMBER IN FAC FOR STRING IN SAC
VAL, TAD SACLEN
DCA VALCNT /COUNT OF CHARS TO INPUT
TAD (VALGET /ADDR OF PHONY INPUT ROUTINE
DCA I (IGETCH /PUT IN INPUT ROUTINE IN PLACE OF KRB
JMS I (FFIN /CALL FPP INPUT ROUTINE
TAD PGETCH /NOW RESTORE REAL INPUT ADDR
DCA I (IGETCH /RESTORE IN INPUT ROUTINE
JMP I PILOOP /DONE
VALGET, 0
TAD VALCNT /TEST NUMBER OF CHARS LEFT
SNA CLA
JMP EOVAL /NONE
ISZ VALCNT /ELSE BUMP
NOP
TAD I SACXR /GET A BYTE
TAD (240
AND O77
TAD (240 /CONVERT TO 8BIT
SKP
EOVAL, TAD O215
DCA CHAR
JMP I VALGET /RETURN WITH CHAR IN 'CHAR'
VALCNT, 0
PAGE
/ DATE FUNCTION
/ RETURNS STRING OF THE FORM "MM/DD/YY" IN SAC IF DATE IS PRESENT
/ RETURNS NULL STRING OTHERWISE
DATE, TAD CDFIO /COPY CDF TO FIELD 17600 IN LINE
DCA .+1
YEAREX, 0
TAD PSFLAG /GET TD8E BIT TO LINK
CLL RAL
SNL CLA
TAD I (MDATE /IF ZERO LOOK AT MDATE IN N7600
SZL
TAD I (MDATE-200 /ELSE LOOK AT N7400
DCA DATEWD /STORE (DATE IS NOT A CLOSED SUBROUTINE)
CDF /DATE IS IN THE FORM MMM MDD DDD YYY
TAD DATEWD /PICK UP DATE
SZA CLA
TAD (-10 /RETURN 8. BYTES IF NOT NULL DATE
DCA SACLEN /SET SAC LENGTH
TAD I (BIPCCL /NOW GET YEAR EXTENSION
AND (600 /IT'S IN THE 600 BITS
CLL RTR
RTR /SHIFT INTO PLACE
DCA YEAREX /HOLD YEAR EXTENSION
TAD DATEWD /NOW ISOLATE MONTH
AND O7400
CLL RTL
RTL
RAL
JMS PUTN /PUT "MM/" INTO THE SAC
TAD DATEWD /NOW GET DAY OF MONTH
AND (370
CLL RTR
RAR
JMS PUTN /PUT "DD/" IN SAC
TAD DATEWD /FINALLY GET YEAR
AND (7
TAD YEAREX /ADD TO EXTENSION BITS
TAD (106 /ADD 70. FOR BASE YEAR
JMS PUTN /PUT OUT "YY/" (EXTRA SLASH WILL BE IGNORED)
JMP I (SSMODE /RETURN IN STRING MODE
PUTN, 0
ISZ NHIGH /BUMP HIGH ORDER DIGIT
TAD (-12 /-10.
SMA
JMP .-3 /LOOP IF NOT REDUCED YET
TAD (12+60 /CONVERT TO DECIMAL DIGIT
DCA NLOW /HOLD MOMENTARILY
TAD NHIGH /NOW GET HI ORDER DIGIT
TAD (57 /MAKE 6BIT
DCA I SACXR
TAD NLOW /SEND OUT LOW DIGIT
DCA I SACXR
TAD (57
DCA I SACXR /SEND OUT "/"
DCA NHIGH /CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!)
JMP I PUTN
NHIGH, 0
NLOW, 0
DATEWD, 0
/TRACE FUNCTION PRINTER. WHEN TRACE IS ENABLED,THIS ROUTINE
/PRINTS THE LINE # EACH TIME IT IS STORED
TPRINT, JMS I (LMAKE /MAKE LINE # INTO FIVE DIGITS
TAD ("%
JMS I PXPUTCH /PRINT "%"
TAD ("
JMS I PXPUTCH /PRINT A SPACE
TAD (DIG1-1 /ADDR OF FIRST DIGIT-1
DCA XR5 /IN XR5
IGS, TAD I XR5 /GET DIGIT OF LINE NUMBER
DCA TCHR /SAVE IT
TAD (-"0
TAD TCHR /COMPARE IT TO 0
SNA CLA /IS IT A 0?
JMP IGS /YES-IGNORE LEADING ZEROES
PREST, TAD TCHR /NO-GET CHAR AGAIN
TAD M215
SNA CLA /IS IT A CR?
JMP TDONE /YES-LINE NUMBER IS PRINTED
TAD TCHR /NO-GET CHAR A THIRD TIME
JMS I PXPUTCH /TYPE IT
TAD I XR5 /GET NEXT CHAR
DCA TCHR
JMP PREST /AND LOOP
TDONE, TAD ("
JMS I PXPUTCH /FOLLOW LINE # WITH A SPACE
TAD ("%
JMS I PXPUTCH /TYPE ANOTHER "%"
TAD (215
JMS I PXPUTCH /TYPE,CR,LF
TAD (212
JMS I PXPUTCH
JMS I PXPRINT /EMPTY RING BUFFER OF TRACE NUMBER
JMP .-1
JMP I PILOOP /DONE
TCHR, 0
PAGE
/TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF
TRACE, TAD ACH /GET HI MANTISSA OF ARG
SNA CLA /SKP TO TURN TRACE ON
TAD TRREST /ELSE RESTORE TRACE BYPASS INSTR IN LINE NUMBER ROUTINE
DCA I HOOKL /BY NOP ING INSTRUCTION AT TRHOOK
TRREST, JMP I PILOOP
HOOKL, TRHOOK
/ERROR ROUTINE
ERRORR, JMS I PXPRINT /PURGE TTY RING BUFFER
JMP .-1 /BEFORE PRINTING ERROR
TAD ETABA /ADDR OF ERROR TABLE
DCA XR4 /POINTS INTO ERROR TABLE
FERRLP, TAD I XR4 /GET 2 CHAR ERROR CODE
DCA TEMP1 /SAVE
TAD TEMP1
CLL RTR
RTR
RTR
AND O77 /STRIP TO 6 BIT
TAD K0300 /MAKE 8 BIT (LETTERS ONLY ALLOWED)
DCA ESTRNG /PUT IN MESSAGE
TAD TEMP1 /2 CHAR CODE AGAIN
AND O77 /SECOND CHAR
TAD K0300 /MAKE LETTER
DCA ESTRNG+1 /PUT IN MESSAGE
TAD I XR4 /GET ERROR CODE +1
TAD I PERROR /COMPARE AGAINST RETURN ADDR
SZA CLA /MATCH?
JMP FERRLP /NO-TRY NEXT ONE
JMS LMAKE /MAKE THE LINE # INTO DECIMAL DIGITS
TAD ESTRA /ADDR OF MESSAGE
DCA XR5
ETLOP, TAD I XR5 /GET MESSAGE CHAR
SPA /DONE? (MESSAGE ENDNS WITH - NUMBER
JMP FATCHK /YES-DETERMINE ERROR TYPE
JMS I PXPUTCH /NO-PUT CHAR IN RING BUFFER
JMP ETLOP
FATCHK, CLA
TAD MFATAL /-ADDR OF FATAL ERRORS
TAD XR4 /ADDR OF THIS ERROR
SMA CLA /FATAL ERROR?
JMP I ERRETN /NO-NEXT INST
JMP I STOPI /YES-TERMINATE RUN
ERRETN, XERRRET
STOPI, FSTOPN
MAKED, 0
AND O17 /ISOLATE BCD DIGIT
TAD K260 /MAKE ASCII DIGIT
JMP I MAKED
K260, 260
K0300, 300
/SUBROUTINE LMAKE-MAKES THE CURRENT LINE NUMBER INTO FIVE DIGITS
/STARTING AT DIG1
LMAKE, 0
TAD LINEHI /YES:GET HI LINE #
JMS MAKED /GET DIGIT 2
DCA DIG2 /PUT IN MESSAGE
TAD LINEHI
CLL RTR
RTR
JMS MAKED /GET DIGIT 1
DCA DIG1 /AND PUT IN MESSAGE
TAD LINELO /DOGOTS 3,4, AND 5
JMS MAKED /GET DIGIT 5
DCA DIG5
TAD LINELO
CLL RTR
RTR
JMS MAKED /GET DIGIT 4
DCA DIG4 /AND PUT IN MESSAGE
TAD LINELO
CLL RAL
RTL
RTL
JMS MAKED /GET DIGIT 3
DCA DIG3 /MESSAGE NOW COMPLETE
JMP I LMAKE
/ERROR MESSAGE
EMESS, 215
212
ESTRNG, 0000
0000
"
"A
"T
"
"L
"I
"N
"E
"
DIG1, 0
DIG2, 0
DIG3, 0
DIG4, 0
DIG5, 0
215
212
ESTRA, EMESS-1 /MINUS NUMBER TO END ABOVE MESSAGE
/ERROR TABLE
/ENTRY FORMAT- 2 CHAR 6-BIT ERROR CODE (LETTERS ONLY)
/ -(ADDR OF CALL)-1
ETABA, ETAB-1
MFATAL, -EFATAL
ETAB, 0602 /FB
-FB-1 /ATTEMPT TO OPEN AN ALREADY OPEN FILE
0722 /GR
-GR-1 /RETURN WITHOUT A GOSUB
2622 /VR
-VR-1 /ATTEMPT TO READ VARIABLE LENGTH FILE
2325 /SU
-SU-1 /SUBSCRIPT ERROR
0405 /DE
-DE-1 /DEVICE DRIVER ERROR
1705 /OE
-OE-1 /DRIVER ERROR WHILE OVERLAYING
0615 /FM
-FM-1 /ATTEMPT TO FIX MINUS NUMBER
0617 /FO
-FO-1 /ATTEMPT TO FIX NUMBER >4095
0616 /FN
-FN-1 /ILLEGAL FILE #
2303 /SC
-SC-1 /ATTEMPT TO OVERFLOW SAC ON CONCATENATE
0611 /FI
-FI-1 /ATTEMPT TO CLOSE OR USE UNOPENED FILE
0401 /DA
-DA-1 /ATTEMPT TO READ PAST END OF DATA LIST
0723 /GS
-GS-1 /TOO MANY NESTED GOSUBS
2322 /SR
-SR-1 /ATTEMPT TO READ STRING FROM NUMERIC FILE
2327 /SW
-SW-1 /ATTEMPT TO WRITE STRING INTO NUMERIC FILE
2001 /PA
-PA-1 /ILLEGAL ARG IN POS
0603 /FC
-FC-1 /OS/8 ERROR WHILE CLOSING TENTATIVE FILE
0311 /CI
-CI-1 /INQUIRE FAILURE IN CHAIN
0314 /CL
-CL-1 /LOOKUP FAILURE IN CHAIN
1116 /IN
-IN-1 /INQUIRE FAILURE IN OPEN
0417 /DO
-DO-1 /NO MORE ROOM FOR DRIVERS
0605 /FE
-FE-1 /FETCH ERROR IN OPEN
0217 /BO
-BO-1 /NO MORE FILE BUFFERS AVAILABLE
0516 /EN
-EN-1 /ENTER ERROR IN OPEN
1106 /IF
-IF-1 /ILLEGAL DEV:FILENAME SPECIFICATION
2314 /SL
-SL-1 /STRING TOO LONG OR UNDEFINED
1726 /OV
-O0-1 /NUMERIC OR INPUT OVERFLOW
1415 /LM
-LM-1 /ATTEMPT TO TAKE LOG OF NEG # OR 0
0515 /EM
-EM-1 /ATTEMPT TO EXPONENTIATE A NEG NUMBER TO A REAL ROWER
1101 /IA
-IA-1 /ILLEGAL ARGUMENT IN USER FUNCTION
0330 /CX
-CX-1 /ILLEGAL FILENAME EXTENSION IN A CHAIN STATEMENT
/***********************************************************
EFATAL, /ERRORS BEFORE THIS LABEL ARE FATAL
/*******************************************************
2205 /RE
-RE-1 /ATTEMPT TO READ PAST EOF
2705 /WE
-WE-1 /ATTEMPT TO WRITE PAST EOF
0426 /DV
-DV-1 /ATTEMPT TO DIVIDE BY 0
2324 /ST
-ST-1 /STRING TRUNCATION ON INPUT
1117 /IO
-IO-1 /TTY INPUT BUFFER OVERFLOW
T= .
*ETAB
*T
/SEG$ FUNCTION
/RETURNS SEGMENT OF X$ BETWEEN Y AND Z
/IF Y<=0,THEN Y TAKEN AS 1
/IF Y>LEN(X$),NULL STRING RETURNED
/IF Z<=0,NULL STRING RETURNED
/IF Z>LEN(X$),Z IS SET=LEN(X$)
/IF Z<Y,NULL STRING IS RETURNED
SEG, CLA IAC
DCA MODESW /RETURN IN STRING MODE
TAD ACH /IS Y>0?
SMA SZA CLA
JMS I PUNSFIX /FIX IF POSITIVE
SNA
IAC /SET Y TO 1 IF Y.LE.0
DCA YARG
TAD SACLEN /COMPARE YARG TO SACLEN
CIA
STL CIA
TAD YARG
SNL SZA CLA /SKP IF YARG.LOS.LEN(X$)
JMP NULLST /NO-RETURN THE NULL STRING
DCA INSAV /FAKE POINTER TO SCALAR #0
JMS I ARGPLK /GET ADDR OF Z
JMS I PFFGET /LOAD Z INTO FAC
ARGPLK, ARGPRE /LOC SKIPPED BY FPP SO WE PUT CONST HERE
TAD ACH /HI MANTISSA OF Z
SPA SNA CLA /IS Z<0?
JMP NULLST /YES-RETURN THE NULL STRING
JMS I PUNSFIX /NO-FIX Z
STL
TAD SACLEN /CALC Z-LEN(SAC)
SNL /SKP IF Z.LO.LEN(SAC)
CLA /ELSE TAKE LEN(SAC)
CMA
TAD SACLEN
TAD YARG /NUMBER OF BYTES TO USE
SMA
JMP NULLST /NONE, RETURN NULL STRING
DCA STRCNT
TAD YARG /INDEX INTO STRING FOR SOURCE BYTES
TAD (SAC-2
DCA XR2 /SET SOURCE XR
TAD STRCNT
DCA SACLEN /SET NEW LENGTH OF SAC NOW
TAD I XR2 /NOW MOVE THE BYTES
DCA I SACXR
ISZ STRCNT
JMP .-3
JMP I PILOOP /--RETURN--
NULLST, CLA CLL
DCA SACLEN /ZERO SAC
JMP I PILOOP /--RETURN--
YARG, 0
PAGE
/POS FUNCTION
/RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z
POS, CLA CLL
DCA INSAV /FAKE AS STRING CALL TO STRING 0
JMS I (STFIND /FIND Y$
TAD STRCNT /# OF CHARS IN Y$
SNA CLA /IS Y$ THE NULL STRING?
JMP ONERET /YES-RETURN 1 AS POSITION
TAD SACLEN /NO-# OF CHARS IN X$
SNA CLA /IS X$ THE NULL STRING?
JMP ZRORET /YES-RETURN 0
TAD ACH /NO-GET HORD OF Z
SPA SNA CLA /IS Z GT 0?
PA, JMS I PERROR /NO-ILLEGAL ARGUMENT
JMS I PUNSFIX /FIX Z
DCA POSITN /USE IT AS POSITION TO START SEARCH
TAD POSITN
STL
TAD SACLEN /COMPARE POSITION TO MAXIMUM LENGTH OF STRING
SNL SZA CLA
JMP PA /Z IS PAST END OF STRING-ERROR
POSSET, TAD STRCNT
CMA
TAD POSITN /GET POSITION NOW CHECKING+SIZE IF Y$
TAD SACLEN /COMPARE AGAINST LENGTH OF STRING
SMA SZA CLA /ANY MORE TO COME?
JMP ZRORET /NO-SEARCH FAILS
JMS I (BYTSET /SETUP BYTE LOAD ROUTINE
TAD POSITN /SEARCH START POSITION IN X$
TAD (SAC-2 /ADD TO BASE OF SAC
DCA SACXR
TAD STRCNT /# OF CHARS IN Y$
DCA TEMP3 /COUNTER
SRCLP, JMS I (LDB
CIA
TAD I SACXR /COMPARE CHARS
SNA CLA /DO THEY MATCH?
JMP SCONTU /YES-CONTINUE MATCH TO NEXT CHAR IN X$ AND Y$
ISZ POSITN /BUMP POSITION TO BE CHECKED
JMP POSSET /ITERATE
SCONTU, ISZ TEMP3 /MORE CHARS IN Y$?
JMP SRCLP /YES, ITERATE
TAD POSITN /NO FOUND A MATCH
JMP I (FLOATS
ZRORET, JMS I PFACCLR /SEARCH FAILS-RETURN 0
JMP I PILOOP
ONERET, CLA IAC
JMP I (FLOATS /RETURN 1
POSITN, 0
PAGE
RELOC
//////////////////////////////////////////////////
//////////////////////////////////////////////////
///////// OVERLAY 3-FILE MANIPULATING ////////////
///////// FUNCTIONS ////////////
//////////////////////////////////////////////////
//////////////////////////////////////////////////
*3400
/FILE CLOSING ROUTINE
VERSON^100+SUBVFF+6000 /VERSION WORD FOR FILES OVERLAY
ANDPTR, ANDLST
ANDLST, 7776 /MASKS FOR CLEARING BUFFER AND HANDLER STATUS BITS
7775
7773
7767
CLOSE, TAD ENTNO /GET FILE #
SNA CLA /IS IT TTY?
JMP I PILOOP /YES-DON'T DO ANYTHING
JMS I PIDLE /SEE IF FILE OPEN
JMS I PFTYPE /IS FILE NUMERIC?
JMP NOCZ /YES-DON'T OUTPUT ^Z
JMS I (FOTYPE /NO-IS FILE VARIABLE LENGTH?
JMP NOCZ /NO-DON'T OUTPUT ^Z
TAD (232 /YES
JMS I PPUTCH /WRITE A ^Z IN FILE
NOCZ, JMS I (WRBLK /WRITE LAST BLOCK IF IT HAS CHANGED
JMS I PPSWAP /RESTORE 17600
JMS I (FOTYPE /IS FILE FIXED LENGTH?
JMP CLOSED /YES-NO NEED TO CLOSE THE FILE
TAD I IOTLEN /NO-GET FILE LENGTH
DCA CLENG /PUT IN CLOSE CALL
TAD IOTFIL
DCA FNAP /POINTER TO FILE NAME
TAD I IOTHDR
CLL RTL
RTL
RAL /GET DEVICE NUMBER INTO BITS 8-11
AND O17 /ISOLATE IT
CIF 10
JMS I O7700 /CALL USR
4 /CLOSE
FNAP, . /POINTER TO FILE NAME
CLENG, .
FC, JMS I PERROR /FILE CLOSING ERROR
CLOSED, TAD I IOTBUF /GET BUFFER ADDRESS
CLL RTL
RTL /BUFFER NUMBER INTO AC
RAL /BITS 10,11
AND (3 /STRIP
TAD ANDPTR /USE AS INDEX INTO MASKS
DCA TEMP1
TAD BMAP /BUFFER STATUS MAP
AND I TEMP1 /CLEAR THE BIT FOR THIS BUFFER
DCA BMAP
TAD I IOTHDR /HEADER WORD
AND O7400 /STRIP HEADER TO DEVICE # ONLY
DCA I IOTHDR
TAD MM4 /-4
DCA TEMP3 /USE AS COUNTER
CHECKL, TAD TEMP3 /GET 3 OF FILE TO CHECK
TAD (W0PTR /MAKE POINTER TO PROPER W0 HEADER
DCA TEMP1 /SAVE POINTER
TAD TEMP3 /-# OF FILE WERE CHECKING
TAD ENTNO /COMPARE TO CURRENT NUMBER
SNA CLA /IS IT THIS ONE?
JMP PSTCHK /YES-DON'T CHECK DRIVER
TAD I TEMP1 /GET HEADER WORD FOR THE FILE OF INTEREST
AND O7400 /ISOLATE DEVICE #
CIA /NEGATE
TAD I IOTHDR /COMPARE TO CURRENT DEVICE #
SNA CLA /SAME DEVICE?
JMP CRETN /YES-LEAVE DRIVER IN CORE
PSTCHK, ISZ TEMP3 /ALL 4 CHECKED?
JMP CHECKL /NO-CHECK THE NEXT 1
TAD I IOTHDR
AND O10 /GET HANDLER LENGTH BIT
SZA CLA /TWO PAGES?
JMP TPREL /YES-FREE BOTH PAGES
TAD I IOTHND /THIS IS THE ONLY FILE USING HANDLER THEN
CLL RTL
RTL /SLIDE BITS 4,5 OF HANDLER PAGE TO AC BITS 10,11
RAL
AND (3 /ISOLATE HANDLER BUFFER NUMBER
TAD ANDPTR /MAKE POINTER TO PROPER AND MASK
RELCOM, DCA TEMP1
TAD DMAP /DRIVER PAGE MAP
AND I TEMP1 /CLEAR HANDLER PAGE BIT
DCA DMAP
CRETN, DCA I IOTHND /SET FILE AS IDLE
JMS I PPSWAP /GET RID OF 17600 AGAIN
JMP I PILOOP /DONE
TPREL, TAD I IOTHND /ONLY FILE USING HANDLER
CLL RTL
RTL /ISOLATE HANDLER BUFFER NUMBER
RAL
AND (3
TAD (ANDLS2 /USE AS INDEX TO AND MASK
JMP RELCOM
W0PTR, FILE1
FILE2 /FILE TABLE ENTRIES
FILE3
FILE4
MM4,
ANDLS2, 7774
7701
/CODE TO READ IN COMPILER AND START IT
/THIS CODE GETS MOVED TO FIELD 1 AND EXECUTED FROM
/LOC 2001-2013 IN FIELD 1
CREAD, CDF 10
CIF 0
4613 /"JMS I L7607K"
3700 /31 PAGES
0 /0-7577
CBLK, 7617 /STARTING BLOCK OF COMPILER
HLT /SYSTEM ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
CIF 0
5612 /"JMP I .+1"-START THE COMPILER
7001 /STARTING ADDR OF COMPILER
K7607K, 7607
/LESS THAN THE DESIRED VALUE
EXTCHK, 0 /SKIP RETURN IF CURRENT
AC0002
IAC
TAD IOTFIL /IS .SV
DCA EXTEMP /JUST A TEMP
TAD I EXTEMP /GET EXTENSION
TAD (-2326
SNA CLA /IS IT .SV?
ISZ EXTCHK /YES: SKIP
JMP I EXTCHK
EXTEMP, 0
PAGE
/CHAIN FUNCTION
/SETS UP COMMAND DECODER AREA,THEN CHAINS TO BCOMP.SV
CHAIN, JMS I PXPRINT /EMPTY TTY RING BUFFER
JMP .-1
JMS I PPSWAP /RESTORE PG 17600
JMS I DNA2 /GET FILE NAME IN NAME AREA FROM CURRENT FILE
CIF 10
JMS I O7700 /CALL USR
10 /LOCK IN CORE
TAD I IOTDEV
DCA DNA1 /FIRST TWO CHARS OF DEV NAME
TAD I IOTDEV+1 /LAST TWO CHARS
DCA DNA2
CIF 10
JMS I USR
12 /INQUIRE
DNA1, 0 /DEVICE NAME
DNA2, NAMEG
CDIN, 0
CI, JMS I PERROR /ERROR
TAD CDIN /GET ENTRY POINT OF DRIVER FOR CHAIN FILE
SZA CLA /IS IT IN CORE?
JMP DISIN /YES-NO NEED TO FETCH IT
TAD DNA2 /NO-DEVICE # INTO AC
CIF 10
JMS I USR
1 /FETCH HANDLER
7001 /INTO PAGE 7000
JMP CI /MAKE IT LOOK LIKE INQUIRE ERROR
DISIN, TAD IOTFIL
DCA STB /POINTER TO FILE NAME
TAD DNA2 /GET DEVICE #
CIF 10
JMS I USR
2 /LOOKUP
STB, 0 /POINTER TO FILE NAME
FLN, 0
CL, JMS I PERROR /LOOKUP ERROR
TAD STB /GET STARTING BLOCK
CDF 10
DCA I (7620 /STARTING BLOCK IN CD AREA
TAD FLN /FILE LENGTH
CLL RTL
RTL
AND (7760 /PUT IN BITS 0-7
TAD DNA2 /COMBINE WITH DEVICE #
DCA I (7617 /PUT IN CD AREA
TAD O100 /SET R SWITCH
DCA I (7644
TAD I (7605 /STARTING BLOCK OF COMPILER
SNA /(IS THIS A CORE IMAGE?
JMP CICHAIN /YES: HANDLE SOMEWHAT DIFFERENTLY
CDF
DCA I (CBLK /INTO COMPILER READ CODE
CDF
JMS I (EXTCHK /SKP IF EXTENSION .SV
SKP
JMP CX /ERROR IF IT IS
JMS I (PSWAP2 /NOW EXEC DESTRUCTIVE EXIT CODE
CDF 10
JMP I (CSMOVE /MOVE THE COMPILER READ TO FIELD 1 AND EXECUTE IT
CICHAIN,CDF
JMS I (EXTCHK /SKP IF EXTENSION IS .SV
CX, JMS I PERROR /ERROR IF NOT
JMS I (PSWAP2 /NOW EXEC ONCE ONLY CLEAN UP ROUTINE
TAD STB
DCA CHNSTB
CIF 10 /NOW DO A RESET AND DELETE TENTATIVE FILES
JMS I USR
13 /RESET
CIF 10 /FLAG TENTATIVE FILE CLEANUP
JMS I USR
6
CHNSTB, HLT
/FILE LOOKUP
FLOOK, AC0002
JMS I (ENTLOK /LOOKUP
DCA I IOTLEN /ACTUAL LENGTH
TAD I IOTLEN
DCA I IOTMAX /ALSO EQUALS MAXIMUM LENGTH
CLEANP, DCA I IOTPOS /ZERO COLUMN POINTER
CMA /-1
TAD I IOTLOC /STARTING BLOCK-1
DCA I IOTBLK /CURRENT BLOCK #=STARTING BLOCK-1
TAD I IOTBUF
DCA I IOTPTR /READ/WRITE POINTER AT BEGINNING OF BUFFER
CIF 10
JMS I USR /CALL TO USR
11 /USROUT
JMS I PPSWAP /GET RID OF 17600
JMS I (BLZERO
JMS I (NEXREC /DO A NEXREC TO READ IN FIRST FILE BLOCK
JMP I PILOOP /DONE
/ROUTINE FOR INTERPRETER EXIT
FSTOP, KSF /IS THE KEYBOARD FLAG SET?
JMP NOCTC /NO-THERE IS NO CHANGE ^C SENT US HERE
TAD O200 /YES-FORCE PARITY BIT
KRB /GET CHARACTER
TAD (-203 /COMPARE AGAINST ^C
SZA CLA /WAS IT ^C?
JMP NOCTC /NO-THIS IS A NORMAL EXIT
TSF
JMP .-1
TAD ("^ /YES -ECHO ^
TLS
CLA
TSF
JMP .-1
TAD ("C /ECHO "C"
TLS
NOCTC, TSF
JMP .-1
JMP I (MEXIT
PAGE
/FILE OPENING ROUTINE
OPENAV, TAD (4 /ALPHANUMERIC,VARIABLE LENGTH
OPENAF, IAC /ALPHANUMERIC,FIXED LENGTH
JMP OPENNF
OPENNV, TAD (4 /NUMERIC,VARIABLE LENGTH
OPENNF, DCA I IOTHDR /SET UP HEADER WORD
TAD ENTNO /IS FILE TTY?
SNA CLA
JMP I PILOOP /YES-DON'T DO ANYTHING
TAD I IOTHND /GET HANDLER ENTRY
SZA CLA /IS FILE IDLE?
FB, JMS I PERROR /ATTEMPT TO OPEN FILE ALREADY OPEN
JMS I PPSWAP /RESTORE 17600
JMS I (NAMEG /GET FILE DEVICE NAME AND FILE NAME INTO WORDS 7-14 FROM SAC
CIF 10
JMS I O7700 /CALL TO USR
10 /LOCK USR IN CORE
TAD I IOTDEV
DCA DEVNA1 /DEVICE NAME INTO INQUIRE CALL
TAD I IOTDEV+1
DCA DEVNA2
CIF 10
JMS I USR /CALL TO USR
12 /INQUIRE
DEVNA1, . /DEVICE NAME
DEVNA2, .
ENTRYN, 0 /ENTRY POINT
IN, JMS I PERROR /INQUIRE ERROR
TAD DEVNA2 /GET DEVICE #
CLL RAR
RTR /PUT INTO BITS 0-3
RTR
TAD I IOTHDR
DCA I IOTHDR /STORE IN HEADER WORD
TAD ENTRYN /GET DRIVER ADDRESS
SZA /IS IT IN CORE?
JMP I (DRIVRN /YES-NO NEED TO FETCH IT
TAD DMAP /NO-GET MAP OF DRIVER PAGES
CLL RAR /PAGE 7000 BIT IN LINK
SNL /IS PAGE 7000 FREE?
JMP FREE70 /YES
CLL RAR /NO-7200 BIT TO LINK
SNL /IS PAGE 7200 FREE?
JMP FREE72 /YES
CLL RAR /NO-7400 BIT TO LINK
SZL CLA /IS PAGE 7400 FREE?
DO, JMS I PERROR /NO-NO MORE ROOM FOR DRIVERS
TAD O7400 /YES-LOAD HANDLER INTO 7400
DCA FETPAG /SET UP IN FETCH CALL
TAD (4 /SET BIT 9 TO SHOW PAGE 7400 OCCUPIED
JMP DFETCH /FETCH DRIVER
FREE70, CLL RAR /PAGE 7200 BIT TO LINK
SNL CLA /IS 7200 FREE?
IAC /YES-THERE IS ROOM FOR A TWO PAGE HANDLER
TAD (7000
DCA FETPAG /SET UP FETCH TO USE PAGE 7000
CLL CLA CML RTL /TURN ON BIT 10
DCA TPH /SAVE IN TWO PAGE SET WORD
IAC /SET BIT 11 TO SHOW PAGE 7000 OCCUPIED
JMP DFETCH /FETCH HANDLER
FREE72, CLL RAR /7400 BIT TO LINK
SNL CLA /IS 7400 PAGE FREE?
IAC /YES-THEN THERE IS ROOM FOR A 2 PAGE HANDLER
TAD (7200
DCA FETPAG /SET ADDRESS IN FETCH CALL
TAD (4
DCA TPH /IF TWO PAGE LOADED,SET BIT 9 ALSO
AC0002 /TURN ON BIT 10 TO SHOW PAGE 7200 OCCUPIED
DFETCH, TAD DMAP /TURN ON PAGE BIT FOR WHERE BUFFER WILL BE LOADED
DCA DMAP
TAD DEVNA2 /DEVICE # IN AC
CIF 10
JMS I USR /CALL TO USR
1 /FETCH
FETPAG, . /DRIVER ADDRESS
FE, JMS I PERROR /FETCH ERROR
CDF 10
CLA CMA
TAD I (37 /GET ADDR OF HANDLER INFO TABLE
TAD DEVNA2 /USE THE DEVICE # AS AN INDEX INTO THAT TABLE
DCA TEMP1 /SAVE POINTER
TAD I TEMP1 /GET THE INFO WORD FOR THE HANDLER JUST FETCHED
CDF
SMA CLA /IS HANDLER 2 PAGES LONG?
JMP DRAP /NO MAP IS COMPLETE
TAD TPH /YES-UPDATE DRIVER MAP TO INCLUDE
TAD DMAP /SECOND PAGE OF TWO PAGE HANDLERS
DCA DMAP
TAD O10
TAD I IOTHDR /SET 2 PAGE BIT IN HEADER WORD
DCA I IOTHDR
DRAP, TAD FETPAG /HANDLER ENTRY ADDRESS
JMP I (DRIVRN /PAGE ESCAPE
TPH, 0
/ROUTINE TO MOVE THE COMPILER READER INTO FIELD 1 AND START IT
CSMOVE, TAD (CREAD-1
DCA XR1 /POINTES TO COMPILER STARTING CODE
TAD (-13
DCA TEMP1 /COUNTER
TAD (2000
DCA XR2 /MOVE TO LOC 2001 IN FIELD 1
CDF
TAD I XR1 /GET WORD OF CODE
CDF 10
DCA I XR2 /MOVE IT
ISZ TEMP1 /DONE?
JMP .-5 /NO
CIF 10 /YES-START IT
JMS I (2000
PAGE
DRIVRN, DCA I IOTHND /DRIVER ENTRY INTO I/O TABLE
TAD BMAP /GET BUFFER MAP
CLL RAR /BUFF1 BIT TO LINK
SNL /IS IT FREE?
JMP B1 /YES-ASSIGN BUFF1
RAR /BUFF2 BIT TO LINK
SNL /IS IT FREE?
JMP B2 /YES-ASSIGN BUFF2
RAR /BUFF3 BIT TO LINK
SNL /IS IT FREE
JMP B3 /YES-ASSIGN BUFF3
RAR /NO-BUFF4 BIT TO LINK
SZL CLA /IS IT FREE?
BO, JMS I PERROR /NO-NO MORE BUFFERS AVAILABLE
TAD (1400
DCA I IOTBUF /SET BUFFER ADDRESS TO 1400
TAD O10 /SET BUFF4 BIR IN MAP
JMP BUFASS
B3, CLA
TAD (1000
DCA I IOTBUF /SET BUFFER ADDRESS TO 1000
TAD (4
JMP BUFASS /SET BUFF3 BIT IN MAP
B2, CLA
TAD O400
DCA I IOTBUF /SET BUFF ADDRESS TO 400
CLL CML CLA RTL /SET BUFF2 BIT IN MAP
JMP BUFASS
B1, CLA
DCA I IOTBUF /SET BUFF ADDRESS TO 0000
CLA IAC /TURN ON BUFF1 BIT IN MAP
BUFASS, TAD BMAP
DCA BMAP /UPDATE BUFFER ASSIGNMENT MAP
TAD I IOTHDR /GET HEADER WORD
CLL RTR
RAR /FIXED,VARIABLE BIT TO LINK
SNL CLA /IS IT FIXED?
JMP I (FLOOK /YES-DO A LOOKUP
TAD (3 /NO-DO AN ENTER
JMS ENTLOK /ENTER
DCA I IOTMAX /MAXIMUM LENGTH IN WORD 7
DCA I IOTLEN /ZERO ACTUAL LENGTH
JMP I (CLEANP /FINALIZE I/O TABLE ENTRY
MEXIT, CLA
JMS I PPSWAP
JMS I (PSWAP2 /RESTORE PG 27600
CDF 10
TAD I (EDBLK /GET BLOCK # FOR EDITOR
CDF
SNA /SHALL WE CALL THE EDITOR?
JMP I (7600 /NOkJUST CALL OS/8
DCA EBLK /YES-PUT THE BLOCK # IN DRIVER CALL
JMS I (7607 /CALL SYS DRIVER
2100 /READ 8 BLOCKS
0 /INTO 0-3377
EBLK, . /BLOCK # OF EDITOR
HLT /SYS ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
JMP I .+1 /START THE EDITOR
3212
ENTLOK, 0
DCA FNOM /FUNCTION NUMBER IN PLACE
TAD IOTFIL /POINTER TO FILE NAME
DCA STARTB /INTO CALL
TAD I (DEVNA2 /DEVICE NUMBER
CIF 10
JMS I USR /CALL TO USR
FNOM, . /ENTER OR LOOKUP
STARTB, .
FLEN, .
EN, JMS I PERROR /ENTER ERROR
TAD STARTB /FILE STARTING BLOCK #
SZA CLA /IS IT NON-ZERO?
JMP FILSTU /YES-DEVICE IS FILE STRUCTURED
TAD FLEN /NO-GET FILE LENGTH
SZA CLA /IS IT EMPTY?
JMP FILSTU /NO-DEVICE IS FILE STRUCTURED
TAD (20 /NO-FILE IS READ/WRITE ONLY
TAD I IOTHDR
DCA I IOTHDR /SET READ/WRITE ONLY BIT
TAD FNOM
CLL RAR
SNL CLA
IAC
FILSTU, TAD STARTB /GET STARTING BLOCK # OF FILE
DCA I IOTLOC /PUT IN I/O TABLE
TAD FLEN /FILE LENGTH
CIA /MAKE FILE LENGTH POSITIVE
JMP I ENTLOK /RETURN
/SUBROUTINE P2SWAP-RESTORE OS/8 RESIDENT MONITOR PRIOR TO EXIT FROM INTERPRETERTER
/THIS IS DESTRUCTIVE CODE,AND ONCE THIS ROUTINE HAS BEEN EXECUTED
/THERE IS NO PLACE TO GO BUT OUT.
/HAS 3 FUNCTIONS:
/ 1) REMOVES CTRL/C HOOKS FROM SYS DRIVER
/ 2) RESTORES BATCH CONTROL WORDS TO 27774-27777
/ 3) IF SYS=TD/8E,RESTORES PAGE 27600 AND RETURNS CDFS TO PAGE 07600
PSWAP2, 0
TAD (4207
DCA I (7600 /REMOVE CTRL/C HOOKS
TAD (6213
DCA I (7605
TAD (7600
DCA I (HICORE /FUDGE POINTER IN SWAP ROUTINE (IN CASE IT WAS TD8E)
TAD PSFLAG /GET RESIDENT STATUS FLAG
SPA CLA /IS THIS TD8/E SYS?
JMS I (PSWP2P /YES-RESTORE PAGE 27600 AND PAGE 07600
TAD CDFIO
DCA .+3 /CDF TO HI CORE
CDF 10
TAD I BOSPT1 /GET BATCH WORD
CDF 10
DCA I BOSPT2 /BACK INTO LOFTY STATE
ISZ BOSPT1
ISZ BOSPT2
JMP .-6
CDF
JMP I PSWAP2 /YES-WE ARE FINISHED,SO RETURN
BOSPT1, 7600
BOSPT2, 7774
PAGE
/PARSE A FILENAME OF THE FORM "DEVN:FILENM.EX" IN THE SAC
/DSK: AND A NULL EXTENSION ARE THE DEFAULTS
/THE END OF THE SAC IS USED AS A WORK AREA
/IF SYNTAX IS CORRECT, THE NAME IS PACKED INTO
/THE FILENAME FIELD OF THE CURRENT FILE
/OTHERWISE A FATAL ERROR IS RETURNED
/ENTERED WITH OS/8 SWAPPED IN
WKAREA= SAC+16 /DEFINE SCRATCH AREA
NAMEG, 0
TAD SACLEN
TAD (16 /COMPARE STRING LENGTH TO 16
SPA CLA
IF, JMS I PERROR /TOO MANY CHARS IN "DEV:FILENM.EX"
TAD SACLEN
DCA TEMP2 /STRING LENGTH COUNTER
TAD PSACM1
DCA SACXR
TAD (DSK-1 /FIRST USE THE DEFAULT DEVICE
JMS DEVFUD
NCG, TAD I SACXR /GET CHAR FROM SAC
DCA TEMP1 /SAVE
TAD TEMP1
TAD (-72 /IS IT A COLON?
SNA
JMP CAD /YES-CHARS SO FAR=DEVICE NAME
TAD (14 /NO-IS IT A PERIOD?
SNA CLA
JMP SSAD /YES-NEXT TWO CHARS=EXTENSION
TAD TEMP1 /NO-GET CHAR AGAIN
DCA I XR2 /STORE IN WORK AREA
ISZ TEMP4 /BUMP COUNT FOR CURRENT SECTION
NCGS, ISZ TEMP2 /END OF STRING YET?
JMP NCG /NO-NEXT CHAR
TAD TEMP4 /YES-GET CHAR COUNT FOR THIS SECTION (NAME)
TAD (-6
SMA SZA CLA /IS IT >6?
JMP IF /YES-TOO MANY CHARACTERS IN FILE NAME
TAD (WKAREA-1 /NO-ADDRESS OF SCRATCH NAME BLOCK
DCA XR1
STA /-1
TAD IOTDEV /ADDRESS OF FINAL NAME BLOCK-1
DCA XR2
TAD (-6 /MOVE 6 WORDS
DCA TEMP2
MML, TAD I XR1
CLL RTL
RTL
RTL
TAD I XR1
DCA I XR2 /MOVE NAME WORD FROM SCRATCH AREA TO FINAL DEST
ISZ TEMP2 /DONE?
JMP MML /NO
JMP I NAMEG /YES-RETURN
CAD, TAD TEMP4 /GET CHAR COUNT FOR THIS SECTION
TAD (-4 /COMPARE AGAINST 4
SMA SZA CLA /TOO MANY CHARS?
JMP IF /YES-DEVICE NAME TOO LONG
TAD (WKAREA-1+4
JMS DEVFUD /CLEAR BUF AND GET NAME FROM FILE FIELD THIS TIME
JMP NCGS
SSAD, TAD TEMP4 /COUNT FOR THIS SECTION (FILE NAME)
TAD (-6
SMA SZA CLA /TOO MANY?
JMP IF /YES-FILE NAME TOO LONG
DCA TEMP4 /NO-CLEAR COUNT
TAD DSK
TAD TEMP2 /COMPARE AGAINST # OF CHARS LEFT
SPA SNA CLA
JMP IF /TOO MANY CHARS IN EXTENSION
TAD (WKAREA-1+12
DCA XR2
JMP NCGS
DEVFUD, 0
DCA XR1 /POINT AT LOC OF DEV:
TAD (WKAREA-1
DCA XR2 /POINT AT START OF WORK AREA
TAD (-10
DCA TEMP4
TAD (-4
DCA TEMP3
TAD I XR1 /GET A DEVICE NAME BYTE
DCA I XR2 /STORE IN WORK AREA DEVICE FIELD
ISZ TEMP3
JMP .-3 /ITERATE
DCA I XR2 /NOW CLEAR REST OF FILE NAME
ISZ TEMP4
JMP .-2 /ITERATE
TAD (WKAREA-1+4 /POINT XR2 AT FILENAME FIELD
DCA XR2
JMP I DEVFUD /RETURN WITH TEMP4 CLEAR
DSK, 4;23;13;0 /6BIT DEFAULT DEVICE NAME "DSK"
/SUBROUTINE TO RESTORE PAGE 27600 OF TD8/E DRIVER
/AND READJUST THE CDFS IN FIELD 0
PSWP2P, 0
TAD PSFLAG
RTL
SNL CLA /BIT 1 SET MEANS PHONEY TD8E
JMP .+3
DCA PSFLAG
JMP I PSWP2P
DCA PSFLAG /CLEAR RESIDENT STATUS FLAG
TAD (CDF 20
DCA I (P2CDF /PUT CDF 20 IN SWAP ROUTINE
TAD (CDF 20
DCA I (P2CDF1
JMS I PPSWAP /MOVE DOWN PAGE 27600
TAD (6223
DCA I (7642
TAD (6222
DCA I (7721
TAD (6222 /RESTORE CDFS IN PAGE 07600
DCA I (7727
JMP I PSWP2P /RETURN
PAGE
FIELD 0
/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////// END OF OVERLAY AREA /////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////
$
<:STTYF, 1+1"E0;'
J<SPRINT;R-5DI[XPRINT>
J<SSACPTR;R-6DI[SAC-1>
J<SPUTCHL;R-6DI[PUTCH>
J<SILOOPL;R-6DI[ILOOP>
J<SINTL;R-4DI[UNSFIX>
J<SCDFPSL;R-6DI[CDFPSU>
J<SERROR;R-5DI[ERRDIS>
J<SFBITS;R-5DI[FBITGT>
J<SPWFECL;R-5DI[PWFECH>
J<SMPYLNK;R-6DI[MPY>
J<SXPUT;R-4DI[XPUTCH>
J<SFIDLE;R-5DI[IDLE>
J<SDEVCAL;R-6DI[DRCALL>
J<SWRITFW;R-6DI[WRITFL>
J<SSTHINL;R-6DI[STHINI>
J<SLDHINL;R-6DI[LDHINI>
J<SSTH;R-3DI[STHL>
J<SLDH;R-3DI[LDHL>
J<SFACSAL;R-6DI[FACSAV>
J<SFACREL;R-6DI[FACRES>
J<SFGETL;R-5DI[FFGET>
J<SFPUTL;R-5DI[FFPUT>
J<SFNORL;R-5DI[FFNOR>
J<SFCLR;R-4DI[FACCLR>
J<SFNEGL;R-5DI[FFNEG>
J<SFLOATL;R-6DI[FFLOAT>
J<SGETCHL;R-6DI[GETCH>
J<SEOFSEL;R-6DI[EOFSET>
J<SBSWL;R-4DI[BSWP>
J<SPACKL;R-5DI[PACKCH>
J<SCNOCLL;R-6DI[CNOCLR>
J<SBUFCHL;R-6DI[BUFCHK>
J<SFTYPL;R-5DI[FTYPE>
J<SCHRNOL;R-6DI[CHARNO>
J<SNEXREL;R-6DI[NEXREC>
J<SCRLF;R-4DI[CRLFR>
J<SVALLK;R-5DI[VALGET>
J<SPATCHP;R-6DI[PATCHF>
J<SP1SWAP;R-6DI[PSWAP>
J<SLDHRST;R-6DI[LRESET>
J<SSTHRST;R-6DI[SRESET>
P>