File: DPF40.PA of Tape: OS8/OS8-Latest/new-5
(Source file text)
/ DATAPLAN FOCAL V40.1
/
/
/
/
/
/
/
/
/
/COPYRIGHT (C) 1979,1980 BY DATAPLAN GMBH, LAUDA, BRD
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DATAPLAN GMBH.
/DATAPLAN GMBH ASSUMES NO RESPONSIBILITY FOR ANY ERRORS THAT MAY APPEAR
/IN THIS DOCUMENT.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DATAPLAN'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DATAPLAN.
/
/DATAPLAN GMBH ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
/OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DATAPLAN.
/
/
/
/
/
/
/
/
/
/
/
/
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
EJECT DPF INTERPRETER
XLIST
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
SPLAT, "\ /OR 210=BS FOR SCOPE
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, PDLEND-1 /START OF PDL
/FOCAL'S COMMAND/INPUT DRIVER
*177
START, NEW /PROGRAM START FROM SELF (INDIRECT)(OR TO FORLEX)
NEW, 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, 233 /WILL BE CHANGED TO '$' (PERHAPS)
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
INCONV, 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.:CHANGE,ESC.:PRINT
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, ISZ ECHO /FOR 'FIND' POPJ
TAD INDOL
JMP INCONV /CONVERT TO ESC
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.
MQL /FASTER THAN PUSHA
SORTC
GLIST-1
POPJ /FIRST CHAR IN MQ
GETC
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, DRONEP
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
AND P337 /ALLOW LOWER CASE
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 OR 'DCA LINENO' *KEY*
ISZ DEBGSW /DISABLE TRACE
FINDLN /SEARCG FOR LINE NUMBER
JMP WTESTG /NOT THERE OR GROUP OR '0' *KEY*
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 OR '0' *KEY*
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
INPUAC, 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 /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
/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, 207 /BELL;CAN 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 /TERM.,SHOULD BE '*'
JMP FORMAT /NUMBER;NORMAL FORMAT
STRMSP, "*-240 /FALLS THRU
TSTCHR /OTHER;SET NO LEADER
-"\ /IF %\XXXX
JMP FORMAT /VARIABLE FORMAT
TAD C200
JMP TINTR+1 /DELETE LEADER
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
SCEND /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
334 /BACK-SLASH
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 /BACK-SLASH=KILL
INPUAC /RUBOUT=TERMINATOR
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
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
INEX-1
ILIST, IF1 /,
PROCESS /;
PC1 /CR
/SEARCH ROUTINES
MODIFY, TAD LINENO
DCA ATSW /KEEP IF GETLN GIVES 0
GETLN /READ LINE NO.
TAD LINENO
SNA /OR 'SNA CLA' *KEY*
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, CLA STL RTL /=2 DISABLE ECHO FOR MULTI8
CIF CDF L
JMS I INDEV /READ THE TELETYPE SILENTLY
SCEND, 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, STL 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
/CONDITIONAL TRANSFER PROCESS
SPNA= SPA SNA CLA
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 (SPA
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 (NOP
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 (2004 /SET REVERSE SENSE
BSW
CLL RAR
TAD (7600-SPNA
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 (ENDCOM /GO TO END OF COMMAND
ISZ BRSW
JMP I (GOTO+1
JMP I (DO+1
BRSW,
SCOPSU, 0 /FOR SCOPE RUBOUTS
TAD P40 /BS ALREADY OUT
PRINTC /SPACE
TAD SPLAT /BS
PRINTC
ISZ ECHO
JMP I SCOPSU
PAGE
OUT, 0 /OUTPUT A CHARACTER-"PRINTC"
SNA /USE AC OR CHAR
TAD CHAR
AND P177
SNA
JMP I OUT /IGNORE NULLS
TAD M15 /CHECK FOR CR
SNA
JMP NEWLIN /TYPE CR,LF
TAD CCR /ADD 200 BIT
OUTCLF, CIF CDF L
JMS I OUTDEV
JMP I OUT
NEWLIN, TAD CCR /CR
CIF CDF L
JMS I OUTDEV
TAD CLF /LF
JMP OUTCLF
M15, -15
OUTDEV, LOWOUT
/CHARACTER REMOVAL ROUTINE
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
DELSCP, JMS I PSCOPS /OR 'ISZ ECHO' IF NO SCOPE RUBOUTS
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
PSCOPS, SCOPSU /SUB TO PRINT SPACE,BACKSPACE
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 SPC /PROGRAM UP TO 7300
CDF P /PROGRAMS MAX. 15 BLOCKS LONG
SNL CLA /7300 GIVES SPACE FOR APPEN AND PDL
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 DEFEAT /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
DEFEAT, ISZ T3 /COMPENSATE BY INCREMENTING EXP
LEDCHR, 240 /SPACE OR $,F,M,ETC.
CLA CLL
FPRNT, TAD DECP
DCA PLCE /FOR INT/FLT CHECK
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 FILOUT-1/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 NOPER
TAD PLCE /IS IT INTEGER FORMAT?
SNA CLA
JMP NOPER /YES: NO PERIOD
TAD PER /YES, PRINT PERIOD
PRINTC /EVEN IF FIELD IS FULL
NOPER, 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 *
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 PLCE /NO INT WHEN FORMAT OVERFLOW
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
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
ERCALL, ERROR2 /NO ITEM IN LIST
320 /NA=NOT AVAILABLE
PAGE
IFLIST, 300
276 /.GT.
275 /.EQ.
300
274 /.LT.
MMINSK, JMS I MINSKI
POPJ
FORLEX, CIF CDF L
JMP I .+1
LEXIT
XDRONE, 0
CIF L
JMS I .+2
JMP I XDRONE
XIDLE
RELESE, SZA CLA /PRINT LINE ONLY IF RUNNING
PRNTLN
TAD P13 /=11 FOR MULTI8 RELEASE
6770 /GIANT IOT
CLA /YOU NEVER KNOW!
JMP I START /AND BACK TO KB OR OS/8
/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 40.1
0000
0006
2403
1463
1464
STVAR=.
ZBLOCK OVRLAY-.
XLIST
EJECT DPF FCARIT AND FPP
XLIST
/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 /IN VERSION 2 AT 15700
FNTABL=.
2533 /ABS
2650 /SGN
2632 /OS8
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
/ FUNCTIONS T,U,V,W,Y,Z NOT ASSIGNED (FREE FOR USER)
/ FOR CODING NAME, USE OCTAL CHARS WITH 200 BIT SET
/ AND CALCULATE THE FOLLOWING EXPRESSION:
/
/ X=CHAR1
/ IF CHAR2 THEN: X=X*2+CHAR2
/ IF CHAR3 THEN: X=X*2+CHAR3
/ THEN REPLACE A FREE SLOT BY THIS VALUE
*XSQRT+126 /IN VERSION 2 AT 15726
FNTABF=.
CDF L
XABS /ABS -ABSOLUTE VALUE
CDF L
XSGN /SGN -REAL SIGN FUNCTION
CDF L
XOS8 /OS8 -OS8=1,MULTI8=0 FUNCTION
CDF P
XINT /ITR -INTEGER PART
CDF P
FRAN /RAN -RANDOM NUMBER * NOT
CDF P
ARTN /ATN - * LOADED
CDF P
FEXP /EXP -EXPO FUNCTIONS * WITH
CDF P
FLOG /LOG - * NO
CDF P
FSIN /SIN -TRIG FUNCTIONS * FUNCTIONS
CDF P
FCOS /COS - * OPTION
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
/ THIS TABLE IS 2 TIMES LONGER THAN 'FNTABL'
/ INSERT THE FIELD AND ADRESS OF YOUR FUNCTION
/ IN THE APPROPRIATE FREE SLOT (CORRESPONDING
/ TO THE ONE SELECTED IN 'FNTABL'). BE SURE TO
/ LOAD A 'DPF0' SECTION IN THE FIELD YOU ARE
/ USING. SEE 'DPF0' FOR MORE INFO.
/END OF ARIT OVERLAY
PAGE
/FIELD 1 ERROR 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
TAD SPC
PRINTC
ISZ PC /END OF ERROR ROUTINE;USES SUBS. IN THIS FIELD
JMS I DPC
DCA LINENO
TAD LINENO
JMP I .+1
RELESE /RELEASE MULTI-8 DEVICES
/FLOATING OUTPUT CONVERSION ROUTINE
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, JMS I INTEGE
MQL /PRESERVE AC OVER POPJ
POPJ
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
XLIST
EJECT IO-UTILITY-INIT
XLIST
/****** STORAGE ALLOCATION MAP ******
/***** *****
/* 200 START,OCLOSE,NOCHAR,OSETUP
/* 400 OOPEN,ICHAR,FILEST,EXITOS
/* 600 IOPEN,POP,NAMEVL,XABS,XSGN,XOS8
/* 1000 NAME,GTMON,DISMISS
/* 1200 HANDAD,COMPARE,LOADER,IOWAIT
/* 1400 SAVPR,ENDLOD,OROI
/* 1600 LOWLIB,LOADS,GOSUB,RETOUR,FILSEC
/* 2000 OPEN,BUMP,XIN,EXIT,MORE
/* 2200 XCOM,CORITE,CCLOSE
/* 2400 COHNDL,ARRAY,LOWOUT,COCLR
/* 2600 XIDLE,XOUT,ERROL
/* 3000 ERROL,LOWIN,TERMNL
COMBUF=3200
OUTBUF=5200 /ALSO INIT ##SEE BELOW##
INBUFF=5600
/* 6200 OUTPUT HANDLER
/* 6600 INPUT HANDLER
/* 7200 LIBRARY AND COMMON HANDLER
/***** *****
/************************************
/***** COMMAND DECODER INIT *****
/*
/* 3200 KEYER,APPEN
/* 3600 MONTHS
/* 36XX DEVICES
/* 4200 CDTBL
/* 4400 USRTBL
/* 4600 SETUP 1
/* 5000 SETUP 2
/* 5200 SETUP 3
/* 5400 SETUP 4
/* 5600 SETUP SUBS
/* 6000 POPS PAGE
/* 6200 HEADER PAGE
/* ---- REST OVERLAYS-PATCHES
/* 7200 ALWAYS RESERVED
/***** *****
/************************************
FIELD 0
*1
CIF 30 /INTERRUPT? SERVICE ROUTINE
JMP 1 /FOR SYMBIONT
PAUS, -1
LINLEN, -110
PAGLEN, -110
CHRCNT, 0
LINCNT, 0
/AUTO-INDEX REGISTERS
AUTO1, 0 /GENERAL
AUTO2, 0 /COMPARE
AUTO3, 0 /COMPARE
INFLG, 0 /FILE INPUT:1,TTY:0,EOF:-1
INECH, 0 /INPUT ECHO:0,NO ECHO:-1
OUTFLG, 0 /FILE OUTPUT:1,TTY:0
OUTECH, 0 /OUTPUT ECHO:0,NO ECHO:-1
ERRCOD, 0
XCNTR, 0 /GENERAL COUNTER-
USR, 7700 /POINTER TO MONITOR (200 IF USR IN)
NAMLOC, ZBLOCK 3 /USED BY NAME
EXTENS, 0 /"FC", "FD", OR "FN"
NEWDEV, ZBLOCK 2 /USED BY NAME
TEM7, 0
ATEM, 0 /KEEP HERE : TPOPF NEWDEV
/DEFINE LOWER FIELD INSTRUCTIONS . . .
DRONE=JMS I .
XIDLE
TSORTJ=JMS I .
SORTB
TINTEG=JMS I .
MINTEG
ERROR1=JMS I .
ERROL
TPOPA=JMS I .
MPOPA
TPUSHA=JMS I .
MPUSHA
TPUSHF=JMS I .
MPUSHF
TPOPF=JMS I .
MPOPF
TPUSHJ=JMS I .
MPUSHJ
TPOPJ=JMP I .
MPOPJ
ECHFLG, 0 /-1:NO ECHO
OPNFLG, 0 /OOPEN:-1;OCLOSE:0
IPNFLG, 0 /IOPEN:-1;EOF:0
OUTINH, 0 /NOT LAST BLK:0,LAST BLK:1
DEVHLD, 0 /OOPEN:DEV. NO. FOR CLOSE
FILEN, 0 /SPECIFIED FILE LENGTH []
FLNGTH, 0 /SET BY OPEN
STBLK, 0 /SET BY OPEN
DEVNO, 0 /SET BY HANDAD
LIBFIL, 0 /START BLK OF SAVED PROG;UNSAVED:0
LIBBLK, 0 /FOR DEVICE NAME
0
7200 /LOAD POINT
0 /FOR DEVICE #
LIBHND, 0 /HANDLER ENTRY
INBLK, 0
0
6600
0
INHND, 0
OUTBLK, 0
0
6200
0
OUTHND, 0
DERR, ERROR1 /DEVICE ERROR
64 /DE=DEV.ERR.
CHARL, 0
DCHAR, CHAR
CLNGTH, 0 /SET BY COMMON
COMFLG, 0 /1:WRITE;0:READ
SETBLK, 0 /THE RELATIVE BLOCK IN USE
THSBLK, 0 /ASKED FOR BLOCK
COWRIT, 1 /WRITE:1 READ:0
TELSW, 0
GOSWIT, 0
MONA, 0
LISA, 0
YEAR, 0
INBUF, 0
DEPTH, 0
DXOUT, XOUT
LF, 212 /RELOC PROBLEMS
MECH, 3 /MULTI8 ECHO SWITCH
WAIT, -1 /WAIT COUNTER
PAGE
/OS/8 FILE ROUTINES
/CHAIN WITH AC=0 FOR PROCEED,1:START,2:GOSUB,3:GOTO,4:WRITE
MAINTR, CLA IAC /MAIN ENTRY-POINT
CHENTR, JMP I STRTSW /CHAIN ENTRY-POINT - -
IFNDEF KEY <
TPUSHF /OR 'DCA STRTSW' AFTER INIT
MONHUK /INSTALL CTRL.C HOOK
TPOPF
7600>
IFDEF KEY <
NOP;NOP;NOP;NOP>
DCA TELSW /ALLOW TTY: TO START
CLA CMA
TAD STRTSW
SNA CLA
JMP I AAMESG /GO START DIRECT MODE
TAD STRTSW
CONTIN, DCA GOSWIT /GO BACK TO 'PROC':MAIN FLOW
JMP I [EXITOS
AAMESG, RESTRT
STRTSW, SETUP
OCLOSE, 0 /CLOSE THE OPEN OUTPUT FILE
TAD OPNFLG
SNA CLA /DON'T BOTHER IF IT ISN'T OPEN
JMP I OCLOSE
DCA OPNFLG /MUST BE HERE!
DCA OUTINH /WE CAN CLOSE THE LAST BLK
TAD [232 /WRITE '^Z'
JMS I [NOCHAR
TAD OPTR1 /PAD BUFFER WITH ZEROS
TAD (-OUTBUF /(AND WRITE IT OUT)
SZA CLA
JMP .-4
JMS I [GTMON
TAD DEVHLD /SAVED DEVICE #
CIF 10
JMS I USR
4 /CLOSE
ONMTMP /POINTER TO SAVED NAME
BLKCNT, 0 /FILE LENGTH; ZEROED BY OOPEN
JMP DERR /HUH?
DCA OUTFLG /RESTORE TELETYPE OUTPUT ROUTINE
JMP I OCLOSE /DO WHATEVER ELSE NEEDS TO BE DONE
/OS/8 3/2 BUFFERED CHARACTER OUTPUT
NOCHAR, 0 /ENTER WITH 2XX
ISZ O3 /WHICH CHAR OF THREE?;-3 INITIALLY
JMP O2 /STRAIGHT PACKING
JMS RT /HALF WORD PACKING - PACK FIRST HALF
TAD ATEM /GET SAVED ARG
JMS RT /PACK SECOND HALF
CLA CLL CMA RTL /RESET 3-WAY SWITCH
DCA O3
ISZ OCHCT /BUFFER CAN ONLY BE FILLED
JMP I NOCHAR / WITH 3RD CHAR OF 3
JMS I [PUTDEV /TELL USR THIS HANDLER'S IN
OUTHND-1/POINTER TO DEVICE # AND ENTRY
TAD OUTINH /LAST BLOCK?
SZA CLA
JMP OOVER /YES, CLOSE IN EXTREMIS
JMS I OUTHND /WRITE ONE BLOCK BUFFER
4200
OUTBUF
OBLK, 0 /SET BY OOPEN
JMP DERR /DEVICE ERROR
ISZ OBLK /BUMP OUTPUT BLOCK
ISZ BLKCNT /AND COUNT OF BLOCKS SO FAR
CLA CLL
TAD OLNGTH /-MAXIMUM ALLOWABLE LENGTH+1
TAD BLKCNT /LENGTH SO FAR
SZL CLA /HAS HE GONE TOO FAR?
ISZ OUTINH /YES;MUST CLOSE BEFORE NEXT END
TAD OUTINH /ONE WORD LESS IN NEXT BLOCK
JMS OSETUP /RESET POINTERS FOR NEXT BUFFER
JMP I NOCHAR
O2, DCA I OPTR1 /NORMAL PACKING IS EASY!
ISZ OPTR1 /BUMP POINTER
JMP I NOCHAR
O3=. /WHY NOT?
RT, 0 /HALF-WORD PACK ROUTINE
CLL RTL
RTL
DCA ATEM /SAVE FOR SECOND HALF
TAD ATEM
AND [7400
TAD I OPTR2 /ADD IN CHARACTER IN RIGHT HALF
DCA I OPTR2 /PACK IT
ISZ OPTR2 /BUMP POINTER AGAIN
JMP I RT
OOVER, CLA CMA /THERE IS JUST ROOM FOR CTRL.Z
DCA OCHCT /LET CLOSE WRITE IT FROM ERROR
ERROR1
345 /OF=OUTPUT FULL
OSETUP, 0 /RESET ALL THE POINTERS
TAD [7600 /THIS IS CHANGED TO -177
DCA OCHCT / FOR LAST BLOCK
TAD OBLK-1
DCA OPTR1
TAD OBLK-1
DCA OPTR2
CLA CLL CMA RTL
DCA O3
JMP I OSETUP
OPTR1, 0
OPTR2, 0
OLNGTH, 0 /SET BY OOPEN
OCHCT, 0
COMPO, SAVER
FETCHER
CHAINER
BUMP
GOSUB
RETOUR
LEXIT
LOADER
FOCTXT, FILENAME FOCAL.TM /USED BY GOSUB
TTYTXT, DEVICE TTY
NAMGO, NAMEVL
PERD
ECHCHK
CHANEL
RESTOR
NAMLEN
NAMEC
MONHUK, CIF CDF L
5602 /'JMP I .+1'
MEXIT
CNMTMP, ZBLOCK 4
PAGE
OOPEN, TAD [ORST /RESTORE ADRESS
JMS I [OPEN /CALL USR, HANDLER; ENTER FILE
YINT, OUTBLK-1/OUTPUT HANDLER BLOCK
3 /MONITOR 'ENTER' CODE
JMP TTYOUT /'OPEN OUTPUT TTY:'
JMP I (OCLCHK /SEE IF FILE OPEN
TPUSHF /SAVE NAME AND EXTENSION
NAMLOC
TPOPF
ONMTMP
TAD STBLK /STARTING BLOCK
DCA I (OBLK /IN NOCHAR
TAD FLNGTH /-MAXIMUM ALLOWABLE LENGTH
CLL IAC /CHECK IF ONE BL0CK LONG
DCA I (OLNGTH /IN NOCHAR (+1)
RAL /IF ONE LONG, LINK SET
DCA OUTINH /SEND OUT ^Z AT END OF FIRST BUFF
TAD OUTINH /ADJUST CHAR.CNT.
JMS I (OSETUP /SET UP PACKING POINTERS
CLA CLL CMA /THERE'S A FILE OPEN!
DCA OPNFLG
TAD DEVNO /SAVE FOR CLOSE
DCA DEVHLD
DCA I (BLKCNT /DITTO
ORST, TAD OPNFLG /ENTRY FOR 'OPEN RESTORE OUTPUT'
SZA CLA /IF 'OPEN OUTPUT', FLAG IS SET
CLA IAC /SET OUTPUT TO NOCHAR
TTYOUT, DCA OUTFLG /SET OUTPUT TO TTY (INTERRUPT)
TAD ECHFLG
DCA OUTECH /SET OUTPUT ECHO
JMP I [CONTIN /FINISH THE LINE
MINTEG, 0 /INTEGER FAKE
CDF P
TPUSHJ
XINTEG
MQA /RESTORE AC OVER POPJ
JMP I MINTEG
ICHAR, 0 /GET A CHARACTER FROM A FILE
CLA CLL CML /MAKE SURE-SET LINK FOR KEY BIT
ISZ INCHT /NEED ANOTHER BUFFER?;-1 INITIALLY
JMP I RDPTR /NO, UNPACK THE CHARACTER
JMS I INHND /YES, GO GET IT
0200
INBUFF
IBLK, 0 /SET BY IOPEN
SMA CLA /ONLY BOTHER WITH FATAL ERRORS
SKP CLA /REFERENCED!
JMP DERR /WE'VE GOT ONE
JMS I [DISMIS
ISZ IBLK /BUMP TO NEXT BLOCK
TAD IBLK-1 /AND RESTORE POINTERS
DCA IPNTR
CLA CMA /-1 FOR FIRST TIME ROUND
TAD [-600
DCA INCHT
ICHARL, JMS RDPTR /FIRST TIME AND KEY IN POS. 0
RTL
RTL
SPA /KEY IN POS. 0?
JMP ICHARL /YES;READ IN COMBINED WORD
DCA ITEMP /SAVE HALF-WORD AND KEY:POS.8-4-0
TAD I IPNTR /GET FULL WORD
JMS RDPTR
TAD I IPNTR /GET HALF WORD
ISZ IPNTR
AND [7400 /ISOLATE
CLL RAL /MAGIC STEP
TAD ITEMP /ADD IN OTHER HALF? AND KEY
JMP ICHARL+1 /GO SHIFT MORE AND TEST IF FULL
RDPTR, 0 /THIS IS A COROUTINE
AND [177 /ISN'T THAT AMAZING?
SNA /IGNORE NULLS AND PARITY
JMP ICHAR+1
TAD (-32 /END OF FILE? (^Z)
SZA
JMP .+4 /NO
DCA IPNFLG /YES, CLEAR OPEN FILE FLAG
CLA CMA /PREVENT AN
DCA INFLG /'ATTEMPT-TO-READ-PAST-EOF'!
TAD [232 /PASS ^Z TO PROGRAM FOR TESTING
JMP I ICHAR
ITEMP, 0
IPNTR, 0
INCHT, 0 /SET TO -1 BY IOPEN
ONMTMP, ZBLOCK 4
FILEST, TAD (604 /HERE'S WHERE FILES START!
DCA EXTENSION /SET '.FD' ASSUMED EXTENSION
CDF P
TPUSHJ
TERMER
MQA
CIF P
TSORTJ /GO DO COMMAND
FILIST-1
FILGO-FILIST
ERROR1 /OOPS - BAD 'O' COMMAND
36 /BO=BAD OPEN COMMAND
FILGO, IOPEN
OOPEN
OROI
OCLOSR
ARRAY
CCLOSR
FILIST, "I /INPUT
"O /OUTPUT
"R /RESTORE
"C /CLOSE
"A /ARRAY=COMMON
"T /TERMINATE(COMMON)
SAVER, JMS I [NAME /GET NAME FOR SAVE
JMS I (SAVPR /DO IT
EXITOS, JMS I [DISMIS /NORMAL RETURN FOR OS/8 COMMANDS
TAD GOSWIT
CDF CIF 10
JMP I .+1
LIBRET
PAGE
IOPEN, TAD (IRST /RESTORE ADRESS
JMS I [OPEN /CALL GENERAL-PURPOSE SUBROUTINE
INBLK-1
2 /MONITOR 'LOOKUP'
JMP TTYIN /'OPEN INPUT TTY:'
JMP IRST+2 /WHOOPS - FILE NOT FOUND
TAD STBLK /SET POINTERS AND OTHER CRAP
DCA I (IBLK /IN ICHAR
CLA CLL CMA
DCA IPNFLG
CLA CLL CMA
DCA I (INCHT /IN ICHAR
IRST, TAD IPNFLG /'OPEN RESTORE INPUT' COMES HERE
SNA CLA /FLAG IS SET ALREADY IF 'OPEN INPUT'
ERROR1 /NO INPUT FILE TO RESTORE
330 /NI=NO INPUT FILE
CLA IAC /SET I/O POINTERS
TTYIN, DCA INFLG
TAD ECHFLG /AND ECHO MODE
DCA INECH
CLA STL IAC RAL /=3 + ECHO=0/NO ECHO=-1
TAD INECH
DCA MECH /=> MULTI8 ECHO=3/NO ECHO=2
JMP I [CONTIN
FLD0=CLA CLL /PDL SATELLITES;FIELD 0
MPOPA, 0
MQL
FLD0
CIF T
JMS I .+1
ZPOPA
MPUSHA, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHA
MPUSHF, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHF
MPOPF, 0
MQL
FLD0
CIF T
JMS I .+1
ZPOPF
MPUSHJ, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHJ
MPOPJ, CIF CDF T
JMP I .+1
ZPOPJ
/THE FOLLOWING CODE WILL RECOGNIZE FOR EX.L C DATA(X)
/AND LOOK FOR DATA99 IF X=99
NAMEVL, TAD I (NAMECT /CHECK NUMBER OF CHARS
TAD (-4 /AT MOST 4
SMA SZA CLA
EVLERR, ERROR1
135 /FN=FILE NAME ERROR
DCA ATEM /CLEAR TEN COUNTER
CDF P /GO TO EVAL
TPUSHJ /'('READY,DUMP ')'
EVAL-1
TINTEG
TAD (-144 /.LT. 100 (DEC)
SZL /NOW WE HAVE X-100
JMP EVLERR
TAD [12 /X-100+ATEM*10
ISZ ATEM
SPA
JMP .-3
MQL /OVERFLOW IS LOW ORDER
TAD ATEM /ATEM IS 10 - HIGH ORDER
CIA /HIGH ORDER - 10
TAD [12 /HIGH ORDER
TAD [60 /6-BIT ASCII
JMS I (NAMSTO
MQA /LOW ORDER AGAIN
TAD [60
JMS I (NAMSTO
JMP I (NAMEC
XOS8, CDF P /OS8-MULTI8 FUNCTION
6254 /SKIP ON MULTI8
JMP YOS8 /OS8=1
TPUSHF
FLTZER /MULTI8=0
JMP NOS8
XSGN, CDF P /REAL SIGNUM FUNCTION
TAD I (HORD
SNA CLA
TPOPJ /FSGN(0)=0
YOS8, TPUSHF /DF P!
FLTONE
NOS8, CDF P
TPOPF
FLAC
XABS, CDF V /TAKE ABS OF FLAC
TAD I FLARGH
SMA CLA
TPOPJ
CDF P
TPUSHJ
MMINSK
TPOPJ
FLARGH, FLARG+1
DCWBM, 7757
GETDEV, 0 /GET DEVICE TYPE FROM MONITOR TABLE
TAD DCWBM /DCB-1
TAD DEVNO
DCA MPOPA
CDF P
TAD I MPOPA
CDF L
JMP I GETDEV
PAGE
/LIBRARY COMMAND PROCESSOR
/READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV'
NAME, 0
DCA NAMRET /SETUP RESTORE RETURN
DCA FILEN /SET TO LARGEST EMPTY
JMS I [DISMIS /'GETC' WON'T WITH THE USR IN CORE
TAD [5723 /CODE FOR 'DSK:'
DCA NEWDEV /(DEFAULT DEVICE)
NAME2, DCA NEWDEV+1
DCA NAMLOC /CLEAR NAME AREA
DCA NAMLOC+1 /(DON'T CLEAR ASSUMED EXTENSION)
DCA NAMLOC+2
TAD [NAMLOC /INITIALIZE POINTERS
DCA NMBASE
CLA CMA
DCA PERDSW
NAME3, DCA NAMECT
NAMEC, CDF P
TPUSHJ
MGETC
NAMENC, CLA CLL CMA
DCA ECHFLG /INIT. ECHO FLAG
CIF P
TSORTJ
NAMLST-1
NAMGO-NAMLST
JMS DECODE /MUST BE A-Z, 0-9
JMP NAMOUT /NO!, NOR IN NAMLST:END OF NAME
SZL /RESTORE CHARACTER
TAD (57
IAC /6-BIT ASCII
JMS NAMSTO
JMP NAMEC /CONTINUE LOOP
NAMSTO, 0
DCA DECODE /TEMPORARY STORAGE
TAD NAMECT /NO MORE THAN 6 CHARACTERS/NAME
TAD [-6
US7700, SMA CLA
JMP NAMEC
TAD NAMECT /BUILD POINTER TO CHARACTER POS
CLL RAR
TAD NMBASE
DCA TT
TAD DECODE /LEFT OR RIGHT HALF?
SNL
BSW /LEFT, SHIFT OVER
TAD I TT /ADD IN OTHER HALF
DCA I TT
ISZ NAMECT /BUMP COUNT
JMP I NAMSTO
PERD, TAD NAMLOC /FOUND A PERIOD IN STRING
SZA CLA
ISZ PERDSW
ERROR1 /DOUBLE PERIODS OR NO FILE NAME
35 /BN=BAD NAME IN FILES
DCA EXTENSION /CLEAR EXTENSION
ISZ NMBASE /FAKE OUT POINTERS
TAD [4
JMP NAME3
CHANEL, TAD NAMLOC /MOVE TO DEVICE AREA
DCA NEWDEV
TAD NAMLOC+1
JMP NAME2 /GET FILENAME
RESTOR, TAD NAMRET /COMES HERE ON '"'
SZA
DCA NAME /CHANGE RETURN IF NON. 0
JMP NAMEC
ECHCHK, CDF P /MOVE PAST COMMA
TPUSHJ
MGETC
CDF P
TPUSHJ /MOVE TO END KEEP FIRST
TERMER
MQA
TAD (-"E /MUST BE 'E'
NAMOUT, SNA CLA /DECODE 'NO' EXIT IS NON-ZERO
DCA ECHFLG /SET ECHO FLAG
JMP I NAME
DECODE, 0 /CHECK FOR A-Z, 0-9
TAD CHARL /IF YES ISZ RETURN
TAD (-"9-1
CLL
TAD ["9+1-"0
SZL
JMP DCDYES /NUMBER;CHAR-260;L=1
TAD ("0-"Z-1
CLL CML
TAD ("Z-"A+1
SNL
DCDYES, ISZ DECODE /ALPHA;CHAR-301;L=0
JMP I DECODE
NMBASE, 0
PERDSW, 0
NAMECT, 0
TT, 0
NAMRET, 0
NAMLEN, CDF P /INDICATE OPT. FILE LENGHT
TPUSHJ
EVAL-1 /GETS NUMBER IN []
TINTEG
CLL RTL
RTL
AND [7760
DCA FILEN
JMP NAMEC
GTMON, 0 /LOCK THE USR IN CORE
/(NOP IF ALREADY IN CORE)
CDF L
CIF P
JMS I USR
10
TAD [200 /SET POINTER FOR LATER CALLS
DCA USR
JMP I GTMON
DISMIS, 0 /IF THE USR IS IN, KICK IT OUT
CLA CLL
CDF L /MAKE SURE
TAD USR /CHECK POINTER TO FIND OUT
SPA CLA
JMP I DISMIS
CIF P
JMS I USR
11
TAD US7700 /RESET POINTER
DCA USR
JMP I DISMIS
PAGE
/HANDAD CALL: HANDAD
/SLOT
/SETS DEVNO; DEVICE NO. IN SLOT; ENTRYPOINT IN SLOT
HANDAD, 0 /LOADS HANDLER INTO PROPER SLOT
TAD I HANDAD /WHICH SLOT?
ISZ HANDAD
DCA SLOT
JMS COMPARE /IF THE HANDLER HAS THE SAME NAME,
-2 /DON'T LOAD IT AGAIN
SLOT, 0
NEWDEV-1
JMP NOTEQ /DIFFERENT NAMES, LOAD NEW HANDLER
ISZ AUTO2
TAD I AUTO2 /(SET BY 'COMPARE')
DCA DEVNO /MOVE DEVICE# (FOR SAVE AND CLOSE)
TAD AUTO2 /POINTS TO DEVICE #
DCA .+2
JMS I [PUTDEV /SO USR KNOWS IT'S IN CORE
0
JMP I HANDAD
NOTEQ, ISZ SLOT /BUMP POINTER TO SAVE NAME
TAD NEWDEV /MOVE NEW DEVICE NAME TO TABLE
DCA I SLOT
ISZ SLOT
TAD NEWDEV+1
DCA I SLOT
ISZ SLOT
JMS I [GTMON
RETRY, TAD NEWDEV /MOVE DEVICE NAME FOR MONITOR CALL
DCA DEVC
TAD NEWDEV+1
DCA DEVC+1
TAD I SLOT /MOVE LOAD POINT
IAC /TWO PAGE HANDLER!
DCA DLOAD
CIF P
JMS I USR /CALL MONITOR (ALREADY IN CORE)
1 /FETCH BY NAME
DEVC, 0 /NAME
0 /RETURNS DEVICE NO.
DLOAD, 0 /RETURNS ENTRY POINT
ERROR1 /DEVICE NOT AVAILABLE
323 /ND=NO DEVICE
CLL
TAD DLOAD /ENTRY POINT FOR HANDLER
TAD [200 /IF THIS HANDLER IS IN PAGE 7600,
SZL CLA /DON'T CHECK FOR LEGALITY
JMP HANDOK /SYSTEM HANDLER
TAD DLOAD /IF THE HANDLER WAS NOT LOADED
AND [7600 /INTO THE PROPER PAGE, RELOAD IT
CLL CIA
TAD I SLOT /PROPER LOADING ADDRESS
SNA CLA
JMP HANDOK /EVERYTHING'S ALL RIGHT
DCA DLOAD /CLEAR ENTRY POINT
JMS I [PUTDEV /TELL USR THE HANDLER IS NOT
DEVC+1 /IN CORE ANYMORE
JMP RETRY /LOAD IT THIS TIME
HANDOK, ISZ SLOT /BUMP POINTER TO DEVICE #
TAD DEVC+1 /SAVE IT
DCA I SLOT
ISZ SLOT /MOVE TO ENTRY POINT
TAD DLOAD /SAVE ENTRY
DCA I SLOT
TAD DEVC+1 /GET DEVICE #
DCA DEVNO /SAVE IT AND EXIT
JMP I HANDAD
COMPARE,0 /COMPARE TWO BLOCKS
TAD I COMPARE /CALLING SEQUENCE:
ISZ COMPARE /JMS COMPARE
DCA XCNTR / -# OF WORDS TO CHECK
TAD I COMPARE / FIRST-1
ISZ COMPARE / SECOND-1
DCA AUTO2 /RETURN IF NO MATCH
TAD I COMPARE /RETURN IF MATCH
ISZ COMPARE
DCA AUTO3
AGAIN, TAD I AUTO2 /COMPARE TWO WORDS
CIA
TAD I AUTO3
SZA CLA
JMP I COMPARE /NO MATCH
ISZ XCNTR /FINISHED?
JMP AGAIN /NO, CHECK NEXT TWO
ISZ COMPARE /YES, BUMP RETURN POINTER
JMP I COMPARE
NAMLST, "( /SUBSCRIPTED FILE NAMES
". /EXTENSION
", /ECHO
": /DEVICE
"" /RESTORE OLD IN/OUT
"[ /FILE LENGHT SPEC.
" /SPACE: IGNORE
/THIS IS FOR CHAINING TO ANOTHER PROGRAM
LOADER, JMS I [OCHK /DON'T FORGET TO CLOSE THE FILES
JMS I [NAME /OR FOR OVERLAYING FOCAL ITSELF
TAD (2326 /EXTENSION "SV" IS FORCED ON
DCA EXTENSION /IT HAS TO BE A SAVE FILE:CHAIN
JMS I [IOWAIT
TAD [NAMLOC /POINTER TO NAME
DCA LOADUS+2
CLA STL RTL /=2
DCA LOADUS+1
IAC /CHAIN EXPECTS IT TO BE ON SYS:
CIF P
LOADUS, JMS I USR
2 /LOOKUP RETURNS FILE START IN ARG2
NAMLOC
0
ERROR1 /USR DID NOT FIND IT
47 /CH=CHAINING ERROR
DCA LIBBLK /KILL LIB HANDLER;CHAIN DOES RESET
CLA IAC STL RTL /OK! CHANGE USR FUNCTION TO CHAIN=6
DCA LOADUS+1
JMP LOADUS-1 /BY-BY!! MIGHT SEE YOU AGAIN
COMLIST,"S /SAVE
"C /CALL
"R /RUN
"D /DELETE
"G /GOSUB
215 /'LIBRARY RETURN'
"E /EXIT
"L /LOAD; CHAIN A PROGRAM
OCLOSR, JMS I [OCLOSE /CLOSE OUTPUT FILE
JMP I [CONTIN
IOWAIT, 0
DRONE
TAD TELSW
SZA CLA
JMP .-3
JMP I IOWAIT
PAGE
CODENU, 0
SAVPR, 0 /CALLED BY 'SAVER' AND 'GOSUB'
TAD [NAMLOC /POINTER TO NAME
DCA SAVEPT
CDF P
TAD I (BUFR
DCA BLOCK /SAVE TEMP. PROGRAM LENGTH
CDF T
TAD [LINE0+2
DCA AUTO1 /SET AUTO-INDEX FOR TRNSFR.
TAD NAMLOC
DCA I AUTO1
TAD NAMLOC+1
DCA I AUTO1 /TRANSFER NAME
TAD NAMLOC+2
DCA I AUTO1
TAD EXTENS
BSW
AND [77
TAD (5600
DCA I AUTO1 /TRANSFER .F
TAD EXTENS
AND [77
BSW
DCA I AUTO1 /REST OF EXTENSION: C@
TAD MONA /GET MONTH NAME
DCA I AUTO1 /SAVE
TAD LISA /SECOND HALF+ "-"
DCA I AUTO1
TAD YEAR
DCA I AUTO1 /SAVE YEAR
TAD BLOCK
IFNDEF KEY<
DCA I LINPUT /SAVE PROGRAM LENGTH
>
IFDEF KEY<
CLA CLL
>
JMS I [GTMON /GET USR;RESETS DF
JMS I [OCHK /CLOSE OUTPUT FILE, AVOID TROUBLE
JMS I [HANDAD /AND GET HANDLER
LIBBLK-1
TAD BLOCK
AND [7600 /MASK OFF
CLL RAR /CONVERT TO PAGES
DCA BLOCK /FOR HANDLER
TAD BLOCK /ROUND UP TO BLOCKS
TAD [100
AND [7600
CLL RTR
RAR
DCA RECORD /FOR MONITOR 'ENTER':BITS 0-7
TAD DEVNO /PREDELETE FILE
CIF 10
JMS I USR
4
NAMLOC
0
LINPUT, LINE0-1 /SKIP ERROR
TAD RECORD /GET DESIRED LENGTH
TAD DEVNO /(SET BY 'HANDAD')
CIF 10
JMS I USR /ENTER OUTPUT FILE
3
SAVEPT, NAMLOC
0
ERROR1 /NO ROOM ON DEVICE
65 /DF=DEVICE FULL
TAD RECORD /SHIFT FOR CLOSING LENGTH -
CLL RTR / - OR '0' *KEY*
RTR
DCA SAVBLK
TAD DEVNO /CLOSE THE FILE BEFORE WE WRITE IT!
CIF 10 /(SURE, IT'S CHEATING, BUT
JMS I USR /IT SAVES TIME!)
4 /CLOSE
NAMLOC
SAVBLK, 0 /NO. OF BLOCKS
JMP DERR /IMPOSSIBLE ERROR!
TAD SAVBLK /SAVE THIS CRAP TO REMEMBER
CIA /WHERE THIS PROGRAM IS
DCA LIBLEN /IN CASE WE WANT TO GOSUB
TAD SAVEPT
DCA LIBFIL
TAD NEWDEV
DCA LIBDEV
TAD NEWDEV+1
DCA LIBDEV+1
TAD SAVEPT /MOVE STARTING BLOCK FOR WRITE
DCA POINT4
TAD WRFUN /GET FUNCTION WORD OR 'TAD [OCLOSE' *KEY*
TAD BLOCK /HOW MUCH TO WRITE /=220 READ!!
DCA BLLL
JMS I LIBHND
BLLL, 0 /WRITE (BLOCK) BLOCKS FROM FIELD 2
200 /FROM 200 UP
POINT4, 0
JMP DERR /GO COMPLAIN ABOUT DEVICE
JMP I SAVPR
WRFUN, 4021 /WRITE IN FIELD 2 FORW
LIBLEN, 0 /SAVED LENGTH
LIBDEV, ZBLOCK 2
RECORD, 0
BLOCK, 0
ENDLOD, TAD NEWDEV /SAVE THIS STUFF SO WE
DCA LIBDEV /KNOW WHERE WE ARE
TAD NEWDEV+1
DCA LIBDEV+1
TAD STBLK
DCA LIBFIL
TAD FLNGTH
DCA LIBLEN
CDF T
TAD CODENU
TAD I (PC0+2
DCA SAVBLK
TAD I (PC0+2
SZA
JMP SAVCIF
TAD I LINPUT
KEYRES, CDF P
DCA I (BUFR
CIF CDF L
IFNDEF KEY<
JMP I [EXITOS
1234
>
IFDEF KEY<
JMP I .+1
KEYER
>
SAVCIF, CIF T
JMP I SAVBLK
PAGE
/ACTUAL LIBRARY PROCESSOR
/STARTING WITH COMMAND DECODE:
LOWLIB, DCA GOSWIT
TAD [617 /NEW EXTENSION .FO
DCA EXTENSION
CDF P
TPUSHJ
TERMER
MQA
CIF P
TSORTJ /AND BRANCH TO APPROPRIATE ROUTINE
COMLIST-1
COMPO-COMLIST
LIERR, ERROR1 /SORRY, CHARLIE!
270 /LI=LIBRARY COMMAND ERROR
/LOOKUP AND LOAD ROUTINES
CHAINER,ISZ GOSWIT /THESE ALL DO THE SAME THING
GOSUB1, ISZ GOSWIT /AND THEN GO TO DIFFERENT PLACES
FETCHER,ISZ GOSWIT
JMS I [OPEN /CALL THE HANDLER AND LOOKUP FILE
LIBBLK-1
2
JMP .+6 /TTY: NOT A DIRECTORY DEVICE
ERROR1
337 /NP=NO PROGRAM FOUND
JMS I [DISMISS
JMS I [GETDEV /GET DEVICE TYPE
SMA CLA
ERROR1 /NOT A DIRECTORY DEVICE
63 /DD=NOT A DIR. DEV.
CDF P
TPUSHJ
PGETLN /SOME COMMANDS HAVE LINE NUMBERS
LOADGO, JMS I [DISMISS /ONLY USED BY 'RETOUR'
TAD STBLK /BLOCK TO READ FROM
DCA POINT6
CLA CLL CMA RAL /(=-2)
TAD GOSWIT /IS THIS A GOSUB?
SZA CLA
JMP NOGOSB /NO, SKIP THIS GARBAGE
TAD CHARL /YES, SAVE PROGRAM NAME, ETC.
TPUSHA /PDL NOW CONTAINS:
TAD [215 /CHAR,DEV,FILE LENGTH,START BLOCK
CDF P
DCA I DCHAR
NOGOSB, TAD FLNGTH /COMPUTE FUNCTION WORD
CMA /BLOCKS-1
BSW
CLL CML RAL /SET TO SEARCH FORWARD
DCA LENF1
TAD FLNGTH /NOW CHECK FOR LENGHT
TAD (17 /.LE. 15(10)
SPA
JMP PLERR /READING IN NONSENSE
SZA CLA /IS IT MAX. LENGTH?
TAD [100 /NO: READ ALL
TAD (120 /YES: READ 1 PAGE LESS (SET FIELD)
TAD LENF1
DCA LENF1 /FINAL CONTROL WORD
CDF T
TAD I (PDLXR /BOTTOM OF PDL
CIA
CLL RAR /TEST CTW-(PDL-200)/2
TAD [100 /FOR PAGE 0
TAD LENF1
PLERR, CDF L
SPA CLA
ERROR1 /PROGRAM TOO LONG
373 /PL=PROGRAM LENGTH ERROR
JMS I LIBHND /GET THE PROGRAM
LENF1, 3521 /LARGEST CTW
200
POINT6, 0
JMP DERR
JMP I (ENDLOD
/REMARK: THE PDL MAY NOT BE LOWER THAN 7444 FOR
/ A PROGRAM OF MAXIMAL LENGTH (15 BLKS).
GOSUB, TAD LIBFIL /CHECK FOR CURRENT PROGRAM
SZA
JMP NOSAVE /NO NEED TO SAVE CORE
TPUSHF /MOVE 'FOCAL.TM' TO NAME AREA
FOCTXT
TPOPF
NAMLOC
TAD [5723 /DEVICE 'DSK' FOR SAVE
DCA NEWDEV
DCA NEWDEV+1
JMS I (SAVPR /SAVE FILE (LEAVE USR IN CORE)
TAD [617 /RESET EXTENSION TO 'FO'
DCA EXTENSION
TAD LIBFIL /STARTING BLOCK
NOSAVE, TPUSHA /'LIBFIL' STILL IN AC
TAD I (LIBLEN
TPUSHA
TPUSHF
LIBDEV
ISZ DEPTH
JMP GOSUB1
RETOUR, STA CLL
TAD DEPTH
DCA DEPTH /KEEP COUNT OF SUBS
SNL
JMP LIERR
TPOPA /GET BACK ALL THE JUNK WE SAVED
CDF 10 /FOR THE LAST GOSUB
DCA I DCHAR /IN-LINE CHARACTER
CDF
TPOPF /DEVICE NAME
NEWDEV
TPOPA /FILE LENGTH
DCA FLNGTH
TPOPA /STARTING BLOCK
DCA STBLK
JMS I [HANDAD /GET THE HANDLER BACK
LIBBLK-1
JMP LOADGO /LOAD THE PROGRAM
COCLR, 0 /CLEAR COMMON BUFFER
TAD (COMBUF-1 /DON'T TOUCH LINK!
DCA AUTO1
TAD [-2000
DCA XCNTR
DCA I AUTO1
ISZ XCNTR
JMP .-2
JMP I COCLR
PAGE
/MISCELLANEOUS GENERAL-PURPOSE ROUTINES
/THIS IS THE GENERAL OPEN SUBROUTINE
/CALLNG SEQUENCE:
/JMS I [OPEN
/HANDLER BLOCK
/MONITOR CALL CODE
/RETURN IF TTY: IS DEVICE
/ERROR RETURN
/NORMAL RETURN
/SETS STBLK, FLNGTH ON PAGE ZERO
OPEN, 0
JMS I [NAME /GET DEVICE AND FILENAME
JMS I (COMPAR /DEVICE 'TTY:' IS SPECIAL
-2
NEWDEV-1
TTYTXT-1
JMP OTHER /DEVICE OTHER THAN TTY
ISZ OPEN /INCREMENT TO PROPER RETURN
ISZ OPEN
JMP I OPEN
OTHER, TAD I OPEN /GET HANDLER BLOCK TO USE
DCA HND
ISZ OPEN
TAD [NAMLOC /POINTER TO NAME
DCA NAMPT
JMS I [GTMON
JMS I [HANDAD /GET THE HANDLER
HND, 0 /SET TO HANDLER BLOCK
TAD I OPEN /GET MONITOR CALL CODE (2 OR 3)
ISZ OPEN
DCA CALL
DCA LNGTH /FOR MONITOR KLUDGE
TAD DEVNO /DO THE CALL
TAD FILEN /ADD IN OPT. FILE LENGHT
CIF 10 /DEV # IN AC
JMS I USR /2: LOOKUP
CALL, 0 /3: ENTER
NAMPT, NAMLOC /NAME POINTER;RETURNS START BLOCK
LNGTH, 0 /RETURNS -FILE LENGTH IN BLOCKS
/TENTATIVE FOR ENTER
JMP OTHER-2 /CALLING ROUTINE HANDLES ERROR
TAD LNGTH /MOVE PARAMETERS TO PAGE ZERO
DCA FLNGTH
TAD NAMPT
DCA STBLK
JMP OTHER-3 /AND TAKE NORMAL RETURN
BUMP, JMS I [NAME /DELETE IS AN EASY ONE (THANK GOD!)
JMS I [GTMON
JMS I [HANDAD
LIBBLK-1
JMS I [OCHK /CLOSE ANY OPEN OUTPUT FILE
CIF 10 /DELETE THE FILE
TAD DEVNO
JMS I USR
4
NAMLOC
0
ERROR1
123 /FD=FILE DELETION ERROR
DCA LIBFIL /IF CURRENT PROGRAM DELETED
JMP I [EXITOS
OCLCHK, TAD OPNFLG
SNA CLA
ERROR1
344 /OE=OPEN OUTPUT ERROR
JMS I [OCLOSE
TAD (YINT
DCA OPEN
JMP OTHER
PUTDEV, 0 /TELL USR A HANDLER IS IN OR OUT
TAD I PUTDEV /GET POINTER TO DEV# AND ENTRY
DCA XIN
TAD I XIN /DEVICE#
ISZ XIN /BUMP POINTER TO ENTRY
TAD (7646 /MONITOR TABLE
DCA PUTTEM /POINTER TO 'HANDLER IN CORE' FLAG
TAD I XIN /FLAG IS HANDLER ENTRY
CDF P /TABLE IS IN FIELD ONE
DCA I PUTTEM
CDF L
ISZ PUTDEV
JMP I PUTDEV
PUTTEM, 0
MEXIT, KCC
JMS I [IOWAIT /BE SURE ^C CAN BE SENT
TAD (203
JMS I [TERMNL /TYPE ^C
LEXIT, TPUSHF /LIBRARY EXIT ROUTINE
RESMON /ALSO USED BY CTRL.C
TPOPF
7600 /RESTORE MONITOR CALL
JMS I [OCHK /CLOSE FILES
JMS I [DISMISS /BOOT USR OUT
JMS I [IOWAIT /WAIT FOR TTY;IOF
JMP I [7600 /LEAVE FOCAL
XIN, 0 /VIA (INDEV)
JMS I [IOWAIT
STA
DCA WAIT /CLEAR WAIT
KSF
JMP .-1
DRONE
TAD INBUF
DCA PUTDEV
DCA INBUF
KCC
TAD PUTDEV
SNA
JMP XIN+1 /IGNORE KILLER NULL
JMP I XIN
OROI, CDF P
TPUSHJ
TERMER
MQA
TAD (-"I
SNA CLA
TAD (IRST-ORST
TAD [ORST /DEFAULT O R O
DCA I [NAME /FAKE OUT NAME
JMP I (NAMENC /TO SET ECHO MODE
/LEIDER NO SPACE
/MORE, 0
/ CDF V
/ NOP /SKIP1
/ JMP MORE2 /VAR. FLD STILL ON
/ DCA I XNMBSG /CLEARS HORD VAR "#"
/ NOP /CLEAR1
/MORE2, NOP /SKIP2
/ JMP MORE3
/ DCA I XEXCLA /VARIABLE "!"
/ NOP /CLEAR2
/MORE3, NOP /SKIP3
/ JMP I MORE
/ DCA I XQUOTS /VARIABLE """
/ NOP /CLEAR3
/ JMP I MORE
/XNMBSG, NMBSGN
/XEXCLA, EXCLA
/XQUOTS, QUOTS
CONVER, 0
TAD (-33
SNA CLA
JMP CONESC
TAD (136
JMS I DXOUT /TYPE ^
TAD [100
JMP I CONVER /AND CONVERT;100+LOWIN=ALPHA
CONESC, TAD ["$-33
JMP I CONVER
PAGE
XCOM, TINTEG /COMMON FOR 4096 4-W. VARIABLES
DCA BLKTMP
TAD BLKTMP
AND [377 /ADRESS IN BUFFER
CLL RTL /*4 : 4-WORD
TAD I (COSTA /START OF BUFFER
TPUSHA
TAD BLKTMP
AND [7400 /:8 BUFFERS
BSW /OF 4 BLOCKS EACH
TPUSHA /STORE RECURSIVELY
TPUSHJ /PUT OR GET?
ARG
CLA CMA /GET
DCA GEPUSW /PUT
TPOPA /GET BLOCK #
TPUSHJ
COMEXT /GET BLOCK
ISZ GEPUSW
JMP COMPUT
TPOPA /NOW GET ADRESS
DCA GEPUSW
TPUSHF
GEPUSW, COMBUF
CDF P
TPOPF
FLAC
TPOPJ
COMPUT, TPOPA
DCA BLKTMP
CDF P
TPUSHF
FLAC
TPOPF
BLKTMP, COMBUF
IAC
DCA COWRIT
TPOPJ
ARG, TAD CHARL
TAD [-",
SZA CLA
TPOPJ
CDF P
TPUSHJ
EVAL-1
IAC
TPOPJ
COMEXT, DCA THSBLK /ASKED FOR BLOCK
TAD THSBLK
CIA
TAD SETBLK /IS IT ALLREADY HERE?
SNA CLA
TPOPJ /YES.EXIT
CLL CML IAC RAL /+3 SO THAT WE DON'T
TAD THSBLK / WRITE ON ANOTHER FILE
TAD CLNGTH /SET TO 0 BY CCLOSE
SMA CLA
ERROR1 /WE ARE ASKING FOR TO MUCH!
4 /AE=ARRAY EXCEEDING CORE LIMITS
JMS CORITE /WRITE OUT IF ANY MODIFICATIONS
TAD COMFLG /AND CLEAR BUFFER IF WRITE
SNA CLA /NEW OR OLD?
JMP COINPT /OLD
TAD COCNT /LARGEST SO FAR
CIA
TAD THSBLK
SPA CLA
JMP COINPT /THSBLK .LT. COCNT;ALREADY OUT
TAD COCNT
DCA SETBLK /SET TO WRITE AND CLEAR NEXT BUFF
JMP COMEXT+1
COINPT, CLA CLL /LNK=0 FOR READ
TAD THSBLK /READ ASKED FOR BLOCK
MQL
JMS I (COHNDL
TAD THSBLK
DCA SETBLK /NOW SET CURRENT BLOCK
TAD COMFLG /IF NEW FILE SET WRITE FLAG, IF OLD
DCA COWRIT /CLEAR WRITE FLAG
TPOPJ
CORITE, 0 /ALSO CALLED BY CCLOSE
TAD COWRIT
SNA CLA /ONLY WRITE IF NEW DATA
JMP I CORITE
CLA CLL CML /LNK=1 FOR WRITE
TAD SETBLK /WRITE BLOCK IN CORE
MQL
JMS I (COHNDL
JMS I (COCLR /NOW CLEAR BUFFER
TAD SETBLK
CIA
TAD COCNT /CHECK IF LAST BUFFER
SZA CLA
JMP I CORITE
CLA CLL IAC RTL /4
TAD COCNT
DCA COCNT /UPDATE COCNT
JMP I CORITE
/SUBROUTINE CALLED BY 'OPEN TERMINATE' AND 'OCHK'
CCLOSE, 0
TAD CLNGTH
SNA CLA
JMP I CCLOSE
JMS CORITE
TAD COMFLG
SNA CLA
JMP CLOOUT /ONLY CLOSE INTERNALLY
JMS I [GTMON
TAD DEVNO
CIF P
JMS I USR
4 /CLOSE
CNMTMP
COCNT, 0
ERROR1
2 /AC=ARRAY CLOSE ERROR
CLOOUT, DCA CLNGTH /ONLY INCORE FX() NOW
DCA SETBLK /AND ONLY FX(0)-FX(255)
JMP I CCLOSE
CCLOSR, JMS I [CCLOSE
JMP I [CONTIN
RESMON, 4207 /'JMS SHNDLR'
5000 /WRITE 10 PAGES FIELD 0
0000 /FROM ADRESS 0
0033 /IN BLOCK 33
PAGE
COHNDL, 0 /SUB FOR READING OR WRITING ARRAY BUFFER
SZL
JMP .+6 /WRITE
TAD SETBLK /READ
TAD [12 /IF LAST WRITTEN BLOCK+4+7
CMA
TAD THSBLK /IS SMALLER THAN ASKED FOR BLOCK
CLA RTL /ROTATE LINK FOR SEARCH FORWARD
TAD [2000 /HERE LNK=0:READ;1:WRITE
RAR /5000:WRITE;1000:READ;8 PAGES
DCA COARG /1001:READ FORWARD
MQA /BLOCK
TAD CBLOCK /FIRST OF FILE
DCA COSTA+1
TPUSHF
COMDEV
TPOPF
NEWDEV /GET HANDLER BACK
JMS I [HANDAD
LIBBLK-1
JMS I LIBHND
COARG, 0
COSTA, COMBUF
0
JMP DERR
JMS I [DISMIS
JMP I COHNDL
CBLOCK, 0
COMDEV, ZBLOCK 2
/"OPEN ARRAY"
ARRAY, JMS I [CCLOSE //FILE STILL OPEN?
TAD (0601 /ASSUMED EXTENSION .FA
DCA EXTENS
JMS I [OPEN
LIBBLK-1
2 /FIRST DO A LOOKUP
JMP NODIR /TTY NOT A DIRECTORY DEVICE
SKP CLA /THERE WAS NO FILE OF THAT NAME
JMP COMON /FOUND IT!
TAD ARPNT /FAKE 'OPEN' FOR ENTER
DCA I [OPEN
JMP I (OTHER
LIBBLK-1
3 /ENTER
ARPNT, .-2 /IT CAN'T COME HERE;ALREADY TESTED
ERROR1 /DEFINITELY AN ERROR
5 /AF=ARRAY FULL
CLA IAC /1 IF NEW FILE
COMON, DCA COMFLG /SET NEW/OLD FLAG
JMS I [GETDEV /I.E. A DISPLAY IS NO GOOD
SMA CLA
NODIR, ERROR1
3 /AD=ARRAY DEVICE ERROR
TPUSHF /EVERYTHING IS OK
NAMLOC
TPOPF
CNMTMP /SAVE NAME FOR CLOSE
TAD NEWDEV
DCA COMDEV
TAD NEWDEV+1
DCA COMDEV+1
TAD STBLK
DCA CBLOCK /SAVE FIRST BLOCK
CLL
TAD FLNGTH
TAD [100 /IS LENGTH GREATER THAN 100BLOCKS?
SNL
CLA CLL /YES;IGNORE
TAD NODIR-1 /-100
DCA CLNGTH /STORE LENGTH .LE. 100 (NEG)
DCA I (COCNT /NEW LENGTH IS ZERO
DCA THSBLK /FIRST BLOCK IS IN CORE
TPUSHJ /SET SETBLK=THSBLK, COWRIT=COMFLG
COINPT /AND READ FIRST BUFFER (EVEN IF NEW)
TAD COMFLG /IS IT AN NEW FILE?
SZA CLA
JMS I (COCLR /YES, CLEAR BUFFER OF FIRST BLOCK (HAS RUBBISH)
JMP I [CONTIN
OCHK, 0 /IF ANY FILE EXISTS CLOSE IT
JMS I [CCLOSE
JMS I [OCLOSE
JMP I OCHK
LOWOUT, 0 /OUT DRIVER
DCA LOWOTM
CDF P
TAD I [ECHO /CHK ECHO
TAD INECH
SPA CLA /0+-1:NO PRINT
JMP OUTOUT
TAD LOWOTM
TAD (-216 /IS IT CRONLY?
SZA /YES; CHANGE TO REAL CR
IAC /NO; DON'T CHANGE CHAR
SNA /IF 215-216 RESET TABC
DCA I (TABC
TAD (215-240 /IS IT PRINTING?
SMA
ISZ I (TABC /YES INC TABC
NOP
TAD [240
DCA LOWOTM
CDF L
TAD OUTFLG
SNA CLA /0:TTY
JMP LOWTTO
TAD LOWOTM
JMS I [NOCHAR /WRITE ON FILE
TAD OUTECH
SZA CLA /0:ECHO
JMP OUTOUT
LOWTTO, TAD LOWOTM
JMS I [TERMNL /ON TTY
OUTOUT, CDF L
DRONE
CIF CDF P
JMP I LOWOUT
LOWOTM, 0
PAGE
XIDLE, 0
CLA CLL
RDF
TAD CCDI
DCA INTEXI+1
CDF L
KSF /CHECK FOR KEYBOARD FIRST
JMP TINT /MORE TO COME
CTRLSO, KRS /INPUT CHARACTER
AND [177 /IGNORE BLANK AND L-T AND PARITY BIT
SNA
JMP TINT-1 /GO INITIATE NEXT READ
TAD [200
DCA XTEMP
TAD XTEMP
TAD [-203 /CTRL.C?
SNA
JMP I DMEXIT /YES
TAD [-20
SNA /CTRL S?
JMP CTRLS
TAD [2
SNA /CTRL.Q?
JMP TINT-1 /KILL
TAD [2 /(CHAR-217)/2=0 FOR CTRL.O AND P
CLL RAR /IS IT?
SNA CLA
JMP RECOVR /YES A BREAK
TAD INBUF
SNA
TAD XTEMP
DCA INBUF
CDF V
TAD INBUF
DCA I XDOL /SAVE IN INPUT VARIABLE
SKP
KCC
TINT, TSF
JMP INTEXI
DCA TELSW /TURN OFF THE IN-PROGRESS-FLAG
CDF P
TAD I OPTRI
SNA
JMP INTEXI
TLS /TYPE NEXT
DCA TELSW /CLEAR AC AND TURN ON THE FLAG
DCA I OPTRI /ZERO OUT THE DATA AREA
TAD OPTRI
IAC
AND K37
TAD OPTR0
DCA OPTRI
INTEXI, CLA / JMS I DMORE
HLT
JMP I XIDLE
XDOL, DOLL
XTEMP, 0
/DMORE, MORE
DMEXIT, MEXIT
OFILES=7600
OPTR0, OFILES
OPTRO, OFILES
OPTRI, OFILES
CTRLS, KCC /KILL ^S IN BUFFER
KSF
JMP .-1 /WAIT FOR GODOT
JMP CTRLSO /USE GODOT
XOUT, 0 /VIA (OUTDEV)
DCA ERROL
ISZ CHRCNT
K37, 37
CDF P
TAD I OPTRO /ANY ROOM ?
SNA CLA /A CHAR. IS NONZERO
JMP .+4
CCDI, CIF CDF 0
DRONE /NO = WAIT
JMP .-6
TAD TELSW /IN PROGRESS ?
MIN40, SMA SZA CLA
JMP .+5
TAD ERROL /NO
TLS /TYPE CHAR
DCA TELSW /SET IN PROGRESS FLAG
JMP .+10 /RETURN
TAD ERROL /SEND DATA
DCA I OPTRO
TAD OPTRO /SET POINTERS
IAC
AND K37
TAD OPTR0
DCA OPTRO
CDF L
JMP I XOUT
ERRONC, -2
ERROL, 0 /ERROR PRINT AND RESET
CLA CMA CLL
TAD I ERROL /GET ERROR CODE
DCA ERRCOD /DEFINED BY TECO CODE:
/^O^T-1&37*20UY^T-1&17+QY==^D CODES UP TO ?ZP
JMS I [IOWAIT /WAIT FOR OUTPUT TO FINISH
TAD ERRCOD
RECOVR, IAC /AB=A BREAK
RESTRT, DCA ERRCOD /AA=START ALL OVER
KCC
ISZ ERRONC /AVOID STAYING IN CLOSE ERROR
JMS I [OCHK
JMS I [DISMISS
CLA CLL CMA RAL /NOW WE ARE OK
DCA ERRONC
DCA DEPTH
DCA INBUF /CLEAR INPUT BUFFER
TAD MIN40 /CLEAR OUTPUT BUFFER
DCA XCNTR
CMA
TAD OPTR0
DCA AUTO1
TAD OPTR0
DCA OPTRI
TAD OPTR0
DCA OPTRO
DCA OUTECH
DCA INECH
CLA STL IAC RAL /ENABLE MULTI8-ECHO
DCA MECH
DCA OUTFLG /CLEAR IN/OUT FLAGS
DCA INFLG
CDF P
DCA I AUTO1
ISZ XCNTR
JMP .-2
CLA IAC /RESET ECHO TO ON
DCA I [ECHO
CDF L
TAD [215 /BACK TO START OF LINE
JMS TERMNL
TAD LF
JMS TERMNL
TAD (213 /RESET COUNTERS
JMS TERMNL
TAD [77
JMS TERMNL /?
TAD ERRCOD
CLL RTR
RTR
TAD (301 /FIRST LETTER
JMS TERMNL
TAD ERRCOD
AND (17
TAD (301 /SECOND LETTER
JMS TERMNL
CIF CDF P
JMP I .+1 /FOR LINENO PRINTOUT
ENDERR
/IN DRIVER
LOWIN, 0
SNA /DISABLE ECHO =2 IN AC
TAD MECH /DEFAULT SET BY INECH
6770 /IN MULTI8
DRONE
TAD INFLG
SPA
JMP EOF /-:END OF FILE
SNA CLA
JMP LOWTTI /0:TTY
JMS I (ICHAR /INPUT FROM FILE
SKP
LOWTTI, JMS I (XIN /FROM TTY
CIF CDF P
JMP I LOWIN
EOF, ERROR1
105 /EF=END-OF-FILE
TERMNL, 0 /HANDLER FOR TTY DEVICE
AND [177
DCA LOWIN
TAD LOWIN
TAD [-16 /CHAR-16
CLL
TAD [7 /OVERFLOW IF 7.LE.CHAR.GE.15
SZL CLA /FORMAT CHAR.?
JMP TERCTL
TAD LOWIN /CONTRL.CHAR.?
AND TERNMV
SZA CLA
JMP TEROUT /NO;OUT NORMAL
TAD INFLG
CIA
SMA
TAD INECH /O I TTY:?
SMA /FALLS THRU WITH -1;SO NO MOVE
JMP TERCON /NO. CONVERT TO ^X
TERMMV, IAC /WITH NEXT GIVES -2
TERNMV, CMA CLL /-1, ALSO MASK 140
TAD CHRCNT
DCA CHRCNT /MODIFIED CHAR.CNT.
TEROUT, TAD LOWIN /GIVE OUT STANDARD
JMS I DXOUT
TERCHK, TAD CHRCNT /CHECK IF OVERFLOW
SPA CLA
JMP I TERMNL /NO. GO BACK
TAD [215 /FALLS IN FROM LINE OVERFLOW
JMS I DXOUT
TERLFD, TAD LF
ISZ LINCNT /TEST IF AT END OF PAGE
JMP LINRES-1 /NO: GIVE LF
TERPS, JMS I [IOWAIT
TERLUP, ISZ LINCNT
JMP TERLUP
KSF
SKP
JMP TERLST
ISZ WAIT
JMP TERLUP
TERLST, TAD LF
JMS I DXOUT
TAD PAUS
DCA WAIT
TERRES, TAD PAGLEN /AT END *****
DCA LINCNT /RESET
JMP LINRES /NOW RESET LINE
TERCTL, TAD LOWIN /BUILD JUMP
TAD TERJMP
DCA .+1
HLT /MUST!! BE 6 AFTER 'TERRES'*****
JMP TERNMV /" 7":BELL;UNCHANGED;NO MOVE
JMP TERMMV /"10":BSPC; " " ;BACKUP CHAR.CNT.
JMP TERTAB /"11":HTAB
JMP TERLFD /"12":LF ;RESETS CHAR.CNT.
TERJMP, JMP TERRES /"13":VTAB;RESET
JMP TERFF /"14":FFED;SIMULATE
TAD [215 /"15":CRET;CRLF
JMS I DXOUT
LINRES, TAD LINLEN /RESET CHAR. CNTR.
DCA CHRCNT
JMP I TERMNL
/FORMFEED:
/HARDWARE /SOFTWARE
TERFF, TAD [214 / ISZ LINCNT
JMS I DXOUT / SKP
TAD [200 / JMP .+4
JMS I DXOUT / TAD LF
ISZ LINCNT / JMS I DXOUT
JMP .-3 / JMP TERFF
CLA STL IAC RAL /
JMP TERLST /
TERTAB, TAD (240
JMS I DXOUT
TAD CHRCNT
AND [7
SZA CLA
JMP TERTAB
JMP TERCHK /GO CHECK IF END OF LINE
TERCON, TAD LOWIN
JMS I (CONVER
JMP TEROUT
*COMBUF
IFNDEF KEY<
ZBLOCK 400
>
XLIST
EJECT DPF COMMAND DECODER AND INIT
XLIST
/FILE SECURITY DATAPLAN-FOCAL80
/TO BE ASSEMBLED WITH PARAMETER KEY=1
/CALL PROGRAM TO BE MODIFIED WITH COMMAND DECODER
/PROGRAM THAN SAVES AGAIN AND COMES BACK FOR MORE
/THE CODE NUMBER IS INDICATED IN FIRST CD CALL WITH
/=OPTION. FURTHER SPECS ASSUME INITIAL =CODE.
/IF DPF IS TO BE RECODED:INSERT THE CODE-NUMBER FIRST
/ADRESS FOR CODE-NUMBER IN DPF IS:00000
IFDEF KEY<
KEYER, CDF L
TAD I (CODENU /TRANSFER CODE-NUMBER
CIA
DCA TMCOD /NEG. TEMP.
TAD I (CODENU
DCA I (CODE /IN APPEN
CDF P
TAD I (BUFR /GET LENGTH OF PROGRAM
CDF L
DCA APPSTR
TAD APPSTR
DCA I (APBUF /KEEP FOR L CALL
TAD APPSTR
AND (177
DCA KRELOC /RELOCATION VALUE
TAD KRELOC
TAD (APPLEN-200 /DOES CODE FIT?
SPA CLA
JMP .+6 /YES
DCA KRELOC /NO RELOC
TAD APPSTR
TAD (200 /NEXT PAGE
AND (7600
DCA APPSTR /STORE TEMP
TAD APPSTR
TAD (APPLEN
CDF P
DCA I (BUFR /RESET BUFR
TAD (APPEN-2
DCA AUTO1
CMA
TAD APPSTR
DCA AUTO2
TAD (APPLEN
CIA
DCA COUNT
TAD KRELOC
DCA REL1
TRNSLP, CDF 0 /NOW TRANSFER APPEN TO FLD 2
TAD I AUTO1
SNA /ZERO ENDS RELOCATION
DCA REL1
SMA /DON'T RELOCATE IOTS&OPRS$JMPJMSS
TAD REL1
CDF 20
DCA I AUTO2
ISZ COUNT
JMP TRNSLP
TAD TMCOD
TAD I (LINE1
DCA I (PC0+1 /C(LINE1)-CODE TO PC0+1
TAD TMCOD
TAD I (LINE0
DCA I (LINE1 /C(LINE0)-CODE TO LINE1
DCA I (LINE0 /0 TO LINE0
TAD TMCOD
TAD APPSTR
IAC
DCA I (PC0+2 /APPEN ENTRY-CODE TO PC0+2
DCA I (LINE0-1 /NOT NEEDED ANY MORE
CDF 0
TAD I (APPJMP
MQL
TAD I (APPEN
TAD KRELOC /RELOCATE 'JMS .'
CDF T
ISZ APPSTR
DCA I APPSTR
TAD APPSTR
TAD (APPJMP-APPEN
DCA APPSTR
MQA
TAD KRELOC
DCA I APPSTR /RELOCATE 'JMP I APPBCK'
CDF L
TAD (RECORD&177+1200
DCA I (SAVEPT+4
TAD (WRFUN&177+1200
DCA I (BLLL-4
JMS I (SAVPR /NOW RESAVE PROGRAM
JMS I [DISMISS
CDF P
TAD (200
DCA I (PC
DCA I (LINENO
CDF T
TAD (GORETN-1
DCA I (PDLXR
CDF L
CLA IAC
JMP I (SETUP /BACK TO COMMAND DECODER
TMCOD, 0
APPSTR, 0
KRELOC, 0
REL1, 0
COUNT, 0
PAGE
/THIS PART IS MOVED TO FLD 2 AT THE END OF THE PROGRAM
SKP /FALLING IN WILL GIVE ERROR
APPEN, JMS . /ADRESS: C (PC0+2) + CODE
CMA /AC CARRIES C(PC0+2)=CODE-APPEN-1
TAD APPEN /AC=CODE
CIA
TAD CODE
SZA /IF ZERO ALL OK
JMP PCHK+12
DCA I PC02PT /CLEAR POINTER
TAD I LIN1PT
TAD CODE
DCA I LIN0PT /SET LINE0
TAD I PC01PT
TAD CODE
DCA I LIN1PT /SET LINE1
DCA I PC01PT
CDF 10
TAD SNACL
DCA I MODPT /KILL MODIFY
TAD DCALIN
DCA I WRITPT
DCA I WRIT1P /KILL WRITE
DCA I WRIT2P
CIF CDF 0
DCA I SVPTPT
TAD SAVMOD
DCA I BLM4PT /KILL SAVE
TAD APBUF /APPEN IN AC FOR BUFR
APPJMP, JMP I APPBCK
0 /END OF RELOC
APPBCK, KEYRES
CODE, 0
PC02PT, PC0+2
LIN1PT, LINE1
LIN0PT, LINE0
PC01PT, PC0+1
SNACL, SNA CLA
DCALIN, DCA LINENO
MODPT, MODIFY+4
WRITPT, WRITE
WRIT1P, WRITE+3
WRIT2P, WRITE+14
SVPTPT, SAVEPT+4
SAVMOD, TAD [OCLOSE /READ INSTEAD OF WRITE
BLM4PT, BLLL-4
APBUF, 0
APPLEN=.-APPEN+1
IFZERO APPLEN-70&4000 <APERR, ????>
PAGE
>
/MONTHS OF THE YEAR
MONAME, TEXT "--19"
*.-1
TEXT "JAN-"
*.-1
TEXT "FEB-"
*.-1
TEXT "MAR-"
*.-1
TEXT "APR-"
*.-1
TEXT "MAY-"
*.-1
TEXT "JUN-"
*.-1
TEXT "JUL-"
*.-1
TEXT "AUG-"
*.-1
TEXT "SEP-"
*.-1
TEXT "OCT-"
*.-1
TEXT "NOV-"
*.-1
TEXT "DEC-"
/DEVICE NAME TABLE: CODE
/ # OF OF INDEXED NAMES-1
/ DEVICE NAME
/7777 IN CODE ENDS LIST
/CODES IN INCREASING ORDER!
DVCDNM, 406 /
0
DEVICE DF
2426 /
0
DEVICE TV
4004 /
0
DEVICE HDX
4020 /
0
DEVICE LPT
4023 /
0
DEVICE LST
4024 /
0
DEVICE PTP
4215 /4217
2
DEVICE RL0A
4224 /
0
DEVICE PTR
4315 /4317
2
DEVICE RL1A
4415 /4417
2
DEVICE RL2A
4503 /4512
7
DEVICE CSA0
4513 /
0
DEVICE DIAB
4515 /4517
2
DEVICE RL3A
4573 /4576
3
DEVICE DKA0
4604 /4613
7
DEVICE DTA0
4631 /
0
DEVICE SYS
4673 /4676
3
DEVICE DKB0
5074 /5077
3
DEVICE SLU0
5524 /
0
DEVICE TTY
5604 /5613
7
DEVICE LTA0
5704 /5713
7
DEVICE MTA0
5723 /
0
DEVICE DSK
6002 /
0
DEVICE DBL
6003 /6012
7
DEVICE DSK0
6034 /
0
DEVICE COMM
6145 /
0
DEVICE DUMP
6362 /6371
7
DEVICE RBA0
6373 /6376
3
DEVICE RKA0
6410 /6417
7
DEVICE RXA0
6464 /6467
3
DEVICE SDA0
6473 /6476
3
DEVICE RKB0
6504 /
0
DEVICE CDR
6564 /6567
3
DEVICE SDB0
6601 /
0
DEVICE BAT
6605 /6614
7
DEVICE TUA0
7010 /7017
7
DEVICE VXA0
7241 /
0
DEVICE NULL
7310 /7317
7
DEVICE RXH0
7421 /
0
DEVICE LQP
7501 /7510
7
DEVICE LQP0
7777
PAGE
CDTBL, ZBLOCK 200
USRTBL, ZBLOCK 200
/FIRST TIME INITIALIZING FOR OS/8 FOCAL
SETUP, DCA CHAINS /REMEMBER CALL
CDF 0
CIF 10
JMS I (7700 /CALL USR
10 /LOCK IN
TAD CHAINS
SNA CLA
JMP NODECD
CIF 10
JMS I (200
5 /COMMAND DECODE
5200 /SPECIAL MODE
NODECD, TAD I (7777 /GET BOS WORD
AND (600 /EXTRACT EXT DATE
SNA
TAD (200 /78 IF NONE
CLL RTR
RTR
DCA YEAR /SAVE
DCA TEM7 /INIT COUNTER
CDF 10
TAD I (7666 /GET DATE WORD
AND (7 /EXTRACT MOD 8 YEAR
SNA
CLA CLL IAC RAL /80 IF NONE
TAD YEAR /ADD FOR 5 BIT YEAR
TAD (-12 /DIVIDE BY 10(10)
ISZ TEM7
SMA /DONE?
JMP .-3
TAD (6760-100+12
BSW /YES
TAD TEM7 /PUT IN 10'S
BSW
DCA YEAR /YEAR IN 2 6-BITS
TAD I (7666 /GET MONTH
AND (7400
BSW
CLL RAR
TAD (MONAME /ADDRESS OF NULL MONTH NAME
DCA TEM7
CDF 0
TAD I TEM7 /GET 'JA' FROM JAN-
DCA MONA
ISZ TEM7
TAD I TEM7 /GET 'N-' FROM JAN-
DCA LISA
CDF 10
STA
TAD I (36 /GET POINTER TO DEVNAM TABLE
CDF 0
DCA .+4
JMS I (MVCORE /MOVE TABLE DOWN
-20
CDF 10
HLT
CDF 0
USRTBL /IN BUFFER AREA
JMS I (MVCORE /MOVE FILE TABLE DOWN
-50
CDF 10
7600
CDF 0
CDTBL /ALSO IN BUFFER AREA
CIF 10
JMS I (200
11 /USROUT
JMS I (MVCORE /CLEAR OUTPUT BUFFER
-40
CDF 0
COMBUF
CDF 10
7600
TAD I (CDTBL+6 /CHECK IF NAME
SNA CLA
JMP I (GOSTRT /NO;RUN FCINIT(MAYBE)
TAD I (CDTBL+5 /GET DEVNO
JMS I (DNTONM /CONVERT
LINE3A+4
JMP I (DEVERR
JMS I (MVCORE
-3 /MOVE FILENAME
CDF 0
CDTBL+6
CDF 0
LINE3A+7
TAD I (CDTBL+11 /CHECK EXTENSION
SNA
TAD (617 /DEFAULT - FO
DCA I (LINE3A+13
JMP I (CHKINP
CHAINS, 0
PAGE
CHKINP, TAD I (CDTBL+12 /CHECK INPUT
SNA
JMP NOINPT+3 /SET TTY:,E
JMS I (DNTONM
LINE2A+4
JMP I (DEVERR
TAD I (CDTBL+13
SNA CLA
JMP NOINPT /NO NAME
JMS I (MVCORE
-3 /MOVE NAME
CDF 0
CDTBL+13
CDF 0
LINE2A+7
TAD (5640 /SET . FOR EXTNSN
DCA I (LINE2A+12
TAD I (CDTBL+16
SNA
TAD (604 /DEFAULT .FD
DCA I (LINE2A+13
NOINPT, JMS I (GESWIT
"I-300 /INPUT ECHO?
SKP
TAD (5405 /YES - SET ,E
DCA I (LINE2A+14
TAD I (CDTBL /GO ON WITH O O
SNA
JMP NOOUTP+3
JMS I (DNTONM
LINE1A+4
JMP I (DEVERR
TAD I (CDTBL+1
SNA CLA
JMP NOOUTP
JMS I (MVCORE
-3
CDF 0
CDTBL+1
CDF 0
LINE1A+7
TAD (5640
DCA I (LINE1A+12
TAD I (CDTBL+4
SNA
TAD (604
DCA I (LINE1A+13
NOOUTP, JMS I (GESWIT
"O-300
SKP
TAD (5405
DCA I (LINE1A+14
JMP MOD3
GOSTRT, JMS I (GESWIT /CHECK IF CHAIN TO FCINIT
"C-300
SKP CLA
MOD3, CLA IAC
CLL CML RAL /SETS MODE TO 1 OR 3
DCA I (MODE /FOR START OR GOTO
JMS I (GESWIT /NO FUNCTIONS?
"N-300
JMP .+4
TAD (CDF 10
JMS I (PATCH
NOFUNC
JMS I (GESWIT /REDUCED PRECISION?
"6-225
JMP I (FULPRC
TAD (CDF 10 /REDUCED PRECISION PATCHES
JMS I (PATCH
REDPRC
TAD (CDF 0
JMS I (PATCH
OTHVAR
JMS I (MVCORE
-31
CDF 0
DIVOVL
CDF 10
DUBDIV+10
JMS I (MVCORE
-36
CDF 0
NEWVAR
CDF 10
STSECR
JMP I (FULPRC
PAGE
FULPRC, JMS I (GESWIT
"B-300 /BACK SPACE TERMINAL?
JMP NOBCKS
JMS I (MVCORE
-6
CDF 0
BACKSP
CDF 10
FORW+11
NOBCKS, JMS I (GESWIT
"A-300 /MODIFY ASK TO COLON?
JMP NOCOL
TAD (":
JMP SETASK
NOCOL, JMS I (GESWIT
"R-300
JMP NOBEL
TAD (207 /BELL IN ASK
JMP SETASK
NOBEL, JMS I (GESWIT
"Q-300
JMP NOQUES
TAD ("? /? IN ASK
SETASK, CDF 10
DCA I (DIDO
CDF 0
NOQUES, JMS I (GESWIT
"P-300
JMP NOPAG
JMS I (MVCORE
-6
CDF 0
SFTFF
CDF 0
TERFF
NOPAG, CDF 10
TAD I (7726 /LOOK FOR SCOPE BIT
AND (200
SNA CLA
JMP NOSCOP
TAD (210 /BACKSPACE
DCA I (SPLAT /FOR RUBOUT
TAD (-120
DCA LINLEN
TAD (-30
DCA PAGLEN
TAD (-200
DCA PAUS
TAD PAUS
DCA WAIT
JMP SCOPMR
NOSCOP, TAD (ISZ ECHO
DCA I (DELSCP /KILL BS-SPACE-BS
SCOPMR, CDF 0
TAD I (CDTBL+42
AND (3777 /ELIMINATE ALT-MODE SWITCH
CIA
SNA
TAD PAGLEN
DCA PAGLEN
TAD I (CDTBL+46 /CHECK = OPTION
IFNDEF KEY <
CIA
SNA
TAD LINLEN /ALREADY DEFINED (SET?)
DCA LINLEN>
IFDEF KEY <
SNA
TAD I (CODENU
DCA I (CODENU
NOP>
TAD LINLEN
DCA CHRCNT
TAD PAGLEN
DCA LINCNT
NOTTWD, JMS I (GESWIT
"S-300 /SAVE SWITCH;GO BACK TO KM.
SKP
JMP I (7600 /WITH PATCHES SET
JMS I (GESWIT
"W-300 /WRITE PROGRAM?
JMP I (NOWRIT
TAD (340 /YES;SET L C;NO EXECUTION
DCA I (LINE3A+3
CLA CLL IAC CML RAL /'GO'=3
DCA I (MODE
TAD (ENDWRT /SET TO COME BACK HERE
CDF 10
DCA I (FORLEX+2
JMP I (NOWRIT+3 /SIMULATE ALT-MODE
ENDWRT, TAD (LEXIT /RESET
CDF 10
DCA I (FORLEX+2
TAD (200
DCA I (PC
CDF 20
TAD (GORETN-1
DCA I (PDLXR /RESET PDL FOR RETURN
CDF 0
CLA CLL IAC RTL /'WRITE'=4
JMP I (CHENTR
PAGE
NOWRIT, JMS I (GESWIT
0 /CHECK ALT-ESC
JMP NOALTM /NONE
CDF 10 /YES CHANGE EXIT
TAD (FORLEX
DCA I (START
CDF 0
JMP YESGO
NOALTM, JMS I (GESWIT /CHECK IF GO
"G-300
SKP CLA
JMP YESGO
TAD (340
DCA I (LINE3A+3 /SET L C
YESGO, CMA
TAD MODE
SZA CLA /IF START ERASE ALL
JMP NOSTRT
DCA I (LINE0A
TAD (LINE1
CDF 10
DCA I (BUFR
CDF 0
NOSTRT, TAD CHNDCA
DCA I (CHENTR /RESET CHAIN ENTRY
JMS I (MVCORE /NOW MOVE HEADER UP
-400
CDF 0
POPSUB
CDF 20
0
JMS I (MVCORE /AND PDL (WIPE OUT BATCH?)
-100
CDF 0
PDLMON
CDF 20
7500
CDEXIT, IFNDEF KEY <JMS I (COCLR>
TAD MODE /GO TO FOCAL
JMP I (CHENTR
MODE, 0
CHNDCA, STRTSW&177+3200
PAGE
/MOVE CORE ROUTINE: JMS MVCORE
/ -# OF WORDS
/ CDF FROM
/ ADRESS FROM
/ CDF TO
/ ADRESS TO
MVCORE, 0
TAD I MVCORE
DCA MVCNT
ISZ MVCORE
TAD I MVCORE
DCA FRMCDF
ISZ MVCORE
TAD I MVCORE
DCA MVPTFR
ISZ MVCORE
TAD I MVCORE
DCA TOCDF
ISZ MVCORE
TAD I MVCORE
DCA MVPTTO
ISZ MVCORE
FRMCDF, HLT
TAD I MVPTFR
ISZ MVPTFR
TOCDF, HLT
DCA I MVPTTO
ISZ MVPTTO
ISZ MVCNT
JMP FRMCDF
CDF 0
JMP I MVCORE
MVCNT, 0
MVPTFR, 0
MVPTTO, 0
/GET A SWITCH ROUTINE: JMS GESWIT
/ CODE: ALTESC=0,A-Z="X-300,0-9="#-225
/ RETURN NOT SET
/ RETURN SET
GESWIT, 0
TAD I GESWIT
CIA
DCA SWITNU /SAVE SWITCH NUMBER NEGATIVE
TAD SWILOC
DCA SWIPNT /RESET POINTER
TAD SWITNU
SZA CLA /ALT-ESC?
JMP NEXSWI /NO
CLA CMA /YES
DCA SWITNU /ROTATE ONLY ONCE
SKP /KEEP POINTER AT FIRST WORD
NEXSWI, ISZ SWIPNT /NEXT WORD
CLA CLL CML /SET MASK-BIT
SWILUP, RAR
SZL /AT END OF WORD?
JMP NEXSWI /YES;TO NEXT WORD,DON'T BUMP SWITNU
ISZ SWITNU /RIGHT LOC?
JMP SWILUP /NO;SHIFT MORE
AND I SWIPNT /YES;AND MASK WITH SWITCH
ISZ GESWIT
SZA CLA /BIT SET?
ISZ GESWIT /YES;BUMP RETURN
JMP I GESWIT
SWITNU, 0
SWIPNT, 0
SWILOC, CDTBL+42
/DEVICE CODE TO NAME AND STORE ROUTINE
/ TAD DEVNO
/ JMS DNTONM
/ ADRESS FOR STORE
/ ERROR RETURN (NOT IN LIST)
/ NORMAL RETURN (STORED)
DNTONM, 0
AND (17 /TAKE DEVICE BITS
TAD (USRTBL /ADRESS OF TABLE
DCA DNPTR
TAD I DNTONM
DCA PUTDCN /SET ADRESS FOR STORE
ISZ DNTONM /AT ERROR RETURN
TAD I DNPTR /GET USR DEVICE NAME
CIA
DCA DCCODE
TAD (DVCDNM /START SEARCH
DCA DNPTR
DNLOOP, CLA CLL
TAD DCCODE
TAD I DNPTR /GET CODE,IS IT .GE. DCCODE?
ISZ DNPTR
SNA
JMP DNFND+2 /EXACT
SZL
JMP DNEXIT /NOT IN LIST
TAD I DNPTR /SEE IF WE GET AN INDEXED NAME
SZL
JMP DNFND /YES;OVERFLOW IS MAX#-#
ISZ DNPTR
ISZ DNPTR /BUMP POINTER-SEARCH ON
ISZ DNPTR
JMP DNLOOP
DNFND, CIA /#-MAX#
TAD I DNPTR /#
MQL
ISZ DNPTR
TAD I DNPTR /TRANSFER NAME
DCA I PUTDCN
ISZ DNPTR
ISZ PUTDCN
MQA /ADD IN NUMBER
TAD I DNPTR
DCA I PUTDCN
ISZ DNTONM /NORMAL RETURN
DNEXIT, CLA CLL
JMP I DNTONM
DNPTR, 0
PUTDCN, 0
DCCODE, 0
PATCH, 0 /ROUTINE PATCH CDF ADRESS OF TABLE
DCA PATCDF /COMES IN WITH CDF X
TAD I PATCH /GET LIST ADRESS
ISZ PATCH
DCA PATATO
PATLUP, TAD I PATATO /GET ADRESS TO PATCH
SNA
JMP I PATCH /0 ENDS LIST
DCA PATTER
ISZ PATATO
TAD I PATATO /A LA RIM LOADER
PATCDF, HLT
DCA I PATTER
CDF 0
ISZ PATATO
JMP PATLUP
PATATO, 0
PATTER, 0
DEVERR, CIF 10 /USER ERROR 7
JMS I (7700
7
7
PAGE
FIELD 0
*6000
POPSUB=.
RELOC 0
/GETS LOADED IN FIELD 2
/CORE MAP: /0-177: PDL SUBROUTINES
/200-X: TEXT
/X-7545: PUSHDOWN LIST
/7546-7577: MONTHS OF THE YEAR
0 /FOR RUBOUT PROTECTION;SEE RUB1
PSHBUF, BUFR /INDIRECT FOR TEXT PROTECTION
PSHCDF, CDF 0
PSHERR, ERROL+3 /POINTER TO ERRROR ROUTINE
0
0 /FOR ODT
0
PSHCNT, 0
PSHAX, 0
PDLXR, GORETN-1 /MAIN AX FOR PDL
PSHM4, -4
PSHMSK, 7
POPOVR, 376-1 /PO=PDL. OVERFLOW
PSHM5, -5
FLDCDI, HLT /CDI CURRENT
JMP I FLDRET /EXIT
FLDRET, 0
ZPOPA, 0 /ONE ITEM FROM PDL TO AC;OLD AC IN MQ
JMS FLDSET
TAD I PDLXR
JMP FLDCDI /NO INC RETURN
ZPUSHA, 0 /AC TO PDL;AC TO MQ
JMS FLDSET
CLA CMA
JMS PCHK
MQA
DCA I PDLXR
CLA CMA
JMS PCHK
JMP FLDCDI /NO INC RETURN
/LOCAL FIELD SATELLITES FOR ALL POPS EXCEPT
/POPJ MUST BE AS FOLLOWS:
/XPOPU, 0
/ MQL
/ FLDCUR (DEFINED ON OTHER PAGE)
/ CIF T (WHERE T IS FIELD OF POP SUBS.)
/ JMS I .+1
/ ZPOPU
/FLDCUR=CLA FOR FIELD 0
/ =CLA IAC 1
/ =CLA IAC RAL 2
/ =CLA CLL CML IAC RAL 3
/ =CLA IAC RTL 4
/ =CLA CLL CMA RTL 5
/ =CLA CLL CMA RAL 6
/ =CLA CMA 7
FLDSET, 0 /SUBROUTINE FOR ANALYZING FIELDS AND ADRESSES
AND PSHMSK /TAKE ONLY 7 BITS
CLL RAL
RTL
TAD PSHCDF
DCA FLDCDF /CALLING DATA FIELD
TAD PSHCDF /NOW LET'S SEE WHICH D.F. HE PUT
RDF
DCA ACCES /ACCES DATA FIELD
CDF T /THIS FIELD
CLA CLL CMA RAL /JMS FLDSET ALWAYS FIRST INSTR. OF ZPOPU'S
TAD FLDSET /ZPOPU+2
DCA FLDRET /NOW BECAUSE OF STANDARD FORM OF SATELLITES
TAD PSHM5 /-5 PLUS THE
TAD I FLDRET /CONT. OF ZPOPU ENTRY,GIVES ADRESS OF XPOPU
DCA FLDRET
FLDCDF, HLT /CHANGE TO CALLING D.F.
TAD I FLDRET /THIS IS ADRESS OF ARG.
DCA FLDRET /AND FINAL RETURN ADD. FOR POPA,PUSHA
CLA CMA /FOR RELATIVE ADRESSING:'TAD FLDRET'
TAD I FLDRET /ARGUMENT-1 FOR AX
DCA PSHAX
CLA CLL IAC RAL /BUILD A CIF CDF CALLING FIELD
TAD FLDCDF /FOR FINAL RETURN
DCA FLDCDI
CDF T /BACK TO THIS FIELD
JMP I FLDSET
/BY THE WAY: THE DATA FIELD IS ALWAYS RESET TO CURRENT
/THIS CAN BE USEFUL
/CALLS IN A PROGRAM WILL LOOK LIKE THIS:
/CDF ACCES
/PUSHF
/ LOC /RELATIVE: LOC-.-1
/WILL PUSH 4 WORDS STARTING IN LOC IN FIELD ACCES
ZPUSHF, 0 /4 WORDS IN PDL;AC CONSERVED;AC TO MQ
JMS FLDSET
TAD PSHM4
JMS PCHK
TAD PSHM4
DCA PSHCNT
ACCES, HLT /SET BY FLDSET
TAD I PSHAX /""
CDF T
DCA I PDLXR /STORE IN PDL
ISZ PSHCNT
JMP ACCES /LOOP
TAD PSHM4
JMS PCHK /RESET PDLXR
PSHFEX, MQA /RESTORE AC
ISZ FLDRET /BUMP PAST ARG
JMP FLDCDI
ZPOPF, 0 /4 WORDS FROM PDL IN LOC;AC CONSERVED;AC TO MQ
JMS FLDSET
TAD PSHM4
DCA PSHCNT
TAD ACCES /RELOCATE CDF ACCES
DCA .+3
POPLOP, CDF T
TAD I PDLXR
HLT
DCA I PSHAX
ISZ PSHCNT
JMP POPLOP /LOOP
JMP PSHFEX /SAME RETURN AS ZPUSHF
/!!!!!
/POPJ IS THE ONLY POPU THAT NEEDS ANOTHER SATELLITE!
/XPOPJ, CIF CDF T
/ JMP I .+1 /JMP!!
/ ZPOPJ
ZPUSHJ, 0 /GO TO ARG IN ACCES;CDF ALSO ACCES;AC CONSERVED
JMS FLDSET /AC TO MQ
CLA CLL CMA RAL /-2
JMS PCHK
IAC /TO BUMP PAST ARG
TAD FLDRET /RETURN AFTER POPJ
DCA I PDLXR
TAD FLDCDI /CDI AFTER POPJ
DCA I PDLXR
CLA CLL CMA RAL
JMS PCHK
CLA CLL IAC RAL
TAD ACCES /BUILD CDI ACCES
DCA .+2
MQA
HLT
JMP I PSHAX /!!
ZPOPJ, TAD I PDLXR /AC INCS RETURN AND IS LOST;MQ CONSERVED
DCA FLDRET
TAD I PDLXR
DCA FLDCDI
JMP FLDCDI
PCHK, 0 /SUB TO BACKUP PDL AND CHECK OVERFLOW
TAD PDLXR /AC COMES IN WITH AMOUNT OF BACKUP
DCA PDLXR
TAD PDLXR
CIA CLL
CDF P /SOME OTHER FIELD
TAD I PSHBUF /GET LOWER BOUNDARY
CDF T
SNL CLA
JMP I PCHK /NO OVERFLOW
TAD POPOVR
CIF CDF L
JMP I PSHERR
VPOPA=JMS I . /FOR FIELD T POPS
NOP
VPUSHA=JMS I .
NOP
VPUSHJ=JMS I .
NOP
VPOPJ=JMP I .
NOP
VPUSHF=JMS I .
NOP
VPOPF=JMS I .
NOP
RELOC
*6200
RELOC 200
PC0, 0 /TEXT BUFFER HEAD
0 /OR C(LINE1)-CODE *KEY*
0 /OR APPEN-CODE *KEY*
0
0
5051 /LPAR,RPAR FOR DUMP
BUFR
LINE4+1 /OR '0' *KEY*
LINE0, LINE1
LINE0A=LINE0+POPSUB
0
IFNDEF KEY < TEXT "C-DATAPLAN FOCAL80" >
IFDEF KEY < TEXT "C-DATAPLAN FOKEY80" >
*.-1
7715 /DUMMY CR
LINE1A=.+POPSUB
/TEXT FOR AUTOMATIC LOADING AFTER CHAIN
LINE1, LINE2 /OR C(LINE0)-CODE *KEY*
212 /LINE 1.1
TEXT "O O TTY : ,E"
*.-1
7715
LINE2A=.+POPSUB
LINE2, LINE3
224 /LINE 1.2
TEXT "O I TTY : ,E"
*.-1
7715
LINE3A=.+POPSUB
LINE3, 0000
236 /LINE 1.3
TEXT "L R DSK : FCINIT. FO <00.0> "
*.-1
7715
LINE4A=.+POPSUB
LINE4=.
7715
7715
RELOC
/OVERLAYS
DIVOVL=.
RELOC DUBDIV+10
TAD AC1L
TAD LORD
DCA MP2
RAL
TAD HORD
TAD AC1H
SNL
JMP .+4
DCA HORD
TAD MP2
DCA LORD
CLA
TAD MP1
RAL
DCA MP1
TAD MP4
RAL
DCA MP4
ISZ MP3
JMP DV3
TAD MP1
DCA LORD
TAD MP4
DCA HORD
JMP I DUBDIV
RELOC
BACKSP=.
RELOC FORW+11 /FOR TERMINAL WITH BS
JMP .+2
TAD M30
TAD SPC
DCA T3
M30, -30
TAD T3
RELOC
SFTFF=.
RELOC TERFF /FOR SIMULATED FF'S
ISZ LINCNT
SKP
JMP .+4
TAD LF
JMS I DXOUT
JMP TERFF
RELOC
NEWVAR=.
RELOC STSECR
4400
0000
0013
DOLL1, 0001
0000
4300
NMBSG1=.+2
ZBLOCK 4
4100
EXCLA1=.+2
ZBLOCK 4
4200
QUOTS1=.+2
ZBLOCK 4
2011 /PI
0000
0002
3110
3756
2605 /VERSION NUMBER 40.1
0000
0006
2403
1463
STVAR1=.
RELOC
PDLMON=.
RELOC 7500
ZBLOCK 36
GORETN, INPUTX+2 /RETURN FOR GOTO
CIF CDF P
ZBLOCK 40
PDLEND=.
RELOC
/PATCHES
NOFUNC, VARTOP /
XSQRT-10
FNTABF+11 /
ERCALL
FNTABF+13 /
ERCALL
FNTABF+15 /
ERCALL
FNTABF+17 /
ERCALL
FNTABF+21 /
ERCALL
FNTABF+23 /
ERCALL
0000
OTHVAR, /XNMBSG /
/ NMBSG1
/ XEXCLA /
/ EXCLA1
/ XQUOTS /
/ QUOTS1
XDOL /
DOLL1
0000
REDPRC, LASTV /ADRESS
STVAR1
END /
STVAR1
FSIZE /
6
DECP /
3
GINC /
5
MFLT /
-3
DIGITS /
7
TWOPI+2 /
3756
PI+2 /
3756
PIOT+2 /
3756
PTEN+2 /
3147
FPNT+3 /
DCA OVER1
FPNT+4 /
DCA OVER2
ZERO+20 /
DCA OVER1
TEST2 /
27
DMULT+32 /
DMDONE&177+5200
DMDONE+7 /
DCA OVER2
MULDIV+4 /
ISZ OVER2
MIF /
-27
0000
FIELD 0
*200
$$$$