File: FOCLIB.PA of Tape: Sources/Focal/fc3
(Source file text)
/PS/8 FOCAL LIBRARY ROUTINES
FIELD 0
*1 /INTERRUPT SERVICE ROUTINE
CIF CDF 10
JMP I .+1
2603
RMF /RETURN FROM INTERRUPT
ION
JMP I 0
*10
AUTO1, 0 /AUTO-INDEX REGISTERS...ACTUALLY USE SOME
AUTO2, 0
AUTO3, 0
AUTO4, 0
AUTO5, 0
AUTO6, 0
AUTO7, 0
AUTO8, 0
XCNTR, 0 /GENERAL COUNTER--SUCH AS FOR MPD2,MPD3
USR, 7700 /POINTER TO MONITOR (200 IF IN CORE)
EXIT, JMS I [DISMIS /NORMAL RETURN FOR PS/8 COMMANDS
ION
CDF CIF 10
JMP I .+1
GOSWITCH-3
NAMLOC, ZBLOCK 3
EXTENSION, 0 /"FC" OR "FD"
LISTFLG, 0
NEWDEV, ZBLOCK 2
TEM7, 0
ATEM, 0
XCHAR, CHAR
SHNDLR, 7607
/DEFINE LOWER FIELD INSTRUCTIONS . . .
TGETC=JMS I .
XGETC
TPOPA=JMS I .
MPOPA
TPUSHA=JMS I .
MPUSHA
TPUSHF=JMS I .
MPD2
TPOPF=JMS I .
MPD3
TSORTJ=JMS I .
MSORTJ
ECHFLG, 0
OPNFLG, 0
IPNFLG, 0
FLNGTH, 0
STBLK, 0
DEVNO, 0
LIBBLK, 0 /FOR DEVICE NAME
0
7400 /LOAD POINT
0 /FOR DEVICE #
LIBHND, 0 /HANDLER ENTRY
TESTRM=JMS I .
MSORTC
ERROR1=JMS I .
ERROR
*66
CHAR, 0 /FOR OBSCURE FAKING REASONS
INBLK, 0
0
5000
0
INHND, 0
OUTBLK, 0
0
5200
0
OUTHND, 0
TPRINTC=JMS I .
MPRINTC
TGETLN=JMS I .
MGETLN
TSPNOR=JMS I .
XTSPNOR
LIBFIL, 0
DEVHLD, 0
PAGE
/INITIAL TEXT FOR PS/8 FOCAL
*200
PC0, 0
0
0
0
0
5051
BUFR
LINE1
LINE0, 0
0
TEXT "C-PS/8 FOCAL, 1971"
*.-1
7715 /DUMMY CR
LINE1=.
PAGE
/PS/8 FOCAL FILE ROUTINES
*3614
RESTORE,TSPNOR /'OPEN RESTORE' COMMAND
TAD CHAR /SAVE COMMAND CHAR (3 WORD COMMAND!)
TPUSHA
TGETC
TESTRM /GO TO END OF COMMAND WORD
SKP CLA
JMP .-3
CLA CLL CMA /INITIALIZE ECHO SWITCH
DCA ECHFLG
JMS I [NAME /JUST TO SET ECHO MODE
TPOPA
TAD [-"I /OPEN RESTORE INPUT?
SNA
JMP I [IRST /YES
TAD ["I-"O /NO, MUST BE OUTPUT
SZA CLA
ERROR1 /NEITHER ONE!
JMP I [ORST
OCLOSE, 0 /CLOSE THE OPEN OUTPUT FILE
TAD OPNFLG
SNA CLA /DON'T BOTHER IF IT ISN'T OPEN
JMP I OCLOSE
TAD [232 /WRITE '^Z'
JMS NOCHAR
TAD OPTR1 /PAD BUFFER WITH ZEROS
TAD (-4400 /(AND WRITE IT OUT)
SZA CLA
JMP .-4
TAD DEVHLD /SAVED DEVICE #
IOF
CIF 10
JMS I USR
4
ONMTMP /POINTER TO SAVED NAME
BLKCNT, 0 /FILE LENGTH (BLOCKS)
ERROR1 /HUH?
DCA OPNFLG /CLEAR 'FILE OPEN' FLAG
ION
CDF 10
TAD [OUTL /RESTORE TELETYPE OUTPUT ROUTINE
DCA I [OUTDEV
CDF
JMP I OCLOSE /DO WHATEVER ELSE NEEDS TO BE DONE
NOCHAR, 0 /PS/8 3/2 BUFFERED CHARACTER OUTPUT
JMS I [FLDSET /CALLED FROM EITHER FIELD
DCA CCIF /SAVE CALLING FIELD
CDF
TAD ATEM /CHARACTER TO BE OUTPUT
AND (377 /MASK OUT GARBAGE
ISZ O3 /WHICH CHAR OF THREE?
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 WITH 3RD CHAR OF 3
JMP CCIF /NOT FULL YET, RETURN TO CALLING ROUTINE
JMS I [PUTDEV /TELL THE MONITOR THIS HANDLER'S IN CORE
OUTHND-1 /POINTER TO DEVICE # AND ENTRY
CLA CLL
TAD OLNGTH /-MAXIMUM ALLOWABLE LENGTH
TAD BLKCNT /LENGTH SO FAR
SZL CLA /HAS HE GONE TOO FAR?
JMP OOVER /YES, KILL HIM
IOF
JMS I OUTHND /WRITE ONE BLOCK BUFFER
4200
4400
OBLK, 0
JMP I [DERR /DEVICE ERROR
ISZ OBLK /BUMP OUTPUT BLOCK
ISZ BLKCNT /AND COUNT OF BLOCKS SO FAR
JMS OSETUP /RESET POINTERS FOR NEXT BUFFER
ION
JMP CCIF
O2, DCA I OPTR1 /NORMAL PACKING IS EASY!
ISZ OPTR1 /BUMP POINTER
CCIF, HLT /FILLED WITH CIF CDF
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, DCA OPNFLG /HE BLEW IT - KILL THE FILE!!
TAD DEVHLD
IOF
CIF 10
JMS I USR
4
ONMTMP
0 /LENGTH OF ZERO TO DELETE
O7600, 7600 /IGNORE ERRORS
ERROR1 /BECAUSE WE ALREADY KNOW ABOUT THEM
OSETUP, 0 /RESET ALL THE POINTERS (WHAT FUN!)
TAD OBLK-1
DCA OPTR1
TAD OBLK-1
DCA OPTR2
CLA CLL CMA RTL
DCA O3
TAD O7600
DCA OCHCT
JMP I OSETUP
OPTR1, 0
OPTR2, 0
OLNGTH, 0
OCHCT, 0
PAGE
*5400
OOPEN, JMS I [IOWAIT /WAIT FOR TELETYPE TO FINISH (DECTAPES ARE SLOW!)
JMS I [OPEN /CALL USR, HANDLER; ENTER OUTPUT FILE
YINT, OUTBLK-1 /OUTPUT HANDLER BLOCK
3 /MONITOR 'ENTER' CODE
YBLK, JMP TTYOUT /'OPEN OUTPUT TTY:'
JMP OCLCHK /ERROR ON ENTER - SEE IF FILE ALREADY OPEN
JMS I [DISMISS /KICK USR OUT
TPUSHF /SAVE NAME AND OTHER CRAP
NAMLOC
TPOPF
ONMTMP
TAD STBLK /STARTING BLOCK
DCA I (OBLK
TAD FLNGTH /-MAXIMUM ALLOWABLE LENGTH
DCA I (OLNGTH
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 ALREADY SET
ERROR1 /NO OUTPUT FILE TO RESTORE
CDF 10
ISZ ECHFLG /SKIP IF NO ECHO
TAD IBLK+2
DCA I (OUTECH /SET OUTPUT ROUTINE
TAD (OCHAR /POINTER TO FILE OUTPUT ROUTINE
CIF CDF 10
DCA I [OUTDEV
ION
JMP I [PROC /FINISH THE LINE
TTYOUT, TAD [OUTL /SWITCH OUTPUT TO TELETYPE (INTERRUPT)
JMP .-5
FILEST, TAD I XCHAR /HERE'S WHERE FILES START!!
DCA CHAR /GET NEXT CHAR
CDF
TAD (604 /SET '.FD' ASSUMED EXTENSION
DCA EXTENSION
TSPNOR /SKIP SPACES
TAD CHAR /SAVE COMMAND CHAR
TPUSHA
TGETC
TESTRM /GO TO END OF COMMAND WORD
SKP CLA
JMP .-3
TPOPA
TSORTJ /GO DO COMMAND
FILIST-1
FILGO-FILIST
ERROR1 /OOPS - BAD 'O' COMMAND
ICHAR, 0 /GET A CHARACTER FROM A FILE
CLA CLL /MAKE SURE
ISZ INCHT /DO WE NEED ANOTHER BUFFER?
JMP I RDPTR /NO, UNPACK THE CHARACTER
IOF
JMS I INHND /YES, GO GET IT
0200
4000
IBLK, 0
SMA CLA /ONLY BOTHER WITH FATAL ERRORS
SKP CLA
JMP I [DERR /WE'VE GOT ONE
ION
ISZ IBLK /BUMP TO NEXT BLOCK
TAD IBLK-1 /AND RESTORE POINTERS
DCA IPNTR
TAD [7200
DCA INCHT
ICHAR1, TAD I IPNTR /STRAIGHTFORWARD UNPACK ROUTINE
JMS RDPTR /DO COMMON CRAP
ICHAR2, TAD I IPNTR /SAVE LEFT HALF FOR LATER
AND [7400
DCA ITEMP
ISZ IPNTR /INCREMENT TO NEXT WORD
TAD I IPNTR /ANOTHER EASY ONE
JMS RDPTR
ICHAR3, TAD I IPNTR /THIS IS THE TRICKY ONE!
ISZ IPNTR /GET LOW-ORDER HALF
AND [7400
CLL RTR /SHIFT RIGHT
RTR
TAD ITEMP /GET HIGH-ORDER HALF (REMEMBER?)
RTR /SHIFT SOME MORE
RTR
JMS RDPTR /GOT IT!
JMP ICHAR1 /1-2-3-1-2-3-1-2-3 ...
RDPTR, 0 /IF YOU DIDN'T KNOW, 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 .+5 /NO
DCA IPNFLG /YES, CLEAR OPEN FILE FLAG
CDF 10 /AND SET UP CLEVER KLUDGE
TAD (EOF /TO CHECK FOR A STUPID
DCA I [INDEV /'ATTEMPT-TO-READ-PAST-EOF'!
TAD [232 /PASS ^Z TO PROGRAM (MIGHT COME IN HANDY)
CIF CDF 10
JMP I ICHAR
ITEMP, 0
IPNTR, 0
INCHT, 0
ONMTMP, ZBLOCK 4
PAGE
IOPEN, JMS I [IOWAIT /WAIT FOR TELETYPE (DECTAPES ARE STILL SLOW!)
JMS I [OPEN /CALL THAT AMAZING GENERAL-PURPOSE SUBROUTINE
INBLK-1
2 /MONITOR 'LOOKUP'
JMP TTYIN /'OPEN INPUT TTY:'
ERROR1 /WHOOPS - FILE NOT FOUND
JMS I [DISMISS /BOOT THE USR OUT
TAD STBLK /SET POINTERS AND OTHER CRAP
DCA I (IBLK
CLA CLL CMA
DCA IPNFLG
CLA CLL CMA
DCA I (INCHT
IRST, TAD IPNFLG /'OPEN RESTORE INPUT' COMES HERE
SNA CLA /FLAG IS SET ALREADY IF 'OPEN INPUT'
ERROR1 /NO INPUT FILE TO RESTORE
TAD (ICHARF /SET I/O POINTERS
CIF CDF 10
DCA I [INDEV
ISZ ECHFLG /AND ECHO MODE
TAD [PRINTC
DCA I [2163
ION
JMP I [PROC
TTYIN, TAD [X133 /'OPEN INPUT TTY:'
JMP TTYIN-7
MPUSHA, 0 /PUSH THE AC ON THE STACK
JMS FLDSET /CALLED FROM EITHER FIELD
DCA ACDF
CDF 10 /DO SOME CRAZY, MIXED-UP POINTER SCRAMBLING
TAD I (PDLXR
DCA TEM7
CMA
TAD TEM7
DCA I (PDLXR
TAD TEM7
CIA CLL
TAD I [BUFR
SZL CLA
PDERR, ERROR1 /PUSHDOWN OVERFLOW
TAD I (PDLXR
CDF
DCA AUTO2
TAD ATEM
DCA I TEM7
ACDF, CIF CDF
JMP I MPUSHA
MPD2, 0 /PUSH 4 WORDS ON THE STACK
TAD I MPD2 /GET POINTER TO FIRST WORD
TAD [3 /PUSH IN REVERSE ORDER
DCA MPD3
ISZ MPD2
JMS FLDSET
DCA FCDF
CDF
TAD [-4
DCA XCNTR
FCDF, HLT /CHANGE FIELD TO CALLING FIELD
TAD I MPD3 /GET THE NEXT WORD
CIF CDF
JMS MPUSHA /PUSH IT
CLA CLL CMA /BACK UP POINTER
TAD MPD3
DCA MPD3
ISZ XCNTR
JMP FCDF /GET THE NEXT ONE
TAD FCDF
DCA .+1
0 /RESTORE CALLING FIELD
JMP I MPD2
MPD3, 0 /POP 4 WORDS
CLA CLL CMA /GET POINTER-1
TAD I MPD3
DCA AUTO3
ISZ MPD3
TAD (CDF
RDF
DCA FCIF
TAD [-4 /FOUR WORDS
DCA XCNTR
CDF
JMS MPOPA /GET ONE
FCIF, CDF
DCA I AUTO3 /PUT IT AWAY
ISZ XCNTR /ALL DONE?
JMP FCIF-2 /NO, GET ANOTHER
CLL CLA CML RTL /YES, CHANGE CDF TO CIF CDF
TAD FCIF
DCA .+1
0 /CHANGE FIELD AND EXIT
JMP I MPD3
MPOPA, 0 /POP A WORD
JMS FLDSET /(THIS ONE'S EASY)
DCA ACIF
CDF 10
ISZ I (PDLXR
CDF
TAD I AUTO2
ACIF, CIF CDF
JMP I MPOPA
FLDSET, 0
DCA ATEM
TAD FCDF+2
RDF
JMP I FLDSET
XRESTOR,TAD LISTFLG /PART OF ERROR ROUTINE TO RESET I/O TO TELETYPE
SZA CLA
JMS I [SWAPIN /RESTORE CORE SWAPPED BY DIRECTORY LIST
CIF CDF 10
TAD [PRINTC /'OPEN INPUT TTY:,ECHO;OPEN OUTPUT TTY:'
DCA I [2163
TAD [X133
DCA I [INDEV
TAD [OUTL
DCA I [OUTDEV
JMP I .+1
RECOVX+3
MSORTC, 0 /CHECK FOR TERMINATOR
CIF CDF 10
JMS I [TERMER
ISZ MSORTC
JMP I MSORTC
PAGE
/LIBRARY COMMAND PROCESSOR
/****** STORAGE ALLOCATION MAP ******
/***** *****
/* 3600 FILES (OUTPUT AND RESTORE)
/* 4000 INPUT BUFFER (PAGE 1)
/* 4200 INPUT BUFFER (PAGE 2)
/* 4400 OUTPUT BUFFER (PAGE 1)
/* 4600 OUTPUT BUFFER (PAGE 2)
/* 5000 INPUT HANDLER
/* 5200 OUTPUT HANDLER
/* 5400 FILES (INPUT AND OPEN)
/*
/* 5600 PUSHDOWN LIST CONTROLS
/* 6000 NAME, GTMON, DISMISS, IOWAIT
/* 6200 HANDAD, COMPARE
/* 6400 LOWLIB, SAVER, RETURN
/* 6600 CHAINER, FETCHER, GOSUB
/* 7000 LIBRARIAN
/* 7200 MISCELLANEOUS
/* 7400 LIBRARY HANDLER
/***** *****
/************************************
NAME, 0 /READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV'
JMS DISMIS /'GETC' WON'T WITH THE USR IN CORE
TAD (5723 /CODE FOR 'DSK:'
DCA NEWDEV /(DEFAULT DEVICE)
DCA NEWDEV+1
JMS GNAME /GET FIRST PART (MIGHT BE DEVICE)
TAD ["A-": /WAS IT A DEVICE?
SZA CLA
JMP I NAME /NO, ALL SET UP
TGETC /YES, MOVE PAST ':'
TAD NAMLOC /MOVE TO DEVICE AREA
DCA NEWDEV
TAD NAMLOC+1
JMP NAME+4 /GET FILENAME
GNAME, 0 /READ A NAME INTO 'NAMLOC'
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
TSPNOR
SKP
NAMEC, TGETC /MAIN LOOP
TAD CHAR /LOWER FIELD COPY, OF COURSE
TAD [-". /EXTENSION?
SNA
JMP PERD /YES, CLEAR DEFAULT EXTENSION
TAD [".-", /COMMA?
SNA CLA
JMP ECHCHK /YES, CHECK FOR ECHO
ECHGO, JMS DECODE /MUST BE A-Z, 0-9
JMP I GNAME /IT WASN'T, MUST BE END OF NAME
SZL /RESTORE CHARACTER
TAD [57
IAC
DCA DECODE /TEMPORARY STORAGE
TAD NAMECT /NO MORE THAN 6 CHARACTERS/NAME
TAD [-6
SMA CLA
JMP NAMEC
TAD NAMECT /BUILD POINTER TO CHARACTER POSITION
CLL RAR
TAD NMBASE
DCA TT
TAD DECODE /LEFT OR RIGHT HALF?
SZL
JMP .+4
CLL RTL /LEFT, SHIFT OVER
RTL
RTL
TAD I TT /ADD IN OTHER HALF
DCA I TT
ISZ NAMECT /BUMP COUNT
JMP NAMEC /CONTINUE LOOP
PERD, TAD NAMLOC /FOUND A PERIOD IN STRING
SZA CLA
ISZ PERDSW
ERROR1 /DOUBLE PERIODS OR NO FILE NAME
DCA EXTENSION /CLEAR EXTENSION
TGETC /MOVE PAST PERIOD
ISZ NMBASE /FAKE OUT POINTERS
TAD [4
JMP NAMEC-3
ECHCHK, TGETC /MOVE PAST COMMA
TSPNOR
TAD CHAR /MUST BE FOLLOWED BY 'ECHO'
TAD [-"E
SZA CLA
JMP I GNAME
DCA ECHFLG /SET ECHO FLAG
TGETC /MOVE TO END OF WORD
JMS DECODE
JMP I GNAME
CLA CLL
JMP .-4
DECODE, 0 /CHECK FOR A-Z, 0-9
TAD CHAR
TAD [-"9-1
CLL
TAD ["9+1-"0
SZL
JMP DCDYES
TAD ["0-"Z-1
CLL CML
TAD ["Z-"A+1
SNL
DCDYES, ISZ DECODE /IT WAS!
JMP I DECODE
NMBASE, 0
PERDSW, 0
NAMECT, 0
TT, 0
IOWAIT, 0 /WAIT FOR TELETYPE TO FINISH
ION
CDF 10
TAD I (TELSW /BUSY FLAG IS ZERO WHEN THROUGH
SZA CLA
JMP .-2
CDF
IOF
JMP I IOWAIT
GTMON, 0 /LOCK THE USR IN CORE
IOF /(NOP IF ALREADY IN CORE)
CIF 10
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
TAD USR /CHECK POINTER TO FIND OUT
SPA CLA
JMP I DISMIS
IOF
CIF 10
JMS I USR
11
TAD ECHGO+10 /RESET POINTER
DCA USR
JMP I DISMIS
PAGE
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 AUTO5
TAD I AUTO5 /(SET BY 'COMPARE')
DCA DEVNO /MOVE DEVICE # (FOR SAVE AND CLOSE)
TAD AUTO5 /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 /WE MUST CALL THE USR, MIGHT AS WELL LOCK IT IN
RETRY, TAD NEWDEV /MOVE DEVICE NAME FOR MONITOR CALL
DCA DEVC
TAD NEWDEV+1
DCA DEVC+1
TAD I SLOT /MOVE LOAD POINT
DCA DLOAD
CIF 10
JMS I USR /CALL MONITOR (ALREADY IN CORE)
TABCPT, 1
DEVC, 0
0
DLOAD, 0
ERROR1 /DEVICE NOT AVAILABLE OR TWO PAGE HANDLER
CLL
TAD DLOAD /ENTRY POINT FOR HANDLER
TAD [200 /IF THIS HANDLER IS IN PAGE 7600,
SZL CLA /DON'T BOTHER TO 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 OF INDEFINITE LENGTH
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 AUTO5 /RETURN IF MATCH
TAD I COMPARE /RETURN IF NO MATCH
ISZ COMPARE
DCA AUTO6
AGAIN, TAD I AUTO5 /COMPARE TWO WORDS
CIA
TAD I AUTO6
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
MPRINTC,0 /CROSS-FIELD 'PRINTC'
CIF CDF 10
JMS I (CPRNT
JMP I MPRINTC
TABCNT, 0 /TAB COUNTER (ONLY PRINTING CHARACTERS)
TAD (-15 /7-BIT CR MEANS RETURN ONLY
SNA
JMP CRONLY
TAD [-200 /CHECK FOR CR
SNA
JMP NEWLIN /TYPE CR,LF
ISZ TABCNT
TAD (215-240
SMA
ISZ I TABCPT /IT PRINTS, INCREMENT COUNT
NOP /IT JUST MIGHT SKIP
TAD [240
CIF 10
JMP I TABCNT
CRONLY, TAD [215
CIF 10
JMS I [PRINTX
DCA I TABCPT
TAD [200 /NULL FOR DELAY
JMP TABCNT+1
NEWLIN, DCA I TABCPT
JMP CRONLY-2
COMLIST,"S /SAVE
"C /CALL
"R /RUN
"L /LIST
"D /DELETE
"G /GOSUB
" /FAKE A 'LIBRARY RETURN' WITH A SPACE
"E /EXIT
FILGO, IOPEN
OOPEN
OCLOSR
RESTOR
PAGE
/ACTUAL LIBRARY PROCESSOR
/STARTING WITH COMMAND DECODE:
LOWLIB, CDF 10 /CLEAR SWITCH FOR NORMAL RETURN
DCA I [GOSWITCH /I.E. TO 'PROC' FOR REST OF LINE
TAD I XCHAR /MOVE CURRENT CHARACTER DOWN
CDF
DCA CHAR
TAD CHAR /SAVE FOR COMMAND SORT
TPUSHA
TAD [603 /'.FC' ASSUMED EXTENSION
DCA EXTENSION
SKP CLA /MIGHT BE A TERMINATOR ALREADY
TGETC /MOVE TO END OF COMMAND WORD
TESTRM
SKP
JMP .-3
TPOPA /RESTORE COMMAND CHAR
TSORTJ /AND BRANCH TO APPROIATE ROUTINE
COMLIST-1
COMGO-COMLIST
ERROR1 /SORRY, CHARLIE!
COMGO, SAVER
FETCHER
CHAINER
LIBRARIAN
DELETE
GOSUB
RETURN
C7600, 7600
SAVER, JMS I [NAME /GET NAME FOR SAVE
JMS SAVE /DO IT
JMP EXIT /EASY, WASN'T IT?
SAVE, 0 /CALLED BY 'SAVE' AND 'GOSUB'
JMS OCHK /CLOSE OUTPUT FILE TO AVOID TROUBLE
TAD [NAMLOC /POINTER TO NAME
DCA SAVEPT
CDF 10
TAD I [BUFR /GET PROGRAM LENGTH
CDF
DCA I [207 /SAVE IT WITH THE PROGRAM
JMS I [GTMON /CALL THE MONITOR
JMS I [HANDAD /AND THE HANDLER
LIBBLK-1
TAD I [207 /SAVED LENGTH, REMEMBER?
AND C7600 /MASK OFF
CLL RAR /CONVERT TO PAGES
DCA BLOCK /FOR HANDLER
TAD BLOCK /ROUND UP TO BLOCKS
TAD [100
AND C7600
CLL RTR
RAR
DCA RECORD /FOR MONITOR 'ENTER'
TAD RECORD /GET DESIRED LENGTH
TAD DEVNO /(SET BY 'HANDAD')
CIF 10
JMS I USR /ENTER OUTPUT FILE
3
SAVEPT, NAMLOC
0
ERROR1 /NO ROOM ON DEVICE
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
NAMLOC
SAVBLK, 0
ERROR1 /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
CLL CML RAR /COMPUTE FUNCTION WORD
IAC /SET TO SEARCH FORWARD
TAD BLOCK /HOW MUCH TO WRITE
DCA BLLL
JMS I LIBHND
BLLL, 0 /WRITE (BLOCK) BLOCKS FROM FIELD 0
200 /FROM 200 UP
POINT4, 0
JMP I [DERR /GO COMPLAIN ABOUT DEVICE
JMP I SAVE
LIBLEN, 0
LIBDEV, ZBLOCK 2
RECORD, 0
BLOCK, 0
RETURN, TPOPA /GET BACK ALL THE JUNK WE SAVED
CDF 10 /FOR THE LAST GOSUB
DCA I XCHAR /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
OCLOSR, JMS I [OCLOSE /CLOSE OUTPUT FILE
CIF CDF 10
JMP I [PROC /ANOTHER EASY ONE!
PUTDEV, 0 /TELL THE MONITOR A HANDLER IS IN OR OUT
TAD I PUTDEV /GET POINTER TO DEV # AND ENTRY
DCA RECORD
TAD I RECORD /DEVICE #
ISZ RECORD /BUMP POINTER TO ENTRY
TAD (7646 /MONITOR TABLE
DCA BLOCK /POINTER TO 'HANDLER-IN-CORE' FLAG
TAD I RECORD /FLAG IS HANDLER ENTRY
CDF 10 /TABLE IS IN FIELD 1
DCA I BLOCK
CDF
ISZ PUTDEV
JMP I PUTDEV
PAGE
/LOOKUP AND LOAD ROUTINES
CHAINER,IAC /THESE ALL DO THE SAME THING
GOSUB1, IAC /AND THEN GO TO DIFFERENT PLACES
FETCHER,IAC
CDF 10
DCA I [GOSWITCH
CDF
LOAD, JMS I [OPEN /CALL THE HANDLER AND LOOKUP THE FILE
LIBBLK-1
2
JMP .+5 /TTY: NOT A DIRECTORY DEVICE
ERROR1
JMS I [DISMISS
JMS I (GETDEV /GET DEVICE TYPE
SMA CLA
ERROR1 /NOT A DIRECTORY DEVICE
TGETLN /SOME COMMANDS HAVE LINE NUMBERS
LOADGO, JMS I [DISMISS /ONLY USED BY 'RETURN'
TAD STBLK /BLOCK TO READ FROM
DCA POINT6
TAD AUTO2 /GET PUSHDOWN POINTER
TAD [-200 /DIDDLE IT
AND [7600
CLL RAL
RTL
RTL
TAD FLNGTH /NOW COMPARE WITH LENGTH OF FILE
SPA CLA
JMP PDERR /PROGRAM TOO LONG
CDF 10
CLA CLL CMA RAL /(=-2)
TAD I [GOSWITCH /IS THIS A GOSUB?
SZA CLA
JMP .+7 /NO, SKIP THIS GARBAGE
TAD I XCHAR /YES, SAVE PROGRAM NAME, ETC.
CDF
TPUSHA
TAD [215
CDF 10
DCA I XCHAR
CDF
TAD FLNGTH /COMPUTE FUNCTION WORD
CIA
CLL RTL
RTL
RTL
CLL CML RAL /SET TO SEARCH FORWARD
DCA LENF1
JMS I LIBHND /GET THE PROGRAM
LENF1, 3600
0200
POINT6, 0
JMP I [DERR
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
TAD I [207 /MOVE PROGRAM LENGTH
CDF 10
DCA I [BUFR
CDF
JMP EXIT /GO TO APPROPRIATE ROUTINE
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 SAVE /SAVE FILE (THIS WILL LEAVE USR IN CORE)
TAD [603 /RESET EXTENSION TO 'FC'
DCA EXTENSION
JMS I [DISMISS /KICK MONITOR OUT TO SAVE STARTING BLOCK
TAD LIBFIL
NOSAVE, TPUSHA /'LIBFIL' STILL IN AC
TAD LIBLEN
TPUSHA
TPUSHF
LIBDEV
JMP GOSUB1
XTSPNOR,0 /DUPLICATE UPPER FIELD ROUTINE
TAD CHAR
TAD [-240
SZA CLA
JMP I XTSPNOR
TGETC
JMP XTSPNOR+1
TTYTXT, DEVICE TTY /HANDY THING TO HAVE
MSORTJ, 0 /ANOTHER DUPLICATE
CIA
DCA ATEM
TAD I MSORTJ
ISZ MSORTJ
DCA AUTO4
TAD I AUTO4
SPA
JMP MSEX
TAD ATEM
SZA CLA
JMP .-5
TAD AUTO4
TAD I MSORTJ
DCA ATEM
TAD I ATEM
DCA ATEM
JMP I ATEM
MSEX, ISZ MSORTJ
CLA CLL
JMP I MSORTJ
FILIST, "I /INPUT
"O /OUTPUT
"C /CLOSE
"R /RESTORE
PAGE
/THIS SECTION DOES THE DIRTY WORK OF LISTING
/ALL "FC"'S AND "FD"'S ON THE DEVICE REFERENCED
/IT WAS FUN...
LIBRARIAN, JMS I [NAME /GET DEVICE TO LIST
JMS I [HANDAD /GET THE HANDLER
LIBBLK-1
JMS I [DISMISS /KICK OUT USR (IN CASE HANDAD CALLED IT)
JMS GETDEV /FIND DEVICE TYPE
SMA CLA
ERROR1 /CAN'T LIST A NON-DIRECTORY DEVICE
JMS I SHNDLR /SWAP OUT CORE TO MAKE ROOM FOR DIRECTORY
4200
1000
40 /SYSTEM SCRATCH AREA
JMP I [DERR /WHOOPS!
CLA IAC /SET FLAG TO SWAP BACK IN
DCA LISTFLG
CLL CLA IAC /DIRECTORY BEGINS WITH BLOCK 1
BLOKLP, DCA LBLOCK
IOF
JMS I LIBHND
0200
1000
LBLOCK, 1
JMP I [DERR
TAD (1004 /FIRST 5 WORDS ARE INFORMATION
DCA AUTO4
LOOP2, TAD AUTO4 /SAVE FOR LATER
DCA AUTO8
TAD AUTO4
DCA LIBX
TAD I AUTO4 /LOOKING FOR .FC & .FD FILES
SNA CLA
JMP PATCH /ZERO FILE
ISZ AUTO4
ISZ AUTO4
TAD I AUTO4 /PICK UP EXTENSION
DCA LBLOCK
TAD I (1004 /WASTE WORDS (NEGATIVE)
CIA /THANKS FOR TELLING US, RITCHIE
TAD AUTO4 /SKIP TO LENGTH
DCA AUTO4
TAD I AUTO4 /ZERO LENGTH MEANS TEMPORARY FILE
SNA
JMP LOOP3 /IGNORE SUCH THINGS
CLL CIA
DCA FLNGTH /SAVE POSITIVE LENGTH
TAD NAMLOC /IF A NAME WAS GIVEN, SEE IF WE
SNA CLA /HAVE REACHED IT YET
JMP TESTGO /NO NAME
JMS I [COMPARE /COMPARE THIS NAME WITH ARG
-4
LIBX, 0
NAMLOC-1
JMP LOOP3 /NON-MATCHING
DCA NAMLOC /WE FOUND IT, DON'T CHECK ANY MORE
TESTGO, TAD LBLOCK /COMPARE EXTENSION
TAD (-604 /DO WE WANT THIS ONE?
SZA
IAC
SZA CLA
JMP LOOP3 /GUESS NOT
DIRLIST,CLA CLL CMA RTL /PRINT 3 WORDS
DCA COUNT
TAD I AUTO8/SET BEFORE THIS
JMS NPACK /PRINT 2 CHARS
ISZ COUNT
JMP .-3
TAD (".
TPRINTC
TAD I AUTO8 /PRINT EXTENSION
JMS NPACK
TAD (TABLE /SET UP FOR DECIMAL LENGTH PRINT
DCA POINT
ZLOOP, DCA ZERSW
DCA COUNT
NLOOP, TAD I POINT /FINISHED ALL POWERS OF 10?
SNA
JMP NEND /YES, ALL DONE
TAD FLNGTH /NO, SUBTRACT THIS POWER
SPA /UNDERFLOW?
JMP DIGIT /YES, PRINT THIS DIGIT
DCA FLNGTH /NO, GO THROUGH THE LOOP AGAIN
ISZ COUNT /ADD ONE TO THIS DIGIT
JMP NLOOP /ANOTHER DIVIDE CYCLE
DIGIT, CLA CLL /CRAP IN AC
ISZ POINT /NEXT POWER OF TEN
TAD COUNT /IF THIS DIGIT IS ZERO,
ISZ ZERSW /AND NO OTHER DIGITS HAVE BEEN NON-ZERO,
SZA /PRINT A SPACE INSTEAD
JMP NPRNT
TAD [240
TPRINTC
JMP ZLOOP
NPRNT, TAD [260 /CHANGE TO ASCII
TPRINTC
CLA CLL CMA /SET ZERO SWITCH
JMP ZLOOP
NEND, TAD [215 /DONE WITH THIS LINE (WHEW!)
TPRINTC
JMP LOOP3
PATCH, ISZ AUTO4 /BUMP PAST EMPTY LENGTH
LOOP3, ISZ I LBLOCK-1 /DONE WITH THIS BLOCK?
JMP LOOP2 /NO, KEEP GOING
LEXIT, JMS I [IOWAIT /WAIT FOR I/O
TAD I [1002 /LINK TO NEXT BLOCK
SZA /LAST BLOCK?
JMP BLOKLP /NO, GET THE NEXT
JMS SWAPIN /YES, RESTORE SWAPPED CORE AND EXIT
JMP EXIT
GETDEV, 0 /GET DEVICE TYPE FROM MONITOR TABLE
TAD [7757 /DCB-1
TAD DEVNO
DCA COUNT
CDF 10
TAD I COUNT
CDF
JMP I GETDEV
DECIMAL
TABLE, -1000
-100
-10
-1
0
OCTAL
POINT=NEWDEV
ZERSW=NEWDEV+1
POINT7, 0
COUNT, 0
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
CLA CLL CMA /INITIALIZE ECHO FLAG TO OFF
DCA ECHFLG
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 (IT FALLS THROUGH ON ERROR)
TAD DEVNO /DO THE CALL
CIF 10
JMS I USR
CALL, 0
NAMPT, NAMLOC
LNGTH, 0
JMP OTHER-2 /LET THE CALLING ROUTINE DECIDE ERROR PROCEDURE
TAD LNGTH /MOVE PARAMETERS TO PAGE ZERO
DCA FLNGTH
TAD NAMPT
DCA STBLK
JMP OTHER-3 /AND TAKE NORMAL RETURN
ERROR, 0 /LOWER FIELD ERROR ROUTINE
JMS I [DISMIS /MAKE SURE
TAD ERROR /FAKE OUT ERROR ROUTINE
CIF CDF 10 /AND GO TO IT
DCA I (ERR2
JMP I (ERR2+1
DELETE, JMS I [NAME /DELETE IS AN EASY ONE (THANK GOD!)
JMS I [GTMON
JMS I [HANDAD
LIBBLK-1
JMS OCHK /CLOSE ANY OPEN OUTPUT FILE
CIF 10 /DELETE THE FILE
TAD DEVNO
JMS I USR
4
NAMLOC
0
ERROR1
DCA LIBFIL /IN CASE HE JUST DELETED THIS PROGRAM
JMP EXIT
OCHK, 0 /IF ANY FILE EXISTS, CLOSE IT
TAD DEVHLD
SZA CLA
JMS OCLOSE
JMP I OCHK
SWAPIN, 0 /RESTORE CORE AFTER DIRECTORY LIST
DCA LISTFLG
IOF
JMS I SHNDLR
200
1000
40
DERR, ERROR1 /DEVICE ERROR
JMP I SWAPIN
NPACK, 0 /STANDARD 6-BIT UNPACK ROUTINE
DCA OCHK
TAD OCHK
RTR
RTR
RTR
JMS XFORM
TAD OCHK
JMS XFORM
JMP I NPACK
XFORM, 0
AND [77
SZA /PRINT SPACES FOR NULLS
TAD (-40
SPA
TAD [100
TAD [240
TPRINTC
JMP I XFORM
OCLCHK, TAD OPNFLG /MAKE 'OPEN OUTPUT' WITH AN ALREADY OPEN FILE
SNA CLA /THE SAME AS 'OUTPUT CLOSE;OPEN OUTPUT'
ERROR1
JMS OCLOSE
TAD (YINT /FAKE OUT 'OPEN'
DCA OPEN
JMP OTHER
MGETLN, 0 /CROSS-FIELD FAKE
CIF CDF 10
JMS I (PGETLN
JMP I MGETLN
FOCTXT, FILENAME FOCAL.TM /USED BY 'GOSUB'
XGETC, 0 /ANOTHER FAKE
CIF CDF 10
JMS I (MGETC
TAD I XCHAR
CDF
DCA CHAR
JMP I XGETC
PAGE
$