File: EFOS8P.PA of Tape: Sources/Focal/s4
(Source file text)
XLIST
/PSEUDO FLOATING POINT INSTRUCTIONS
FIXMRI FGET=0000
FIXMRI FADD=1000
FIXMRI FSUB=2000
FIXMRI FDIV=3000
FIXMRI FMUL=4000
FIXMRI FPOW=5000
FIXMRI FPUT=6000
FNOR=7000
FINT=JMS I 7
FENT=JMS I 7
FEXT=0
FXIT=0
/PERMANENT SYMBOLS FOR PAL8-V9B
/PDP8/E-SYMBOLS
CAM=7621
SRQ=6003
CINT=6204
SINT=6254
CUF=6264
SUF=6274
/NEW INSTRUCTIONS
RIE=6013 /S/CL ERR. INT. (READER)
RCR=6015 /CLEAR READER/PUNCH ERROR
RSE=6017 /SKIP ERROR READER
PIE=6023 /S/CL ERR. INT. (PUNCH)
PSK=6025 /SKIP ON READER OR PUNCH FLAG
PSE=6027 /SKIP ERROR PUNCH
/KE8-E (EAE)-SYMBOLS
SWAB=7431
SWBA=7447
SKB=7671
SCA=7441
SCL=7403
MUY=7405
DVI=7407
NMI=7411
SHL=7413
ASR=7415
LSR=7417
ASC=7403
SAM=7457
DAD=7443
DLD=7663
DST=7445
DPIC=7573
DCM=7575
DPSZ=7451
FIXTAB
XLIST
EJECT FOS8 INTERPRETER-ETOS
FIELD 1
/MISCELLANEOUS ITEMS
*0
ECHO, 1
TABC, 0 /TABCOUNTER
SPC, 240 /CONSTANT
ATSW, 0
0
0 /FOR OD
0
T=20 /TEXT FIELD NO.
P=10 /PROGRAM FIELD NO.
L=00 /LIBRARY FIELD NO.
V=10 /VARIABLE FIELD NO.
FPNT /ADRESS OF FLOATING POINT(LOC*7)
/AUTO INDEX REGISTERS
AXIN, LINE4 /STORAGE INDEX(LOC*10)
XRT, 0 /EXTRA XR
XRT2, 0 /EXTRA XR
PER, 256 /LET'S HOPE IT IS NOT INDIRECTLY ADRESSED!
FLTXR, 0 /XR FOR FLOATING POINT
FLTXR2, 0 /EXTRA FOR F.P.
MPER, -256 /CONSTANT
TEXTP=. /TEXT POINTERS(LOC*17)
AXOUT, LINE4 /OUTPUT INDEX
XCT, 7777 /UNPACK SWITCH;THESE 4 ARE PUSHED
GTEM, 0 /UNPACK STORAGE
PC, PC0 /PROGRAM COUNTER
THISLN, 0 /LINE POINTER FROM 'FINDLN'
THISOP, 0 /CURRENT 'EVAL' OPERATION
LASTLN, 0 /BACK POINTER FROM 'FINDLN'
DEBGSW, 1 /DEBUG SWITCH;NON ZERO FOR LITERAL
PACKST, 0 /RUBOUT PROTECTION
PT1, 0 /VARIABLE POINTER
LASTV, STVAR /ADRESS OF LAST VARIABLE
T1, 0 /TEMP. REGISTER - MAIN
T2, 0 /TEMP FOR NEW INSTR.
T3, 0 /TEMP. REGISTER FOR OUTPUT
INSUB, 0 /0=GETC;#0=READC
SUBS, 0 /VARIABLE SUBSCRIPT
P177, 177 /STEP MASK;DON'T MOVE;AND P177=37!!
*40 /FLOATING POINT
EX1, 0 /OPERAND STORAGE
AC1H, 0
AC1L, 0
OVER1, 0
FLAC=. /FLOATING ACCUMULATOR
EXP, 0
HORD, 0
LORD, 0
OVER2, 0
SIGNF, 0 /FLOATING SIGN
MINSKI, ACMINS /NEGATE FLAC SUBROUTINE
FISW, 1 /OUTPUT FORMAT 1=FIXED,0=FLOAT
INTEGE, FIX /FIX FLAC
*54 /VARIABLES - INITIALIZED FOR THE DIALOGUE
CELSO=. /ECALL PUSHES THESE FOUR
POPFP, CIF CDF P /+ECALL=15 BIT POPJ
EFOP, 0 /FUNCTION CODE
LASTOP, 0 /LAST OPERATION FOR EVAL
SORTCN, 0 /NUMBER IN TABLE FROM SORTC
BUFR, LINE4 /NEXT LOC. IN BUFFER=LAST LOC. IN TEXT
ADD, 4300 /CHAR. BUF. IN
XCTIN, 0000 /PACK SWITCH
OUTDEV, LOWOUT /POINTER TO OUT. SUB.
INDEV, LOWIN /POINTER TO IN. SUB.
CNTR, 0 /DELETE AND FP
LIST6=. /INPUT LIST FOR "SFOUND"
CVT, 213 /V.T. (^K)
207 /BELL
LIST7=.
375 /ALT MODE
233 /ESCAPE
225 /^U
P337, 337 /LEFT ARROW
CLF, 212 /L.F.
LIST3=. /EXCRETION LIST
CCR, 215 /LIST BRANCHER
DMPSW, HLT /(SEARCH CHAR)-VARIABLE
/=0000 FOR TRACE ON
P7600, 7600 /ENDS LISTS
P77, 77 /DON'T MOVE;AND P77=100!!!
/CONSTANTS
P13, 13 /USEFUL CONSTANT
C200, 200
M77, -77 /EXTEND CODE TEST
P17, 17 /BCD MASK
P277, 277 /"?"
M2, -2 /CONSTANT
ERROR2=JMS I . /FIELD 1 ERROR ADRESS
ERROR /KEEP IT AT LOC. 107;SAME ADRESS IN USR;VOL!!
C260, 260 /ASCII FOR ZERO
M5, -5 /PAREN TEST
M11, -11 /PAREN TEST
P40, 40
FSIZE, 10
DECP, 4
DIGITS, 12
MFLT, -WORDS /=-4 FOR 4-WORD
NAGSW, 0001 /4000=ONE;1=ALL;0=GROUP;ALSO PUSHED
CHAR, 215 /THE MOST IMPORTANT REGISTER
LINENO, 0000 /LINE NUMBER READ BY GETLN
GINC, WORDS+2 /=6 FOR 4-WORD-CONSTANT
/POINTERS ETC.
PAXPNT, PDLXR /POINTER FOR RESET
FLARGP, FLARG /DATA ADRESS
CFRSX, FLTZER /POINTER TO ZERO DATA &
DOUBLE, MULT2 /MULTIPLY FLAC BY 2
FOUTPU, FLOUTP /FLOATING OUTPUT
FINPUT, FLINTP /FLOATING INPUT
CFRS, LINE0 /ADRESS OF DUMMY LINE
END, STVAR /FIRST LOCATION
DECALL, ECALL /RECURSIVE EVAL
DPART, PARTES /PAREN COMPARE ETC.
ENDT, LINE1
WORDS=4
/PDL INSTRUCTIONS
POPA=JMS I . /RESTORE AC
XPOPA
PUSHJ=JMS I . /RECURSIVE SUB. CALL
XPUSHJ
POPJ=JMP I . /SUB. RETURN
XPOPJ
PUSHA=JMS I . /SAVE AC
XPUSHA
PUSHF=JMS I . /SAVE GROUP OF DATA
XPUSHF
POPF=JMS I . /RESTORE GROUP
XPOPF
/NEW INSTRUCTIONS:
STOCHR=JMS I .
CHRSTO /STORE A CHARACTER
TSTCHR=JMS I .
CHRTST /SKIPS IF CHAR=ARG
GETC=JMS I . /UNPACK A CHARACTER
UTRA
PACKC=JMS I . /PACK A CHARACTER
PACBUF
SORTJ=JMS I . /SORT AND BRANCH ON AC OR CHAR
SORTB
SORTC=JMS I . /SORT CHAR
XSORTC
PRINTC=JMS I . /PRINT AC OR CHAR
OUT
READC=JMS I . /READ DATA INTO CHAR AND PRINT IT
IN
PRNTLN=JMS I . /PRINT C(LINENO)
XPRNT
GETLN=JMS I . /UNPACK AND FORM A LINENUMBER
CNUM, XGETLN
FINDLN=JMS I . /SEARCH FOR A GIVEN LINE
XFIND
SPNOR=JMS I . /IGNORE SPACES AND LEADING ZEROS
XSPNOR
TESTN=JMS I . /PERIOD;OTHER;NUMBER
XTESTN
TSTLPR=JMS I . /SKIP IF 5.L.SORTCN.L.E.11(I.E. AN L-PAR)
LPRTST
TSTGRP=JMS I . /SKIP IF G(AC)=G(LINENO)
GRPTST
TESTC=JMS I . /TERM;NUMBER;FUNCTION;LETTER- AND IGNORE SPACES
XTESTC
DELETE=JMS I . /REMOVE OLD TEXT LINE
XDELETE
DRONEP=JMS I .
XDRONE
/VARIOUS NEW POINTERS ETC.
DPC, PCD /PC
DTHIS, THISD /THISLN
DPT1, PT1D /PT1
DXRT, XRTD /(TAD I XRT)
DAXIN, AXIND /(DCA I AXIN)
SECRTV, STSECR /FOR SECRET VARIABLES
EOL, 0 /END OF LINE SWITCH
PDLSTR, MONAME-1 /START OF PDL
/FOCAL'S COMMAND/INPUT DRIVER
*177
START, .+1 /PROGRAM START FROM SELF (INDIRECT)(OR TO LEXIT)
TAD C200
DCA PC /FOR COMMAND MODE
IAC /USE ONE IN THE AC TO
DCA DMPSW /INIT UNPACK AND TRACE SWITCH
DCA DEBGSW /ENABLE TRACE FOR INPUT OF (?)
TAD PDLSTR /SET HIGH LIMIT FOR PDL
CDF T
DCA I PAXPNT
CDF P
DCA ECHO /PRINT ONLY IF ECHO
ISZ EOL /CHECK IF CR TERMINATED
JMP IBAR /NO;($) TREAT LIKE ^U,_
IBAR1, TAD CNUM /ANNOUNCE PRESENCE WITH #
PRINTC
ISZ ECHO
TAD BUFR /COMMAND INPUT BUFFER
DCA AXIN /FOR UNPACKING
DCA XCTIN
TAD BUFR /RUBOUT PROTECTION
DCA PACKST
IGNOR, READC /READ COMMAND STRING
SORTJ
LIST7-1
INLIST-LIST7
PACKC /SAVE STRING CHARACTER
JMP IGNOR
INPUTX, PUSHJ /PROCESS IMMEDIATE COMMAND
PROC
JMS I DPC /TAD I PC
SNA /END OF PROGRM?
JMP I START /YES
DCA PC /SAVE NEW LINE NO
TAD PC /START NEW LINE
IAC
JMP GONE /PROCESS OTHER COMMANDS
/TEXT LINE BUFFER FORMAT
/#1 : POINTER OR ZERO IN LAST
/#2 : LINENO
/#3 - #N+1 : TEXT
/#N : C.R.
/LINE NUMBER FORMATION;RANGE OF ACCEPTIBLE LINE NUMBERS
/=1.01 TO 31.99
XGETLN, 0 /COMPUTED LINE #'S
SPNOR /IGNORE SPACES
TSTCHR /'A' IS SPECIAL
-"A
SKP
JMP TESTA
PUSHJ /EVALUATE NUMBER OR EXPRESSION
EVAL
JMS I INTEGER /GET GROUP PART
TAD P7740 /CHECK IF TOO BIG
SMA CLA
GZERR, ERROR2 /BAD GROUP #
206 /IG
TAD LORD /GET GROUP AGAIN
BSW
CLL RAL
DCA LINENO /SAVE IT
JMS I MINSKI
NOP /CDF V AFTER FENT
FENT
FADD I FLARGP /GET FRACTION
FMUL FL100
FADD FLP5 /ROUND UP
FEXT
JMS I INTEGER
TAD LINENO /ADD GROUP
TESTA, DCA LINENO
CLA CLL
TAD LINENO /CHECK FOR ERROR
AND P7600
SZA CLA
CML
TAD LINENO
AND P177
SNL SZA
JMP GZERR /ILLEGAL GROUP ZERO USAGE
P7740, SMA SZA CLA /SMA FOR 7740
TAD P2000 /SET NAGSW;GROUP=0,LINE=4000,ALL=1
CML RAL
DCA NAGSW
JMP I XGETLN
FL100, 0007
3100
0000
FLP5, 0000
P2000, 2000
0000
0000
IBAR, TAD CCR /ALTESC AND ^U,_ COME HERE
PRINTC
JMP IBAR1
/COMMAND/INPUT PROCESSOR
ESRETN, TAD CCR
STOCHR /ESCAPE CONVERTED TO CR
CLA CMA
IRETN, CMA
DCA EOL /EOL REMEMBERS WHICH
PACKC /START TO PACK C.R.
PACKC /FINISH C.R.
TAD BUFR /INITIALIZE FOR UNPACKING
GONE, DCA AXOUT /SETUP CURRENT LINE
DCA XCT
GETC /READ FIRST CHARACTER
TAD P7740
TAD PDLSTR /SET LOW LIMIT FOR PDL
CDF T
DCA I PAXPNT
CDF P
SPNOR /IGNOR LEADING BLANKC
TESTN /DOES THE LINE BEGIN WITH 1-9?
JMP GZERR /PERIOD =ILLEGAL GROUP ZERO USAGE
JMP INPUTX /NO
ISZ DEBGSW /YES, DISABLE TRACE FOR REPACKING
GETLN /READ THIS LINE NUMBER
CLA CLL CML RAR /TEST FOR SINGLE LINE
TAD NAGSW
SZA CLA
ERROR2 /ILLEGAL LINE NUMBER ON INPUT
213 /IL
TAD BUFR /SET POINTERS
DCA AXIN
DCA XCTIN
TAD LINENO /SAVE LINE #
JMS I DAXIN /DCA I AXIN
SPNOR /IGNORE SPACES AFTER LINE NUMBER
SKP
GETC /READ 1ST AFTER LINENO TERMINATOR
SRETN, PACKC /SAVE TEXT AND RESTORE DATA FIELD
TSTCHR /TEST FOR END OF INPUT STRING
-215 /-C.R.
JMP .-4
DELETE /REMOVE OLD LINE, IF ANY
CDF T /TERMINATE THE BUFFER LINE:OLD "ENDLN"
TAD I LASTLN
DCA I BUFR
TAD BUFR /POINT TO NEW NEXT LINE
DCA I LASTLN
TAD ADD /CHECK FOR EXTRA INFO.
SZA
DCA I AXIN
TAD AXIN /COMPUTE NEW END OF BUFFER
IAC
DCA BUFR
GOKILL, CDF L
DCA I LIBN /WE'VE CHANGED SOMETHING
CDF P
START1, JMP I START /POINTERS MUST BE REINITIALIZED
LIBN, LIBFIL
/PUSHDOWN LIST SATELLITES
FLD1=CLA CLL IAC
XPOPA, 0
MQL
FLD1
CIF T
JMS I .+1
ZPOPA
XPUSHA, 0
MQL
FLD1
CIF T
JMS I .+1
ZPUSHA
XPUSHF, 0
MQL
FLD1
CIF T
JMS I .+1
ZPUSHF
XPOPF, 0
MQL
FLD1
CIF T
JMS I .+1
ZPOPF
XPOPJ, CIF CDF T
JMP I .+1
ZPOPJ
/RECURSIVE OPERATE, EXECUTE, OR CALL
DO, GETLN /EXECUTE ONE LUNE, A GROUP, OR ALL
PUSHF /SAVE REST OF THIS LINE
TEXTP /AXOUT,XCT,GTEM,PC
DGRP, PUSHF /SAVE NAGSW; CHAR; AND LINENO
NAGSW
TAD NAGSW /CHECK DATA FROM GETLN
SPA CLA /SKIP IF GROUP OR ALL
JMP DOONE /DO ONE LINE
FINDLN /INIT FOR GROUP AND SET THISLN
INDOL, "$
TAD THISLN /TEST FOR GOOD GROUP NUMBER
DCA XRT
JMS I DXRT /TAD I XRT
TSTGRP
ERROR2 /NO SUCH GROUP NUMBER
66 /DG
DGRP1, PUSHJ /EXECUTE OBJECT LINE AND SET PC
PROCESS-2
POPF /RESTORE THE DATA
NAGSW
JMS I DPC /CHECK FOR END OF TEXT
SNA
JMP DCONT /ALL DONE
IAC
DCA PT1 /SAVE POINTER TO LINENO
TAD NAGSW /CHECK FOR GROUP
SMA SZA CLA
JMP .+4 /DO ALL
JMS I DPT1 /TEST GROUP
TSTGRP /AGAINST LINENO
JMP DCONT /NOT IN GROUP
JMS I DPT1 /READ NEXT LINE NO
DCA LINENO
JMP DGRP /CONTINUE THE SUBROUTINE
DOONE, FINDLN /FIND THE LINE
ERROR2 /NO SUCH LINE NUMBER
73 /DL
PUSHJ /EXECUTE IT
PROCESS-2 /AND SET PC
POPF /RESTORE CHAR
NAGSW
DCONT, POPF /RESTORE TEXT POINTERS
TEXTP
JMP I .+1 /CONTINUE PROCESSING THIS LINE
PROC
IN, 0 /READ IN A CHARACTER SUBROUTINE."READC"
DCA INCOMP /IF AC # 0 THEN KEEP CHAR TO COMPARE
CIF CDF L
JMS I INDEV
STOCHR
TAD CHAR
CIA /NOW COMPARE
TAD INCOMP
SNA CLA
POPJ /FOUND IT;EXIT FROM 'FIND'
DCA ECHO
SORTJ
ECHOLST-1 /LF. OR RUB.:IGNORE
ECHOGO-ECHOLST /ALT.ESC.:CHANGE
PRINTC
INEX, ISZ ECHO
JMP I IN
FIND, JMS I INTEGE /GET VALUE OF SEARCH CHAR.
READC /PASS IT ON TO 'IN'
TAD INCOMP
JMP .-2 /LOOP;'IN' WILL GIVE 'POPJ'
INCOMP, 0
INALT, TAD INDOL
JMP INEX-1
CHRTST, 0 /TEST CHAR SUB; "TSTCHR"
TAD I CHRTST /GET ARG
ISZ CHRTST /BUMP PAST ARG
TAD CHAR
SNA CLA
ISZ CHRTST /SKIP IF EQUAL
JMP I CHRTST
TERMER, SPNOR /GOES TO TERMINATOR
TAD CHAR /SAVE TEMP.
DCA ATSW /FASTER THAN PUSHA
SORTC
GLIST-1
POPJ /FIRST CHAR IN MQ
GETC
TAD ATSW
MQL /MQ NOT USED BY SORTC AND POPJ
JMP TERMER+3
FLIST2, FLIMIT /,=STANDARD
FINFIN /;=SHORT
FLIMIT-2 /CR=DUMB
FLIST1, FINCR /,=STANDARD FORMAT
PROCESS /;=SET;PLUS,..
PC1 /C.R.=SET COMMAND
/PRIMARY CONTROL AND TRANSFER
GOTO, GETLN /READ THE LINE NUMBER REQUESTE
FINDLN /LOCATE IT AND RESET TEXTP
ERROR2 /NOT THERE
156 /GO
TAD THISLN /SET PC;DON'T MOVE ;REF. "DO"
DCA PC
PROCESS,GETC /TEST FOR END OF LINE
PROC, TSTCHR /FIRST CHARACTER READY = USE PROC
-215 /C.R.
SKP
PC1, POPJ /EXIT "PROCESS"
SORTC /IGNORE "SPACE",",", AND ";"
GLIST-1
JMP PROCESS
PUSHJ /GO TO TERMINATOR
TERMER
MQA
SORTJ /GO DO COMMAND
COMLST-1
COMGO-COMLST
ERROR2 /ILLEGAL COMMAND
202 /IC
COMMENTS=PC1 /ALSO IS CONTINUE
/OUTPUT COMMAND TEXT
WRITE, GETLN /SET LINENO
ISZ DEBGSW /DISABLE TRACE
FINDLN /SEARCG FOR LINE NUMBER
JMP WTESTG /NOT THERE OR GROUP
TAD LINENO
SZA CLA
PRNTLN /PRINT LINE NUMBER AND A SPACE
GETC
PRINTC /PRINT TEXT OF A LINE
TSTCHR
-215 /C.R.
JMP .-4
JMS I DTHIS /TEST FOR END OF TEXT
WTEST2, SNA
JMP WX-2 /EXIT;DO NEXT INDIRECT LINE
IAC
DCA PT1 /SAVE POINTER TO LINENO OF NEXT
TAD NAGSW
SMA CLA
JMS I DPT1
TSTGRP /TRY NEXT LINENO FOR GROUP
JMP WX
WALL, JMS I DPT1 /SET LINENO
DCA LINENO
JMP WRITE+2
WTESTG, TAD THISLN /INIT GROUP PRINTOUT
JMP WTEST2
DCA DEBGSW
POPJ
WX, TAD NAGSW
SPA SNA CLA /SKIP IF ALL
JMP WX-2
PRINTC /PRINT C.R. AGAIN
JMP WALL
XTESTC, 0 /TEST THE NATURE OF THE NEXT ALPHANUMERIC - "TESTC"
SPNOR /IGNORE SPACES
SORTC /TEST THE VARIABLE TERMINATORS
TERMS-1
JMP I XTESTC /YES - SORTCN IS SET
ISZ XTESTC /NO
TESTN
JMP I XTESTC /.
SKP /OTHER
JMP I XTESTC /NUMBER
TSTCHR
-"F /SKIP IF 'F'
ISZ XTESTC
ISZ XTESTC /RETURNS:T;N;F;A
JMP I XTESTC
XSORTC, 0 /SORT CHAR OR AC AGAINST TABLE - "SORIC"
SNA /AC?
TAD CHAR /NO.TAKE CHAR
DCA T2 /STORE IN TEMP
TAD I XSORTC
DCA XRT2 /1ST ARG IS LIST-1
TAD I XRT2
SPA /LIST IS ENDED BY A NEGATIVE NUMBER
JMP SEXC /2AND EXIT = NOT IN LIST
CIA
TAD T2
SZA CLA /COMPARE
JMP .-6
TAD I XSORTC /COMPUTE INCREMENT : 0 - N
CMA
TAD XRT2
DCA SORTCN
SKP /1ST EXIT = YES
SEXC, ISZ XSORTC
ISZ XSORTC
CLA
JMP I XSORTC
GRPTST, 0 /AC VS LINENO - "TSTGRP"
AND P7600
CIA
DCA T2
TAD LINENO
AND P7600
TAD T2
SNA CLA
ISZ GRPTST
JMP I GRPTST
/INPUT FROM TEXT OR KEYBOARD;
/IF BACK-ARROW, RESTART INPUT
INPUT, 0 /INPUT A CHARACTER
TAD INSUB /NON/ZERO FOR KEYBOARD
SZA CLA
JMP .+3
GETC
JMP I INPUT
READC
SORTJ
SPECIAL-1
INFIX-SPECIAL
JMP I INPUT
COMLST=. /COMMAND DECODING LIST
"S /SET
"F /FOR
"I /IF
"B /BRANCH
"D /DO
"G /GOTO
"C /COMMENT
"A /ASK
"T /TYPE
"L /LIBRARY
"E /ERASE
"W /WRITE
"M /MODIFY
"Q /QUIT
"R /RETURN
"O /OPEN
"X /EXTRA
/THIS COMMAND LIST IS SPEED OPTIMIZED;"FOR" ENDS IT
/LOOP CONTROL STATEMENT
SET=. /SUBSET OF "FOR"
FOR, PUSHJ /LOOPS, ETC.
GETARG /LOOK FOR "=" NEXT
SPNOR
TSTCHR
-"=
ERROR2 /LEFT OF "=" IN ERROR:'FOR' OR 'SET'
324 /NE
JMS SAVNAM /SAVE NAME OF VARIABLE
PUSHJ
EVAL-1 /GET INITIAL VALUE EXPRESSION
JMS GETNAM /ALL THIS FOR ZEROED VARS
NOP /EVENTUALLY FCDF V
FINT /INITIALIZE NOW
FGET I FLARGP /FLAC GETS KILLED BY GETNAM
FPUT I PT1
FXIT
SORTJ /TEST LAST CHAR FROM "EVAL"
TLIST-1
FLIST1-TLIST
ERROR2 /EXCESS R-PAR
117 /EP
FINCR, JMS SAVNAM /SAVE VARIABLE NAME
PUSHJ /EVALUATE THE INCREMENT,IF ANY
EVAL-1
SORTJ /TEST TERMINATORS
TLIST-1
FLIST2-TLIST
ERROR2 /ILLEGAL TERMINATOR IN 'FOR'
122 /FC=FOR COMMAND
FLIMIT, CDF V
PUSHF /SAVE THE INCREMENT
FLARG
PUSHJ /GET THE LIMIT(NO ERROR DETECTION AFTER LIMIT)
EVAL-1
FCONT, CDF V
PUSHF /SAVE THE LIMIT
FLARG
PUSHF /SAVE TEXT OF OBJECT STATEMENTS
TEXTP
PUSHJ /DO THE OBJECT STATEMENTS
PROCESS
POPF /RESTORE REMAINING TEXT
TEXTP
CDF V
POPF /GET LIMIT
FLARG
POPF /GET INCREMENT
ITER1
JMS GETNAM /GET VARIABLE NAME
NOP
NOP /FCDF V;IN AFTER FGET
FINT /INCREMENT AND TEST
FGET I FINKP /LOAD INCREMENT
FADD I PT1 /ADD VARIABLE
FPUT I PT1 /CHANGE IT
FSUB I FLARGP /TEST IT
FMUL I FINKP /ABSOLUTE FOR TEST
FXIT
TAD HORD
SMA SZA CLA
POPJ /END OF LOOP
JMS SAVNAM /SAVE NAME
PUSHF /SAVE INCREMENT AGAIN
FINKP, ITER1
JMP FCONT
FINFIN, PUSHF /SET INCREMENT TO ONE
FLTONE
JMP FCONT
SAVNAM, 0 /LOCAL SUB TO SAVE NAME AND SUBSCRIPT IN PDL
TAD SUBS
PUSHA
TAD EFOP
PUSHA
JMP I SAVNAM
GETNAM, 0 /IDEM FOR GETTING
POPA
DCA EFOP
POPA
PUSHJ /PASSES AC
GS1 /SETS PT1
JMP I GETNAM
SORTB, 0 /SORT AND BRANCH ROUTINE. - "SORTJ"
SNA
TAD CHAR /ASSUME CHAR IF AC=0
CIA
DCA T2 /SAVE SORT ITEM
TAD I SORTB /FIRST ARG IS LIST LESS ONE
ISZ SORTB /2AND IS INTRA-LIST LENGTH
DCA XRT2
TAD I XRT2
SPA /**LISTS ENDED BY NEGATIVE NUMBER**
JMP SEX /READ EXIT
TAD T2 /FIND ADRESS
SZA CLA
JMP .-5
TAD XRT2 /MATCH FOUND
TAD I SORTB
DCA T2
TAD I T2
DCA SORTB
JMP SEX+1
SEX, ISZ SORTB /MATCH NOT FOUND
CLA CLL
RDF
TAD .+4
DCA .+1
HLT
JMP I SORTB /RETURN TO CALLING SEQUENCE
CIF CDF 0
COMGO=. /COMMAND ROUTINE ADRESSES
SET
FOR
IF
BR
DO
GOTO
COMMENT
ASK
TYPE
LIB
ERASE
WRITE
MODIFY
START1 /RETURN TO COMMAND MODE VIA 'QUIT'
RETRN
FILER /OPEN
ERCALL
/INPUT OUTPUT STATEMENTS
ASK, CLA CMA /REMEMBER WHICH CALL
TYPE, DCA ATSW
TASK, DCA DEBGSW /RE-ENABLE THE TRACE
SORTJ /SPECIAL CHARACTER?
ALIST-1
ATLIST-ALIST
TAD ATSW /TEST QUOTE SWITCH
SMA CLA
JMP TYPE2
PUSHJ /DO ASK; SETUP PT1
GETARG
TAD CHAR /SAVE IN LINE CHARACTER
PUSHA
DCA ECHO /ONLY IF ECHO
TAD DIDO /RING-A-DING-DONG
PRINTC
ISZ ECHO
ISZ INSUB /INDICATE 'READC'
IAC /POINT PAST CHAR
JMS I FINPUT /READ DATA AND SAVE
JMP ENDASK
TYPE2, PUSHJ /DO TYPE
EVAL
TAD CHAR
PUSHA /SAVE FOR RETEST
ENDESC, JMS I FOUTPUT /PRINT
IAC
DCA ECHO
ENDASK, POPA /RETEST LAST TERMINATOR
STOCHR
JMP TASK /CONTINUE PROCESSING
ESC, DCA ECHO /ONLY IF ECHO
FINT
FGET I PT1
FEXT
JMP ENDESC /ECHO CURRENT VALUE OF LITERAL
DIDO, 240 /SPACE;WILL BE SET BY CD
TQUOT, ISZ DEBGSW /DISABLE TRACE
GETC /TYPE LITERALS
SORTJ
TLIST2-1
TLIST3-TLIST2
PRINTC
JMP TQUOT+1
TINTR, TAD SPC
DCA I LEADCH /RESET CHARS.
TAD SPCMZE
DCA I DFILL
GETC /PASS PERCENT SIGN
TESTC
JMP FILL /SHOULD BE '*'
JMP FORMAT /NUMBER;NORMAL FORMAT
STRMSP, "*-240 /FALLS THRU
TAD CHAR /OTHER;SET LEADING CHAR
DCA I LEADCH
JMP TINTR+4 /LOOP
FILL, TSTCHR
-"*
JMP FORMFL /TERM., SET FLOAT FORMAT
TAD STRMSP /SET "*"
JMP TINTR+2 /GET NEXT CHAR
SPCMZE, 240-"0
LEADCH, LEDCHR
DFILL, FILLER
FORMAT, CLA IAC /FIXED POINT
FORMFL, DCA FISW /FLOATING
GETLN
TAD LINENO
AND P7600
BSW
CLL RAR
SNA
TAD DIGITS /FLOATING
DCA FSIZE
TAD LINENO
AND P17
DCA DECP
TAD FSIZE
CIA
TAD DECP
SMA CLA
FORMER, ERROR2 /FORMAT ERROR
136 /FO
JMP TASK
TCRLF, IAC /"!":CR,LF
TFOFED, IAC /"&":FOFED
TRESET, IAC /"#": RESET PAGE COMMAND
TLFEED, TAD CLF /"'":LINE-FEED
PRINTC
TASK4, GETC /MOVE TO NEXT CHAR
JMP TASK
XTAB, PUSHJ
EVAL-1
JMS I INTEGE
SPA SNA
CLA IAC /OVER LEFT MARGIN
DCA LORD /AND ALLOW FOR 'T :,'
FORW, TAD TABC /'T :1,' IS FIRST POSITION
CMA CLL
TAD LORD
SNA
JMP TASK /NO MOVEMENT
SMA /NEGATIVE IF BACKUP
CLL CML CIA /FORWARDS; SET LINK
DCA CNTR
SZL /FOR TERMINAL WITH BS
JMP P216+1 / JMP .+2
TAD P216 / TAD M30
PRINTC / TAD SPC
JMP FORW / DCA T3
P216, 216 /M30, -30
TAD SPC / TAD T3
PRINTC
ISZ CNTR
JMP .-3
CMA
TAD LORD
DCA TABC
JMP TASK
ALIST=. /ASK/TYPE LIST OF CONTROLS
"'
"&
"#
":
"%
""
"!
"$
GLIST=.
240 /SPACE
TLIST=.
",
";
215 /C.R.
/FIND OR ENTER A VARIABLE IN THE LIST
GETARG, TESTC /FIRST LETTER OF ARG
TLIST2, 0242 /"
0215 /C.R. - FUNCTION OR NUMBER IS NOT AN ARG.
ERROR2 /BAD ARGUMENT IN 'FOR','SET',OR 'ASK'
20 /BA
GETVAR, DCA XCTIN /PACK INTO ADD.
PACKC /PACK FIRST CHAR
TAD ADD /SAVE NAME
DCA EFOP /WHERE WE CAN PUSH IT
GETLP, GETC /GET NEXT CHAR
SORTC /END OF NAME?
TERMS-1
JMP GSERCH /YES
ISZ XCTIN /IS THIS THE SECOND CHAR?
JMP GETLP /MORE THAN 2 CHARS;IGNORE
TAD CHAR /PACK SECOND CHAR
AND P77 /MASK IT
JMP GETLP-2 /ADD TO NAME
GSERCH, TSTLPR /CHECK FOR SUBSCRIPT
JMP GS1 /NONE
JMS I DECALL /PICK IT UP
POPA /RESTORE NAME
DCA EFOP
JMS I DPART /CHECK PAREN MATCH,ETC.
JMS I INTEGE /CONVERT TO 12 BIT
GS1, DCA SUBS /SAVE SUBSCRIPT
MQL /CLEAR LAST ZERO HOLD
TAD SECRTV /START SEARCH WITH SECRET
JMP GSTRT /GO IN LOOP
GS2, ISZ XRT /NAME DID NOT MATCH
GS3, ISZ XRT /SUBSCRIPT DID NOT MATCH
TAD I XRT /GETS HORD OF VAR.
SZA CLA /IS VAR. ZERO?
JMP .+3 /NO.MUST BE REAL
TAD PT1 /YES!LET'S STORE ADRESSES
MQL /AS WE GO ALONG
TAD PT1
TAD GINC /NEXT
/VARIABLES GET ADDED IN THE FOLLOWING WAY:
/IF ANY ZERO'S AVAILABLE:FROM LASTV DOWNWARDS;BUT NOT SECRET
/IF NO ZERO'S FROM LASTV UPWARDS;THEN BLOW-UP
GSTRT, DCA PT1 /FIRST OR NEXT POINTER
TAD LASTV /CHECK FOR END OF
CIA CLL /EXISTING VARS.
TAD PT1
SZL CLA
JMP MAKVAR /VAR. NOT IN LIST;CREATE NEW ONE
TAD PT1 /REPLICATE SO PT1 STAYS
DCA XRT /AT START OF VAR.
CDF V /VARIABLE FIELD
TAD I PT1 /NAME
CIA
TAD EFOP /ASKED NAME
SZA CLA /CHECK?
JMP GS2 /NO
TAD I XRT /OK.WHAT ABOUT SUBS.?
CIA
TAD SUBS
SZA CLA
JMP GS3 /ALMOST!
ISZ PT1 /FOUND IT!!
ISZ PT1 /POINT TO DATA
POPJ
MAKVAR, MQA /GET OUT LAST ZERO ADRESS
SNA /ANY ZERO'S?
JMP TOPVAR /NO.PUT IT ON TOP
CIA /CHECK FOR SECRET VARS.
TAD END /STVAR
SNL SZA CLA
JMP TOPVAR /IT WAS SECRET;ON TOP
MQA /OK.USE ZERO VAR.
DCA PT1 /RESET PT1
JMP VAREX
TOPVAR, TAD VARTOP /CHECK FOR TOP
CIA CLL
TAD LASTV
SZL CLA
ERROR2 /REALLY NO MORE SPACE!
265 /LF=LITERALS FULL
TAD LASTV /OK;UPDATE LASTV
TAD GINC
DCA LASTV
VAREX, TAD EFOP /NOW STORE IN RIGHT PLACE
DCA I PT1
ISZ PT1
TAD SUBS
DCA I PT1
ISZ PT1 /POINTING AT DATA
CDF P /CAREFUL FPNT!
NOP /FOR FCDF V
FINT
FGET I CFRSX /ZERO THE DATA
FPUT I PT1
FXIT
POPJ /EXIT
VARTOP, STARTF-10
CHRSTO, 0 /STORE A CHAR IN FLD 0 AND 1 - "STOCHR"
DCA CHAR
TAD CHAR
CDF L
DCA I XCHAR
CDF P
JMP I CHRSTO
XCHAR, CHARL
INLIST=. /INPUT CONTROL CHARACTERS
ESRETN /ALTM = TERMINATE,ECHO $
ESRETN /ESCAPE = "" ""
IBAR /^U = RESTART
IBAR /B.A. = RESTART
IGNOR /L.F. = IGNORE
IRETN /C.R. = TERMINATE STRING
ATLIST=.
TLFEED /' - LINE FEED
TFOFED /& - FORM FEED
TRESET /# - RESET PAGE
XTAB /: - TABULATOR
TINTR /% - FORMAT DELIMITER
TQUOT /" - LITERAL DELIMITER
TCRLF /! - CARRIAGE RETURN AND LINE FEED
TDUMP /DOLLAR/- DUMP THE SYMBOL TABLE CONTENTS
TASK4 /SP- TERMINATOR FOR NAMES
TASK4 /, - TERMINATOR FOR EXPRESSIONS
PROCESS /; - TERMINATOR FOR COMMANDS
PC1 /C.R.TERMINATOR FOR STRINGS
/DOLLAR/ - FOR TDUMP TERMINATES THE COMMAND
PAGE
/EVALUATE AN EXPRESSION WHICH
/TERMINATES WITH AN R-PAR, ; OR C.R. AND
/LEAVE THE RESULT IN FLAC AND IN FLARG
ECALL, 0 /RECURSIVE CALL TO "EVAL"
PUSHF /SAVE SORTCN,LASTOP,EFOP
CELSO /INCLUDES 'CIF CDF P' FOR POPJ
TAD ECALL /RETURN TO CALLING
PUSHA /ADRESS AFTER NEXT POPJ
GETC /MOVE PAST EXTRA CHAR
EVAL, DCA LASTOP /EVALUATION CONTROLLER(CHECKPOINT?)
DRONEP /FOR ETOS
TESTC /TEST CHAR AND IGNORE SPACES
JMP ETERM1 /TERMINATOR
JMP ENUM /NUMBER
JMP EFUN /FUNCTION
PUSHJ /LETTER OF VARIABLE
GETVAR /FIND OR CREATE VARIABLE;ALSO SET PT1
OPNEXT, TESTC /PT1 TO ARG
JMP ETERMN /T
NOP /N-ERROR IN FORMAT
NOP /F
JMP ETERM+1 /'EVAL'FOUND A TERMINATOR WHICH WAS NOT AN OP.
ETERM1, TAD CFRSX /SET PT1
DCA PT1 /TO POINT TO ZERO
TAD M2 /TEST FOR UNARY OPERATIONS
TAD SORTCN
SNA
JMP ETERM /CREATE DUMMY FOR UNARY MINUS
IAC
SNA CLA
JMP ARGNXT /IGNORE UNARY PLUS
TAD SORTCN /TEST FOR NULL PARENS
TAD M11
SPA CLA
JMP ELPAR /MIGHT BE AN L-PAR
ETERMN, TSTLPR
SKP
ERROR2 /OPERATOR MISSING BEFORE PAREN
336 /NO=NO OPERATOR
ETERM, TAD SORTCN /SET FROM "TESTC"-"SORTC"
DCA THISOP
TAD THISOP
TAD M11
SMA CLA /END?
DCA THISOP
ETERM2, TAD THISOP /COMPARE PRIORITIES
CIA
TAD LASTOP
SPA CLA
JMP EPAR /CONTINUE
TAD LASTOP /FIND OPERATION
CLL RTR
RTR
TAD OPTABL
DCA FLOP
TAD LASTOP
SZA CLA /TEST FOR END OF DATA INTO FLOATING AC
POPF /GET LAST DATA
FLAC
NOP /LATER FCDF V
FINT
FLOP, 00 /(FLOPR I PT1)+-*/
FPUT I FLARGP /SAVE RESULT
FXIT
TAD FLARGP
DCA PT1
TAD THISOP
TAD LASTOP /=0?
SNA CLA
JMP EVLEX /EXIT EVAL
POPA /GET PRIOR OP
DCA LASTOP
JMP ETERM2 /COMPARE THIS OP
EVLEX, TAD SORTCN
DCA I ULTSOR /SAVE LAST "SORTCN"
POPJ
EPAR, TSTLPR /TEST FOR SUB-EXPRESSION
SKP
JMP EPAR2 /GO EVALUATE EXPRESSION
TAD LASTOP /CONTINUE READING THE EXPRESSION
PUSHA /SAVE "LASTOP"
TAD PT1
DCA .+3
CDF V
PUSHF /SAVE LAST ARGUMENT
00
TAD THISOP /MORE TO COME
DCA LASTOP
ARGNXT, GETC /READ FIRST CHAR OF AN ARG.
TESTC /DO SPECIAL CHECK
JMP ELPAR
JMP ENUM /N
JMP EFUN /F
JMP OPNEXT-2 /L
OPTABL, FGET I PT1 /BASE FOR OPERATION COMPUTATION
ENUM, PUSHF /TO PROCESS ANUMBER,SAVE AC
FLAC
TAD FLARGP /SET POINTER AS FOR A VARIABLE
DCA PT1
DCA INSUB /POINT TO 'GETC' AND USE CHAR
JMS I FINPUT /READ TEXT NUMBER INTO FLARG
POPF /RESTORE THE AC
FLAC
JMP OPNEXT /CONTINUE
EFUN, DCA EFOP /SET CODE
GETC /READ FUNCTION NAME(1,2,3 LETTERS)
SORTC /LOOK FOR TERMINATION CHAR
TERMS-1
JMP EFUN2 /YES
TAD EFOP /NO
CLL RAL /MISH-MASH HASH CODE
TAD CHAR
JMP EFUN
EFUN2, TSTLPR
ERROR2 /MUST BE FOLLOWED BY PARENS TO SET ARGUMENT
25 /BF=BAD FUNCTION
JMS ECALL /CALL "EVAL" TO COMPUTE ARGUMENT
POPA /GET OUT EFOP
SORTC
FNTABL-1
JMP I STFUNC /FOUND IT
ELPAR, TSTLPR /LEFT PAREN OR FELL THROUGH FUNCTION TABLE
ERROR2 /DOUBLE OPERATORS OR ILLEGAL FUNCTION NAME
124 /FE=FUNCTION ERROR
EPAR2, JMS ECALL /EVALUATE NESTED EXPRESSION
POPA /DUMP EXTRA ARG
JMP I EFUN3I
STFUNC, FUNCST
EFUN3I, EFUN3
ULTSOR, SORTUL
TERMS=. /TERMINATOR TABLE FOR 'EVAL' AND 'GETARG'
240 /0 SPACE
"+ /1
"- /2
"/ /3
"* /4
"^ /5
"( /6
"[ /7
274 /10 (LEFT ANGLE BRACKET)
") /11
"] /12
276 /13(RIGHT ANGLE BRACKET)
", /14
"; /15
215 /16 C.R.
"= /17 TO END GETARG FROM 'SET'
FNTAPT, FNTABF-1 /POINTER TO 2-WORD FNTABF
FUNCST, TAD SORTCN /SET BY SORTC
CLL RAL /*2
TAD FNTAPT
DCA XRT2
TAD I XRT2 /GET FIELD OF FUNCTION
DCA .+3
TAD I XRT2 /GET ADRESS
DCA .+3
HLT
PUSHJ
HLT /POPJ COMES BACK .+1
EFUN3, NOP /FOR FCDF
FINT
FNOR /NORMALIZE FUNCTION RETURN
FPUT I FLARGP /SAVE FUNCTION VALUE
FXIT
TAD FLARGP /SET POINTER
DCA PT1
JMS PARTEST
JMP I .+1
OPNEXT
SORTUL, 0
P3, 3
LPRTST, 0 /SKIP IF LEFT PAREN. - 'TSTLPR'
TAD SORTCN
TAD M11
SMA CLA
JMP I LPRTST
TAD SORTCN
TAD M5
SMA SZA CLA
ISZ LPRTST
JMP I LPRTST
PARTES, 0 /TEST THE PAREN MATCHINGS
POPA /RESTORE THE LAST OPERATION
DCA LASTOP
POPA
TAD P3 /+3 TO COMPARE CODES
CIA /CHECK FOR PAREN MATCH
TAD SORTUL /(STILL SET FROM THE LAST 'EVAL')
SZA CLA /SKIP IF MATCH
ERROR2 /PAREN ERROR
317 /MP=MISSING PARENTHESIS
GETC /MOVE PAST R-PAR
JMP I PARTEST
/THE DELETE ALINE ROUTINE
XDELET, 0 /UNCHAIN A LINE AND RECOVER THE SPACE
NOP/IOF /PROTECT POINTER CHANGES FROM INTERRUPTIONS
FINDLN /SETS "THISLN" AND "LASTLN"
JMP I XDELETE /ALREADY GONE
ISZ DEBGSW /DISABLE TRACE
GETC /MEASURE LENGTH
TSTCHR
-215 /C.R.
JMP .-3
TAD AXOUT /SAVE LAST ADRESS
CMA
TAD THISLN
DCA CNTR /LENGTH .L. 0
TAD CFRS /IT IS ILLEGAL TO DELETE THE FIRST LINE
CIA
TAD THISLN
SNA CLA
JMP I START /JUST IGNORE SUCH COMMANDS
CDF T /CHANGE DATA FIELD TO TEXT
TAD I THISLN /DISCONNECT
DCA I LASTLN
TAD CFRS /START LIST AT TOP
DOK, DCA T2 /EXAMINATION ADRESS
TAD I T2
SNA /TEST FOR END
JMP DONE /YES-WRAP UP ALL
DCA T1 /SAVE NEXT ADRESS
TAD THISLN /COMPARE LINE POSITIONS
CIA CLL
TAD T1
SZL CLA /SKIP IF THISLN .G. X
TAD CNTR /CHANGE (X) TO ACCOUNT FOR
TAD T1 /GARBAGE COLLECTION
DCA I T2
TAD T1 /GET NEXT
JMP DOK
/GARBAGE COLLECTION
DONE, CMA /BACKUP L FOR XR
TAD THISLN
DCA XRT
TAD CNTR /CORRECT END OF BUFFER POINTER
TAD BUFR
DCA BUFR
TAD AXIN /COMPUTE COUNT
CMA
TAD AXOUT
DCA T1
TAD AXIN
TAD CNTR
DCA AXIN
TAD I AXOUT
DCA I XRT
ISZ T1
JMP .-3
JMP XDELETE+1 /RESET 'LASTLN','THISLN', AND DATA FIELD
RETRN, TAD C200
DCA PC
POPJ
SRNLST=. /'MODIFY' CONTROL CHARACTER TABLE
SCHAR /V.T. = CONTINUE
SCONT /BELL = CHANGE SEARCH CHAR
ESRETN /ALTM = END LINE
ESRETN /ESC = END LINE
SBAR /^U = RESTART
SBAR /B.A. = RESTART
SCONT+2 /L.F. = FINISH THE LINE AS BEFORE
LISTGO=.
IRETN /C.R. = END THE LINE HERE AS IT IS
SGOT /CHAR = SEARCH CHAR
SPECIAL=. /INPUT CHARS
225 /CNTRL. U
337 /LEFT ARROW
ECHOLS, 377 /RUBOUT
212 /LINE FEED
375 /ALT MODE
233 /ESCAPE
MGETC, GETC
POPJ
/ERASE SINGLE LINES, GROUPS, OR VARIABLES
ERASE, TESTC /TEST THE SECOND WORD IF ANY
JMP ERVX /ERASE THE VARIABLES
JMP ERL /LINES OR GROUPS
JMP .+3 /ERROR
TSTCHR /ALL TEXT
-"A
ERROR2 /BAD ARG FOR ERASE
24 /BE=BAD ERASE
ERT, TAD ENDT /ERASE ALL TEXT
DCA BUFR
CDF T
DCA I CFRS
JMP I GOK /RESTART
ERL, GETLN /ERASE LINES
TAD BUFR /PROTECT REST OF TEXT
DCA AXIN
ERG, DELETE /EXTRACT ONE LINE
ISZ THISLN
TAD NAGSW
SMA CLA
JMS I DTHIS /(TAD I THISLN)
TSTGRP /DONE ERASING GROUP?(SKIP)
JMP I GOK /YES,ERASE 'CURRENT PROGRAM SAVED' FLAG
JMS I DTHIS /(TAD I THISLN)
DCA LINENO
JMP ERG
ERVX, TAD END /ZERO VARIABLES(BUT NOT SECRET VARIABLES)
DCA LASTV /MAY BE INDIRECT COMMAND
POPJ
GOK, GOKILL
/ROUTINE CALLED VIA "FINDLN":
/SEARCH FOR A GIVEN LINE I.D. =[ "LINENO"]
/1ST RETURN IF NOT FOUND,
/2AND IF FOUND.
/"THISLN" = FOUND LINE OR NEXT LARGER
/"LASTLN" = LESSER AND/OR LAST
/"TEXTP" IS SET
XFIND, 0
TAD CFRS /INITIALIZE POINTERS TO FIRST LINE
DCA LASTLN
TAD CFRS
FINDN, DCA THISLN /SAVE THIS ONE
TAD THISLN
DCA XRT
TAD LINENO
CLL CMA IAC /CLEAR LINK AND NEGATE LINENO
JMS I DXRT /LINENO=0 WILL BE FOUND (X-MEM)
SNA
JMP FEND3-1 /FOUND IT
SZL CLA
JMP FEND3 /PASSED IT
TAD THISLN /MOVE POINTERS
DCA LASTLN
JMS I DTHIS /END OF TEXT ? (X-MEM)
SZA
JMP FINDN /NOT YET
SKP
ISZ XFIND /2ND EXIT = FOUND
FEND3, TAD THISLN /1ST RETURN = NOT FOUND
IAC
DCA AXOUT /SET "TEXTP"
DCA XCT
JMP I XFIND
UTRA, 0 /UNPACK CHARACTER. - "GETC"
JMS GET1
UTE, SPA CLA /NORM & EXTEND
TAD GEND /300-337 & 340-376
TAD M137 /240-276 & 200-236
TAD CHAR
SNA
JMP UTX /"?" FOUND
TAD P337
UTQ, STOCHR
TAD DEBGSW
TAD DMPSW
SNA CLA /PRINT ONLY IF BOTH ARE ZERO
PRINTC
JMP I UTRA
EXTR, JMS GET1
CMA
JMP UTE
UTX, TAD DEBGSW /TEST FOR TRACE-ENABLED
M40, SMA SZA CLA /DEBGSW NEVER NEGATIVE
JMP .+6
TAD DMPSW /FLIP THE TRACE FLOP
SNA CLA
IAC
DCA DMPSW
JMP UTRA+1 /GET NEXT CHARACTER INSTEAD
TAD P277 /TRACE DISABLED = RETURN "?"
JMP UTQ
GET1, 0 /UNPACK 6 BITS
ISZ XCT /STARTS=0
JMP GET3
TAD GTEM
GEND, AND P77
SNA
TAD P40 /CONVERT TO SPACE
DCA CHAR /SAVE
TAD CHAR
TAD M77
SNA CLA
JMP EXTR /EXTENDED
TAD CHAR
TAD M40
JMP I GET1
GET3, CDF T
TAD I AXOUT
CDF P
DCA GTEM
CMA
DCA XCT
TAD GTEM
BSW
JMP GEND
M137, -137
/IF DEBGSW=0 : ENABLE FLIP-FLOP "DMPSW"
/ #0:DISABLE AND RETURN ALL"?" 'S
/IF DMPSW = 0: TRACE ON, IF ENABLED
/ #0: TRACE OFF
/IF BOTH = 0 : PRINT TRACE
PGETLN, GETLN
POPJ
TLIST3=.
TASK4 /" (LITERAL TERMINATORS)
PC1 /C.R.=AUTOMATIC QUOTE MATCH
INFIX=. /DATA CONTROL CHARACTERS
FLINTP+2 /CNTRL. U = KILL
FLINTP+2 /LEFT ARROW=KILL
INPUT+1 /RUBOUT=IGNORE
INPUT+1 /L.F.=IGNORE
ESC /ALT MODE=EXIT
ESC /ESC=ALT
FLTONE, 0001 /(NO RELATIVE REFERENCES)
2000
0000
0000
M12, -12
XSPNOR, 0 /IGNORE LEADING SPACES - "SPNOR"
TSTCHR
-240 /SPACE
JMP I XSPNOR
GETC
JMP XSPNOR+1
XTESTN, 0 /RETURNS: .; OTHER; NUMBER - "TESTN"
TAD CHAR
TAD MPER
SZA
ISZ XTESTN
TAD M2
DCA SORTCN /SAVE VALUE OF NUMBER
TAD SORTCN /TEST IF REALLY A DIGIT
SPA CLA
JMP I XTESTN
TAD SORTCN
TAD M11
SPA SNA CLA
ISZ XTESTN /IF A NUMBER
JMP I XTESTN
XPRNT, 0 /PRINT A LINENUMBER -"PRNTLN"
DCA COMBO+3 /IF AC='SKP' :PACK ALSO
TAD LINENO
AND P7600
BSW
RAR
JMS PRNT /TWO DIGIT PART NUMBER
TAD PER
JMS COMBO
TAD LINENO
JMS PRNT /TWO DIGIT STEP NUMBER
TAD SPC
JMS COMBO /PRINT AND SOMETIMES PACK
DCA COMBO+3 /RESET TO PRINT ONLY
JMP I XPRNT
PRNT, 0 /PRINT TWO DECIMAL DIGITS
AND P177
DCA T1
TAD C260
DCA T3
JMP .+3
ISZ T3
XYZ, DCA T1
TAD T1
TAD M12
SMA
JMP XYZ-1
CLA
TAD T3
JMS COMBO
TAD T1
TAD C260
JMS COMBO
JMP I PRNT
COMBO, 0 /COMBINED PRINT PACK
STOCHR
PRINTC
0
JMP I COMBO
PACKC
JMP I COMBO
/SYMBOL TABLE TYPEOUT ROUTINE
TDUMP, TAD END /INIT POINTER FOR DUMP (DON'T DUMP SECRET VARIABLES)
DCA PT1
TAD LASTV /TEST FOR END OF LIST
CIA
TAD PT1
SNA CLA
POPJ
CDF V
TAD I PT1 /GET VARIABLE
CDF T
DCA I OP+1
CDF P
TAD OP /SETUP UNPACK POINTERS
DCA AXOUT
DCA XCT
GETC /READ AND PRINT "XX("
PRINTC
GETC
PRINTC
GETC
PRINTC
ISZ PT1
CDF V
TAD I PT1 /PRINT SUBSCRIPT TO 99
CDF P
JMS PRNT
GETC /PRINT ")"
PRINTC
ISZ PT1
NOP /FCDF V
FINT /PICK UP VALUE
FGET I PT1
FXIT
JMS I FOUTPUT /PRINT VALUE
TAD CCR
PRINTC
TAD GINC
TAD M2
TAD PT1
JMP TDUMP+1
OP, PC0+3
PC0+4
LGOSUB, PUSHJ /EXECUTE THE SUBROUTINE
DO+1
TAD LIST7+1 /'ESCAPE' THE GOSUB
STOCHR
LIB, CIF CDF L /I.E. TO "PROC" FOR REST OF LINE
JMP I LIBLOW
LIBRET, TAD JMPGOS /RETURN TO APPROPRIATE ROUTINE
DCA .+1
HLT
PROCLB, PROC
START1
LGOSUB
GOTO+1
WRITE+1 /ONLY USED BY CD FOR /W OPTION
LIBLOW, LOWLIB
JMPGOS, JMP I PROCLB
ECHOGO, INEX
INEX
INALT
INALT
ILIST, IF1 /,
PROCESS /;
PC1 /CR
/SEARCH ROUTINES
MODIFY, TAD LINENO
DCA ATSW /KEEP IF GETLN GIVES 0
GETLN /READ LINE NO.
TAD LINENO
SNA
TAD ATSW /USE LAST IF 0
DCA LINENO
FINDLN /LOOK IT UP NOW
ERROR2 /NOT THERE = BAD COMMAND UNLESS ZERO
34 /BM=BAD MODIFY
TAD BUFR /SET POINTERS
DCA AXIN /FOR INPUT
DCA XCTIN
TAD BUFR
DCA PACKST
TAD MODSKP /SET PRNTLN FOR PACKING
PRNTLN
SCONT, CIF CDF L
JMS I INDEV /READ THE TELETYPE SILENTLY
DCA DMPSW /SAVE SEARCH CHAR.
ISZ DEBGSW /NO BREAKS
SCHAR, GETC /TYPE+TEST-F.F.
PRINTC /PLAYBACK THE TEXT
SORTJ /LOOK FOR MATCH
LIST3-1
LISTGO-LIST3
PACKC /SAVE NEW LINE
JMP SCHAR
SBAR, CLL CML CLA IAC RAL /RESTART-B.A.
TAD BUFR
DCA AXIN /SET POINTERS
DCA XCTIN
SFOUND, READC /READ FROM KEYBOARD
SORTJ /TEST
LIST6-1
SRNLST-LIST6
SGOT, PACKC /PACK CHAR.
JMP SFOUND /MORE
BRSW,
OUT, 0 /OUTPUT A CHARACTER-"PRINTC"
SNA /USE AC OR CHAR
TAD CHAR
TAD M216 /CNTRL N MEANS RETURN ONLY
SNA
DCA TABC /XOUTL WILL HANDLE CR ONLY
IAC /CHECK FOR CR
SNA
JMP NEWLIN /TYPE CR,LF
TAD CRMSPC
SMA
ISZ TABC /IT PRINTS, INCREMENT COUNT
IFNOP, NOP
TAD SPC
OUTCLF, CIF L
JMS I OUTDEV
JMP I OUT
NEWLIN, DCA TABC
TAD CCR /CR
CIF L
JMS I OUTDEV
TAD CLF /LF
JMP OUTCLF
M216, -216
CRMSPC, 215-240
*2701 /SO 'IF3' IS JUST PAST PAGE BOUNDARY
/CONDITIONAL TRANSFER PROCESS
SPNA, SPA SNA CLA
P76MSP, 7600-7750 /7750=SPA SNA CLA
P2004, 2004
IFSPA, SPA
BR, CLA CMA /THIS SETS BRANCH COMMAND
IF, DCA BRSW
TESTC /FIRST CHAR. MUST BE TERMINATOR
JMP IFOK /OK!
FRSTIF, 0
SCNDIF, 0
JMP IFER
IFOK, TAD IFSPA
DCA IF2 /RESET IF2
JMS I DECALL /EVALUATE FIRST EXPRESSION
TSTCHR
-", /TEST IF TERMINATED BY ','
JMP COMPIF /NO: COMPUTED IF
GETC /GOBBLE COMMA
SORTC
IFLIST-1 /GET FIRST REL. OP.
MODSKP, SKP
IFER, ERROR2 /NO SUCH!
204 /IE=IF ERROR
TAD SORTCN
DCA FRSTIF /KEEP FIRST REL. OP.
DCA SORTCN
GETC /NEXT REL. OP. IF ANY
SORTC
IFLIST-1
GETC /FOUND ONE;MOVE TO NEXT CHAR
TAD SORTCN
DCA SCNDIF /KEEP;IF NONE = 0
CLA CLL IAC RAL /2=OP. '-'
DCA THISOP
PUSHJ
EPAR /EVALUATE SECOND ARGUMENT
TAD FRSTIF
CIA
TAD SCNDIF
SNA CLA
JMP IFER /SOME COMBINATION LIKE:'=='
TAD IFNOP
DCA IF2 /SET FOR TWO EXITS
TAD FRSTIF /NOW COMPUTE INSTRUCTION
TAD SCNDIF
CLL RAR /.GT. IN LINK
SZL
CMA /COMPL. IF .GT.
SZL
TAD P2004 /SET REVERSE SENSE
BSW
CLL RAR
TAD P76MSP
COMPIF, TAD SPNA
DCA IF3-1
POPA /DUMP EFOP
JMS I DPART /CHECK PARENS.
TAD M2
DCA T1
TAD HORD /TEST COMP.IF. -,0,+
IF2, SPA
ISZ T1
SPA SNA CLA /OR SOME OTHER INSTR.
IF3, ISZ T1 /COUNT COMMAS
SKP
JMP IFBRCO /TRANSFER TO GO AND BRANCH
SORTJ /SEARCH TEXT UNTIL ,;C.R.
TLIST-1
ILIST-TLIST
GETC
JMP .-4
IF1, GETC /MOVE PAST COMMA
JMP IF3
IFBRCO, GETLN /GET LINE FIRST
JMS I IFENCO /GO TO END OF COMMAND
ISZ I IBRSW
JMP I IFGO
JMP I IFBR
IFGO, GOTO+1
IFBR, DO+1
IFENCO, ENDCOM
IBRSW, BRSW
/CHARACTER REMOVAL ROUTINE
*3024
RUB1, TAD AXIN /RUBOUT ONE LETTER
CIA
TAD PACKST /PROTECTION
SPA CLA
TAD AXIN /IF TOO LOW PUT 0 IN T2
DCA T2
CDF T
ISZ XCTIN /TEST HALF
JMP RUB2
TAD I T2 /ADD IS FULL
AND P77 /IF PROTECTION
TAD M77 /THIS NEVER GIVES ZERO
M140, SZA CLA /BECAUSE LOC.0 FLD T IS ZERO
JMP RUB4
RUB3, CMA /IT IS EXTEND CODE
DCA XCTIN /SET SWITCH
CMA
TAD AXIN
DCA AXIN
TAD I T2 /RESET ADD
AND P7700
RUB4, DCA ADD
CDF P
DCA ECHO /ONLY IF ECHO
TAD SPLAT /FOR RUBOUT ACKNOWLEDGEMENT
PRINTC
ISZ ECHO
JMP I PACBUF
RUB2, TAD T2
SNA CLA
JMP PACX /PROTECTED!
TAD I T2 /CHECK FOR EXTEND
AND P7700
TAD M140-2
SZA CLA
JMP RUB3
DCA I T2 /SAVE CORRECTION
JMP RUB3+1
SPLAT, 334
PACBUF, 0 /PACK A CHAR. -"PACKC"
TAD P277
CIA
TAD CHAR
SNA /CHANGE 277 TO 377
TAD P40
TAD P7700
SNA /TEST FOR RUBOUT
JMP RUB1
TAD P377
DCA T2 /SAVE INPUT ITEM
TAD T2 /SO THAT QUESTION DOESN'T MAKE
P377, AND C140 /CHAR LOOK LIKE A LEFT ARROW
TAD M140
SZA /DATA WORD
TAD C140
SNA CLA
JMP ESCA /200-237 & 340-377
PA1, TAD T2 /240-337
AND P77
SZA /IGNORE 300
JMS PCK1
PACX, CDF P
JMP I PACBUF
ESCA, TAD P77
JMS PCK1
JMP PA1
ROT, BSW
DCA ADD
CMA
DCA XCTIN
JMP I PCK1
P7700, 7700
PCK1, 0
ISZ XCTIN /=0 TO START
JMP ROT
TAD ADD
JMS I DAXIN
DCA ADD /CLEAR PACKING WORD
JMP I PCK1
AXIND, 0 /AXIN SUB. NOW CHECKS FOR OVERFLOW
CDF T
DCA I AXIN
TAD I PAXPNT /PDLXR
CLL CIA
TAD AXIN
TAD C200 /ONE PAGE DISTANCE FOR PDL
CDF P /PROGRAMS MAX. 15 BLOCKS LONG
SNL CLA
JMP I AXIND
ERROR2 /TEXT OVERFLOW
365 /PF=PROGRAM FULL
FIN, READC /SINGLE CHAR. INPUT FUNCTION
TAD CHAR /FLOAT CHAR.
DCA HORD
DCA LORD
DCA OVER2
TAD P13
DCA EXP
POPJ
FOUT, JMS I INTEGE /SINGLE CHAR OUTPUT FUNCTION
SNA
TAD C200 /IN CASE IT'S ZERO
PRINTC
POPJ
XINT, JMS I INTEGE
CLA CLL
POPJ
C140, 140 /DON'T MOVE!!
PAGE
/INPUT-OUTPUT ROUTINES FOR THE
/FOCAL FLOATING POINT PACKAGE
/IN THE COMMENTS BELOW:-
/F=NUMBER OF DIGITS TO BE OUTPUT =FISW ---F---
/D=NUMBER OF DECIMAL PLACES =DECP ABC.DEF E GHI
/E=DECIMAL EXPONENT =BEXP -D- -E-
/P=NUMBER OF PLACES REMAINING TO BE
/PRINTED BEFORE DECIMAL POINT
PLCE=SGNPRN
TGO, 0
TAD DIGITS
CMA
DCA SCOUNT /SAVE MAX. NUMBER OF DIGITS AVAILABLE - SET COUNT
TAD FSIZE
CIA
DCA FCOUNT /-F
TAD FISW /(JMP FPRNT) - FOR NO ROUNDING
SNA CLA /FLOATING OUTPUT ?
JMP R6 /YES, F SIGNIFICANT PLACES
TAD FCOUNT
TAD DECP /D-F
TAD T3 /COMPARE DEC. EXPONENT D-F+E
SMA /F-D .G. E ?
R6, CLA /NO, ROUND OF TO .F PLACES
TAD FSIZE /YES
SPA /D+E.L.0 ?
JMP FPRNT-2 /YES, NO ROUNDING NEEDED, GO TO PRINT
CMA /NO, ROUND TO D+E PLACES
TAD DIGITS /-(D+E)-1+DIGITS
SPA /TO A MAX OF D PLACES
CLA CMA /*ROUND UP*
CIA
TAD DIGITS
DCA T2 /SAVE NUMBER+1 OF PLACES TO ROUND TO
TAD FLTXR
TAD T2 /SET UP BUFFER ADDRESS AT WHICH
DCA PLCE /ROUNDING OFF SHOULD START
TAD T2
CIA /SETUP COUNT OF MAX NO
DCA T2 /OF CARRIES ALLOWABLE
TAD K6 /LITTLE EXTRA ON FIRST DIGIT
RET, TAD I PLCE
TAD OM12
SPA CLA /CARRY REQUIRED ?
JMP FPRNT /NO, GO TO OUTPUT
DCA I PLCE /YES, MAKE CURRENT DIGIT ZERO
ISZ T2 /BEGIN OF BUF REACHED ?
JMP DECR /NO, DECREMENT BUF ADDR. AND REPEAT
ISZ I PLCE /YES, SET MANTISSA TO .1
ISZ T3 /COMPENSATE BY INCREMENTING EXP
CLA CLL
FPRNT, TAD T3
DCA OUTEXP /KEEP T3 FOR LATER
TAD FISW /AUTO-INDEX REG ALREADY SET - *PRINT*
SNA CLA /F=0 ?
JMP FLOUT /YES, OUTPUT AS FLOAT NUMBER
TAD FCOUNT
TAD T3
SMA SZA /E .G. F ?
JMP FLOUT /YES, CONVERT TO E FORMAT
TAD DECP /-F-E+D
SMA /E.L.F-D ?
CLA /NO, P=E
CIA /YES, TAKE P=F-D
TAD T3
CIA
DCA T1 /SETUP -P
BACK1, TAD OUTEXP /PRINT DD.DDD
TAD T1
SZA CLA /B=E ?
JMP NODIG /NO
CMA /YES, PRINT DIGIT
TAD OUTEXP /REDUCE E BY ONE
DCA OUTEXP
ISZ SCOUNT
K6, 6
TAD SCOUNT
SPA CLA /ALL SIGNIFICANT FIGURES?
TAD I FLTXR /NO, OUTPUT NUMBER
RIN, DCA OUTEM /YES-OUTPUT ZERO IN TEMP.
TAD OUTSGN
SNA /SIGN OUT ALLREADY?
JMP .+3 /YES - FORGET IT
JMS I OPUT /NO - PRINT - OR FILL
DCA OUTSGN /SIGNAL SIGN OUT
TAD OUTEM /OUTPUT NUMBER
FILOUT, JMS I OPUT /OR FILLER
ISZ T1 /P CHARS. PRINTED?
JMP .+3
TAD PER /YES, PRINT PERIOD
PRINTC /EVEN IF FIELD IS FULL
ISZ FCOUNT /F CHARS. PRINTED?
JMP BACK1 /NO, BACK TO LOOP
JMP I TGO /YES, CHECK IF FLOAT
DECR, CMA /BACKUP TO TOP OF BUF
TAD PLCE
DCA PLCE
ISZ I PLCE /ADD ONE TO DIGIT AT CURRENT POSITION
JMP RET
OM12, -12
OPUT, OUTDG
FILLER, 240-"0 /SPACE OR *
LEDCHR, 240 /SPACE OR $,F,M,ETC.
OUTSGN, 240-"0 /GETS "- - "0 OR 'FILLER'
OUTEXP, 0
OUTEM, 0
SCOUNT, 0
FCOUNT, 0
NODIG, TAD T1
IAC
SMA CLA /P .G. 1?
JMP RIN /NO, PRINT ZERO
TAD FILLER /YES, TYPE FILLER
JMP FILOUT
FLOUT, ISZ TGO /TELL FLOUTP ABOUT FLOAT
CLA IAC
DCA OUTEXP /SET EXP=1
CLA CMA /FAKE F-D=1
JMP BACK1-1
SGNPRN, 0 /TYPES LEADER AND SETS SIGN
TAD LEDCHR
TAD MBSLSH
SNA CLA /BACKSLASH IS NOT PRINTED
JMP .+3
TAD LEDCHR
PRINTC
TAD HORD
SPA CLA /CHECK SIGN
CLL CMA RTL /="- - "0
SNA
TAD FILLER /IF POSITIVE
DCA OUTSGN /WILL GET OUT LATER
JMP I SGNPRN
MBSLSH, -"\
IFLIST, 300
276 /.GT.
275 /.EQ.
300
274 /.LT.
ERCALL, ERROR2 /NO ITEM IN LIST
320 /NA=NOT AVAILABLE
MMINSK, JMS I MINSKI
POPJ
FORLEX, CIF CDF L
JMP I .+1
LEXIT
XDRONE, 0
CIF L
JMS I .+2
JMP I XDRONE
INTRPT /"INTERRUPT" FOR ETOS
NOP /SECRET VARIABLES SHIFTED BY ONE
/SECRET VARIABLES
STSECR=.
4400
0000
0013
DOLL, 0001
0000
0000
4300
NMBSGN=.+2
ZBLOCK 5
4100
EXCLA=.+2
ZBLOCK 5 /INTRPT VARIABLES
4200
QUOTS=.+2
ZBLOCK 5
2011 /SECRET PI
0000
0002
3110
3755
2421
2605 /VERSION NUMBER
0000
0001
2000
0000
0000
STVAR=.
ZBLOCK OVRLAY-.
EJECT FOS8 FCARIT AND FPP
/HEADER FOR FCARIT.SV
*5000
OVRLAY=.
ARIT, HLT
TAD STARIT
DCA I DVAR /UP TO THE PROGRAMMER TO ORGANIZE
CIF CDF L /HIS VARIABLES
JMP I .+1
CHENTR /BACK TO FOS8
STARIT, ARIT-10
DVAR, VARTOP
/EXPONENTIAL
GETSGN=TAD HORD
*5020
STARTF=.
FEXP, GETSGN /TAKE ABSOLUTE VALUE
SPA CLA
JMS I NEGP
DCA T3 /C(SIGN)=-1 IF I X2.L.0
FINT
FMUL LG2E
FPUT I X2
FEXT
JMS I INTEGER
DCA FLAG2 /SAVE LOX ORDER DATA
FINT
FNOR
FPUT I XSQ2
FGET I X2
FSUB I XSQ2
FPUT I X2
FMUL I X2
FPUT I XSQ2
FADD DF
FPUT TEMP
FGET CF
FDIV TEMP
FSUB I X2
FADD AF
FPUT TEMP
FGET BF
FMUL I XSQ2
FADD TEMP
FPUT TEMP
FGET I X2
FDIV TEMP
FMUL TWO
FADD ONE
FEXT
TAD FLAG2
TAD EXP
DCA EXP
ISZ T3
POPJ
FINT
FPUT I X2
FGET ONE
FDIV I X2
FEXT
POPJ
/CONSTANTS FOR FEXP
X2, X
XSQ2, XSQR
AF, 0004
2372
1402
BF, 7774
2157
5157
CF, 0012
5454
0343
DF, 0007
2566
5341
LG2E, 0001
2705
2435
ONE, 0001
2000
0000
TWO, 0002
2000
0000
NEGP, FNEG
FLAG2, 0
TEMP, 0
0
0
0
/MAIN ALGORITHM FOR ARCTANGENT
ARCALG, FINT
FGET I X2
FMUL I X2
FPUT I XSQ2
FMUL BET2
FADD BET1
FMUL I XSQ2
FADD BETZ
FPUT TEMP
FGET ALF2
FMUL I XSQ2
FADD ALF1
FMUL I XSQ2
FADD ALFZ
FMUL I X2
FDIV TEMP
FEXT
JMP I .+1
ARCRTN
/CONSTANTS - FLOATING ARC TANGENT
ALFZ, 0000
2437
1643
ALF1, 7777
3304
4434
ALF2, 7773
3306
5454
BETZ, 0000
2437
1646
BET1, 0000
2427
2323
BET2, 7775
3427
7052
PAGE
/FLOATING POINT ARC TANGENT
ARTN, GETSGN /TAKE ABSOLUTE VALUE
SPA CLA
JMS FNEG
DCA T3
FINT
FPUT X
FSUB I CON1
FEXT
GETSGN
SPA CLA
JMP GO /LESS THAN ONE
FINT
FGET I CON1
FDIV X
FPUT X
FEXT
CLA CMA
GO, DCA FLAG1 /SIGN FLAG OF RESULT
JMP I .+1
ARCALG
ARCRTN, ISZ FLAG1 /RETURN HERE
JMP I EXIT1
FINT
FPUT X
FGET I PI2
FSUB X
FEXT
JMP I .+1
EXIT1, EXIT2
/CONSTANTS FOR ARCTANGENT
PI2, PIOT
CON1, ONE
/FLOATING LOGARITHM
FLOG, GETSGN
SPA SNA
ERROR2 /0 OR - ARGUMENT FOR LOG
274 /LM=LOG MINUS
FINT
FPUT I TEM
FSUB I CON1
FEXT
GETSGN
SNA
POPJ
SMA CLA
JMP STARTL
FINT
FGET I CON1
FDIV I TEM
FPUT I TEM
FEXT
CLA CMA
STARTL, DCA T3
TAD P13
DCA EXP
CMA
TAD I TEM
DCA HORD
DCA LORD
DCA OVER2
IAC
DCA I TEM
FINT
FMUL LOG2
FPUT X
FGET I TEM
FSUB I CON1
FPUT I TEM
FMUL LOG8
FADD LOG7
FMUL I TEM
FADD LOG6
FMUL I TEM
FADD LOG5
FMUL I TEM
FADD L4
FMUL I TEM
FADD L3
FMUL I TEM
FADD L2
FMUL I TEM
FADD L1
FMUL I TEM
FADD X
FEXT
JMP I EXIT1
L1, 0000
3777
7742
L2, 7777
4000
4100
L3, 7777
2517
0307
L4, 7776
4113
7211
/LOGARITHM CONSTANTS
LOG5, 7776
2535
3301
LOG6, 7775
4746
0771
LOG7, 7774
2236
4304
LOG8, 7771
4544
1735
TEM, TEMP
LOG2, 0
2613
4414
FLAG1, 0
FNEG, 0
JMS I MINSKI
CLA CMA
JMP I FNEG
X, 0
0
0
0
XSQR, 0
0
0
0
PAGE
/FLOATING POINT SINE AND COSINE
FCOS, FINT /COS(X)=SIN(PI/2-X)
FPUT I X1
FGET PIOT
FSUB I X1
FEXT
FSIN, GETSGN
SMA SZA CLA
JMP MOD
GETSGN
SMA CLA
POPJ /YES SIN(0)=0
JMS I MINSKI
CMA /NO:SIN(-X)=-SIN(X)
MOD, DCA T3
FINT
FDIV TWOPI /REDUCE X MODULO 2 PI
FPUT I XSQR1
FEXT
JMS I INTEGER
FINT
FNOR
FPUT I X1
FGET I XSQR1
FSUB I X1
FMUL TWOPI
FPUT I X1
FSUB PI /X .L. PI?
FEXT
GETSGN
SPA CLA
JMP PCHECK /YES
FINT /NO, SIN(X-PI)=-SIN(X)
FPUT I X1
FEXT
TAD T3
CMA
DCA T3
PCHECK, FINT /X.L.PI/2?
FGET I X1
FSUB PIOT
FEXT
GETSGN
SPA CLA
JMP PALG /YES
FINT /NO
FGET PI /SIN(X)=SIN(PI-X)
FSUB I X1
FPUT I X1
FEXT
PALG, FINT
FGET I X1
FDIV PIOT
FPUT I X1
FMUL I X1
FPUT I XSQR1
FGET C9
FMUL I XSQR1
FADD C7
FMUL I XSQR1
FADD C5
FMUL I XSQR1
FADD C3
FMUL I XSQR1
FADD PIOT
FMUL I X1
FEXT
EXIT2, ISZ T3
POPJ
JMS I MINSKI
POPJ
/CONSTANTS AND POINTERS
TWOPI, 0003
3110
3755 /3756 3-WORD
2421
PI, 0002
3110
3755 /3756 3-W0RD
2421
PIOT, 0001 /USED BY SINE AND COSINE
3110
3755 /3756 3-W0RD
2421
X1, X
XSQR1, XSQR
/SINE CONSTANTS
C9, 7764
2441
7015
1042
C7, 7771
5464
5514
6150
C5, 7775
2431
5361
4736
C3, 0000
5325
0414
3167
FRAN, FENT /PSEUDO RANDOM NUMBER
FGET RNDM /X(1)=(2^17+3)*X(0) MOD.2^16
FPUT ADDR
FEXT
TAD M16
DCA T1S
JMS I DOUBLE
ISZ T1S
JMP .-2
JMS I ADDO
JMS I DOUBLE
JMS I ADDO /2*(2^16*X+X)+X
FINT
FPUT RNDM
FEXT
DCA EXP
CLA CLL CMA RAR /=3777
AND HORD
DCA HORD /BE SURE IT'S POSITIVE
POPJ
M16, -16
ADDO, DUBLAD
RNDM=.
T1S, 0000
4421
3040
0001
PAGE
/FLOATING SQUARE ROOT FUNCTION
XSQRT, FINT
FPUT I TITER /VALUE
FEXT /NEWTON'S METHOD IS USED
GETSGN
SPA CLA
ERROR2 /NUMBER IS NEGATIVE = IMAGINARY ROOTS
214 /IM=IMAGINARY
TAD EXP /LINK =0 FROM FINT
SPA /MATCH THE SIGN WITH LINK BIT
CML
RAR
DCA SQAC /MAKE FIRST APPROXIMATION
SZL /TEST LSB OF EXP
ISZ SQAC
NOP
TAD SQCON1
DCA SQAC+1
DCA SQAC+2
DCA SQAC+3
TAD HORD
SNA
TAD LORD
SNA CLA
JMP SQEND /NUMBER = 0
CLCU, FINT
FGET I TITER
FDIV SQAC
FADD SQAC
FEXT
CLA CMA
TAD EXP
DCA EXP
TAD EXP
CMA IAC
TAD SQAC
SZA CLA /ARE EXPONENTS EQUAL?
JMP ROOTGO /NO
TAD HORD /ARE HIGH ORDER MANTISSAS EQUAL?
CMA IAC
TAD SQAC+1
SZA CLA
JMP ROOTGO /NO
TAD LORD
CMA IAC
TAD SQAC+2 /DO LOW ORDER MANTISSAS AGREE?
SMA
CMA IAC /WITHIN ONE BIT?
IAC
SMA CLA
POPJ
ROOTGO, FINT
FPUT SQAC
FEXT
JMP CLCU
SQEND, DCA EXP
POPJ
SQCON1, 3015
TITER, ITER1
SQAC, 0
0
0
0
*XSQRT+100
FNTABL=.
2533 /ABS
2650 /SGN
2636 /ITR
2630 /RAN
2572 /ATN
2624 /EXP
2625 /LOG
2654 /SIN /LIST OF CODED FUNCTION NAMES
2575 /COS
2702 /SQT
1140 /IN
2672 /OUT
2604 /(F)IND
0324 /T
0325 /U
0326 /V
0327 /W
0330 /X
0331 /Y
0332 /Z
-1 /ENDS TABLE
*XSQRT+126
FNTABF=.
CDF L
XABS /ABS -ABSOLUTE VALUE
CDF L
XSGN /SGN -REAL SIGN FUNCTION
CDF P
XINT /ITR -INTEGER PART
CDF P
FRAN /RAN -RANDOM NUMBER
CDF P
ARTN /ATN -
CDF P
FEXP /EXP -EXPO FUNCTIONS
CDF P
FLOG /LOG -
CDF P
FSIN /SIN -TRIG FUNCTIONS
CDF P
FCOS /COS -
CDF P
XSQRT /SQT -SQUARE ROOT
CDF P
FIN /INP -CHAR INPUT
CDF P
FOUT /OUT -CHAR OUTPUT
CDF P
FIND /IND -FIND A CHAR
CDF P
ERCALL /T
CDF P
ERCALL /U
CDF P
ERCALL /V
CDF P
ERCALL /W
CDF L
XCOM /(F)X:ARRAY
CDF P
ERCALL /Y
CDF P
ERCALL /Z
/END OF ARIT OVERLAY
PAGE
/FLOATING OUTPUT CONVERSION ROUTINE
ERROL+3 /FLD. 0 ERROR ROUTINE ADRESS
ERROR, 0 /MUST BE AT THIS ADRESS!!USR.VOLATILE!!
CLA CMA CLL
TAD I ERROR /PASS ON CODE-1
CIF CDF L
JMP I ERROR-1
ENDERR, DCA EOL /FORCE CR
ISZ PC /END OF ERROR ROUTINE;USES SUBS. IN THIS FIELD
JMS I DPC
SNA
JMP I START
DCA LINENO
TAD SPC
PRINTC
PRNTLN
JMP I START
FLOUTP, 0
JMS I PRNSGN /GO PRINT LEADER,SET SIGN
JMS I ABSOL2
FGO2, DCA T3 /INITIALIZE DEZ EXP
TAD EXP /IS EXP 0-4 ?
SPA
JMP FGO3 /TOO SMALL: MULT BY 10
SZA
TAD M4
SPA SNA CLA
JMP FGO4
FINT
FMUL I PPTEN / /10
FEXT
IAC
TAD T3
JMP FGO2
FGO3, FINT
FMUL I TENPT /*10
FEXT
CMA
JMP .-6
FGO4, DCA I DPT /MULTIPLY BY TWO TO POSITION BIT0
DCA I REPT /CLEAR OVERFLOW WORD
TAD SADR /INIT BUFFER POINTER
DCA FLTXR
TAD EXP /COMPUTE BITS IN 1ST DIGIT
CMA CLL
DCA OUTDG /TEMP COUNT
TAD DIGITS /SETUP COUNT OF TOTAL OUTPUT
CMA
DCA EXP
JMS I DOUBLE /ROTATE OUT THE 1ST 4 BITS
ISZ OUTDG
JMP .-2
TAD I REPT /TEST FOR 10-15,0,1-9
SNA
JMP FGO5 /IGNORE 1ST ZERO
TAD FM12
SPA CLA
JMP .+7 /0-9
IAC
DCA I FLTXR /OUTPUT A 1
ISZ EXP /COUNT THE DIGIT
TAD FM12 /CORRECT REMAINDER
ISZ T3 /BUMP DECIMAL EXP
NOP
TAD I REPT /COMPUTE RESULTANT OR SECOND DIGIT
ISZ T3
NOP
SKP
FGO5, JMS I M10PT /IE. .672X10=6+.72.. ETC.
DCA I FLTXR
ISZ EXP /ALL DIGITS OUTPUT??
JMP .-3 /NO:CONTINUE
TAD SADR
DCA FLTXR /RESET BUFFER POINTER
JMS I ROUND /OUTPUT MANTISSA
JMP I FLOUTP /FIXED POINT DONE
TAD CHRT /PRINT "E"
PRINTC
/OUTPUT THE EXPONENT
TAD I (BUFFER
SZA CLA /IF #=0 KEEP EXP=0
CLA CMA
TAD T3 /TAKE ABSOLUTE VALUE OF EXPONENT
CLL
SPA
CIA CML
DCA HORD /SAVE + POWER
CMA RTL /PRINT SIGN
TAD PER /.-3=+ ; .-1=-
PRINTC
TAD HORD
ISZ EXP
TAD M144
SMA
JMP .-3
TAD C144
DCA HORD /SAVE TENS AND UNITS
CMA /OUTPUT HUNDREDS
TAD EXP
SZA
JMS OUTDG
TAD HORD /PRINT TWO DIGITS
JMS I PRNTI
JMP I FLOUTP
PRNSGN, SGNPRN
PRNTI, PRNT
CHRT, 305 /E
M144, -144 /-100
C144, 0144 /+100
M4, -4
FM12, -12
PPTEN, PTEN /IEI
DPT, DIGIT
REPT, REMAIN /OVERFLOW FROM INTEGER MULTIPLY
M10PT, MULT10
SADR, BUFFER-1
ROUND, TGO /ACTUAL OUTPUT ROUTINE
TENPT, TEN
ABSOL2, ABSOLV
OUTDG, 0
TAD C260
PRINTC
JMP I OUTDG
RESOLV, 0
TAD SIGNF
SPA CLA
JMS I MINSKI
CLA CLL
JMP I RESOLV
PAGE
/FLOATING POINT INPUT
FLINTP, 0 /IF C(AC)=0, USE CHAR
SZA CLA /IF C(AC)#0, GET NEXT
JMS I DINPUT /GET FIRST CHAR
TSTCHR
7540 /-SPACE
SKP
JMP .-4
JMS I DPCVPT /READ FIRST DIGIT GROUP
TSTCHR /ENDED BY PERIOD?
-".
JMP FIGO1
JMS I DINPUT /YES, READ SECOND GROUP
DCA I DPN
JMS I DCONP
TAD I DPN /SAVE NUMBER OF DIGITS IN T3
CMA IAC
FIGO1, DCA T3 /NO
TAD P43
DCA EXP
JMS I RESOL5
JMS I INORM /NORMALIZE FIRST ,THEN
FINT /SAVE NUMBER
FPUT I PT1
FEXT
TSTCHR /"E" READ IN?
-"E
JMP ENDFI+3 /NO
JMS I DINPUT /YES, READ 3RD DIGIT GROUP
JMS I DPCVPT /I.E. CONVERT DECIMAL EXPONENT
JMS I RESOL5
TAD OVER2
TAD T3 /C(SEXP) PLACES TO RIGHT OF LAST DIGIT
DCA T3
/COMPENSATE FOR DECIMAL EXPONENTS
ENDFI, FINT /RESTORE MANTISSA
FGET I PT1
FEXT
TAD T3 /TEST DECIMAL EXPONENT
SNA
JMP I FLINTP /FINISHED
SMA CLA
JMP FIGO4
FINT /. IS TO THE LEFT:
FMUL PTEN /TIMES .1000
FPUT I PT1
FEXT
IAC
JMP .+6
FIGO4, FINT /. IS TO THE RIGHT:
FMUL TEN /TIMES TEN
FPUT I PT1
FEXT
CMA
TAD T3
DCA T3
JMP ENDFI+3
TEN, 0004
2400
0000
0000
PTEN, 7775
3146
3146 /3147 3-WORD
3150
DPCVPT, DECONV
DCONP, DECON
RESOL5, RESOLV
DPN, DNUMBR
DINPUT, INPUT
INORM, DNORM
P43, 43
ABSOLV, 0
TAD HORD
DCA SIGNF
TAD HORD
SPA CLA
JMS I MINSKI
JMP I ABSOLV
MINUS2, 0 /NEGATE OPERAND
CLA CLL /TRIPLE PRECISION
TAD OVER1
CMA IAC
DCA OVER1
TAD AC1L
CMA
SZL
IAC CLL
DCA AC1L
TAD AC1H
CMA
SZL
IAC CLL
DCA AC1H
JMP I MINUS2
XRTD, 0
CDF T
TAD I XRT
CDF P
JMP I XRTD
PCD, 0
CDF T
TAD I PC
CDF P
JMP I PCD
THISD, 0
CDF T
TAD I THISLN
CDF P
JMP I THISD
PT1D, 0
CDF T
TAD I PT1
CDF P
JMP I PT1D
XPUSHJ, 0
MQL
FLD1
CIF T
JMS I .+1
ZPUSHJ
FILER, CIF CDF L
JMP I .+1
FILEST
ENDCOM, 0 /GO TO END OF COMMAND
SORTC
TLIST /; CR.
JMP I ENDCOM
GETC
JMP .-4
PAGE
/DOUBLE PRECISION DEZIMAL BINARY
/INPUT AND CONVERSION FOR + OR - XXX....
DECONV, 0
DCA LORD
DCA EXP /ZERO THE EXP AND
DCA HORD /INITIALIZE FLAC
DCA OVER2
DCA DNUMBR
DCA SIGNF
TAD CHAR /ALLOW KEYBOARD SIGN CHECKS
TAD MPLUS
SNA
JMP .+6 /PLUS SIGN; GET NEXT
TAD M2 /CHECK MINUS SIGN
SZA CLA
JMP .+4
CMA /INIT SIGN CHECK TO POS.
DCA SIGNF
JMS I XINPUT /GET NEXT
TAD CHAR /A SPACE PERHAPS ?
TAD MSPACE
SNA CLA
JMP .-4
JMS DECON
JMP I DECONV
DECON, 0
TAD CHAR /TEST LEAD. CHAR FOR TERMINATOR
TAD MINE
SNA CLA
JMP I DECON /E
TESTN
JMP I DECON /.
JMP DTST /OTHER
TAD SORTCN /N
DSAVE, DCA DIGIT /YES
JMS MULT10 /REMAIN MUST =0 SINCE OVERFL. IS CHECKED
ISZ DNUMBR /COUNT DIGITS
SZA CLA
ERROR2 /INPUT OVERFL ERROR
316 /MO=MANTISSA OVERFLOW
JMS I XINPUT
JMP DECON+1 /CONTINUE
DTST, TAD CHAR /ALLOW A-Z
TAD MINUSA
SPA CLA
JMP I DECON
TAD CHAR
TAD MINUSZ
SZA SMA CLA
JMP I DECON /USE 6 BITS OF ASCII
TAD CHAR
AND P77
JMP DSAVE
MINE, -305
MINUSZ, -332
MPLUS, -253
MSPACE, -240
MINUSA, -"A
XINPUT, INPUT
MULT10, 0 /ROUTINE TO MULTIPLY FLAC BY 10
TAD OVER2
DCA OVER1
TAD LORD /DOUBLE PRECISION WORD
DCA AC1L /BY 10(DEZ)
TAD HORD /REMAIN=REMAINDER
DCA AC1H
DCA REMAIN /CLEAR OVERFLOW WORD
JMS MULT2 /CALL SR TO
JMS MULT2 /MULT BY 2
JMS DUBLAD /CALL DOUBLE ADD
JMS MULT2
TAD DIGIT /ADD LAST DIGIT RECEIVED
DCA OVER1
DCA AC1L
DCA AC1H
JMS DUBLAD
TAD REMAIN /EXIT WITH REMAINDER
JMP I MULT10 /IN AC
REMAIN, 0
DIGIT, 0 /STORAGE FOR DIGIT
DNUMBR, 0 /= NUMBER OF DIGITS
MULT2, 0 /MULTIPLY OVER2, LORD, HORD BY TWO
TAD OVER2
CLL RAL /CARRY INSERT BIT IS IN LINK
DCA OVER2
TAD LORD
RAL
DCA LORD
TAD HORD
RAL
DCA HORD
TAD REMAIN
RAL
DCA REMAIN
JMP I MULT2
DUBLAD, 0 /TRIPLE PRECISION ADDITION
CLA CLL
TAD OVER2
TAD OVER1
DCA OVER2
RAL
TAD LORD
TAD AC1L
DCA LORD
RAL
TAD HORD
TAD AC1H
DCA HORD
RAL
TAD REMAIN
DCA REMAIN
JMP I DUBLAD
DIV1, 0 /SHIFT OPERAND RIGHT
CLA CLL /TRIPLE PRECISION
TAD AC1H
SPA
CLL CML
RAR
DCA AC1H
TAD AC1L
RAR
DCA AC1L
TAD OVER1
RAR
DCA OVER1
ISZ EX1
JMP I DIV1
JMP I DIV1
PAGE
/FLOATING POINT INTERPRETER FOR FOCAL
FPNT, 0
7600 /CLA;REFERENCED
CLL
NOP /DCA OVER1
NOP /DCA OVER2 3-WORD
TAD I FPNT /GET NEXT INSTRUCTION
SNA
JMP I FPNT /FAST EXIT
DCA JUMP
TAD JUMP
AND C200 /GET PAGE BIT
SNA CLA /PAGE ZERO?
JMP .+3 /YES
TAD FPNT+1 /NO
AND FPNT /C(FPNT) 0-4 CONTAINS PAGE BITS
DCA ADDR
TAD P177 /GET 7 BIT ADRESS
AND JUMP
TAD ADDR
DCA ADDR
TAD INDRCT /INDIRECT BIT =1?
AND JUMP
SNA CLA
JMP LOOP01 /NO- GO ON
TAD I ADDR /YES, DEFER W/O AUTO-INDEX
DCA ADDR
LOOP01, ISZ FPNT
CMA
TAD ADDR
DCA FLTXR2
TAD JUMP /GET COMMAND
CLL RTL
RTL
AND P17 /GET BITS 0-2,I.E. OPCODE
SNA
JMP FLGT
TAD TABLE /LOOK UP THE TABLE
DCA JUMP
TAD I JUMP
SNA
JMP FLPT
DCA JUMP
TAD CEX1 /SAVE FLOATING ARGUMENT,UNLESS 'GET' OR 'PUT'
DCA FLTXR
TAD MFLT
DCA CNTR
TAD I FLTXR2
DCA I FLTXR
ISZ CNTR
JMP .-3
JMP I JUMP /GO THERE
JUMP, 0
ADDR=EX1
INDRCT, 0400
TABLE, ITABLE
FLPT, TAD CEXP /EXP TO (ADDR)
JMP .+5
FLGT, TAD CEXP /(ADDR) TO EXP
DCA FLTXR2
CMA
TAD ADDR
DCA FLTXR /SAVE 'FROM' ADRESS
TAD MFLT /3 OR 4 WORDS
DCA CNTR
TAD I FLTXR
DCA I FLTXR2
ISZ CNTR
JMP .-3
JMP FPNT+1
CEXP, EXP-1
CEX1, EX1-1
FLSU, JMS I OPMINS /FSUB = 2, NEGATE THE OPERAND
FLAD, JMS I ALGN /FLAD = 1, FIRST ALIGN EXPONENTS
JMP FPNT+1 /RETURN IF NO ALIGMENT IS POSSIBLE
JMS I RAR2 /TRIPLE PRECISION ADDITION
JMS I RAR1 /SINCE BITS ARE SHIFTED
JMS I TRAD /RIGHT
NORF, JMS I NORM /NORMALIZE THE RESULT
JMP FPNT+1 /HINT: USE 700X FOR FUNCTIONS
/INTERPRETIVE POWER
FLEX, TAD HORD /ZERO?
SZA CLA
JMP .+6
ZERO, DCA EXP /YES
DCA HORD
DCA LORD
DCA OVER2
JMP FPNT+1
PUSHF /AC TO A + POWER
FLAC
PUSHF /SETUP ARGUMENT (THE EXPONENT)
EX1
POPF
FLAC
JMS I INTEGER /ONLY POSITIVE, INTEGER EXPONENTS
SPA
JMP .+5 /(COULD DIVIDE)
CMA
DCA JUMP /TEMP STORAGE
NOP /DCA OVER1 3-WORD
TAD HORD
SZA CLA
ERROR2 /TOO LARGE OR NEGATIVE EXPONENT
116 /EO=EXPONENT OVERFLOW
PUSHF /INITIALIZE TO ONE
FLTONE
POPF
FLAC
POPF
ITER1
JMP .+6
PUSHF
ITER1
POPF
EX1
JMS I MULT /"MULT"
ISZ JUMP
JMP .-6
JMP FPNT+1
FLMY, JMS I MULT /MULTIPLY
JMP FPNT+1
OPMINS, MINUS2
MULT, DMULT
NORM, DNORM
ALGN, ALIGN
RAR1, DIV1
RAR2, DIV2
TRAD, DUBLAD
PAGE
ACMINS, 0 /ROUTINE TO COMPLEMENT FLAC - VIA "MINSKI"
CLL CLA
TAD OVER2 /TRIPLE PRECISION NEGATION
CMA IAC /OF FLOATING AC
DCA OVER2
TAD LORD
CMA
SZL
IAC CLL
DCA LORD
TAD HORD
CMA
SZL
IAC CLL
DCA HORD
JMP I ACMINS
ALIGN, 0 /SUBROUTINE TO ALIGN
TAD HORD /BINARY POINTS
SNA
TAD LORD
SNA CLA /IS MANTISSA ZERO?
JMP NOX1 /YES, RESULT=OPERAND
TAD AC1H /NO, IS OPERAND ZERO?
SNA
TAD AC1L
SNA
TAD OVER1
SNA CLA
JMP I ALIGN /YES, EXIT
TAD EX1
CMA IAC
TAD EXP
SNA /ARE EXPONENTS EQUAL?
JMP ADONE
DCA ACMINS
TAD ACMINS
SMA /NO
CIA /NEGATE AND
DCA AMOUNT /SAVE THE DIFFERENCE
TAD AMOUNT
TAD TEST2
SPA CLA /CAN THE EXPONENTS BE ALIGNED?
JMP NOX /NO, USE LARGER OF THE TWO
TAD ACMINS /YES, SHIFT THE SMALLER
SMA CLA
JMP ASHFT
JMS DIV2
ISZ AMOUNT
JMP .-2
JMP ADONE
ASHFT, CMA
TAD EX1
DCA EX1
JMS I TAG1
ISZ AMOUNT
JMP .-2
ADONE, ISZ ALIGN
JMP I ALIGN
NOX, TAD EX1 /MISSION IMPOSSIBLE!
SMA CLA /CHECK FOR SIGN DIFFERENCE
JMP NOX2
TAD EXP
SMA CLA
JMP I ALIGN /-+
JMP .+3 /--
NOX2, TAD EXP
SMA CLA
TAD ACMINS /TEMP STORAGE OF DIFFERENCE,
SMA SZA CLA /-BOTH POSITIVE EXP OR BOTH NEG
JMP I ALIGN /OK (+-)
NOX1, TAD EX1 /USE LARGER
DCA EXP
TAD AC1H
DCA HORD
TAD AC1L
DCA LORD
TAD OVER1
DCA OVER2
JMP I ALIGN
AMOUNT, 0
TAG1, DIV1
P27, 27
ABSOL, ABSOLV
RESOL, RESOLV
/LEAVE 12 BIT ANSWER IN AC UPON RETURN
/LEAVE FLAC AS AN INTEGER
FIX, 0 /VIA (INTEGER)
JMS I ABSOL
TAD EXP /TEST FOR FRACTION
SPA SNA CLA
JMP FIXM /DOUBLE CHECK FOR MINUS ONE
IAC
DCA OVER1
TAD P27 /INIT ALIGNEMENT
DCA EX1
JMS ALIGN /DO THE ALIGNEMENT TO AN INTEGER
TEST2, 0043 /ALREADY DONE; (27) FOR 3-WORD
DCA OVER2 /CLEAR THE FRACTION
JMS I RESOL
TAD LORD /EXIT WITH LOW ORDER RESULT IN AC
JMP I FIX
FIXM, DCA EXP /CLEAR EXPONENT
DCA HORD
DCA LORD
JMP TEST2+1
DIV2, 0 /SHIFT FLAC RIGHT
CLA CLL
TAD HORD
SPA
CML
RAR
DCA HORD
TAD LORD
RAR
DCA LORD
TAD OVER2
RAR
DCA OVER2
ISZ EXP
JMP I DIV2
JMP I DIV2
FLTZER, ZBLOCK 4
FLARG, ZBLOCK 4
PAGE
/(A+B+C)*(D+E+F)=C*F,C*E,B*F,C*D,A*F,B*E,A*E,B*D,A*D
DMULT, 0 /N-PRECISION MULTIPLY WITH
IAC /PRODUCT IN TRIPLE PRECISION
TAD EX1 /ADD EXPONENTS + 1
JMS SIGN /AND DETERMINE SIGN OF RESULT
SPA CLA
JMS I MINI
DCA DATUM-1 /INIT RESULT
DCA DATUM-2
DCA DATUM-3
DCA DATUM-4
TAD A /A*D
SAVE /STORE IN MP2
TAD D /SINGLE PREC MULT
MULTY
2 /ACCUM START IN #2 DATA WORD
TAD E /A*E
MULTY
3
TAD B /B*D
SAVE
TAD D
MULTY
3
TAD E /B*E
MULTY
4
DCA DATUM-5 /JMP DMDONE 3-WORD
DCA DATUM-6
TAD F /A*F
SAVE
TAD A
MULTY
4
TAD B /B*F
MULTY
5
TAD C /C*D
SAVE
TAD D
MULTY
4
TAD E /C*E
MULTY
5
TAD F /C*F
MULTY
6
DMDONE, TAD DATUM-1 /COPY RESULT
DCA HORD
TAD DATUM-2
DCA LORD
TAD DATUM-3
DCA OVER2
JMS MULDIV
NOP /DCA OVER2 3-WORD
JMP I DMULT
DATUM=.+6 /INTERMEDIATE STORAGE
/#6-LOW ORDER
/#5
/#4
/#3
/#2
/#1-HIGH ORDER
*DATUM-1
MULDIV, 0 /TERMINATE MULTIPLY AND DIVIDE
ISZ SIGNF /CORRECT FOR SIGN
JMS I MINSKI
JMS I NORMF /SHIFT LEFT
NOP /ISZ OVER2 3-WORD
JMP I MULDIV
FLDV, TAD AC1H /4:DIVIDE
SNA CLA
ERROR2 /DIVISION BY ZERO
70 /DI=DIV
TAD EX1 /SUBTRACT EXPONENTS+1
CMA IAC
IAC
JMS SIGN /SET UP SIGNS
SMA CLA
JMS I MINI /NEGATE DIVISOR
JMS I DIVIDE /DIVIDE
JMS MULDIV
JMP I .+1
FPNT+1
/THIS SUBROUTINE PREPARES MULTIPLY AND DIVIDE
/FOR ANY COMBINATION OF SIGNED ARGUMENTS AND FOR ZERO
/THE RESULT OF EITHER IS ZERO IF FLAC = 0
/RESULT OF MULTIPLY IS ZERO IF EITHER IS ZERO;
/DIVISION BY ZERO IS CHECKED BERFORE THIS
/ROUTINE IS CALLED
/THE CALLING AC CONTAINS AN UPDATE VALUE FOR THE
/EXPONENT, THE RETURNING AC CONTAINS THE SIGN OF
/THE ARGUMENT FOR FURTHER TESTING BY EACH ROUTINE.
SIGN, 0 /TEST AND SAVE SIGN OF RESULT
TAD EXP /COMPUTE NEW EXP FOR MUL-DIV.
DCA EXP
CLL CML RAR /LOAD 4000 TO XOR THE SIGN BITS
AND HORD
TAD AC1H
SMA CLA /RESULT MAY BE ZERO
CMA
DCA SIGNF /+=-1;-=0
TAD HORD
SNA
JMP I REVIT /ANSWER IS ZERO
SPA CLA /TAKE ABSOLUTE VALUE OF FLAC
JMS I MINSKI
TAD AC1H
SNA /RESULT OF EITHER MAY BE ZERO
JMP I REVIT
JMP I SIGN
MINI, MINUS2
REVIT, ZERO
NORMF, DNORM
DIVIDE, DUBDIV
SAVE=DCA I .
MP2
MULTY=JMS I .
MP4
A=HORD
B=LORD
C=OVER2
D=AC1H
E=AC1L
F=OVER1
ITABLE=.-1
FLAD
FLSU
FLDV
FLMY
FLEX
0000
NORF
XINTEG, 0
JMS I INTEGE
CIF CDF L
JMP I XINTEG
BUFFER=.
ITER1, ZBLOCK 13
PAGE
MP4, 0 /SINGLE PREC,UNSIGNED "MULTY"
SNA
JMP I MP4 /NO RESULT ADDED
DCA MP1
DCA MP5
TAD THIR
DCA MP3
CLL
MP6, TAD MP1
RAR
DCA MP1
TAD MP5
SNL
JMP .+3
CLL
TAD MP2
RAR
DCA MP5 /SAVE HI ORDER
ISZ MP3
JMP MP6
TAD MP1 /CORRECT LO ORDER
RAR
DCA MP3
TAD I MP4 /PICKUP SCALE FACT.
CIA
TAD DATUMA
DCA MP1
TAD MP3 /LO ORDER
CLL
TAD I MP1 /ACCUMULATE
DCA I MP1
ISZ MP1
RAL
TAD MP5
TAD I MP1
DCA I MP1
SNL
JMP I MP4 /NO CARRY
ISZ MP1
ISZ I MP1
JMP I MP4
JMP .-3 /CARRY AGAIN
DATUMA, DATUM
MP5, 0 /PRODUCT
MP1, 0 /MULTIPLIER
MP3, 0
MP2, 0 /MULTIPLICAND
THIR, -14 /12 BITS
MIF, -43 /-27 3-WORD
DUBDIV, 0 /2 OR 3 PRECISION DIVIDE
DCA MP4
DCA MP1
TAD MIF /INIT BIT COUNTER
DCA MP3
SKP
DV3, JMS I DOUBLE /SHIFT FLAC LEFT
CLL
TAD OVER1 /----FROM HERE 4-WORD
TAD OVER2
DCA MP5
RAL
TAD AC1L /COMBINE ONE POSITION AND
TAD LORD
DCA MP2 /SAVE RESULT
RAL
TAD HORD /ADD OVERFLOW
TAD AC1H
SNL /SKIP IF OVERFLOW
JMP .+6
DCA HORD /UPDATE FLAC
TAD MP5
DCA OVER2
TAD MP2
DCA LORD
CLA /CLEAR ACCUMULATOR
TAD MP1 /SAVE OVERFLOW BITS CIRCULARLY
RAL
DCA MP1
TAD MP4
RAL
DCA MP4
TAD DNORM
RAL /EXTRA FOR 4-WORD
DCA DNORM
ISZ MP3 /TEST FOR END OF DIVIDE
JMP DV3
TAD DNORM
DCA HORD
TAD MP4
DCA LORD
TAD MP1
DCA OVER2
JMP I DUBDIV
DNORM, 0 /SUB TO NORMALIZE
JMS I ABSOL3
JMS TEST4
TAD HORD
SNA /IS MANT.=0?
TAD OVER2
SNA
TAD LORD
SNA CLA
JMP EXIT3
TAD HORD
RAL CLL
SPA CLA /WILL SHIFT TOO FAR?
JMP .+6
JMS I DOUBLE
CMA CLL
TAD EXP
DCA EXP
JMP .-10
JMS I RESOL3
JMS TEST4 /DON'T LEAVE 4000
JMP I DNORM
EXIT3, DCA EXP
JMP I DNORM
TEST4, 0 /TEST FOR 4000
TAD HORD
SPA
CIA
SPA CLA
JMS I XRAR2 /SHIFT BACK
JMP I TEST4
XRAR2, DIV2
ABSOL3, ABSOLV
RESOL3, RESOLV
PAGE
PAUSE