Directory of image this file is from
This file as a plain text file
/EDUSYSTEM 25
/
/DEC-08-ED25A-A-LA
/
/COPYRIGHT 1972,1973
/
/DIGITAL EQUIPMENT CORPORATION
/
/MAYNARD, MASSACHUSETTS 01754
/
/EDUSYSTEM 25 BASIC
/19 FEBRUARY 1973
/EDUSYSTEM 25 BASIC
/MARK BRAMHALL
/DIGITAL EQUIPMENT CORP.
/BARRY SMITH
/STEVE POULSEN
/OREGON MUSEUM OF SCIENCE & INDUSTRY
/JOHN O'DONNELL
/YALE UNIVERSITY
/REVISIONS AND CORRECTIONS:
/MARK ROSENTHAL
/JAMES DEMPSEY
/DIGITAL EQUIPMENT CORP.
/EDUSYSTEM 25 BASIC IS FOR THE PDP-8/E, -8/F, -8/M, -8/I, -8/L WITH
/12K OR MORE MEMORY AND EITHER THE DC02 OR PT08(KL8E) OPTION
/AND TC08 DECTAPE CONTROLLER WITH TU56 OR TWO TU55 TRANSPORT(S)
/OR RK8E DISK
/NOTE: START ADDRESS IS 20200.
/DEFINITIONS
FIXMRI FGET=0000 /FLOATING INSTRUCTIONS
FIXMRI FADD=1000
FIXMRI FSUB=2000
FIXMRI FMUL=3000
FIXMRI FDIV=4000
FIXMRI FJMP=5000
FIXMRI FCMP=6000
FIXMRI FPUT=7000
FINT=JMS I 7
FEXT=0000
FXIT=0000
FNOR=6010
FSKP=6000
FSNE=6040
FSEQ=6050
FSGE=6100
FSLT=6110
FSGT=6140
FSLE=6150
DTLA=6766
CAF=6007
BSW=7002
MQL=7421
MQA=7501
SPL=6102
MTKF=6123
MTPF=6113
MTON=6117
MINT=6115
MINS=6125
MKSF=6111
MKRB=6116
MTSF=6121
MTCF=6122
MTLS=6126
L0001=CLL CLA IAC
L0004=CLL CLA IAC RTL
L0003=CLL CLA CML IAC RAL
L7777=CLL CLA CMA
L7776=CLL CLA CMA RAL
L7775=CLL CLA CMA RTL
L3777=CLL CLA CMA RAR
L5777=CLL CLA CMA RTR
L4000=CLL CLA CML RAR
L2000=CLL CLA CML RTR
L0002=CLL CLA CML RTL
SWAP=10
/PAGE ZERO
FIELD 0
PAGE 0
0
JMP I .+1 /INTERRUPT HANDLER
INTR8E
USER, 0 /INTERRUPT USER COUNTER
SIN, 0 /INTERRUPT TEMPORARY
TEMP1, 0 /INTERRUPT TEMP
TEMP2, USER0 /INTERRUPT TEMP
FPNT /FLOATING POINT
XREG, 0 /INTERRUPT XREG
XREG2, 0 /INTERRUPT XREG
XREG3, 0 /GENERAL XREG
FLTXR, 0 /FLOATING XREG
FLTXR2, 0 /FLOATING XREG
/ CHANGING THE SWAP AREA???????
/BE SURE TO TAKE A LOOK AT BEG800
/TO MAKE SURE THE AREAS ARE ALIGNED PROPERLY
/WITH THE DUMMY HERE!!!!
STSWAP=. /START OF SWAP
PDLXR, TOP /PUSH-DOWN XREG
AXIN, 0 /PACKING XREG
TEXTP=. /TEXT POINTERS
AXOUT, 0 /UNPACK XREG
GTEM, 0 /UNPACK SWITCH
XCT, 0 /UNPACK SWITCH
PC, READY /PROGRAM RESTART
ADD, 0 /PACK TEMPORARY
XCTIN, 0 /PACK SWITCH
SUBS=XCTIN /SUBSCRIPT
PT1, 0 /FLOATING POINTER
CHAR, 0 /CHARACTER
LINEPC, 0 /LINE POINTER
LINENO, 0 /LINE NUMBER
LASTLN, 0 /LAST LINE POINTER
MODE=LASTLN /FOR MINI-STRINGS
SPACSW, 0 /0 IS IGNORE SPACES
DINPUT, -1 /-1 FOR BREAK ON CR ONLY
/0 FOR BREAK ON ANY AND NO ECHO
OUTPUT, 0 /0 IS ECHO
XIOT, KRB /INPUT IOT
XFIELD, 0 /USER FIELD
DATAPC, 0 /LINE NUMBER OF DATA STATEMENT
0 /DATA POINTER
0 /DATA TEMPORARY
0 /DATA UNPACK SWITCH
0 /DATA CHARACTER
IPTRI, BUFFER /INPUT BUFFER FILL
IPTRO, BUFFER /INPUT BUFFER EMPTY
IPTR0, BUFFER /START OF BUFFER
OPTRI, BUFFER-40 /OUTPUT BUFFER FILL
OPTRO, BUFFER-40 /OUTPUT BUFFER EMPTY
TELSW, 0 /TTY BUSY SWITCH
PACKST, 0 /START OF PACKING
PACKND, 0 /POINTER TO END OF PACKING
BUFR, LINE1 /NEXT FREE SPACE
STARTV=BUFR /START OF VARIABLES
LASTV, LINE1 /LAST DEFINED VARIABLE
PDLST, TOP /START OF PUSH-DOWN
ALINE0, LINE0 /POINTER TO DUMMY LINE
COMBUF, BUFCOM /COMMAND BUFFER
PRNTC1, 0 /PRINT ZONE COUNT
ERLINE, 0 /ERROR LINE
NAME, 1617 /PROGRAM NAME
1605
0
READC=JMS I .
PREADC, XREADC
PRINTC=JMS I .
PPRINT, XPRNTC
FREE2=JMS I .
PFREE2, XFREE2
FREE13=JMS I .
PFREE3, XFREE3
BASE, 5400
IPNTR, 0
I3, 0
IBLK, 0
IBLKH, 0
OPNTR, 0
O3, 0
OBLK, 0
OBLKH, 0
OMAX, 0
CHAINP, READY /'CHAIN' POINTER
FRNDX, 0001
0203
5555
ENSWAP=.-1 /END OF SWAP
DECK=XFIELD /USER ON DECK
SORTCN, 0 /SORT CONSTANT
T1, 0 /THREE TEMPS
T2, 0
CNTR, 0 /COUNTER
T3, 0
THISOP, 0 /CURRENT OP
LASTOP, 0 /LAST OP
EFOP=CNTR /FUNCTION OP
LOOK, USER0-1 /USER BEING RUN OR LOOKED AT
/SET TO USER4-5+#USERS IN INIT
LOOKST, USER0-1 /TO RESET LOOKING
FLARGP, FLARG /POINTER TO TEMP FLAC
INTEGE, FIX /FIX THE FLAC ROUTINE
/KEEP THE NEXT 8 LOCATIONS TOGETHER PLEASE.
CCR, 15 /CR
C7, 7 /BELL
C177, 177 /RUBOUT
C137, 137 /BACK ARROW
LSTMOD, -1 /SET BY *INPUT*
C14, 14 /FF
CLF, 12 /LINE FEED
M12, -12 /-10 DECIMAL
C77, 77 /RIGHT MASK
M6, -6 /MESSAGE LENGTH
C10, 10
M10, -10
M100, -100 /CHARACTER TEST
C7700=M100 /LEFT MASK
M4, -4 /CHARACTER COUNT
C100, 100 /USED IN XGETL
C40, 40
/NEW INSTRUCTIONS
GETC=JMS I . /UNPACK A CHAR
XGETC
SORTJ=JMS I . /SORT JUMP
XSORTJ
SORTC=JMS I . /SORT
ASORTC, XSORTC
PUSHA=JMS I . /SAVE AC
XPUSHA
PUSHJ=JMS I . /PUSH JUMP
XPUSHJ
PUSHF=JMS I . /SAVE FLOATING DATA
XPUSHF
POPA=JMS I . /RESTORE AC
XPOPA
POPJ=JMP I . /POP JUMP
XPOPJ
POPF=JMS I . /RESTORE FLOATING DATA
XPOPF
FLGET=JMS I . /FLOATING GET
XFLGET
FLPUT=JMS I . /FLOATING PUT
XFLPUT
PRINTX=JMS I . /DO OUTPUT
XOUTL
ERROR=JMS I . /ERROR
XERROR
UDF=JMS I . /USER DATA FIELD
AUDF, XUDF
RTL6=JMS I . /SIX RAL*S
XRTL6
TESTN=JMS I . /TEST NUMERIC
XTESTN
TESTC=JMS I . /TEST CHAR
XTESTC
PACKC=JMS I . /PACK A CHAR
XPACKC
GETLN=JMS I . /GET A LINE NUMBER
XGETLN
TSTCCR=JMS I . /SKIP IF CR
CCRTST
TSTCOM=JMS I . /SKIP IF COMMA
COMTST
TSTALP=JMS I . /SKIP IF LETTER
ALPTST
COMMAN=JMS I . /DETERMINE COMMAND
MANCOM
FIND=JMS I . /FIND A STATEMENT
XFIND
GETNXT=JMS I . /GET NEXT LINE
NXTGET
FINDLN=JMS I . /FIND A LINE
XFINDL
TSTEND=JMS I . /TEST FOR END OF LINE
ENDTST
TSTLPR=JMS I . /SKIP IF L-PAREN
LPRTST
GETSGN=TAD I FLARGP
/MAINLINE BASIC
/WHENEVER THERE IS NOTHING BETTER TO DO OR A JOB WANTS TO
/DISMISS ITSELF SO OTHERS CAN TRY THIS ROUTINE IS ENTERED
/IT KEEPS LOOKING FOR A JOB WITH BITS 0 AND 1 OFF WHICH
/SAYS THAT THE JOB IS NOT WAITING FOR INPUT OR OUTPUT
/RESPECTIVLY
*177
NULL, ION
CDF
TAD LOOK
TAD MLOOKE /CHECK POSITION OF POINTER
SPA CLA
JMP .+3 /O.K. TO LOOK AT NEXT
KL8JMP, TAD LOOKST /IF 8-E WITH DC02, INIT ALTERS THIS TO:
/JMP I .+1 (5606)
/KL8FIX
DCA LOOK /RESET POINTER
ISZ LOOK /LOOK AT NEXT
TAD I LOOK /GET STATUS
AND C7700
SZA CLA
JMP NULL /NO GO
DCA PRNT5 /CLEAR FORMAT SWITCH
TAD I LOOK /GET STATUS
IOF /NO INTERRUPTS
JMS DECKON /PUT HIM ONDECK
TAD PC
DCA 0 /RESTART LOCATION
L7776 /NUMBER OF COMMANDS THEN LOOK
DCA PC
ION
JMP I 0 /GO TO IT...
C60, 60
MLOOKE, -USER4+5 /LAST STATUS WORD : SUBTRACT NUMBER OF USERS
/DURING INIT
/*PRNTIT* ROUTINE
/ENTER WITH THE AC CONTAINING THE VALUE TO BE PRINTED AS
/A DECIMAL NUMBER BETWEEN 0 AND 2047
/IF PRNT5 IS NOT 0 THEN LEADING SPACES ARE NOT PRINTED
/PRNT5 IS SET TO 0 AT THE END OF THE ROUTINE
ITPRNT, 0
DCA T1
DCA FLTXR /SIGNIFICANCE TESTER
L7775
DCA CNTR /DO 3 LOOPS
TAD (PRNTLL
DCA T2 /LIST OF SUBTRACTIONS
PRNT1, DCA T3 /HOLDS DIGIT
JMP .+3
ISZ T3 /BUMP DIGIT
DCA T1
TAD T1
TAD I T2 /SUBTRACT
SMA
JMP .-5
CLA
ISZ T2 /POINT TO NEXT
TAD T3 /GET DIGIT
SZA
JMP PRNT2 /NON-ZERO
TAD FLTXR /SIG YET
SNA CLA
JMP PRNT3 /NO
PRNT2, ISZ FLTXR /NOW SIG
TAD C60
PRNT4, PRINTC /PRINT IT
PRNT7, ISZ CNTR
JMP PRNT1 /LOOP
TAD T1
TAD C60
PRINTC /UNITS DIGIT
TAD PRNT5 /FORMATING
SZA CLA
JMP PRNT6 /NO
TAD C40
PRINTC /PRINT SPACE AFTER
PRNT6, DCA PRNT5 /RESET FOR LATER
JMP I ITPRNT
PRNT5, 0
PRNT3, TAD PRNT5 /FORMATTING
SZA CLA
JMP PRNT7 /NO
TAD C40
JMP PRNT4
/*ONDECK* ROUTINE
/ROUTINE TO PUT A USER "ON DECK"
/ENTER WITH HIS NUMBER ON AC BITS 9-11
DECKON, NULL
AND C7 /USER NUMBER ONLY
DCA SIN /SAVE NEW
TAD DECK
CIA
TAD SIN
SNA CLA
JMP DTCHK /FAST EXIT (BUT CHECK TAPE FIRST)
TAD DECK
JMS DFIND /LOCATE OLD
TAD LSTMOD
DCA DINPUT
TAD I (XUDF+1
DCA XFIELD
/* THIS SWAP ROUTINE EXECUTES WITH INTERRUPT OFF
/* AND TAKES APPROXIMATELY 600 MICROSECONDS TO
/* EXECUTE, WHEREAS THE MAXIMUM TIME AVAILABLE
/* TO ANSWER A DECTAPE INTERRUPT AFTER A SEARCH
/* IS 400 MICROSECONDS. THEREFORE, WE MUST CHECK
/* THE DECTAPE FLAG AS PART OF THE INNER LOOP.
TAD I XREG2
CIF CDF SWAP
DCA I XREG /SWAP OUT OLD
JMS DTINTR /CHECK TAPE
ISZ TEMP2
JMP .-5
TAD SIN
JMS DFIND /LOCATE NEW
ENTRY1, CIF CDF SWAP
TAD I XREG
JMS DTINTR /CHECK TAPE
DCA I XREG2 /SWAP IN NEW
ISZ TEMP2
JMP .-5
TAD DINPUT
DCA LSTMOD
TAD XFIELD
DCA I (XUDF+1
TAD SIN
DCA DECK /NEW USER ONDECK
TAD LOOKST
IAC
TAD DECK
DCA TEMP2 /POINT TO STATUS
DTCHK, CIF CDF SWAP
JMS DTINTR
JMP I DECKON
DFIND, ENTRY1
ENTRY, CMA
DCA TEMP2
TAD (ORG1-1-ENSWAP+STSWAP-1 /START AT THE BEGINNING
TAD STARTP /SPACE BETWEEN
ISZ TEMP2
JMP .-2
DCA XREG /POINT TO USER
TAD (STSWAP-1
DCA XREG2 /POINT TO SWAP AREA
TAD (STSWAP-ENSWAP-1
DCA TEMP2 /SWAP COUNT
JMP I DFIND
STARTP, ENSWAP-STSWAP+1 /SPACE BETWEEN
PAGE
/ERROR ROUTINE
/HERE IS WHERE ERROR MESSAGES ARE PRINTED
/IT IS CALLED BY A DISMISSAL WITH THE PC SET TO
/ERRORX AND THE ERROR ADDRESS IN LSTMOD
ERRORX, JMS I (IOFIX /CLEAN UP FILES
TAD I (DTQ1 /CLEAR DECTAPE QUEUE
DCA T3 /(IF NECESSARY)
TAD DECK /ARE WE ON TOP?
CMA
TAD I T3
SNA CLA
JMS I (DTFREE /REMOVE US FROM THE QUEUE
FREE13 /GET ROOM
TAD M40
DCA T3 /BUFFER IS 40 LONG
L7777
TAD IPTR0
DCA XREG3 /POINT TO I BUFFER
UDF
DCA I XREG3 /CLEAR BUFFER
ISZ T3
JMP .-2
CDF
TAD IPTRI
DCA IPTRO /NO INPUT IN BUFFER
DCA OUTPUT /HAVE ECHO
TAD LSTMOD /GET ERROR CODE
SORTC
ERRLST-1
TAD M4
TAD SORTCN
SMA SZA
JMP ERROR2 /TRUE ERROR
SZA CLA
L7775 /WHAT?
TAD C16 /STOP
SKP
ERROR2, L7777
JMS I (READY1 /PRINT ERROR MESSAGE
TAD M4
TAD SORTCN
SPA SNA
JMP ERROR3 /NO NUMBER WITH THESE
JMS I PITPRNT /PRINT ERROR NUMBER
TAD ERLINE /WERE WE RUNNING
SPA SNA CLA
JMP ERROR1 /NO
FREE13
GETC
PRINTC /I
GETC
PRINTC /N
TAD C40
PRINTC
TAD ERLINE
JMS I PITPRNT /PRINT LINE IN ERROR
ERROR1, TAD CCR
PRINTC
ERROR3, CLA
/*READY* ROUTINE
/ROUTINE TO PRINT "READY" AND RESET POINTERS
/ENTER THE ROUTINE AT START TO OMIT READY MESSAGE
READY, JMS I (IOFIX /RESET FILES
FREE13
L0003
JMS I (READY1 /PRINT "READY"
GETC
PRINTC
START, DCA ERLINE /IMMEDIATE MODE
L7777
DCA LSTMOD /SHORT LIST
TAD PDLST
DCA PDLXR /RESET PUSH-DOWN
DCA SPACSW /IGNORE LEADING SPACES
DCA MODE /CLEAR STRING MODE FLAG
TAD (ERR330
PUSHA /TRAP THE *RETURN* SANS *GOSUB*
PUSHJ /INPUT COMMAND LINE
PAKLIN
SZA CLA /END-OF-FILE?
JMP I CHAINP /'OLD' OR 'CHAIN' FINISHED
/INSERT LINE OR DO COMMAND
/AFTER A COMMAND OR LINE IS PACKED INTO THE COMMAND BUFFER
/THIS ROUTINE LOOKS AT IT AND EITHER STORES THE LINE OR
/GOES TO THE PROPER COMMAND
DECODE, TESTN
PITPRNT, ITPRNT
JMP I (INPUTX /COMMAND
GETLN /GET LINE NUMBER
SRETN, TAD BUFR
DCA AXIN /SET TO REPACK
DCA XCTIN
TAD LINENO
UDF
DCA I AXIN /SET LINE NUMBER
CDF
TSTCCR /JUST LINE NUMBER
JMP .+3 /NO
JMS I (XDELET /DELETE THIS LINE
JMP START
ISZ SPACSW /KEEP SPACES
M40, SMA SZA CLA /TSTCCR LEAVES AC=0 SO THIS IS A SKP.
GETC
PACKC /REPACK LINE
TSTCCR
JMP .-3
JMS I (XDELET /DELETE OLD LINE
UDF
IOF
TAD I LASTLN /POINTER TO NEXT
DCA I BUFR /POINT TO NEXT
TAD BUFR
DCA I LASTLN /OLD POINTS TO NEW
TAD ADD
SZA
DCA I AXIN /FINISH PACKING
FINDLN /FIND THE LINE
C16, 16
PUSHJ
ENDFND /SCAN FOR *NEXT*
SNA CLA
TAD C10
IAC
TAD AXIN
DCA BUFR /NEW FREE POSITION
TAD STARTV
DCA LASTV /RESET VARIABLES AFTER INPUTTING TEXT
ION
JMP START
FUPAR1, 2055
0
0
PAGE
KEY, 0
TAD USER
JMS I (DECKON /PUT HIM ONDECK
TAD XIOT
DCA .+1 /SET READ IOT
HLT
AND C177 /IGNORE PARITY
SNA
JMP I KEY /IGNORE 0 NAD 200
DCA SIN /SAVE INPUT
L7775
TAD SIN /CTRL/C?
KM140, SZA CLA
JMP KEY7 /NOT "^C"
ERR004, JMS I (IERROR /RECOVER
JMP I KEY
KEY7, TAD LSTMOD
SNA
JMP KEY6 /NO ECHO - BREAK
CDF SWAP
DCA I (XCCR+4
CDF
TAD SIN
SORTC /CHECK BREAK
XCCR-1
JMP KEY5 /BREAK
TAD SIN
SORTC
ALT-1
JMP KEY6 /FOUND AN ALTMODE
TAD SIN
TAD M12
SNA CLA
JMP I KEY /IGNORE LINE FEED IF NOT BREAK
TAD SIN
AND C140
SNA
JMP KEY3 /ILLEGAL CHAR
TAD KM140
SNA CLA
JMP KEY3 /ILLEGAL CHAR
TAD SIN
PRINTX /ECHO THE CHAR
JMS KEY4 /STORE THE CHAR
TAD IPTRO
CIA
TAD IPTRI
SPA SNA
TAD C40
TAD M12
SPA CLA
JMP I KEY /NO - EXIT
ANYINP, L3777
AND I TEMP2 /CLEAR I WAIT
DCA I TEMP2
JMP I KEY
KEY5, L7777
TAD SORTCN
KCM40, SMA SZA CLA
JMP .+3 /NO ECHO HERE
TAD SIN
PRINTX /ECHO BREAK CHAR - CR AND BELL
KEY6, JMS KEY4 /STORE CHAR
JMP ANYINP /BREAK HERE
KEY3, TAD C7
PRINTX /2 BELLS FOR ILLEGAL CHAR
TAD C7
PRINTX
JMP I KEY
KEY4, 0
UDF
TAD I IPTRI /ROOM?
SZA CLA
ERR070, JMS I (IERROR /NO ROOM
UDF
TAD SIN
DCA I IPTRI
CDF
ISZ IPTRI
TAD IPTRI
CIA
TAD C40
TAD IPTR0
SZA CLA
JMP I KEY4 /OK
TAD IPTR0
DCA IPTRI /RESET POINTER
JMP I KEY4
TTY, 0
TAD USER
JMS I (DECKON /PUT HIM ONDECK
DCA TELSW /CLEAR BUSY
UDF
TTY3, TAD I OPTRO /MORE
SNA
JMP TTY2 /NO
JMS I (XOUTL2 /OUTPUT IT
UDF
DCA I OPTRO /CLEAR BUFFER
ISZ OPTRO /BUMP BUFFER
TAD OPTRO
CIA
TAD IPTR0
SZA CLA
JMP TTY2 /OK
TAD IPTR0
TAD KCM40
DCA OPTRO /RESET BUFFER
TTY2, JMS I (XFREE /ROOM AVAILABLE
C140, 140
JMP I TTY /NOT ENOUGH ROOM
L5777
AND I TEMP2 /CLEAR O WAIT
DCA I TEMP2
JMP I TTY
/POP THE AC ROUTINE
XPOPA, 0
UDF
TAD I PDLXR
CDF
JMP I XPOPA
DECIMAL
PRNTLL, -1000
-100
-10
OCTAL
PAGE
/*READ* AND *INPUT* COMMANDS
INREAD, 0
SZA CLA
JMP INREA3 /RE-ENTRY
PUSHJ /PRINT CRAP
PRIN10
DCA MODE /NEW VARIABLE
PUSHJ /GET A VARIABLE
GETVAR
SZA CLA
JMP ERR500 /WAS FUNCTION
TAD MODE /SET TO IGNORE LEADING SPACES IF NECESSARY
DCA SPACSW
PUSHF /SAVE PT1;CHAR;LINEPC
PT1
PUSHF /SAVE TEXT
TEXTP
PUSHF
DATAPC+1
POPF /GET POINTERS
TEXTP
TAD DATAPC+4
DCA CHAR
TSTEND /MORE?
JMP INREA1 /NO
INREA4, ISZ INREAD /2ND EXIT
JMP I INREAD
INREA1, TSTCOM /MORE?
ERR490, ERROR /JUNK
GETC
TSTEND /COMMA FOLLOWED BY CR OR '?
SKP
JMP INREA4 /YES - ASK FOR MORE
INREA3, TAD MODE
SNA CLA
JMP SPLCH1-2 /NUMERIC INPUT
SPLCH, PUSHJ /GET THE STRING
QINP
JMP SPLCH1
PUSHJ
EVAL
SPLCH1, PUSHF
TEXTP
POPF
DATAPC+1
TAD CHAR
DCA DATAPC+4 /SAVE POINTERS
POPF
TEXTP
POPF
PT1
FLPUT /SET VARIABLE
FLARG
TSTCOM
JMP INREA2
GETC
JMP INREAD+3
INREA2, TSTEND
ERR500, ERROR /JUNK
JMP I INREAD
L7777
READ, JMS INREAD /SET THOSE VARIABLES
POPJ
READ1, TAD MODE /MUST SAVE MODE
PUSHA /IT IS CHANGED BELOW
TAD DATAPC
FIND
3
ERR510, ERROR /OUT OF DATA
DCA DATAPC
POPA /RESTORE MODE
DCA MODE
JMP READ-1
INPUT, JMS CHKFIL /CHECK IF A FILE
PUSHF
DATAPC+1
TAD DATAPC+4
PUSHA
TAD CCR
DCA DATAPC+4
JMS INREAD /SET THOSE VARIABLES
JMP INPUT1 /DONE
INPUT2, PUSHJ /GET LINE OF INPUT
GETINP
L7777
JMP INPUT2-2
INPUT1, TSTEND
JMP INREA1+1
POPA
DCA DATAPC+4
POPF
DATAPC+1
POPJ
CHKFIL, 0
TAD CHAR /CHECK FOR FILE INPUT
TAD MNMSGN
SZA CLA
JMP I CHKFIL /NOT FILE
TAD IBLK /FILE OPEN?
CLL RAR
TAD IBLKH
SZA CLA
GETC /SHOULD BE COMMA
TSTCOM
ERR600, ERROR
GETC /SKIP OVER COMMA
TAD VXGET /SETUP FILE INPUT
DCA PREADC
JMP I CHKFIL /DONE
GETINP, TAD PREADC /CHECK IF FILE, GET LINE OF INPUT
TAD MXREADC
SZA CLA
JMP GETIN1 /IT WAS A FILE
FREE13
TAD C77
PRINTC
TAD C40
PRINTC
GETIN1, PUSHJ
PAKLIN
SZA CLA /EOF?
ERR610, ERROR
POPJ
MNMSGN, 200-"#
VXGET, XGET
MXREADC, -XREADC
/*IF* COMMAND
IF, PUSHJ /GET FIRST VALUE
EVAL
PUSHF /AND SAVE IT
FLARG
TAD MODE
PUSHA /SAVE MODE
TAD SORTCN
TAD M12
SPA
ERR390, ERROR /NO RELATION OR BAD RELATION
CLL CML RTL
DCA IF1 /SAVE REL OP
GETC
SORTC /ANOTHER OP?
TERMS-1
JMP IF2 /MIGHT BE...
IF3, CLA
TAD IF1
SORTC /CHECK OP
IF4-1
PIF5, SKP CLA /7610=IF5, AT LEAST, IT BETTER!!!!!!
JMP ERR390 /BAD OP
TAD SORTCN
TAD PIF5
DCA IF1
TAD I IF1 /GET FLOATING SKIP WORD
DCA IF6
PUSHJ /GET 2ND VALUE
EVAL
L7775
COMMAN /GET NEXT COMMAND
SNA CLA
ERR400, ERROR /THEN NOT FOUND
POPA /GET OLD MODE
TAD MODE
SZA CLA
JMP IFSTR /WE WANT TO DO A STRING COMPARE
POPF
FLARG
FINT
FCMP I FLARGP /GET DIFFERENCT
FPUT I FLARGP /AND SAVE IT
FEXT
IF7, GETSGN /GET SIGN OF DIFFERENCE
IF6, HLT /SKIP IF FALSE
TESTN
IFDONE, POPJ /SO WHO CARES ABOUT A STRANGE NO-OP?
JMP I VRUN8 /GO DO COMMAND
GOTO, GETLN
TSTEND
ERR270, ERROR /JUNK
TAD LINENO /SET UP TRANSFER TO LINE
POPJ /RETURN
IF2, TAD SORTCN
TAD M12
SPA
JMP IF3 /NO 2ND OP
IAC
TAD IF1
DCA IF1
GETC
JMP IF3+1
VRUN8, RUN8
VIF1, IF1-1
VREADY, READY
VRESETO,RESETO
/*MOD* FUNCTION
MOD, PUSHF
FLARG
TSTCOM
JMP I (ERR560
PUSHJ
EVAL-1
POPF
PIF1, IF1
MOD1, FINT
FGET I PIF1
FDIV I FLARGP
FADD I (FCN
FMUL I FLARGP
FPUT I (TEMP
FGET I PIF1
FSUB I (TEMP
FEXT
POPJ
VXREADC,XREADC
IFSTR, POPF /STRING *IF*
IF1 /SAVE FIRST STRING
TAD FLARGP /POINT TO THE STRINGS
DCA MODE
TAD VIF1
DCA FLTXR
L7775 /DO AN INTEGER COMPARE ON 3 WORDS
DCA T3
IFSTR1, TAD I FLTXR /SUBTRACT WORDS, GET SIGN OF DIFFERENCE
CMA /THIS GARBAGE CONVERTS CR'S TO ZEROES
DCA T1 /AND ADDS ONE TO EACH CHARACTER
TAD T1 /SO COMPARES OF DIFFERENT LENGTHS COME OUT OK
AND C77
SZA CLA
TAD C7700
TAD T1
DCA T1
TAD I MODE
IAC
AND C77
DCA T2
TAD I MODE
TAD C100
AND C7700
TAD T2
TAD T1
SZA /IF DIFFERENCE ZERO, TRY ANOTHER PAIR
JMP IF6 /NON ZERO DIFFERENCE, COMPARE THEM
ISZ MODE
ISZ T3
JMP IFSTR1
JMP IF6 /IF DONE, COMPARE THEM
IF1, 0
0
IOFIX, 0
TAD VXREADC
DCA PREADC
TAD VREADY /RESET CHAIN POINTER
DCA CHAINP
JMS I VRESETO
JMP I IOFIX /RESET OUTPUT POINTERS AND EXIT.
PAGE
/*LET* AND *FOR* COMMANDS
FOR, L7777
LET, DCA FOR1 /SAVE DETERMINATOR
PUSHJ /GET VARIABLE
GETVAR
SNA CLA
TAD CHAR
TAD MEQL
SZA CLA
ERR410, ERROR /NO "="
LET2, PUSHF /SAVE ADD,XCTIN,PT1
ADD
PUSHJ /GET VALUE
EVAL-1
POPF
ADD
FLPUT /SET VARIABLE
FLARG
L7777
TAD AXOUT
DCA FOR5
ISZ FOR1 /WHICH COMMAND?
JMP LET1 /LET COMMAND
TAD ADD
SPA CLA
ERR420, ERROR /SUBSCRIPTED
COMMAN /GET WORD
TAD M4
SZA CLA
JMP FOR2+3 /NOT *TO*
TAD PT1
CIA
DCA FOR1 /SAVE POINTER
PUSHJ /GET LIMIT
EVAL
PUSHF /SAVE LIMIT
FLARG
TSTEND
JMP FOR2 /GET INCREMENT
PUSHF /INCREMENT IS ONE
FLTONE
FOR3, TAD LINENO
PUSHA
TAD LINENO
SKP
FOR4, POPA
FIND /FIND A *NEXT* STATEMENT
1 /-NEXT CODE
ERR440, ERROR /OUT OF TEXT
PUSHA /SAVE FOR RESTART
TSTALP
JMP FOR4
PUSHJ /GET VARIABLE
GETVAR
SNA CLA
TAD PT1
TAD FOR1
SZA CLA
JMP FOR4 /LOOP
TSTCCR
JMP I NEXERR /MAKE SURE IT'S LAST ON LINE-SORRY NO COMMENTS
ISZ PDLXR /DUMP RESTART ADDRESS
POPA
DCA LINENO
TAD LINENO
UDF
DCA I AXOUT /SET LINE NUMBER
TAD FOR5
DCA I AXOUT /AND MIDDLE OF LINE POINTER
CDF
POPF /GET INCREMENT
FLARG
TAD AXOUT
FLPUT /PUT INCREMENT
FLARG
POPF /GET LIMIT
FLARG
L0002
IAC
TAD AXOUT
FLPUT /SET LIMIT
FLARG
FINDLN /FIND US AGAIN
MEQL, -"=+200 /THIS NEVER GETS EXECUTED
LET1, TSTEND
ERR450, ERROR /JUNK
TAD FOR5
JMP I (FOREXT
FOR2, L7776
COMMAN /IS IT STEP?
SNA CLA
ERR430, ERROR /NOT STEP
PUSHJ /GET INCREMENT
EVAL
PUSHF /SAVE INCREMENT
FLARG
TSTEND
JMP FOR2+3 /JUNK
JMP FOR3
FOR5, 0
NEXERR, ERR460
UNKWN, TSTALP
JMP ERRCHK
PUSHJ
GETVAR
SNA CLA
TAD CHAR
TAD MEQL
SZA CLA
JMP UNKWN+1 /NO "="
DCA FOR1 /MAKE IT A LET COMMAND
JMP LET2
IFZERO .&1 <!"#%&:?!!DUMPKOPF SCHWIENDHUNDT!>
ERRCHK, CLA
TAD ERLINE
SMA SZA CLA
ERR520, ERROR /RUNNING
ERR000, ERROR /IMMEDIATE MODE--"WHAT?"
OPUSJ1, PUSHA
TAD (OPUS
PUSHA
JMP I T3
FOR1, 0
/*RTL6* ROUTINE
XRTL6, 0
CLL RTL
RTL
RTL
JMP I XRTL6
PAGE
/*DELETE* ROUTINE
XDELET, 0
FINDLN /FIND THE LINE
JMP I XDELET /NOT THERE - EXIT
ISZ SPACSW
GETC
TSTCCR /GO TO END OF LINE
JMP .-2
TAD AXOUT
CMA
TAD LINEPC
PUSHA /SAVE COUNT
TAD LINEPC
IAC
DCA AXOUT /TO UNPACK
DCA XCT
PUSHJ
ENDFND
SNA CLA
TAD M10
POPA
DCA T3 /CORRECTED COUNT
TAD LINEPC
CIA
TAD ALINE0
SNA CLA
JMP I XDELET /NOT LINE0
UDF
TAD I LINEPC /GET POINTER
DCA I LASTLN /REMOVE LINE
TAD ALINE0
XDEL3, DCA T2 /CURRENT LINE
TAD I T2
SNA
JMP XDEL2 /OUT OF TEXT
DCA T1
TAD LINEPC
CLL CIA
TAD T1
SZL CLA
TAD T3 /CORRECT LINE
TAD T1
DCA I T2
TAD T1
JMP XDEL3
XDEL2, L7777
TAD LINEPC
DCA XREG3
TAD T3
CMA
TAD LINEPC
DCA AXOUT
TAD T3
TAD BUFR
DCA BUFR
TAD AXIN
CMA
TAD AXOUT
DCA T1
TAD T3
TAD AXIN
DCA AXIN
TAD I AXOUT
DCA I XREG3 /MOVE TEXT
ISZ T1
JMP .-3
JMP XDELET+1
/PUSH ROUTINES
XPUSHA, 0
DCA XPUSHJ
L7777 /BACK 1
JMS PCHK
TAD XPUSHJ
UDF
DCA I PDLXR /PUSH IT
CDF
L7777
JMS PCHK /BACK AGAIN
JMP I XPUSHA
XPUSHJ, 0
TAD I XPUSHJ /GET SEND ADDRESS
DCA XPUSHA
ISZ XPUSHJ /CALCULATE RETURN ADDRESS
JMP XPUSHA+2
PCHK, 0
TAD PDLXR
DCA PDLXR
L0002
TAD LASTV
STL CIA
TAD PDLXR
SZL CLA
JMP I (ERR100-2 /PUSHED TOO FAR
JMP I PCHK
/*PUSHF* ROUTINE
XPUSHF, 0
L7777
TAD I XPUSHF
DCA XREG3 /POINT TO DATA
L7775
JMS PCHK
L7775
DCA T3
TAD I XREG3
UDF
DCA I PDLXR
CDF
ISZ T3
JMP .-5
L7775
JMS PCHK /BACK AGAIN
ISZ XPUSHF
JMP I XPUSHF
/SUBROUTINE TO WRITE OUT MESSAGES
READY1, 0
DCA AXOUT /POINT TO MESSAGE
DCA XCT
TAD M6
DCA T2
GETC
PRINTC /PRINT MESSAGE
ISZ T2
JMP .-3
JMP I READY1
RUN9X, PUSHA /SAVE FIELD 1 RESTART ADDRESS
JMS I (RUN9 /DISMISS US
POPA /RESTORE ADDRESS
DCA T1
CIF CDF 10 /GO TO IT
JMP I T1
PAGE
MANCOM, 0
DCA FLTXR2 /SAVE AC
TAD (LIST7 /START AT BEGINNING OF LIST
CDF SWAP /IN FIELD 1
COMLP1, DCA T2 /LIST POINTER
L0001
DCA T1 /LETTER POINTER
TAD I T2 /GET -UNIQUE COUNT-1
RTR /
AND C7 /
CLL RAR /
CMA /
DCA CNTR /
JMS COM11 /UNIQUE?
JMP COM3 /YES - TRY REST
JMS COMPOP /NO - POP TEXT FOR NEXT
ISZ T2 /GET NEXT COMMAND IN LIST
TAD I T2 /
SZA /END OF LIST?
JMP COMLP1 /NO - GO ON
COM5, CDF /YES - RETURN FAILURE
JMP I MANCOM /AC=0
COM3, TAD I T2 /GET FULL LENGTH-2
AND C7 /
IAC /
CMA /
TAD T1 /T1=UNIQUE POINTER+1
DCA CNTR /-NO. OF CHARS TO GO-1
JMS COM11 /LONG FORM OF COMMAND?
JMP COM4 /YES - THROW OUT SHORT POINTERS
JMS COMPOP /NO - RESET POINTERS TO END OF SHORT CMD
JMP COM8
COM4, L0004 /DELETE LAST 4 ENTRIES FROM PDL
TAD PDLXR /
DCA PDLXR /
COM8, TAD I T2
RTL6
RTL
AND C77 /GET CODE
TAD (-32 /CORRECT IT
DCA FLTXR /AND SAVE IT
TAD FLTXR2
SNA
JMP .+4 /NO DOUBLE CHECK
TAD FLTXR
SZA CLA
JMP COM7 /DOUBLE CHECK FAILS
CDF
L0004
TAD PDLXR /DUMPPDLJUNK
DCA PDLXR
TAD FLTXR
JMP I MANCOM
COM7, JMS COMPOP /RESET POINTERS TO ENTRY VALUES
JMP COM5 /TAKE FAILURE RETURN
COM11, 0 /COMMAND COMPARISON
CDF
PUSHF
TEXTP /SAVE TEXT POINTERS
TAD CHAR /
PUSHA /
COMLP2, CDF SWAP
ISZ CNTR /-NO. OF CHARS TO GO-1
SKP
JMP I COM11 /SUCCESS RETURN FROM COM11
L0001
TAD T1
RAR
TAD T2
DCA XREG3
TAD I XREG3
SZL
JMP .+4
RTR
RTR
RTR
AND C77
SNA
TAD TSTCON
TAD (-137
TAD CHAR
SZA CLA /SAME SO FAR?
JMP COM13 /NO GO
CDF
GETC /NEXT CHAR
CDF SWAP
ISZ T1 /LETTER POINTER
JMP COMLP2 /LOOP
COM13, ISZ COM11 /FAILURE RETURN FROM COM11
JMP I COM11
COMPOP, 0 /RESTORE TEXT POINTERS FROM PDL
POPA
DCA CHAR
POPF
TEXTP
CDF SWAP
JMP I COMPOP
TSTCH1, 0 /TEST A-Z,0-9 FOR FIELD 1
TESTN
TSTCON, -215+337
SKP
ISZ TSTCH1
TSTALP
SKP
ISZ TSTCH1
CIF CDF 10
JMP I TSTCH1
PRPATCH, JMS I INTEGE
TAD (-15
SNA
JMP I (PRIN11+1
TAD CCR
JMP I (PATCH1
PAGE
/*EDIT* COMMAND
EDIT, GETLN /GET LINE NUMBER
TSTCCR
ERR001, ERROR /JUNK
FINDLN /FIND THE LINE
JMP ERR001 /NOT THERE
ISZ SPACSW
JMS I EPINPACK /SET TO PACK IT
MODF2, DCA LSTMOD /READ SILENTLY
READC
MODF3, TAD CHAR
DCA LSTMOD /SET SEARCH CHARACTER
MODF1, GETC
FREE2
PRINTC /PRINT LINE UNTIL...
SORTJ
CCR-1
MODL1-CCR
PACKC /KEEP PACKING
JMP MODF1
MODF4, PACKC /PACK IT
READC /GET CHARS
SORTJ /CHECK THEM
CCR-1
MODL2-CCR
JMP MODF4
MODF5, PACKC /PACK THE CR
PACKC
JMS I .+2
JMP I .+2
OTPACK
SRETN
EPINPACK,INPACK
/*DELETE* COMMAND
DELETE, JMS GETLIM /GET LIMITS
TAD BUFR
DCA AXIN /PROTECT TEXT
JMS GETLIN /GET A LINE
JMP I CREADY /WE ARE DONE
JMS I CXDELET /DELETE IT
TAD LASTLN
DCA LINEPC /RESTORE POINTERS
JMP .-5 /LOOP
/*LIST* COMMAND
LIST, JMS GETLIM /GET LIMITS
ISZ SPACSW /KEEP SPACES
TAD M100
DCA PT1
TAD OUTPUT
SNA CLA
JMP LLIST3-3 /NORMAL MODE
DCA OUTPUT /WE WILL OUTPUT FOR A WHILE
LLIST5, FREE2
L4000
PRINTC /DO L/T
ISZ PT1
JMP LLIST5
FREE2
TAD CCR
PRINTC
LLIST3, JMS GETLIN /GET A LINE
JMP LLIST4 /WE ARE DONE
FREE13
TAD LINENO
JMS I CITPRNT /PRINT THE NUMBER
GETC
FREE2
PRINTC /PRINT THE LINE
TSTCCR
JMP .-4 /UNTIL A CR
JMP LLIST3 /LOOP
LLIST4, TAD PT1
SZA CLA
JMP I CSAVDON /SEE IF THIS IS A 'SAVE'
TAD M100
DCA PT1
LLIST6, FREE2
L4000
PRINTC /DO L/T
ISZ PT1
JMP LLIST6
JMP I CTAPE
GETLIN, 0
TAD CCR /FAKE OUT GETNXT!
DCA CHAR
GETNXT /GET NEXT LINE
JMP I GETLIN /OUT OF TEXT
POPA
DCA T3 /GET LIMIT
TAD T3
PUSHA /SAVE LIMIT
TAD LINENO
CIA
TAD T3
SMA CLA
ISZ GETLIN /OK
JMP I GETLIN
GETLIM, 0
TSTCCR
JMP LIMGT1 /NOT ALL
DCA LASTLN /START AT 0
L3777
JMP LIMGT3
LIMGT1, GETLN /GET A LINE NUMBER
TAD LINENO
DCA LASTLN /AND SAVE IT
TSTCOM
JMP LIMGT2 /ONLY ONE LINE
GETC
GETLN /GET LINE NUMBER
TAD LINENO
LIMGT3, PUSHA /UPPER LIMIT
TAD LASTLN
DCA LINENO /LOWER LIMIT
TSTCCR
JMP EDIT+2 /JUNK
LIMGT4, FINDLN /FIND THE LINE
CREADY, READY
TAD LASTLN
DCA LINEPC /AND GO BACK ONE
JMP I GETLIM
LIMGT2, TAD LASTLN /1ST = 2ND
JMP LIMGT3
CXDELET,XDELET
CITPRNT,ITPRNT
CSAVDON,SAVDON
CTAPE, TAPE
/*NEXT* COMMAND
NEXT, PUSHJ /GET VARIABLE
GETVAR
SNA CLA
TSTCCR
ERR460, ERROR /WAS FUNCTION
FINT
FGET I FLARGP /PUT VARIABLE INTO FLAC
FEXT
UDF
TAD I AXOUT /GET *FOR* LINE NUMBER
SNA
ERR470, ERROR /*NEXT* NOT INITIALIZED
DCA T1 /SAVE LINE
TAD I AXOUT
DCA RUNSCR
CDF
TAD AXOUT
FLGET /GET INCREMENT
FLARG
GETSGN
NEXT3, SMA CLA
TAD C50 /POSITIVE INCREMENT
TAD NEXT3 /NEGATIVE INCREMENT
DCA NEXT1 /SET LIMIT TEST INSTRUCTION
FINT
FADD I FLARGP /BUMP VARIABLE
FPUT I FLARGP /SAVE VALUE
FEXT
FLPUT /SET VARIABLE
FLARG
L0003
TAD AXOUT
FLGET /GET LIMIT
FLARG
FINT
FSUB I FLARGP
FPUT I FLARGP
FEXT
GETSGN /SIGN OF DIFFERENCE
NEXT1, HLT /SKIP IF DONE
JMP NEXT2 /NOT DONE
L7777
TAD AXOUT
DCA T1
UDF
DCA I T1 /NOT INITIALIZED NOW
POPJ
NEXT2, TAD T1 /GET LINE NUMBER OF *FOR*
DCA LINENO
FINDLN
C50, 50 /IF IT AIN'T THERE, WELL...
TAD RUNSCR
FOREXT, DCA AXOUT
DCA CHAR
POPJ
CHAIN1, JMS I PIOFX
JMS I (DTFREE /REALLY FREE IT THIS TIME
/*RUN* COMMAND
RUN, TAD STARTV
DCA LASTV /NO VARIABLES
PUSHF
FRNDX1
POPF /SET RANDOM NUMBER
FRNDX
RUN4, TAD ERLINE
FIND /FIND THE NEXT STATEMENTS
1 /- NEXT CODE
JMP RUN3 /OUT OF TEXT
DCA ERLINE /SAVE FOR RESTART
JMS RUN9 /DISMISS US NOW
PUSHJ
GETVAR
SNA CLA
TSTCCR
JMP ERR460
UDF
DCA I AXOUT /NOT INITIALIZED NOW
CDF
JMP RUN4
RUN3, JMS RUN9 /DISMISS US AGAIN
TAD ALINE0
DCA LINEPC /START AT LINE ZERO
RUN7, GETNXT /GET NEXT LINE
JMP I (READY /ALL DONE
RUN6, DCA SPACSW
GETC
ISZ PC
JMP RUN8+1 /STILL O.K.
JMS RUN9 /DISMISS US NOW
SKP
RUN8, ISZ PDLXR
JMS I PIOFX
DCA MODE
TAD LINENO
DCA ERLINE /SET CURRENT LINE
COMMAN /GET COMMAND
SMA SZA
JMP I (ERRCHK
TAD (COMGOL
DCA T1
CDF SWAP
TAD I T1 /GET ADDRESS
CDF
DCA .+2
PUSHJ /GO TO IT
RUNSCR, 0
SNA
JMP RUN7 /NORMAL RETURN
DCA LINENO /FOR TRANSFER
GOSUB2, FINDLN /FIND THE LINE
ERR380, ERROR /NOT FOUND
JMP RUN6
RUN9, 0 /DISMISSAL ROUTINE
TAD RUN9
DCA PC /SET RESTART ADDRESS
JMP NULL /DISMISS
ABS, CDF SWAP
DCA I (ACSIGN
POPJ
GOSUB1, POPA
DCA LINENO
FINDLN
PIOFX, IOFIX
POPA
JMP FOREXT
FCN, 2330 /INTEGERIZING CONSTANT
0
0
PAGE
/EXPRESSION EVALUATOR
ECALL, 0
TAD SORTCN
PUSHA
TAD LASTOP
PUSHA
TAD EFOP
PUSHA
TAD ECALL
PUSHA /RETURN ADDRESS
GETC
EVAL, DCA LASTOP /0 IS END
TAD EVAL1
PUSHA /SAVE EVAL1
DCA EVAL1 /0 EVAL1
TESTC
JMP ETERM1 /INITIAL TERMINATOR
JMP ENUM /NUMBER
JMP EVAR /VARIABLE
JMP I (QUOTES /CHECK FOR LITERAL STRING
ETERM1, TAD (FLZERO
DCA PT1 /0 DATA
L7776
TAD SORTCN
SNA
JMP ETERM /MINUS
IAC
SNA CLA
JMP ARGNXT /PLUS
ELPAR, TSTLPR
JMP EVAL2 /CHECK UNARY
EPAR2, JMS ECALL /RECURSIVE CALL
ISZ PDLXR
JMP I (ENDFUN /END AS FUNCTION
ENUM, TAD FLARGP
DCA PT1 /DATA TO FLARG
JMS I (FLIN /GET VALUE
OPNEXT, ISZ EVAL1
JMP .+4 /NO UNARY
L4000
TAD I PT1
DCA I PT1 /FLIP SIGN
DCA EVAL1
SORTC
TERMS-1
JMP ETERMN
DCA SORTCN /ALL ELSE IS END
ETERMN, TSTLPR
SKP
ERR120, ERROR /EXCESS L-PARENS
ETERM, TAD SORTCN
DCA THISOP /SET OP
TAD THISOP
TAD M10
SMA CLA
DCA THISOP /END
ETERM2, TAD THISOP
CIA
TAD LASTOP /PRIORITIES
SPA CLA
JMP EPAR /NO GO YET
TAD LASTOP
TAD (OPTABL
DCA CNTR
TAD I CNTR
DCA FLOP /SET OP
TAD LASTOP
SZA CLA
POPF /GET DATA
T1 /DUMB TEMP
FINT
FGET T1
FLOP, FJMP I (FUPARR /FLOATING OP
FPUT I FLARGP /SAVE DATA
FEXT
TAD FLARGP
DCA PT1 /POINT TO DATA
TAD THISOP
TAD LASTOP
SNA CLA
JMP EVAL3 /DONE
POPA
DCA LASTOP /NEW OP
JMP ETERM2
EPAR, TSTLPR
SKP
JMP EPAR2 /DO RECURSIVE
TAD LASTOP
PUSHA
TAD PT1
DCA .+2
PUSHF /SAVE DATA
0
TAD THISOP
DCA LASTOP
ARGNXT, GETC
TESTC
JMP ELPAR /T
JMP ENUM /N
JMP EVAR /V
JMP ERR110 /OTHER
EVAR, PUSHJ /GET VARIABLE
GETVAR
SZA
JMP I (FUNCT3 /FUNCTION
TAD FLARGP
DCA PT1 /POINT TO DATA
JMP OPNEXT
EVAL1, 0
EVAL2, L7776
TAD SORTCN /IS IT + OR -?
SMA SZA
ERR110, ERROR /NO - DOUBLE OPS OR EX L-PARNES
SZA CLA
JMP ARGNXT /WAS +
TAD EVAL1
CMA
DCA EVAL1 /FLIP EVAL1
JMP ARGNXT
EVAL3, POPA
DCA EVAL1 /RESTORE EVAL1
POPJ /EXIT
PAGE
FUNCT6, PUSHA /SAVE CHARACTER
DCA EFOP
ISZ EFOP
PUSHF /SAVE ARGS
FLARG
TSTCOM
JMP .+6 /NO MORE ARGS
JMS I (ECALL /GET NEXT
POPA
ISZ PDLXR
ISZ PDLXR
JMP .-12
TAD LASTV
DCA SUBS /SAVE END OF VARIABLES
TAD EFOP
FUNC10, TAD (2000
DCA ADD /CREATE ILLEGAL NAME
PUSHJ /LOOK IT UP - WILL DEFINE
LOOKUP
POPF
FLARG
FLPUT /SET ARGUMENT
FLARG
L5777
TAD ADD
SZA
JMP FUNC10 /MORE ARGUMENTS
L4000
POPA
CIA
DCA FUNC17 /-CHAR OF FUNCTION
PUSHF
TEXTP
TAD SORTCN
PUSHA
TAD SUBS
PUSHA
SKP
FUNC11, POPA
FIND /FIND A *DEF*
11 /-DEF CODE
ERR170, ERROR /OUT OF TEXT
PUSHA /FOR RESTART
COMMAN /GET WORD
TAD (-5
SZA CLA
JMP FUNC11
TAD CHAR
TAD FUNC17
SZA CLA
JMP FUNC11 /NOT PROPER FUNCTION
ISZ PDLXR
TAD ERLINE
PUSHA /SAVE CALLING LINE
TAD LINENO
DCA ERLINE /CALL THIS OUR LINE
GETC
SORTC
TERMS-1
TSTLPR
ERR180, ERROR /NO L-PAREN
TAD SORTCN
PUSHA
GETC
L2000
DCA T1
TAD LASTV
DCA PT1 /POINT TO ARGUMENTS
FUNC14, TSTALP
JMP ERR180 /ILLEGAL VARIABLE
TAD CHAR
AND C37
RTL6
RAR
DCA T2 /SAVE NAME
GETC
TESTN
C37, 37
JMP FUNC13 /NOT NUMBER
TAD CHAR
AND C37
TAD T2
DCA T2
GETC
FUNC13, ISZ T1 /SET ILLEGAL NAME
UDF
TAD I PT1
CIA
TAD T1
SZA CLA
ERR200, ERROR /WRONG NUMBER OF ARGUMENTS
TAD T2
DCA I PT1 /SET TEMPORARY NAME
CDF
TAD M4
TAD PT1
DCA PT1 /POINT TO NEXT
TSTCOM
JMP FUNC12 /NO MORE
GETC
JMP FUNC14
FUNC17, 0
FUNC12, ISZ T1
UDF
TAD I PT1
CDF
CIA
TAD T1
SNA CLA
JMP ERR200 /SHOULD NOT AGREE
SORTC
TERMS-1
SKP
JMP ERR180 /NO PAREN
L7776
TAD SORTCN
CIA
POPA
SZA CLA
JMP ERR180 /NO MATCH
JMP I (FUNC16
/*UDF* ROUTINE
XUDF, 0
CDF 20 /TO USER'S FIELD
JMP I XUDF
PAGE
/COMMON PART FOR *PRINT* AND *INPUT* COMMANDS
PRINT8, GETC /GO BY THE ";"
ISZ PT1 /SHOULD WE SPACE?
JMP PRINT1 /NO
FREE2
TAD C40
PRINTC /PRINT A SPACE
PRINT1, SORTJ /CHECK , " ' CR
PRNTL1-1
PRNTL2-PRNTL1
PRINT4, L7777
COMMAN /TAB?
SZA CLA
JMP PRIN5+1
TAD (-26
COMMAN
SNA CLA
POPJ /MUST BE EXPRESSION
PRIN5, L7777
PUSHA
SORTC
TERMS-1
TSTLPR
ERR340, ERROR
JMS I (ECALL /GET RECURSIVE
ISZ PDLXR /DUMP EFOP
JMS I (PARTST /CHECK MATCH
UDF
ISZ I PDLXR /AHA!
JMP I (PRIN12 /WAS TAB FUNCTION
JMP I .+1
PRPATCH
PATCH1, PUSHA
FREE2 /MAKE SOME ROOM
POPA
SNA
L4000 /MAKE "NULL" PRINTABLE (OTHERWISE WE PRINT CHAR...)
PRINTC
JMP PRIN10
PRIN11, JMS I INTEGE /MAKE INTEGER OF TAB ARG
TAD (-110
SZA /SPECIAL CASE CHECK
TAD (110
CMA
DCA PT1 /SET -COUNT -1
TAD PRNTC1
TAD (110
TAD PT1
SPA
JMP PRINT9
CLA
IOF
TAD CCR
JMS I (XOUTL2
TAD CCR
JMS I (XOUTL2
TAD (-110
DCA PRNTC1
ION
SKP
PRINT9, DCA PT1
ISZ PT1
SKP
JMP PRINT3+2
FREE2
TAD C40
PRINTC
JMP PRINT9+1
PRINT3, DCA SPACSW
GETC
SKP
L7777
PRIN10, DCA PT1 /SET SPACE INDICATOR
SORTJ /CHECK ; , ' " CR
PRNTL4-1
PRNTL6-PRNTL4
ISZ PT1 /NO FIND O.K.?
JMP PRINT4 /YES - ASSUME TAB OR EXPRESSION
ERR350, ERROR /NO - SYNTAX ERROR
FREE2
TAD C40
PRINTC /SPACES TO FINISH ZONE
PRINT5, TAD PPRINT
TAD (-XPRNTC
SZA CLA
JMP PRNT5A
TAD C7
TAD PRNTC1
TAD CCR
SPA
JMP .-2
SZA CLA
JMP PRINT5-3 /KEEP GOING
PRNT5B, GETC /GO BY THE ","
JMP PRINT1
PRNT5A, FREE2
PRINTC
JMP PRNT5B
/*PRINTX* ROUTINE
XOUTL, 0
SNA
TAD CHAR /USE CHAR IF AC=0
JMS I (XOUTL2 /DO OUTPUT
TAD XREG3
TAD (-15 /WAS IT A CR
SNA
JMP XOUTL1 /YES!
TAD (15-40
SPA
SKP CLA /IT IS A NON-PRINTING CHARACTER
TAD M100
SPA CLA
ISZ PRNTC1 /IT IS A PRINTING CHAR SO COUNT IT
JMP I XOUTL
TAD CCR /END OF LINE SO DO CR-LF
JMP XOUTL+3
XOUTL1, TAD (-110
DCA PRNTC1 /RESET COUNT
TAD CLF
JMP XOUTL+3
PAGE
XOUTL2, 0
CDF
DCA XREG3 /SAVE CHAR
TAD OUTPUT
SZA CLA
JMP XOUTL4 /NO ECHO
TAD TELSW /BUSY
SZA CLA
JMP XOUTL5 /YES
TAD C10
TAD XIOT
DCA XOUTL6 /SET OUTPUT IOT
TAD DECK
CLL CML CMA
DCA T3
CCM40, SMA SZA CLA /AC=0 SO ITS A SKP
RAR
ISZ T3
JMP .-2
MTON /TURN ON PROPER USER
CLA
TAD XREG3
XOUTL6, HLT
/IF NOT DC02,
/XOUTL6-3 AND XOUTL6+3 ARE SET TO ZERO IN BEG760
DCA TELSW /SET BUSY
TAD I (AUSER
MTON /ALL ON AGAIN
CLA
JMP XOUTL4
XOUTL5, UDF
TAD I OPTRI /ROOM
SZA CLA
ERR080, JMS IERROR /NO ROOM
UDF
TAD XREG3
DCA I OPTRI /FILL BUFFER
ISZ OPTRI /BUMP BUFFER
TAD OPTRI
CIA
TAD IPTR0
SZA CLA
JMP XOUTL4 /OK
TAD IPTR0
TAD CCM40
DCA OPTRI /RESET BUFFER
XOUTL4, CDF
JMP I XOUTL2
/*FINDLN* ROUTINE
XFINDL, 0
TAD LINENO
SPA CLA /IS THIS IMMEDIATE MODE???????
JMP XFNDL3 /YEP.
UDF
TAD ALINE0
DCA LASTLN
TAD ALINE0
XFNDL1, DCA LINEPC /CURRENT LINE
TAD LINEPC
DCA XREG3
TAD LINENO
CIA
TAD I XREG3
SNA
JMP XFNDL2-1 /FOUND LINE
SMA CLA
JMP XFNDL2 /WENT BEYOND
TAD LINEPC
DCA LASTLN
TAD I LINEPC
SZA
JMP XFNDL1 /LOOP
SKP /OUT OF TEXT
ISZ XFINDL /FOUND LINE
XFNDL2, TAD LINEPC
IAC
DCA AXOUT /SET TO UNPACK
DCA XCT
CDF
JMP I XFINDL
XPAKL1, 15 /THE NEXT 6 LOCATIONS MUST STAY TOGETHER
7 /BELL
177 /RUBOUT
XGETL1, 137 /BACK ARROW
100 /USED IN XGETL
40
XFNDL3, L7777
TAD COMBUF
DCA LINEPC
JMP XFNDL2-1 /RESET TO DO COMMAND BUFFER NOW
/ERROR ENTERING ROUTINES
XERROR, 0
IOF
CLA
IERRO1, CDF
TAD C177
DCA IERROR
IERRO2, TAD XERROR
CLL RAR /FORM ERROR CODE
DCA LSTMOD
L3777
AND I TEMP2 /CLEAR I WAIT
DCA I TEMP2
JMS I (IOFIX /RESET FILES
TAD (ERRORX
DCA PC /SET FOR RESTART
JMP I IERROR
IERROR, 0
L7777
TAD CCM40
TAD IPTR0
DCA XREG3
TAD CCM40
DCA T3 /BUFFER COUNT
UDF
DCA I XREG3 /CLEAR BUFFER
ISZ T3
JMP .-2
CDF
TAD OPTRI
DCA OPTRO
TAD IERROR
DCA XERROR
TAD LOOK
CIA
TAD TEMP2
SNA CLA
JMP IERRO1 /RUNNING
JMP IERRO2 /NOT RUNNING
PAGE
/*PACKC* ROUTINE
XPACKC, 0
SORTJ
XPAKL1-1
XPAKL2-XPAKL1
XXPAK, SORTC /CHECK FOR ALTMODE
ALT-1
JMP XPPCK1 /IT IS ALTMODE
TAD CHAR
TAD (-40
XPACK4, ISZ XCTIN
JMP XPACK1 /NO PARTIAL
TAD ADD /FORM WORD
UDF
DCA I AXIN /PACK IT
CDF
DCA ADD
TAD I PACKND
TAD M12
CLL CIA
TAD AXIN
SZL CLA
ERR060, ERROR /TOO FAR
XPACK5, JMP I XPACKC
XPACK2, TAD (37
XPACK3, TAD C40
JMP XPACK4
XPACK1, RTL6
DCA ADD /SAVE PARTIAL
L7777
DCA XCTIN /INDICATE PARTIAL
JMP I XPACKC
XPACK7, ISZ XCTIN /PARTIAL HERE
JMP XPACK8 /NO
XPACK9, DCA ADD
TAD C137
PRINTC /PRINT BACK ARROW
JMP I XPACKC
XPACK8, TAD PACKST
CIA
TAD AXIN
SNA CLA
JMP I XPACKC /ALL GONE ANY HOW
TAD AXIN
DCA T3
L7777
DCA XCTIN /INDICATE PARTIAL
L7777
TAD AXIN
DCA AXIN /PUT IT BACK ONE
UDF
TAD I T3 /GET OLD
AND C7700
JMP XPACK9
XPPCK1, PUSHF /SAVE TEXT POINTERS
TEXTP
TAD XPACKC
PUSHA /SAVE ADDRESS IF DISMISSED
FREE13
TAD (44
PRINTC /PRINT "$"
TAD C40
PRINTC
TAD C7
JMS I (READY1 /PRINT "DELETE"
GETC /PRINT "D"
PRINTC
GETC /PRINT CR
PRINTC
POPA
DCA XPACKC /RESTORE ADDRESS
TAD PACKST
DCA AXIN
POPF
TEXTP
DCA CHAR
JMP XPACK1+3
/*READC* ROUTINE
XREADC, 0
UDF
TAD I IPTRO /GET CHAR
DCA CHAR /SET CHARACTER
DCA I IPTRO /CLEAR BUFFER
CDF
TAD CHAR
SNA CLA /WAS THERE A CHARACTER
JMP XREAD1 /NO - WAIT
ISZ IPTRO /BUMP BUFFER
TAD IPTRO
CIA
TAD C40
TAD IPTR0
SZA CLA
JMP .+3 /OK
TAD IPTR0
DCA IPTRO /RESET BUFFER
JMP I XREADC
XREAD1, L7777
TAD XREADC
DCA PC /SET TO REDO ROUTINE
TAD I LOOK
JMS I (XOR
4000 /I WAIT AND DISMISS
/*TSTLPR* ROUTINE
LPRTST, 0
TAD SORTCN
TAD M6
SPA CLA
JMP I LPRTST /NOT L-PAREN
TAD SORTCN
TAD M10
SPA CLA
ISZ LPRTST /L-PAREN
JMP I LPRTST
RESETO, 0 /RESET OUTPUT POINTERS
TAD (XPRNTC
DCA PPRINT
TAD (XFREE2
DCA PFREE2
TAD (XFREE3
DCA PFREE3
JMP I RESETO
PAGE
/*POPF* ROUTINE
XPOPF, 0
L7777
TAD I XPOPF
DCA XREG3 /POINT TO DATA AREA
L7775
DCA T3
POPA
DCA I XREG3 /MOVE DATA
ISZ T3
JMP .-3
ISZ XPOPF
JMP I XPOPF
/*TESTC* ROUTINE
XTESTC, 0
SORTC
TERMS-1
JMP I XTESTC /TERMINATOR
ISZ XTESTC
TESTN
JMP I XTESTC
SKP
JMP I XTESTC
ISZ XTESTC
TSTALP
ISZ XTESTC /OTHER
JMP I XTESTC /LETTER
/*TESTN* ROUTINE
XTESTN, 0
TAD CHAR
TAD (-60
DCA SORTCN /SAVE BINARY DIGIT
L0002
TAD SORTCN
SNA
JMP I XTESTN /PERIOD
ISZ XTESTN
TAD (-13
SMA SZA CLA
JMP I XTESTN /GREATER THAN 271
TAD SORTCN
SMA CLA
ISZ XTESTN /DIGIT
JMP I XTESTN
/*GETC* ROUTINE
XGETC, 0
ISZ XCT
JMP XGET1 /NO PARTIAL
TAD GTEM /GET PARTIAL
XGET2, AND C77 /AND OFF JUNK
TAD C40 /CORRECT TO ASCII
DCA CHAR
SORTJ /CHECK SPECIALS
XGETL1-1
XGETL2-XGETL1
XGET7, TAD CHAR /COPY TO UPPER FIELD
CDF SWAP
DCA I (OCHAR
CDF
JMP I XGETC
XGET1, UDF
TAD I AXOUT /GET NEXT
CDF
DCA GTEM /SAVE PARTIAL
L7777
DCA XCT /INDICATE PARTIAL
TAD GTEM
RTL6
RAL
JMP XGET2
XGET3, TAD SPACSW /SPACE TEST
SZA CLA
JMP XGET7 /KEEP SPACES
JMP XGETC+1 /IGNORE SPACES
XGET4, TAD C7 /BELL
XGET6, DCA CHAR
JMP XGET7
XGET5, TAD CCR /CR
JMP XGET6
/*GETNXT* ROUTINE
NXTGET, 0
TSTCCR /END OF LINE?
SKP CLA
JMP NXTGT1 /YES, GET NEXT LINE NUMBER
TAD CHAR
TAD MSPLAT
SNA CLA
JMP NXTG /YES, NEXT COMMAND FOUND
GETC /NO, GET ANOTHER CHAR
JMP NXTGET+1 /TRY AGAIN
NXTGT1, UDF
TAD I LINEPC /POINTER TO NEXT
SNA
JMP NXTG+1 /OUT OF TEXT
DCA LINEPC /NEW POINTER
TAD LINEPC
DCA AXOUT
DCA XCT /SET TO UNPACK
TAD I AXOUT /GET LINE NUMBER
DCA LINENO
NXTG, ISZ NXTGET
CDF
JMP I NXTGET
/*FIND* ROUTINE
XFIND, 0
DCA LINENO /SET START LINE
FINDLN
MSPLAT, -"\+200
XFIND1, GETNXT /GET NEXT LINE
JMP XFIND2 /OUT OF TEXT
GETC
COMMAN
TAD I XFIND /CORRECT COMMAND
SZA CLA
JMP XFIND1 /NO - LOOP
ISZ XFIND
TAD LINENO /FOR RESTART
XFIND2, ISZ XFIND
JMP I XFIND
GETCX1, 0 /*GETC* FOR FIELD 1
GETC
CIF CDF SWAP
JMP I GETCX1
USER0, 0
USER1, 1
USER2, 2
USER3, 3
USER4, 4
/INTERRUPTS HERE FIRST
INTR8E, CIF SWAP
JMP I .+1
INTR81
PAGE
/*GOSUB* COMMAND
GOSUB, GETLN
TSTEND
ERR290, ERROR
GOSUB3, L7777
TAD AXOUT
PUSHA
TAD ERLINE
PUSHA
TAD (GOSUB1
PUSHA
JMP I (GOSUB2
/*NEW* AND *BYE* AND *SCRATCH* COMMANDS
NEW, L7777
RENAME, DCA MODE /KLUDGE!
PUSHJ
GETNAM
JMS I (DTGRAB /SO WE DON'T BLOW ANY OTHER NAMES
CIF CDF SWAP /UNPACK THE NAME
JMS I (XGETNAM
JMS MOVNAM /GET THE NAME WHERE IT COUNTS
JMS I (DTFREE /SEE, WE DIDN'T USE THE TAPE!
ISZ MODE /NEW OR RENAME COMMAND?
JMP I (READY
BYE, TSTCCR
ERR002, ERROR /JUNK
UDF
DCA I ALINE0 /NO TEXT
L0002
TAD ALINE0
DCA BUFR /FREE UP TEXT SPACE
END, TAD STARTV
DCA LASTV
JMP I (READY
MOVNAM, 0
CDF SWAP /MOVE NAME DOWN
TAD I CCR /TAD I [NAMEX
DCA NAME
TAD I (NAMEX+1
DCA NAME+1
TAD I (NAMEX+2
DCA NAME+2
CDF
JMP I MOVNAM
INPUTX, DCA DATAPC
TAD CCR
DCA DATAPC+4 /AUTO-RESTORE
COMMAN
TAD M6
SPA
JMP IMMED /IMMEDIATE MODE
TAD (COMGO1
DCA T1
CDF SWAP
TAD I T1
CDF
DCA T1
JMP I T1
IMMED, L7777
TAD COMBUF
DCA LINEPC
L7777
DCA LINENO /IMMEDIATE MODE
JMS I (OTPACK
JMP I (RUN8+1
/*ON* COMMAND--ON-GOTO AND ON-GOSUB
ON, PUSHJ /GET VALUE
EVAL
COMMAN
TAD C7
SNA
JMP .+5
TAD (4
SZA CLA
ERR300, ERROR
L7777
DCA T2
JMS I INTEGE
SNA SPA SZL
JMP ON2
CIA
DCA T1
ON1, GETLN
ISZ T1
JMP .+3
TAD LINENO
PUSHA
TSTCOM
JMP .+3
GETC
JMP ON1
TSTEND
JMP ERR300
TAD T1
SPA CLA
JMP ON2 /IT WASN'T THERE
POPA
DCA LINENO
TAD LINENO
ISZ T2
POPJ /*GOTO* COMMAND--TRANSFER TO IT
JMP GOSUB3 /*GOSUB* CMD--CALL GOSUB (NO NEED TO CLEAR AC)
ON2, TAD ERLINE /INDEX WAS OUT OF RANGE
DCA LINENO
POPJ
PRIN12, FINT
FPUT I (IF1 /SETUP CALL TO 'MOD'
FEXT
PUSHF
F72
POPF
FLARG
PUSHJ
MOD1
PUSHJ
ABS /MAKE IT POSITIVE
JMP I (PRIN11
PAGE
/GET A VARIABLE OR FUNCTION ROUTINE
/EXIT WITH AC NON-ZERO IF FUNCTION
/AC IS LIST POINTER UNLESS
/AC IS NEGATIVE, THEN AC IS CHAR FOR USER FUNCTION
GETVAR, TSTALP
ERR220, ERROR /MUST BE LETTER
TAD CHAR
AND P37
RTL6
RAR
DCA ADD /SAVE FOR NAME
GETC
TESTC
JMP SUBT /T - TEST FOR SUBSCRIPT
JMP P37-1 /N - ADD TO NAME
JMP I FUNCTI /TRY FOR FUNCTION
TAD CHAR /CHECK FOR $
TAD MDOLR
SZA CLA
JMP LOOKUP
ISZ MODE /IT'S A STRING!
JMP .+4
TESTN
P37, 37
JMP LOOKUP /WAS A .
TAD CHAR
AND P37
TAD ADD
DCA ADD /NEW NAME
GETC
SORTC
TERMS-1
JMP SUBT
LOOKUP, UDF
TAD LASTV
GS1, DCA PT1 /POINT TO VARIABLES
TAD STARTV
CIA
TAD PT1
SNA CLA
JMP GS2 /NOT FOUND AT ALL
TAD I PT1 /GET NAME
CLL CIA
TAD ADD
SNA
JMP I GFND1I /FOUND NAME
SNL
CIA /POSITIVE DIFFERENCE
CLL RTL /AC WILL BE 0 IF DIFFERENCE WAS 2000
SNA CLA
ERR130, ERROR /ERROR - A(I) AND A(I,I) CANNOT EXIST TOGETHER
TAD I PT1
SPA CLA
L7777 /BACK 1 FOR SUBSCRIPT
GS4, TAD M4
TAD PT1
JMP GS1
GS2, TAD C7
TAD LASTV /ROOM LEFT
CLL CIA
TAD PDLXR
SZL CLA
JMP .+4
TAD STARTV
DCA LASTV /WIPE OUT VARIABLES--OVERFLOW
ERR100, ERROR /NO ROOM
L0001
RTL
TAD LASTV
DCA PT1 /POINT TO NEW SPACE
TAD ADD
SMA CLA
JMP GPUT1
TAD SUBS
DCA I PT1 /SET SUBSCRIPT
ISZ PT1
GPUT1, TAD ADD
DCA I PT1 /SET NAME
CDF
TAD PT1
PUSHA
L0001
TAD LASTV
DCA PT1 /POINT TO NEW DATA SPACE
POPA
DCA LASTV /NEW LIMIT
FLPUT /SET TO 0
FLZERO
JMP I GS5I
SUB2I, SUB2
GS5I, GS5
FUNCTI, FUNCT
ECALLI, ECALL
AC3I, AC3
MDOLR, -44
GFND1I, GFND1
SUBT, TSTLPR
JMP LOOKUP /NOT SUBSCRIPTED
TAD ADD
DCA EFOP
JMS I ECALLI /GET SUBSCRIPT
L4000
POPA
DCA ADD /SAVE NAME
JMS I INTEGE
SPA SZL
SUB1, ERROR /TOO BIG OR NEGATIVE
ERR230=SUB1
DCA SUBS /SET SUBSCRIPT
TSTCOM
JMP I SUB2I /ONLY ONE SUBSCRIPT
PUSHF /SAVE ADD,SUBS
ADD
PUSHJ /GET SECOND SUBSCRIPT
EVAL-1
POPF
ADD
JMS I INTEGE
AND C7700
RAR
SZA CLA
JMP SUB1 /TOO BIG
TAD SUBS
AND C7700
SZA CLA
JMP SUB1 /TOO BIG
TAD SUBS
RTL6
CDF SWAP
TAD I AC3I /FORM DOUBLE SUBSCRIPT
CDF
DCA SUBS
L2000
TAD ADD
DCA ADD /INDICATE 2 SUBSCRIPTS
SUB2, JMS I (PARTST /CHECK PAREN MATCH
JMP I (LOOKUP
GFND1, TAD ADD
SMA CLA
JMP GFND2 /NO SUBSCRIPT
L7777
TAD PT1
DCA PT1
TAD I PT1 /GET SUBSCRIPT
CIA
TAD SUBS
SZA CLA
JMP I (GS4 /WRONG SUBSCRIPT
GFND2, CDF
L7775
TAD PT1
DCA PT1 /POINT TO DATA
GS5, FLGET /GET VARIABLE
FLARG
POPJ
FUNCT, TAD CHAR
AND (37
TAD ADD
SORTC /CHECK 2 LETTERS
FUNL1-1
SKP
JMP I (LOOKUP /NOT A FUNCTION
TAD SORTCN
SNA CLA
JMP FUNCT4 /USER FUNCTION
PUSHF
TEXTP
TAD CHAR
PUSHA
GETC
TAD CHAR
DCA PT1
POPA
DCA CHAR
POPF
TEXTP
TAD SORTCN
TAD (FUNL2-1
DCA T3
CDF SWAP
TAD I T3 /GET CORRECT CODE
TAD PT1
SZA CLA
JMP I (LOOKUP /WAS NOT A FUNCTION
TAD SORTCN
PUSHA /SAVE CONSTANT
GETC
FUNCT5, GETC
SORTC
TERMS-1
TSTLPR
ERR240, ERROR /NO L-PAREN
POPA
IAC /FUNCTION CODE
POPJ
FUNCT4, GETC
TSTALP
ERR250, ERROR /NOT LETTER
L3777
TAD CHAR
PUSHA /SAVE CHAR OF USER FUNCTION
JMP FUNCT5
/*SORTC* ROUTINE
XSORTC, 0
SNA
TAD CHAR /USE CHAR IF AC IS 0
CIA
DCA T3
TAD I XSORTC
DCA XREG3 /SET TO LIST
CDF SWAP
TAD I XREG3
CDF
SPA
JMP XSORT3 /END OF LIST
TAD T3
SZA CLA
JMP .-7 /NO GO - LOOP
TAD I XSORTC
CMA
TAD XREG3
DCA SORTCN /SET CONSTANT
SKP
XSORT3, ISZ XSORTC
ISZ XSORTC
CLL CLA
JMP I XSORTC
/*SORTJ* ROUTINE
XSORTJ, 0
SNA
TAD CHAR /USE CHAR IF AC IS 0
CIA
DCA T3
TAD I XSORTJ
DCA XREG3 /SET TO LIST
ISZ XSORTJ
TAD I XREG3
SPA
JMP XSORT1 /END OF LIST
TAD T3
SZA CLA
JMP .-5 /NO GO - LOOP
TAD XREG3
TAD I XSORTJ
DCA XSORTJ
CDF SWAP
TAD I XSORTJ /GET ADDRESS
CDF
DCA XSORTJ
XSORT1, CLL CLA
ISZ XSORTJ
JMP I XSORTJ
XPRT1, 0 /PRINTC FOR FIELD 1
PRINTC
CIF CDF SWAP
JMP I XPRT1
PAGE
FLOUT, 0
CIF CDF SWAP
JMS I (OFLOUT
JMP I FLOUT
ISZ I (PRNT5
JMS I (ITPRNT
JMP I FLOUT
SGN, FINT
FSGE
FGET MNSONE
FSLE
FGET I (FLTONE
FEXT
POPJ
MNSONE, 6014
0
0
FUPARR, FPUT I (TEMP
FGET I PT1
FADD I (FCN
FCMP I PT1
FSEQ
FJMP EXPLNG
FGET I PT1
FSGE
FMUL MNSONE
FSUB I (FUPAR1
FSLE
FJMP EXPLNG
FGET I PT1
FSLT
FJMP .+5
FGET I (FLTONE
FDIV I (TEMP
FPUT I (TEMP
FGET I PT1
FEXT
JMS I INTEGE
SPA
CIA
CMA
DCA FUPAR2
FINT
FGET I (FLTONE
FEXT
JMP .+4
FINT
FMUL I (TEMP
FEXT
ISZ FUPAR2
JMP .-4
JMP FUPAR3
FUPAR2=FLOUT
EXPLNG, FGET I (TEMP
FEXT
PUSHJ
LOG
FINT
FMUL I PT1
FEXT
PUSHJ
FEXP
FUPAR3, FINT
FJMP I (FLOP+1
TAPE, L0001
KKEY, DCA PT1 /SAVE CONSTANT FOR OUTPUT
TSTCCR
ERR003, ERROR /JUNK
JMS I (RUN9 /DISMISS US NOW
TAD TELSW
SZA CLA
JMP .-3 /STILL BUSY - WAIT
TAD PT1
DCA OUTPUT /SET OUTPUT
JMP I (READY
FUNC16, GETC
TAD CHAR
TAD FMEQL
SZA CLA
ERR210, ERROR
PUSHJ
EVAL-1
TSTEND
JMP .-4
POPA
DCA ERLINE
TAD ERLINE
DCA LINENO
FINDLN
FMEQL, -"=+200
POPA
DCA LASTV
POPA
DCA SORTCN
POPF
TEXTP
DCA MODE /!!!
JMP I (ENDFUN
XFLGET, 0
SZA
JMP .+3
L7777
TAD PT1
XFLGT2, DCA FLTXR
L7777
TAD I XFLGET
DCA FLTXR2
L7775
DCA T3
UDF
TAD I FLTXR
CDF
DCA I FLTXR2
ISZ T3
JMP .-5
ISZ XFLGET
JMP I XFLGET
PAGE
INTRPT, DCA SAVAC /SAVE THE AC
RAR
DCA SAVLK /AND THE LINK
TAD T3
DCA T3SV /SAVE T3
TAD XREG3
DCA XREG3S /SAVE XREG3
TAD SORTCN
DCA SRTCNS /SAVE SORTCN
TAD I AUDF
DCA UDFSV /SAVE UDF ADDRESS
TAD I ASORTC
DCA SORTCS /SAVE SORTC ADDRESS
TAD I PXFREE
DCA FREESV /SAVE XFREE ADDRESS
DCA USER /START AT USER 0
DCA TEMP1 /NO TTY'S TO TURN ON AT FIRST
TAD TADINT
DCA INTRP1 /SET LIST POINTER
INTRP1, HLT /GET TLS IOT
TAD M4
DCA INTRP4 /TCF
L7777
TAD INTRP4
DCA INTRP3 /TSF
TAD M10
TAD INTRP3
DCA INTRP2 /KSF
CIF CDF SWAP /GO CHECK DECTAPE FLAG
JMS DTINTR
TAD TEMP1
MTON /TURN ON PROPER USER
CLA
INTRP2, HLT /KEY?
/IF NOT DC02,
/INTRP2-2 AND INTRP2+4 ARE SET TO ZERO IN BEG760
SKP /NO
JMS I PKEY /READ TTY
TAD TEMP1
MTON /USER ON AGAIN
CLL RAR /SHIFT FOR NEXT USER
SNA /FIRST TIME?
L4000 /YES - GET TTY #1 BIT
DCA TEMP1
INTRP3, HLT /TTY?
JMP .+3 /NO
INTRP4, HLT /CLEAR ITS FLAG
JMS I PTTY /DO TTY OUTPUT
ISZ USER /NEXT USER PLEASE
ISZ INTRP1 /BUMP LIST POINTER
TAD USER
TAD MUSER /ARE WE DONE?
SZA CLA
JMP INTRP1 /NO
INTRP5, TAD AUSER
/IF NOT DC02,
/INTRP5 AND INTRP5+1 ARE SET TO ZERO IN BEG760
MTON /TURN ALL USERS ON AGAIN
CLA
TAD I LOOK /GET RUNNING USER
JMS I DECKNI /AND PUT HIM ONDECK
TAD T3SV
DCA T3 /RESTORE ALL THOS STORED THINGS
TAD XREG3S
DCA XREG3
TAD SRTCNS
DCA SORTCN
TAD UDFSV
DCA I AUDF
TAD SORTCS
DCA I ASORTC
TAD FREESV
DCA I PXFREE
ISZ I PINTCN /COUNT INTERRUPTS
DECKNI, DECKON
TAD SAVLK /GET LINK BACK
CLL RAL
TAD SAVAC /AND THE AC ALSO
RMF
ION
JMP I 0 /EXIT FROM INTERRUPT
TADINT, TAD INTRPL
PKEY, KEY
PTTY, TTY
PXFREE, XFREE
PINTCN, INTCNT
SAVAC, 0
SAVLK, 0
T3SV, 0
XREG3S, 0
SRTCNS, 0
UDFSV, 0
FREESV, 0
MUSER, -1 /-1 FOR 1 USER, -2 FOR 2, ETC.
/(SET IN INIT)
AUSER, 0 /4000 FOR 2 USERS; 6000 FOR 3 USERS; ETC.
SORTCS, 0
INTRPL, TLS /USER 0 TLS IOT
MTLS /USER 1 TLS IOT
MTLS /USER 2
MTLS /USER 3
MTLS /USER 4
CIF SWAP
JMP I INTRPL-1 /AND EXIT
/CHECK IF STRING RETURNED, SET UP TO GET SECOND ARG
/FOR MID AND CAT FUNCTIONS
GETSTR, 0
TAD MODE /MAKE SURE FIRST ARG IS A STRING
SZA CLA
TSTCOM /CHECK FOR COMMA
ERR560, ERROR /FIRST ARG NOT STRING, MISSING ARG
PUSHF /SAVE THE STRING
FLARG
DCA MODE /CLEAR MODE TO CHECK NEXT ARG TYPE
JMP I GETSTR /RETURN
/FIX FOR KL8/E HARDWARE BUG:
/(BARRY OR STEVE--MOVE THIS TO FIELD 1 SOMETIME. THIS SPACE COULD
/BE BETTER USED)
KL8FIX, TAD TADINT
DCA KL8F1
TAD MUSER
DCA T2
IAC
TAD M12
KL8F1, HLT
DCA .+2
IAC
HLT
ISZ KL8F1
ISZ T2
JMP KL8F1-1
CLA MQA
IAC
MQL
TAD LOOKST
DCA LOOK
JMP NULL
OPTABL, FGET I PT1
FADD I PT1
FSUB I PT1
FMUL I PT1
FDIV I PT1
FJMP 0
PRNTEX, TAD CHAR
PUSHA
PUSHF
TEXTP
PUSHF
FLARG
TAD PDLXR
DCA AXOUT /SET UP UNPACKING FROM STACK
DCA XCT
TAD M6
DCA MODE
ISZ SPACSW
PRNTX1, GETC
TSTCCR
SKP
JMP .+4
PRINTC
ISZ MODE
JMP PRNTX1
POPF
FLARG
POPF
TEXTP
POPA
DCA CHAR
DCA MODE /IN CASE OF A STRING LESS THAN 6
DCA SPACSW /IGNORE SPACES AGAIN
JMP PRINT
FIX, 0
CIF CDF SWAP /CALL THE FIX ROUTINE
JMS I (FIX1
JMP I FIX
OLD, TAD (SAVDN1 /SET UP FAKE RETURN FOR *OLD* COMMAND
DCA CHAINP /TO LOCK THE TAPE ON AN OLD
JMP I (OLD1 /GO TO REAL ROUTINE
PRNTL4, 73 /;
PRNTL1, 54 /,
47 /'
PRNTL7, 42 /"
15 /CR
134 /\
/FUNCTIONS IN FIELD 1 CALLED WITH *PUSHJ*
RND, FINT
FGET FRNDX
FEXT
TAD (ORND-OINT
INT, TAD (OINT-OFFIX
FFIX, TAD (OFFIX-OSQR
SQR, TAD (OSQR-OTAN
TAN, TAD (OTAN-OCOS
COS, TAD (OCOS-OFSIN
FSIN, TAD (OFSIN-OFEXP
FEXP, TAD (OFEXP-OLOG
LOG, TAD (OLOG-OATN
ATN, TAD (OATN
DCA T3
CIF CDF SWAP
JMP I T3
SETUPO, 0
TAD (XPUT
DCA PPRINT
TAD (OFREE2
DCA PFREE2
TAD (OFREE3
DCA PFREE3
JMP I SETUPO
PRINT0, TAD CHAR
TAD (200-"#
SZA CLA
JMP PRINT /OK AS IS
TAD OBLK /THIS WILL WORK BECAUSE HE CAN'T USE BLOCK 0
CLL RAR
TAD OBLKH
SZA CLA
GETC
TSTCOM
JMP I (ERR600
GETC
JMS SETUPO
PRINT, PUSHJ
PRIN10
SZA CLA
POPJ /ALL DONE
FREE13
PUSHJ
EVAL /GET EXPR.
TAD MODE
SZA CLA
JMP PRNTEX
TAD PRNTC1
TAD (16
SPA CLA
JMP .+3 /IT WILL FIT
TAD CCR /MAKE IT FIT
PRINTC
JMS I (FLOUT
PRNTX2, L7777
JMP PRINT
FREE2
TAD CCR
PRINTC
PRINT6, IAC
POPJ
PAGE
/*OR* ROUTINE
XOR, 0
DCA T3
TAD I XOR
CMA
AND T3
TAD I XOR
DCA I LOOK
JMP NULL
INPACK, 0
TAD COMBUF
DCA AXIN
DCA XCTIN
TAD COMBUF
DCA PACKST
TAD (ALINE0
DCA PACKND
JMP I INPACK
OTPACK, 0
TAD COMBUF
DCA AXOUT
DCA XCT
TAD CCR /DON'T MOVE PDLXR FROM 15
DCA PACKND
GETC
JMP I OTPACK
PAKLIN, JMS INPACK
READC
JMP .+3
L0001
POPJ
PACKC
TSTCCR
JMP .-6
PACKC
JMS OTPACK
POPJ
FPNT, 0 /CALL THE REAL INTERPRETER
CLA CLL
TAD FPNT
CIF CDF SWAP
DCA I (OFPNT
JMP I (OFPNT+3 /SET FIELD 0
OTEST2, 0 /FIELD 1 *TESTN*
TESTN
JMP .+4 /RETURN +1
SKP /+2
ISZ OTEST2 /+3
ISZ OTEST2
CIF CDF SWAP /RETURN TO FIELD 1
JMP I OTEST2
XGETLN, 0 /*GETLN*
CIF CDF 10 /CALL THE REAL ROUTINE
JMS I (OGETLN
JMP I XGETLN
/PAREN TEST ROUTINE
PARTST, 0
POPA
DCA LASTOP /SAVED BY *ECALL*
L7776
TAD SORTCN
CIA
POPA /CHECK MATCH
SZA CLA
ERR260, ERROR /NO MATCH
GETC
JMP I PARTST
/*RETURN* AND *POPJ*
RETURN, ISZ PDLXR /DUMP ONE RETURN ADDRESS
TSTEND
ERR320, ERROR
XPOPJ, DCA XREG3 /SAVE AC
POPA
DCA T3 /RETURN ADDRESS
TAD XREG3 /GET AC
JMP I T3
FUNCT3, DCA EFOP
JMS I IECALL
POPA
SPA
JMP I FUNC6I
TAD FUNL3I
DCA EFOP
CDF SWAP
TAD I EFOP
CDF
DCA .+2
PUSHJ
0
JMP I (ENDFUN
IECALL, ECALL
FUNC6I, FUNCT6
FUNL3I, FUNL3-2
FLIN, 0
CIF CDF SWAP
JMS I (OFLIN
FINT
FPUT I PT1
FEXT
JMP I FLIN
GETNAM, TSTEND /DID THEY GIVE A NAME?
POPJ /YES, GO UNPACK IT
FREE13 /PRINT "NAME--"
TAD (21 /POINT TO TEXT
JMS I (READY1
PUSHJ /GO PACK THE REPLY
PAKLIN
POPJ
ALPTST, 0
TAD CHAR
TAD (-"A+200
SPA CLA
JMP I ALPTST /LESS THAN *A*
TAD CHAR
TAD (-"Z+200
SPA SNA CLA
ISZ ALPTST
JMP I ALPTST
F72, 2074;4000;0
PAGE
/*FREE2* AND *FREE13* ROUTINES
XFREE2, 0
JMS XFREE /ROOM
JMP .+3 /WE MUST WAIT
0
JMP I XFREE2
TAD XFREE2
JMP FREEWT /GET ROOM
XFREE3, 0
JMS XFREE /ROOM
FREEC, 14
SKP /MUST WAIT
JMP I XFREE3
TAD XFREE3
FREEWT, DCA PC /SET RESTART
TAD I LOOK
JMS I (XOR /SET O WAIT AND DISMISS
2000
/*FREE* ROUTINE
XFREE, 0
UDF
TAD I OPTRI /ANY ROOM
CDF
SZA CLA
JMP I XFREE /NO
TAD OPTRI
CIA
TAD OPTRO
SPA SNA
TAD C40
CIA /-COUNT
IAC
SNA
JMP I XFREE /ONLY 1 FREE
IAC
SNA
JMP I XFREE /ONLY 2 FREE
ISZ XFREE
TAD FREEC
SPA SNA CLA
ISZ XFREE /14 OR MORE FREE
JMP I XFREE
/*LINPUT* COMMAND, INPUT AN ENTIRE LINE OF TEXT
/INTO A STRING ARRAY
LINPUT, JMS I (CHKFIL /CHECK IF FILE INPUT
DCA SUBS /CLEAR SUBSCRIPT
PUSHJ /GET VARIABLE
GETVAR
SNA CLA /FUNCTION?
TSTEND
ERR540, ERROR /ILLEGAL OR MORE THAN ONE VARIABLE
TAD MODE
SNA CLA
JMP .-3 /NOT STRING VARIABLE
PUSHF /SAVE PT1;CHAR;LINEPC
PT1
PUSHF /SAVE TEXT POINTERS
TEXTP
TAD ADD /CHECK IF SUBSCRIPTED
CLL RAL
STL RAR
DCA ADD
TAD SUBS
AND C7700 /ZERO LAST DIMENSION
DCA SUBS
PUSHF /SAVE NAME AND SUBSCRIPT
ADD
ISZ SPACSW /KEEP LEADING SPACES
PUSHJ /GET LINE OF INPUT
GETINP
DCA LINCT /ZERO CHARACTER COUNTER
POPF /RESTORE NAME AND SUBSCRIPT
ADD
JMP .+3
LINXT, ISZ SPACSW /KEEP SPACES
GETC /SKIP OVER COMMA
ISZ SUBS /INCREMENT SUBSCRIPT
PUSHJ /GET VARIABLE
LOOKUP
PUSHF /SAVE NAME AND SUBSCRIPT
ADD
PUSHJ /GET NEXT 6 CHARS OF STRING
QLINP
LINXT2, TAD I (QCT1 /GET CHARACTER COUNT
TAD LINCT /BUMP CHARACTER COUNT
DCA LINCT
POPF /RESTORE NAME AND SUBSCRIPT
ADD
FLPUT /SET VARIABLE
FLARG
TSTEND /END OF STRING?
JMP LINXT /NO, GET NEXT 6 CHARS
TAD SUBS /ZERO LAST DIMENSION
AND C7700
DCA SUBS
PUSHJ
LOOKUP /GET VARIABLE
TAD LINCT
JMS I (FLOAT /FLOAT AC INTO FLARG
FLPUT /PUT IT AWAY
FLARG
POPF /RESTORE TEXT
TEXTP
POPF /RESTORE OTHER GARBAGE
PT1
POPJ /RETURN
MGET, 0 /FAKE OUT GETC
ISZ T2 /CHECK FLAG
JMP MGET1
TAD CNTR
JMP MGET2
MGET1, L7777 /SET FLAG
DCA T2
TAD I FLTXR /GET NEW PAIR
DCA CNTR
TAD CNTR
RTR
RTR
RTR
MGET2, AND C77 /KILL GARGAGE
JMP I MGET /RETURN
LINCT,
TEMP, 0
0
0
FLARG, 0
0
0
PAGE
/*MID* FUNCTION FORMAT: MID(A$,X,Y)
/RETURNS Y CHARACTERS STARTING WITH THE XTH CHAR IN A$
MID, JMS I (GETSTR /GET THE FIRST TWO ARGS
PUSHJ
EVAL-1
JMS MIDCHK /CHECK IF ARG IN BOUNDS
PUSHA /SAVE FOR LATER
TSTCOM /ANOTHER COMMA?
ERR550, ERROR /MISSING OR BAD ARG
PUSHJ /GET THIRD ARG
EVAL-1
JMS MIDCHK /CHECK ARG
DCA MIDC2
POPA /GET SECOND ARG
DCA MIDC1 /SAVE
POPF /GET STRING
FLARG
TAD (FLARG-1
DCA FLTXR2 /PACK POINTER
DCA T1 /PACK SWITCH
TAD MIDC1 /# OF CHARS TO IGNORE
CIA
CLL RAR
TAD FLTXR2 /CALCULATE FIRST CHAR
DCA FLTXR
SZL /CHECK IF PARTIAL
CLA CMA
DCA T2 /UNPACK SWITCH
SZL
TAD I FLTXR /GET CHAR IF PARTIAL
DCA CNTR
MID1, L7777 /CALCULATE NUMBER OF CHARS TO TRANSFER
TAD MIDC2
DCA MIDC2
TAD MIDC2
TAD MIDC1
CIA
TAD M6
SMA SZA CLA
JMP ERR550 /SECOND ARG LESS THAN FIRST
TAD M6 /CHARACTER COUNTER
DCA MODE
MID2, JMS I (MGET /GET CHAR
JMS MPUT /PUT CHAR
ISZ MODE
SKP
JMP MID3 /DONE WITH ALL 6 CHARS
ISZ MIDC2
JMP MID2 /GET ANOTHER CHARACTER
TAD C77
JMS MPUT /FILL STRING WITH CR'S
ISZ MODE
JMP .-3
MID3, ISZ MODE /SET STRING MODE FOR STRING *IF*'S
ISZ PDLXR /KILL POPJ RETURN
JMP I .+1 /SPECIAL RETURN FOR STRING FUNCTIONS
ENDF1
MIDCHK, 0 /CHECK ARGUMENT LIMITS
JMS I INTEGE /MAKE AN INTEGER
SPA SNA SZL /CHECK IF ZERO, NEGATIVE OR TOO BIG
JMP ERR550
CIA
TAD C7 /CHECK IF TOO BIG
SPA SNA
JMP ERR550 /TOO BIG
TAD M6 /FIX IT UP
JMP I MIDCHK
MIDC1, 0 /FIRST CHAR TO COPY
MIDC2, 0 /LAST CHAR TO COPY
MPUT, 0 /FAKE OUT PACKC
ISZ T1 /CHECK FLAG
JMP MPUT1
TAD T3
DCA I FLTXR2 /STASH CHAR
JMP I MPUT
MPUT1, RTL6
AND C7700
DCA T3 /SAVE PARTIAL
L7777 /SET FLAG
DCA T1
JMP I MPUT
/*CAT* FUNCTION FORMAT: CAT(A$,B$)
/RETURNS A STRING OF A$ CONCATENATED WITH B$
CAT, JMS I (GETSTR /GET TWO ARGUMENTS
PUSHJ
EVAL-1
TAD MODE /CHECK IF SECOND ARG IS A STRING
SNA
JMP ERR550
DCA SPACSW /KEEP SPACES
TAD M6 /COUNT FOR 6 CHARS
DCA MIDC2
DCA MIDCHK /CLEAR FLAG
POPF /FIRST STRING INTO FLARG
FLARG
FINT /PUT STRING INTO IF1
FPUT I (IF1
FEXT
TAD (FLARG-1 /POINT TO STRING
DCA FLTXR
DCA T2 /CLEAR UNPACK SWITCH
TAD (FLARG-1 /POINT TO PACKING TEMP
DCA FLTXR2
DCA T1 /CLEAR PACK SWITCH
CCAT1, JMS I (MGET /GET A CHAR
DCA MIDC1 /SAVE
TAD MIDC1
IAC
AND C7700 /CHECK FOR CR
SZA CLA
JMP CCAT2 /CR FOUND
TAD MIDC1
CCAT3, JMS MPUT /REPACK CHAR
ISZ MIDC2 /CHECK IF 6 YET
JMP CCAT1
JMP MID3 /RETURN
CCAT2, TAD MIDCHK /CHECK IF ALREADY HERE
SNA CLA
JMP .+3
TAD MIDC1 /FLAG SET, RESTORE CHAR
JMP CCAT3
TAD (IF1-1 /SET POINTERS TO SECOND STRING
DCA FLTXR
DCA T2 /CLEAR FLAG
ISZ MIDCHK /SET FLAG
JMP CCAT1
PAGE
/*FLPUT* ROUTINE
XFLPUT, 0
SZA
JMP .+3
L7777
TAD PT1
XFLPT2, DCA FLTXR
L7777
TAD I XFLPUT
DCA FLTXR2
L7775
DCA T3
TAD I FLTXR2 /PUT VARIABLE
UDF
DCA I FLTXR
CDF
ISZ T3
JMP .-5
ISZ XFLPUT
JMP I XFLPUT
/CHARACTER TEST ROUTINES
COMTST, 0
TAD (-",+200
TAD CHAR
SNA CLA
ISZ COMTST /FOUND IT
JMP I COMTST
CCRTST, 0
TAD CCRTST
DCA COMTST
TAD (-15
JMP COMTST+2
ENDTST, 0
TAD (-"'+200
TAD CHAR
SZA
TAD ("'-"\
SNA CLA
ISZ ENDTST
TAD ENDTST
JMP CCRTST+2
/*LEN* FUNCTION, RETURNS NUMBER OF CHARACTERS
/(UP TO 6) IN A STRING
LEN, DCA CNTR /CHAR COUNTER
L7775 /COUNT FOR 3 WORDS
DCA T1
CLA STL CMA
TAD FLARGP
DCA FLTXR
LENXT, TAD I FLTXR /GET NEXT TWO CHARACTERS
TAD C100
SZL /LINK SET ONLY IF TOP HALF IS CR
JMP LENDON
ISZ CNTR /COUNT CHAR
AND C77 /KILL TOP HALF
IAC
AND C7700 /KILL BOTTOM HALF
SZA CLA /AC=100 IF BOTTOM HALF IS CR
JMP LENDON
ISZ CNTR /COUNT CHAR
ISZ T1 /DONE?
JMP LENXT
LENDON, CLA /CLEAR GARBAGE IN AC
DCA MODE /NO LONGER STRING MODE
TAD CNTR
JMS FLOAT /FLOAT NUMBER INTO FLARG
POPJ
/FLOATS NUMBER IN AC INTO FLARG
FLOAT, 0
DCA T1 /SAVE NUMBER
TAD (ACSIGN-1 /SET TO FLOAT
DCA FLTXR
CDF SWAP
DCA I FLTXR /ZERO ACSIGN
DCA I FLTXR
TAD (217 /EXPONENT FUDGE
DCA I FLTXR /INTO ACEXP
DCA I FLTXR /ZERO AC3
TAD T1
DCA I FLTXR /NUMBER IN AC2
DCA I FLTXR /ZERO AC1
FINT
FNOR /FLOAT NUMBER
FPUT I FLARGP /PUT INTO FLARG
FEXT
JMP I FLOAT /DONE
POPF
FLARG
ENDFND, DCA SPACSW
PUSHF
TEXTP
GETC
TSTEND
JMP .-2
TSTCCR
JMP ENDFND-2
POPF
TEXTP
GETC
COMMAN
IAC
POPJ
XPUT, 0 /FILE OUTPUT ROUTINE
SNA
TAD CHAR
DCA T3
TAD XPUT
PUSHA
XPUT3, TAD T3
PUSHA
TAD T3
JMS I (XPUT0
POPA
TAD (-15
SZA CLA
POPJ
TAD CLF
DCA T3
JMP XPUT3
CHAIN, JMS I (DTGRAB
TAD (CHAIN1
DCA CHAINP
JMP I (CHAIN2
PAGE
C6777, 6777 /THIS MUST BE AT THE BEGINNING OF THE PAGE CHECK C200
DTQ1, DTQ
DTQ2, DTQ
DTGRAB, 0 /GET THE TAPE!
CIF 10 /CALL CHECKING ROUTINE
JMS I (DTCHKX
DCA I DTQ2
TAD DTQ2 /BUMP QUEUE POINTER
IAC /(MUST BE AT START OF PAGE)
AND (7607
DCA DTQ2
TAD DTQ1 /WAS THE QUEUE EMPTY?
CLL CMA
TAD DTQ2
AND C7
SNA CLA
JMP XDTG1 /YES, GIVE THIS JOB THE TAPE
TAD DTGRAB /SET RESTART ADDRESS
DCA PC
TAD I LOOK /SET DECTAPE BUSY
JMS I (XOR /AND DISMISS
1000
XDTG1, ION /RETURN TO THE JOB
JMP I DTGRAB /(WITH THE DECTAPE)
DTFREE, 0 /LET THE TAPE GO
TAD CHAINP /CHECK IF WE SHOULD HOLD ONTO TAPE
TAD (-READY /FOR AN OLD, SAVE, OR CHAIN
SZA CLA
JMP I DTFREE /RETURN, BUT STILL HOLD ONTO TAPE!!
DCA I DTQ1 /CLEAR THE SLOT
TAD DTQ1 /BUMP THE POINTER
IAC
AND (7607
DCA DTQ1
TAD I DTQ1 /IS THERE ANOTHER REQUEST?
SNA
JMP I DTFREE /NO, ALL DONE!
TAD LOOKST /BUILD A POINTER TO STATUS
DCA T3
CIF 0 /*** THIS IS REALLY AN IOF UNTILL JMP I DTFREE
TAD I T3 /CLEAR DECTAPE BUSY
C200, AND C6777 /THIS IS WHY C6777 MUST BE AT THE BEGINNING OF THE PAGE
DCA I T3
JMP I DTFREE /BACK TO CURRENT JOB
XGET, 0 /FILE INPUT ROUTINE
CLA CLL
ISZ I3 /3RD CHAR OF 3?
JMP GET1 /NO, NORMAL
L7776 /BACK UP POINTER
TAD IPNTR
DCA IPNTR
L7775 /RESET 3-WAY SWITCH
DCA I3
CDF SWAP /GET THE FIRST HALF
TAD I IPNTR
ISZ IPNTR
AND C7400
CLL RTL
RTL
DCA CHAR /HANDY TEMP
TAD I IPNTR /GET THE SECOND HALF
AND C7400
TAD CHAR /GET THE FIRST HALF (AGAIN?)
RTL
RTL
RAL
JMP GEXIT
GET1, TAD IPNTR /IS THERE ANY BUFFER?
AND C177
C12M32, SZA CLA SMA SNL /DUMMY SMA SNL TO PRODUCE (12-32
JMP GET2 /GUESS SO
TAD BASE /BUILD POINTER TO BUFFER
TAD C200
DCA IPNTR
TAD XGET /SAVE THE RETURN
PUSHA
JMS DTGRAB /GET THE DECTAPE
TAD IPNTR /MOVE THE ARGS
DCA IBUFF
TAD IBLK
DCA INBLK
TAD IBLKH
CLL RAR /LINK WILL HAVE THE HIGH ORDER ADDRESS
ISZ IBLK /NEXT BLOCK, NEXT TIME
SKP /THE NEXT 4 LOCATIONS ARE FOR THOSE WITH RK8E
ISZ IBLKH /WITH 17777 PAGES
CLA IAC /AC=1 FOR READ
CIF SWAP
JMS I (DTAPE /DO THE DECTAPE THING
IBUFF, 0
7600 /READ 200 WORDS (ONE PAGE)
INBLK, 0
JMS DTFREE /ALL THROUGH, GIVE IT BACK
POPA /RESTORE THE RETURN
DCA XGET
L7776 /PRETEND WE SET THE PACK SWITCH
DCA I3
GET2, CDF SWAP /NORMAL CHARACTER UNPACKING
TAD I IPNTR /GET THE CHARACTER
GEXIT, ISZ IPNTR
C7400, NOP 400 /IN CASE IT SKIPS
CDF
AND C177 /MASK OFF PARITY
SNA /IGNORE NULLS
JMP XGET+1
TAD M12 /AND LINE FEEDS
CLL RTR /AND FORM FEEDS
SNA
JMP XGET+1
RTL
TAD C12M32 /CHECK FOR ^Z. 12-32=7760=SZA CLA SMA SNL
SZA
JMP .+6
ISZ XGET /SKIP RETURN FOR EOF
DCA IBLK /CLEAR FILE OPEN
DCA IBLKH
TAD (XREADC /RESET 'READC'
DCA PREADC
TAD (32 /RESTORE CHAR
DCA CHAR
JMP I XGET /WHEW!
PAGE
DTQ, ZBLOCK 10
STRFIL, 0 /GET A STRING FILENAME
JMS I (DOLCHK /SET EXTENSION
PUSHJ /GET FILE NAME
EVAL
TAD CHAR /SAVE TEXT POINTERS
PUSHA
PUSHF
TEXTP
CLA CMA /PUSH A CR
PUSHA
PUSHF /FINALLY, PUSH THE STRING
FLARG
TAD PDLXR /SET UP UNPACKING (FROM THE STACK!)
DCA AXOUT
DCA XCT
GETC /GET THE FIRST CHAR
CIF CDF SWAP
JMS I (XGETNAM /GET THE FILE NAME
TAD PDLXR /UNSTACK GARBAGE
TAD (4
DCA PDLXR
POPF /RESTORE THE TEXT POINTERS
TEXTP
POPA
DCA CHAR
JMP I STRFIL /DONE WITH FILENAME
OPEN, JMS I (DTGRAB /GET THE DECTAPE
TAD M100 /SET '.DX' EXTENSION
JMS STRFIL /GET THE FILENAME
TAD CLF /DOUBLE CHECK FOR 'FOR'
COMMAN
SNA CLA
ERR620, ERROR /WASN'T THERE
COMMAN /MUST BE 'INPUT' OR 'OUTPUT'
TAD (5 /CHECK FOR 'INPUT'
SNA
JMP OINPUT
TAD (-5-4+32
SZA CLA
JMP ERR620
FILOUT, TSTCOM /LENGTH GIVEN?
JMP NOLEN /ASSUME 10 BLOCKS
PUSHJ /EVALUATE THE LENGTH
EVAL-1
JMS I INTEGER /FIX IT
SPA SNA SZL
ERR650, ERROR /TOO BIG OR TOO LITTLE
LENIN, DCA OMAX /SAVE LENGTH
TAD DECK /USER 0 CAN OPEN ANY LENGTH
SZA CLA
TAD OMAX /ANYBODY ELSE IS LIMITED TO 64
TAD C7700
SPA SNA CLA /TOO BIG, SCREW HIM!
LENOK, TSTEND /SHOULD BE END
JMP LENIN-1
TAD M100 /MAKE SURE EXTENSION IS CORRECT
JMS I (DOLCHK /(HE COULD HAVE SAID 'OPEN $')
TAD OMAX /PUT LENGTH FOR ENTER IN AC
CIF CDF SWAP
JMS I (XENTER /ENTER AND CLOSE
ERR630, ERROR
CLL RAL
DCA OBLK
RAL
DCA OBLKH
L7775
DCA O3 /INIT POINTERS
TAD BASE
DCA OPNTR
TAD OMAX /FORM MAXIMUM LENGTH (IN PAGES)
CLL RAL
CMA
DCA OMAX
JMP OUTOUT /USE SOME COMMON CODE
NOLEN, TAD CLF /ASSUME 10 BLOCKS
JMP LENIN
SAVDON, TAD PPRINT /WAS THIS A 'SAVE'?
TAD (-XPRNTC
SNA CLA
JMP I (READY /NO, GOTO 'READY'
PUSHJ /CLOSE THE FILE
CLOSE0
SAVDN1, JMS I (IOFIX
JMS I (DTFREE /RELEASE THE TAPE FOR REAL
JMP I (READY /ALL DONE!
OINPUT, TSTEND
JMP ERR620
CIF CDF SWAP
JMS I (FLOOK /LOOK UP THE FILE
CLL RAL /GET THE TAPE BLOCK*2 FOR PAGES
DCA IBLK
RAL
DCA IBLKH
DCA I3 /CLEAR THE SWITCH
DCA IPNTR /AND THE POINTER
OUTOUT, JMS I (DTFREE /GIVE UP THE TAPE
POPJ
RESTOR, TSTEND
ERR280, ERROR
DCA DATAPC
TAD CCR
DCA DATAPC+4
POPJ
FLTONE, 2014
FLZERO, 0
0
0
ERR330, ERROR
PAGE
XPUT0, 0
CDF SWAP
ISZ O3
JMP PUT1
DCA T3
L7776
TAD OPNTR
DCA OPNTR
JMS OPAK
JMS OPAK
CDF
L7775
DCA O3
TAD OPNTR
AND C177
SZA CLA
JMP I XPUT0
ISZ OMAX /GONE TOO FAR?
JMP .+4
DCA OBLK /CLEAR FILE
DCA OBLKH
ERR640, ERROR
TAD BASE
DCA OPNTR
JMS I (DTGRAB
TAD BASE
DCA OBUFF
TAD OBLK
DCA OUTBLK
TAD OBLKH
CLL RAR /OBLKH MUST BE EITHER 0 OR 1 NOTHING ELSE.
ISZ OBLK
SKP /RK8E AGAIN
ISZ OBLKH
CIF SWAP
JMS I (DTAPE
OBUFF, 0
7600
OUTBLK, 0
JMS I (DTFREE
JMP I XPUT0
PUT1, AND C177
DCA I OPNTR
ISZ OPNTR
CDF
JMP I XPUT0
OPAK, 0
TAD T3
CLL RTL
RTL
DCA T3
TAD T3
AND (7400
TAD I OPNTR
DCA I OPNTR
ISZ OPNTR
JMP I OPAK
OFREE2, 0
TAD OFREE2
PUSHA
TAD (-2+200
TAD BASE
CLL CIA
TAD OPNTR
SNL CLA
POPJ
L4000
PRINTC
TAD BASE
CIA
TAD OPNTR
SZA CLA
JMP .-6
POPJ
OFREE3, 0
TAD OFREE3
PUSHA
TAD M6
JMP OFREE2+3
OLD1, TAD CHAR /CHECK FOR LIBRARY CALL
TAD (-"$+200
SZA CLA
JMP .+4
GETC /SKIP OVER $
TAD C10
SKP
TAD DECK /PUSH HIS NUMBER IF NOT LIBRARY
PUSHA
PUSHJ /GET THE PROGRAM NAME
GETNAM
JMS I (DTGRAB /GET THE TAPE
POPA /SET THE EXTENSION
TAD (560
CIF CDF SWAP /UNPACK THE NAME
DCA I (EXTEN
JMS I (XGETNAM
SKP
CHAIN2, JMS I (STRFIL
JMS I (MOVNAM /MOVE THE NEW NAME DOWN
PUSHJ /LOOKUP THE FILE
OINPUT+2 /AND SWITCH TO FILE INPUT
UDF /SCRATCH USER AREA
DCA I ALINE0
CDF 0
L0002
TAD ALINE0
DCA BUFR
TAD (XGET
DCA PREADC
JMP I (START /RETURN TO COMMAND INPUT!
OPUS, POPA
DCA T3
CDF CIF 10
JMP I T3
PAGE
INTCNT, 0
RANDOM, TAD FRNDX+1
TAD INTCNT
DCA FRNDX
TAD INTCNT
DCA FRNDX+1
POPJ
XPRNTC, 0
IOF
PRINTX
ION
JMP I XPRNTC
CLOSE0, TAD OBLK /ANY FILE TO CLOSE?
CLL RAR
TAD OBLKH /THIS WILL WORK BECAUSE HE CAN'T USE BLOCK 0
SNA CLA
JMP I (ERR600
JMS I (SETUPO /OPEN OUTPUT
TAD (232 /WRITE A ^Z
PRINTC
TAD BASE
CIA
TAD OPNTR
SZA CLA
JMP .-6
DCA OBLK /CLOSE THE FILE!
DCA OBLKH
POPJ
SAVE, ISZ CHAINP /SET TAPE LOCKING FLAG
JMS I (DTGRAB /GET THE DECTAPE
CDF SWAP /MOVE THE NAME TO
TAD NAME /WORKING SPACE
DCA I CCR /** NAMEX IS AT LOCATION 15
TAD NAME+1
DCA I (NAMEX+1
TAD NAME+2
DCA I (NAMEX+2
TAD DECK
TAD (560 /SET '.EX' EXTENSION
DCA I (EXTEN
CDF
DCA OMAX /SETUP TO COMPUTE LENGTH
TAD ALINE0 /(BUFR)-(ALINE0)=LENGTH IN WORDS
CIA
TAD BUFR
CLL RAR /HALVE IT FOR THOSE USERS WITH OVER 2K
ISZ OMAX /(# WORDS)*2/(CHAR'S/BLOCK)+1=BLOCKS
TAD (-124 /(APPROX # CHAR'S/BLOCK)/2 (AND 2 AGAIN)
SMA
JMP .-3 /CONTINUE DIVISION
CLA CLL /NOW DO ENTER
PUSHJ /OPEN FILE
LENOK+4
DCA OUTPUT /FOR 'LIST'
JMS I (SETUPO /SETUP TO PRINT
JMP I (LIST /CALL 'LIST'
KILL, L4000
DCA ERLINE
UNSAVE, PUSHJ /GET THE NAME
GETNAM
JMS I (DTGRAB /GET THE DECTAPE
CIF CDF SWAP /BUILD THE NAME
JMS I (XGETNAM
TAD ERLINE /WHICH EXTENSION?
SZA CLA
TAD M100 /'.DX' EXTENSION
JMS DOLCHK /JUST TO SET '.EX' EXTENSION
CIF CDF SWAP /DO THE CLOSE
JMS I (XENTER /WHAT?
PCAT0, CAT0 /ENTER WITH 0 SHOULD ALWAYS SKIP
UNSAV1, JMS I (DTFREE /RELEASE THE TAPE
JMP I (READY /ALL DONE
DATLOG, L4000
DCA ERLINE
CATLOG, TAD CLF
PRINTC
JMS I (DTGRAB /GET THE TAPE
TAD ERLINE
SZA CLA
TAD M100 /LIST '.DX' EXTENSIONS
JMS DOLCHK /SET CATALOG TO LIST
CIF CDF SWAP /GET THE CATALOG
JMS I PCAT0
CATLUP, FREE13 /MAKE SURE THERE'S ROOM
CIF CDF SWAP /PRINT THE NEXT NAME
JMS I (CAT1
JMP CATLUP /DO IT AGAIN!
JMP UNSAV1
PRINT2, ISZ SPACSW /KEEP SPACES
GETC
SORTJ
PRNTL7-1 /CHECK " CR
PRNTL8-PRNTL7
FREE2
PRINTC
JMP PRINT2+1 /KEEP PRINTING THE LITERAL
DOLCHK, 0 /DECIDE WHICH CATALOG TO USE
TAD (560 /SET EITHER '.E0' OR '.D0'
DCA T1
TAD CHAR /CHECK FOR $
TAD (-"$+200
SNA CLA
JMP .+7
TAD DECK /ADD CURRENT USER TO EXTENSION
CDF SWAP
TAD T1
DCA I (EXTEN
CDF
JMP I DOLCHK
GETC /SKIP OVER $
TAD C10
JMP .-7
PAGE
FIELD 1
*5000
MVPAG=.
NOPUNCH
*7600 /THIS WILL BE MOVED LATER
ENPUNCH
JMP 7756 /FOR A MONITOR SYSTEM
QMQOT, -42
QPT1, .+1
11
QCT1, 0
QEVAL2, EVAL2+3
QINPACK,INPACK
QUOCNT, 0
IFNZRO 7610-. <IF STATEMENT WON'T WORK?!?!?>
IF5, SMA SZA CLA
SPA CLA
SNA CLA
SMA CLA
SPA SNA CLA
SZA CLA
QCOUNT, 0
QUOTES, TAD CHAR /LITERAL STRING
TAD QMQOT
SZA CLA
JMP I QEVAL2 /ERROR, NOT STRING
TAD QOPNEXT /SET UP POPJ RETURN
PUSHA
QINP, TAD QCON1 /ENTRY POINT FOR INPUT COMMAND
QLINP, TAD QCON2 /ENTRY POINT FOR LINPUT COMMAND
DCA QSLIS /WHICH LIST TO SORT THROUGH
TAD M6
DCA QCOUNT /COUNT FOR 6 CHARS
DCA QUOCNT /QUOTE COUNTER
ISZ SPACSW /KEEP SPACES
ISZ MODE /SET STRING MODE INDICATOR
PUSHF /PUSH 3 WORDS ONTO STACK
CCR
TAD PDLXR
DCA AXIN
DCA XCTIN
TAD AXIN
DCA PACKST
TAD QPT1
DCA PACKND
SKP /WE ALREADY HAVE FIRST CHAR
QUOTE1, GETC
SORTJ
PRNTL1-1
QSLIS, 0
QNEXTC, TAD QCOUNT /HAVE WE GOT 6 CHARS YET
SPA CLA /YES, DON'T BOTHER PACKING
PACKC
ISZ QCOUNT /BUMP CHAR COUNTER
JMP QUOTE1
TAD QSLIS /GOT 6 CHARS; CHECK IF LINPUT COMMAND
CIA
TAD QCON2
SZA CLA
JMP QUOTE1 /NO, IGNORE REST OF STRING
TAD QCOM /YES, FAKE A COMMA
DCA QUOCNT /SO WE CAN GET REST OF STRING
JMP QDONE2
QUOCHK, TAD QUOCNT /CHECK WHICH QUOTE THIS IS
SNA CLA /SECOND QUOTE, ALL DONE
JMP .+4
DCA SPACSW /IGNORE SPACES
GETC /SKIP OVER QUOTE
JMP QDONE /END OF STRING
ISZ QUOCNT
JMP QUOTE1 /SET FLAG AND CONTINUE
QCOMCK, TAD QUOCNT /CHECK IF COMMA INSIDE QUOTES
SNA CLA
JMP QDONE /NO QUOTES, ENDS STRING
JMP QNEXTC /INSIDE QUOTES, KEEP IT
QDONE, TAD CHAR /DONE, SAVE TERMINATOR
DCA QUOCNT
TAD QCOUNT /SAVE CHAR COUNT, FILL WORD WITH CR'S
CIA
QDONE2, TAD M6
CIA
DCA QCT1
TAD QCOUNT
SMA CLA
JMP QDONE1 /YES
TAD CCR /CCR ENDS STRING
DCA CHAR
PACKC
ISZ QCOUNT
JMP .-2
QDONE1, POPF /GET THE STRING
FLARG
TAD FLARGP /POINT TO STRING
DCA PT1
TAD QUOCNT
DCA CHAR /RESTORE CHARACTER
DCA SPACSW /SET TO IGNORE SPACES
POPJ /RETURN
QCON1, QLIS2-QLIS1
QCON2, QLIS1-PRNTL1
QCOM, ",-200
FRNDX1, 0001 /INITIALIZE RANDOM NUMBER
0203
5555
ENDFUN, FINT
FNOR /NORMALIZE IT
FPUT I FLARGP /SAVE DATA
FEXT
ENDF1, TAD FLARGP
DCA PT1 /POINT TO DATA
DCA SPACSW
JMS I QPARTST
JMP I QOPNEXT
QPARTST,PARTST
QOPNEXT,OPNEXT
PAGE 0
DTINTR, 0
DTSF /DECTAPE? (DSKP IF RK8E - SEE SYSINI)
JMP DIS+1
DCA INTAC1 /JUST FOR *DECKON*
JMP I MCOM /YES, GO TO IT
OCHAR, 0 /*CHAR* FROM FIELD 0
OCNTR, 0 /FLT PT COUNTER
/!!!!! WARNING DON'T MOVE OFPNT OR ITS ENTRY POINT !!!!!
Z200, OFPNT /FLOATING INTERPRETER CALL
FXR1, 0 /FLOATING POINT INDEX REG
FXR2, 0
XR1, 0
XR2, 0
XR3, 0
*15 /NAMEX MUST BE AT LOCN. 15 FOR MOVNAM TO WORK
NAMEX, ZBLOCK 3
DIS, TAD INTAC1 /RESTORE AC
CIF CDF
JMP I DTINTR /RESUME INTERRUPT PROCESSING
CALL=JMS I . /CALL AN OVERLAY OVER ENTER
XCALL
OPRINTC=JMS I . /FIELD 1 PRINTC
OPRINC
OERROR= JMS I . /FIELD 1 ERROR CALL
OERRX
OGETC= JMS I . /FIELD 1 GETC (LEAVES CHAR IN 'OCHAR')
OGETCX
OTESTN= JMS I . /FIELD 1 TESTN
OTESTX
OPOPJ= JMP I .
OPOPJX
OPUSHJ= JMS I .
OPUSHX
DECTAP= JMS I . /DO READ OR WRITE
DTAPE
ERROX= JMP .
ERR530, OERROR
GETCAT= JMS I . /READ IN DIRECTORY
XGETCAT
BUMPXR= JMS I . /UTILITY
XBUMPXR
DIRSCH= JMS I . /FIND A FILE NAME
XDIRSCH
SETPT= JMS I . /SETUP DIRECTORY POINTERS
XSETPT
/FLOATING POINT STORAGE
OPSIGN, 0 /OPERAND SIGN
ACSIGN, 0 /FLAC SIGN
OPEXP, 0 /OPERAND EXPONENT
ACEXP, 0 /FLAC EXPONENT
AC3, 0 /FLAC
AC2, 0
AC1, 0
OP3, 0 /OPERAND
OP2, 0
OP1, 0
OVER, 0 /OVERFLOW INTO HERE
FFLAG, 0 /-1 IF OP NOT 0
INTAC1, 0
TEMPX, 0
TEMPX1, 0
FILEN, 0
BLOCK, 0
WASTE, 0
ENTRIES, 0
PSQUISH, SQUISH
FOUND, 0
MCOM, 0
EXTEN, 0
PPLINK, CALL /CALL LINK OVERLAY. MOVE THIS IF YOU CAN FIND ROOM
CLINK^2
LINK
XGETNAM, 0 /FUDGE TO GET FILE NAME
CDF /IN SOME CASES
TAD I [CHAR /CHAR IS DESTROYED!!!
CDF SWAP
DCA OCHAR
JMP I [XGTNM1 /CALL THE REAL ROUTINE
Z100, 100
Z1000, 1000
Z6777, 6777
ZLOOK, LOOK
ZRUN9X, RUN9X
ZDTQ1, DTQ1
ZUSER0M1, USER0-1
ZDIRBUF, DIRBUF
ZDXIT, DXIT /POINTER TO DTAPE (RK8E) RETURN
PXCALLB, -XCALLB-1
ZOERROR, OERROR
PAGE
OFPNT, 0 /ENTRY POINT
C7600, 7600
RDF
TAD DIS+1 /OPERANDS IN CALLING FIELD
DCA FLOOP+2
JMP .+3
FLOOP, JMS I [FNORM /NORMALIZE RESULT
ISZ OFPNT /GET NEXT
CIF CDF
TAD I OFPNT /GET OPERATION
SNA
JMP I OFPNT /0000 => EXIT
CIF SWAP
RTL
RTL
AND [7
DCA FGOTO /SAVE OP
TAD I OFPNT
AND [200
SNA CLA
JMP FPNT1 /PAGE ZERO MODE
TAD OFPNT
AND C7600 /GET PAGE
FPNT1, DCA FADDR
TAD I OFPNT
AND [177
TAD FADDR
DCA FADDR /GET ADDRESS
SNL
JMP FPNT2
TAD I FADDR /DO INDIRECT
DCA FADDR
FPNT2, L4000
AND I FADDR
DCA OPSIGN /SET SIGN
TAD I FADDR
SZA CLA
L7777
DCA FFLAG /-1 IF NOT 0
TAD I FADDR
RTR
RAR
AND [377
DCA OPEXP /SET EXP
TAD I FADDR
AND [7
DCA OP1 /SET WORDS
ISZ FADDR
TAD I FADDR
DCA OP2
ISZ FADDR
TAD I FADDR
DCA OP3
L7775
TAD FADDR
DCA FXR2
FPNT3, TAD FGOTO
TAD [JMP I FJUMP
DCA .+1 /FIND OP ADDRESS
FGOTO, HLT
FJUMP, FPGET
FPADD
FPSUB
FPMUL
FPDIV
FPJMP
FPCMP
FPPUT
FADDR, 0
FPJMP, L7776 /FLOATING JUMP
TAD FADDR
DCA OFPNT
JMP FLOOP+2
FPCMP, TAD I OFPNT
RTL
RTL
SZL SPA CLA
JMP FPNT4 /FLOATING COMPARE
TAD I OFPNT
TAD .-1 /TAD (1600
DCA .+2 /SET SKIP WORD
JMS HIGHWD /GET WORD
HLT /SKIP IF FALSE
ISZ OFPNT /TRUE => SKIP
JMP FLOOP
FPPUT, JMS HIGHWD
DCA I FXR2 /SET WORD 1
TAD AC2
DCA I FXR2 /SET WORD 2
TAD AC3
DCA I FXR2 /SET WORD 3
JMP FLOOP+1
FPGET, TAD OPSIGN
DCA ACSIGN /TRANSFER INTO FLAC
TAD OPEXP
DCA ACEXP
TAD OP1
DCA AC1
TAD OP2
DCA AC2
TAD OP3
DCA AC3
JMP FLOOP+1
HIGHWD, 0
TAD ACEXP
CLL RAL
SMA
CLL RTL
SPA SZL
ERR040, OERROR /OVERFLOW
TAD ACSIGN
TAD AC1 /FORM WORD
JMP I HIGHWD
FPNT4, L4000
TAD OPSIGN
DCA OPSIGN
JMS I [OCTADD
TAD AC1
SNA
TAD AC2
SZA CLA
JMP FLOOP /NOT ZERO
TAD AC3
AND [7774
SZA CLA
JMP FLOOP /NOT ZERO
JMP I [MULCLR /CALL IT ZERO
PAGE
AR1, 0
TAD AC1
CLL RAR
DCA AC1
TAD AC2
RAR
DCA AC2
TAD AC3
RAR
DCA AC3
RAR
DCA OVER
JMP I AR1
ACN, 0
TAD (OP3
DCA OADD
L7775
DCA AR1
CDF SWAP /MAKE SURE
TAD I OADD
CMA
SZL
CLL IAC
DCA I OADD
ISZ OADD
ISZ AR1
JMP .-7
JMP I ACN
OADD, 0
CLL
TAD AC3
TAD OP3
DCA AC3
RAL
TAD AC2
TAD OP2
DCA AC2
RAL
TAD AC1
TAD OP1
DCA AC1
JMP I OADD
FPSUB, L4000
TAD OPSIGN
DCA OPSIGN
FPADD, JMS OCTADD
JMP I [FLOOP
OCTADD, 0
ISZ FFLAG
JMP I OCTADD
TAD ACEXP
CLL CIA
TAD OPEXP
SZL
JMP BCKWDS
DCA OADD
ALGNLP, TAD OP1
CLL RAR
DCA OP1
TAD OP2
RAR
DCA OP2
TAD OP3
RAR
DCA OP3
ISZ OADD
JMP ALGNLP
JMP SETSGN
BCKWDS, CMA
DCA OADD
TAD OPEXP
DCA ACEXP
SKP
JMS AR1
ISZ OADD
JMP .-2
SETSGN, TAD ACSIGN
TAD OPSIGN
SPA CLA
JMS ACN
JMS OADD
TAD AC1
SMA CLA
JMP I OCTADD
L7775
JMS ACN
TAD OPSIGN
DCA ACSIGN
JMP I OCTADD
FPMUL, ISZ FFLAG
JMP MULCLR
TAD ACSIGN
TAD OPSIGN
DCA ACSIGN
TAD ACEXP
TAD OPEXP
TAD (-201
DCA ACEXP
TAD AC1
DCA OPSIGN
TAD AC2
DCA OPEXP
TAD AC3
DCA TEMPX
TAD (-33
DCA OCNTR
MPYLUP, JMS AR1
TAD OPSIGN
RAR
DCA OPSIGN
TAD OPEXP
RAR
DCA OPEXP
TAD TEMPX
RAR
DCA TEMPX
SZL
JMS OADD
ISZ OCNTR
JMP MPYLUP
JMP I [FLOOP
MULCLR, DCA AC1
JMS I (NFIX
JMP I [FLOOP
PAGE
FNORM, 0
DCA OVER
TAD AC1
TAD KM10
SPA CLA
JMP NOTBIG
JMS I [AR1
ISZ ACEXP
JMP FNORM+2
NOTBIG, TAD OVER
SMA CLA
JMP NOBUMP
ISZ AC3
JMP NOBUMP
ISZ AC2
JMP NOBUMP
ISZ AC1
JMP FNORM+1
L7777
NOBUMP, TAD ACEXP
SPA
JMP UNDERF /UNDERFLOW OR ZERO
DCA ACEXP
L7775
TAD AC1
SMA SZA CLA
JMP I FNORM
JMS AL1
JMP NOBUMP-1
KM10=.
UNDERF, SPA SNA SZL CLA
TAD AC1
SNA
TAD AC2
SNA
TAD AC3
SZA CLA
ERR050, OERROR /UNDERFLOW
JMS NFIX
JMP I FNORM
AL1, 0
TAD AC3
CLL RAL
DCA AC3
TAD AC2
RAL
DCA AC2
TAD AC1
RAL
DCA AC1
JMP I AL1
FPDIV, ISZ FFLAG
ERR030, OERROR
TAD ACSIGN
TAD OPSIGN
DCA ACSIGN
TAD OPEXP
CIA
TAD ACEXP
TAD [177
DCA ACEXP
DCA OCNTR
TAD (-35
DCA FNORM
DIVLP, L4000
AND OP1
TAD AC1
SMA CLA
JMS I (ACN
JMS I (OADD
TAD OCNTR
RAL
DCA OCNTR
TAD OPEXP
RAL
DCA OPEXP
TAD OPSIGN
RAL
DCA OPSIGN
JMS AL1
ISZ FNORM
JMP DIVLP
TAD OPSIGN
DCA AC1
TAD OPEXP
DCA AC2
TAD OCNTR
DCA AC3
JMP I [FLOOP
NFIX, 0
TAD AC1
SNA CLA
JMP ZFIXEX
FIXLUP, TAD ACEXP
TAD (-233
SMA CLA
JMP FIXEXT
JMS I [AR1
ISZ ACEXP
JMP FIXLUP
ZFIXEX, DCA ACEXP
DCA ACSIGN
DCA AC1
DCA AC2
DCA AC3
FIXEXT, TAD AC3
JMP I NFIX
MULT10, 0
JMS AL1
TAD AC3
DCA OP3
TAD AC2
DCA OP2
TAD AC1
DCA OP1
JMS AL1
JMS AL1
JMS I (OADD
JMP I MULT10
FIXCON, 1544
1433
6750
LIST7, 12^40+22
LIST70
-"O+337^100-"N+337
PAGE
OFLIN, 0
TAD [-11
DCA DNUMBR
JMS DECONV
TAD OCHAR
TAD [-".+200
SZA CLA
JMP FIGO1
OGETC
TAD DNUMBR
DCA FXR1
JMS DECON
TAD DNUMBR
CIA
TAD FXR1
FIGO1, DCA FXR1
TAD C233
DCA ACEXP
FINT
FNOR
FPUT I [OTEMP
FEXT
TAD DNUMBR
TAD [11
SNA CLA
ERR150, OERROR
TAD OCHAR
TAD [-"E+200
SZA CLA
JMP FIGO2
OGETC
L7775
DCA DNUMBR
JMS DECONV
L0002
TAD DNUMBR
SPA CLA
JMP .-14
TAD ACSIGN
CLL RAL
TAD AC3
SZL
CIA
TAD FXR1
DCA FXR1
FIGO2, FINT
FGET I [OTEMP
FEXT
TAD FXR1
SNA
JMP FLINGO
SPA CLA
JMP FIGO4
TAD FXR1
CIA
DCA FXR1
TAD M1000
FIGO4, TAD [FDIV I [TEN
DCA .+2
FIGO3, FINT
HLT
FEXT
ISZ FXR1
JMP FIGO3
FLINGO, CIF CDF
JMP I OFLIN
DNUMBR, 0
DECONV, 0
DCA AC3
DCA AC2
DCA AC1
DCA ACSIGN
TAD OCHAR
TAD [-"++200
SNA
JMP .+6
CLL RTR
SZA CLA
JMP .+4
L4000
DCA ACSIGN
OGETC
JMS DECON
JMP I DECONV
DECON, 0
OTESTN
M1000, NOP
JMP I DECON
JMS I [MULT10
DCA OP1
DCA OP2
TAD OCHAR
TAD [-60
DCA OP3
JMS I [OADD
OGETC
ISZ DNUMBR
JMP DECON+1
ERR160, OERROR
OGETLN, 0
OTESTN
C233, 233
ERR370, OERROR
TAD [-6
DCA DNUMBR
JMS DECONV
TAD AC2
SZA CLA
JMP OGETLN+3
TAD AC3
SPA SNA
JMP OGETLN+3
CDF
DCA I [LINENO
TAD I [LINENO
IAC
SPA CLA
JMP OGETLN+3
CIF CDF
JMP I OGETLN
OPRINC, 0
CIF CDF
JMS I (XPRT1
JMP I OPRINC
XGETL2, XGET5-1 /CR
XGET4-1 /BELL
XGET3-1 /SPACE
PAGE
OFLOUT, 0
TAD ACSIGN
SPA CLA
TAD (55-40
TAD [40
OPRINTC
TAD AC1
SZA CLA
JMP FOGO1
TAD (60
OPRINTC
JMP FLOXIT
FOGO1, JMS I (FIXUP
TAD (-7
DCA OCNTR
TAD (NUMBUF-1
DCA FXR1
JMP .+5
FOGO2, TAD AC1
AND [177
DCA AC1
JMS I (MULT10
TAD AC1
CLL RTL
RTL
RTL
AND (17
TAD (60
DCA I FXR1
ISZ OCNTR
JMP FOGO2
TAD (NUMBUF-1
DCA FXR1
L0002
TAD I (DECEXP
SNA
JMP FOGO4
SPA
JMP FOGO3
TAD (-10
SPA CLA
JMP FOGO5
FOGO3, CLA
TAD I FXR1
OPRINTC
TAD (".-200
OPRINTC
TAD [-6
DCA OCNTR
TAD I FXR1
OPRINTC
ISZ OCNTR
JMP .-3
TAD ("E-200
OPRINTC
TAD I (DECEXP
SPA CLA
L0002
TAD ("+-200
OPRINTC
TAD I (DECEXP
SPA
CIA
ISZ OFLOUT
FLOXIT, CIF CDF
JMP I OFLOUT
FOGO4, TAD (".-200
OPRINTC
TAD (60
OPRINTC
FOGO5, TAD (-7
DCA OCNTR
TAD (NUMBUF+6
FOGO6, DCA TEMPX
TAD I TEMPX
TAD [-60
SZA CLA
JMP FOGO7
ISZ OCNTR
L7777
TAD TEMPX
JMP FOGO6
FOGO7, TAD I (DECEXP
TAD OCNTR
SPA CLA
JMP .+4
TAD I (DECEXP
CMA
DCA OCNTR
L7776
FOGO8, CMA
TAD I (DECEXP
SZA
JMP .+3
TAD (".-200
OPRINTC
DCA I (DECEXP
TAD I FXR1
OPRINTC
ISZ OCNTR
JMP FOGO8
JMP FLOXIT
TEN, 2045
0
0
MODL2, MODF5-1 /CR
MODF2-1 /BELL
MODF4-1 /RUBOUT
MODF4-1 /_
MODF1 /CHAR
MODF1-1 /FORM
MODF3-1 /LINE FEED
LIST70, 13^40+34
LIST71
337-"S^100-"T+337
337-"O^100-"P+337
PAGE
FIXUP, 0
TAD ACEXP
TAD .+2
DCA ACEXP
CLA SKP /THIS IS 7610 OR -170
FIXUP4, TAD DECEXP
DCA DECEXP
FIXUP1, TAD AC1
RTL
SZL CLA
JMP FIXUP2
JMS I PAL1
L7777
TAD ACEXP
DCA ACEXP
JMP FIXUP1
PAL1, AL1
K5400, 5400
K2166, 2166
KM5, -5
K377, 377
PMULT10, MULT10
PFIXCON, FIXCON
PNFIX, NFIX
FIXUP2, TAD ACEXP
KM40, SMA SZA CLA
JMP FIXUP3
JMS I [AR1
JMS I [AR1
JMS I [AR1
JMS I [AR1
JMS I PMULT10
TAD ACEXP
TAD FIXC4
DCA ACEXP
L7777
JMP FIXUP4
FIXUP3, TAD ACEXP
TAD KM5
SPA
JMP FIXUP5
FIXUP7, CLL CLA
TAD KM40
DCA OCNTR
FIXUP8, TAD AC1
TAD K5400
SMA
DCA AC1
CLA
TAD AC3
RAL
DCA AC3
TAD AC2
RAL
DCA AC2
TAD AC1
RAL
DCA AC1
ISZ OCNTR
JMP FIXUP8
TAD AC1
AND K377
DCA AC1
L0001
JMP FIXUP4
FIXUP5, DCA OCNTR
SKP
JMS I [AR1
ISZ OCNTR
JMP .-2
TAD AC1
TAD K5400
SMA CLA
JMP FIXUP7
CLL
TAD K2166
TAD AC3
DCA AC3
SZL
ISZ AC2
SKP
ISZ AC1
TAD AC1
TAD K5400
SZA CLA
JMP I FIXUP
TAD [200
DCA AC1
DCA AC3
ISZ DECEXP
FIXC4, 4
JMP I FIXUP
DECEXP, 0
NUMBUF, ZBLOCK 7
FATNC=NUMBUF
OTEMP=NUMBUF+3
FIX2, 0
FINT
FSLE
FADD I PFIXCON
FSGE
FSUB I PFIXCON
FEXT
JMS I PNFIX
CLL RAR
TAD ACSIGN
RAL
SZL
CIA
DCA FIXUP
CLL
TAD AC1
SNA
TAD AC2
SZA CLA
CLL CML
TAD FIXUP
JMP I FIX2
LIST75, 17^40+35
LIST76
337-"G^100-"O+337
337-"S^100-"U+337
337-"B^100
IFNZRO .-1577 <YOU GOOFED>
OSQR, FINT
FPUT FSINZ
FSNE
FJMP SQEXIT
FEXT
TAD ACSIGN
SPA CLA
ERR020, OERROR
TAD ACEXP
TAD KK7600
CLL
SPA
CML
RAR
TAD [200
DCA ACEXP
TAD KKM10
DCA SQCNT
SQLOOP, FINT
FPUT FSINZZ
FGET FSINZ
FDIV FSINZZ
FADD FSINZZ
FEXT
L7777
TAD ACEXP
DCA ACEXP
ISZ SQCNT
JMP SQLOOP
SQEXIT, FEXT
OPOPJ
SQCNT, 0
OTAN, FINT
FPUT I POTEMP
FEXT
OPUSHJ
COS
FINT
FPUT I PFATNC
FGET I POTEMP
FEXT
OPUSHJ
FSIN
FINT
FDIV I PFATNC
FEXT
OPOPJ
OCOS, FINT
FADD FSINC7
FSKP
OFSIN, FINT
FDIV FSINC1
FPUT FSINZ
FEXT
OPUSHJ
FFIX
L4000
TAD ACSIGN
DCA ACSIGN
FINT
FADD FSINZ
FEXT
ISZ ACEXP
ISZ ACEXP
FINT
FSINXX, FPUT FSINZ
FEXT
DCA ACSIGN
FINT
FSUB OFLTONE
FSGT
FJMP FSINOK
FGET FSINZ
FEXT
OPUSHJ
SGN
ISZ ACEXP
FINT
FSUB FSINZ
FJMP FSINXX
FSINOK, FGET FSINZ
FMUL FSINZ
FPUT FSINZZ
FMUL FSINC3
FADD FSINC4
FMUL FSINZZ
FADD FSINC5
FMUL FSINZZ
FADD FSINC6
FMUL FSINZZ
FADD FSINC7
FMUL FSINZ
FEXT
OPOPJ
FSINZ, 0;0;0
FSINZZ, 0;0;0
FSINC1, 2036;2207;7325
FSINC3, 1644;7553;6722
FSINC4, 5714;6223;1423
FSINC5, 1755;632;1276
FSINC6, 6005;1256;7406
FSINC7, 2016;2207;7325
KK7600, 7600
KKM10, -10
POTEMP, OTEMP
PFATNC, FATNC
OFLTONE, 2014
OFLZERO, 0
0
0
ALT, 175
176
33
OFEXP, FINT
FDIV FEXPC1
FPUT I (FEXPU
FEXT
OPUSHJ
INT
L4000
TAD ACSIGN
DCA ACSIGN
FINT
FPUT FEXPI
FADD I (FEXPU
FPUT I (FEXPF
FMUL I (FEXPF
FADD FEXPC2
FPUT I (FEXPU
FGET FEXPI
FEXT
JMS I (FIX2
CIA
IAC
DCA FEXPI
FINT
FGET FEXPC3
FDIV I (FEXPU
FADD FEXPC4
FSUB I (FEXPF
FPUT I (FEXPU
FGET I (FEXPF
FMUL I (FEXPF
FMUL FEXPC5
FADD I (FEXPU
FPUT I (FEXPU
FGET I (FEXPF
FDIV I (FEXPU
FADD FEXPC6
FEXT
TAD ACEXP
TAD FEXPI
DCA ACEXP
FINT
FNOR
FEXT
OPOPJ
FEXPI, 0;0;0
FEXPU=FSINZ
FEXPF=FSINZZ
FEXPC1, 2005;4271;300
FEXPC2, 2075;3552;7022
FEXPC3, 6124;6477;715
FEXPC4, 2044;7643;62
FEXPC5, 1744;3372;3400
FEXPC6, 2004;0;0
OLOG, JMS I PHIGHWD
SPA SNA CLA
ERR010, OERROR
TAD ACEXP
DCA LOGEXP
TAD L200
DCA ACEXP
FINT
FPUT I (FEXPU
FADD FLOGC1
FPUT I (FEXPF
FGET I (FEXPU
FSUB FLOGC1
FDIV I (FEXPF
FPUT I (FEXPF
FMUL I (FEXPF
FMUL FLOGC2
FADD FLOGC3
FMUL I (FEXPF
FMUL I (FEXPF
FADD FLOGC4
FMUL I (FEXPF
FSUB FEXPC6
FPUT I (FEXPF
FGET LOGFWD
FSUB LOGOKW
FADD I (FEXPF
FMUL FEXPC1
FADD I (FLZERO
FEXT
OPOPJ
FLOGC1, 2005;5202;3632
FLOGC2, 2004;6253;2521
FLOGC3, 2007;5421;3604
FLOGC4, 2025;6125;1007
LOGFWD, 2174
LOGEXP, 0
0
LOGOKW, 2174
L200, 200
0
FIX1, 0 /FIELD 0 'INTEGER'
JMS I PFIX2
CIF CDF
JMP I FIX1
MODL1, MODF5-1 /CR
MODF1+5 /BELL
PHIGHWD,HIGHWD /RUBOUT
PFIX2, FIX2 /_
MODF4-1 /CHAR
PAGE
ATNSGN, 0
OATN, TAD ACSIGN
DCA ATNSGN
DCA ACSIGN
FINT
FPUT I (FATNT
FPUT I (FATNAX
FSUB FATNC1
FSGT
FJMP ATNBIG
FSUB FATNC2
FSGT
FJMP ATNLOW
FGET I (OFLTONE
FDIV I (FATNT
FPUT I (FATNT
ATNLOW, FGET I (OFLZERO
FPUT I (FATNC
FGET I (FATNT
FSUB FATNC3
FSGE
FJMP ATNNOT
FGET I (FATNT
FADD FATNC4
FPUT I (FATNT
FGET FATNCJ
FDIV I (FATNT
FADD FATNC4
FPUT I (FATNT
FGET FATNC5
FPUT I (FATNC
ATNNOT, FGET I (FATNT
FMUL I (FATNT
FPUT I (FATNTT
FGET FATNC6
FMUL I (FATNTT
FADD FATNC7
FMUL I (FATNTT
FADD FATNC8
FMUL I (FATNTT
FADD FATNC9
FMUL I (FATNTT
FADD I (OFLTONE
FMUL I (FATNT
FADD I (FATNC
FPUT I (FATNT
FGET I (FATNAX
FSUB I (OFLTONE
FSGT
FJMP ATNBIG
FGET I (FSINC7
FSUB I (FATNT
FPUT I (FATNT
ATNBIG, FGET I (FATNT
FEXT
TAD ATNSGN
DCA ACSIGN
OPOPJ
FATNAX=FSINZ
FATNT=FSINZZ
FATNTT=FEXPI
FATNCJ, 6034;0;0
FATNC1, 1634;0;0
FATNC2, 2007;7776;0
FATNC3, 1774;2230;2427
FATNC4, 2016;7331;7272
FATNC5, 2004;1405;2216
FATNC6, 1756;462;4562
FATNC7, 5764;4221;3403
FATNC8, 1766;3141;6672
FATNC9, 5775;2525;2377
XCCR, 15
7
177
137
0
14
12
OINT, TAD ACSIGN
SMA CLA
JMP OFFIX
FINT
FPUT I (OTEMP
FEXT
OPUSHJ
FFIX
FINT
FCMP I (OTEMP
FSNE
FJMP .+4
FGET I (OTEMP
FSUB I (OFLTONE
FJMP .+2
FGET I (OTEMP
FEXT
OFFIX, JMS I (FIX2
FINT
FNOR
FEXT
OPOPJX, CIF CDF
JMP I (XPOPJ
PAGE
IF4, 2 /<
6 />
12 /=
5 /<=
11 />=
4 /<>
ORND, JMS I (AL1 /FLAC=FLAC*2
JMS I (OADD /FLAC=FLAC+FLAC*2=FLAC*3
CDF
TAD I (FRNDX+2 /MULT BY 2^17 MOD 2^27
CLL RTL
RTL
RTL
DCA I (FRNDX
TAD I (FRNDX
RAR
TAD AC2
AND (7740
DCA I (FRNDX+1
RAL
TAD AC1
TAD I (FRNDX
DCA I (FRNDX
TAD AC3
DCA I (FRNDX+2
TAD (200
DCA ACEXP
DCA ACSIGN
TAD I (FRNDX
AND (7
DCA AC1
TAD I (FRNDX+1
DCA AC2
OPOPJ
OTESTX, 0
TAD OTESTX
CIF CDF
DCA I (OTEST2
JMP I (OTEST2+1
OPUSHX, 0
TAD I OPUSHX
CIF CDF
DCA I (T3
TAD OPUSHX
IAC
JMP I (OPUSJ1
OGETCX, 0
CIF CDF
JMS I (GETCX1
JMP I OGETCX
OERRX, 0
CLA
CIF CDF
TAD OERRX
DCA I (XERROR
JMP I (XERROR+1
XPAKL2, XPACK2-1 /CR
XPACK3-1 /BELL
XPACK7-1 /RUBOUT
XPACK7-1 /
XPACK5-1 /@
XXPAK-1 /SPACE (KLUDGE!!)
LIST15, 52^40+34
LIST16
-"S+337^100-"A+337
-"V+337^100-"E+337
LIST16, 53^40+36
LIST17
-"U+337^100-"N+337
-"S+337^100-"A+337
-"V+337^100-"E+337
LIST17, 54^40+37
LIST18
-"C+337^100-"A+337
-"T+337^100-"A+337
-"L+337^100-"O+337
-"G+337^100
LIST18, 7^40+35
LIST19
-"C+337^100-"H+337
-"A+337^100-"I+337
-"N+337^100
LIST19, 3^40+36
LIST20
-"R+337^100-"A+337
-"N+337^100-"D+337
-"O+337^100-"M+337
LIST20, 6^40+34
LIST21
-"O+337^100-"P+337
-"E+337^100-"N+337
LIST21, 4^40+36
LIST22
-"O+337^100-"U+337
-"T+337^100-"P+337
-"U+337^100-"T+337
LIST22, 5^40+35
LIST23
-"C+337^100-"L+337
-"O+337^100-"S+337
-"E+337^100
LIST23, 55^40+36
LIST24
-"R+337^100-"E+337
-"N+337^100-"A+337
-"M+337^100-"E+337
LIST71, 11^40+33
LIST72
337-"E^100-"N+337
337-"D^100
LIST13, 41^40+11
LIST15
-"_+337^100
PAGE
XDIRSCH, 0
CLA STL /READ FIRST BLOCK
GETCAT
SCHLP, TAD I XR1
SNA CLA
JMP SKPMTF
CLA CMA
TAD XR1
DCA XR1
CLA CLL CMA RTL
DCA XBUMPXR
TAD [NAMEX-1
DCA XR3
SRCWDL, TAD I XR3
CIA
TAD I XR1
SZA CLA
JMP NXTFIL
ISZ XBUMPXR
JMP SRCWDL
TAD EXTEN
CIA
TAD I XR1
SZA CLA
JMP NXTFIL
BUMPXR
TAD I XR1
SNA
JMP SKPMTF+4
DCA FILEN
ISZ XDIRSCH
TAD BLOCK
JMP I XDIRSCH
NXTFIL, TAD XBUMPXR
CIA
BUMPXR
SKPMTF, TAD I XR1
CIA
TAD BLOCK
DCA BLOCK
ISZ ENTRIES
JMP SCHLP
JMS I [CATNEX
JMP I XDIRSCH
XBUMPXR, 0
TAD WASTE
TAD XR1
DCA XR1
JMP I XBUMPXR
XGTNM1, DCA NAMEX
DCA NAMEX+1
DCA NAMEX+2
DCA TEMPX
SKP
NLOOP, OGETC
CIF CDF
JMS I [TSTCH1
JMP NDONE
TAD TEMPX
TAD [-6
SMA CLA
JMP NLOOP
TAD TEMPX
CLL RAR
TAD [NAMEX
DCA WASTE
TAD OCHAR
AND [77
SZL
JMP .+4
CLL RTL
RTL
RTL
TAD I WASTE
DCA I WASTE
ISZ TEMPX
JMP NLOOP
NDONE, TAD OCHAR
TAD [-15
SZA CLA
ERROX
TAD TEMPX
SNA CLA
ERROX
CIF CDF
JMP I XGETNAM
QLIS2, QCOMCK-1 /,
QNEXTC-1 /'
QUOCHK-1 /"
QDONE-1 /CR
QLIS1, QNEXTC-1 /\ ,
QNEXTC-1 /'
QNEXTC-1 /"
QDONE-1 /CR
QNEXTC-1 /\
LIST25, 57^40+37
LIST26
-"F+337^100-"I+337
-"L+337^100-"E+337
-"L+337^100-"O+337
-"G+337^100
LIST26, 60^40+34
LIST14
-"C+337^100-"H+337
-"R+337^100-"$+337
LIST72, 14^40+37
LIST73
-"R+337^100-"E+337
-"S+337^100-"T+337
-"O+337^100-"R+337
-"E+337^100
CAT0, 0000
CLA STL /GET FIRST BLOCK GETCAT
GETCAT
CIF CDF
JMP I CAT0
XCALL, 0000 /OVERLAY CALLING PROGRAM
TAD I XCALL /BLOCK NUMBER TO READ
ISZ XCALL
DCA XCALLB
TAD I XCALL /LINK ADDRESS
DCA XCALL
L0001
DECTAPE
XENTER+1 /USE ENTER AS OVERLAY AREA
7600
XCALLB, 0000
JMP I XCALL
PAGE
DTAPE, 0 /ENTER WITH AC=1 FOR READ
IOF /NO INT PLEASE
TAD [DR128
DCA DRET /READ/WRITE RETURN AFTER SEARCH
TAD ENTERF /SAVE CALLING FIELD
RDF
DCA DXIT
DGR, CLA CMA
TAD I DTAPE
ISZ DTAPE
DCA DCORE /FIRST CORE LOCATION-1 OF TRANSFER
TAD I DTAPE
ISZ DTAPE
DCA DWDS / -NUMBER OF WORDS TO BE TRANSFERRED
TAD I DTAPE /GET BLOCK NO.
ISZ DTAPE
DCA DTEM /AND STORE
/INITIATE SEARCH
DTS1, TAD [DTBLOK /DTBLOK TO 7755 (CA)
CDF
DCA I DCAA
TAD [DINT-1
DCA MCOM /INTERRUPT RETURN
TAD EXTEN /SEE IF .DX OR .EX
AND Z100
SZA CLA
JMP UNIT0 /MUST BE .EX
TAD PXCALLB /AND EXCEPT FOR CALL
TAD DTAPE
SZA CLA
UNIT1, TAD Z1000 /USE UNIT1
UNIT0, TAD [614 /SET TO SEARCH,NORMAL,REVERSE
DTLA /LOAD STATUS A
TAD [10
DTLB /FIELD 1
CIF CDF 0
TAD I ZLOOK /SET BUSY FLAG
DCA TEMPX
TAD I TEMPX /GET STATUS
AND Z6777 /DO AN OR
TAD Z1000
DCA I TEMPX
TAD ZDXIT /FAKE RETURN ADDRESS
JMP I ZRUN9X /AND DISMISS
DXIT, HLT /RETURN TO PROPER FIELD
JMP I DTAPE
DTEM, 0
DR128, TAD [20 /WRITE (NOT READ),(40-20)
TAD [30 /READ NORMAL, CANCEL SEARCH (20+10)
DTXA /SET FUNCTION
TAD DCORE /1ST CORE LOC.-1 OF TRANSFER
CDF
DCA I DCAA /TO 7755(CA)
ISZ MCOM /POINT INTERRUPT RETURN TO DATA
DGO, CLA CLL
TAD DWDS / -NUMBER OF WORDS TO READ
TAD Z200 /LOCATION 7 HAS LITTERAL 200, FULL PAGE READ?
SNL
CLA /YES, SET WC TO -128
SNL /SKIP OVER IF CRAP IN AC
DR127, DTXA /SEND READ OR WRITE
TAD D7600 /SET WORD COUNT FOR 1 PAGE
CDF
DCA I DWC /-128 TO 7754 (WC)
DTXA /IN CASE WE MISSED IT BEFORE
JMP DIS /EXIT
JMP DTS3A
DINT, DTRB /READ STATUS B
SPA CLA
JMP DER1 /ERROR FLAG
CLA CLL
TAD DWDS /BUMP COUNT AND CHECK FOR MORE
TAD Z200 /LOCATION 7 HAS LITTERAL 200, 128 WORD PAGE
DCA DWDS /SAVE FOR NEXT TIME
SNL
JMP DGO /GET NEXT PAGE
DER2, TAD [600 /COMPLEMENT MOTION AND DIRECTION
DTXA
CDF
TAD I ZDTQ1 /GET POINTER TO QUEUE
DCA TEMPX
TAD I TEMPX /GET USER #
TAD ZUSER0M1 /BUILD POINTER TO STATUS
DCA TEMPX
TAD I TEMPX
AND Z6777 /CLEAR BUSY
DCA I TEMPX
JMP DIS /FINISH INTERRUPT
DCAA, 7755 /POINTER TO CURRENT ADDRESS
DWC, 7754 /POINTER TO WORD COUNT
DWDS, 0 / -WORDS TO TRANSFER
DTBLOK, 0 /BLOCK NUMBER DEPOSITED HERE BY CONTROL
DCORE, 0 /STARTING ADDRESS-1
DRET, 0 /DR128 IF WRITE, OR DR128+1 IF READ
DTS3A, DTRB /READ STATUS B
RTL /LOOK AT BIT 2
SPA CLA /END ZONE?
JMP DTURNX /YES (MOTION BIT=0), TURN
DTRB
SPA CLA
JMP DER1 /ERROR FLAG BIT 0=1
DTRA
RTL
RTL /FOR-REV STATUS (BIT 3) IN LINK
D7600, 7600 /GROUP 2 CLA
TAD DTBLOK
CIA
TAD DTEM /LINK COMP. IF REQUIRED BLK NO.
SNA /IS BIGGER I.E. MUST GO FORWARD
JMP DTFIND /FOUND BLOCK CHECK DIRECTION
CIA
SNL
IAC /GO 2 MORE BLOCKS BEFORE TURNING
SNL CLA
DTURN, TAD [400 /TURN IF HERE
JMP DR127 /XOR TO A STATUS AND DISMIS
DTFIND, SNL CLA /TEST DIRECTION
JMP DR127 /DONT TURN YET, STILL IN REVERSE
JMP I DRET /GO DO READ OR WRITE
DTURNX, TAD [600 /REVERSE OUT OF END ZONE
JMP DR127
DER1, TAD ZOERROR
DCA DXIT
JMP DER2
PAGE
*.-3 /BUMP BACK TO 3 LOCATIONS BEFORE PAGE BOUNDRY
ENTERF, CDF CIF 0
JMP I XENTER
XENTER, 0 /OS/8 DIRECTORY 'ENTER'
DCA TEMPX1 /BLOCKS NEEDED
DIRSCH /SEARCH DIRECTORY FOR DUPLICATE FILE.
JMP NODLET /NO FILE TO DELETE
L7776 /FOUND A FILE SO DELETE IT
TAD XR1
DCA XR1 /RESTORE XR1 TO SIZE-2
TAD XR1
DCA XR3
DCA I XR3 /MAKE THIS AN EMPTY ENTRY
L7775
TAD I [DIRBUF+4 /SQUISH OUT NAME.EX+WASTE
JMS I PSQUISH /LEAVING THE EMPTY OF COURSE
CONSOL, SETPT /NOW CLEAN UP THAT MESSY DIRECTORY
TAD I XR1
SNA CLA
JMP CONMTF /ITS AN EMPTY
TAD [4 /ITS NOT. SO IGNORE IT
BUMPXR
ISZ ENTRIES /DONE?
JMP CONSOL+1 /NOPE
EOCLOS, CLA CLL /WRITE (L=0) OUT DIRECTORY
TAD I [CATBLK /USE THE BLOCK WE READ IN
GETCAT /ACTUALLY PUT CAT
NODLET, TAD TEMPX1
SNA CLA
JMP ENTXIT /ALL DONE EXIT
DCA FOUND /CLEAR FOUND FOR SEARCH
STL
GETCAT /READ IN FIRST BLOCK
MLOOP, TAD I XR1
SNA CLA
JMP MEMPTY
TAD [4
BUMPXR
MLOOPC, ISZ ENTRIES
JMP MLOOP
CLA /AC IS NOT 0 AFTER SZL IN MEMPTY
TAD FOUND
SZA CLA
JMP MLOOPF
FLOOPF, DCA FOUND
JMS I [CATNEX /IF ANOTHER CAT BLOCK EXISTS RETURNS TO LAST GETCAT+1
JMP I .+1 /NO ROOM
PPLINK /TRY TO LINK DIRECTORIES
ENTXIT, ISZ I [XENTER /OK EXIT CALL + 1
DIRSCH /SEARCH DIRECTORY FOR ENTRY
NOP /IF SOMEONE OPENS A FILE WITH 0 LENGTH IT WILL COME HERE.
JMP I .+1
ENTERF
MEMPTY, TAD FOUND /SEE IF WE WERE ALREADY HERE
SNA CLA
JMP .+3
ISZ XR1
JMP MLOOPC
CLL /MAKE SURE LINK IS 0
TAD I XR1 /-SIZE OF EMPTY
TAD TEMPX1 /SIZE WE WANT. LINK SHOULD HAVE BEEN 0 AT MEMPTY
SZL
JMP MLOOPC /NOT BIG ENOUGH
DCA XGETNAM /SAVE SIZE OF NEW EMPTY IF ANY
L7776
TAD XR1
DCA FOUND /AND WHERE IN THE BLOCK WE CAME FROM
JMP MLOOPC /CONTINUE TO END OF BLOCK
MLOOPF, TAD XR1
DCA TEMPX
TAD [4
BUMPXR
TAD XR1
TAD [-DIRBUF-370
SMA CLA
JMP FLOOPF
MLOOP3, TAD I TEMPX /BUMP UP CATALOG TO MAKE ROOM
DCA I XR1
CLA CLL CMA RAL
TAD XR1
DCA XR1
CLA CMA
TAD TEMPX
DCA TEMPX
TAD TEMPX
CLL CML CIA
TAD FOUND
SZL SNA CLA
JMP MLOOP3
TAD FOUND
DCA XR1
TAD NAMEX
DCA I XR1
TAD NAMEX+1
DCA I XR1
TAD NAMEX+2
DCA I XR1
TAD EXTEN /".EX" EXTENSION
DCA I XR1
DCA I XR1
CLA CMA
BUMPXR
TAD TEMPX1
CIA
DCA I XR1 /PROPER LENGTH
DCA I XR1 /MAKE AN EMPTY
TAD XGETNAM
DCA I XR1 /OF NEW LENGTH
CLA CMA
TAD I ZDIRBUF /# OF ENTRIES
DCA I ZDIRBUF
DCA TEMPX1 /SET UP FOR NODLET
JMP EOCLOS
CONMTF, TAD I XR1
SNA
JMP SQTRIV
DCA TEMPX
TAD XR1
DCA FOUND
ISZ ENTRIES
SKP
JMP EOCLOS
TAD I XR1
SZA CLA
JMP CONSOL+4 /NOT A DOUBLE EMPTY
TAD I XR1
TAD TEMPX
DCA I FOUND /MAKE 1 EMPTY OUT OF 2
SQTRIV, L7776 /REMOVE AN EMPTY
JMS I PSQUISH
ISZ I ZDIRBUF /RESET NUMBER OF ENTRIES
JMP CONSOL
LIST77, 21^40+33
LIST78
-"D+337^100-"E+337
-"F+337^100
LIST78, 22^40+33
LIST79
-"D+337^100-"I+337
-"M+337^100
LIST82, 24^40+22
LIST83
337-"I^100-"F+337
LIST12, 22^40+11
LIST13
-"'+337^100
XSETPT, 0
TAD I ZDIRBUF
DCA ENTRIES
TAD I [DIRBUF+1
DCA BLOCK
TAD I [DIRBUF+4
CIA CLL /MAKE SURE L=0 FOR MEMPTY
DCA WASTE
TAD [DIRBUF+4
DCA XR1
JMP I XSETPT
CATNEX, 0000
TAD I [DIRBUF+2 /SEE IF IT LINKS
CLL RAL /MULTIPLY BY TWO
STL /SET LINK FOR READ
SNA
JMP I CATNEX /NO LINKAGE RETURN
SKP /ENTER GETCAT+1 IF LINKAGE EXISTS
XGETCAT, 0
SNA /SEE IF ENTERED WITH SEGMENT NUMBER
TAD [2 /ASSUME FIRST CAT BLOCK. DON'T L0002!
DCA CATBLK /BLOCK NUMBER TO FETCH
RAL /READ OR WRITE WAS IN LINK
DECTAPE
DIRBUF
7400
CATBLK, 2
SETPT
JMP I XGETCAT
SQUISH, 0
TAD XR1
DCA XR2
TAD I XR1
DCA I XR2
TAD XR1
TAD [-DIRBUF-377
SZA CLA
JMP .-5
JMP I SQUISH
CAT1, 0
TAD I XR1
SNA
JMP DEMPTY
DCA NAMEX
TAD I XR1
DCA NAMEX+1
TAD I XR1
DCA NAMEX+2
TAD EXTEN
CIA
TAD I XR1
SZA CLA /DON'T FORGET TO CLEAR AC!!!
JMP DEMPTY-1
BUMPXR
TAD I XR1
SNA CLA
JMP DEMPTY+1
TAD NAMEX
JMS TWOPRT
TAD NAMEX+1
JMS TWOPRT
TAD NAMEX+2
JMS TWOPRT
TAD [15
OPRINTC
JMP DEMPTY+1
BUMPXR
DEMPTY, ISZ XR1
ISZ ENTRIES
JMP .+3
JMS I [CATNEX
ISZ CAT1
CIF CDF
JMP I CAT1
FLOOK, 0 /GET CATALOG AND LOOKUP
DIRSCH
ERROX
CIF CDF
JMP I FLOOK /THAT WAS EASY
TWOPRT, 0
DCA NAMEX
TAD NAMEX
CLL RTR
RTR
RTR
JMS ONEPRT
TAD NAMEX
JMS ONEPRT
JMP I TWOPRT
ONEPRT, 0
AND [77
SNA
JMP I TWOPRT
TAD [-40
SPA
TAD Z100
TAD [40
OPRINTC
JMP I ONEPRT
DTCHKX, 0 /CHECK IF USER ALREADY HAS TAPE
IOF
TAD I [DECK
IAC
DCA XR3
TAD I ZDTQ1
DCA OP3
TAD I OP3
CIA
TAD XR3
CIF
SNA CLA
JMP I [XDTG1
TAD XR3
JMP I DTCHKX
PAGE
FUNL1, 316 /FN
1151 /SI
157 /CO
64 /AT
270 /EX
617 /LO
42 /AB
1161 /SQ
1147 /SG
456 /IN
1116 /RN
311 /FI
1201 /TA
651 /MI
141 /CA
657 /MO
605 /LE
FUNL2, -"N+200 /SIN
-"S+200 /COS
-"N+200 /ATN
-"P+200 /EXP
-"G+200 /LOG
-"S+200 /ABS
-"R+200 /SQR
-"N+200 /SGN
-"T+200 /INT
-"D+200 /RND
-"X+200 /FIX
-"N+200 /TAN
-"D+200 /MID
-"T+200 /CAT
-"D+200 /MOD
-"N+200 /LEN
TERMS, 40 /SPACE 0
53 /+ 1
55 /- 2
52 /* 3
57 // 4
136 /^ 5
50 /( 6
133 /[ 7
51 /) 10
135 /] 11
74 /< 1
76 /> 13
75 /= 14
FUNL3, FSIN
COS
ATN
FEXP
LOG
ABS
SQR
SGN
INT
RND
FFIX
TAN
MID
CAT
MOD
LEN
PRNTL6, PRINT8-1 /;
PRINT5-4 /,
PRINT6-4 /'
PRINT8 /"
PRINT6-4 /CR
PRINT6-4 /\
PRNTL2, PRINT5-4 /,
PRINT6-1 /'
PRINT2-1 /"
PRINT6-1 /CR
PRINT6-1 /\
PRNTL8, PRINT3-1 /"
PRINT6-4 /CR
PRINT3-4 /\ MUST BE PRINTABLE
LIST24, 56^40+34
LIST25
-"K+337^100-"I+337
-"L+337^100-"L+337
UNKWN+1 /ENTER NEW COMMAND HERE
RANDOM
UNKWN+1 /OUTPUT FUDGE
CLOSE0
OPEN
CHAIN
LINPUT
END
ON
READY /STOP
RESTOR
READ
RETURN
GOSUB
FOR
XPOPJ /DEF
XPOPJ /DIM AND REM
GOTO
IF
INPUT
PRINT0
XPOPJ /DATA
LET
NEXT
COMGOL, UNKWN
ERRLST, ERR000
ERR001
ERR002
ERR003
ERR004
ERR010
ERR020
ERR030
ERR040
ERR050
ERR060
ERR070
ERR080
ERR100
ERR110
ERR120
ERR150
ERR160
ERR170
ERR180
ERR200
ERR210
ERR220
ERR130
ERR230
ERR240
ERR250
ERR260
ERR270
ERR280
ERR290
ERR300
ERR650
ERR320
ERR330
ERR340
ERR350
ERR640
ERR370
ERR380
ERR390
ERR400
ERR410
ERR420
ERR430
ERR440
ERR450
ERR460
ERR470
ERR490
ERR500
ERR510
ERR520
ERR530
ERR540
ERR550
ERR560
ERR600
ERR610
ERR620
ERR630
PDXIT, DXIT /DECTAPE ERROR
ERREND=.
LIST79, 22^40+33
LIST80
-"R+337^100-"E+337
-"M+337^100
LIST80, 10^40+36
LIST81
-"L+337^100-"I+337
-"N+337^100-"P+337
-"U+337^100-"T+337
LIST81, 23^40+34
LIST82
-"G+337^100-"O+337
-"T+337^100-"O+337
LIST83, 25^40+35
LIST84
-"I+337^100-"N+337
-"P+337^100-"U+337
-"T+337^100
LIST84, 26^40+35
LIST85
-"P+337^100-"R+337
-"I+337^100-"N+337
-"T+337^100
LIST85, 27^40+34
LIST86
-"D+337^100-"A+337
-"T+337^100-"A+337
LIST86, 30^40+33
LIST87
-"L+337^100-"E+337
-"T+337^100
LIST87, 31^40+34
LIST88
-"N+337^100-"E+337
-"X+337^100-"T+337
LIST88, 33^40+33
LIST89
-"T+337^100-"A+337
-"B+337^100
LIST89, 34^40+34
LIST90
-"S+337^100-"T+337
-"E+337^100-"P+337
LIST90, 35^40+34
LIST91
-"T+337^100-"H+337
-"E+337^100-"N+337
LIST91, 36^40+22
LIST92
-"T+337^100-"O+337
LIST92, 37^40+22
LIST93
-"F+337^100-"N+337
LIST93, 40^40+34
LIST94
-"L+337^100-"I+337
-"S+337^100-"T+337
LIST94, 42^40+33
LIST95
-"B+337^100-"Y+337
-"E+337^100
LIST95, 50^40+33
LIST96
-"N+337^100-"E+337
-"W+337^100
LIST96, 42^40+37
LIST97
-"S+337^100-"C+337
-"R+337^100-"A+337
-"T+337^100-"C+337
-"H+337^100
LIST97, 43^40+36
LIST98
-"D+337^100-"E+337
-"L+337^100-"E+337
-"T+337^100-"E+337
LIST98, 44^40+34
LIST99
-"E+337^100-"D+337
-"I+337^100-"T+337
LIST99, 45^40+33
LIST10
-"K+337^100-"E+337
-"Y+337^100
LIST10, 46^40+34
LIST11
-"T+337^100-"A+337
-"P+337^100-"E+337
LIST11, 47^40+33
LIST12
-"R+337^100-"U+337
-"N+337^100
LIST76, 20^40+33
LIST77
-"F+337^100-"O+337
-"R+337^100
DIRBUF, ZBLOCK 400
INTR80=.-1 /2 POWER FAIL/AUTO RECOVER TEMPS
INTR8F=.-2
INTRRV, CAF /RECOVER - CLEAR ALL
/ TLS /IF NOT DC02 - SEE BEG760
/ 0 /IF NOT 8-E - SEE BEG550
AAACDF, CIF CDF
INTRV2, TAD I PAUSER
MTON
/ 0 /IF NOT DC02 - SEE BEG760
JMS I PINTRPL
/ MTLS /IF DCO2 - SEE BEG760
CLA
TAD PINTR8
DCA I [2
TAD INTR8F
AND [7
CLL RTL
RAL
TAD AAACDF
DCA INTR88
TAD INTR8F
AND [70
TAD CCIF
DCA INTR89
TAD INTR8F
RAL
CLA
INTR88, CDF
INTR89, CIF
TAD INTAC1 /AND AC
ION
JMP I INTR80 /AND EXIT
PINTRPL, INTRPL-1
PAUSER, AUSER
CCIF2, CIF SWAP
PINTR8, INTR8E
PINTRRV, INTRRV
INTR81, DCA INTAC1 /SAVE AC
6634 /READ CARD READER TO CLEAR FLAG
6674 /AND CARD DONE FLAG
CLA /AND CLEAR THE AC
SPL /POWER FAIL INTERRUPT?
JMP INTR82 /NO
RAR
RIB
DCA INTR8F /AND FLAGS
TAD I A0000
DCA INTR80 /AND LOCATION
TAD CCIF2
DCA I A0000 /SET "CIF SWAP"
TAD PINTRRV
DCA I [2 /AND SET ADDRESS
HLT
INTR82, TAD INTAC1 /GET THE AC AGAIN
CCIF, CIF
JMP I .+1 /GO TO REAL INTERRUPT ROUTINE
INTRPT
LIST73, 15^40+34
LIST74
-"R+337^100-"E+337
-"A+337^100-"D+337
LIST74, 16^40+36
LIST75
-"R+337^100-"E+337
-"T+337^100-"U+337
-"R+337^100-"N+337
LIST14, 51^40+33
A0000, 0
-"O+337^100-"L+337
-"D+337^100
COMGO1, LIST
START /CR
BYE
DELETE
EDIT
KKEY
TAPE
RUN
NEW
OLD
SAVE
UNSAVE
CATLOG
RENAME
KILL
DATLOG
UNKWN+1 /CHR FUDGE!!
ORG1=.+1
IFZERO .-4732&4000 <OVERLAPPING I/O BUFFERS AND SWAP REGION!!>
PAGE
/USER DEFINITIONS
LIMIT=7776 /HIGHEST CORE POSITION
SWAPR=ENSWAP-STSWAP+1 /SWAP LENGTH
ORG=. /USER STARTING ORIGIN
BUFFER=40
BUFCOM=100
LINE0=162
LINE1=164
TOP=LIMIT
FIELD 2
PAGE 0
CONBEG, 7745 /CR,E
6262 /RR
5762 /OR
5156 /IN
7762 /CR,R
4541 /EA
4471 /DY
7777 /CR,CR
4445 /DE
5445 /LE
6445 /TE
4477 /D,CR
6750 /WH
4164 /AT
3777 /?,CR
7763 /CR,S
6457 /TO
6077 /P,CR
5641 /NA
5545 /ME
1515 /--
CONEND=.
USRPTR, USRLST
CORPTR, 0
USRPT2, 0
CORPT2, 0
BEGUSR, 0
CURFLD, 0
BEGDEV, 0
USRCTR, 0
SS, 0
BEGCOR, 0
KLTOP, 0
OS8PTR, 0
OSDRK8, 1377
3030
1376
3031
5030
0
0
0
0
0
0
0
0
0
0
0
5031
6733
OSDDSK, 1772
3771
2371
2372
5356
5350
0
0
0
0
0
7750
7773
7600
6603
6622
5352
5752
OSDDTA, 6774
1377
3354
1376
3355
1375
6766
6771
5365
1374
6766
6771
5371
5200
220
600
7577
7700
PAGE
/*SYSTEM ENTRY POINT FOR INITIALIZATION*
BEGIN, NOP /SO WE CAN CHAIN BACK TO OURSELF
KCC
JMS I (SYSINI
BEGINB, CDF 10
TAD I (7760 /GET DCB OF SYS:
AND (770
TAD (-050 /5 IS RK8
SPA
JMP OS8ERR /<5 IS ERROR
SNA
JMP OS8RK8 /5 = RK8
TAD (050-160 /16 IS DECTAPE
SPA
JMP OS8KSK /6 TO 15 = DSK
SNA CLA
JMP OS8DTA /16 = DTA:
OS8ERR, CLA
CDF 20
JMS I (BEG003
OS8ERM /BAD O/S8 DEVICE
JMP I (BEGMV0 /DO NOT SET UP ANY THING
OS8KSK, CLA
JMP OS8DSK
OS8DSK, IAC
OS8DTA, IAC
OS8RK8, IAC
TAD (OS8LST-1
DCA OS8PTR
CDF 20
TAD I OS8PTR
DCA OS8PTR /POINT TO BOOTSTRAP
JMS I (BEG003
OS8MSG /O/S8 MESSAGE
JMS I (BEG003
OS8AB, OS8M1
JMS I (BEG003
OS8M2
JMP I (BEGMV0
OS8LST, OSDRK8
OSDDTA
OSDDSK
USR=7700 /ENTRY POINT TO OS-8 USR
FETCH=1 /FETCH DEVICE HANDLER
L00KUP=2 /LOOK UP BLOCK NUMBER OF FILE
CHA1N=6 /CHAIN TO A PROGRAM ON "SYS:"
ERRLDR, JMS I (BEG003 /COULDN'T FIND HANDLER OR W.L.
LDRERR
JMS I (BEG003
LDRER2
CIF CDF 0
JMP I (7605 /RETURN TO OS8
ERRCHN, JMS I (BEG003
CHNERR
JMP ERRLDR+2
BEG708, CIF 10
JMS I (USR /LOAD HANDLER AND
FETCH /GET NUMBER OF DEVICE "SYS"
TEXT %SYS% /NO DEVICE PSEUDO-OP IN PAL10
SYSNO=.-1
4001 /HE'S DEAD ANYWAY, SO NO NEED TO SAVE
/THE AREA FOR THE DEVICE HANDLER
JMP ERRCHN /ERROR - CAN'T CHAIN
TAD SYSNO /LOAD DEVICE NUMBER
CIF 10
JMS I (USR
L00KUP
BLOCK0, EDUNAM
0
JMP ERRCHN /ERROR - EDU25 NOT ON "SYS"
TAD BLOCK0 /MOVE BLOCK NUMBER
DCA STCHN /FOR USE BY CHAIN
CIF 10
JMS I (USR
CHA1N
STCHN, 0
EDUNAM, TEXT %EDU25% /NO FILENAME PSEUDO-OP IN PAL10
2326 /"SV"
PAGE
BEGMV0, CDF
TAD I (FLOP
DCA I (OPTABL+5
CDF 10
TAD I BEGIN1 /MAKE SURE THAT NO ERRORS ARE NEG. SO THAT
/THEY DON'T TERMINATE TABLE
IAC
CLL RAR
DCA I BEGIN1
ISZ BEGIN1
ISZ BEGIN2
JMP .-6
BEG002, CDF 20
KCC
TAD (BEGIOT
DCA BEG012
TAD (-4
DCA BEG013
TAD (120
DCA I BEG012
ISZ BEG012
ISZ BEG013
JMP .-4
JMS I (BEG003
BEGM1 /INIT MESSAGE
BEG006, JMS I (BEG003
BEGM2 /# USER MESSAGE
JMS I (BEG001
TAD (-"5
SMA SZA
JMP I (BEG005
TAD (5
SPA SNA
JMP I (BEG005
CIA
DCA BEGUSR
BEG008, JMP I (BEGX08
CORDON, CDF 20
TAD (7745
DCA CONBEG /RESTORE THE BLOODY TEXT!
TAD BEGUSR
IAC
SNA CLA
JMP BEG010
BEG009, JMS I (BEG003
BEGM4 /DC02?
JMS I (BEG001
TAD (-"Y
SNA
JMP BEG010+1
TAD ("Y-"N
SNA CLA
JMP BEG010
JMS I (BEG003
BEGME
JMP BEG009
BEG010, L7777 /BEGDEV=-1 IF NOT DC02
DCA BEGDEV /BEGDEV= 0 IF DC02
TAD BEGDEV
SNA CLA
JMP I (BEGCK0
TAD (BEGIOT
DCA BEG012
TAD BEGUSR
DCA BEG013
TAD (410
DCA BEG12A
BEG14B, ISZ BEG013
JMP BEG14A
JMP I (BEG015
BEG14A, TAD BEG12A
DCA I BEG012
ISZ BEG012
TAD BEG12A
TAD (20
DCA BEG12A
JMP BEG14B
BEG12A, 400
BEG012, 0
BEG013, 0
BEGIN1, ERRLST
BEGIN2, ERRLST-ERREND
PAGE
BEG015, TAD BEGUSR
IAC
SNA CLA
JMP I (BEGCK0
BEG15E, JMS I (BEG003
BEGM7 /STANDARD?
JMS I (BEG001
TAD (-"Y
SNA
JMP I (BEGCK0
TAD ("Y-"N
SNA CLA
JMP BEG15A
JMS I (BEG003
BEGME
JMP BEG15E
BEG15A, TAD BEGUSR
DCA BEG15B
TAD (BEGIOT
DCA BEG15C
TAD (4361 /TEXT "#1"
DCA I (BEGM5A
BEG15D, ISZ BEG15B
JMP BEG014
JMP I (BEGCK0
BEG15C, 0
BEG15B, 0
BEG014, JMS I (BEG003
BEGM5 /DEVICE CODE
JMS I (BEG001
TAD (-"7
SMA SZA
JMP I (BEG016
TAD (7
SPA
JMP I (BEG016
CLL RTL
RTL
RTL
DCA I BEG15C
JMS I (BEG001
TAD (-"7
SMA SZA
JMP I (BEG016
TAD (7
SPA
JMP I (BEG016
IAC
CLL RTL
RAL
TAD I BEG15C
DCA I BEG15C
ISZ BEG15C
ISZ I (BEGM5A
JMP BEG15D
/FIGURE OUT HIGHEST CORE FIELD FOR HIM
BEGX08, L0001
DCA BEGCOR /FIELD 1 TOP TO START WITH
TAD (6221
DCA BEGCHK
TAD CNOP
CDF
DCA I (0
CDF 10
TAD CNOP
DCA I (0
BEGCHK, 0
TAD (1000
DCA I (0
CNOP, NOP
TAD I (0
SKP /PDP-8 NXM BUG
HLT /THIS SHOULD HAUL DOWN A PDP-8
CDF 10 /DOUBLE CHECK FOR PDP8/L
TAD I (0
SZA CLA
JMP I (CORDON /NO MORE CORE
TAD (1000
CDF
TAD I (0
SZA CLA
JMP I (CORDON /NO MORE CORE-PROBABLY A PDP-8/L
ISZ BEGCOR /THIS FIELD WAS SUCCESSFUL
TAD BEGCHK
TAD (10
DCA BEGCHK
JMP BEGCHK
PAGE
BEG016, JMS BEG003
BEGME
JMP I (BEG014
BEG005, JMS BEG003
BEGME
JMP I (BEG006
BEG007, JMS BEG003
BEGME
JMP I (BEG008
BEG001, 0
KSF
JMP .-1
KRB
TAD (-203
SNA
JMP I (BEG002
TAD (203
TLS
TSF
JMP .-1
AND (177
TAD (200
JMP I BEG001
BEG003, 0
CLA
TAD I BEG003
DCA BEG004
ISZ BEG003
TAD I BEG004
CLL RTR
RTR
RTR
JMS BEG03X
TAD I BEG004
JMS BEG03X
ISZ BEG004
JMP BEG003+5
BEG03X, 0
AND (77
SNA
JMP I BEG003
TAD (-37
SNA
JMP CRLF
SPA
TAD (100
TAD (237
JMS TTCHAR
JMP I BEG03X
TTCHAR, 0
TLS
CLA
TSF
JMP .-1
KSF
JMP I TTCHAR
JMP I BEG003 /EXIT ON CHAR.
CRLF, TAD (215
JMS TTCHAR
TAD (212
JMP TTCHAR-2
BEG004, 0
PAGE
BEGCK0, L0001
TAD BEGUSR
SMA CLA
JMP I (BEGOLD /ONLY ONE USER--WHY BOTHER HIM W/DUMB QUESTIONS?
JMS I (BEG003
BEGMQ
JMS I (BEG001
TAD (-"N
SNA
JMP I (BEG500 /GO ASK FOR IT
TAD (-"Y+"N
SNA CLA
JMP I (BEGOLD /THIS WAS AN AFTERTHOUGHT, QUITE FRANKLY
JMS I (BEG003
BEGME
JMP BEGCK0 /ASK HIM AGIN
PAGE
LBLK=SS
OLNUM=USRPT2
NUNUM=CORPT2
BEGER0, CDF 20
JMS I (BEG003
WNGDM
BEG500, CDF 20
TAD BEGUSR
DCA USRCTR
TAD (USRLST
DCA USRPTR
TAD BEGCOR
IAC
DCA CURFLD
BEGFLD, L7777
TAD CURFLD
SPA SNA
JMP BEGER0 /EH?
DCA CURFLD
JMS I (BEG003
BEGMFL
TAD (60
TAD CURFLD
TLS
CLA
TSF
JMP .-1
TAD (20 /20 LOGICAL BLOCKS
DCA LBLK
BEGXXX, JMS I (BEG003
BEGMXX
TAD LBLK
JMS I (BEGPRNT
JMS I (BEG003
BEGMX1
JMS I (BEG001
TAD (-"5
SMA SZA
JMP BEGER1
TAD (5
SPA SNA
JMP BEGER1 /BAD USERNO
DCA I USRPTR
TAD BEGUSR
TAD I USRPTR
SMA SZA CLA
JMP BEGER1 /NONEXISTENT USER DUMMY
ISZ USRPTR
TAD CURFLD
DCA I USRPTR
ISZ USRPTR /AND HIS NO.
BEGRE, JMS I (BEG003
BEGTTI
DCA OLNUM /DOUBLE CHECK!
BEGINP, JMS I (BEG001
TAD (-215
SNA
JMP DN
TAD (215-"9
SMA SZA
JMP BEGER2 /UNGOOD NO
TAD (11
SPA
JMP BEGER2 /LIKEWISE
DCA NUNUM
TAD OLNUM /MULT BY 10 DECIM
CLL RAL
RTL
TAD OLNUM
TAD OLNUM
TAD NUNUM /PLUS NEW DIGIT
DCA OLNUM /MAKES NEW NO
JMP BEGINP
DN, TAD OLNUM
SNA SPA SZL
JMP BEGER2 /JUNKY NO
CIA
TAD LBLK
SPA
JMP BEGER0 /TOO MUCH ASKED FOR
DCA LBLK /NEW AMOUNT REMAINING
TAD OLNUM
ISZ USRCTR
SKP
JMP BEGR2
DCA I USRPTR
ISZ USRPTR
TAD LBLK
SZA CLA /MORE TO COME IN THIS FIELD?
JMP BEGXXX /SURE IS
L7776
TAD CURFLD
SNA SPA CLA
JMP BEGER0
JMP BEGFLD /MORE FIELDS TO COME
BEGER2, JMS I (BEG003
BEGME
JMP BEGRE
BEGER1, JMS I (BEG003
BEGME
JMP BEGXXX
BEGR2, TAD LBLK /EXPAND HIM TO FINISH FIELD
DCA I USRPTR /THERE'S NO REASON TO WASTE CORE
ISZ USRPTR /JUST THINK OF ALL THE PEOPLE WHO GO TO BED HUNGRY FOR IT EVERY NIGHT!
JMP I (BEG540
PAGE
BEG540, CLA CLL IAC BSW
TAD (-100
SZA CLA
JMP BEG550-2 /NOT AN 8/E
ISZ KL8FRST /FIRST TIME THRU?
JMP BEG550 /NO - DON'T BLOW IT!
TAD BEGDEV
SNA CLA
JMP BEG550 /THE FOOL HAS AN 8/E WITH DC02
CDF
TAD (KL8JMP+1&177+5600
DCA I BEGKL3
ISZ BEGKL3
TAD (KL8FIX
DCA I BEGKL3
CDF 20
JMP BEG550
BEGKL3, KL8JMP
KL8FRST, 7777
CDF 10
DCA I (INTRRV /NOT AN 8/E
BEG550, CDF 20
TAD (USRLST /NOW WE SORT FOR FIELDS TO MAKE IT EASY
DCA USRPTR
L0003
TAD (USRLST
DCA CORPTR
TAD BEGUSR
DCA USRCTR
DCA SS /SORT SWITCH FOR MODIFIED BUBBLE SORT
BEG551, TAD USRPTR
IAC
DCA USRPT2
TAD CORPTR
IAC
DCA CORPT2
ISZ USRCTR
SKP
JMP BEG553
TAD I USRPT2
CIA
TAD I CORPT2
SNA SPA CLA /DECREASING SORT ON FIELDS
JMP BEG552
L7775
DCA SS /3 SWAPS
TAD I USRPTR
DCA BEG554
TAD I CORPTR
DCA I USRPTR
TAD BEG554
DCA I CORPTR
ISZ USRPTR
ISZ CORPTR
ISZ SS
JMP .-11
ISZ SS /SET TO INDICATE
BEG552, L0002
TAD USRPT2
DCA USRPTR
L0002
TAD CORPT2
DCA CORPTR
JMP BEG551
BEG553, TAD SS
SZA CLA
JMP BEG550
JMP I (BEG600
BEG554, 0000
PAGE
BEG600, TAD (BEGLST
DCA USRPT2
TAD (USRLST
DCA USRPTR
TAD BEGUSR
DCA USRCTR
TAD I (USRLST+1
BEG610, DCA CURFLD
DCA BEG602
TAD (CONEND
DCA BEG601
NXUSR, TAD I USRPTR
ISZ USRPTR
DCA I USRPT2
ISZ USRPT2
TAD I USRPTR
CIA
TAD CURFLD
SZA CLA
JMP BEG609 /HE WANTS A NEW FIELD
ISZ USRPTR
TAD CURFLD
CLL RAL
RTL
TAD (6201 /MAKE UP XFIELD OP
DCA I USRPT2 /INTO OUR QUICKIE LIST
ISZ USRPT2
TAD I USRPTR
ISZ USRPTR
CIA
DCA SS
TAD (400
ISZ SS
JMP .-2 /MULT. HIS BLOCKSIZE BY 400 OCTAL FOR CORE SIZE
DCA SS
L7776
TAD BEG602
DCA I USRPT2
ISZ USRPT2
TAD SS
CIA
TAD BEG602
DCA BEG602
L0004
TAD BEG602
SPA CLA
JMP BEG608-1
TAD BEG602
SPA
JMP BEG607
CIA
TAD BEG601
SMA CLA
JMP BEG607
TAD BEG602
BEG608, DCA I USRPT2
ISZ USRPT2
ISZ USRCTR
JMP NXUSR
JMP I (BEG700 /WHEW..THAT WENT QUICKLY ANYWAY
BEG601, 0 /BOTTOM
BEG602, 0 /TOP
BEG609, TAD USRPTR
DCA CURFLD /SAVE IT
L7777
TAD USRPTR
DCA USRPTR /TAKE OUT ENTRIES
L7777
TAD USRPT2
DCA USRPT2
TAD I CURFLD /COUNT DOWN FIELD
JMP BEG610
BEG607, CLA
TAD BEG601
JMP BEG608
PAGE
BEG700, TAD (BEGLST
DCA USRPTR
DCA SS
TAD BEGUSR
DCA USRCTR
L0004
TAD (BEGLST
DCA USRPT2
BEG7X1, ISZ USRCTR
SKP
JMP BEG703
TAD I USRPTR
CIA
TAD I USRPT2
SNA
JMP I (BEGER0 /MULTIPLE ASSIGNMENTS FOR ONE USER
SMA CLA /ASCENDING SORT ON USER NUMBERS
JMP BEG702
TAD (-4
DCA SS
BEG701, TAD I USRPTR
DCA CORPTR
TAD I USRPT2
DCA I USRPTR
TAD CORPTR
DCA I USRPT2
ISZ USRPTR
ISZ USRPT2
ISZ SS
JMP BEG701
ISZ SS
TAD (-4
BEG702, TAD USRPT2
DCA USRPTR
L0004
TAD USRPTR
DCA USRPT2
JMP BEG7X1
BEG703, TAD SS
SZA CLA
JMP BEG700 /MORE TO COME
TAD (BEGLST
DCA USRPTR /NOW TAKE OUT USER NOS.
TAD BEGUSR
DCA USRCTR
IAC
TAD (BEGLST
DCA USRPT2
BEG704, L7775
DCA SS
TAD I USRPT2
DCA I USRPTR
ISZ USRPTR
ISZ USRPT2
ISZ SS
JMP .-5
ISZ USRPT2 /SKIP OVER USER NO.
ISZ USRCTR
JMP BEG704
JMS I (BEG003
BEGM6A
JMS I (BEG001
TAD (-"Y
SZA CLA
JMP I (BEG708 /OH NO--ALL THIS JUNK FOR NOTHING!
/ALL'S WELL - PRINT "END OF DIALOGUE" AND MOVE IN OS-8 BOOTSTRAP
/ AND PAGE 7600 FIELD 0
JMS I (BEG003
BEGM6
BEGMV4, CDF 10
TAD I BEGMV1 /MOVE PAGE 7600 FIELD 0 INTO ITS SPOT
CDF
DCA I BEGMV2
ISZ BEGMV1
ISZ BEGMV2
ISZ BEGMV3
JMP BEGMV4
OS8LP1, CDF 20
TAD I OS8PTR
ISZ OS8PTR
CDF
DCA I OS8PT2
ISZ OS8PT2
JMP OS8LP1
JMP I (BEG750
OS8PT2, 7756 /INTO RIM LOCATIONS
BEGMV1, MVPAG
BEGMV2, 7600
BEGMV3, -156
BEGPRNT,0
DCA BEG705
TAD (-12
DCA BEG706
DCA BEG707
JMP .+3
ISZ BEG707
DCA BEG705
BEGPR1, TAD BEG705
TAD BEG706
SMA
JMP .-5
CLA
TAD (60
TAD BEG707
TLS
TSF
JMP .-1
KCC
ISZ BEG706
SKP
JMP I BEGPRNT /WAS SECOND TIME THROUGH
L7777
DCA BEG706
DCA BEG707
JMP BEGPR1
BEG706, 0
BEG707, 0
BEG705, 0
BEG604=SS
BEG605=USRPTR
PAGE
BEG750, CDF 20
TAD BEGCOR
DCA I (BGCORS
CDF
TAD I (MLOOKE
TAD BEGUSR
DCA I (MLOOKE /CORRECT FOR NO. OF USERS
TAD I (MLOOKE
CIA
DCA I (LOOK
TAD BEGUSR
DCA I (MUSER /SETUP FOR NO. OF USERS
TAD (BEGIOT-1
DCA BEG604
TAD (INTRPL
DCA BEG605
L7777
TAD BEGUSR
DCA BEG60X
TAD BEGUSR
DCA USRCTR
BEG75Q, CDF 20
TAD I BEG604
ISZ BEG604
CDF
ISZ BEG60X
JMP .+4
CLA CMA
DCA BEG60X
TAD (CLA-6006
TAD (6006
DCA I BEG605
ISZ BEG605
ISZ USRCTR
JMP BEG75Q
CDF
TAD BEGUSR
DCA SS
ISZ SS
SKP
JMP .+3
CLL CML RAR
JMP .-4
DCA I (AUSER
CDF 20
BEG75X, TAD BEGCOR
CLL RTL
RAL
TAD (CDF
DCA BEG756
TAD BEG756
TAD (-6221
SNA CLA
JMP BEG760
DCA BEG751
DCA BEG752
BEG755, CDF 20
TAD I BEG751
ISZ BEG751
NOP
BEG756, CDF 30
DCA I BEG752
ISZ BEG752
JMP BEG755
L7777
TAD BEGCOR
DCA BEGCOR
JMP BEG75X
BEG60X, 0
BEG751=USRCTR
BEG752=USRPTR
BEG760, TAD BEGDEV
SNA CLA
JMP BEG76X
CDF
DCA I (XOUTL6+3
DCA I (XOUTL6-3
DCA I (INTRP2-2
DCA I (INTRP2+4
DCA I (INTRP5
DCA I (INTRP5+1
CDF 10
DCA I (INTRV2+1
JMP I (BEG800
BEG76X, L0001
MINT
CLA /TURN ON INTERRUPTS
CDF 10
TAD (TLS
DCA I (INTRRV
TAD (MTLS
DCA I (INTRV2+2
JMP I (BEG800
PAGE
USRLST, 0
PAGE
BEGOLD, L7777
TAD BEGCOR /COUNT DOWN BY ONE FOR BREVITY OF LISTS
CLL RTL
RAL
TAD BEGUSR /GET ADDR. OF ADDR. OF LIST
TAD (BGLD1
DCA SS
TAD I SS
DCA SS
TAD (USRLST
DCA USRPTR /SETUP TO SLIDE
TAD BEGUSR
DCA USRCTR /NO. OF SLIDES
BEGOL1, TAD I SS
CLL RTL
RTL
AND (7
DCA I USRPTR
ISZ USRPTR
TAD I SS
CLL RTR
RTR
RTR
AND (7 /SET FIELD
DCA I USRPTR
ISZ USRPTR
TAD I SS
AND (37
DCA I USRPTR
ISZ SS
ISZ USRPTR
ISZ USRCTR
JMP BEGOL1
JMP I (BEG540 /CONTINUE ON...WE'VE ANSWERED QUESTIONS FOR HIM NOW.
PAGE
X=100
BGL22, 12^X+10
22^X+10
BGL21, 12^X+20
BGL31=BGL21
BGL41=BGL21
BGL51=BGL21
BGL61=BGL21
BGL71=BGL21
BGL23, 12^X+6
22^X+5
32^X+5
BGL24, 12^X+4
22^X+4
32^X+4
42^X+4
BGL25, 12^X+4
22^X+3
32^X+3
42^X+3
52^X+3
BGL33, 12^X+20
23^X+10
33^X+10
BGL32, 12^X+20
23^X+20
BGL42=BGL32
BGL52=BGL32
BGL62=BGL32
BGL72=BGL32
BGL34, 12^X+10
22^X+10
33^X+10
43^X+10
BGL35, 12^X+5
22^X+6
32^X+5
43^X+10
53^X+10
BGL44, 12^X+20
23^X+20
34^X+10
44^X+10
BGL43, 12^X+20
23^X+20
34^X+20
BGL53=BGL43
BGL63=BGL43
BGL73=BGL43
BGL45, 12^X+20
23^X+10
33^X+10
44^X+10
54^X+10
BGL55, 12^X+20
23^X+20
34^X+20
45^X+10
55^X+10
BGL54, 12^X+20
23^X+20
34^X+20
45^X+20
BGL64=BGL54
BGL74=BGL54
BGL56, 12^X+20
23^X+20
34^X+10
44^X+10
55^X+10
65^X+10
BGL65, 12^X+20
23^X+20
34^X+20
45^X+20
56^X+20
BGL75=BGL65
BGL77, 77^X+20
BGL76, 12^X+20
23^X+20
34^X+20
56^X+20
45^X+20
BGLD1, 0;0;0
BGL25
BGL24
BGL23
BGL22
BGL21
0;0;0
BGL35
BGL34
BGL33
BGL32
BGL31
0;0;0
BGL45
BGL44
BGL43
BGL42
BGL41
0;0;0
BGL55
BGL54
BGL53
BGL52
BGL51
0;0;0
BGL65
BGL64
BGL63
BGL62
BGL61
0;0;0
BGL75
BGL74
BGL73
BGL72
BGL71
0040
BEGIOT, 0120
0120
0120
0120
PAGE
BEG800, CDF 20
TAD I BEG804
JMS BEG900
TAD (-4
JMS BEGZER
TAD (READY
JMS BEG900
TAD (-10
JMS BEGZER
L7777
JMS BEG900
JMS BEG900
TAD I BEG805
TAD (6006-10
JMS BEG900
TAD I BEG802
JMS BEG900
TAD (-5
JMS BEGZER
TAD (BUFFER
TAD I BEG803
JMS BEG900
TAD (BUFFER
TAD I BEG803
JMS BEG900
TAD (BUFFER
TAD I BEG803
JMS BEG900
TAD (BUFFER-40
TAD I BEG803
JMS BEG900
TAD (BUFFER-40
TAD I BEG803
JMS BEG900
L7775
JMS BEGZER
TAD (LINE1
TAD I BEG803
JMS BEG900
TAD (LINE1
TAD I BEG803
JMS BEG900
TAD I BEG804
JMS BEG900
TAD (LINE0
TAD I BEG803
JMS BEG900
TAD (BUFCOM
TAD I BEG803
JMS BEG900
JMS BEG900
JMS BEG900
TAD (1617 /"NO"
JMS BEG900
TAD (1605 /"NE"
JMS BEG900
JMS BEG900
TAD (XREADC
JMS BEG900
TAD (XPRNTC
JMS BEG900
TAD (XFREE2
JMS BEG900
TAD (XFREE3
JMS BEG900
TAD BEGBAS
JMS BEG900
TAD BEGBAS
TAD (400
DCA BEGBAS
TAD (-15
JMS BEGZER
ISZ BEG802
ISZ BEG802
ISZ BEG802
ISZ BEG803
ISZ BEG803
ISZ BEG803
ISZ BEG804
ISZ BEG804
ISZ BEG804
ISZ BEG805
ISZ BEGUSR
JMP BEG800
JMP I (FINISH
BEG801, ORG1 /KLUDGE TO MAKE EXTRA ROOM
BEG802, BEGLST
BEG803, BEGLST+2
BEG804, BEGLST+1
BEG805, BEGIOT-1
BEGBAS, 5400
BEGZER, 0
DCA BEGZCT
JMS BEG900
ISZ BEGZCT
JMP .-2
JMP I BEGZER
BEGZCT, 0
BEG900, 0
CDF 10
DCA I BEG801
CDF 20
ISZ BEG801
JMP I BEG900
PAGE
BEGLST,0
PAGE
OS8ERM, TEXT "_ILLEGAL OS/8 DEVICE FOUND_NO BOOTSTRAP POSSIBLE!__"
OS8MSG, TEXT "_TO BOOTSTRAP BACK "
OS8M1, TEXT "OS/8 "
OS8M2, TEXT "MONITOR:_ LOAD ADDRESS 07600_ AND START__"
BEGME, TEXT %_INVALID RESPONSE_%
BEGM1, TEXT %__EDUSYSTEM 25 BASIC__%
BEGM2, TEXT %_NUMBER OF USERS (1 TO 5)?%
BEGM4, TEXT %_PDP-8/L COMPUTER (Y OR N)?%
BEGM5, TEXT %_TELETYPE #1 DEVICE CODE?%
BEGM5A=BEGM5+5
BEGM7, TEXT %_STANDARD REMOTE TELETYPE CODES (Y OR N)?%
BEGMFL, TEXT %_FIELD %
BEGMXX, TEXT %_THERE ARE %
BEGMX1, TEXT % BLOCKS LEFT IN THIS FIELD._ YOUR ALLOCATION FOR USER #%
BEGTTI, TEXT % WILL BE HOW MANY BLOCKS?%
BEGM6, TEXT %__END OF DIALOGUE_%
WNGDM, TEXT %_BLOCK SIZES DON'T WORK--HAVE TO START AGAIN__%
BEGMQ, TEXT %_SAME AMOUNT OF STORAGE FOR ALL USERS?%
BEGM6A, TEXT %_IS THE ABOVE CORRECT (Y OR N)?%
LDRERR, TEXT %_"EDU" NOT ASSIGNED TO OS8 DEVICE_OR IT'S WRITE LOCKED%
LDRER2, TEXT %__RETURNING TO OS8_%
CHNERR, TEXT %_"SYS:EDU25.SV" NOT FOUND%
BEGMRK, TEXT %__IS THE SYSTEM DEVICE AN RK8-E (Y OR N)?%
PAGE
LINK=XENTER+1
PLINK, SETPT
ISZ ENTRIES
SKP
JMP LINKF /TAPE FULL
LINK2, TAD I XR1
SNA CLA
JMP .+3
L0003
BUMPXR
TAD I XR1
CIA
TAD BLOCK
DCA BLOCK
ISZ ENTRIES
JMP LINK2 /IGNORE ALL BUT THE LAST ENTRY
TAD I XR1 /SEE IF ITS AN EMPTY
SZA CLA
JMP LINKF /ITS NOT TAPE FULL
TAD I XR1 /IT IS, SEE IF ITS BIG ENOUGH
DCA LINKS /SAVE SIZE OF EMPTY
TAD LINKS
CLL
TAD TEMPX1
SZL CLA
JMP LINKF /ITS NOT BIG ENOUGH
TAD I (CATBLK /SEE IF ON THE LAST BLOCK
TAD (-14
SZL CLA
JMP LINKF /NO WHERE TO LINK TO
L0002
TAD I (CATBLK
CLL RAR
DCA I (DIRBUF+2 /LINK THE BLOCK
ISZ I (DIRBUF /RESET # ENTRIES
TAD BLOCK
DCA LBLOCK /SAVE BLOCK GETCAT HITS IT
CLL
TAD I (CATBLK
GETCAT /WRITE IT OUT
TAD LBLOCK
DCA I (DIRBUF+1 /SET UP STARTING BLOCK NUMBER
DCA I XR1 /MAKE AN EMPTY
TAD LINKS
DCA I XR1 /OF THE RIGHT SIZE
STA
DCA I (DIRBUF /1 ENTRY FOR THIS BLOCK
DCA I (DIRBUF+2 /ZERO LINK
L0002
TAD I (CATBLK
GETCAT /L=0 SO WRITE
CALL
CENTER^2
MLOOP /GOOD LINK RETURN TO MLOOP
LINKF, CALL
CENTER^2
ENTERF /FAILURE RETURN
LBLOCK, 0
LINKS, 0
GCATS, 0
PAGE
/THAT WAS TO FIX THOSE NASTY LITERALS
DSKP=6741
DCLR=6742
DLAG=6743
DLCA=6744
DRST=6745
DLDC=6746
/FIX END OF PAGE LITTERALS SO THEY READ
/ENTERF, CDF CIF 0
/ JMP I XENTER
/XENTER, 0000
AND (0000
AND (5777
AND (CDF CIF
*.-3 /RESET THE LOCATION COUNTER TO THE START OF THE PAGE
RK8E, 0000
IOF /NO INT PLEASE
SNA CLA /AC=1 FOR READ
TAD (4000 /LINK HAS ARG SO N L4000 PLEASE
DCA RK8ERW /READ = 0 WRITE = 4000
DCA RK8EHI /CLEAR HIGH ORDER (BLOCK ADDRESS)
RDF
TAD RKX
DCA RKXIT /SAVE CALLING FIELD
TAD I RK8E
ISZ RK8E
DCA BUFADD /SAVE BUFFER ADDRESS
TAD I RK8E
ISZ RK8E
AND Z200 / LOCATION 7 HAS 200, SEE IF HALF OR FULL BLOCK
DCA HALFBLOCK /200 IF HALF A BLOCK 0 IF FULL BLOCK
TAD I RK8E /CONSTRUCT FULL ADDRESS
ISZ RK8E
RAR /BLOCK NUMBER NOW IN AC HALF BLOCK FLAG IN LINK
DCA BLOCKNUM
SNL
TAD BUFADD /USE BUFADD
SZL
TAD ZDIRBUF /LAST HALF SO USE DIRBUF
DLCA
RAR
DCA LASTHALF /LAST HALF OF BLOCK FLAG
TAD EXTEN /SEE IF .EX
AND Z100
SZA CLA
JMP RUNIT0
TAD (-XCALLB-1 /SEE IF CALL
TAD RK8E
SZA CLA
RUNIT1, TAD (6260
CLL
TAD BLOCKNUM
DCA BLOCKNUM
SZL
ISZ RK8EHI
RUNIT0, TAD LASTHALF
SZA CLA
JMP RKLHF
TAD HALFBLOCK
CLL RAR
TAD RK8ERW
RKLHF, TAD RK8EHI
TAD (1410 /ENABLE INTERRUPT ON DONE FROM FIELD 1
/AND CHECK THE SEEK BECAUSE I'M NOT DOING SEQUENTIAL ADDRESSING.
DLDC /LOAD COMMAND REGISTER
TAD BLOCKNUM
DLAG /DISK LOAD AND GO
RKX, CIF CDF
TAD I ZLOOK
DCA TEMPX
TAD I TEMPX
AND Z6777
TAD Z1000
DCA I TEMPX /SET BUSY FLAG
TAD ZDXIT /FAKE ADDRESS
JMP I ZRUN9X /IT WILL TURN ION AT NULL
RK8INT, DRST
CLL RAL
SZA CLA
JMP RK8ERR /SOME SORT OF FAILURE REPORT IT.
DCLR /CLEAR STATUS REGISTER (AND FLAG)
TAD LASTHALF
SNA CLA
JMP RK8END
TAD (DIRBUF+200
DCA RK8EPT
TAD (-200
DCA LASTHALF
TAD RK8ERW
SMA CLA
JMP RK8ERD /ITS A READ
TAD I BUFADD
DCA I RK8EPT
ISZ BUFADD
ISZ RK8EPT
ISZ LASTHALF
JMP .-5
TAD ZDIRBUF
DLCA
TAD RK8EHI
TAD (1410
TAD RK8ERW
DLDC
TAD BLOCKNUM
DLAG
JMP DIS
RK8ERD, TAD I RK8EPT
DCA I BUFADD
ISZ BUFADD
ISZ RK8EPT
ISZ LASTHALF
JMP .-5
RK8END, CDF 0
TAD I ZDTQ1
DCA TEMPX
TAD I TEMPX
TAD ZUSER0M1 /BUILD POINTER TO STATUS
DCA TEMPX
TAD I TEMPX
AND Z6777
DCA I TEMPX
JMP DIS
RKXIT, HLT
JMP I RK8E
RK8ERR, DCLR /ERROR,CLEAR FLAG
TAD ZOERROR
DCA RKXIT
JMP RK8END
BUFADD, 0
HALFBLOCK, 0
LASTHALF, 0
BLOCKNUM, 0
RK8EPT, 0
RK8EHI, 0
RK8ERW, 0
PAGE
CENTER=27 /ENTER CALL OVERLAY
CLINK=30 /LINK CALL OVERLAY
SYSINI, 0000
CLA CLL
JMS I (BEG003
BEGMRK
JMS I (BEG001
TAD (-"N
SNA
JMP SYSDTA
TAD ("N-"Y
SZA CLA
JMP SYSINI+1
CDF 10
TAD (DSKP
DCA I (DTINTR+1 /FIX THE SKIP INSTRUCTION
TAD (RK8INT&177+DTAPE
DCA I (MCOM
TAD (RKXIT&177+DTAPE
DCA I (PDXIT
TAD (RKXIT&177+DTAPE
DCA I (ZDXIT
CDF 20
JMS BLT
CDF 20
RK8E /MOVE IN THE DISK HANDLER
CDF 10
DTAPE /OVER THE DECTAPE HANDLER
7600
CDF 20
TAD (DLAG
DCA I (OSDRK8+21
SYSDTA, JMS BLT /BLOCK TRANSFER
CDF 0
4000 /FROM 4000 IN FIELD 0
CDF 10
DIRBUF /TO DIRBUF IN FIELD 1
7600 /SAVE THE WHOLE PAGE
CLA CLL
CDF 20
CIF 10
JMS I (USR
FETCH
TEXT %EDU% /PAL10 DOESN'T HAVE DEVICE PSUDO-OP
ENTRY0, 4000 /PUT DTA HANDLER IN PAGE 4000 FIELD 0
JMP I (ERRLDR /HANDLER NOT FOUND
CLA CLL
CDF 20
CIF 0
JMS I ENTRY0
4120 /WRITE 1 PAGE FROM FIELD 2
PLINK /FROM CORE AT PLINK
CLINK /TO DECTAPE BLOCK NUMBER CLINK
JMP I (ERRLDR
CLA CLL
CDF 20
CIF 0
JMS I ENTRY0 /DO SAME FOR XENTER
4110 /WRITE 1 PAGE FROM FIELD 1
XENTER+1 /FROM CORE AT XENTER+1
CENTER /TO TAPE BLOCK CENTER
JMP I (ERRLDR
CLA CLL
JMS BLT
CDF 10
DIRBUF
CDF 0
4000
7600
CDF 20
JMP I SYSINI
BLT, 0000
TAD I BLT
ISZ BLT
DCA BLT1
TAD I BLT
ISZ BLT
DCA BLT2
TAD I BLT
ISZ BLT
DCA BLT3
TAD I BLT
ISZ BLT
DCA BLT4
TAD I BLT
ISZ BLT
DCA BLT5
BLT1, 0000
TAD I BLT2
BLT3, 0
DCA I BLT4
ISZ BLT2
ISZ BLT4
ISZ BLT5
JMP .-7
JMP I BLT
BLT2, 0
BLT4, 0
BLT5, 0
*7600
FINISH, TAD (CONEND
DCA XPNT
TAD BGCORS
CLL RTL
RAL
TAD (CDF
DCA XCDF
XCDF, 0
DCA I XPNT /CLEAR FIELD
ISZ XPNT
JMP .-2
L7777
TAD BGCORS
DCA BGCORS
L7777
TAD BGCORS
SZA CLA
JMP FINISH /ANOTHER FIELD TO WIPE STILL
CIF CDF
JMP I (ENTRY /WHEW!
BGCORS, 0
XPNT, 0
$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*$*
Version as of 19 FEBRUARY 1973.Thank God It's off my Back!
h