File: EFOS8L.PA of Tape: Sources/Focal/s4
(Source file text)
EJECT FOS8 I-O,FILES,CD-ETOS
FIELD 0
*1 /INTERRUPT SERVICE ROUTINE
JMP I .+1
INTRPT
DRONE=JMS I .
XIDLE
0
0 /FOR OD
0
*7
TSORTJ=JMS I .
SORTB
/AUTO-INDEX REGISTERS
AUTO1, 0 /GENERAL
AUTO2, 0 /COMPARE
AUTO3, 0 /COMPARE
INFLG, 0 /FILE INPUT:1,TTY:0,EOF:-1
INECH, 0 /INPUT ECHO:0,NO ECHO:-1
OUTFLG, 0 /FILE OUTPUT:1,TTY:0
OUTECH, 0 /OUTPUT ECHO:0,NO ECHO:-1
ERRCOD, 0
XCNTR, 0 /GENERAL COUNTER-
USR, 7700 /POINTER TO MONITOR (200 IF USR IN)
NAMLOC, ZBLOCK 3 /USED BY NAME
EXTENS, 0 /"FC", "FD", OR "FN"
NEWDEV, ZBLOCK 2 /USED BY NAME
TEM7, 0
ATEM, 0 /KEEP HERE : TPOPF NEWDEV
/DEFINE LOWER FIELD INSTRUCTIONS . . .
TINTEG=JMS I .
MINTEG
ERROR1=JMS I .
ERROL
TPOPA=JMS I .
MPOPA
TPUSHA=JMS I .
MPUSHA
TPUSHF=JMS I .
MPUSHF
TPOPF=JMS I .
MPOPF
TPUSHJ=JMS I .
MPUSHJ
TPOPJ=JMP I .
MPOPJ
ECHFLG, 0 /-1:NO ECHO
OPNFLG, 0 /OOPEN:-1;OCLOSE:0
IPNFLG, 0 /IOPEN:-1;EOF:0
OUTINH, 0 /NOT LAST BLK:0,LAST BLK:1
DEVHLD, 0 /OOPEN:DEV. NO. FOR CLOSE
FILEN, 0 /SPECIFIED FILE LENGTH []
FLNGTH, 0 /SET BY OPEN
STBLK, 0 /SET BY OPEN
DEVNO, 0 /SET BY HANDAD
LIBFIL, 0 /START BLK OF SAVED PROG;UNSAVED:0
LIBBLK, 0 /FOR DEVICE NAME
0
7200 /LOAD POINT
0 /FOR DEVICE #
LIBHND, 0 /HANDLER ENTRY
INBLK, 0
0
6600
0
INHND, 0
OUTBLK, 0
0
6200
0
OUTHND, 0
DERR, ERROR1 /DEVICE ERROR
64 /DE=DEV.ERR.
CHARL, 0
DCHAR, CHAR
CLNGTH, 0 /SET BY COMMON
COMFLG, 0 /1:WRITE;0:READ
SETBLK, 0 /THE RELATIVE BLOCK IN USE
THSBLK, 0 /ASKED FOR BLOCK
COWRIT, 1 /WRITE:1 READ:0
CHRCNT, -110
TELSW, 0
GOSWIT, 0
CTCINH, 0
INBUF, 0
PAGE
/OS/8 FILE ROUTINES
/CHAIN WITH AC=0 FOR PROCEED,1:START,2:GOSUB,3:GOTO,4:WRITE
MAINTR, CLA IAC /MAIN ENTRY-POINT
CHENTR, JMP I STRTSW /CHAIN ENTRY-POINT - -
TPUSHF /OR 'DCA STRTSW' AFTER INIT
MONHUK /INSTALL CTRL.C HOOK
TPOPF
7600
DCA TELSW /ALLOW TTY: TO START
CLA CMA
TAD STRTSW
SNA CLA
JMP I AAMESG /GO START DIRECT MODE
TAD STRTSW
CONTIN, DCA GOSWIT /GO BACK TO 'PROC':MAIN FLOW
JMP I [EXITOS
AAMESG, RESTRT
STRTSW, SETUP
OCLOSE, 0 /CLOSE THE OPEN OUTPUT FILE
TAD OPNFLG
SNA CLA /DON'T BOTHER IF IT ISN'T OPEN
JMP I OCLOSE
DCA OPNFLG /MUST BE HERE!
DCA OUTINH /WE CAN CLOSE THE LAST BLK
TAD [232 /WRITE '^Z'
JMS I [NOCHAR
TAD OPTR1 /PAD BUFFER WITH ZEROS
TAD (-OUTBUF /(AND WRITE IT OUT)
SZA CLA
JMP .-4
JMS I [GTMON /TURNS ON 'CTCINH'
TAD DEVHLD /SAVED DEVICE #
CIF 10
JMS I USR
4 /CLOSE
ONMTMP /POINTER TO SAVED NAME
BLKCNT, 0 /FILE LENGTH; ZEROED BY OOPEN
JMP DERR /HUH?
DCA OUTFLG /RESTORE TELETYPE OUTPUT ROUTINE
JMP I OCLOSE /DO WHATEVER ELSE NEEDS TO BE DONE
/OS/8 3/2 BUFFERED CHARACTER OUTPUT
NOCHAR, 0
AND (377 /MASK OUT GARBAGE
ISZ O3 /WHICH CHAR OF THREE?;-3 INITIALLY
JMP O2 /STRAIGHT PACKING
JMS RT /HALF WORD PACKING - PACK FIRST HALF
TAD ATEM /GET SAVED ARG
JMS RT /PACK SECOND HALF
CLA CLL CMA RTL /RESET 3-WAY SWITCH
DCA O3
ISZ OCHCT /BUFFER CAN ONLY BE FILLED
JMP I NOCHAR / WITH 3RD CHAR OF 3
JMS I [PUTDEV /TELL USR THIS HANDLER'S IN
OUTHND-1/POINTER TO DEVICE # AND ENTRY
TAD OUTINH /LAST BLOCK?
SZA CLA
JMP OOVER /YES, CLOSE IN EXTREMIS
ISZ CTCINH
JMS I OUTHND /WRITE ONE BLOCK BUFFER
4200
OUTBUF
OBLK, 0 /SET BY OOPEN
JMP DERR /DEVICE ERROR
JMS I [DISMIS /ONLY FOR TURNING OFF 'CTCINH'
ISZ OBLK /BUMP OUTPUT BLOCK
ISZ BLKCNT /AND COUNT OF BLOCKS SO FAR
CLA CLL
TAD OLNGTH /-MAXIMUM ALLOWABLE LENGTH+1
TAD BLKCNT /LENGTH SO FAR
SZL CLA /HAS HE GONE TOO FAR?
ISZ OUTINH /YES;MUST CLOSE BEFORE NEXT END
TAD OUTINH /ONE WORD LESS IN NEXT BLOCK
JMS OSETUP /RESET POINTERS FOR NEXT BUFFER
JMP I NOCHAR
O2, DCA I OPTR1 /NORMAL PACKING IS EASY!
ISZ OPTR1 /BUMP POINTER
JMP I NOCHAR
O3=. /WHY NOT?
RT, 0 /HALF-WORD PACK ROUTINE
CLL RTL
RTL
DCA ATEM /SAVE FOR SECOND HALF
TAD ATEM
AND [7400
TAD I OPTR2 /ADD IN CHARACTER IN RIGHT HALF
DCA I OPTR2 /PACK IT
ISZ OPTR2 /BUMP POINTER AGAIN
JMP I RT
OOVER, CLA CMA /THERE IS JUST ROOM FOR CTRL.Z
DCA OCHCT /LET CLOSE WRITE IT FROM ERROR
ERROR1
345 /OF=OUTPUT FULL
OSETUP, 0 /RESET ALL THE POINTERS
TAD [7600 /THIS IS CHANGED TO -177
DCA OCHCT / FOR LAST BLOCK
TAD OBLK-1
DCA OPTR1
TAD OBLK-1
DCA OPTR2
CLA CLL CMA RTL
DCA O3
JMP I OSETUP
OPTR1, 0
OPTR2, 0
OLNGTH, 0 /SET BY OOPEN
OCHCT, 0
COMPO, SAVER
FETCHER
CHAINER
BUMP
GOSUB
RETOUR
LEXIT
LOADER
FOCTXT, FILENAME FOCAL.TM /USED BY GOSUB
TTYTXT, DEVICE TTY
NAMGO, NAMEVL
PERD
ECHCHK
CHANEL
RESTOR
NAMLEN
NAMEC
MONHUK, CIF CDF L
5602 /'JMP I .+1'
MEXIT-1
PAGE
OOPEN, TAD (ORST /RESTORE ADRESS
JMS I [OPEN /CALL USR, HANDLER; ENTER FILE
YINT, OUTBLK-1/OUTPUT HANDLER BLOCK
3 /MONITOR 'ENTER' CODE
JMP TTYOUT /'OPEN OUTPUT TTY:'
JMP I (OCLCHK /SEE IF FILE OPEN
TPUSHF /SAVE NAME AND EXTENSION
NAMLOC
TPOPF
ONMTMP
TAD STBLK /STARTING BLOCK
DCA I (OBLK /IN NOCHAR
TAD FLNGTH /-MAXIMUM ALLOWABLE LENGTH
CLL IAC /CHECK IF ONE BL0CK LONG
DCA I (OLNGTH /IN NOCHAR (+1)
RAL /IF ONE LONG, LINK SET
DCA OUTINH /SEND OUT ^Z AT END OF FIRST BUFF
TAD OUTINH /ADJUST CHAR.CNT.
JMS I (OSETUP /SET UP PACKING POINTERS
CLA CLL CMA /THERE'S A FILE OPEN!
DCA OPNFLG
TAD DEVNO /SAVE FOR CLOSE
DCA DEVHLD
DCA I (BLKCNT /DITTO
ORST, TAD OPNFLG /ENTRY FOR 'OPEN RESTORE OUTPUT'
SNA CLA /IF 'OPEN OUTPUT', FLAG IS SET
ERROR1 /NO OUTPUT FILE TO RESTORE
325 /NF=NO FILE
CLA IAC /SET OUTPUT TO NOCHAR
TTYOUT, DCA OUTFLG /SET OUTPUT TO TTY (INTERRUPT)
TAD ECHFLG
DCA OUTECH /SET OUTPUT ECHO
JMP I [CONTIN /FINISH THE LINE
MINTEG, 0 /INTEGER FAKE
CIF CDF P
JMS I [XINTEG
JMP I MINTEG
ICHAR, 0 /GET A CHARACTER FROM A FILE
CLA CLL CML /MAKE SURE-SET LINK FOR KEY BIT
ISZ INCHT /NEED ANOTHER BUFFER?;-1 INITIALLY
JMP I RDPTR /NO, UNPACK THE CHARACTER
ISZ CTCINH
JMS I INHND /YES, GO GET IT
0200
INBUFF
IBLK, 0 /SET BY IOPEN
SMA CLA /ONLY BOTHER WITH FATAL ERRORS
SKP CLA /REFERENCED!
JMP DERR /WE'VE GOT ONE
JMS I [DISMIS
ISZ IBLK /BUMP TO NEXT BLOCK
TAD IBLK-1 /AND RESTORE POINTERS
DCA IPNTR
CLA CMA /-1 FOR FIRST TIME ROUND
TAD [7200
DCA INCHT
ICHARL, JMS RDPTR /FIRST TIME AND KEY IN POS. 0
RTL
RTL
SPA /KEY IN POS. 0?
JMP ICHARL /YES;READ IN COMBINED WORD
DCA ITEMP /SAVE HALF-WORD AND KEY:POS.8-4-0
TAD I IPNTR /GET FULL WORD
JMS RDPTR
TAD I IPNTR /GET HALF WORD
ISZ IPNTR
AND [7400 /ISOLATE
CLL RAL /MAGIC STEP
TAD ITEMP /ADD IN OTHER HALF? AND KEY
JMP ICHARL+1 /GO SHIFT MORE AND TEST IF FULL
RDPTR, 0 /THIS IS A COROUTINE
AND [177 /ISN'T THAT AMAZING?
SNA /IGNORE NULLS AND PARITY
JMP ICHAR+1
TAD [-32 /END OF FILE? (^Z)
SZA
JMP .+4 /NO
DCA IPNFLG /YES, CLEAR OPEN FILE FLAG
CLA CMA /PREVENT AN
DCA INFLG /'ATTEMPT-TO-READ-PAST-EOF'!
TAD [232 /PASS ^Z TO PROGRAM FOR TESTING
JMP I ICHAR
ITEMP, 0
IPNTR, 0
INCHT, 0 /SET TO -1 BY IOPEN
ONMTMP, ZBLOCK 4
FILEST, TAD (604 /HERE'S WHERE FILES START!
DCA EXTENSION /SET '.FD' ASSUMED EXTENSION
CDF P
TPUSHJ
TERMER
MQA
CIF P
TSORTJ /GO DO COMMAND
FILIST-1
FILGO-FILIST
ERROR1 /OOPS - BAD 'O' COMMAND
36 /BO=BAD OPEN COMMAND
FILGO, IOPEN
OOPEN
OCLOSR
ARRAY
CCLOSR
FILIST, "I /INPUT
"O /OUTPUT
"C /CLOSE
"A /ARRAY=COMMON
"T /TERMINATE(COMMON)
SAVER, JMS I [NAME /GET NAME FOR SAVE
JMS I (SAVPR /DO IT
EXITOS, JMS I [DISMIS /NORMAL RETURN FOR OS/8 COMMANDS
TAD GOSWIT
CDF CIF 10
JMP I .+1
LIBRET
PAGE
IOPEN, TAD (IRST /RESTORE ADRESS
JMS I [OPEN /CALL GENERAL-PURPOSE SUBROUTINE
INBLK-1
2 /MONITOR 'LOOKUP'
JMP TTYIN /'OPEN INPUT TTY:'
JMP IRST+2 /WHOOPS - FILE NOT FOUND
TAD STBLK /SET POINTERS AND OTHER CRAP
DCA I (IBLK /IN ICHAR
CLA CLL CMA
DCA IPNFLG
CLA CLL CMA
DCA I (INCHT /IN ICHAR
IRST, TAD IPNFLG /'OPEN RESTORE INPUT' COMES HERE
SNA CLA /FLAG IS SET ALREADY IF 'OPEN INPUT'
ERROR1 /NO INPUT FILE TO RESTORE
330 /NI=NO INPUT FILE
CLA IAC /SET I/O POINTERS
TTYIN, DCA INFLG
TAD ECHFLG /AND ECHO MODE
DCA INECH
JMP I [CONTIN
FLD0=CLA CLL /PDL SATELLITES;FIELD 0
MPOPA, 0
MQL
FLD0
CIF T
JMS I .+1
ZPOPA
MPUSHA, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHA
MPUSHF, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHF
MPOPF, 0
MQL
FLD0
CIF T
JMS I .+1
ZPOPF
MPUSHJ, 0
MQL
FLD0
CIF T
JMS I .+1
ZPUSHJ
MPOPJ, CIF CDF T
JMP I .+1
ZPOPJ
/THE FOLLOWING CODE WILL RECOGNIZE FOR EX.L C DATA(X)
/AND LOOK FOR DATA99 IF X=99
NAMEVL, TAD I (NAMECT /CHECK NUMBER OF CHARS
TAD (-4 /AT MOST 4
SMA SZA CLA
EVLERR, ERROR1
135 /FN=FILE NAME ERROR
DCA ATEM /CLEAR TEN COUNTER
CDF P /GO TO EVAL
TPUSHJ /'('READY,DUMP ')'
EVAL-1
TINTEG
TAD (-144 /.LT. 100 (DEC)
SZL /NOW WE HAVE X-100
JMP EVLERR
TAD [12 /X-100+ATEM*10
ISZ ATEM
SPA
JMP .-3
MQL /OVERFLOW IS LOW ORDER
TAD ATEM /ATEM IS 10 - HIGH ORDER
CIA /HIGH ORDER - 10
TAD [12 /HIGH ORDER
TAD [60 /6-BIT ASCII
JMS I (NAMSTO
MQA /LOW ORDER AGAIN
TAD [60
JMS I (NAMSTO
JMP I (NAMEC
XSGN, CDF P /REAL SIGNUM FUNCTION
TAD I (HORD
SNA CLA
TPOPJ /FSGN(0)=0
TPUSHF /DF P!
FLTONE
CDF P
TPOPF
FLAC
XABS, CDF V /TAKE ABS OF FLAC
TAD I FLARGH
SMA CLA
TPOPJ
CDF P
TPUSHJ
MMINSK
TPOPJ
FLARGH, FLARG+1
DCWBM, 7757
GETDEV, 0 /GET DEVICE TYPE FROM MONITOR TABLE
TAD DCWBM /DCB-1
TAD DEVNO
DCA IOWAIT
CDF P
TAD I IOWAIT
CDF L
JMP I GETDEV
IOWAIT, 0
CDF L
DRONE
TAD TELSW
SZA CLA
JMP .-3
JMP I IOWAIT
CNMTMP, ZBLOCK 4
PAGE
/LIBRARY COMMAND PROCESSOR
/****** STORAGE ALLOCATION MAP ******
/***** *****
/* 200 START,OCLOSE,NOCHAR,OSETUP
/* 400 OOPEN,ICHAR,FILEST,EXITOS
/* 600 IOPEN,POP,NAMEVL,XABS,XSGN,IOWAIT
/* 1000 NAME,GTMON,DISMISS
/* 1200 HANDAD,COMPARE,LOADER
/* 1400 SAVPR,ENDLOD
/* 1600 LOWLIB,LOADS,GOSUB,RETOUR
/* 2000 OPEN,BUMP,XIN,XIDLE,INTERRUPT
/* 2200 XCOM,CORITE,CCLOSE
/* 2400 COHNDL,ARRAY,LOWOUT,LEXIT
/* 2600 INTRPT,XOUT,ERROL
/* 3000 ERROL,LOWIN,TERMNL
COMBUF=3200
OUTBUF=5200 /ALSO INIT
INBUFF=5600
/* 6200 OUTPUT HANDLER
/* 6600 INPUT HANDLER
/* 7200 LIBRARY AND COMMON HANDLER
/***** *****
/************************************
/READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV'
NAME, 0
DCA NAMRET /SETUP RESTORE RETURN
CLA CLL CMA
DCA ECHFLG /INIT. ECHO FLAG
DCA FILEN /SET TO LARGEST EMPTY
JMS I [DISMIS /'GETC' WON'T WITH THE USR IN CORE
TAD [5723 /CODE FOR 'DSK:'
DCA NEWDEV /(DEFAULT DEVICE)
DCA NEWDEV+1
DCA NAMLOC /CLEAR NAME AREA
DCA NAMLOC+1 /(DON'T CLEAR ASSUMED EXTENSION)
DCA NAMLOC+2
TAD [NAMLOC /INITIALIZE POINTERS
DCA NMBASE
CLA CMA
DCA PERDSW
DCA NAMECT
NAMEC, CDF P
TPUSHJ
MGETC
CIF P
TSORTJ
NAMLST-1
NAMGO-NAMLST
JMS DECODE /MUST BE A-Z, 0-9
JMP NAMOUT /NO!, NOR IN NAMLST:END OF NAME
SZL /RESTORE CHARACTER
TAD [57
IAC /6-BIT ASCII
JMS NAMSTO
JMP NAMEC /CONTINUE LOOP
NAMSTO, 0
DCA DECODE /TEMPORARY STORAGE
TAD NAMECT /NO MORE THAN 6 CHARACTERS/NAME
TAD [-6
US7700, SMA CLA
JMP NAMEC
TAD NAMECT /BUILD POINTER TO CHARACTER POS
CLL RAR
TAD NMBASE
DCA TT
TAD DECODE /LEFT OR RIGHT HALF?
SNL
BSW /LEFT, SHIFT OVER
TAD I TT /ADD IN OTHER HALF
DCA I TT
ISZ NAMECT /BUMP COUNT
JMP I NAMSTO
PERD, TAD NAMLOC /FOUND A PERIOD IN STRING
SZA CLA
ISZ PERDSW
ERROR1 /DOUBLE PERIODS OR NO FILE NAME
35 /BN=BAD NAME IN FILES
DCA EXTENSION /CLEAR EXTENSION
ISZ NMBASE /FAKE OUT POINTERS
TAD [4
JMP NAMEC-1
CHANEL, TAD NAMLOC /MOVE TO DEVICE AREA
DCA NEWDEV
TAD NAMLOC+1
JMP NAME+10 /GET FILENAME
RESTOR, TAD NAMRET /COMES HERE ON '"'
SZA
DCA NAME /CHANGE RETURN IF NON. 0
JMP NAMEC
ECHCHK, CDF P /MOVE PAST COMMA
TPUSHJ
MGETC
CDF P
TPUSHJ /MOVE TO END KEEP FIRST
TERMER
MQA
TAD [-"E /MUST BE 'E'
NAMOUT, SNA CLA /DECODE 'NO' EXIT IS NON-ZERO
DCA ECHFLG /SET ECHO FLAG
JMP I NAME
DECODE, 0 /CHECK FOR A-Z, 0-9
TAD CHARL /IF YES ISZ RETURN
TAD [-"9-1
CLL
TAD ["9+1-"0
SZL
JMP DCDYES /NUMBER;CHAR-260;L=1
TAD ["0-"Z-1
CLL CML
TAD ["Z-"A+1
SNL
DCDYES, ISZ DECODE /ALPHA;CHAR-301;L=0
JMP I DECODE
NMBASE, 0
PERDSW, 0
NAMECT, 0
TT, 0
NAMRET, 0
NAMLEN, CDF P /INDICATE OPT. FILE LENGHT
TPUSHJ
EVAL-1 /GETS NUMBER IN []
TINTEG
CLL RTL
RTL
AND [7760
DCA FILEN
JMP NAMEC
GTMON, 0 /LOCK THE USR IN CORE
/(NOP IF ALREADY IN CORE)
ISZ CTCINH /WE MAY CALL OS/8
CDF L
CIF P
JMS I USR
10
TAD [200 /SET POINTER FOR LATER CALLS
DCA USR
JMP I GTMON
DISMIS, 0 /IF THE USR IS IN, KICK IT OUT
CLA CLL
CDF L /MAKE SURE
TAD USR /CHECK POINTER TO FIND OUT
SPA CLA
JMP DISMEX
CIF P
JMS I USR
11
TAD US7700 /RESET POINTER
DCA USR
DISMEX, TAD CTCINH /CHECK IF 'ION' ALLOWED
SZA CLA
NOP/ION
DCA CTCINH /BACK IN FOCAL
JMP I DISMIS
PAGE
/HANDAD CALL: HANDAD
/SLOT
/SETS DEVNO; DEVICE NO. IN SLOT; ENTRYPOINT IN SLOT
HANDAD, 0 /LOADS HANDLER INTO PROPER SLOT
TAD I HANDAD /WHICH SLOT?
ISZ HANDAD
DCA SLOT
JMS COMPARE /IF THE HANDLER HAS THE SAME NAME,
-2 /DON'T LOAD IT AGAIN
SLOT, 0
NEWDEV-1
JMP NOTEQ /DIFFERENT NAMES, LOAD NEW HANDLER
ISZ AUTO2
TAD I AUTO2 /(SET BY 'COMPARE')
DCA DEVNO /MOVE DEVICE# (FOR SAVE AND CLOSE)
TAD AUTO2 /POINTS TO DEVICE #
DCA .+2
JMS I [PUTDEV /SO USR KNOWS IT'S IN CORE
0
JMP I HANDAD
NOTEQ, ISZ SLOT /BUMP POINTER TO SAVE NAME
TAD NEWDEV /MOVE NEW DEVICE NAME TO TABLE
DCA I SLOT
ISZ SLOT
TAD NEWDEV+1
DCA I SLOT
ISZ SLOT
JMS I [GTMON
RETRY, TAD NEWDEV /MOVE DEVICE NAME FOR MONITOR CALL
DCA DEVC
TAD NEWDEV+1
DCA DEVC+1
TAD I SLOT /MOVE LOAD POINT
IAC /TWO PAGE HANDLER!
DCA DLOAD
CIF P
JMS I USR /CALL MONITOR (ALREADY IN CORE)
1 /FETCH BY NAME
DEVC, 0 /NAME
0 /RETURNS DEVICE NO.
DLOAD, 0 /RETURNS ENTRY POINT
ERROR1 /DEVICE NOT AVAILABLE
323 /ND=NO DEVICE
CLL
TAD DLOAD /ENTRY POINT FOR HANDLER
TAD [200 /IF THIS HANDLER IS IN PAGE 7600,
SZL CLA /DON'T CHECK FOR LEGALITY
JMP HANDOK /SYSTEM HANDLER
TAD DLOAD /IF THE HANDLER WAS NOT LOADED
AND [7600 /INTO THE PROPER PAGE, RELOAD IT
CLL CIA
TAD I SLOT /PROPER LOADING ADDRESS
SNA CLA
JMP HANDOK /EVERYTHING'S ALL RIGHT
DCA DLOAD /CLEAR ENTRY POINT
JMS I [PUTDEV /TELL USR THE HANDLER IS NOT
DEVC+1 /IN CORE ANYMORE
JMP RETRY /LOAD IT THIS TIME
HANDOK, ISZ SLOT /BUMP POINTER TO DEVICE #
TAD DEVC+1 /SAVE IT
DCA I SLOT
ISZ SLOT /MOVE TO ENTRY POINT
TAD DLOAD /SAVE ENTRY
DCA I SLOT
TAD DEVC+1 /GET DEVICE #
DCA DEVNO /SAVE IT AND EXIT
JMP I HANDAD
COMPARE,0 /COMPARE TWO BLOCKS
TAD I COMPARE /CALLING SEQUENCE:
ISZ COMPARE /JMS COMPARE
DCA XCNTR / -# OF WORDS TO CHECK
TAD I COMPARE / FIRST-1
ISZ COMPARE / SECOND-1
DCA AUTO2 /RETURN IF NO MATCH
TAD I COMPARE /RETURN IF MATCH
ISZ COMPARE
DCA AUTO3
AGAIN, TAD I AUTO2 /COMPARE TWO WORDS
CIA
TAD I AUTO3
SZA CLA
JMP I COMPARE /NO MATCH
ISZ XCNTR /FINISHED?
JMP AGAIN /NO, CHECK NEXT TWO
ISZ COMPARE /YES, BUMP RETURN POINTER
JMP I COMPARE
NAMLST, "( /SUBSCRIPTED FILE NAMES
". /EXTENSION
", /ECHO
": /DEVICE
"" /RESTORE OLD IN/OUT
"[ /FILE LENGHT SPEC.
" /SPACE: IGNORE
/THIS IS FOR CHAINING TO ANOTHER PROGRAM
LOADER, JMS I [OCHK /DON'T FORGET TO CLOSE THE FILES
JMS I [NAME /OR FOR OVERLAYING FOCAL ITSELF
TAD [2326 /EXTENSION "SV" IS FORCED ON
DCA EXTENSION /IT HAS TO BE A SAVE FILE:CHAIN
JMS I [IOWAIT
ISZ CTCINH /TURN ON INT. IF COMING BACK
TAD [NAMLOC /POINTER TO NAME
DCA LOADUS+2
TAD [2
DCA LOADUS+1
IAC /CHAIN EXPECTS IT TO BE ON SYS:
CIF P
LOADUS, JMS I USR
2 /LOOKUP RETURNS FILE START IN ARG2
NAMLOC
0
ERROR1 /USR DID NOT FIND IT
47 /CH=CHAINING ERROR
DCA LIBBLK /KILL LIB HANDLER;CHAIN DOES RESET
TAD (6 /OK! CHANGE USR FUNCTION TO CHAIN
DCA LOADUS+1
JMP LOADUS-1 /BY-BY!! MIGHT SEE YOU AGAIN
COMLIST,"S /SAVE
"C /CALL
"R /RUN
"D /DELETE
"G /GOSUB
233 /'LIBRARY R(ESCAPE)'
"E /EXIT
"L /LOAD; CHAIN A PROGRAM
OCLOSR, JMS I [OCLOSE /CLOSE OUTPUT FILE
JMP I [CONTIN
PAGE
SAVPR, 0 /CALLED BY 'SAVER' AND 'GOSUB'
TAD [NAMLOC /POINTER TO NAME
DCA SAVEPT
CDF P
TAD I (BUFR
DCA BLOCK /SAVE TEMP. PROGRAM LENGTH
TAD I (7666 /GET SYSTEM DATE
SNA /IF BOOTED THEN 1977
CMA
AND [7
TAD (6760 /'70'
DCA SAVBLK
TAD I (7666 /AGAIN FOR MONTHS
AND [7400
BSW
CLL RAR
TAD (MONAME /ADRESS OF NULL MONTH NAME
DCA RECORD
CDF T
TAD [LINE0+2
DCA AUTO1 /SET AUTO-INDEX FOR TRNSFR.
TAD NAMLOC
DCA I AUTO1
TAD NAMLOC+1
DCA I AUTO1 /TRANSFER NAME
TAD NAMLOC+2
DCA I AUTO1
TAD EXTENS
BSW
AND [77
TAD (5600
DCA I AUTO1 /TRANSFER .F
TAD EXTENS
AND [77
BSW
DCA I AUTO1 /REST OF EXTENSION: C@
TAD I RECORD /GET MONTH NAME
DCA I AUTO1 /SAVE
ISZ RECORD
TAD I RECORD /SECOND HALF+ "-"
DCA I AUTO1
TAD SAVBLK
DCA I AUTO1 /SAVE YEAR
TAD BLOCK
IFNDEF KEY<
DCA I (LINE0-1 /SAVE PROGRAM LENGTH
>
IFDEF KEY<
CLA CLL
>
JMS I [GTMON /GET USR;RESETS DF
JMS I [OCHK /CLOSE OUTPUT FILE, AVOID TROUBLE
JMS I [HANDAD /AND GET HANDLER
LIBBLK-1
TAD BLOCK
AND [7600 /MASK OFF
CLL RAR /CONVERT TO PAGES
DCA BLOCK /FOR HANDLER
TAD BLOCK /ROUND UP TO BLOCKS
TAD [100
AND [7600
CLL RTR
RAR
DCA RECORD /FOR MONITOR 'ENTER':BITS 0-7
TAD RECORD /GET DESIRED LENGTH
TAD DEVNO /(SET BY 'HANDAD')
CIF P
JMS I USR /ENTER OUTPUT FILE
3
SAVEPT, NAMLOC
0
ERROR1 /NO ROOM ON DEVICE
65 /DF=DEVICE FULL
TAD RECORD /SHIFT FOR CLOSING LENGTH
CLL RTR
RTR
DCA SAVBLK
TAD DEVNO /CLOSE THE FILE BEFORE WE WRITE IT!
CIF 10 /(SURE, IT'S CHEATING, BUT
JMS I USR /IT SAVES TIME!)
4 /CLOSE
NAMLOC
SAVBLK, 0 /NO. OF BLOCKS
JMP DERR /IMPOSSIBLE ERROR!
TAD SAVBLK /SAVE THIS CRAP TO REMEMBER
CIA /WHERE THIS PROGRAM IS
DCA LIBLEN /IN CASE WE WANT TO GOSUB
TAD SAVEPT
DCA LIBFIL
TAD NEWDEV
DCA LIBDEV
TAD NEWDEV+1
DCA LIBDEV+1
TAD SAVEPT /MOVE STARTING BLOCK FOR WRITE
DCA POINT4
TAD (4021 /GET FUNCTION WORD
TAD BLOCK /HOW MUCH TO WRITE
DCA BLLL
JMS I LIBHND
BLLL, 0 /WRITE (BLOCK) BLOCKS FROM FIELD 2
200 /FROM 200 UP
POINT4, 0
JMP DERR /GO COMPLAIN ABOUT DEVICE
JMP I SAVPR
LIBLEN, 0 /SAVED LENGTH
LIBDEV, ZBLOCK 2
RECORD, 0
BLOCK, 0
ENDLOD, TAD NEWDEV /SAVE THIS STUFF SO WE
DCA LIBDEV /KNOW WHERE WE ARE
TAD NEWDEV+1
DCA LIBDEV+1
TAD STBLK
DCA LIBFIL
TAD FLNGTH
DCA LIBLEN
JMP I (FILSEC
RESMON, 4207 /'JMS SHNDLR'
5000 /WRITE 10 PAGES FIELD 0
0000 /FROM ADRESS 0
0033 /IN BLOCK 33
PAGE
/ACTUAL LIBRARY PROCESSOR
/STARTING WITH COMMAND DECODE:
LOWLIB, DCA GOSWIT
TAD [603
DCA EXTENSION
CDF P
TPUSHJ
TERMER
MQA
CIF P
TSORTJ /AND BRANCH TO APPROPRIATE ROUTINE
COMLIST-1
COMPO-COMLIST
ERROR1 /SORRY, CHARLIE!
270 /LI=LIBRARY COMMAND ERROR
/LOOKUP AND LOAD ROUTINES
CHAINER,ISZ GOSWIT /THESE ALL DO THE SAME THING
GOSUB1, ISZ GOSWIT /AND THEN GO TO DIFFERENT PLACES
FETCHER,ISZ GOSWIT
JMS I [OPEN /CALL THE HANDLER AND LOOKUP FILE
LIBBLK-1
2
JMP .+6 /TTY: NOT A DIRECTORY DEVICE
ERROR1
337 /NP=NO PROGRAM FOUND
JMS I [DISMISS
JMS I (GETDEV /GET DEVICE TYPE
SMA CLA
ERROR1 /NOT A DIRECTORY DEVICE
63 /DD=NOT A DIR. DEV.
CDF P
TPUSHJ
PGETLN /SOME COMMANDS HAVE LINE NUMBERS
LOADGO, JMS I [DISMISS /ONLY USED BY 'RETOUR'
TAD STBLK /BLOCK TO READ FROM
DCA POINT6
CDF T
TAD I (PDLXR /BOTTOM OF PDL
CDF L
TAD [-20
AND [7600 /PAGES
BSW
CLL RTR /BLOCKS
TAD FLNGTH /NOW COMPARE WITH LENGTH OF FILE
SPA CLA
ERROR1 /PROGRAM TOO LONG
373 /PL=PROGRAM LENGTH ERROR
CLA CLL CMA RAL /(=-2)
TAD GOSWIT /IS THIS A GOSUB?
SZA CLA
JMP NOGOSB /NO, SKIP THIS GARBAGE
TAD CHARL /YES, SAVE PROGRAM NAME, ETC.
TPUSHA /PDL NOW CONTAINS:
TAD [215 /CHAR,DEV,FILE LENGTH,START BLOCK
CDF P
DCA I DCHAR
CDF L
NOGOSB, TAD FLNGTH /COMPUTE FUNCTION WORD
CIA
BSW
CLL CML RAL /SET TO SEARCH FORWARD
TAD (20 /FIELD 2
DCA LENF1
ISZ CTCINH
JMS I LIBHND /GET THE PROGRAM
LENF1, 1221
200
POINT6, 0
JMP DERR
JMP I (ENDLOD
GOSUB, TAD LIBFIL /CHECK FOR CURRENT PROGRAM
SZA
JMP NOSAVE /NO NEED TO SAVE CORE
TPUSHF /MOVE 'FOCAL.TM' TO NAME AREA
FOCTXT
TPOPF
NAMLOC
TAD [5723 /DEVICE 'DSK' FOR SAVE
DCA NEWDEV
DCA NEWDEV+1
JMS I (SAVPR /SAVE FILE (LEAVE USR IN CORE)
TAD [603 /RESET EXTENSION TO 'FC'
DCA EXTENSION
TAD LIBFIL /STARTING BLOCK
NOSAVE, TPUSHA /'LIBFIL' STILL IN AC
TAD I (LIBLEN
TPUSHA
TPUSHF
LIBDEV
JMP GOSUB1
RETOUR, TPOPA /GET BACK ALL THE JUNK WE SAVED
CDF 10 /FOR THE LAST GOSUB
DCA I DCHAR /IN-LINE CHARACTER
CDF
TPOPF /DEVICE NAME
NEWDEV
TPOPA /FILE LENGTH
DCA FLNGTH
TPOPA /STARTING BLOCK
DCA STBLK
JMS I [HANDAD /GET THE HANDLER BACK
LIBBLK-1
JMP LOADGO /LOAD THE PROGRAM
FILSEC, CIF CDF T
TAD CODENU
TAD I (PC0+2
DCA POINT6
TAD I (PC0+2
SZA
JMP I POINT6
TAD I (LINE0-1
CDF P
DCA I (BUFR
CIF CDF L
IFNDEF KEY<
JMP I [EXITOS
CODENU, TEXT "WVDM"
>
IFDEF KEY<
SKP
CODENU, KEY
JMP I .+1
KEYER
>
PAGE
/MISCELLANEOUS GENERAL-PURPOSE ROUTINES
/THIS IS THE GENERAL OPEN SUBROUTINE
/CALLNG SEQUENCE:
/JMS I [OPEN
/HANDLER BLOCK
/MONITOR CALL CODE
/RETURN IF TTY: IS DEVICE
/ERROR RETURN
/NORMAL RETURN
/SETS STBLK, FLNGTH ON PAGE ZERO
OPEN, 0
JMS I [NAME /GET DEVICE AND FILENAME
JMS I [COMPARE /DEVICE 'TTY:' IS SPECIAL
-2
NEWDEV-1
TTYTXT-1
JMP OTHER /DEVICE OTHER THAN TTY
ISZ OPEN /INCREMENT TO PROPER RETURN
ISZ OPEN
JMP I OPEN
OTHER, TAD I OPEN /GET HANDLER BLOCK TO USE
DCA HND
ISZ OPEN
TAD [NAMLOC /POINTER TO NAME
DCA NAMPT
JMS I [GTMON
JMS I [HANDAD /GET THE HANDLER
HND, 0 /SET TO HANDLER BLOCK
TAD I OPEN /GET MONITOR CALL CODE (2 OR 3)
ISZ OPEN
DCA CALL
DCA LNGTH /FOR MONITOR KLUDGE
TAD DEVNO /DO THE CALL
TAD FILEN /ADD IN OPT. FILE LENGHT
CIF 10 /DEV # IN AC
JMS I USR /2: LOOKUP
CALL, 0 /3: ENTER
NAMPT, NAMLOC /NAME POINTER;RETURNS START BLOCK
LNGTH, 0 /RETURNS -FILE LENGTH IN BLOCKS
/TENTATIVE FOR ENTER
JMP OTHER-2 /CALLING ROUTINE HANDLES ERROR
TAD LNGTH /MOVE PARAMETERS TO PAGE ZERO
DCA FLNGTH
TAD NAMPT
DCA STBLK
JMP OTHER-3 /AND TAKE NORMAL RETURN
BUMP, JMS I [NAME /DELETE IS AN EASY ONE (THANK GOD!)
JMS I [GTMON
JMS I [HANDAD
LIBBLK-1
JMS I [OCHK /CLOSE ANY OPEN OUTPUT FILE
CIF 10 /DELETE THE FILE
TAD DEVNO
JMS I USR
4
NAMLOC
0
ERROR1
123 /FD=FILE DELETION ERROR
DCA LIBFIL /IF CURRENT PROGRAM DELETED
JMP I [EXITOS
OCLCHK, TAD OPNFLG
SNA CLA
ERROR1
344 /OE=OPEN OUTPUT ERROR
JMS I [OCLOSE
TAD (YINT
DCA OPEN
JMP OTHER
PUTDEV, 0 /TELL USR A HANDLER IS IN OR OUT
TAD I PUTDEV /GET POINTER TO DEV# AND ENTRY
DCA XIN
TAD I XIN /DEVICE#
ISZ XIN /BUMP POINTER TO ENTRY
TAD (7646 /MONITOR TABLE
DCA PUTTEM /POINTER TO 'HANDLER IN CORE' FLAG
TAD I XIN /FLAG IS HANDLER ENTRY
CDF P /TABLE IS IN FIELD ONE
DCA I PUTTEM
CDF L
ISZ PUTDEV
JMP I PUTDEV
XIN, 0 /VIA (INDEV)
DRONE
TAD INBUF
SPA SNA
JMP .-3
DCA PUTDEV
DCA INBUF
KCC /SET READER RUN
TAD PUTDEV
JMP I XIN
OCHK, 0 /IF ANY FILE EXISTS CLOSE IT
JMS I [CCLOSE
JMS I [OCLOSE
JMP I OCHK
KCC
MEXIT, JMS I [IOWAIT /BE SURE ^C CAN BE SENT
TAD (203
JMS I [TERMNL /TYPE ^C
LEXIT, TPUSHF /LIBRARY EXIT ROUTINE
RESMON /ALSO USED BY CTRL.C
TPOPF
7600 /RESTORE MONITOR CALL
JMS I [OCHK /CLOSE FILES
JMS I [DISMISS /BOOT USR OUT
JMS I [IOWAIT /WAIT FOR TTY;IOF
JMP I [7600 /LEAVE FOCAL
MORE, 0
CDF V
NOP /SKIP1
JMP MORE2 /VAR. FLD STILL ON
DCA I XNMBSG /CLEARS HORD VAR "#"
NOP /CLEAR1
MORE2, NOP /SKIP2
JMP MORE3
DCA I XEXCLA /VARIABLE "!"
NOP /CLEAR2
MORE3, NOP /SKIP3
JMP NOMORE
DCA I XQUOTS /VARIABLE """
NOP /CLEAR3
NOMORE, NOP /CLEAR ODD FLAGS
NOP
NOP
NOP
CDF L
JMP I MORE
XNMBSG, NMBSGN
XEXCLA, EXCLA
XQUOTS, QUOTS
PUTTEM, 0
PAGE
XCOM, TINTEG /COMMON FOR 4096 4-W. VARIABLES
DCA BLKTMP
TAD BLKTMP
AND [377 /ADRESS IN BUFFER
CLL RTL /*4 : 4-WORD
TAD I (COSTA /START OF BUFFER
TPUSHA
TAD BLKTMP
AND [7400 /:8 BUFFERS
BSW /OF 4 BLOCKS EACH
TPUSHA /STORE RECURSIVELY
TPUSHJ /PUT OR GET?
ARG
CLA CMA /GET
DCA GEPUSW /PUT
TPOPA /GET BLOCK #
TPUSHJ
COMEXT /GET BLOCK
ISZ GEPUSW
JMP COMPUT
TPOPA /NOW GET ADRESS
DCA GEPUSW
TPUSHF
GEPUSW, COMBUF
CDF P
TPOPF
FLAC
TPOPJ
COMPUT, TPOPA
DCA BLKTMP
CDF P
TPUSHF
FLAC
TPOPF
BLKTMP, COMBUF
IAC
DCA COWRIT
TPOPJ
ARG, TAD CHARL
TAD [-",
SZA CLA
TPOPJ
CDF P
TPUSHJ
EVAL-1
IAC
TPOPJ
COMEXT, DCA THSBLK /ASKED FOR BLOCK
TAD THSBLK
CIA
TAD SETBLK /IS IT ALLREADY HERE?
SNA CLA
TPOPJ /YES.EXIT
CLL CML IAC RAL /+3 SO THAT WE DON'T
TAD THSBLK / WRITE ON ANOTHER FILE
TAD CLNGTH /SET TO 0 BY CCLOSE
SMA CLA
ERROR1 /WE ARE ASKING FOR TO MUCH!
4 /AE=ARRAY EXCEEDING CORE LIMITS
JMS CORITE /WRITE OUT IF ANY MODIFICATIONS
TAD COMFLG / OR ZEROING
SNA CLA /IN OR OUT?
JMP COINPT
TAD COCNT /LARGEST SO FAR
CIA
TAD THSBLK
SPA CLA
JMP COINPT /THSBLK .LT. COCNT;ALREADY OUT
TAD COCNT
DCA SETBLK /SET TO WRITE AND CLEAR NEXT BUFF
JMP COMEXT+1
COINPT, CLA CLL /LNK=0 FOR READ
TAD THSBLK /READ ASKED FOR BLOCK
MQL
JMS I (COHNDL
TAD THSBLK
DCA SETBLK /NOW RESET
DCA COWRIT /CLEAR WRITE FLAG
TPOPJ
CORITE, 0 /ALSO CALLED BY CCLOSE
TAD COWRIT
SNA CLA /ONLY WRITE IF NEW DATA
JMP I CORITE
CLA CLL CML /LNK=1 FOR WRITE
TAD SETBLK /WRITE BLOCK IN CORE
MQL
JMS I (COHNDL
CLA CMA /NOW CLEAR BUFFER
TAD I (COSTA
DCA AUTO1
TAD [-2000
DCA XCNTR
DCA I AUTO1
ISZ XCNTR
JMP .-2
TAD SETBLK
CIA
TAD COCNT /CHECK IF LAST BUFFER
SZA CLA
JMP I CORITE
CLA CLL IAC RTL /4
TAD COCNT
DCA COCNT /UPDATE COCNT
JMP I CORITE
/SUBROUTINE CALLED BY 'OPEN TERMINATE' AND 'OCHK'
CCLOSE, 0
TAD CLNGTH
SNA CLA
JMP I CCLOSE
ISZ COWRIT /FORCE A LAST WRITE
JMS CORITE
TAD COMFLG
SNA CLA
JMP CLOOUT /ONLY CLOSE INTERNALLY
JMS I [GTMON
TAD DEVNO
CIF P
JMS I USR
4 /CLOSE
CNMTMP
COCNT, 0
ERROR1
2 /AC=ARRAY CLOSE ERROR
CLOOUT, DCA CLNGTH
DCA SETBLK
DCA COMFLG
JMP I CCLOSE
PAGE
COHNDL, 0 /SUB FOR READING OR WRITING ARRAY BUFFER
SZL
JMP .+6 /WRITE
TAD SETBLK /READ
TAD [12 /IF LAST WRITTEN BLOCK+4+7
CMA
TAD THSBLK /IS SMALLER THAN ASKED FOR BLOCK
CLA RTL /ROTATE LINK FOR SEARCH FORWARD
TAD [2000 /HERE LNK=0:READ;1:WRITE
RAR /5000:WRITE;1000:READ;8 PAGES
DCA COARG /1001:READ FORWARD
MQA /BLOCK
TAD CBLOCK /FIRST OF FILE
DCA COSTA+1
TPUSHF
COMDEV
TPOPF
NEWDEV /GET HANDLER BACK
JMS I [HANDAD
LIBBLK-1
ISZ CTCINH
JMS I LIBHND
COARG, 0
COSTA, COMBUF
0
JMP DERR
JMS I [DISMIS
JMP I COHNDL
CBLOCK, 0
COMDEV, ZBLOCK 2
/"OPEN ARRAY"
ARRAY, JMS I [CCLOSE //FILE STILL OPEN?
TAD (0601 /ASSUMED EXTENSION .FA
DCA EXTENS
JMS I [OPEN
LIBBLK-1
2 /FIRST DO A LOOKUP
JMP NODIR /TTY NOT A DIRECTORY DEVICE
SKP /THERE WAS NO FILE OF THAT NAME
JMP COMON /FOUND IT!
TAD ARPNT /FAKE 'OPEN' FOR ENTER
DCA I [OPEN
JMP I (OTHER
LIBBLK-1
3 /ENTER
ARPNT, .-2 /IT CAN'T COME HERE;ALREADY TESTED
ERROR1 /DEFINITELY AN ERROR
5 /AF=ARRAY FULL
CLA CLL CML IAC RAL /3
COMON, DCA REDFLG /SET TEMP FLAG
JMS I [GETDEV /I.E. A DISPLAY IS NO GOOD
SMA CLA
NODIR, ERROR1
3 /AD=ARRAY DEVICE ERROR
TPUSHF /EVERYTHING IS OK
NAMLOC
TPOPF
CNMTMP /SAVE NAME FOR CLOSE
TAD NEWDEV
DCA COMDEV
TAD NEWDEV+1
DCA COMDEV+1
TAD STBLK
DCA CBLOCK /SAVE FIRST BLOCK
CLL
TAD FLNGTH
TAD [100 /IS LENGTH GREATER THAN 100BLOCKS?
SNL
CLA CLL /YES;IGNORE
TAD NODIR-1 /-100
DCA CLNGTH /STORE LENGTH .LE. 100 (NEG)
TAD REDFLG
CLL RAR /SET LINK IF OUT
DCA COMFLG
DCA I (THSBLK
SZL
JMP .+3
TPUSHJ
COINPT /READ FIRST BUFFER IF INPUT
DCA I (COCNT
JMP I [CONTIN
*2521 /MAGIC ADRESS FOR NICE PATTERN
IDLER2, -200 /2521
XIDLE, 0
TAD IDLER1 /NULL JOB
ISZ IDLER2 /2524
JMP .-1 /2525
ISZ IDLER3
JMP XIDOUT
CLL RAL
SNL
CLA CMA
DCA IDLER1
TAD [-200
DCA IDLER3
XIDOUT, JMS I (INTRPT
TAD [-200
DCA IDLER2
JMP I XIDLE
IDLER1, 0
IDLER3, -6
CCLOSR, JMS I [CCLOSE
JMP I [CONTIN
REDFLG, 0
LOWTEM, 0 /KEEP HERE : 'POPF'
LOWOUT, 0 /OUT DRIVER
DCA LOWTEM
TAD I [ECHO /CHK ECHO;CDF P STILL ON
CDF L
TAD INECH
SPA CLA /0+-1:NO PRINT
JMP OUTOUT
TAD OUTFLG
SNA CLA /0:TTY
JMP LOWTTO
TAD LOWTEM
JMS I [NOCHAR /WRITE ON FILE
TAD OUTECH
SZA CLA /0:ECHO
JMP OUTOUT
LOWTTO, TAD LOWTEM
JMS I [TERMNL /ON TTY
OUTOUT, CIF CDF P
JMP I LOWOUT
PAGE
/INTERRUPT PROCESSOR
INTRPT, 0
CLA CLL
RDF
TAD CCDI
DCA INTEXI
TSF /GIVE OUTPUT PRIORITY
JMP KINT
TCF
DCA TELSW /TURN OFF THE IN-PROGRESS-FLAG
CDF P
TAD I OPTRI
SNA
JMP KINT
TPC /TYPE NEXT
DCA TELSW /CLEAR AC AND TURN ON THE FLAG
DCA I OPTRI /ZERO OUT THE DATA AREA
TAD OPTRI
IAC
AND [37
TAD OPTR0
DCA OPTRI
KINT, KSF /CHECK FOR KEYBOARD FIRST
JMP INTEXI-1 /MORE TO COME
KRS /INPUT CHARACTER
KCF /CLEAR FLAG
AND [177 /IGNORE BLANK AND L-T AND PARITY BIT
SNA
JMP INTEXI-2 /GO INITIATE NEXT READ
TAD [200
DCA INBUF
TAD INBUF
TAD [-203 /CTRL.C?
SNA
JMP I [MEXIT /YES
CLL RAR /(CHAR-203)/2=6 FOR CTRL.O AND P
TAD [-6 /IS IT?
SNA CLA
JMP RECOVR /YES A BREAK
CDF V
TAD INBUF
DCA I XDOL /SAVE IN INPUT VARIABLE
SKP
KCC
JMS I [MORE
INTEXI, CIF CDF L
JMP I INTRPT
XDOL, DOLL
CCDI, CIF CDF 0
KSTAT, 0
BREAK, 0
CTCADR, MEXIT
CTPADR, RECOVR
OFILES=7600
OPTR0, OFILES
OPTRO, OFILES
OPTRI, OFILES
XOUT, 0 /VIA (OUTDEV)
DCA ERROL
ISZ CHRCNT
CDF L
DRONE /MAY SKIP
CDF P
TAD I OPTRO /ANY ROOM ?
SZA CLA /A CHAR. IS NONZERO
JMP .-5 /NO = WAIT
TAD TELSW /IN PROGRESS ?
MIN40, SMA SZA CLA
JMP .+5
TAD ERROL /NO
TLS /TYPE CHAR
DCA TELSW /SET IN PROGRESS FLAG
JMP .+10 /RETURN
TAD ERROL /SEND DATA
DCA I OPTRO
TAD OPTRO /SET POINTERS
IAC
AND [37
TAD OPTR0
DCA OPTRO
CDF L
JMP I XOUT
*2736
ERRONC, -2
DKSTAT, KSTAT
ERROL, 0 /ERROR PRINT AND RESET
CLA CMA CLL
TAD I ERROL /GET ERROR CODE
DCA ERRCOD /DEFINED BY TECO CODE:
/^O^T&37-1*20UY^T&37-1+QY=^D
JMS I [IOWAIT /WAIT FOR OUTPUT TO FINISH
TAD ERRCOD
RECOVR, IAC /AB=A BREAK
RESTRT, DCA ERRCOD /AA=START ALL OVER
ISZ ERRONC /AVOID STAYING IN CLOSE ERROR
JMS I [OCHK
DCA CTCINH /TO KEEP INTERRUPT OFF
JMS I [DISMISS
CLA CLL CMA RAL /NOW WE ARE OK
DCA ERRONC
TAD DKSTAT
6047 /SET ETOS STATUS
CLA CLL
DCA INBUF /CLEAR INPUT BUFFER
TAD MIN40 /CLEAR OUTPUT BUFFER
DCA XCNTR
CMA
TAD OPTR0
DCA AUTO1
TAD OPTR0
DCA OPTRI
TAD OPTR0
DCA OPTRO
DCA OUTECH
DCA INECH
DCA OUTFLG /CLEAR IN/OUT FLAGS
DCA INFLG
CDF P
DCA I AUTO1
ISZ XCNTR
JMP .-2
CLA IAC /RESET ECHO TO ON
DCA I [ECHO
CDF L
TAD [215 /BACK TO START OF LINE
JMS TERMNL
TAD [212
JMS TERMNL
TAD (213 /RESET COUNTERS
JMS TERMNL
TAD [77
JMS TERMNL /?
TAD ERRCOD
CLL RTR
RTR
TAD (301 /FIRST LETTER
JMS TERMNL
TAD ERRCOD
AND (17
TAD (301 /SECOND LETTER
JMS TERMNL
CIF CDF P
JMP I .+1 /FOR LINENO PRINTOUT
ENDERR
/IN DRIVER
LOWIN, 0
TAD INFLG
SPA
JMP EOF /-:END OF FILE
SNA CLA
JMP LOWTTI /0:TTY
JMS I (ICHAR /INPUT FROM FILE
SKP
LOWTTI, JMS I (XIN /FROM TTY
CIF CDF P
JMP I LOWIN
EOF, ERROR1
105 /EF=END-OF-FILE
TERMNL, 0 /HANDLER FOR TTY DEVICE
AND [177
DCA LOWIN
TAD LOWIN
TAD (-17 /CHAR-17
CLL
TAD (10 /OVERFLOW IF 7.LE.CHAR.GE.16
SZL CLA /FORMAT CHAR.?
JMP TERCTL
TAD LOWIN /CONTRL.CHAR.?
AND TERNMV
SZA CLA
JMP TEROUT /NO;OUT NORMAL
TAD INECH /O I TTY:?
SMA /FALLS THRU WITH -1;SO NO MOVE
JMP TERCON /NO. CONVERT TO ^X
TERMMV, IAC /WITH NEXT GIVES -2
TERNMV, CMA CLL /-1, ALSO MASK 140
TAD CHRCNT
DCA CHRCNT /MODIFIED CHAR.CNT.
TEROUT, TAD LOWIN /GIVE OUT STANDARD
JMS I (XOUT
TERCHK, TAD CHRCNT /CHECK IF OVERFLOW
SPA CLA
JMP I TERMNL /NO. GO BACK
TAD [215 /FALLS IN FROM LINE OVERFLOW
JMS I (XOUT
TERLFD, JMS TERLF
JMP LINRES /NOT AT END OF PAGE
TERFF, TAD LINCNT /END OF PAGE OR FF.
TAD [-6 /EXTRA SKIP
DCA LINCNT
JMS TERLF
JMP .-1 /NOT AT END;CONTINUE
TERRES, TAD PAGLEN /AT END *****
DCA LINCNT /RESET
JMP LINRES /NOW RESET LINE
TERCTL, TAD LOWIN /BUILD JUMP
TAD TERJMP
DCA .+1
HLT /MUST!! BE 6 AFTER 'TERRES'*****
JMP TERNMV /" 7":BELL;UNCHANGED;NO MOVE
JMP TERMMV /"10":BSPC; " " ;BACKUP CHAR.CNT.
JMP TERTAB /"11":HTAB
JMP TERLFD /"12":LF ;RESETS CHAR.CNT.
TERJMP, JMP TERRES /"13":VTAB;RESET
JMP TERFF /"14":FFED;SIMULATE
JMP TERCR /"15":CRET;CRLF
LINNEW, TAD [215 /"16":CRONLY
JMS I (XOUT
CLA CLL
TERCR, TAD [215
JMS I (XOUT /FOR DELAY
LINRES, TAD LINLEN /RESET CHAR. CNTR.
DCA CHRCNT
JMP I TERMNL
TERLF, 0 /SUB FOR GENERATING LF,S
TAD [212
JMS I (XOUT
ISZ LINCNT
JMP I TERLF
ISZ TERLF /SECOND RETURN:AT END
JMP I TERLF
TERTAB, TAD (240
JMS I (XOUT
TAD CHRCNT
AND [7
SZA CLA
JMP TERTAB
JMP TERCHK /GO CHECK IF END OF LINE
TERCON, TAD (136 /^
JMS I (XOUT
TAD [100 /CONVERT;100+LOWIN=ALPHA
JMP TEROUT
LINCNT, -102
LINLEN, -110
PAGLEN, -102 /TOTAL LENGTH-6
*COMBUF
ZBLOCK 1000
IFNDEF KEY<
ZBLOCK 1000
>
/FILE SECURITY DATAPLAN-FOS877
/TO BE ASSEMBLED WITH PARAMETER KEY=CODENU
/CALL PROGRAM TO BE MODIFIED WITH L C XXXXX
/PROGRAM THAN SAVES AGAIN AND COMES BACK FOR MORE
/IF FOS8 IS TO BE RECODED:INSERT THE CODE-NUMBER FIRST
/ADRESS FOR CODE-NUMBER IN FOCAL IS:01760
IFDEF KEY<
APPLEN=55
KEYER, CDF 0
TAD I (CODENU /TRANSFER CODE-NUMBER
CIA
DCA TMCOD
TAD TMCOD /NEG. TEMP
CIA
DCA I (CODE /IN APPEN
CDF 10
TAD I (BUFR /GET LENGTH OF PROGRAM
CLL
TAD (APPLEN-GORETN /SEE IF APPEN FITS IN PAGE
SZL CLA
ERROR1
373 /?PL
TAD I (BUFR
DCA APPSTR
TAD APPSTR
AND (177
DCA KRELOC /RELOCATION VALUE
TAD KRELOC
TAD (APPLEN-200 /DOES CODE FIT?
SNL CLA
JMP .+6 /YES
DCA KRELOC /NO RELOC
TAD APPSTR
TAD (200 /NEXT PAGE
AND (7600
DCA APPSTR /STORE TEMP
TAD APPSTR
DCA I (BUFR /RESET BUFR
TAD (APPEN-2
DCA AUTO1
CMA
TAD APPSTR
DCA AUTO2
TAD (APPLEN
CIA
DCA COUNT
TAD KRELOC
DCA REL1
TRNSLP, CDF 0 /NOW TRANSFER APPEN TO FLD 2
TAD I AUTO1
SNA /ZERO ENDS RELOCATION
DCA REL1
SMA /DON'T RELOCATE IOTS&OPRS$JMPJMSS
TAD REL1
CDF 20
DCA I AUTO2
ISZ COUNT
JMP TRNSLP
TAD TMCOD
TAD I (LINE1
DCA I (PC0+1 /C(LINE1)-CODE TO PC0+1
TAD TMCOD
TAD I (LINE0
DCA I (LINE1 /C(LINE0)-CODE TO LINE1
DCA I (LINE0 /0 TO LINE0
TAD TMCOD
TAD APPSTR
IAC
DCA I (PC0+2 /APPEN ENTRY-CODE TO PC0+2
DCA I (LINE0-1 /NOT NEEDED ANY MORE
CDF 0
TAD I (APPJMP
MQL
TAD I (APPEN
TAD KRELOC /RELOCATE 'JMS .'
CDF T
ISZ APPSTR
DCA I APPSTR
TAD APPSTR
TAD (APPJMP-APPEN
DCA APPSTR
MQA
TAD KRELOC
DCA I APPSTR /RELOCATE 'JMP I APPBCK'
CDF L
JMS I (SAVPR /NOW RESAVE PROGRAM
JMP I (EXITOS /AND BACK TO FOCAL
TMCOD, 0
APPSTR, 0
KRELOC, 0
REL1, 0
COUNT, 0
PAGE
/THIS PART IS MOVED TO FLD 2 AT THE END OF THE PROGRAM
SKP /FALLING IN WILL GIVE ERROR
APPEN, JMS . /ADRESS: C (PC0+2) + CODE
CMA /AC CARRIES C(PC0+2)
TAD APPEN /AC=CODE
CIA
TAD CODE
SZA /IF ZERO ALL OK
JMP I PDLXR /IT WILL BLOW UP
DCA I PC02PT /CLEAR POINTER
TAD I LIN1PT
TAD CODE
DCA I LIN0PT /SET LINE0
TAD I PC01PT
TAD CODE
DCA I LIN1PT /SET LINE1
DCA I PC01PT
CDF 10
TAD SNACL
DCA I MODPT /KILL MODIFY
TAD DCALIN
DCA I WRITPT
DCA I WRIT1P /KILL WRITE
DCA I WRIT2P
CIF CDF 0
DCA I SVPTPT
TAD SAVMOD
DCA I BLM4PT /KILL SAVE
TAD APPEN /APPEN IN AC FOR BUFR
APPJMP, JMP I APPBCK
0 /END OF RELOC
APPBCK, CODENU-4
CODE, 0
PC02PT, PC0+2
LIN1PT, LINE1
LIN0PT, LINE0
PC01PT, PC0+1
SNACL, SNA CLA
DCALIN, DCA LINENO
MODPT, MODIFY+4
WRITPT, WRITE
WRIT1P, WRITE+3
WRIT2P, WRITE+14
SVPTPT, SAVEPT+4
SAVMOD, TAD [OCLOSE /READ INSTEAD OF WRITE
BLM4PT, BLLL-4
APPLEN=.-APPEN+1
ZBLOCK 5200-.
>
/GET OUT THE PAGE 0 LITERALS
FIELD 0
/FIRST TIME INITIALIZING FOR OS/8 FOCAL
CDTBL=7200
USRTBL=7300
*5200
SETUP, DCA CHAINS /REMEMBER CALL
CDF 0
CIF 10
JMS I (7700 /CALL USR
10 /LOCK IN
TAD CHAINS
SNA CLA
JMP NODECD
CIF 10
JMS I (200
5 /COMMAND DECODE
5200 /SPECIAL MODE
NODECD, CLA CMA /ZAP OPEN FILES,SET -1
CDF 10
TAD I (36 /GET POINTER TO DEVNAM TABLE
CDF 0
DCA .+4
JMS I (MVCORE /MOVE TABLE DOWN
-20
CDF 10
HLT
CDF 0
USRTBL /IN CHAIN AREA
JMS I (MVCORE /MOVE FILE TABLE DOWN
-50
CDF 10
7600
CDF 0
CDTBL /ALSO IN CHAIN AREA
CIF 10
JMS I (200
11 /USROUT
JMS I (MVCORE /CLEAR OUTPUT BUFFER
-40
CDF 0
COMBUF
CDF 10
7600
TAD I (CDTBL+6 /CHECK IF NAME
SNA CLA
JMP I (GOSTRT /NO;RUN FCINIT(MAYBE)
TAD I (CDTBL+5 /GET DEVNO
JMS I (DNTONM /CONVERT
LINE3A+4
JMP I (DEVERR
JMS I (MVCORE
-3 /MOVE FILENAME
CDF 0
CDTBL+6
CDF 0
LINE3A+7
TAD I (CDTBL+11 /CHECK EXTENSION
SNA
TAD (603 /DEFAULT - FC
DCA I (LINE3A+13
TAD I (CDTBL+12 /CHECK INPUT
SNA
JMP I (NOINPT+3 /SET TTY:,E
JMS I (DNTONM
LINE2A+4
JMP I (DEVERR
TAD I (CDTBL+13
SNA CLA
JMP I (NOINPT /NO NAME
JMS I (MVCORE
-3 /MOVE NAME
CDF 0
CDTBL+13
CDF 0
LINE2A+7
TAD (5640 /SET . FOR EXTNSN
DCA I (LINE2A+12
TAD I (CDTBL+16
SNA
TAD (604 /DEFAULT .FD
DCA I (LINE2A+13
JMP I (NOINPT
CHAINS, 0
PAGE
NOINPT, JMS I (GESWIT
"I-300 /INPUT ECHO?
SKP
TAD (5405 /YES - SET ,E
DCA I (LINE2A+14
TAD I (CDTBL /GO ON WITH O O
SNA
JMP NOOUTP+3
JMS I (DNTONM
LINE1A+4
JMP I (DEVERR
TAD I (CDTBL+1
SNA CLA
JMP NOOUTP
JMS I (MVCORE
-3
CDF 0
CDTBL+1
CDF 0
LINE1A+7
TAD (5640
DCA I (LINE1A+12
TAD I (CDTBL+4
SNA
TAD (604
DCA I (LINE1A+13
NOOUTP, JMS I (GESWIT
"O-300
SKP
TAD (5405
DCA I (LINE1A+14
JMP .+4
GOSTRT, JMS I (GESWIT /CHECK IF CHAIN TO FCINIT
"C-300
SKP CLA
CLA IAC
CLL CML RAL /SETS MODE TO 1 OR 3
DCA MODE /FOR START OR GOTO
JMS I (GESWIT /NO FUNCTIONS?
"N-300
JMP .+4
TAD (CDF 10
JMS I (PATCH
NOFUNC
JMS I (GESWIT /REDUCED PRECISION?
"6-225
JMP FULPRC
TAD (CDF 10
JMS I (PATCH
REDPRC
TAD (CDF 0
JMS I (PATCH
OTHVAR
JMS I (MVCORE
-31
CDF 0
DIVOVL
CDF 10
DUBDIV+10
JMS I (MVCORE
-36
CDF 0
NEWVAR
CDF 10
STSECR
FULPRC, JMS I (GESWIT
"B-300 /BACK SPACE TERMINAL?
JMP NOBCKS
JMS I (MVCORE
-6
CDF 0
BACKSP
CDF 10
FORW+11
NOBCKS, JMS I (GESWIT
"A-300 /MODIFY ASK TO COLON?
JMP NOCOL
TAD (":
CDF 10
DCA I (DIDO
CDF 0
NOCOL, JMS I (GESWIT
"R-300
JMP NOBEL
TAD (207 /BELL IN ASK
CDF 10
DCA I (DIDO
CDF 0
NOBEL, JMS I (GESWIT
"Q-300
JMP I (NOQUES
TAD ("? /? IN ASK
CDF 10
DCA I (DIDO
CDF 0
JMP I (NOQUES
MODE, 0
PAGE
NOQUES, TAD I (CDTBL+46 /CHECK = OPTION
SNA
TAD (110 /NO TTY LINE-WIDTH
CIA /MINUS LINE-WIDTH
DCA I (LINLEN
TAD I (LINLEN
DCA CHRCNT
TAD I (CDTBL+42
AND (3777 /ELIMINATE ALT-MODE SWITCH
SNA
TAD (110 /NO PAGE-LENGTH
CIA
TAD (6 /SKIP LENGTH AT PAGE BOUNDARY
DCA I (PAGLEN
TAD I (PAGLEN
DCA I (LINCNT
NOTTWD, JMS I (GESWIT
"S-300 /SAVE SWITCH;GO BACK TO KM.
SKP
JMP I (7600 /WITH PATCHES SET
JMS I (GESWIT
"W-300 /WRITE PROGRAM?
JMP NOWRIT
TAD (340 /YES;SET L C;NO EXECUTION
DCA I (LINE3A+3
CLA CLL IAC CML RAL /'GO'=3
DCA I (MODE
TAD (ENDWRT /SET TO COME BACK HERE
CDF 10
DCA I (FORLEX+2
JMP NOWRIT+3 /SIMULATE ALT-MODE
ENDWRT, TAD (LEXIT /RESET
CDF 10
DCA I (FORLEX+2
TAD (200
DCA I (PC
CDF 20
TAD (GORETN-1
DCA I (PDLXR /RESET PDL FOR RETURN
CDF 0
JMS ETINIT
CLA CLL IAC RTL /'WRITE'=4
JMP I (CHENTR
NOWRIT, JMS I (GESWIT
0 /CHECK ALT-ESC
JMP NOALTM /NONE
CDF 10 /YES CHANGE EXIT
TAD (FORLEX
DCA I (START
CDF 0
JMP YESGO
NOALTM, JMS I (GESWIT /CHECK IF GO
"G-300
SKP CLA
JMP YESGO
TAD (340
DCA I (LINE3A+3 /SET L C
YESGO, CMA
TAD I (MODE
SZA CLA /IF START ERASE ALL
JMP NOSTRT
DCA I (LINE0A
TAD (LINE1
CDF 10
DCA I (BUFR
CDF 0
NOSTRT, TAD CHNDCA
DCA I (CHENTR /RESET CHAIN ENTRY
JMS I (MVCORE /NOW MOVE HEADER UP
-400
CDF 0
POPSUB
CDF 20
0
JMS I (MVCORE /AND PDL (WIPE OUT BATCH?)
-100
CDF 0
PDLMON
CDF 20
7500
CDEXIT, JMS ETINIT
TAD I (MODE /GO TO FOCAL
JMP I (CHENTR
ETINIT, 0
TAD (KSTAT
6047
CLA CLL
TAD (215
JMS I (TYPIT
TAD (212
JMS I (TYPIT
JMP I ETINIT
CHNDCA, 3217
PAGE
/MOVE CORE ROUTINE: JMS MVCORE
/ -# OF WORDS
/ CDF FROM
/ ADRESS FROM
/ CDF TO
/ ADRESS TO
MVCORE, 0
TAD I MVCORE
DCA MVCNT
ISZ MVCORE
TAD I MVCORE
DCA FRMCDF
ISZ MVCORE
TAD I MVCORE
DCA MVPTFR
ISZ MVCORE
TAD I MVCORE
DCA TOCDF
ISZ MVCORE
TAD I MVCORE
DCA MVPTTO
ISZ MVCORE
FRMCDF, HLT
TAD I MVPTFR
ISZ MVPTFR
TOCDF, HLT
DCA I MVPTTO
ISZ MVPTTO
ISZ MVCNT
JMP FRMCDF
CDF 0
JMP I MVCORE
MVCNT, 0
MVPTFR, 0
MVPTTO, 0
/GET A SWITCH ROUTINE: JMS GESWIT
/ CODE: ALTESC=0,A-Z="X-300,0-9="#-225
/ RETURN NOT SET
/ RETURN SET
GESWIT, 0
TAD I GESWIT
CIA
DCA SWITNU /SAVE SWITCH NUMBER NEGATIVE
TAD SWILOC
DCA SWIPNT /RESET POINTER
TAD SWITNU
SZA CLA /ALT-ESC?
JMP NEXSWI /NO
CLA CMA /YES
DCA SWITNU /ROTATE ONLY ONCE
SKP /KEEP POINTER AT FIRST WORD
NEXSWI, ISZ SWIPNT /NEXT WORD
CLA CLL CML /SET MASK-BIT
SWILUP, RAR
SZL /AT END OF WORD?
JMP NEXSWI /YES;TO NEXT WORD,DON'T BUMP SWITNU
ISZ SWITNU /RIGHT LOC?
JMP SWILUP /NO;SHIFT MORE
AND I SWIPNT /YES;AND MASK WITH SWITCH
ISZ GESWIT
SZA CLA /BIT SET?
ISZ GESWIT /YES;BUMP RETURN
JMP I GESWIT
SWITNU, 0
SWIPNT, 0
SWILOC, CDTBL+42
/DEVICE CODE TO NAME AND STORE ROUTINE
/ TAD DEVNO
/ JMS DNTONM
/ ADRESS FOR STORE
/ ERROR RETURN (NOT IN LIST)
/ NORMAL RETURN (STORED)
DNTONM, 0
AND (17 /TAKE DEVICE BITS
TAD (7300 /ADRESS OF TABLE
DCA DNPTR
TAD I DNTONM
DCA PUTDCN /SET ADRESS FOR STORE
ISZ DNTONM /AT ERROR RETURN
TAD I DNPTR /GET USR DEVICE NAME
CIA
DCA DCCODE
TAD (DVCDNM /START SEARCH
DCA DNPTR
DNLOOP, CLA CLL
TAD DCCODE
TAD I DNPTR /GET CODE,IS IT .GE. DCCODE?
ISZ DNPTR
SZL SNA
JMP DNFND+2 /EXACT
SZL
JMP DNEXIT /NOT IN LIST
TAD I DNPTR /SEE IF WE GET AN INDEXED NAME
SZL
JMP DNFND /YES;OVERFLOW IS MAX#-#
ISZ DNPTR
ISZ DNPTR /BUMP POINTER-SEARCH ON
ISZ DNPTR
JMP DNLOOP
DNFND, CIA /#-MAX#
TAD I DNPTR /#
MQL
ISZ DNPTR
TAD I DNPTR /TRANSFER NAME
DCA I PUTDCN
ISZ DNPTR
ISZ PUTDCN
MQA /ADD IN NUMBER
TAD I DNPTR
DCA I PUTDCN
ISZ DNTONM /NORMAL RETURN
DNEXIT, CLA CLL
JMP I DNTONM
DNPTR, 0
PUTDCN, 0
DCCODE, 0
PATCH, 0 /ROUTINE PATCH CDF ADRESS OF TABLE
DCA PATCDF /COMES IN WITH CDF X
TAD I PATCH /GET LIST ADRESS
ISZ PATCH
DCA PATATO
PATLUP, TAD I PATATO /GET ADRESS TO PATCH
SNA
JMP I PATCH /0 ENDS LIST
DCA PATTER
ISZ PATATO
TAD I PATATO /A LA RIM LOADER
PATCDF, HLT
DCA I PATTER
CDF 0
ISZ PATATO
JMP PATLUP
PATATO, 0
PATTER, 0
DEVERR, CIF 10 /USER ERROR 7
JMS I (7700
7
7
PAGE
/DEVICE NAME TABLE: CODE
/ # OF OF INDEXED NAMES-1
/ DEVICE NAME
/7777 IN CODE ENDS LIST
/CODES IN INCREASING ORDER!
DVCDNM, 406
0
DEVICE DF
2303
0
DEVICE SC
2426
0
DEVICE TV
4020
0
DEVICE LPT
4024
0
DEVICE PTP
4224
0
DEVICE PTR
4503
7
DEVICE CSA0
4573
3
DEVICE DKA0
4604
7
DEVICE DTA0
4631
0
DEVICE SYS
4673
3
DEVICE DKB0
5524
0
DEVICE TTY
5604
7
DEVICE LTA0
5704
7
DEVICE MTA0
5723
0
DEVICE DSK
6373
3
DEVICE RKA0
6464
3
DEVICE SDA0
6473
3
DEVICE RKB0
6504
0
DEVICE CDR
6564
3
DEVICE SDB0
6601
0
DEVICE BAT
7777
TYPIT, 0
TLS
CLA CLL
TSF
JMP .-1
JMP I TYPIT
BACKSP=.
RELOC FORW+11
/FOR TERMINAL WITH BS
JMP .+2
TAD M30
TAD SPC
DCA T3
M30, -30
TAD T3
RELOC
*6400
POPSUB=.
RELOC 0
/GETS LOADED IN FIELD 2
/CORE MAP: /0-177: PDL SUBROUTINES
/200-X: TEXT
/X-7545: PUSHDOWN LIST
/7546-7577: MONTHS OF THE YEAR
0 /FOR RUBOUT PROTECTION;SEE RUB1
PSHBUF, BUFR /INDIRECT FOR TEXT PROTECTION
PSHCDF, CDF 0
PSHERR, ERROL+3 /POINTER TO ERRROR ROUTINE
0
0 /FOR ODT
0
PSHCNT, 0
PSHAX, 0
PDLXR, GORETN-1 /MAIN AX FOR PDL
PSHM4, -4
PSHMSK, 7
POPOVR, 376-1 /PO=PDL. OVERFLOW
PSHM5, -5
FLDCDI, HLT /CDI CURRENT
JMP I FLDRET /EXIT
FLDRET, 0
ZPOPA, 0 /ONE ITEM FROM PDL TO AC;OLD AC IN MQ
JMS FLDSET
TAD I PDLXR
JMP FLDCDI /NO INC RETURN
ZPUSHA, 0 /AC TO PDL;AC TO MQ
JMS FLDSET
CLA CMA
JMS PCHK
MQA
DCA I PDLXR
CLA CMA
JMS PCHK
JMP FLDCDI /NO INC RETURN
/LOCAL FIELD SATELLITES FOR ALL POPS EXCEPT
/POPJ MUST BE AS FOLLOWS:
/XPOPU, 0
/ MQL
/ FLDCUR (DEFINED ON OTHER PAGE)
/ CIF T (WHERE T IS FIELD OF POP SUBS.)
/ JMS I .+1
/ ZPOPU
/FLDCUR=CLA FOR FIELD 0
/ =CLA IAC 1
/ =CLA IAC RAL 2
/ =CLA CLL CML IAC RAL 3
/ =CLA IAC RTL 4
/ =CLA CLL CMA RTL 5
/ =CLA CLL CMA RAL 6
/ =CLA CMA 7
FLDSET, 0 /SUBROUTINE FOR ANALYZING FIELDS AND ADRESSES
AND PSHMSK /TAKE ONLY 7 BITS
CLL RAL
RTL
TAD PSHCDF
DCA FLDCDF /CALLING DATA FIELD
TAD PSHCDF /NOW LET'S SEE WHICH D.F. HE PUT
RDF
DCA ACCES /ACCES DATA FIELD
CDF T /THIS FIELD
CLA CLL CMA RAL /JMS FLDSET ALWAYS FIRST INSTR. OF ZPOPU'S
TAD FLDSET /ZPOPU+2
DCA FLDRET /NOW BECAUSE OF STANDARD FORM OF SATELLITES
TAD PSHM5 /-5 PLUS THE
TAD I FLDRET /CONT. OF ZPOPU ENTRY,GIVES ADRESS OF XPOPU
DCA FLDRET
FLDCDF, HLT /CHANGE TO CALLING D.F.
TAD I FLDRET /THIS IS ADRESS OF ARG.
DCA FLDRET /AND FINAL RETURN ADD. FOR POPA,PUSHA
CLA CMA /FOR RELATIVE ADRESSING:'TAD FLDRET'
TAD I FLDRET /ARGUMENT-1 FOR AX
DCA PSHAX
CLA CLL IAC RAL /BUILD A CIF CDF CALLING FIELD
TAD FLDCDF /FOR FINAL RETURN
DCA FLDCDI
CDF T /BACK TO THIS FIELD
JMP I FLDSET
/BY THE WAY: THE DATA FIELD IS ALWAYS RESET TO CURRENT
/THIS CAN BE USEFUL
/CALLS IN A PROGRAM WILL LOOK LIKE THIS:
/CDF ACCES
/PUSHF
/ LOC /RELATIVE: LOC-.-1
/WILL PUSH 4 WORDS STARTING IN LOC IN FIELD ACCES
ZPUSHF, 0 /4 WORDS IN PDL;AC CONSERVED;AC TO MQ
JMS FLDSET
TAD PSHM4
JMS PCHK
TAD PSHM4
DCA PSHCNT
ACCES, HLT /SET BY FLDSET
TAD I PSHAX /""
CDF T
DCA I PDLXR /STORE IN PDL
ISZ PSHCNT
JMP ACCES /LOOP
TAD PSHM4
JMS PCHK /RESET PDLXR
PSHFEX, MQA /RESTORE AC
ISZ FLDRET /BUMP PAST ARG
JMP FLDCDI
ZPOPF, 0 /4 WORDS FROM PDL IN LOC;AC CONSERVED;AC TO MQ
JMS FLDSET
TAD PSHM4
DCA PSHCNT
TAD ACCES /RELOCATE CDF ACCES
DCA .+3
POPLOP, CDF T
TAD I PDLXR
HLT
DCA I PSHAX
ISZ PSHCNT
JMP POPLOP /LOOP
JMP PSHFEX /SAME RETURN AS ZPUSHF
/!!!!!
/POPJ IS THE ONLY POPU THAT NEEDS ANOTHER SATELLITE!
/XPOPJ, CIF CDF T
/ JMP I .+1 /JMP!!
/ ZPOPJ
ZPUSHJ, 0 /GO TO ARG IN ACCES;CDF ALSO ACCES;AC CONSERVED
JMS FLDSET /AC TO MQ
CLA CLL CMA RAL /-2
JMS PCHK
IAC /TO BUMP PAST ARG
TAD FLDRET /RETURN AFTER POPJ
DCA I PDLXR
TAD FLDCDI /CDI AFTER POPJ
DCA I PDLXR
CLA CLL CMA RAL
JMS PCHK
CLA CLL IAC RAL
TAD ACCES /BUILD CDI ACCES
DCA .+1
HLT
MQA /RESTORE AC
JMP I PSHAX /!!
ZPOPJ, TAD I PDLXR /AC INCS RETURN AND IS LOST;MQ CONSERVED
DCA FLDRET
TAD I PDLXR
DCA FLDCDI
JMP FLDCDI
PCHK, 0 /SUB TO BACKUP PDL AND CHECK OVERFLOW
TAD PDLXR /AC COMES IN WITH AMOUNT OF BACKUP
DCA PDLXR
TAD PDLXR
CIA CLL
CDF P /SOME OTHER FIELD
TAD I PSHBUF /GET LOWER BOUNDARY
CDF T
SNL CLA
JMP I PCHK /NO OVERFLOW
TAD POPOVR
CIF CDF L
JMP I PSHERR
VPOPA=JMS I . /FOR FIELD T POPS
NOP
VPUSHA=JMS I .
NOP
VPUSHJ=JMS I .
NOP
VPOPJ=JMP I .
NOP
VPUSHF=JMS I .
NOP
VPOPF=JMS I .
NOP
RELOC
*6600
RELOC 200
PC0, 0 /TEXT BUFFER HEAD
0
0
0
0
5051 /LPAR,RPAR FOR DUMP
BUFR
235
LINE0, LINE1
LINE0A=LINE0+POPSUB
0
TEXT "C-FOS8 DATAPLAN-77"
*.-1
7715 /DUMMY CR
LINE1A=.+POPSUB
/TEXT FOR AUTOMATIC LOADING AFTER CHAIN
LINE1, LINE2
212 /LINE 1.1
TEXT "O O TTY : ,E"
*.-1
7715
LINE2A=.+POPSUB
LINE2, LINE3
224 /LINE 1.2
TEXT "O I TTY : ,E"
*.-1
7715
LINE3A=.+POPSUB
LINE3, 0000
236 /LINE 1.3
TEXT "L R DSK : FCINIT. FC <00.0> "
*.-1
7715
LINE4A=.+POPSUB
LINE4=.
7715
7715
RELOC
DIVOVL=.
RELOC DUBDIV+10
TAD AC1L
TAD LORD
DCA MP2
RAL
TAD HORD
TAD AC1H
SNL
JMP .+4
DCA HORD
TAD MP2
DCA LORD
CLA
TAD MP1
RAL
DCA MP1
TAD MP4
RAL
DCA MP4
ISZ MP3
JMP DV3
TAD MP1
DCA LORD
TAD MP4
DCA HORD
JMP I DUBDIV
RELOC
NEWVAR=.
RELOC STSECR
4400
0000
0013
DOLL1, 0001
0000
4300
NMBSG1=.+2
ZBLOCK 4
4100
EXCLA1=.+2
ZBLOCK 4
4200
QUOTS1=.+2
ZBLOCK 4
2011 /PI
0000
0002
3110
3756
2605 /VE
0000
0001
2000
0000
STVAR1=.
RELOC
*7000
NOFUNC, VARTOP /
FNTABL-10
FNTABF+7 /
ERCALL
FNTABF+11 /
ERCALL
FNTABF+13 /
ERCALL
FNTABF+15 /
ERCALL
FNTABF+17 /
ERCALL
FNTABF+21 /
ERCALL
FNTABF+23 /
ERCALL
0000
OTHVAR, XNMBSG /
NMBSG1
XEXCLA /
EXCLA1
XQUOTS /
QUOTS1
XDOL /
DOLL1
0000
REDPRC, LASTV /ADRESS
STVAR1
END /
STVAR1
FSIZE /
6
DECP /
3
GINC /
5
MFLT /
-3
DIGITS /
7
TWOPI+2 /
3756
PI+2 /
3756
PIOT+2 /
3756
PTEN+2 /
3147
FPNT+3 /
DCA OVER1
FPNT+4 /
DCA OVER2
ZERO+20 /
DCA OVER1
TEST2 /
27
DMULT+32 /
DMDONE&177+5200
DMDONE+7 /
DCA OVER2
MULDIV+4 /
ISZ OVER2
MIF /
-27
0000
PDLMON=7100
*7104
RELOC 7504
GORETN, INPUTX+2 /RETURN FOR GOTO
CIF CDF P
ZBLOCK 40
/MONTHS OF THE YEAR
MONAME, TEXT "--19"
*.-1
TEXT "JAN-"
*.-1
TEXT "FEB-"
*.-1
TEXT "MAR-"
*.-1
TEXT "APR-"
*.-1
TEXT "MAY-"
*.-1
TEXT "JUN-"
*.-1
TEXT "JUL-"
*.-1
TEXT "AUG-"
*.-1
TEXT "SEP-"
*.-1
TEXT "OCT-"
*.-1
TEXT "NOV-"
*.-1
TEXT "DEC-"
RELOC
FIELD 0
*200
$$$$