File: FOCOVR.PA of Tape: Sources/Focal/fc3
(Source file text)
/PATCHES TO FOCAL ITSELF!
FIELD 1
*0
ECHOP, ECHO
TABC, 0 /TAB COUNTER
CNTRX, 0
ATSW, 0
RISZ, 0 /RANDOM RANDOM #'S
*TELSW
0 /CLEAR IN-PROGRESS FLAG
*PC
PC0
*LASTV
STVAR
*37
GOK, GOKILL /TO KILL 'CURRENT PROGRAM SAVED' FLAG
*BUFR
LINE1
*73
LIST6, 214 /F.F. (^L)
207 /BELL
LIST7=.
*126
POPA=JMS I .
XPOPA
*COMBUF
LIBN, LIBFIL
LINE0
STVAR
LINE1
*137
CFRSX, FLTZER /MOVED FOR ^L FUDGE
*140 /REDEFINE SOME NEW INSTRUCTIONS
PUSHJ=JMS I .
XPUSHJ
POPJ=JMP I .
XPOPJ
PUSHA=JMS I .
XPUSHA
PUSHF=JMS I .
PD2
POPF=JMS I .
PD3
*154
XGETLN /CHANGE POINTER
*167 /8K SUBROUTINES
DPC, 2564 /PC
DTHIS, THISD /THISLN
DPT1, PT1D /PT1
DXRT, XRTD /(TAD I XRT)
DAXIN, AXIND /(DCA I AXIN)
DAXOUT, AXOUTD /(TAD I AXOUT)
SECRTV, STVAR /FOR SECRET VARIABLES, OF COURSE
TELPCH
*200
JMP I 176 /FUDGE FOR ?00.00 PRINTOUT
*201
TAD C200 /INITIALIZE PC
*206
TAD PUSHB /OVERFLOW PROTECTION
*211
JMS I ECHOP /SHOULD WE PRINT A '*'?
*212
TAD BUFR /COMMAND INPUT BUFFER
*215
TAD BUFR /RUBOUT PROTECTION
*221
LIST7-1 /MOVED DOWN ONE
INLIST-LIST7
*226
PUSHB, RESTORE-1+13 /END FOR TEXT AND COMMAND INPUT
*231
TAD BUFR /INITIALIZE FOR UNPACKING
*235
TAD PUSHB1 /INIT STACK POINTER
*255
JMS I DAXIN /DCA I AXIN
*273
JMS I DPC /TAD I PC
*302
FL100, 7
3100
0
FLP5, 0
2000
0
0
TEMP, ZBLOCK 4
XGETLN, 0 /COMPUTED LINE #'S
SPNOR /IGNORE SPACES
TAD CHAR /'A' IS SPECIAL
TAD MINUSA
SNA CLA
JMP TESTA
PUSHJ /EVALUATE NUMBER OR EXPRESSION
EVAL
FENT
FPUT TEMP /SAVE IT
FEXT
INTEGER /GET GROUP PART
TAD P7740 /CHECK IF TOO BIG
SMA CLA
ERROR2 /BAD GROUP #
TAD FLAC+2 /GET GROUP AGAIN
RTL6
RAL
DCA LINENO /SAVE IT
NEGATE
FENT
FADD TEMP /GET FRACTION
FMUL FL100
FADD FLP5 /ROUND UP
FEXT
INTEGER
TAD LINENO /ADD GROUP
TESTA, DCA LINENO
CLA CLL
TAD LINENO /CHECK FOR ERROR
AND P7600
SZA CLA
CML
TAD LINENO
AND P177
SNL SZA
ERROR2 /ILLEGAL GROUP ZERO USAGE
SZA CLA /AND SET NAGSW
TAD P2000
CML RAL
DCA NAGSW
JMP I XGETLN
PUSHB1, 3576+13
*375 /PATCHES TO FUNCTION TABLE
XSGN
*400
FRAN
*410
FIN
FOUT
*436
JMS I DXRT /TAD I XRT
*445
JMS I DPC
*455
JMS I DPT1 /TAD I PT1
*473
POPA
*460
JMS I DPT1 /TAD I PT1
/PUSH DOWN LIST SUBROUTINES
*477
PD2, 0
TAD I PD2
ISZ PD2
DCA .+3
CIF
JMS I .+3
0
JMP I PD2
MPD2
PD3, 0
TAD I PD3
DCA .+4
ISZ PD3
CIF
JMS I .+3
0
JMP I PD3
MPD3
XPOPA, 0
CIF
JMS I .+2
JMP I XPOPA
MPOPA
*630
POPA
*652
JMS I DTHIS /TAD I THISLN
*661
JMS I DPT1 /TAD I PT1
*664
JMS I DPT1 /TAD I PT1
*1012
"O /ADD 'OPEN' COMMAND
*1015
POPA
*1140
FLTONE /MOVED FOR ^L FUDGE
*1054
POPA
*1115
POPA
*1155
POPA
*1200
RETRN /MOVE 'RETURN'
FILER /ADD 'OPEN'
*1203
DCA ATSW /ALL REFERENCES TO 'ATSW' MUST BE CHANGED
*1206
ALIST-1
ATLIST-ALIST
*1210
ISZ ATSW
*1216
CLA CLL /DON'T PRINT COLON
NOP
*1223
POPA
*1246
TAD P15 /PRINT CR ONLY
PRINTC /(PRINTC HANDLES NULL FOR DELAY!)
JMP .+3
*1255
P15, 15
*1265
JMS I DAXIN /DCA I AXIN
*1277
LISTGO-LIST3 /LISTGO HAS MOVED
*1310
LIST6-1
SRNLST-LIST6
*1354
XPUSHA, 0
CIF
JMS I .+2
JMP I XPUSHA
MPUSHA
*1365
1302 /MOVE UP ONE TO ADD TAB
1271
LISTGO, 0261
1312
ALIST, ":
*1433
POPA
*1440
TAD SECRTV /VARIABLE SEARCH STARTS WITH SECRET VARIABLES
*1464
TAD BOTTOM /CHECK FOR OVERFLOW
*1530 /RESIDENT FOR LIBRARY GOSUB
SP, 240
LIB+1
*1553
LGOSUB, CLA CLL
PUSHJ /EXECUTE SUBROUTINE
DO+1
TAD SP /LIBRARY 'SPACE' = LIBRARY RETURN!
DCA CHAR
JMP I SP+1 /SKIP 'SPNOR'
RETRN, TAD C200
DCA PC
XPOPJ, POPA
DCA T2
JMP I T2
CLA CLL /FREE LOCATION!!
ATLIST, XTAB
*1626
JMP 1650 /'EVAL' FOUND A TERMINATOR WHICH WAS NOT AN OPERATOR -
/END OF EXPRESSION (NOT ERROR!)
*1705
POPA
*1757
POPA
*1766
POPA
*2010
GOKILL, CDF
DCA I LIBN /ZERO 'CURRENT PROGRAM SAVED' FLAG
CDF 10
JMP START
*2050
POPA
*2052
POPA /REVERSE THESE TWO INSTRUCTIONS
TAD 2034
*2105
CDF /CHANGE DATA FIELD FOR 'DELETE'
*2201
1140 /FIN
2672 /FOUT
*2216
CDF
DCA I CFRS /ERASE ALL TEXT
JMP I GOK
*2231
JMS I DTHIS /TAD I THISLN
TSTGRP /DONE ERASING GROUP?
JMP I GOK /YES, ERASE 'CURRENT PROGRAM SAVED' FLAG
JMS I DTHIS /TAD I THISLN
*2237
TAD END /ZERO VARIABLES (BUT NOT SECRET VARIABLES!)
*2253
JMS I DXRT /TAD I XRT
*2262
JMS I DTHIS /TAD I THISLN
*2345
JMS I DAXOUT /TAD I AXOUT
*2361
CDF /CHANGE TO TEXT FIELD
*2374
DCA I LIBN /WE'VE ADDED A NEW LINE
CDF 10 /KILL 'CURRENT PROGRAM SAVED' FLAG
*2405
INPUT+1 /^L IN ASK STATEMENT, IGNORE IT
FLTONE, 0001 /ALL THIS MUST BE MOVED DOWN ONE
2000
FLTZER, 0000
0000
0000
0000
M12, -12 /CONSTANT FOR 'PRNT'
XPUSHJ, 0
CLA CLL IAC
TAD XPUSHJ /BUMP RETURN ADDRESS
PUSHA /SAVE IT ON THE STACK
TAD I XPUSHJ /GET THE ADDRESS
DCA XPUSHJ /INDIRECT INDIRECT!
JMP I XPUSHJ
*2453
TAD M12 /PATCH 'PRNT'
*OUT+3
CIF
JMS I TAB /COUNT CHARACTERS
JMP OUTCR /IT WAS A CR, PRINT CR/LF
JMS I OUTDEV /PRINT NORMAL CHAR
JMP I OUT
OUTCR, TAD CCR
JMS I OUTDEV
TAD CLF
JMP OUTCR-2
TAB, TABCNT
*2530 /RESTORE FIELD AFTER 'PACKC'
CDF 10
*2541
JMS I DAXIN /DCA I AXIN
*2564
0 /PC
CDF
TAD I PC
CDF 10
JMP I .-4
*2572
AXOUTD, 0
CDF
TAD I AXOUT
CDF 10
JMP I AXOUTD
*2602
-220 /CHANGE BREAK CHAR /WE MOVED ITACTER TO ^P
*2640
JMP RECOVR
*2646
PCF /CLEAR COMMON FLAGS
RRB
DCMA /CLEAR DF32 FLAG
CLA CLL
TAD SAVLK
CLL RAL
TAD SAVAC
CIF CDF /RETURN FROM INTERRUPT
JMP 4
RANRAN, ISZ RISZ /BUMP RANDOM NUMBER
JMP 2667 /WHILE WAITING FOR INPUT
JMP RANRAN /DON'T LEAVE ZERO
*2671
JMP RANRAN
*2725
ERROR5, DCA .+1
ERR2, 0
ION
TAD TELSW /WAIT FOR OUTPUT TO FINISH
SZA CLA
JMP .-2
CLA CLL CMA /PUT ERROR CODE IN 'LINENO' FOR 'PRNTLN'
TAD ERR2
SKP
RECOVR, TAD C200 /TELETYPE BREAK
DCA LINENO
IOF
TAD M20 /CLEAR OUTPUT BUFFER
DCA CNTR
CMA
TAD OPTR0
DCA 10
TAD OPTR0
DCA OPTRI
TAD OPTR0
DCA OPTRO
CDF 10
DCA I 10
ISZ CNTR
JMP .-2
DCA INBUF /AND INPUT BUFFER
RECOVX, CIF CDF /DO LOWER FIELD FIXES
JMP I .+1
XRESTOR
TAD P277
PRINTC /PRINT A '?'?
PRNTLN
ISZ PC
JMS I DPC
SNA
JMP .+6
DCA LINENO
TAD P7700
PRINTC
PRINTC
PRNTLN
TAD CCR
PRINTC
JMP START
*3015
JMS I ECHOP /SHALL WE ECHO A '\'?
*3020
CDF /LOWER FIELD TO RUBOUT TEXT
*3052
TAD END /INIT POINTER FOR DUMP (DON'T DUMP SECRET VARIABLES)
*3062
JMP I 3116 /KLUDGE UP TDUMP
*3115
PC0+3
TDUMPX
*3120
ZBLOCK 20 /CLEAR OUTPUT BUFFER
*3140
ECHO, 0
ION /MAKE SURE!
DCA CHAR /SAVE IN CHAR
TAD I C2163 /DO WE WANT TO PRINT?
SNA CLA
JMP I ECHO /NO
PRINTC /YES
JMP I ECHO
C2163, 2163
ICHARF, 0 /INPUT A CHARACTER FROM A FILE
CIF CDF
JMS I CHARI /CALL LOWER FIELD
JMP I ICHARF
CHARI, ICHAR
FILER, CIF /FILE COMMANDS ('OPEN')
JMP I .+1
FILEST
X133P, X133
TERMER, 0 /CHECK FOR TERMINATOR (;, CR, SPACE, OR ,)
SORTC
GLIST-1
ISZ TERMER
CIF CDF
JMP I TERMER
EOF, 0 /TRYING TO READ FROM A FILE AFTER END
TAD X133P /(SHAME ON YOU!)
DCA INDEV /RESET POINTER TO TTY
TAD P277 /PRINT A '?'
JMS OUTL /ON THE TELETYPE
JMS I INDEV /READ A CHARACTER
JMP I EOF
PAGE
OCHAR, 0 /OUTPUT A CHARACTER
DCA T2
OUTECH, SKP /ECHO ON TELETYPE?
JMP .+5
TAD T2 /NO
SNA /YES
CLA CLL CML RAR /LET HIM PRINT NULLS!
JMS I OUTLP
TAD T2
CIF
JMS I NOCARE /OUTPUT IT
JMP I OCHAR
OUTLP, OUTL
NOCARE, NOCHAR
IFNDEF FDIS < /FDIS FOR TEKTRONIX T-4002 AVAILABLE - IF USED,
/PRINTX OVERLAYS OLD FDIS
PRINTX, 0
JMS I OUTDEV
CIF
JMP I PRINTX
STVAR=.>
*5352 /AFTER EXTENDED FUNCTIONS
XTAB, PUSHJ
EVAL-1
FENT
FADD I TRND /LET'S ROUND OFF
FEXT
INTEGER
CIA
TAD TABC
IAC
SMA
JMP BACK
DCA CNTRX
TAD SPACE
PRINTC
ISZ CNTRX
JMP .-3
BACK, CLA CLL
JMP I .+1
TASK
TRND, FLP5
SPACE, 240
*5774
MGETC, 0 /GETC FAKE FOR LOWER FIELD
GETC
CIF
JMP I MGETC
*6135
0240 /CHANGE '=' TO A SPACE
*6160
THISD, 0
CDF
TAD I THISLN
CDF 10
JMP I THISD
PT1D, 0
CDF
TAD I PT1
CDF 10
JMP I PT1D
*6311
XRAN, FENT /PSEUDO-RANDOM NUMBER
FGET RNDM /X(1)=(2^17+3)*X(0) MOD 2^16
FPUT FLOP
FEXT
TAD M16
DCA T1S
JMS I DOUBLE
ISZ T1S
JMP .-2
JMS I ADDR
JMS I DOUBLE
JMS I ADDR
FINT
FPUT RNDM
FEXT
DCA FLAC
CLA CLL CMA RAR /=3777
AND FLAC+1
DCA FLAC+1 /BE POSITIVE IT'S POSITIVE
JMP I EFUN3I
M16, -16
ADDR, DUBLAD
RNDM=.
T1S, 0
4421
3040
0001
XRTD, 0
CDF
TAD I XRT
CDF 10
JMP I XRTD
AXIND, 0
CDF
DCA I AXIN
CDF 10
JMP I AXIND
TDUMPX, CDF
DCA I .+3
CDF 10
JMP I .+2
PC0+4
3063
TELPCH, DCA TELSW /SETUP TO PRINTOUT
JMP I .+1
RECOVR+1
*6545
FLTONE /MOVED DOWN ONE
*7003
214 /^L IS IGNORED IN AN 'ASK' COMMAND
/THIS IS THE "LIBRARY HEAD"
*7503
LIB, SPNOR /IGNORE SPACES
TAD TELSW /WAIT FOR OUTPUT TO FINISH
SZA CLA /(DECTAPE SYSTEMS REALLY NEED THIS!)
JMP .-2
IOF
CIF CDF /CALL LOWER FIELD
JMP I (LOWLIB
TAD (JMP I GOSWITCH+1 /RETURN TO APPROPIATE ROUTINE
TAD GOSWITCH
DCA GOSWITCH
GOSWITCH, JMP I .+1
PROC
START
LGOSUB
GOTO+1
FIN, DCA FLAC+2 /SINGLE CHARACTER INPUT FUNCTION
DCA FLAC+3 /CLEAR FLAC
TAD SORTCN /SAVE SORTCN IN CASE OF RUBOUT OR LF
DCA PGETLN
READC /READ A CHAR
TAD CHAR /FLOAT IT
DCA FLAC+1
TAD PGETLN /RESTORE SORTCN
DCA SORTCN
TAD P13
DCA FLAC
JMP I EFUN3I
FOUT, INTEGER /SINGLE CHARACTER OUTPUT FUNCTION
SNA
TAD P4000 /IN CASE IT'S ZERO
PRINTC
JMP I EFUN3I
CPRNT, 0 /CROSS FIELD FAKES!
PRINTC
CIF CDF
JMP I CPRNT
PGETLN, 0
GETLN
CIF CDF
JMP I PGETLN
FRAN, TAD (XRAN /RANDOM RANDOM NUMBERS
DCA I (400 /(FIRST CALL ONLY)
TAD RISZ /INITIALIZE 'RNDM'
DCA I (RNDM+1
JMP I (XRAN
XSGN, TAD FLAC+1 /REAL SIGNUM FUNCTION!!
SNA CLA
JMP I EFUN3I
PUSHF
FLTONE
POPF
FLAC
JMP XABS
PAGE