Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
foropn.mac
There are 27 other files named foropn.mac in the archive. Click here to see a list.
SEARCH FORPRM
TV FOROPN OPEN & CLOSE ,7(3256)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1983
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
COMMENT \
***** Begin Revision History *****
1100 CKS 5-Jun-79
New
1272 DAW 19-Feb-81
A few low-risk changes to support extended addressing.
1273 EDS 19-Feb-81 Q10-04732
Add /RECL to dialog keyword table.
1274 EDS 19-Feb-81 Q10-04574
Add support code for TAPEMODE='ANSI-ASCII'.
1277 JLC 23-Feb-81
Added code to calculate bytes/word (BPW) on -10,
plus used it to calculate rounded record size (RSIZR)
for use in %IREC.
1305 JLC 26-Feb-81
Moved the RSIZR code to its correct resting place in FIXDEF.
1306 DAW 26-Feb-81
New arg list format passed by %SAVE.
1307 EDS 26-Feb-81
Put ACCESS back in list of valid switches for DIALOG.
1310 DAW 26-Feb-81
Full words in DDB for ERR=, END=, IOST=, AVAR= addresses.
1312 EDS 27-Feb-81
Remove edit 1307 as it causes generation number skew on TOPS-20
with certain combinations of ACCESS in DIALOG different from
the ACCESS that was specified in the OPEN.
1313 JLC 3-Mar-81
Added code to handle magtape op's better
1316 JLC 5-Mar-81
Changed refs to D%LIO to D%LOUT. Major code changes
for magtape i/o and proper direction switching.
1325 JLC 9-Mar-81
Yet more changes for magtape I/O for the -10
1326 JLC 10-Mar-81
Minor bug fix in -10 open.
1333 JLC 11-Mar-81
Magtape patches (mostly typos) for the -10
1336 JLC 12-Mar-81
Fix more typos; change name of CLOSE to CLOSE0.
1353 JLC 18-Mar-81
More magtape op fixes. Set I/O direction flags after
calling routine. Install backing over EOF if program
reads to EOF then writes. Fix empty buffer problem
for OSWTCH.
1354 JLC 18-Mar-81
OSWTCH fix. Must truncate file at previous block to
get the monitor to not round word count up to blocksize.
1356 JLC 18-Mar-81
Add dump mode write to oswtch.
1361 JLC 20-Mar-81
Put -20 null file prevention code in IF20.
1363 JLC 24-Mar-81
Commented out code for common tty ddbs.
1364 CKS 24-Mar-81
Don't do RLJFN if the GTJFN failed
1365 JLC 25-Mar-81
Move code to set device index for -10 up slightly in DOOPEN
so magtapes will know about it after half-open (seqinout).
Typo in dump mode output FILOP.
1370 EDS 26-Mar-81 Q10-04566
Make IMAGE and BINARY mode I/O illegal on TTYs.
1375 EDS 31-Mar-81 Q10-05002
Fix FILOP. for CLOSE DISPOSE='RENAME', remove monitor
version dependent code.
1376 JLC 31-Mar-81
Fix more code in -10 OSWTCH, did not do correct thing for
null files or pointer at beginning of buffer.
1400 JLC 02-Apr-81
Typo - PUSHJ should use P as reg and not 0.
1401 JLC 03-Apr-81
Make sure block number never goes negative in OSWTCH.
1402 JLC 06-Apr-81
Avoid doing dump-mode truncation for magtape - not necessary.
Move turning on CRLF suppression from OSW to %IREC.
1407 JLC 07-Apr-81
Move device-dependent I/O so it gets called before buffers
are set up, so BLOCKSIZE will work.
1410 JLC 07-Apr-81
Move setup of record buffer to FORIO in preparation for
input/output separation of record buffer.
1411 DAW 08-Apr-81
Use IJFN and OJFN instead of JFN field in DDB.
1412 JLC 09-Apr-81
Uncomment the commented-out tying of TTYs to 1 DDB,
as multiple channels to the same DDB doesn't work on
the -10.
1416 JLC 10-Apr-81
Removed RSIZR code, was unnecessary.
1417 DAW 10-Apr-81
Type traceback info if OPEN arg error caused user to
get to DIALOG mode.
1420 JLC 10-Apr-81
Deallocation of separate record buffers.
1421 JLC 10-Apr-81
Typo in edit 1407. DF was not set up
when DSKSET was called.
1422 JLC 13-Apr-81
External symbol %TRACE.
1423 DAW 13-Apr-81
Put %SETD in FORIO (was in FOROPN).
1426 JLC 14-Apr-81
Changed error reporting in OSWTCH-10 to fatal errors.
Restore .JBFF in DOOPEN upon FILOP failure, caused
problems with SORT.
1427 JLC 15-Apr-81
Changed RSIZ to be a word (RSIZE) in the DDB.
1433 DAW 16-Apr-81
Show possible switches user can type when he gets to DIALOG
mode on the -20 and types a question mark.
1434 DAW 16-Apr-81
Check for READONLY set and if so, change ACCESS=
'RANDOM' to 'RANDIN', 'SEQINOUT' to 'SEQIN'.
1441 JLC 17-Apr-81
Remove all refs to D%RSIZ, no longer needed.
1442 DAW 17-Apr-81
Remove /LABELS and /TAPEMODE from OPEN and DIALOG options.
1451 JLC 23-Apr-81
Special handling of dump mode I/O in OSWTCH. Removal of
BAKEOF call in OSWTCH for magtape (reading to EOF, followed
by write, will leave the tape mark).
1453 JLC 24-Apr-81
Move -10 code to set up BPW, so that BLOCKSIZE setup will work.
1463 JLC 7-May-81
Many major changes. See revhist in FOROTS.MAC.
1464 DAW 11-May-81
Error messages.
1465 JLC 15-May-81
Major changes to -20 I/O.
1473 CKS 21-May-81 Qvarious
Add flags to IOERR macro, I%REC to print current input record with
arrow under current position, I%FMT to do same for current format.
Add I%REC and I%FMT to appropriate messages.
1474 JLC 22-May-81
Fix bug in new -20 open code, can't look at DF before it's set up.
1475 JLC 22-May-81
Minor bug in XXXSET, %GTBLK has no error return.
1476 JLC 26-May-81
Fix bug in non-disk opens, was setting BYTN to large
number which then overflowed.
1477 JLC 27-May-81
In OSWTCH-10, must clear BLKN for magtape if writing after
EOF, since it's a new file.
1502 JLC 28-May-81
Install defensive WAIT operations in magtape code.
1503 JLC 28-May-81
SINR and SOUTR are asymmetric - tape I/O rounds up to
words, so that SINR fails with default (1000 bytes).
Fix: force rounding to words in OPEN.
1505 JLC 01-Jun-81
Don't do extra backspace in MTAISW; data is still there.
1512 BL 5-JUN-81 Q10-05829
Fix omission of <crlf> when output assigned from DSK to TTY.
1513 BL 8-Jun-81 Q10-06193
Fix no error message writing small file to write-locked tape.
1514 JLC 8-Jun-81
Change default "width" of disk output lines from 132 to 72 chars
for NAMELIST and list-directed output.
1515 BL 9-Jun-81
Change JRST to CLSERR in EDIT 1513 to PUSHJ.
1532 DAW 14-Jul-81
OPEN rewrite: Base level 1
1534 DAW 14-Jul-81
Code for TOPS-20 "STATUS='SCRATCH'". Also fix infinite
loop if errors in DIALOG='string'.
1537 DAW 16-Jul-81
Finish TOPS-20 SCRATCH file handling. Fixup TOPS-20
CLOSE code so it works again.
1540 DAW 17-Jul-81
Delete IS from DDB, use IOSTAT variable directly.
Set IOSTAT variable to zero at the start of each IO statement.
Set D%ERR if "?" error in IOERR.
1541 DAW 17-Jul-81
Get rid of D%LIN and D%LOUT.
1542 JLC 17-Jul-81
Delete D%EOF, hopefully forever.
1543 DAW 17-Jul-81
Allow SCRATCH files for devices besides DSK:
1544 DAW 20-Jul-81
Invent "FIXU" to solve problem with /CARRAIGECONTROL.
1545 DAW 20-jul-81
Remove call to %OCRLF at CLOSE time.
1546 JLC 20-Jul-81
Don't suppress initial CRLF in files.
1547 DAW 20-Jul-81
Provide the functionality that %AUXBF used to.
1554 DAW 22-Jul-81
Fix CLOSE /DISPOSE actions; CLOSE keywords different from OPEN.
1556 DAW 22-Jul-81
CLOSE from EXIT.
1560 DAW 28-Jul-81
OPEN rewrite base level 2.
1563 DAW 29-Jul-81
DIALOG='string' lost track of its arg type.
1564 DAW 29-Jul-81
Check conflicts in CLOSE args; use STATUS value if DISPOSE not given.
1565 DAW 29-Jul-81
Default BLANK= correctly.
1570 DAW 30-Jul-81
Don't clear %IONAM in %IOERR anymore - it is used at end of OPEN.
1573 DAW 31-Jul-81
Better error handling for RENAME.
1575 JLC 05-Aug-81
Fixed half-hearted attempt to make DIRECTORY=array work,
implemented separate access bit-setting by device type
in DOOPEN, eliminating need for MTACRK and making
SEQINOUT work in general.
1576 DAW 11-Aug-81
OSWTCH for disk.
1602 JLC 12-Aug-81
Reinserted suppression of initial CRLF for terminals only.
1610 DAW 17-Aug-81
CLOSE /default rename didn't work on the -10
1616 DAW 19-Aug-81
Infinite loop on TOPS-10 if non-disk OPEN failed.
1617 DAW 19-Aug-81 Q10-5204
Problem with DISPOSE='SUBMIT'
1620 DAW 20-Aug-81
Fix TOPS-20 generation skew problem in DIALOG mode
1621 DAW 20-Aug-81
CLOSE/ RENAME/ DELETE on the -10.
1625 DAW 21-Aug-81
Get rid of "DF".
1640 DAW 26-Aug-81
Always use EXTENDED GTJFN to get ";FORMAT:F"
This edit for future use for magtape format specifier.
Part of edit (actual format specifier) is REPEAT 0'd
until we allow magtape format to be specified in OPEN
statement.
1641 DAW 26-Aug-81
OPEN STATUS='NEW' FAILED ON TOPS-20
1642 JLC 27-Aug-81
Replace %FILOP calls with FILOPs.
1643 JLC 27-Aug-81
Change IRBUF & ORBUF into full word byte pntrs, so
releasing them must use only right half addr.
1650 BL 31-Aug-81
Fix RECORDSIZE applied to NAMELIST & LIST directed output.
1652 DAW 1-Sep-81
Fix DUMP MODE I/O on TOPS-10.
1654 BL 1-Sep-81
Typo in EDIT 1650.
1655 DAW 1-Sep-81
Clear .RBALC after OPEN FILOP.
1660 DAW 3-Sep-81
Use low channels if all extended ones are taken.
1663 JLC 8-Sep-81
Write out last buffer for magtape on -10. Normally done
by monitor, but if no data, no tape mark gets written unless
the initial OUT is done.
1664 DAW 8-Sep-81
Don't call DOOPEN twice if DDB's get consolidated at OPENX.
1665 DAW 8-Sep-81
D.TTY = DDB address of the controlling TTY: (if OPEN yet..)
1666 DAW 8-Sep-81
/MODE:IMAGE implies /FORM:F. /FORM:U is a conflict.
1670 DAW 9-Sep-81
Two DSK: files open for append no longer get same DDB.
1672 DAW 9-Sep-81
Was bypassing conflict check for RANDOM and no RECORDSIZE.
1674 DAW 9-Sep-81
Couldn't WRITE to LPT: on the -10 ("IO" bits toggled).
1675 DAW 9-Sep-81
Added code for device conflicts with MODE.
1677 JLC 10-Sep-81
Fixed unmapping of unused pages.
1701 JLC 10-Sep-81
Added SETO for setup to unmap pages
1706 DAW 11-Sep-81
Lots of changes to errors.
1711 DAW 15-Sep-81
Set D%ERR if IOERR, even if message not typed.
1712 JLC/DAW 15-Sep-81
Got rid of D%ERR, use DDBADR instead.
1715 DAW 15-Sep-81
If user specified FORM='FORMATTED' but not MODE, he got
an "?Internal FOROTS error".
1717 DAW 16-Sep-81
Implement D%NCLS - set if CLOSE error happened,
to avoid the "infinite loop" of CLOSE - %ABORT - CLOSE - %ABORT ...
1723 DAW 17-Sep-81
Fix problem with sticky ERR= from OPEN.
1725 DAW 17-Sep-81
DIALOG parsing on TOPS-10.
1732 DAW 22-Sep-81
Fix -20 STATUS='NEW'.
1734 DAW 22-Sep-81
STATUS='SCRATCH', ACCESS='RANDOM' on TOPS-20.
1740 DAW 23-Sep-81
More REREAD code - clear U.RERD in %CLOSE.
1742 JLC 23-Sep-81
Fix OSWTCH to do the right thing to N.REC: decrement it
for disk, as we are backing over the ENDFILE record, set
it to 1 for magtape, as we are writing a new file. All this
because BACKSPACE checks the record number and leaves
if zero.
1743 DAW 24-Sep-81
Fix obscure bug in DIALOG scanning, caused "?Bad source/dest designator"
on TOPS-20 if a switch was mis-typed and then typed correctly.
1744 DAW 24-Sep-81
Allow user to OPEN the special negative units (note: not documented.)
1750 DAW 28-Sep-81
Stop after reading in 5 SFD's in DIRECTORY=array.
1751 JLC 28-Sep-81
Fix unformatted backspace again. A bug in DSKOSW-20 was causing
attempts to PMAP page -1. If either IPTR is zero or the file
position is negative, clear IPTR/ICNT so we'll just start
writing at the start of the file.
1752 DAW 29-Sep-81
Minor fixes to DIALOG processing.
1753 DAW 29-Sep-81
IOERR's to type the PC. %TRACE call no longer needed.
1754 DAW 29-Sep-81
Allow negative generation numbers on TOPS-20. (For example,
-1 means the next generation number).
1755 DAW 1-Oct-81
Allow protections <111> in TOPS-10 DIALOG mode, as per V5a.
They can be either before or after PPN's.
1757 DAW 2-Oct-81
Conflict with /READONLY caused "?Ill mem ref".
1763 DAW 7-Oct-81
Fatal error if user tries to write to a LINED file.
1764 DAW 7-Oct-81
TOPS-10 MTASET got "Integer divide check", "TAPOP. error" trying
to set BLOCKSIZE.
1765 DAW 7-Oct-81
Make TOPS-10 OPEN error type the non-printing character
that caused the problem.
1770 DAW 8-Oct-81
TOPS-10 progs hang in EW state at the QUEUE. UUO if GALAXY
version 2 is running.
1771 DAW 8-Oct-81
Missing /LIMIT code for TOPS-10 GALAXY V2 packet.
1772 DAW 8-Oct-81
TOPS-10 DISPOSE='DELETE' didn't release the channel.
1774 DAW 8-Oct-81
Avoid getting "?Unexpected TAPOP. error" for typical errors.
1775 JLC 9-Oct-81
Prevent doing tapops if program didn't specify anything.
1776 DAW 9-Oct-81
Allow BINARY,DUMP,IMAGE mode to be used with TOPS-10 NUL: device.
1777 DAW 9-Oct-81
FILOP. CLOSE before RELEASE when appropriate.
2000 DAW 9-Oct-81
Fix typo that caused PLOT routines to stop working because
unit -7 couldn't be opened.
Get rid of extraneous, unreachable TOPS-10 code.
2002 DAW 13-Oct-81
OPEN 'TTY', ACCESS='SEQIN', followed by "TYPE" didn't work.
2004 DAW 14-Oct-81
Before consolidating DDB's, check to make sure MODE is the same.
2005 JLC 15-Oct-81
Add unmapping of unused pages for random files also.
2011 DAW 19-Oct-81
At DOOPEN store EOFN from .RBSIZ info. Use that to compute blocks
when queueing file. Also get rid of "FSIZE".
2014 JLC 19-Oct-81
Fix unmapping of unused pages not to unmap holes in the file.
2016 JLC 20-Oct-81
Fix minor bug in QUEUE acknowledge, error msgs.
2023 DAW 23-Oct-81
With GALAXY R2, DISPOSE='LIST' didn't make the file be
deleted after it was printed.
2026 JLC 27-Oct-81
Fixed RSIZW for LINED files so backspace will work.
2027 DAW 27-Oct-81
Rework GALAXY v2 code to use symbolic names, so sites who
have modified QSRMAC can just reassemble FOROTS to make it
handle /DISPOSE:<queue> at their site.
2033 DAW 30-Nov-81
In CLSQ, zero out the page returned by GTPGS.
***** Begin Version 6A *****
2041 DAW 21-Dec-81
Correct deficiency in TOPS-20 logical name handling that
caused unexpected "?File not found" errors for OPEN/READ
sequence.
2042 TGS 2-Feb-82 20-17208
Change NREC(D) to NREC(U) at end-of-file routines so record
counts get correctly updated.
2043 ERD 9-Feb-82 10-32099
Change in DPRFN1 to allow leading spaces in file names on
TOPS-10.
2050 ERD 20-Apr-82 10-32326
Code addition in %LSTBF so that DUMP mode output on magtape
will skip over the initial output.
2062 EDS 7-Jun-82
Files with extension of "DAT" when sent to the printer via
DISPOSE = 'LIST' or 'PRINT' do not have the first character
of each line used for carriage control.
2064 EDS 10-Jun-82
Create files for STATUS='SCRATCH' using the standard naming
convention for TOPS-10. File names will now be nnnccc.TMP,
where nnn is the job number and ccc are random letters.
2112 TGS 29-Sep-82 10-32830
Set up the path pointer in the RENAME block before executing the
rename FILOP. so CLOSE/DISPOSE=RENAME can rename a file to a
different SFD or directory.
***** Begin Version 7 *****
3012 JLC 4-Nov-81
Rework FOROTS call arg copier. No more LTYPE.
Rework of OPNDIR, which modified the arg list.
3015 AHM 7-Nov-81
DIALOG with zero address comes out as 1,,0 when produced by the XMOVEI
at OPNDIA and was thus not seen as zero.
3016 JLC 9-Nov-81
Fix OPNDIA for new arg block - checks if immediate-mode arg
to decide if it has a string.
3023 JLC 15-Nov-81
Various V6 patches: non-consolidation of NUL:, correct call
to %FREPGS in disk close, leading blanks in OPEN parameters,
quickie patch to turn off D%IO for TTY input after DIALOG.
3035 JLC 5-Feb-82
Rework of OPEN code that decides default MODE and FORM
parameters. Set byte size to 7 and BPW to 5 for all files.
Fix APPEND bug - was not setting BLKN to end of file.
3051 JLC 26-Feb-82
Set BUFFERCOUNT to 1 for magtapes on the -10, ignoring the
user's specification, since PULSAR does not return the magtape
EOF bit in a consistent place (sometimes the active buffer,
sometimes the EOF buffer), so BACKSPACE, WRITE cannot work
because the active buffer count, and therefore the number of
blocks to backspace, is sometimes off by 1.
3056 JLC 23-Mar-82
Catch illegal OPEN arguments (such as RECORDSIZE=0) and
illegal options for binary files (such as BLANK=).
3072 JLC 30-Mar-82
Fix CLOSE of image mode files with character data, was rounding
incorrectly (wrong AC).
3111 JLC 15-Apr-82
Fix SDO error message, was getting unit number with LOAD, which
does not sign-extend.
3114 BL 29-Apr-82
Make character expressions work in OPEN statements (FOROPN.MAC).
3115 BL 13-May-82
Continue above(3114). Fix OPNCHR & DIABLT to check ARGTYP and
get the character descriptor if appropriate.
3116 BL 14-May-82
Move label DIANST up one line(typo).
3117 BL 14-May-82
Changed HLRE to HXRE in CNSCHK to get correct unit number
in SDO error. (Note: Same edit as 3111!)
3122 JLC 28-May-82
Make FILE= fully qualified string work. Fix some extended
addressing bugs for character args.
3123 JLC 29-May-82
Fix bug in SMBA, was not paying attention to FORM=.
3125 JLC 3-Jun-82
Moved the AC save routine back to the hiseg.
3126 JLC 7-Jun-82
Installed OPEN on a "connected unit". Fixed some code
which flowed across SEGMENT macros.
3136 JLC 26-Jun-82
Support work for I/O performance. Install some TSG patches.
3140 JLC 2-Jul-82
Put in missing external %EXCHN.
3150 JLC 12-Jul-82
Day 1 bug - DIALOG in close set up GTJFN flag word with
junk from T0 (HLLOM instead of HLLOS). Fix bug in -10 OPNDIR,
did not recognize character string args.
3153 JLC 20-Jul-82
Fixed problem caused by new EOF-handling code for random files.
3161 JLC 19-Aug-82
Installed modified TSG patch regarding setting and restoring
of CCOC words. Fixed TPAGE on the -20 so it won't leave
a null file with 1 page allocated. Changed NREC(U) to CREC(D).
3165 JLC 28-Aug-82
Fix random I/O so it can handle files larger than 256K blocks.
3166 JLC 30-Aug-82
Fix XXXSET so it sets WSIZ to a page rather than 15 bytes.
Search QSRMC2 instead of QSRMAC on the -10, since QSRMAC is
now for GALAXY 4.1. Change APPEND so it uses PMAP again.
3174 JLC 4-Sep-82
Fix FOROPN on the -10 so TPAGE is calculated in pages, not
blocks.
3175 JLC 8-Sep-82
Change OPEN on "connected unit" to only do this if the
OPEN in progress specifies STATUS='OLD'.
3200 JLC 24-Sep-82
Install 6A patch to supercede on TOPS-10 rather than
deleting the file in OSWTCH. This avoids failures for
protection code 2 and accidently creating the file in
a different SFD than the original file. Fix DSKCLS on
the -20 to free the page tables, which caused eventual
memory full if many random files were opened and closed
repeatedly.
3202 JLC 26-Oct-82
Install code to provide base support for ANSI tapes for
TOPS-20, since most of the work is done by the monitor.
3203 JLC 31-Oct-82
Store a word of spaces (SPCWD) in DDB for each type
of file.
3212 JLC 11-Nov-82
Update and consolidate -20 magtape code so that B36FLG(D) controls
whether formatted or unformatted I/O is done.
3213 JLC 12-Nov-82
Fix FILOP close in OSWCRE, didn't expect a skip (normal) return.
3214 BL 12-Nov-82
Merge in EDIT 2124 from V6A...
This edit supersedes edit 2063. Ensure that calls to FRSISW errors
always pass SIXBIT strings for keywords and key values on TOPS10 only.
3215 JLC 15-Nov-82
Fix magtape bugs, typos.
3216 JLC 16-Nov-82
Fix bytesize on CLOSE. Also store the data mode, which heretofore
was discarded.
3221 JLC 21-Nov-82
Fix %LSTBF call so it doesn't setup the buffer (changed call
to %OBUF).
3223 JLC 22-Nov-82
Do not allow modes on OPEN after all, as most of the devices
don't allow them anyhow. Fix DEVICE=' '.
3225 JLC 24-Nov-82
Remove extraneous (and deadly) multiplication of # bytes by BPW.
3226 JLC 29-Nov-82
Fix various little bugs, magtape bugs, etc.
3227 JLC 8-Dec-82
Fix EOFN problem at OSWTCH.
3230 RJD 8-Dec-82
Fix CLOSE STATUS and DISPOSE problems.
3231 JLC 14-Dec-82
Remove warning given for CLOSE on units that are not OPENed.
Fix EOFN problems regarding null files (REWIND, ENDFILE)
and files which have data to page bounds (REWIND, WRITE).
3250 JLC 7-Jan-83
Fix GTJFN in DOOPEN do try GJ%OLD, then no flags if correct
type of failure. In CLOSE, save UDB of file to be renamed
in %RNOLD.
3252 JLC 12-Jan-83
Fix RENAME error msg reporting.
3253 JLC 13-Jan-83
Fix EXIT1 so it doesn't fall over with I/O within I/O.
3256 JLC 14-Jan-83
Fix CLOSE so it puts DDB addr in UDB so $F can find it.
***** End Revision History *****
\
FSRCH
IF10,< SEARCH QSRMC2 >
IF20,< SEARCH QSRMAC,GLXMAC >
INTERN %ALCHF,%DECHF,%EXIT1
INTERN %SETIN,%SETOUT,%CHKNR
IF10,< INTERN %CHMSK,%CLSER,%ST10B,%CALOF >
IF20,< INTERN %CLSOP >
INTERN %UNNAM
INTERN %OPENX,%LSTBF
INTERN %ARGNM
EXTERN A.END,A.ERR,A.IOS,%CUNIT,%OCCOC,%CCMSK,%ICCOC
EXTERN %POPJ,%POPJ1,%POPJ2
EXTERN %SAVE1,%SAVE2,%SAVE3,%SAVE4,%SAVAC,%CPARG,%PUSHT,%POPT
EXTERN %GTBLK,%FREBLK,%GTPGS,%FREPGS
EXTERN %OCRLF,%RTMSK,%EXCHN
IF20,< EXTERN %PTOF,%OSMAP,%OBUF >
EXTERN %CRLF
EXTERN %ABORT,%ABFLG
EXTERN %DDBTAB,%UDBAD,I.PID,%SIZTB
EXTERN D.TTY,U.TTY,U.ERR,AU.ACS
IF10,< EXTERN G.PPN,%RANWR,I.MVER,%CLRBC,%BACKB,%BAKEF,%ISET,I.JOB >
EXTERN %SETAV
EXTERN U.RERD
IF20,< EXTERN DBSTP.> ;Close out DBMS databases
SEGMENT CODE
SUBTTL OPEN
FENTRY (OPEN)
PUSHJ P,%SAVAC ;SAVE USER'S ACS, COPY ARG LIST
PUSHJ P,%CPARG
SETZM DIASAG ;CLEAR DIALOG=STRING ARG POINTER
SETZM FILSAG ;CLEAR FILE=STRING POINTER
SETZM EFSFLG ;FLAG FOR [ENTER CORRECT FILE SPECS]
XMOVEI T1,[ASCIZ /OPEN/] ;SET STATEMENT NAME FOR ERROR MESSAGES
MOVEM T1,%IONAM
PUSHJ P,OPNCNV ;CONVERT OLD ARG BLOCK FORMAT
;Get %CUNIT= unit #, A.ERR= "ERR=" address, A.IOS= "IOSTAT=" address
PUSHJ P,FNDAGL ;Find UNIT=, ERR=, IOSTAT=
;If no UNIT= given, gets abortive error.
PUSHJ P,UNRNGE ;Check unit range
; (returns if in range, unit # in T2).
SKIPE T1,A.IOS ;Any IOSTAT variable?
SETZM (T1) ;Yes, initialize to zero
;Unit may not be closed yet. In an case,
;get a new one.
MOVEI T1,ULEN ;Length of a unit block
PUSHJ P,%GTBLK ;Allocate it
MOVE U,T1 ;Point to empty unit block
MOVE T2,%CUNIT ;Stick unit number in block
STORE T2,UNUM(U)
MOVEI T1,DLEN ;Length of a DDB block
PUSHJ P,%GTBLK ;Allocate it
MOVE D,T1 ;Point to empty DDB block
MOVEM U,%UDBAD ;FLAG THAT WE HAVE A PROPER DDB
MOVEM D,DDBAD(U) ;SAVE DDB ADDR
TXO F,F%DCU ;Set flag that tells IOERR
; to deallocate U and D
;Setup the U and D blocks with information from the arg list.
;Possibly dialog mode will be flagged.
PUSHJ P,OPNARG ;Copy arguments from arg list
;(Possibly take ERR= branch)
PUSHJ P,PPNDIR ;PROCESS PPN IF NECESSARY
SKIPE FILSAG ;FILE='string' SEEN?
PUSHJ P,FILSTR ;YES. PROCESS IT
SKIPE DIASAG ;DIALOG='string' SEEN?
PUSHJ P,DLGSTR ;Yes, do it
TXZ F,F%INDST ;Clear flag if set
PUSHJ P,CKSCRT ;Check STATUS='SCRATCH' conflict
PUSHJ P,DFBSTS ;Set defaults based on STATUS
PUSHJ P,CHKDLG ;Go do DIALOG if necessary
PUSHJ P,CKSCRT ;Check STATUS='SCRATCH' conflict
PUSHJ P,OPNCON ;CHECK FOR OPEN ON A CONNECTED UNIT
JRST DEALDU ;YES. DEALLOCATE D AND U
;OPEN args all read in (including "DIALOG" if specified).
PUSHJ P,SMBA ;SET MODE BY ACCESS
PUSHJ P,OPENX ;Call the implicit OPEN routine
;Note: OPENX (not %OPENX) because
; there may be switch conflicts.
MOVX T1,D%OPEN ;"Explicit OPEN statement has been done"
IORM T1,FLAGS(D) ; Set DDB flag
PJRST %SETAV ;Set AVAR if given, return from OPEN
DEALDU:
IF20,<
LOAD T1,IJFN(D) ;GET JFN
CAIN T1,.PRIIN ;IS IT TTY?
JRST NORJF ;YES. DON'T HAVE TO RELEASE IT
RLJFN% ;RELEASE IT
ERJMP .+1
NORJF:
> ;END IF20
SETZM %UDBAD ;NO DDB ANYMORE
MOVE T1,U ;DEALLOCATE U
PUSHJ P,%FREBLK
MOVE T1,D ;DEALLOCATE D
PJRST %FREBLK ;RETURN TO USER
OPNCON: PUSHJ P,%SAVE2 ;SAVE P1,P2
MOVE P1,%CUNIT ;GET UNIT # AGAIN
SKIPN P1,%DDBTA(P1) ;IS THERE A UDB ADREADY?
JRST %POPJ1 ;NO. JUST PROCEED WITH OPEN
MOVE P2,DDBAD(P1) ;GET DDB ADDR
PUSHJ P,CMPFIL ;COMPARE FILENAME STRINGS
JRST GOCLOS ;NOT EQUAL. CLOSE OLD ONE
PUSHJ P,CMPEXT ;CHECK EXTENSION
JRST GOCLOS ;BAD
PUSHJ P,CMPGEN ;CHECK GENERATION
JRST GOCLOS ;BAD
PUSHJ P,CMPSTA ;CHECK STATUS
JRST GOCLOS ;BAD
PUSHJ P,CMPMOD ;CHECK MODE
JRST GOCLOS ;BAD
PUSHJ P,CMPFRM ;CHECK FORM
JRST GOCLOS ;BAD
PUSHJ P,CMPACC ;CHECK ACCESS
JRST GOCLOS ;BAD
PUSHJ P,CMPDEV ;CHECK DEVICE
JRST GOCLOS ;BAD
PUSHJ P,CMPDIR ;CHECK DIRECTORY
JRST GOCLOS ;BAD
LOAD T1,BLNK(U) ;GET BLANK=
STORE T1,BLNK(P1) ;STORE IN OLD FILE DDB
LOAD T1,CC(U) ;GET CARRIAGE=
STORE T1,CC(P1) ;STORE IN OLD FILE DDB
LOAD T1,PADCH(U) ;GET PADCHAR
STORE T1,PADCH(P1) ;STORE IN OLD FILE DDB
POPJ P,
GOCLOS: PUSHJ P,CLZUNT ;CLOSE THE OLD FILE
AOS (P) ;SKIP RETURN TO PROCEED WITH OPEN
POPJ P,
;CLZUNT-- Routine to do an implicit "CLOSE (UNIT=un)"
;U points to unit block
; The ERR= and IOSTAT= args are copied from the OPEN parameters.
;If IOERR happens in CLOSE, D and U blocks are not deallocated.
; (because F%DCU is not set).
CLZUNT: MOVEM U,SAVEU ;SAVE NEW DDB
MOVEM D,SAVED
TXZ F,F%FSS!F%DSS ;PREVENT RENAME FOR CLOSING FILE!
MOVE T1,%CUNIT ;GET UNIT #
MOVE U,%DDBTAB(T1) ;GET UDB
MOVE D,DDBAD(U) ;Get old DDB block
PUSHJ P,%CLOSX ;Go close it.
MOVE U,SAVEU ;RESTORE NEW DDB
MOVE D,SAVED
POPJ P, ;CONTINUE OPEN
SEGMENT DATA
SAVEU: BLOCK 1 ;SAVED UNIT BLOCK
SAVED: BLOCK 1 ;SAVED DEVICE BLOCK
;COMPARE ROUTINES FOR OPEN ON A CONNECTED UNIT
SEGMENT CODE
IF20,<
CMPFIL: MOVE T1,[POINT 7,FILE(D)] ;COMPARE NEW FILE
MOVE T4,[POINT 7,FILE(P2)] ;WITH OLD ONE
DOFCMP: MOVEI T0,^D79 ;FULL FILENAME COMPARE
MOVEI T3,^D79
EXTEND T0,[EXP CMPSN,0,0] ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPEXT: MOVE T1,[POINT 7,EXT(D)] ;COMPARE NEW EXT
MOVE T4,[POINT 7,EXT(P2)] ;WITH OLD ONE
JRST DOFCMP ;GO JOIN COMMON CODE
CMPGEN: MOVE T1,XGEN(D) ;GET NEW GENERATION
JUMPE T1,%POPJ1 ;IF 0, DECLARE A MATCH
CAMN T1,XGEN(P2) ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPDEV: MOVE T1,[POINT 7,DEV(D)] ;POINT TO NEW DEVICE
MOVE T4,[POINT 7,DEV(P2)] ;AND OLD ONE
JRST DOFCMP ;COMPARE THEM
CMPDIR: MOVE T1,[POINT 7,DIR(D)] ;POINT TO NEW DIRECTORY
MOVE T4,[POINT 7,DIR(P2)] ;AND OLD ONE
JRST DOFCMP ;COMPARE THEM
> ;END IF20
CMPMOD: LOAD T1,MODE(D) ;GET NEW MODE
JUMPE T1,%POPJ1 ;OK IF NONE
LOAD T2,MODE(P2) ;GET OLD MODE
CAIN T1,(T2) ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
;CMPSTA - IN ORDER TO MAINTAIN COMPATIBILITY WITH V6, ONLY FILES
;OPENED WITH STATUS='OLD' ARE CONSIDERED TO BE CANDIDATES FOR
;A "CONNECTED OPEN". OTHERWISE, CMPSTA WILL NON-SKIP RETURN, FORCING
;THE CURRENTLY OPEN FILE TO BE CLOSED FIRST.
CMPSTA: LOAD T1,STAT(D) ;GET STATUS OF NEW ONE
CAIN T1,ST.OLD ;IS IT OLD?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPFRM: LOAD T1,FORM(D) ;GET FORMAT OF NEW FILE
JUMPE T1,%POPJ1 ;OK IF NONE
LOAD T2,FORM(P2) ;GET OLD ONE
CAIE T1,(T2) ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPACC: LOAD T1,ACC(D) ;GET ACCESS OF NEW FILE
JUMPE T1,%POPJ1 ;OK IF NONE
LOAD T2,ACC(P2) ;GET OLD ONE
CAIN T1,(T2) ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
IF10,<
CMPFIL: MOVE T1,FILE(D) ;GET FILENAME
CAMN T1,FILE(P2) ;COMPARE WITH OLD ONE
AOS (P) ;SKIP IF EQUAL
POPJ P,
CMPEXT: HLRZ T1,EXT(D) ;GET EXTENSION OF NEW FILE
HLRZ T1,EXT(P2) ;AND OF OLD ONE
CAIN T1,(T2) ;EQUAL?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPGEN: AOS (P) ;NO GENERATIONS ON TOPS-10
POPJ P,
CMPDEV: MOVE T1,DEV(D) ;GET NEW DEVICE
CAMN T1,DEV(P2) ;SAME AS OLD DEVICE?
AOS (P) ;YES. SKIP RETURN
POPJ P,
CMPDIR: MOVEI T1,PTHB+.PTPPN(D) ;GET NEW DIRECTORY
HRLI T1,-6 ;PPN AND 5 SFDS
XMOVEI T2,PTHB+.PTPPN(P2) ;GET OLD DIRECTORY
CMPTHL: MOVE T3,(T1) ;GET A WORD
CAME T3,(T2) ;SAME?
POPJ P, ;NO. LEAVE
ADDI T2,1 ;INCR PATH PNTRS
AOBJN T1,CMPTHL ;COMPARE ALL 6 WORDS
AOS (P) ;PATHS EQUAL. SKIP RETURN
POPJ P,
> ;END IF10
;%OPENX: Routine to do implicit open
; This routine is used by all I/O statements that do
;an implicit OPEN, and also the OPEN statement itself.
; This routine must only be called when the arguments given
;so far do not conflict.
; D and U are setup with the implicit args.
; (including ERR=, IOSTAT=)
; Errors go to ERR= or call DIALOG.
;If no errors, DDBTAB entry is set up.
;Here if we either know or suspect that there are conflicts
; in the args given.
OPENX: PUSHJ P,DFBSTS ;Set default filespec info based on STATUS
PUSHJ P,CHKDLG ;Do DIALOG mode if necessary
PUSHJ P,CKCONF ;Check conflicts in OPEN switches now
JRST OPENX ;Conflicts, go fix
JRST OPENX1 ;No conflicts in args
;Here if we know there are no conflicting OPEN switches
; ** Implicit OPEN routine starts here **
%OPENX: PUSHJ P,%SAVE1 ;Make sure P1 gets preserved
PUSHJ P,DFDEV ;Set default device
PUSHJ P,DFBSTS ;Set default filespec info based on STATUS
OPENX1: PUSHJ P,OPDFLT ;Set other defaults
TXNE F,F%DRE ;If problem,
JRST OPENX ;Go fix it
PUSHJ P,DFDEV1 ;Get real device info
JRST OPENX ;Fix problem
PUSHJ P,MARKCS ;Mark for consolidation if we can
; (goes to %ABORT if problem)
MOVEM D,DDBAD(U) ;Set DDB address
LOAD T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%IN+D%OUT ; Is it already open (consolidated DDB's?)
JRST OPXRET ;Yes, return
;No errors. Do the actual OPEN if we need to
LOAD T1,STAT(D) ;Get status
CAIL T1,ST.DISP ;STATUS that's really a DISPOSE?
PUSHJ P,STATDS ;Yes, change to DISPOSE, STATUS='UNKNOWN'
;There are four possibilities for STATUS= now.
; If STATUS='UNKNOWN' and file access is sequential
; then the file is not opened until
;the first I/O operation.
CAIN T1,ST.UNK ;STATUS='UNKNOWN'?
JRST OPXUNK ;Yes
CAIN T1,ST.OLD ;STATUS='OLD'?
JRST OPXOLD ;yes
CAIN T1,ST.NEW ;STATUS='NEW'? (or implied)
JRST OPXNEW ;Yes, go do the OPEN
CAIN T1,ST.SCR ;STATUS='SCRATCH'?
JRST OPXSCR ;Yes, go do the OPEN
$SNH ;?That's all that could happen
;Here if STATUS='OLD'
OPXOLD: PUSHJ P,OPNOLD ;** OPEN FILE FOR INPUT **
JRST OPENX ;Error, go try again
JRST OPXRET ;Return
;Here if STATUS='NEW'
OPXNEW: PUSHJ P,OPNNEW ;** OPEN FILE FOR OUTPUT **
JRST OPENX ;Error, go try again
JRST OPXRET ;Return
;Here if STATUS='SCRATCH'
OPXSCR: PUSHJ P,OPNSCR ;** OPEN FILE FOR SCRATCH **
JRST OPENX ;Error, go try again
JRST OPXRET ;Return
;Here if STATUS='UNKNOWN'
OPXUNK: LOAD T1,INDX(D) ;What type of device?
CAIN T1,DI.TTY ;If TTY:,
SKIPA T1,[AC.SOU] ;Pretend "SEQOUT" access.
LOAD T1,ACC(D) ;Get access
PUSHJ P,OPXUAC(T1) ;Do something
JRST OPENX ;?failed
JRST OPXRET ;Success, return
;OPEN routine to call when status='UNKNOWN', by access type
OPXUAC: $SNH ;*UNKOWN ACCESS*
JRST OPNOLD ;SEQIN
JRST OPNOUT ;SEQOUT - Open file for output
JRST OPXUSO ;SEQINOUT- See what to do
JRST OPNOLD ;RANDIN
JRST OPNRIO ;RANDOM
JRST OPNAPP ;APPEND
;Here if SEQINOUT UNKNOWN
OPXUSO: TXNE F,F%CTTY ;Controlling TTY:?
JRST OPNOUT ;Yes, go open it now
JRST %POPJ1 ;Don't OPEN it yet
;Here when %OPENX is successful
OPXRET: HXRE T1,UNUM(U) ; Get unit number
MOVEM U,%DDBTAB(T1) ;Store unit block address in DDBTAB.
; PJRST STBLNK ;Set BLANK= default and return
;Routine to set BLANK= default
; If device is TTY: the default is always NULL
; Else if this is an OPEN statement, set BLANK=NULL
; else set BLANK=ZERO.
;This may seem like nonsense, but it makes FOROTS compatible
; with VAX.
STBLNK: LOAD T1,FORM(D) ;GET FORM=
CAIE T1,FM.FORM ;FORMATTED?
POPJ P, ;NO. DON'T STORE BLANK=
LOAD T1,BLNK(U) ;GET BLANK=
JUMPN T1,%POPJ ;Return if user specified it
LOAD T2,INDX(D) ; T2= device index
MOVE T1,%IONAM ; T1= address of statement name
MOVE T1,(T1) ;Get ASCIZ
CAIE T2,DI.TTY ;For TTY
CAMN T1,[ASCIZ /OPEN/] ; or OPEN statement
SKIPA T1,[BL.NULL] ;Default is BLANK=NULL
MOVEI T1,BL.ZERO ;Else Default is BLANK=ZERO..
STORE T1,BLNK(U) ;Store the value
POPJ P, ;Return
;Routine to change STATUS that's really a DISPOSE into
; STATUS='UNKNOWN' and DISPOSE.
;There should be no conflicts with DISPOSE and STATUS when we
;get here.
;Call:
; T1/ STATUS value that's really a dispose
;Return:
; T1/ ST.UNK, DISP(D) set, STAT(D) set to ST.UNK
STATDS: SUBI T1,ST.DISP ;Get /DISPOSE value
LOAD T2,DISP(D) ; If not set,
SKIPN T2
STORE T1,DISP(D) ; Set it
MOVEI T1,ST.UNK ;Set 'UNKNOWN' status
STORE T1,STAT(D)
POPJ P, ;Return, T1= 'UNKNOWN' status
;Routine to set OPEN defaults based on STATUS
;If STATUS='SCRATCH', all info except device is cleared
; Otherwise default name is FORnn.DAT
;This routine does not affect the value of F%DRE.
; and can not cause an error.
;This routine should be called before each DIALOG mode is called
; and before the OPEN is done.
DFBSTS: LOAD T1,STAT(D) ;Get current value of "STATUS"
CAIE T1,ST.SCR ;'SCRATCH'?
PJRST DFFILE ;No, set default filename and return
TXZ F,F%FSS ;Clear flag "user specified filespec stuff"
TXZ F,F%EXT ;Clear "extension was specified"
IF10,< ;Set defaults for STATUS='SCRATCH'
DFSCR: SETZM LKPB(D) ;Clear the LOOKUP block
HRLI T1,LKPB(D)
HRRI T1,LKPB+1(D)
BLT T1,LKPB+LLEN-1(D) ; . .
SETZM PTHB(D) ;Clear the path block
HRLI T1,PTHB(D)
HRRI T1,PTHB+1(D)
BLT T1,PTHB+^D9-1(D) ; . .
SETZM PPN(D) ;Clear PPN or ptr to path block
POPJ P, ;Return
>
IF20,< ;Set defaults for STATUS='SCRATCH'
DFSCR: SETZM DIR(D) ;Clear directory
SETZM FILE(D) ; Filename
SETZM EXT(D) ; Extension
SETZM PROT(D) ; Protection
SETZM XGEN(D) ; Generation #
POPJ P, ;Return
>
;Routine to check for unit out of range
;Input:
; %CUNIT/ unit number from OPEN or CLOSE arg list
; PUSHJ P,UNRNGE
; <return here if unit in range, unit # in T2>
; If unit is not in range for OPEN or CLOSE,
; the program takes ERR= path (TERR) or aborts.
UNRNGE: MOVE T2,%CUNIT ;Get unit number
CAML T2,[MINUNIT] ;Skip if less than the minimum
CAILE T2,MAXUNIT ;Skip if .LE. the maximum
$ECALL IUN,%ABORT ;?UNIT out of range
POPJ P, ;Ok, unit in range
;CKCONF - Routine to check for conflicts in OPEN args.
;Called after each DIALOG to check for bad arguments,
; inconsistancies, etc.
; This routine gives error messages (possibly takes ERR= branch),
; or sets F%DRE if there are errors.
;It must be called in OPEN after OPNARG, and after each
; DIALOG.
;If no errors, returns .+2
CKCONF: PUSHJ P,CKSCRT ;Check STATUS='scratch' conflict
;Check /STATUS conflict with /DISPOSE
;T1= status
CKCNST: MOVEM T1,%OPNV1 ;Store switch value for error message
LOAD T2,DISP(D) ;Get /DISPOSE
CAIN T1,ST.SCR ;/STATUS=SCRATCH?
JRST CKCNS1 ;Yes, /DISPOSE=SAVE not allowed
SUBI T1,ST.DISP ;Convert to /DISP:something
JUMPLE T1,CKCNFM ;Go check /FORM
JUMPE T2,CKCNFM ; If not specified, no conflict then
CAIN T1,(T2) ;Do STATUS and DISPOSE agree?
JRST CKCNFM ;Yes, no error
JRST CKCNS2 ;Error
CKCNS1: CAIE T2,DS.SAVE ;/DISPOSE='SAVE' specified?
JRST CKCNFM ;No, ok
CKCNS2: MOVEM T2,%OPNV2 ;Store /DISPOSE value for error
MOVEI T1,OK.STAT ;Store switch number for errors
MOVEM T1,%OPNK1
MOVEI T1,OK.DISP
MOVEM T1,%OPNK2
PUSHJ P,OPCONF ;Give error message
;Check /MODE and /FORM conflict
CKCNFM: LOAD T1,FORM(D) ;T1= form
JUMPE T1,CKCNAC ;If not specified, no conflict
LOAD T2,MODE(D) ;T2= mode
JUMPE T2,CKCNAC ;If not specified, no conflict
CAIL T2,MD.ASC ;ASCII or greater implies /FORM:F
JRST CKFMF ;Go check that
;8-SEP-81 /DAW, MODE='IMAGE' conflicts with FORM='FORMATTED'
; CAIGE T2,MD.BIN ;BINARY or greater implies /FORM:U
; JRST CKCNAC ;/MODE:IMAGE - no conflict
;Must be /FORM:UNFORMATTED
CKFMU: CAIN T1,FM.UNF ;UNFORMATTED?
JRST CKCNAC ;Yes, ok
CKFMUE: MOVEM T1,%OPNV2 ;Store value for error message
MOVEI T1,OK.MOD ;Store switch numbers
MOVEM T1,%OPNK1
MOVEI T1,OK.FORM
MOVEM T1,%OPNK2
MOVEM T2,%OPNV1 ;Value of /MODE
PUSHJ P,OPCONF ;Give error
JRST CKCNAC ;Go on
;Here if /FORM must be "FORMATTED"
CKFMF: CAIE T1,FM.FORM ;FORMATTED?
JRST CKFMUE ;No, give error
;Check conflict of /ACCESS and /READONLY
CKCNAC: LOAD T1,RO(D) ;T1= "Readonly" bit
JUMPE T1,CKCSRO ;If not specified, no conflict
LOAD T2,ACC(D) ;T2= ACCESS
CAIE T2,AC.SOU ;SEQOUT?
CAIN T2,AC.APP ; or APPEND?
JRST .+2 ;Yes, can't have READONLY
JRST CKCSRO ;Otherwise it's ok
MOVEM T2,%OPNV1 ;Store value of ACCESS
SETOM %OPNV2 ;READONLY has no value
MOVEI T1,OK.ACC
MOVEM T1,%OPNK1
MOVEI T1,OK.RO
MOVEM T1,%OPNK2
PUSHJ P,OPCONF ;Give error
;Check conflict of /STATUS and /READONLY
CKCSRO: LOAD T1,RO(D) ;Get value of /READONLY
JUMPE T1,CKCSAC ;Not specified, no conflict
LOAD T2,STAT(D) ;Get /STATUS
CAIE T2,ST.NEW
CAIN T2,ST.SCR ;New and scratch don't make sense
JRST .+2
JRST CKCSAC ;Otherwise OK
MOVEM T2,%OPNV1
SETOM %OPNV2 ;READONLY has no value
MOVEI T1,OK.STAT
MOVEM T1,%OPNK1
MOVEI T1,OK.RO
MOVEM T1,%OPNK2
PUSHJ P,OPCONF ;Give error
;Check conflict of /STATUS and /ACCESS
CKCSAC: LOAD T1,ACC(D)
JUMPE T1,CKCACM ;If no ACCESS specified, no conflict
LOAD T2,STAT(D) ;Get STATUS
JUMPE T2,CKCACM ;If not specified, no conflict
CAILE T2,ST.DISP ;Any kind of DISPOSE is ok
JRST CKCACM
CAIE T2,ST.OLD ;STATUS='old'
CAIN T2,ST.UNK ;STATUS='unknown'
JRST CKCACM ;No conflict
;STATUS= 'NEW' or 'SCRATCH' - can't happen if file is read-only
CAIE T1,AC.SIN ;SEQIN
CAIN T1,AC.RIN ;RANDIN
JRST CKCSC1 ;?Conflict
CAIE T2,ST.SCR ;STATUS='SCRATCH'?
JRST CKCACM ;No, no conflict
CAIE T1,AC.SIO ;Yes, only SEQINOUT
CAIN T1,AC.RIO ; and RANDOM allowed
JRST CKCACM ;No conflict
;/ACCESS vs. /STATUS
CKCSC1: MOVEM T1,%OPNV1
MOVEM T2,%OPNV2
MOVEI T1,OK.ACC
MOVEM T1,%OPNK1
MOVEI T1,OK.STAT
MOVEM T1,%OPNK2
PUSHJ P,OPCONF ;Give error
;Check /ACCESS conflict with /MODE
CKCACM: LOAD T1,ACC(D) ;Get /ACCESS
LOAD T2,MODE(D) ;Get /MODE
CAIE T1,AC.RIN ;Random?
CAIN T1,AC.RIO
JRST .+2 ;Yes
JRST CHKRSZ ;No, -- next check
;Random (DIRECT) access.
CAIE T2,MD.DMP ;/MODE:DUMP illegal (not hard to make
; it legal at some future date.. if so
; each record would be a block and /RECORDSIZE
; could not also be specified (??).).
JRST CHKRSZ ;Not /MODE:DUMP, go on.
MOVEM T1,%OPNV1 ;Value of ACCESS
MOVEM T2,%OPNV2 ;Value of MODE
MOVEI T1,OK.ACC
MOVEM T1,%OPNK1
MOVEI T1,OK.MODE
MOVEM T1,%OPNK2
PUSHJ P,OPCONF ;Give error
;Make sure he specified "RECORDSIZE" if random access requested
CHKRSZ: LOAD T1,ACC(D) ;GET /ACCESS
CAIE T1,AC.RIN ;RANDOM?
CAIN T1,AC.RIO
JRST .+2 ;YES
JRST CKCNXT ;No
MOVE T1,RSIZE(D) ;GET /RECORDSIZE
JUMPN T1,CKCNXT ;NONZERO, OK
; IOERR (RRR,30,507,?,Random IO requires /RECORDSIZE,,%POPJ)
$ECALL RRR,REQDIA ;"?Random IO requires /RECORDSIZE"
CKCNXT: TXNN F,F%DRE ;Skip if errors
AOS (P) ;No, skip return
POPJ P, ;Yes, return .+1
;CKSCRT--Routine to check for STATUS='SCRATCH' and also filespec given.
; If both specified, an error is generated. Either ERR= will be
; taken or F%DRE will be set.
;Call:
; PUSHJ P,CKSCRT
; <return here unless ERR= taken>
;On return, T1= status
CKSCRT: LOAD T1,STAT(D) ;Get STATUS
CAIE T1,ST.SCR ;SCRATCH?
POPJ P, ;No
TXNN F,F%FSS ;User specify filespec stuff?
POPJ P, ;No, ok
$ECALL SNM,REQDIA ;?STATUS='SCRATCH' with a named file!
;ROUTINE TO TYPE ERROR MESSAGE FOR CONFLICTING OPEN SWITCHES
;ARGS: %OPNK1 = KEYWORD NUMBER OF FIRST CONFLICTING SWITCH
; %OPNV1 = KEYWORD-VALUE NUMBER OF SWITCH
; %OPNK2 = KEYWORD NUMBER OF OTHER CONFLICTING SWITCH
; %OPNV2 = KEYWORD-VALUE NUMBER, OR -1 IF SWITCH DOESN'T TAKE VALUE
OPCONF: MOVE T1,%OPNK1 ;GET FIRST SWITCH NUMBER
MOVEI T2,OPNSWT ;POINT TO SWITCH TABLE
PUSHJ P,FNDSWT ;FIND CORRESPONDING STRING IN OPNSWT
EXCH T1,%OPNK1 ;SAVE STRING ADDRESS, GET SWITCH NUMBER
HRRZ T2,OPNDSP(T1) ;GET SWITCH VALUE TABLE ADDRESS
MOVE T1,%OPNV1 ;GET SWITCH VALUE NUMBER
PUSHJ P,FNDSWT ;FIND SWITCH VALUE STRING IN ITS TABLE
MOVEM T1,%OPNV1 ;STORE STRING ADDRESS
MOVE T1,%OPNK2 ;SAME FOR SECOND SWITCH
MOVEI T2,OPNSWT
PUSHJ P,FNDSWT
EXCH T1,%OPNK2
HRRZ T2,OPNDSP(T1)
SKIPGE T1,%OPNV2
SKIPA T1,[[0]]
PUSHJ P,FNDSWT
MOVEM T1,%OPNV2
; IOERR (ICA,30,506,?,Incompatible attributes /$Z$Z /$Z$Z,<%OPNK1,%OPNV1,%OPNK2,%OPNV2>,REQDIA)
$ECALL ICA,REQDIA
;CNFDEV - Check for conflicts for OPEN device
;If there is a conflict, either ERR= is taken or
; an error message is typed and F%DRE is set.
;Readonly devices cannot do output
CNFDEV: LOAD T1,IO(D) ;Get possible IO values
TRNE T1,2 ;Can device do output?
JRST CNFDV1 ;Yes, ok
LOAD T1,ACC(D) ;Get access
CAIE T1,AC.SOU ;SEQOUT
CAIN T1,AC.APP ;APPEND
JRST CNFDAC ;Yes, conflict
CAIE T1,AC.RIO ;RANDOM (DIRECT)
CAIN T1,AC.RIN ;RANDIN
JRST CNFDAC ;Yes, conflict
JRST CNFDV1 ;Yes, ok
;T1= Access type that conflicts
CNFDAC: MOVEI T2,SWACC ;Get switch value table address
PUSHJ P,FNDSWT ;Find switch value string in its table
; IOERR (IAC,30,248,/ACCESS:$Z is illegal for this device)
$ECALL IAC,REQDIA ;Set F%DRE if ERR= not taken
;Writeonly devices cannot do input
CNFDV1: LOAD T1,IO(D) ;Get input/output possible
TRNE T1,1 ;Can device do input?
JRST CNFDV2 ;Yes, ok
LOAD T1,ACC(D) ;Get ACCESS
CAIE T1,AC.RIN ;No RANDOM allowed
CAIN T1,AC.RIO
JRST CNFDAC ;?conflict
CAIN T1,AC.SIN ;SEQIN
JRST CNFDAC ;?conflict
JRST CNFDV2 ;No conflict
;Check for DIRECT access specified for a sequential device
CNFDV2: LOAD T1,ACC(D) ;Get /ACCESS
CAIE T1,AC.RIN ;Random?
CAIN T1,AC.RIO
JRST .+2 ;Yes, check to see if device allows this
JRST CNFDV3 ;Not RANDOM access, all devices allow it
LOAD T2,DVTYP(D) ;Get type of device
IF20,<
CAIE T2,.DVDSK ;Disk
CAIN T2,.DVNUL ; and NUL: are the only random-access devices
JRST CNFDV3 ;OK, next test
>
IF10,<
CAIE T2,.TYDSK ;DSK: (and NUL: which gets this same value)
CAIN T2,.TYDTA ; and DECTAPE can do random-IO
JRST CNFDV3 ;OK, next test
>
;Device can not do RANDOM IO
;T1= ACCESS MODE
JRST CNFDAC
;/BLOCKSIZE only allowed with magtape.
CNFDV3: LOAD T1,BLKSZ(D) ;Get /BLOCKSIZE
JUMPE T1,CNFDV4 ;Jump if not specified
LOAD T1,INDX(D) ;Get device type
CAIN T1,DI.MTA ;Magtape?
JRST CNFDV4 ;Yes, ok
SETZ T1, ;Clear it
STORE T1,BLKSZ(D)
; IOERR (BSI,0,0,% BLOCKSIZE ignored: device is not a magnetic tape)
$ECALL BSI
;Check to see that the device can be opened in the requested mode
CNFDV4: LOAD T1,INDX(D) ;Get device type
LOAD T2,MODE(D) ;Get mode
JUMPE T2,CNFDV5 ;Jump if no mode specified (no conflict, then)
CAIN T2,MD.ASC ;Everything likes ASCII
JRST CNFDV5
;Not ASCII mode
CAIE T1,DI.DSK ;DSK: everything allowed
CAIN T1,DI.MTA ; also magtape
JRST CNFDV5 ;No conflict
LOAD T1,DVTYP(D) ;Get device type
IF10,<
CAIE T1,.TYDSK ;DSK: (append)
CAIN T1,.TYDTA ;DTA:
JRST CNFDV5 ;Everything allowed
CAIE T1,.TYTTY ;TTY:
CAIN T1,.TYPTY ; or PTY:
JRST CNFD4X ;Yes, conflict
>
IF20,<
CAIE T1,.DVDSK ;DSK: (append)
CAIN T1,.DVNUL ;NUL:
JRST CNFDV5 ;Everything allowed
CAIE T1,.DVTTY ;TTY:
CAIN T1,.DVPTY ;or PTY:?
JRST CNFD4X ;Yes, conflict
>
;Not TTY: or PTY:, everything else likes image
CAIN T2,MD.IMG ;Image?
JRST CNFDV5 ;Yes, no conflict
;Mode is not IMAGE or ASCII
IF10, CAIN T1,.TYLPT ;LPT:?
IF20, CAIN T1,.DVLPT ;LPT:?
JRST CNFD4X ;Yes, conflict
IF10,<
CAIN T1,.TYPLT ;Plotter?
JRST CNFD4X ;Yes, conflict
>;END IF10
;Not LPT: either, everthing else likes BINARY
CAIN T2,MD.BIN
JRST CNFDV5 ;No conflict
;Mode is LINED or DUMP (TOPS-10)
;We know that device is not MTA, DTA, DSK, NUL.
;ERROR- mode conflict with device
CNFD4X: MOVE T1,T2 ;Get /MODE value
MOVEI T2,SWMODE
PUSHJ P,FNDSWT ;Find switch value string in its table
; IOERR (IDM,n1,n2,/MODE:$A illegal for this device,T1)
$ECALL IDM,REQDIA ;Request DIALOG mode
CNFDV5: JRST %POPJ1 ;No error-- skip return
;CHKDLG - routine to check for dialog needed and do it
;Called from OPEN and CLOSE routines
;Returns when everything cleared up.
CHKDLG: TXZN F,F%DRE ;Dialog requested because of errors?
JRST CHKDL2 ;No
TXZ F,F%DIALOG ;Clear /DIALOG if set
CHKDL1: PUSHJ P,CLRCNS ;Clear DDB consolidation pointers, if any
PUSHJ P,DIALOG ;Do DIALOG (could set F%DRE again)
JRST CHKDLG ; Loop until no errors.
CHKDL2: TXZE F,F%DIALOG ;DIALOG requested?
JRST CHKDL1 ;Yes
POPJ P, ;Return
;FNDAGL:
;Routine to find UNIT=, ERR=, and IOSTAT= in the argument list
; and if there, store them in %CUNIT, A.ERR, and A.IOS respectively.
;
;Called by OPEN% and CLOSE%
;
;Inputs:
; L points to argument list
;Uses T1, T2, T3
;Leaves L intact
FNDAGL: SETZM A.ERR ;Not specified yet..
SETZM A.IOS
SETZM A.END
;"L" is "saved" in T1 below.
MOVE T1,L ;Keep L in T1 during this code.
;Find unit. If not specified, abort.
FAGL1A: LDB T2,[POINTR ((L),ARGKWD)]
CAIE T2,OK.UNIT
AOBJN L,FAGL1A
JUMPL L,FAGL1B ;Jump if we found it
; IOERR (UNS,30,501,?,Unit not specified,,%ABORT)]
$ECALL UNS,%ABORT ;?Unit not specified
FAGL1B: HRRE T2,@(L) ;Assume half-word negatives
MOVEM T2,%CUNIT ;Store UNIT= arg.
MOVE L,T1 ;Restore L
;Find ERR= and IOSTAT= if specified.
FAGL2A: LDB T2,[POINTR ((L),ARGKWD)]
CAIN T2,OK.ERR ;ERR=
JRST FAGL2B
CAIN T2,OK.IOS ;IOSTAT=
JRST FAGL2C
FAGL2E: AOBJN L,FAGL2A ;Loop thru arg list
MOVE L,T1 ;Restore L
POPJ P, ;Return
;ERR=
FAGL2B: XMOVEI T2,@0(L) ;Get address
MOVEM T2,A.ERR ;save it
JRST FAGL2E
;IOSTAT=
FAGL2C: XMOVEI T2,@0(L) ;Get address
MOVEM T2,A.IOS ;Save it
JRST FAGL2E ;Continue
;OPNRIO - Open random file for Input and Output.
; STATUS = 'unknown'
OPNRIO:
IF20,< SETZ T1,> ;No special JFN bits
PJRST OPCMO ;open for output
;OPNAPP - Open file when Access= 'APPEND'
OPNAPP:
IF20,< SETZ T1,> ;No special JFN bits
PJRST OPCMO ;Open for output
;OPNOLD - Open file for input
;This routine is called from OPEN to open a file when
; STATUS='OLD'.
OPNOLD:
IF20,< MOVX T1,GJ%OLD> ;FILE MUST EXIST
MOVX T3,D%IN ;Assume open for input
LOAD T2,ACC(D) ;But ACCESS might change it
CAIE T2,AC.SOU ;SEQOUT
CAIN T2,AC.APP ;APPEND
MOVX T3,D%OUT ;Will open file for output
TXNE T3,D%IN ;Open for input?
JRST OPCMI ;Yes
; JRST OPCMO ;Open for output
;Common routine to OPEN file for output
OPCMO: MOVX T0,D%IO ;Say "Doing output"
IORM T0,FLAGS(D) ;. .
IF10,< MOVX T1,D%OUT>
PUSHJ P,DOOPEN ;Do the OPEN
POPJ P, ;Problems, single return
MOVX T1,D%OUT ;Set "OPENED FOR OUTPUT"
IORM T1,FLAGS(D) ; . .
JRST %POPJ1 ;Skip return
;Common routine to open file for input
OPCMI: MOVX T0,D%IO ;Make sure "Doing output" bit
ANDCAM T0,FLAGS(D) ; is off
IF10,< MOVX T1,D%IN>
PUSHJ P,DOOPEN ;Do the OPEN
POPJ P, ;Problems, single return
MOVX T1,D%IN ;Set "OPENED for input"
IORM T1,FLAGS(D) ; . .
JRST %POPJ1 ;OK, skip return
;OPNNEW - Open file if status=new
; This routine is called only from OPEN when STATUS='NEW'.
; The file must not exist and is opened for output.
OPNNEW:
IF20,< MOVX T1,GJ%NEW> ;"File must not exist"
PJRST OPCMO ;Continue at common output code
;OPNOUT - Open file for output
; This is called from IO statements to open
;a file for output. If the file already exists, it is superseded.
OPNOUT:
IF20,< MOVX T1,GJ%FOU> ;New generation (supersede also)
PJRST OPCMO ;Go to common code
;OPNSCR - Open file if status=scratch
;This routine is called only from OPEN when STATUS='SCRATCH'.
; A random filename is generated and the file must not exist.
; It is opened for output.
IF10,<
OPNSCR: PJRST OPCMO ;Go to common output code
>
IF20,< ;TOPS-20 open scratch file routine
OPNSCR: PUSHJ P,%SAVE1 ;Free up P1
PUSHJ P,GMODBY ;Get info based on /MODE
MOVE T2,[POINT 7,[ASCIZ/FOROTS-SCRATCH-FILE.TMP/]]
SETZ P1, ;Number of tries so far = 0
OPNTX0: PUSHJ P,GTSNAM ;Get a scratch name
MOVX T1,GJ%SHT!GJ%FOU ;Next generation number, pls
GTJFN% ;Get handle on a temp file
ERJMP OTME01 ;Can't
STORE T1,OJFN(D) ;Store it
STORE T1,IJFN(D)
MOVX T3,D%RJN ;'Got a real JFN'
IORM T3,FLAGS(D) ;Set flag
;DO OPENF
LOAD T2,ACC(D)
CAIN T2,AC.RIO ;RANDOM?
JRST OPSCR ;Yes, open for input and output
MOVX T2,OF%WR ;SEQINOUT - OPEN FOR OUTPUT ONLY
OR T2,DMABS(D)
OPENF%
ERJMP OTME02 ;?Can't
JRST OPSCRA
OPSCR: MOVX T2,OF%RD+OF%WR ;Get initial bits for OPENF
OR T2,DMABS(D) ;Put in byte size
OPENF%
ERJMP OTME02 ;?Can't
JRST OPSCRA
OPSCRA: MOVX T1,D%OUT ;Say "File is opened for output"
IORM T1,FLAGS(D)
LOAD T1,INDX(D) ;Get device index
CAIE T1,DI.DSK ;Skip if disk
JRST OPSCRB ;Not DSK, skip UFPGS%
LOAD T1,OJFN(D) ;Get JFN
HRLZ T1,T1
SETZ T2, ;Update file pages to make the file appear
UFPGS%
ERJMP OTME03 ;?can't
OPSCRB: LOAD T1,ACC(D) ;GET ACCESS
MOVE T2,ACCTAB(T1) ;Get bits to set in DDB flags
IORM T2,FLAGS(D) ; Set 'em
PUSHJ P,OPFSTT ;Do DSKSET, etc.
POPJ P, ;Error, return .+1
JRST %POPJ1 ;Success, return
;Here if can't get JFN for file
OTME01: $ECALL OPE,%ABORT ;Wierd OPEN error
;Here if OPENF% failed
OTME02: CAIE T1,OPNX9 ;Invalid simultaneous access?
$ECALL OPE,%ABORT ;No, take ERR= or abort
; (No dialog if SCRATCH open fails!)
;OPENF% failed because of invalid simultanous access.
;Note that this should only happen if there are two users on the system
; and one has opened a file with the same name as this user but has not
; done an "UPFGS" JSYS yet. We will simply pick another name, try that,
; and if it continues to fail the same way we'll just give the error.
ADDI P1,1 ;Increment number of tries
CAILE P1,5 ;Tried too many times?
$ECALL OPE,%ABORT ;Yes, go give the error
LOAD T1,OJFN(D) ;Get JFN
RLJFN%
ERJMP .+1 ;This should never happen
MOVX T1,D%RJN ;Don't have a real JFN anymore
ANDCAM T1,FLAGS(D) ;Clear the DDB flag
SETZ T1,
STORE T1,OJFN(D)
STORE T1,IJFN(D)
MOVEI T1,^D100 ;Sleep for a fraction of a second
DISMS%
GTAD% ;Return current date/time
ANDI T1,3 ;Get random number 0 to 3
MOVE T2,OTMFNS(T1) ;Get a random filename
JRST OPNTX0 ;Go try again
;Table of four random filenames
OTMFNS: POINT 7,[ASCIZ/WXX.TMP/]
POINT 7,[ASCIZ/XXX.TMP/]
POINT 7,[ASCIZ/YXX.TMP/]
POINT 7,[ASCIZ/ZXX.TMP/]
;Here if UPFGS% JSYS fails
OTME03: $ECALL OPE,%ABORT ;Type JSYS error, abort.
; (or take ERR=)
;Routine to get a scratch name
;Call:
; T2/ byte ptr to file name
;Return:
; T2/ byte ptr to whole filespec
GTSNAM: PUSH P,T2 ;Save ptr to name
MOVE T1,[POINT 7,SNAMEX]
MOVE T2,[POINT 7,DEV(D)]
PUSHJ P,CPYNUL ;Copy to null
MOVEI T3,":" ;Colon separator after device
IDPB T3,T1
POP P,T2 ;Retrieve ptr to name
LOAD T3,INDX(D) ;Get device index
CAIN T3,DI.MTA ;Magtape?
JRST GTSNDN ;Yes, done (no file name needed)
PUSHJ P,CPYNUL ; Append filename to string
MOVE T2,[POINT 7,[ASCIZ/.-1;T/]] ;Say "temp file"
LOAD T3,INDX(D) ;Device index again
CAIN T3,DI.DSK ;DSK?
PUSHJ P,CPYNUL ;Yes, append ".-1;t" to string
GTSNDN: SETZ T3, ;Store null byte to end
IDPB T3,T1
MOVE T2,[POINT 7,SNAMEX] ;Get ptr to whole thing
POPJ P, ;And return
;Copy to null
;T1/ ptr to string to append to
;T2/ ptr to string to append
;Returns:
;T1/ updated string ptr.
CPYNUL: ILDB T3,T2 ;Get a byte
JUMPE T3,%POPJ ;Jump when got a null
IDPB T3,T1 ;Store it
JRST CPYNUL ;Loop
SEGMENT DATA
SNAMEX: BLOCK 100 ;ASCIZ scratch file name
SEGMENT CODE
>;END IF20
;%SETIN-- Get file opened for input
; If already open for input, just returns.
; If file has been opened for output, closes it.
%SETIN: MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%IN ;File already opened for input?
POPJ P, ;Yes, nothing to do
TXNN T1,D%OUT ;Skip if file opened for output
JRST OPIN ;No, open for input
TXZ T1,D%IO ;PATCH - TURN OFF OUTPUT BIT
MOVEM T1,FLAGS(D) ;AND SAVE AWAY AGAIN
;File is now opened for output.
SWIN: LOAD T1,ACC(D) ;Get access
MOVE T2,LOUTIN(T1) ;Switch direction to input
PUSHJ P,(T2)
MOVE T1,FLAGS(D) ;Get DDB flags
TXZ T1,D%OUT ;Clear old direction flag
TXO T1,D%IN ;Set new direction flag
MOVEM T1,FLAGS(D) ;Set in DDB
POPJ P, ;Return
;Open file for input.
OPIN: LOAD T1,ACC(D) ;Get access
MOVE T2,NIOIN(T1) ;First READ routine
PUSHJ P,(T2) ;Do OPEN if necessary
JRST FSTINF ;?Failed to OPEN file
MOVX T1,D%IN ;Set "File opened for input"
IORM T1,FLAGS(D) ; Set in DDB
POPJ P, ;Return
;First READ failed to OPEN file
FSTINF: PUSHJ P,OPENX ;Do generic OPEN
JRST %SETIN ;Go try again
;%SETOUT-- Get file opened for output
; If already open for output, just return.
; If file is read-only, give error (%ABORT).
; If file is open for input, closes it and opens for output.
; (What happens in this case depends on the device).
;Returns .+1
%SETOUT: LOAD T1,MODE(D) ;Get MODE
CAIN T1,MD.ASL ;'LINED'?
$ECALL CWL,%ABORT ;Yes, can't do it.
MOVE T1,FLAGS(D) ;Get DDB flags now
TXO T1,D%IO ;Set "doing output"
IORM T1,FLAGS(D)
TXNE T1,D%OUT ;File already opened for output?
POPJ P, ;Yes, nothing to do
TXNN T1,D%IN ;Skip if file was opened for input
JRST OPOUT ;Open file for output
;File was open for input, switch to output
LOAD T1,ACC(D) ;Get access mode
MOVE T2,LINOUT(T1) ;Get routine
PUSHJ P,(T2) ;Set new direction
MOVE T1,FLAGS(D) ;Get DDB flags to change
TXZ T1,D%IN ;Clear input
TXO T1,D%OUT ;Set output
MOVEM T1,FLAGS(D) ;Set new flags
POPJ P, ;Done, return
;Open file for output. Supersede any file with same name.
OPOUT: LOAD T1,ACC(D) ;Get access
MOVE T2,NIOOUT(T1) ;First WRITE action
PUSHJ P,(T2) ;Call routine
JRST FWTFAI ;?Failed, no ERR= taken.
MOVX T1,D%OUT ;Set output
IORM T1,FLAGS(D)
POPJ P, ;Return
;First WRITE failed to OPEN file.
FWTFAI: PUSHJ P,OPENX ;Generic OPEN again.
JRST %SETOUT ;And set output again.
ILLIN: DMOVE T1,[EXP [ASCIZ /read/],[ASCIZ /output/]]
JRST CDT
ILLOUT: DMOVE T1,[EXP [ASCIZ /write/],[ASCIZ /input/]]
CDT: XMOVEI T1,(T1) ;Section number in LH
XMOVEI T2,(T2) ;. .
; IOERR (CDT,31,502,?,Can't $A an $A-only file,<T1,T2>,%ABORT)
$ECALL CDT,%ABORT
;HERE TO FIND OUT WHAT TO DO IF LAST OPERATION WAS INPUT
;AND NEXT OPERATION IS INPUT, BY ACCESS TYPE
LININ: %POPJ ;SEQINOUT
%POPJ ;SEQIN
%POPJ ;SEQOUT
%POPJ ;SEQINOUT
%POPJ ;RANDIN
%POPJ ;RANDOM
%POPJ ;APPEND
;HERE TO FIND OUT WHAT TO DO IF LAST OPERATION WAS INPUT
;AND NEXT OPERATION IS OUTPUT, BY ACCESS TYPE
LINOUT: OSWTCH ;SEQINOUT
ILLOUT ;SEQIN
OSWTCH ;SEQOUT
OSWTCH ;SEQINOUT
ILLOUT ;RANDIN
%POPJ ;RANDOM
OSWTCH ;APPEND
;HERE TO FIND OUT WHAT TO DO IF LAST OPERATION WAS OUTPUT
;AND NEXT OPERATION IS INPUT, BY ACCESS TYPE
LOUTIN: ISWTCH ;SEQINOUT
ISWTCH ;SEQIN
ISWTCH ;SEQOUT
ISWTCH ;SEQINOUT
%POPJ ;RANDIN
%POPJ ;RANDOM
ISWTCH ;APPEND
;HERE TO FIND OUT WHAT TO DO IF LAST OPERATION WAS OUTPUT
;AND NEXT OPERATION IS OUTPUT, BY ACCESS TYPE
LOUTOU: %POPJ ;SEQINOUT
ILLOUT ;SEQIN
%POPJ ;SEQOUT
%POPJ ;SEQINOUT
ILLOUT ;RANDIN
%POPJ ;RANDOM
%POPJ ;APPEND
;HERE TO FIND OUT WHAT TO DO IF NO I/O DONE BEFORE
;AND NEXT OPERATION IS INPUT, BY ACCESS TYPE
NIOIN: SEQIN ;SEQINOUT FIRST READ
%POPJ1 ;SEQIN
NIOISW ;SEQOUT
SEQIN ;SEQINOUT FIRST READ
%POPJ1 ;RANDIN
%POPJ1 ;RANDOM
NIOISW ;APPEND
NIOISW: PUSHJ P,ISWTC1 ;Switch to input
JRST %POPJ1 ;Success return
;HERE TO FIND OUT WHAT TO DO IF NO I/O DONE BEFORE
;AND NEXT OPERATION IS OUTPUT, BY ACCESS TYPE
NIOOUT: SEQOUT ;SEQINOUT FIRST WRITE
ILLOUT ;SEQIN
%POPJ1 ;SEQOUT
SEQOUT ;SEQINOUT FIRST WRITE
ILLOUT ;RANDIN
%POPJ1 ;RANDOM
%POPJ1 ;APPEND
;SEQINOUT
;HERE WHEN FIRST OPERATION IS READ
SEQIN:
IF20,< MOVX T1,GJ%OLD > ;LEAVE EXISTENCE TEST UNTIL OPENF%
IF10,< MOVX T1,D%IN>
PUSHJ P,DOOPEN ;Do the OPEN
POPJ P, ;Error
JRST %POPJ1 ;Successful OPEN, return .+2
;HERE WHEN FIRST OPERATION IS WRITE
SEQOUT:
IF20,< MOVX T1,GJ%FOU> ;Open new generation for output
IF10,< MOVX T1,D%OUT >
PUSHJ P,DOOPEN ;Do the OPEN
POPJ P, ;Error
JRST %POPJ1 ;Successful OPEN, return .+2
;HERE FOR SEQUENTIAL FILES ON INPUT FOLLOWING OUTPUT.
;-20: JUST CLEAR THE BYTE COUNT, SPECIFYING EOF.
;
;-10: CLOSE THE FILE, REOPEN FOR INPUT, READ THE LAST
;BLOCK, POINT TO THE END OF THE BLOCK.
;
;-20 Note: DISK APPEND file is DI.OTHR. It is opened on TOPS-20 for
;APPEND access and cannot do input. But to be fast, FOROTS will not
;check and will just POPJ from this routine to set D%IN. Then
;when input is about to be done, ACCESS='APPEND' and DISK will
;cause an EOF error. REWIND and BACKSPACE are no-ops for disk APPEND files.
ISWTCH:
ISWTC1: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIN T1,DI.DSK ;DISK?
JRST DSKISW ;YES
CAIN T1,DI.MTA ;OR MTA
JRST MTAISW ;YES
POPJ P, ;NO. NOTHING TO DO
IF20,<
DSKISW: LOAD T1,ACC(D) ;GET ACCESS
CAIN T1,AC.APP ;APPEND?
JRST ILLIN ;YES. CAN'T DO INPUT TO OUTPUT-ONLY FILE
SETZM ICNT(D) ;TELL DIREC WE'RE AT EOF!
POPJ P,
> ;IF20
IF10,<
DSKISW:
MTAISW: PJRST %ISET ;JUST LIKE A BACKSPACE, ALMOST
>; IF10
;HERE FOR OUTPUT FOLLOWING INPUT FOR ALL DEVICES.
OSWTCH: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIN T1,DI.DSK ;DISK
JRST DSKOSW ;YES
CAIN T1,DI.MTA ;OR MTA
JRST MTAOSW ;YES
POPJ P, ;OTHER
;TOPS-20 DISK OUTPUT SWITCH. IF THE FILE IS INPUT-ONLY, CLOSE
;AND OPEN IT FOR OUTPUT. OTHERWISE JUST USE THE CURRENT
;BUFFER AND BYTE POINTER. IN ANY CASE, WE HAVE TO SET
;THE BYTE COUNT (OCNT) TO THE NUMBER OF BYTES FROM THE
;CURRENT POINTER TO THE END OF A FULL WINDOW. THIS IS CALCULATED
;BY GETTING THE NUMBER OF WORDS FROM THE BEGINNING OF THE WINDOW,
;THEN MULTIPLYING BY BPW(D) TO GET BYTES, THEN SUBTRACTING THIS
;FROM THE FULL WINDOW SIZE, AND ADDING THE NUMBER OF BYTES LEFT
;IN THE CURRENT WORD. THIS LAST QUANTITY IS CALCULATED BY A BIT
;OF "MAGIC" ARITHMETIC: A MULTIPLY OF THE LEFT-HAND OF THE BYTE
;POINTER BY BPW(D); THE HIGH-ORDER WORD OF THE MULTIPLY YIELDS
;THE NUMBER OF LEFTOVER BYTES. THE ARITHMETIC IS, IN FACT,
;MULTIPLYING THE NUMBER OF BITS TO THE RIGHT OF THE CURRENT BYTE
;BY BPW AND THEN DIVIDING BY 32 (BY DINT OF THE
;POSITION WITHIN THE BYTE POINTER OF THE NUMBER OF BITS TO THE
;RIGHT OF THE CURRENT BYTE). THE FORMULAE FOR 6, 7, 8, AND 9-BIT
;BYTES ARE THEN:
;
;6-BIT (N*6)*6/32
;
;7-BIT (N*7+1)*5/32
;
;8-BIT (N*8+4)*4/32
;
;9-BIT (N*9)*4/32
;
;WHERE N IS THE NUMBER OF LEFTOVER BYTES. AS YOU CAN SEE, THE
;QUOTIENT OF ALL OF THESE FORMULAE IS N. SOME OTHER BYTE SIZES WORK
;AS WELL. WE SHALL NOT PRESENT HERE THE THEORETICAL BASIS FOR THE
;ARITHMETIC.
IF20,<
DSKOSW: PUSHJ P,%SAVE3 ;SAVE P ACS
MOVE T1,FLAGS(D) ;GET FLAGS
TXZE T1,D%END ;END OF FILE?
SOS CREC(D) ;[2042] YES. DECR THE RECORD COUNT
MOVEM T1,FLAGS(D) ;SAVE FLAGS WITHOUT EOF
MOVE T1,BYTN(D) ;GET BYTE # OF NEXT WINDOW
SUB T1,ICNT(D) ;GET LAST BYTE IN USE
MOVEM T1,EOFN(D) ;SAVE AS EOF PNTR
TXNN T1,D%WRT ;DO WE HAVE WRITE ACCESS ALREADY?
JRST CLSOUT ;NO. CLOSE FILE, OPEN FOR WRITE
SKIPN IPTR(D) ;YES. ANY DATA IN THIS WINDOW?
POPJ P, ;NO. NOTHING MORE TO DO
HRRZ T1,IPTR(D) ;GET WORD ADDR
SUB T1,WADR(D) ;GET OFFSET WITHIN WINDOW
IMUL T1,BPW(D) ;GET BYTE OFFSET
HLLZ T2,IPTR(D) ;GET LEFT HALF OF BP
MUL T2,BPW(D) ;CALC # BYTES LEFT IN WORD
ADD T1,BPW(D) ;ADD THE CURRENT WORD
SUBI T1,(T2) ;MINUS THE LEFTOVER BYTES
MOVE T2,WSIZ(D) ;GET THE WINDOW SIZE
SUBI T2,(T1) ;GET # AVAILABLE BYTES
MOVEM T2,OCNT(D) ;SAVE IT FOR I/O
POPJ P, ;Return
CLSOUT: MOVX T1,D%WRT ;We have WRITE access now
IORM T1,FLAGS(D)
SETO T1, ;SET TO UNMAP FILE FOR CLOSING
MOVE T2,WPTR(D) ;GET PAGE ID OF FILE WINDOW
HRLI T2,.FHSLF
LOAD T3,BUFCT(D) ;GET PAGE COUNT
HRLI T3,(PM%CNT)
PMAP%
LOAD T1,IJFN(D) ;CLOSE FILE, KEEP JFN
HRLI T1,(CO%NRJ)
CLOSF%
; IOERR (OSW,30,,?,$J,,%ABORT)
$ECALL OSW,%ABORT
LOAD T1,OJFN(D) ;GET JFN BACK
MOVE T2,DMABS(D) ;GET DATA MODE AND BYTE SIZE
TRO T2,OF%WR ;GET WRITE ACCESS
SKIPE IPTR(D) ;ANY DATA YET?
TRO T2,OF%RD ;YES. OPEN FOR READ ALSO
OPENF% ;REOPEN FILE
; IOERR (OSW,30,,?,$J,,%ABORT) ;CAN'T
$ECALL OSW,%ABORT
MOVE P1,IPTR(D) ;GET CURRENT WINDOW BYTE PNTR
JUMPE P1,ZERPNT ;NO DATA NEEDED YET IF 0
PUSHJ P,%PTOF ;CONVERT TO FILE ADDRESS
JUMPL P1,ZERPNT ;IF NEG FILE POSITION, NO DATA NEEDED
MOVEM P1,BYTN(D) ;SAVE FOR SMAPW
PJRST %OSMAP ;MAP IT
ZERPNT: SETZM OPTR(D) ;CLEAR PNTR/COUNT
SETZM OCNT(D)
POPJ P,
> ;IF20
;TOPS-10 OSWTCH
;FOR DISK AND MAGTAPE, TRUNCATE FILE AT CURRENT INPUT POINTER,
;OPEN FOR OUTPUT, AND COPY THE DATA INTO THE OUTPUT BUFFER.
IF10,<
DSKOSW:
MTAOSW: LOAD T1,DMODE(D) ;GET DATA MODE
CAIE T1,.IODMP ;DUMP?
JRST OSNDMP ;NO
SKIPN BLKN(D) ;YES. NULL FILE?
PUSHJ P,OSWCRE ;YES. CREATE A NEW ONE
MOVX T1,D%END ;Clear EOF if any
ANDCAM T1,FLAGS(D)
SETZM PATNUM ;SET FOR NO PATCHING
PUSHJ P,OSWREL ;Close file, release channel.
PUSHJ P,OSWUPD ;Truncate file where we are now.
PJRST OSWOPN ;OPEN FOR OUTPUT AGAIN
OSNDMP: PUSHJ P,OSWPAT ;RECORD DATA TO TRANSFER
LOAD T1,WADR(D) ;GET THE CURRENT BUFFER ADDRESS
MOVEM T1,PATBUF ;SAVE IT (MUST DEALLOCATE IT LATER)
SKIPE PATNUM ;ANY PATCHING TO DO
JRST OSWNDL ;YES. CAN'T POSSIBLY BE NULL FILE
;NO. CURRENT BLOCK HAS NO RELEVANT DATA
;SO THAT ACTUAL BLOCK COUNT SHOULD
;BE DECREMENTED, UNLESS IT'S ALREADY ZERO
SKIPE BLKN(D) ;IF # BLOCKS IN FILE ZERO
SOSG BLKN(D) ;OR DECREMENTING IT MAKES IT ZERO
PUSHJ P,OSWCRE ;DELETE FILE IF NO BLOCKS
OSWNDL: PUSHJ P,OSWREL ;RELEASE THE CHANNEL
PUSHJ P,OSWUPD ;TRUNCATE FILE, REWRITE LAST BLOCK
PUSHJ P,OSWOPN ;REOPEN FOR UPDATE MODE
MOVE T1,PATBUF ;GET THE OLD BUFFER SET
PJRST %FREBLK ;DEALLOCATE IT
OSWPAT: SETZM PATNUM ;INIT # OF PATCH WORDS
LOAD T1,INDX(D) ;GET DEVICE INDEX
MOVE T2,FLAGS(D) ;Get DDB flags
TXZN T2,D%END ;Clear EOF, skip if it was on.
JRST NOBACK ;No. Don't back over EOF
MOVEM T2,FLAGS(D) ;Remember we cleared EOF
CAIN T1,DI.DSK ;DISK?
JRST YESBAK ;YES. GO BACK OVER IT
SETZM BLKN(D) ;NO. WRITING A NEW FILE
SETZM CREC(D) ;CLEAR RECORD COUNT
POPJ P,
YESBAK: PUSHJ P,%BAKEF ;BACK OVER EOF
SOS CREC(D) ;[2042] DECR THE RECORD COUNT
NOBACK: SKIPN BLKN(D) ;NULL FILE?
POPJ P, ;YES. NOTHING MORE TO DO
MOVE T1,IPTR(D) ;SAVE AWAY THE PNTR
MOVEM T1,PATPNT
MOVE T1,IBCB(D) ;GET THE BUFFER HEADER PNTR
HRRZ T1,1(T1) ;GET THE # WORDS IN THIS BUFFER
JUMPE T1,NOPAT ;IF ZERO, NO PATCHING TO DO
IMUL T1,BPW(D) ;GET THE # BYTES IN THIS BUFFER
SUB T1,ICNT(D) ;GET THE # BYTES USED
MOVEM T1,PATCNT ;SAVE FOR LATER
IDIV T1,BPW(D) ;GET # CHARS IN PARTIALLY USED WORD
JUMPE T2,NOZBYT ;NONE
HRRZ T3,IPTR(D) ;GET ADDR OF LAST BYTE
LDB T1,[POINT 6,IPTR(D),5];GET # BYTES LEFT
MOVE T1,%RTMSK(T1) ;GET A MASK
ANDCAM T1,(T3) ;CLEAR THE TRAILING BITS
NOZBYT: HRRZ T3,IPTR(D) ;GET ADDR OF LAST BYTE
HRRZ T2,IBCB(D) ;GET ADDRESS OF BUFFER
SUBI T3,1(T2) ;GET NUMBER OF WORDS
MOVEM T3,PATNUM ;SAVE FOR DUMP MODE WRITE LATER
ADDI T2,2 ;SAVE ADDR OF ACTUAL BUFFER
MOVEM T2,PATADD ;SAVE ADDRESS ALSO
NOPAT: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.MTA ;MAGTAPE?
POPJ P, ;NO. WE'RE DONE
PUSHJ P,%CLRBC ;COUNT ACTIVE BUFFERS
PUSH P,P4 ;Get a spare perm AC
MOVE P4,T1 ;Get # of active buffers
OSWBKL: PUSHJ P,%BACKB
SOJG P4,OSWBKL ;BACKSPACE OVER THEM
POP P,P4 ;Restore P4
POPJ P,
OSWCRE: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.DSK ;DISK?
POPJ P, ;NO. DON'T DELETE THE MAGTAPE
MOVE T2,FBLK(D) ;GET CHANNEL STUFF
HRRI T2,.FOCLS ;CLOSE THE FILE
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR ;SHOULDN'T EVER HAPPEN
SETZM LKPB+.RBALC(D) ;MAKE THE FILE NULL
MOVEI T1,.FOWRT ;CREATE A NEW FILE
HRRM T1,FBLK(D) ;USING THE FULL FILOP BLOCK
MOVEI T1,FBLK(D)
HRLI T1,FLEN
FILOP. T1,
; IOERR (OSW,,,?,$E,<T1>,%ABORT)
$ECALL OSW,%ABORT
POPJ P,
OSWREL: MOVE T2,FBLK(D) ;GET CHANNEL STUFF
HRRI T2,.FOCLS ;CLOSE THE FILE
MOVE T1,[1,,T2] ;WITH A FILOP
FILOP. T1,
PUSHJ P,CLSERR
MOVE T2,FBLK(D)
HRRI T2,.FOREL ; AND RELEASE THE FILE
MOVE T1,[1,,T2] ;WITH A FILOP
FILOP. T1,
PUSHJ P,CLSERR
POPJ P,
OSWUPD: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.MTA ;MAGTAPE?
SKIPN T1,BLKN(D) ;OR NULL FILE?
POPJ P, ;YES. NOTHING TO UPDATE
MOVEM T1,LKPB+.RBALC(D)
MOVE T1,[FO.PRV+FO.ASC+.FOSAU] ;UPDATE MODE
MOVEM T1,FBLK(D) ;STORE IN FILOP BLOCK
PUSH P,FBLK+.FOIOS(D) ;SAVE THE OLD MODE
MOVEI T1,17 ;SET TO DUMP MODE
MOVEM T1,FBLK+.FOIOS(D)
SETZM FBLK+.FOBRH(D) ;CLEAR THE BLOCK HEADERS
SETZM FBLK+.FONBF(D) ;AND # BUFFERS
MOVEI T1,FBLK(D) ;SETUP FOR OPEN
HRLI T1,FLEN
FILOP. T1,
; IOERR (OSW,,,?,$E,<T1>)
$ECALL OSW,%ABORT
SKIPN PATNUM ;ANYTHING TO WRITE?
JRST NDUMP ;NO
MOVE T3,BLKN(D) ;GET BLOCK # OF LAST BLOCK
HLLZ T2,FBLK(D) ;SETUP FOR USETO
HRRI T2,.FOUSO
MOVE T1,[2,,T2]
FILOP. T1, ;SET TO LAST BLOCK
; IOERR (OSW,,,?,$E,<T1>,%ABORT)
$ECALL OSW,%ABORT ;Must be there.
MOVN T1,PATNUM ;GET # WORDS TO WRITE
HRLZI T1,(T1) ;IN IOWD
HRR T1,PATADD
SUBI T1,1
MOVEM T1,OLST ;SETUP OUTPUT LIST
SETZM OLST+1
MOVEI T3,OLST ;SETUP TO DO OUTPUT
MOVE T2,FBLK(D) ;GET CHANNEL STUFF
HRRI T2,.FOOUT
MOVE T1,[2,,T2] ;DO THE FILOP
FILOP. T1,
; IOERR (OSW,,,?,$E,<T1>)
$ECALL OSW,%ABORT
NDUMP: MOVE T2,FBLK(D) ;GET CHANNEL STUFF
HRRI T2,.FOCLS ;CLOSE THE FILE
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR
MOVE T2,FBLK(D)
HRRI T2,.FOREL ;RELEASE THE FILE
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR
POP P,FBLK+.FOIOS(D) ;RESTORE OLD DATA MODE
POPJ P,
OSWOPN: PUSHJ P,%SAVE1 ;Uses P1
MOVE T1,[FO.PRV+FO.ASC+.FOSAU] ;UPDATE MODE
MOVEM T1,FBLK(D) ;STORE IN FILOP BLOCK
SETZM LKPB+.RBALC(D) ;DON'T RESET THE BLOCK COUNT
MOVE T1,FLAGS(D) ;Get DDB flags
TXZ T1,D%IN ;Clear the input bit
TXO T1,D%IO ;Set for output direction
MOVEM T1,FLAGS(D) ;Store updated flags
MOVX T1,D%OUT ;Set for output only
PUSHJ P,ALLBUF ;AND ALLOCATE BUFFERS
PUSHJ P,DOFLP ;Now do the FILOP.
JRST [PUSHJ P,FLPFL ;Give error, FILOP failed
JRST %ABORT] ;Forget DIALOG.
SKIPN T3,BLKN(D) ;GET BLOCK # OF LAST BLOCK
POPJ P, ;DON'T PROCEED IF NO DATA!
LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.DSK ;DISK?
JRST OSWMOP ;NO. MAGTAPE
SKIPN PATNUM ;ANY PATCHING IN THIS BLOCK?
ADDI T3,1 ;NO. THEN WE WANT BEG OF NEXT ONE!
HLLZ T2,FBLK(D) ;SETUP FOR USETO
HRRI T2,.FOUSO
MOVE T1,[2,,T2]
FILOP. T1, ;SET TO LAST BLOCK
PUSHJ P,CLSERR ;MIGHT NOT BE THERE
OSWMOP: SKIPN PATNUM ;ANYTHING TO BLT?
POPJ P, ;NO. DON'T DO INITIAL OUTPUT
MOVE T2,FBLK(D) ;DO INITIAL OUTPUT
HRRI T2,.FOOUT
MOVE T1,[1,,T2]
FILOP. T1,
; IOERR (OSW,,,?,$E,<T1>)
$ECALL OSW,%ABORT
HRLZ T1,PATADD ;NOW BLT THE DATA TO THE NEW BLOCK
HRR T1,OPTR(D)
ADDI T1,1
HRRZ T2,OPTR(D)
ADD T2,PATNUM
BLT T1,(T2)
MOVE T1,PATPNT ;NOW FIX UP THE PNTR/COUNT
HLLM T1,OPTR(D) ;PNTR FIXUP
MOVE T1,PATNUM ;AND ADDR FIXUP
ADDM T1,OPTR(D)
MOVN T1,PATCNT ;GET NEG # BYTES USED
ADDM T1,OCNT(D) ;UPDATE THE COUNT
POPJ P,
%LSTBF: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.MTA ;MAGTAPE?
POPJ P, ;NO. -10 CLOSE WRITES LAST BUFFER
LOAD T1,MODE(D) ;GET MODE
CAIN T1,MD.DMP ;DUMP?
POPJ P, ;YES. DON'T DO ANYTHING!
MOVE T2,CHAN(D) ;BUT FOR MTA A TAPE MARK
HRRI T2,.FOOUT ;WON'T GET WRITTEN
MOVE T1,[1,,T2] ;UNLESS AN INITIAL OUTPUT IS DONE
FILOP. T1,
$ECALL IOE,%ABORT ;ERROR. DIE
POPJ P,
>;END IF10
SEGMENT DATA
IF10,<
PATADD: BLOCK 1 ;ADDRESS OF DATA TO DUMP
PATNUM: BLOCK 1 ;NUMBER OF WORDS TO DUMP
PATPNT: BLOCK 1 ;PNTR OF OLD BUFFER
PATCNT: BLOCK 1 ;COUNT OF BYTES USED IN OLD BUFFER
PATBUF: BLOCK 1 ;BUFFER BLOCK ALLOCATED
OLST: BLOCK 2 ;DUMP I/O LIST
>;END IF10
SEGMENT CODE
IF20,<
;HERE FOR SEQINOUT MTA ONLY ON READ WHEN FILE IS OPEN FOR OUTPUT
MTAISW: PUSHJ P,%LSTBF ;WRITE LAST BUFFER
SETZM ICNT(D) ;BUFFER HAS NO MORE BYTES IN IT
PUSHJ P,CLSOPN ;CLOSE FILE, OPEN FOR INPUT
LOAD T1,IJFN(D) ;%LSTBF (ABOVE) WROTE AN EOF MARK, BACK OVER IT
MOVEI T2,.MONOP ;FIRST WAIT FOR I/O TO STOP
MTOPR%
MOVEI T2,.MOBKR ;DO THE BACKSPACE
MTOPR%
MOVEI T2,.MONOP ;WAIT FOR TAPE TO STOP
MTOPR%
POPJ P, ;DONE
%LSTBF: PUSHJ P,%SAVE2 ;SAVE P1,P2
DMOVE P1,OPTR(D) ;GET PNTR/COUNT
JUMPE P1,LSBCLS ;IF NO I/O YET, NOTHING MUCH TO DO
MOVEI T1,(P1) ;GET JUST ADDRESS OF LAST DATA
CAML T1,WADR(D) ;ANY DATA IN WINDOW?
PUSHJ P,%OBUF ;YES. OUTPUT BUFFER
LSBCLS: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.MTA ;MAGTAPE?
POPJ P, ;NO
LOAD T1,IJFN(D) ;GET JFN AGAIN
MOVEI T2,.MONOP ;WAIT FOR I/O TO STOP
MTOPR%
MOVEI T2,.MOEOF ;WRITE AN EOF MARK
MTOPR%
MOVEI T2,.MONOP ;AND WAIT AGAIN
MTOPR%
POPJ P,
%CLSOP:
CLSOPN: LOAD T1,OJFN(D) ;CLOSE FILE
HRLI T1,(CO%NRJ) ;KEEP JFN
CLOSF%
; IOERR (ISW,31,,?,$J,,%ABORT)
$ECALL ISW,%ABORT
LOAD T1,IJFN(D) ;GET JFN AGAIN (WITHOUT BITS IN LH)
MOVE T2,DMABS(D) ;GET DATA MODE & BYTE SIZE FOR OPENF
TRO T2,OF%RD ;SET FOR INPUT
OPENF% ;REOPEN FILE
$ECALL ISW,%ABORT
POPJ P,
;HERE FOR SEQINOUT MTA ONLY ON WRITE WHEN TAPE IS OPEN FOR INPUT
MTAOSW: MOVE T1,FLAGS(D) ;Get DDB flags
TXZN T1,D%END ;CLEAR ALL EOF BITS
JRST MTANEF ;NOT AT EOF
MOVEM T1,FLAGS(D) ;Remember we cleared the EOF flag
SETZM CREC(D) ;CLEAR RECORD COUNT
JRST MTACLO ;AND JUST GO CLOSE AND REOPEN
MTANEF: SKIPN IPTR(D) ;ANY I/O DONE YET?
JRST MTACLO ;NO. GO CLOSE, OPEN
LOAD T1,IJFN(D) ;GET JFN
MOVEI T2,.MONOP ;WAIT FOR I/O TO FINISH
MTOPR%
MOVEI T2,.MOBKR ;BACKSPACE RECORD
MTOPR%
MOVEI T2,.MONOP ;AND WAIT FOR IT TO FINISH AGAIN
MTOPR%
HRRZ T1,IPTR(D) ;GET WORD ADDR
SUB T1,WADR(D) ;GET OFFSET WITHIN WINDOW
IMUL T1,BPW(D) ;GET BYTE OFFSET
HLLZ T2,IPTR(D) ;GET LEFT HALF OF BP
MUL T2,BPW(D) ;CALC # BYTES LEFT IN WORD
ADD T1,BPW(D) ;ADD THE CURRENT WORD
SUBI T1,(T2) ;MINUS THE LEFTOVER BYTES
MOVE T2,WSIZ(D) ;GET THE WINDOW SIZE
SUBI T2,(T1) ;GET # AVAILABLE BYTES
MOVEM T2,OCNT(D) ;SAVE IT FOR I/O
MTACLO: LOAD T1,IJFN(D) ;REOPEN FILE FOR OUTPUT
HRLI T1,(CO%NRJ)
CLOSF%
$ECALL OSW,%ABORT
LOAD T1,OJFN(D)
MOVE T2,DMABS(D)
TRO T2,OF%WR
OPENF%
$ECALL OSW,%ABORT
POPJ P,
>;END IF20
SUBTTL MOVE ARGUMENTS TO DDB
;** Warning: Uses P1-P4
OPNARG: PUSHJ P,DFDEV ;Setup default device
PUSHJ P,DFFILE ; and filename for this unit
OARGLP: LDB P1,[POINTR ((L),ARGKWD)] ;GET NEXT ARG KEYWORD
MOVE T1,OPARGN(P1) ;GET ADDR OF KEYWORD STRING
MOVEM T1,%OPNK1 ;SAVE FOR ERROR MSG
CAILE P1,OPNMAX ;RANGE CHECK
SKIPA T1,[OPNERR] ;OUT OF BOUNDS, ERROR
HLRZ T1,OPNDSP(P1) ;POINT TO ROUTINE FOR THIS ARG
IF10,<
MOVE T2,OPARGN(P1) ;Get address of ASCIZ arg name
MOVEM T2,%ARGNM ; To type incase errors
>
PUSHJ P,(T1) ;PUT ARG INTO DDB
AOBJN L,OARGLP ;GO DO NEXT ARG
POPJ P, ;ALL DONE, RETURN
;Here is the routine for CLOSE
CLSARG: PUSHJ P,DFDEV ;Setup default device
PUSHJ P,DFFILE ; and filename for this unit
CLARGL: LDB P1,[POINTR ((L),ARGKWD)] ;Get next arg keyword
CAILE P1,OPNMAX ;Range check
SKIPA T1,[OPNERR] ;Out of bounds, error
HLRZ T1,CLSDSP(P1) ;Point to routine for this arg
PUSHJ P,(T1) ;Call routine
AOBJN L,CLARGL ;Go do next arg
POPJ P, ;All done, return
;Routine to call when an OPEN arg is used in CLOSE but it is meaningless.
CLIGN: MOVE T1,P1 ;Get switch number
MOVEI T2,OPNSWT ;Switch table
PUSHJ P,FNDSWT ;Get t1= addr of ASCII arg.
$ECALL NCK,%POPJ ;?Not a CLOSE keyword, ignored
;UNIT=
OPNUNT: POPJ P, ;Return (we've already range-checked it
; and put it in unit block).
OPNKWD:
IF20,<
XMOVEI T1,ATMBUF ;MOVE ARG TO ATMBUF
PUSHJ P,MVARG
>
IF10,<
PUSHJ P,MAKEBP ;Get BP to arg in %SRCBP
PUSHJ P,PRSSWV ;Parse the switch value
JRST REQDIA ;?Error, request DIALOG
>
HRRZ T1,OPNDSP(P1) ;POINT TO KEYWORD TABLE
HRROI T2,ATMBUF ;POINT TO KEYWORD
PUSHJ P,TABLK ;LOOK UP KEYWORD IN TABLE
JRST KWDUNK ;NOT THERE
JRST KWDAMB ;AMBIGUOUS
HRRZ T2,(T1) ;GET VALUE
JRST OPNDPB ;GO STORE IT IN DDB
;Keyword recognizer for CLOSE keywords
CLSKWD:
IF20,<
XMOVEI T1,ATMBUF ;MOVE ARG TO ATMBUF
PUSHJ P,MVARG
>
IF10,<
PUSHJ P,MAKEBP ;Get BP to arg in %SRCBP
PUSHJ P,PRSSWV ;Parse the switch value
JRST REQDIA ;?Error, request DIALOG
>
HRRZ T1,CLSDSP(P1) ;POINT TO KEYWORD TABLE
HRROI T2,ATMBUF ;POINT TO KEYWORD
PUSHJ P,TABLK ;LOOK UP KEYWORD IN TABLE
JRST KWDUNK ;NOT THERE
JRST KWDAMB ;AMBIGUOUS
HRRZ T2,(T1) ;GET VALUE
JRST OPNDPB ;GO STORE IT IN DDB
OPNERR:; IOERR (UOA,30,503,%,<Unknown OPEN keyword $D, ignored>,<P1>,%POPJ)
$ECALL UOA,%POPJ
KWDUNK: XMOVEI P2,[ASCIZ /Unknown/]
TRNA
KWDAMB: XMOVEI P2,[ASCIZ /Ambiguous/]
MOVEI T1,(P1) ;GET KWD NUMBER
MOVEI T2,OPNSWT ;POINT TO SWITCH TABLE
PUSHJ P,FNDSWT ;FIND ASCII NAME OF SWITCH
XMOVEI T5,ATMBUF ;Point to atom buffer
; IOERR (ESV,30,241,?,$A keyword value /$Z$Z,<P2,T1,[ATMBUF]>,REQDIA)
$ECALL ESV,REQDIA
OPNINT: SKIPG T2,@(L) ;GET ARG
$ECALL IAV,%ABORT ;MUST BE POSITIVE
JRST OPNDPB ;Go store it in DDB
OPNZOK: MOVE T2,@(L) ;GET ARG
JRST OPNDPB ;Go store it in DDB
OPNADR: XMOVEI T2,@0(L) ;Get arg address
JRST OPNDPB ;GO STORE IT IN DDB
OPNSET: MOVEI T2,1 ;[3115]Get a turned-on-bit
OPNDPB: XCT OPSTOR(P1) ;STORE IN DDB
POPJ P,
PADCHR: LDB T2,[POINT 7,@(L),6] ;GET FIRST CHAR OF STRING
LDB T1,[POINTR ((L),ARGTYP)] ;[3115]Get arg type
CAIE T1,TP%CHR ;[3115]Character string?
JRST STOPAD ;[3115]NO.
MOVE T2,@(L) ;[3115]Load descriptor
ILDB T2,T2 ;[3115]Load the character
STOPAD: STORE T2,PADCH(U) ;STORE IN DDB
MOVEI T1,1 ;AND FLAG WE GOT ONE
STORE T1,PADSP(U)
POPJ P, ;RETURN
;Get next char from source string
;Returns char in T1
DPRCHR: PUSHJ P,DPRCHS ;Get char
CAIN T1," " ;Ignore spaces
JRST DPRCHR
POPJ P, ;Return
;Same as DPRCHR but space not ignored
;P4= # chars possibly left to parse
DPRCHS: SOJL P4,DPRNUL ;Return null if string ran out
ILDB T1,SRCBP
AOS %NCHRR
POPJ P, ;Return
DPRNUL: SETZ T1,
POPJ P,
OPNDEV: PUSHJ P,MAKEBP ;Setup SRCBP, %NCHRR, P4
PUSHJ P,PRSDEV ;Parse the device name
JRST REQDIA ;?Error, request dialog
TXO F,F%DSS ;Remember device specified
IF10,<
SKIPE T1,ATMBUF ;IF THERE IS A DEVICE
MOVEM T1,DEV(D) ;STORE IT
POPJ P, ;Return
> ;END IF10
IF20,<
SKIPN ATMBUF ;ANY CHARS?
POPJ P, ;NO. LET DEFAULT STAND
MOVE T1,[POINT 7,ATMBUF]
MOVE T2,[POINT 7,DEV(D)]
ILDB T3,T1
IDPB T3,T2
JUMPN T3,.-2
POPJ P, ;Return
> ;END IF20
IF10,<
PRSDEV: MOVE T3,[POINT 6,ATMBUF] ;Store sixbit in atom buffer
SETZM ATMBUF
PRSDV1: PUSHJ P,DPRCHS ;Get next char
JUMPE T1,%POPJ1 ;end ok
CAIE T1," " ;Space is legal end
CAIN T1,":" ;Colon ends
JRST %POPJ1
PUSHJ P,DPRCSX ;Else must be plain sixbit char
POPJ P, ;?Problem, return .+1
TLNE T3,770000 ;Room?
IDPB T1,T3 ;Yes, store char
JRST PRSDV1 ;Loop until end
>;END IF10
IF20,<
PRSDEV: MOVE T3,[POINT 7,ATMBUF]
SETZM ATMBUF ;CLEAR BUFFER
PRSDV1: PUSHJ P,DPRCHS ;Get char
JUMPE T1,PRSDVE ;End
CAIE T1," " ;Space
CAIN T1,":" ;or colon
JRST PRSDVE ;Is ok end
IDPB T1,T3 ;Store char
JRST PRSDV1 ;Loop
PRSDVE: SETZ T1, ;Store null to end
IDPB T1,T3
JRST %POPJ1 ;Return ok
>;END IF20
IF20,<
OPNDIR: TXO F,F%FSS ;Remember filespec stuff
MOVE T1,@(L) ;GET FIRST WORD OF ARG
TLNN T1,(177B6) ;LEADING ASCII CHAR NULL?
JRST OPNPPN ;YES, IT'S A PPN
XMOVEI T1,DIR(D) ;POINT TO PLACE TO STORE STRING
MOVEI T2,1 ;Break at first space
PUSHJ P,MAKEBP ;CREATE SOURCE/DEST BP
MOVEI P4,^D79 ;UP TO DEST SIZE
PJRST MOVARG ;GO TRANSFER ARG
OPNPPN: TLNE T1,-1 ;PROJECT NUMBER IN LH?
JRST OPNPP1 ;YES, XWD FORMAT
HRLZ T1,T1 ;No, doubleword format
XMOVEI T2,@(L) ;GET ADDR OF ARRAY
HRR T1,1(T2) ;GET PROGRAMMER NUMBER
OPNPP1: JUMPE T1,%POPJ ;ZERO MEANS "DEFAULT PATH"
MOVEM T1,DIR(D) ;STORE PPN
TXO F,F%PPN ;REMEMBER IT'S A PPN, NOT A STRING
POPJ P, ;DONE
>;END IF20
IF10,<
OPNDIR: TXO F,F%FSS ;Remember he supplied filespec info
PUSHJ P,%SAVE4 ;SAVE P1-P2
LDB T1,[POINTR ((L),ARGTYP)] ;GET ARG TYPE
CAIE T1,TP%CHR ;[3150] CHARACTER?
CAIN T1,TP%LIT ;ASCIZ LITERAL?
JRST OPPNST ;YES
MOVE P1,%SIZTB(T1) ;GET ELEMENT SIZE IN WORDS
XMOVEI P3,@(L) ;GET ARRAY ADDR
MOVE T1,(P3) ;GET FIRST WORD OF ARG
JUMPE T1,%POPJ ;ZERO MEANS DEFAULT PATH
TLNN T1,-1 ;PROJECT NUMBER IN LH?
JRST GETPRG ;NO. GET PROGRAMMER NUMBER
ADDI P3,(P1) ;POINT TO PATHS
JRST OPNPP1 ;SKIP GETTING PROG #
GETPRG: HRLZ T1,T1 ;NO, DOUBLEWORD FORMAT
HRR T1,1(P3) ;PUT IN PROGRAMMER NUMBER
ADDI P3,2 ;POINT TO PATHS
OPNPP1: MOVEM T1,PTHB+.PTPPN(D) ;STORE PPN
MOVEI P2,PTHB+.PTPPN+1(D) ;POINT TO PLACE FOR FIRST SFD
HRLI P2,-5 ;MAX # OF SFD'S
OPPNLP: SKIPN (P3) ;END OF LIST?
POPJ P, ;YES, DONE
SETZ T2, ;NO BREAK CHARS
MOVE T0,P3 ;GET ADDR
$BLDBP T0 ;CREATE A B.P.
MOVEM T0,SRCBP
XMOVEI T1,(P2) ;POINT TO PATH BLOCK
MOVEI P4,(P1) ;GET # WORDS/ENTRY
IMULI P4,5 ;GET # CHARS/ENTRY
PUSHJ P,MOVARG ;MOVE SFD NAME INTO PATH BLOCK
ADDI P3,(P1) ;POINT TO NEXT PATH
AOBJN P2,OPPNLP ;COPY WHOLE THING
POPJ P, ;DONE
OPPNST: PUSHJ P,MAKEBP ;Get SRCBP= BP to arg.
PUSHJ P,DPTH ;Go parse path
JRST REQDIA ;Error, go request dialog
POPJ P, ;Success, return
>;END IF10
IF20,<
SETPROT: TXO F,F%FSS ;Remember he typed filespec info
HRLZ T1,T2 ;Put binary protection in LH
MOVEI T0,6 ;GET DIGIT COUNT
MOVEI T3,PROT(D) ;POINT TO PROTECTION BUFFER
HRLI T3,(POINT 7,) ; FOR CONVERSION TO ASCIZ
PRTLP: MOVEI T2,"0"_-3 ;GET HALF A DIGIT
ROTC T1,3 ;GET OTHER HALF DIGIT FROM PROT
IDPB T2,T3 ;STORE IN BUFFER
SOJG T0,PRTLP ;DO 6 DIGITS
SETZ T2, ;TERMINATE WITH NULL
IDPB T2,T3
POPJ P,
>
IF10,<
SETPROT: TXO F,F%FSS ;Remember he typed filespec info
DPB T2,[POINTR (PROT(D),RB.PRV)] ;STORE IN DDB
POPJ P,
>
OPNFIL: MOVE T1,(L) ;GET ARG POINTER
MOVEM T1,FILSAG ;SAVE IT
POPJ P,
OPNDIA: LDB T1,[POINTR ((L),ARGTYP)] ;Get arg type
JUMPE T1,RQDIAX ;If immediate arg, no arg..
MOVE T1,(L) ;GET ARG POINTER
MOVEM T1,DIASAG ;SAVE IT
POPJ P, ;Return for more args.
;HERE TO MOVE FILE= OR DIALOG= STRING TO TEXT BUFFER
DIABLT: LDB T3,[POINTR STRARG,ARGTYP] ;GET ARG TYPE
CAIE T3,TP%CHR ;[3115]Character string?
JRST DIANST ;[3115]NO.
DMOVE P3,(P3) ;[3115]Load byte pointer & length
MOVEM P3,SRCBP ;[3115]Store pointer
JRST DIAFC ;[3115]Go move string
DIANST: $BLDBP P3 ;BUILD A BYTE POINTER
MOVEM P3,SRCBP ;SAVE IT
MOVE P4,%SIZTB(T3) ;GET SIZE OF VARIABLE IN WORDS
IMULI P4,IBPW ;GET IT IN CHARS
SKIPN DIARRY ;CAN IT BE AN ARRAY?
CAIN T3,TP%LIT ;OR IS IT A LITSTRING?
MOVEI P4,-1 ;YES. USE 2**18-1
DIAFC: MOVE T2,[POINT 7,TXTBUF] ;POINT TO BUFFER
SETZ T4, ;CLEAR COUNT OF CHARS TRANSFERRED
DIAFCL: ILDB T1,SRCBP ;GET A BYTE
JUMPE T1,DIAEFC ;SKIP IT IF NULL
CAIE T1," " ;OR SPACE
JRST DIABL2 ;DEPOSIT IF ANYTHING ELSE
DIAEFC: SOJG P4,DIAFCL ;GO SKIP MORE LEADING NULLS OR SPACES
JRST DIAEND ;NULL STRING
DIABL1: ILDB T1,SRCBP ;GET BYTE FROM ARG
JUMPE T1,DIAEND ;NULL, DONE
CAIE T1," " ;SPACE?
JRST DIABL2 ;NO. GO STORE IT
CAIE T3,TP%CHR ;TYPE CHARACTER?
CAIN T3,TP%LIT ;OR LITERAL?
JRST DIASKB ;YES. SKIP IT
SKIPN DIARRY ;CAN IT BE AN ARRAY?
JRST DIASKB ;NO. SKIP IT (MIGHT BE FILE .EXT)
JRST DIAEND ;YES. SPACE ENDS DIALOG STRING
DIABL2: CAILE T4,LTEXT*5-1 ;CHECK LENGTH BEFORE MOVING CHAR
$ECALL DTL,DIAEND ;DIALOG STRING TOO LONG
IDPB T1,T2 ;STORE CHAR
ADDI T4,1 ;INCR # CHARS ACTUALLY TRANSFERRED
DIASKB: SOJG P4,DIABL1 ;LOOP
JRST DIAEND ;CHAR COUNT EXHAUSTED
IF20,<
DIAEND: MOVEI T1,12 ;TERMINATE WITH LF
IDPB T1,T2
ADDI T4,2 ;COUNT IT AND ADD 1
MOVEM T4,CSB+.CMINC ;STORE IN CSB AS IF TEXTI HAD READ THE STRING
POPJ P, ;RETURN TO DIALOG SCANNER
> ;IF20
REQDIA: SKIPGE I.BAT## ;BATCH?
JRST %ABORT ;YES, DON'T TRY TO DIALOG WITH A .CTL FILE
TXO F,F%DRE ;Error condition caused us to go do DIALOG.
RQDIAX: TXO F,F%DIALOG ;REQUEST DIALOG
POPJ P, ;RETURN FROM ROUTINE CONTAINING ERROR
;ROUTINE TO LOOK UP STRING IN TABLE
;FINDS UNIQUE ABBREVIATIONS
;ARGS: T1 = ADDRESS OF TBLUK-FORMAT TABLE
; T2 = POINTER TO STRING TO FIND IN TABLE
;RETURN: T1 = ADDRESS OF TABLE ENTRY THAT MATCHES STRING
;NONSKIP RETURN IF NO MATCH
;1 SKIP IF AMBIGUOUS
;2 SKIPS IF OK
IF20,<
TABLK: TBLUK% ;LOOK UP STRING IN TABLE
TXNN T2,TL%NOM ;NO MATCH?
AOS (P) ;NO, ONE SKIP
TXNN T2,TL%NOM+TL%AMB ;AMBIGUOUS?
AOS (P) ;NO, ONE MORE SKIP
POPJ P, ;RETURN
>
IF10,<
;PRESERVES T5
TABLK: PUSHJ P,%SAVE3 ;SAVE P1-P3
MOVE P1,(T2) ;GET FIRST WORD OF SIXBIT STRING
MOVSI P3,(IFIW (T1)) ;MAKE POINTER TO SWITCH TABLE IN P3
HRRI P3,(T1)
MOVN T2,P1 ;GET RIGHTMOST BIT PRESENT IN WORD
AND T2,P1
JFFO T2,.+1 ;GET BIT NUMBER OF RIGHTMOST BIT
IDIVI T3,6 ;GET BYTE NUMBER OF THE BIT
LSH T2,-5(T4) ;RIGHT-JUSTIFY BIT WITHIN BYTE
MOVN P2,T2 ;MAKE MASK OF CHARS PRESENT IN THE WORD
HLRZ T1,(P3) ;SET TABLE INDEX TO TOP OF TABLE
SETO T4, ;INITIALIZE COUNT OF MATCHING SWITCHES
TABLP: HLRZ T2,@P3 ;GET ADDRESS OF A SWITCH
MOVE T3,(T2) ;GET FIRST WORD OF THE SWITCH
CAMN T3,P1 ;EXACT MATCH
SOJA T1,TABWIN ;YES, WIN NOW
AND T3,P2 ;MASK OUT IGNORED TRAILING CHARS
CAMN T3,P1 ;MATCH?
AOJA T4,.+2 ;YES, COUNT AND KEEP LOOKING
CAMLE T3,P1 ;DOES IT MATCH SWITCH WE'RE LOOKING FOR?
SOJG T1,TABLP ;NO MATCH AND NOT PAST SWITCH YET, LOOP
TABEND: JUMPL T4,%POPJ ;NO MATCHES, NONSKIP RETURN
CAME P1,(T2) ;EXACT MATCH ALWAYS WINS
JUMPG T4,%POPJ1 ;MORE THAN ONE MATCH, AMBIGUOUS RETURN
TABWIN: ADDI T1,1(P3) ;CONVERT OFFSET TO ADDRESS
JRST %POPJ2 ;EXACTLY ONE MATCH, FINE
>
;ROUTINE TO MOVE AN ASCII ARGUMENT TO SOME LOCAL BUFFER
;ARGS: T1 = ADDRESS OF 1-WORD (10) OR 16-WORD (20) BUFFER TO PUT ARG IN
; L = ADDRESS OF FORTRAN ARGUMENT POINTER
;RETURNS WITH ARGUMENT MOVED
MVARG: SETZ T2, ;STOP TRANSFER ONLY WHEN WHOLE STRING MOVED
MVARGX: PUSHJ P,MAKEBP ;GET SRCBP = BYTE POINTER TO ARG STRING
PJRST MOVARG ;GO MOVE THE STRING
;ROUTINE TO SET UP BYTE POINTER AND COUNT TO AN ARGUMENT STRING
;ARGS: L = ADDRESS OF FORTRAN ARGUMENT POINTER
;RETURN: SRCBP = BYTE POINTER TO STRING
; P4 = NUMBER OF CHARS IN STRING
MAKEBP: LDB T4,[POINTR ((L),ARGTYP)] ;GET ARG TYPE
CAIN T4,TP%CHR ;character string?
JRST BPCHAR ;YES. GO GET IT FROM DESCRIPTOR
XMOVEI T3,@0(L) ;Point to arg
$BLDBP T3 ;Build a byte ptr.
MOVEM T3,SRCBP ;Store in SRCBP.
MOVE P4,%SIZTB(T4) ;GET SIZE OF VARIABLE IN WORDS
IMULI P4,IBPW ;GET # CHARS
CAIN T4,TP%LIT ;LITERAL?
MOVEI P4,^D79 ;YES. MAX 16 WORDS WORTH
POPJ P, ;DONE
BPCHAR: DMOVE T3,@0(L) ;GET DESCRIPTOR
MOVEM T3,SRCBP ;SAVE BYTE POINTER
CAILE T4,^D79 ;SIZE BIGGER THAN OUR BUFFER?
MOVEI T4,^D79 ;YES. USE THE MAX SIZE
MOVEI P4,(T4) ;RETURN IT IN THE PROPER AC
POPJ P,
IF20,<
;ROUTINE TO MOVE ARG TO LOCAL AREA, STANDARDIZING IT
;CONVERTS TO UPPER CASE, REMOVES SPACES, PUTS IN ASCIZ NULL AT END
;COPIES ARG UNTIL IT ENDS OR UNTIL A BREAK CHAR
;
;ARGS: T1 = 30-BIT ADDRESS OF 8-WORD BLOCK TO PUT STRING INTO
; T2 = MASK OF BREAK CHARS WITH BIT 1_N ON IF CHAR 40+N TERMINATES ARG
; SRCBP = Ptr to arg.
; P4 = CHAR COUNT
;
;RETURN: T1 = CHAR THAT TERMINATED ARG, OR -1 IF SOURCE STRING EXHAUSTED
; SRCBP, P4 UPDATED
MOVARG: $BLDBP T1 ;Get BP to dest. string
MOVEM T1,DSTBP
BMVALP: ILDB T1,SRCBP ;GET A BYTE
JUMPE T1,MVAEND ;DONE IF NULL
CAIE T1,' ' ;SKIP LEADING BLANKS
JRST MVAL1 ;NON-BLANK CHAR
SOJG P4,BMVALP ;BLANK
SETO T1, ;FLAG END OF STRING FOUND
JRST MVAEND
MVALP: ILDB T1,SRCBP ;GET A BYTE
JUMPE T1,MVAEND ;NULL, DONE
MVAL1: MOVEI T0,1 ;GET BIT
LSH T0,-40(T1) ;SHIFT OVER
TDNE T0,T2 ;CHECK CHAR IN BREAK MASK
SOJA P4,MVAEND ;BREAK CHAR, DONE
CAIN T1," " ;SPACE?
JRST MVANXT ;YES, IGNORE IT
CAIL T1,"a" ;CONVERT LOWER CASE TO UPPER CASE
CAILE T1,"z"
JRST .+2 ;NOT LC
SUBI T1,40 ;LC, CONVERT
IDPB T1,DSTBP ;STORE CHAR IN DEST STRING
MVANXT: SOJG P4,MVALP ;COPY WHOLE STRING
SETO T1, ;FLAG STRING TERMINATED BY NO MORE CHARS
MVAEND: SETZ T0, ;TERMINATE DEST STRING WITH A NULL
IDPB T0,DSTBP
POPJ P, ;ALL DONE
>;END IF20
IF10,<
;ROUTINE TO MOVE ARG TO LOCAL AREA, STANDARDIZING IT
;CONVERTS TO SIXBIT, REMOVES SPACES & CONTROL CHARS, TRUNCATES TO 6 CHARS
;COPIES ARG UNTIL IT ENDS OR UNTIL A BREAK CHAR
;
;ARGS: T1 = ADDRESS OF WORD TO STORE ARG IN
; T2 = MASK OF BREAK CHARS
; SRCBP = SOURCE BYTE PTR.
; P4 = CHAR COUNT
;RETURN: T1 = TERMINATING CHAR, OR -1 IF SOURCE STRING EXHAUSTED
; SRCBP, P4 UPDATED
MOVARG: SETZM (T1) ;CLEAR DEST WORD
MOVEI T3,(T1) ;MAKE BYTE POINTER TO DEST STRING
HRLI T3,(POINT 6,)
MVALP: ILDB T1,SRCBP ;GET SOURCE BYTE
JUMPE T1,%POPJ ;NULL, DONE
MOVEI T0,1 ;GET A BIT
LSH T0,-40(T1) ;SHIFT OVER
TDNN T0,T2 ;CHECK CHAR IN BREAK MASK
CAIN T1,"," ;COMMA TOO
POPJ P, ;BREAK CHAR, DONE
CAIE T1,"[" ;OTHER BREAKS?
CAIN T1,"]"
POPJ P, ;YES, RETURN
CAIG T1," " ;SPACE OR CONTROL CHAR?
JRST MVANXT ;YES, INGORE IT
CAIL T1,"a" ;LOWER CASE?
CAILE T1,"z"
SUBI T1,40 ;NO, CONVERT TO SIXBIT
TLNE T3,770000 ;ALREADY HAVE 6 CHARS IN DEST STRING?
IDPB T1,T3 ;NO, PUT THIS ONE IN
MVANXT: SOJG P4,MVALP ;COPY WHOLE STRING
SETO T1, ;RAN OUT, SET FLAG
POPJ P, ;ALL DONE
>;END IF10
SEGMENT DATA
%SRCBP:: ;Non-indexed source BP
SRCBP: BLOCK 1 ;Source byte ptr
DSTBP: BLOCK 1 ;Destination byte ptr
%NCHRR:: BLOCK 1 ;# chars read from SRCBP so far
; (Used by FORERR)
%ARGNM:: BLOCK 1 ;Addr of ASCII name of arg.
FILSAG: BLOCK 1 ;ARG POINTER OF FILE='string'
DIASAG: BLOCK 1 ;Arg pointer of DIALOG='string'
STRARG: BLOCK 1 ;COMMON STRING ARG POINTER
DIARRY: BLOCK 1 ;0=CANNOT BE AN ARRAY
SEGMENT CODE
;T1=DEC #
;T2=BP
DECASC: MOVE T3,T2
PUSHJ P,DECAS1
SETZ T1,
IDPB T1,T3
POPJ P,
DECAS1: IDIVI T1,12
JUMPE T1,DECAS2
PUSH P,T2
PUSHJ P,DECAS1
POP P,T2
DECAS2: ADDI T2,60
IDPB T2,T3
POPJ P,
DECSIX: MOVE T3,[POINT 6,T4]
SETZ T4,
PUSHJ P,DECSX1
MOVE T1,T4
POPJ P,
DECSX1: IDIVI T1,12
JUMPE T1,DECSX2
PUSH P,T2
PUSHJ P,DECSX1
POP P,T2
DECSX2: ADDI T2,'0'
IDPB T2,T3
POPJ P,
;ASCDEC -- ASCII to DECIMAL conversion routine.
;Input:
; T1/ 18-bit address.
;Call:
; PUSHJ P,ASCDEC
; <here if parse error, no message typed>
; <here if ok>
;Output:
; T1/ number (could be negative).
ASCDEC: MOVSI T4,(POINT 7,)
HRR T4,T1
SETZB T1,T3 ;Start with 0 result, not negated
ILDB T2,T4 ;Get digit or "-"
CAIE T2,"-" ;Minus?
JRST ADECL1 ;No
SETO T3, ;Yes, remember to negate answer
ADECLP: ILDB T2,T4 ;Get next digit
ADECL1: JUMPE T2,ADECL2
CAIL T2,"0"
CAILE T2,"9"
POPJ P, ;?not numeric
IMULI T1,^D10
ADDI T1,-"0"(T2)
JRST ADECLP
ADECL2: SKIPE T3 ;Negative?
MOVN T1,T1 ;Yes, negate
JRST %POPJ1 ;Return ok
;ROUTINE TO CONVERT OLD-STYLE CALL TO NEW-STYLE CALL
;OLD STYLE HAS POSITIONAL ARGS FOR UNIT, END, ERR.
;RECOGNIZED BY FIRST ARG HAVING KEYWORD FIELD 0. PUT IN
;RIGHT KEYWORDS FOR THE POSITIONAL ARGS.
OPNCNV:
CLSCNV: LDB T1,[POINTR ((L),ARGKWD)] ;GET KWD FIELD OF FIRST ARG
JUMPN T1,%POPJ ;NONZERO, NEW-STYLE CALL
MOVEI T1,OK.UNIT ;GET KWD VALUE FOR /UNIT
DPB T1,[POINTR ((L),ARGKWD)] ;STORE IN LOCAL ARG LIST
MOVEI T1,OK.ERR ;GET KWD VALUE FOR /ERR
CAMLE L,[-3,,-1] ;AT LEAST 3 ARGS PRESENT?
POPJ P, ;No, done
DPB T1,[POINTR (2(L),ARGKWD)] ;Store /ERR keyword
POPJ P, ;Return
RLSCNV: HLRZ T1,L ;GET ARG COUNT
CAIE T1,-1 ;MUST BE EXACTLY 1 ARG
; IOERR (WNA,33,504,?,Wrong number of arguments,,%ABORT)
$ECALL WNA,%ABORT
MOVEI T1,OK.UNIT ;GET KWD VALUE FOR /UNIT
DPB T1,[POINTR ((L),ARGKWD)] ;STORE IN LOCAL ARG LIST
POPJ P, ;DONE
SUBTTL FILL IN DEFAULTS & CHECK FOR CONFLICTS
COMMENT &
Trivial defaults are handled by clearing the DDB to zero initially,
then defining the default value for a field to be zero. Unless set to
something else, the zero will be used as the value of the keyword.
Defaults which cannot be handled that way and defaults which interact
with each other are handled here.
&
;OPDFLT - POST-ARG DEFAULT PROCESSING
;THE NEED FOR A DEFAULT IS RECOGNIZED BY A FIELD STILL BEING ZERO.
; HENCE ALL VALUES FOR A DEFAULTED FIELD MUST BE NONZERO. THE ORDER
; OF THESE CALLS IS IMPORTANT.
OPDFLT: PUSHJ P,DFBUF ;BUFFER COUNT
PUSHJ P,DFSTAT ;STATUS [CAN IMPLY /DISP]
PUSHJ P,DFACC ;ACCESS [INTERACTS WITH /STAT, /READONLY]
PUSHJ P,DFDISP ;DISPOSE [IF NOT SET ABOVE]
PUSHJ P,DFFORM ;FORM [IF SET, SETS DEFAULT MODE]
PUSHJ P,DFMODE ;MODE [CAN IMPLY /FORM, /TAPEMODE]
PUSHJ P,DFPAD ;IF NO PADCHAR, SETUP DEFAULT
PJRST DFCHKU ;NOW CHECK UNFORMATTED FILES FOR
;STUPID ATTRIBUTES
DFCHKU: LOAD T1,FORM(D) ;GET FORM=
CAIE T1,FM.UNF ;UNFORMATTED?
POPJ P, ;NO
LOAD T1,PADCH(U) ;ANY PADCHAR?
JUMPE T1,UCHKCC ;NO. GO CHECK CARRIAGECONTROL
MOVE T1,OPARGN+OK.PAD ;GET ADDR OF STRING
MOVEM T1,%OPNK1 ;SAVE FOR MSG
$ECALL IAU ;ILLEGAL ATTRIBUTE FOR UNFORMATTED FILE
UCHKCC: LOAD T1,CC(U) ;GET CARRIAGECONTROL
JUMPE T1,UCHKBL ;NONE. GO CHECK BLANK=
MOVE T1,OPARGN+OK.CC ;GET ADDR OF STRING
MOVEM T1,%OPNK1 ;SAVE FOR MSG
$ECALL IAU ;ILLEGAL ATTRIBUTE
UCHKBL: LOAD T1,BLNK(U) ;GET BLANK=
JUMPE T1,%POPJ ;NONE
MOVE T1,OPARGN+OK.BLNK ;GET ADDR OF STRING
MOVEM T1,%OPNK1 ;SAVE FOR ERROR MSG
$ECALL IAU ;ILLEGAL ATTRIBUTE
POPJ P,
;*** SPOOLED LPT HAS UNIT = -1 AND DEV=.DVLPT
IF20,<
DFDEV: SKIPE DEV(D) ;DEVICE SET?
POPJ P, ;Yes, return
HXRE T1,UNUM(U) ;GET UNIT NUMBER
JUMPL T1,DFDEV0 ;NEGATIVE, NO CHECK FOR LOGICAL NAME
MOVE T2,[POINT 7,DEV(D)] ;POINT TO DESTINATION FOR DEVICE
PUSHJ P,DECASC ;CONVERT UNIT TO DECIMAL ASCIZ STRING
HRROI T1,DEV(D) ;POINT TO DEVICE NAME
STDEV% ;GET DEVICE DESIGNATOR
ERJMP .+2 ;NO SUCH DEVICE
POPJ P, ;Got it, return
HXRE T1,UNUM(U) ;GET UNIT NUMBER AGAIN
DFDEV0: CAIL T1,0 ;NEGATIVE UNIT?
CAIGE T1,MAXDEV ;OR POSITIVE AND IN TABLE?
SKIPA T1,DEVTAB(T1) ;YES, GET DEVICE NAME FROM TABLE
MOVE T1,[ASCII "DSK"] ;NO, USE DEFAULT
MOVEM T1,DEV(D) ;STORE DEVICE NAME
POPJ P, ;Return
;Routine to check out device and get information about it
DFDEV1: HRROI T1,DEV(D) ;POINT TO DEVICE NAME
STDEV% ;GET DEVICE DESIGNATOR
ERJMP .+2
JRST DFDVCH ;OK
XMOVEI T1,DEV(D) ;Get address of device name for error msg
; IOERR (NSD,30,245,?,No such device $A,<T1>,REQDIA)
$ECALL NSD,REQDIA
DFDVCH: MOVE T1,T2 ;PUT DEVICE DESIGNATOR IN RIGHT AC
MOVEM T1,DVICE(D) ;Save device designator
CAMN T1,TT.DES## ;OPENING CONTROLLING TTY?
TXO F,F%CTTY ;YES, REMEMBER THAT
DVCHR% ;GET DEVCHR WORD
LDB T1,[POINT 9,T2,17] ;GET DEVICE TYPE
STORE T1,DVTYP(D) ;STORE THAT
CAIE T1,.DVTTY ;IS DEVICE A TTY?
CAIN T1,.DVPTY ; OR PTY?
TXZ T2,DV%M10 ;NO IMAGE MODE
CAIN T1,.DVMTA ;IS DEVICE A MAGTAPE?
TXO T2,DV%M10 ;ALLOW IMAGE MODE
STORE T2,LGLM(D) ;STORE LEGAL DATA MODES
ROT T2,2 ;GET INPUT/OUTPUT BITS
STORE T2,IO(D) ;STORE THAT
;Figure out appropriate INDX(D) -- device type index
LOAD T1,DVTYP(D) ;Get device type
MOVEI T2,DI.OTHR ;Guess type "other"
CAIN T1,.DVDSK ;Disk?
MOVEI T2,DI.DSK ;Yes
CAIN T1,.DVMTA ;Tape?
MOVEI T2,DI.MTA ;Yes
CAIN T1,.DVTTY ;TTY?
MOVEI T2,DI.TTY
STORE T2,INDX(D) ; . .
JRST %POPJ1 ;No error--Skip return
PPNDIR: TXNN F,F%PPN ;DID USER GIVE DIRECTORY=PPN?
POPJ P, ;NO, GREAT
HRROI T1,ATMBUF ;TRANSLATE PPN TO DIRECTORY STRING
MOVE T2,DIR(D) ;GET PPN
HRROI T3,DEV(D) ;POINT TO DEVICE NAME
PPNST% ;TRANSLATE IT
ERJMP PPNERR ;ERROR, GO BITCH
MOVE P3,[POINT 7,ATMBUF] ;INITIALIZE STRING POINTER
MOVEM P3,SRCBP
MOVEI P4,LATOM*5 ;AND COUNT
XMOVEI T1,ATMBUF ;MOVE STRING TO SELF
MOVSI T2,(1_'<') ;UNTIL START OF DIRECTORY NAME
PUSHJ P,MOVARG ;SKIP TO LEFT ANGLE BRACKET
XMOVEI T1,DIR(D) ;NOW POINT TO REAL DESTINATION
MOVSI T2,(1_'>') ;TERMINATE ON END OF DIRECTORY NAME
PUSHJ P,MOVARG ;MOVE DIRECTORY TO DDB, RETURN
TXZ F,F%PPN ;DIRECTORY IS NO LONGER STORED AS PPN
POPJ P,
PPNERR:; IOERR (PPN,30,405,?,$J,,REQDIA)
$ECALL PPN,REQDIA
;STILL IF20
DFFILE: SKIPE FILE(D) ;FILENAME SET?
JRST DFEXT ;YES, GO CHECK EXT
MOVE T1,[ASCII "FOR0"] ;GET PART OF DEFAULT FILENAME
MOVEM T1,FILE(D) ;STORE IN DDB
HXRE T1,UNUM(U) ;GET UNIT NUMBER
JUMPL T1,DFFILX ;NEGATIVE UNITS ARE SPECIAL
MOVE T2,[POINT 7,FILE(D),27] ;POINT TO AFTER "FOR0"
CAIL T1,^D10 ;UNLESS UNIT NUMBER IS OVER 10
MOVE T2,[POINT 7,FILE(D),20] ;THEN POINT AFTER "FOR"
PUSHJ P,DECASC ;CONVERT UNIT NUMBER TO ASCIZ
JRST DFEXT ;GO DO EXTENSION
DFFILX: MOVE T1,DEVTAB(T1) ;GET DEV NAME FOR NEGATIVE UNIT
SETZ T2, ;CLEAR JUNK
LSHC T1,-^D22 ;MOVE OVER 3 CHARS
LSH T1,1 ;PUT IN EXTRA BIT BETWEEN WORDS
OR T1,["FOR"B20] ;PUT FIRST PART OF FILENAME IN
DMOVEM T1,FILE(D) ;SAVE IN DDB
DFEXT: TXNN F,F%EXT ;EXT SPECIFIED BY FILE=?
SKIPE EXT(D) ;NO, EXTENSION ALREADY SET?
POPJ P, ;YES, DONE
MOVE T1,[ASCIZ "DAT"] ;NO, SET DEFAULT
MOVEM T1,EXT(D)
POPJ P,
>;END IF20
;***TY.SPL & TY.VAR
IF10,<
DFDEV: SKIPE T1,DEV(D) ;DEVICE SET?
POPJ P, ;Yes, return
HXRE T1,UNUM(U) ;GET UNIT NUMBER
JUMPL T1,DFDEV0 ;NEGATIVE, NO LOGICAL NAME CHECK
PUSHJ P,DECSIX ;CONVERT UNIT NUMBER TO SIXBIT
MOVEM T1,DEV(D) ;SAVE IN DDB
DEVCHR T1, ;SEE IF DEVICE EXISTS
;BL; Change at DFDEV+7 (if10) Q10-05829
; JUMPN T1,DFDVCH ;YES, USE UNIT NUMBER AS DEVICE NAME
JUMPN T1,%POPJ ;Yes, use unit number as device name
HXRE T1,UNUM(U) ;GET UNIT NUMBER BACK
DFDEV0: CAIL T1,0 ;NEGATIVE UNIT?
CAIGE T1,MAXDEV ;OR POSITIVE AND IN TABLE?
SKIPA T1,DEVTAB(T1) ;YES, GET TABLE ENTRY
MOVSI T1,'DSK' ;NOT IN TABLE, USE DEFAULT
MOVEM T1,DEV(D) ;SAVE IN DDB
POPJ P, ;Return, default device set.
PPNDIR==%POPJ ;NO DIRECTORY PROCESSING NECESSARY
;Routine to check out device and get information about it
DFDEV1: MOVE T1,DEV(D) ;Get sixbit device name
IONDX. T1, ;GET UDX
SETO T1,
CAMN T1,TT.DES## ;OPENING CONTROLLING TTY?
TXO F,F%CTTY ;YES, REMEMBER THAT
MOVE T1,DEV(D) ;Get device name
DEVCHR T1, ;GET DEVCHR WORD
JUMPN T1,DFDVCH ;GOT IT, GO SAVE IT
MOVE T1,DEV(D) ;GET IT AGAIN FOR ERROR
; IOERR (NSD,30,245,?,No such device $S,<T1>,REQDIA)
$ECALL NSD,REQDIA
DFDVCH: TXNN T1,DV.TTY ;Is device a TTY?
JRST DFDVC1 ;No, FOROTS allows every mode that
; the monitor allows.
TXNN T1,DV.MTA ;If this is also set, device is NUL: - skip.
TXZ T1,DV.M17!DV.M14!DV.M10 ;TTY: -- Don't allow DUMP,BINARY,IMAGE.
DFDVC1: STORE T1,LGLM(D) ;STORE LEGAL DATA MODES
SETZ T0, ;Assume this is not a directory device
TXNE T1,DV.DIR ;Is it?
SETO T0, ;Yes, set flag
STORE T0,DRDVF(D) ;. .
SETZ T0, ;T0 will get input/output bits
TXNE T1,DV.IN ;Can this device do input?
TRO T0,1 ;Yes, set 2nd bit in "IO"
TXNE T1,DV.OUT ;Can this device do output?
TRO T0,2 ;Yes, set 1st bit in "IO"
STORE T0,IO(D) ;STORE LAST TWO BITS IN DDB
MOVE T1,DEV(D) ;GET DEVICE NAME
DEVTYP T1, ;GET DEVTYP BITS
$SNH ;?Should not fail
ANDI T1,TY.DEV ;GET RID OF UNWANTED BITS
STORE T1,DVTYP(D) ;STORE DEVTYP CODE
;Find appropriate INDX(D)
MOVEI T2,DI.OTHR ;Guess type OTHER
CAIN T1,.TYDSK ;DISK?
MOVEI T2,DI.DSK ;Yes
CAIN T1,.TYMTA ;TAPE?
MOVEI T2,DI.MTA ;Yes
CAIN T1,.TYTTY ;TTY?
MOVEI T2,DI.TTY ;Yes
STORE T2,INDX(D) ;Store dev index for dev-dependent code
;Get physical device name (which uniquely identifies this device)
; and store in DVICE(D)
MOVE T1,DEV(D) ;Get device name
DEVNAM T1, ;Get phys. device name
$SNH ;?Can't happen
TXNE F,F%CTTY ;Controlling TTY:?
MOVSI T1,'TTY' ;Yes, just store "TTY"
MOVEM T1,DVICE(D) ;Store unique device identifier.
JRST %POPJ1 ;No error--skip return
;STILL IF10
DFFILE: SKIPE FILE(D) ;FILENAME SET?
JRST DFEXT ;YES, GO CHECK EXT
HXRE T1,UNUM(U) ;GET UNIT NUMBER
JUMPL T1,DFFILX ;NEGATIVE, SPECIAL CODE
PUSHJ P,DECSIX ;CONVERT TO SIXBIT
TLNE T1,007777 ;1-DIGIT NUMBER?
JRST DFFILY ;NO, OK
LSH T1,-6 ;YES, PUT IN LEADING ZERO
TLO T1,'0 '
DFFILY: HRRI T1,'FOR' ;PUT IN REST OF FILENAME
MOVSM T1,FILE(D) ;SAVE IN DDB
JRST DFEXT ;GO DO EXT
DFFILX: HLRZ T1,DEVTAB(T1) ;RH OF FILENAME IS DEVICE NAME
HRLI T1,'FOR' ;PUT IN OTHER HALF OF FILENAME
MOVEM T1,FILE(D) ;SAVE IN DDB
DFEXT: TXNN F,F%EXT ;EXT SPECIFIED BY FILE=?
SKIPE EXT(D) ;NO, EXTENSION ALREADY SET?
POPJ P, ;YES, DONE
MOVSI T1,'DAT' ;NO, SET DEFAULT
MOVEM T1,EXT(D)
POPJ P,
>;END IF10
DFACC: LOAD T1,ACC(D) ;DEFAULT IS /ACCESS:SEQINOUT
JUMPN T1,DFACCX ;SKIP IF ALREADY SET
MOVEI T1,AC.SIO ;GET DEFAULT, SEQINOUT
STORE T1,ACC(D) ;STORE IN DDB
DFACCX: LOAD T2,RO(D) ;GET /READONLY
JUMPE T2,%POPJ ;Not set, leave ACCESS alone
;/READONLY set. Change ACCESS of 'RANDOM' to 'RANDIN',
; change ACCESS of 'SEQINOUT' to 'SEQIN'.
DFACC1: CAIE T1,AC.SIO ;SEQINOUT?
CAIN T1,AC.RIO ;RANDOM?
CAIA ;Yes, change them
POPJ P, ;Don't change /ACCESS
CAIN T1,AC.SIO
SKIPA T1,[AC.SIN] ;SEQINOUT to SEQIN
MOVEI T1,AC.RIN ;RANDOM to RANDIN
STORE T1,ACC(D) ;Store in DDB
POPJ P,
DFBUF:
IF20,< LOAD T1,BUFCT(D) ;GET BUFFER COUNT
JUMPN T1,%POPJ ;IF ALREADY SET, DON'T SET DEFAULT
MOVEI T1,4 ;DEFAULT IS 4
STORE T1,BUFCT(D)
> ;IF20
POPJ P,
DFDISP: LOAD T1,DISP(D) ;DEFAULT IS /DISP:SAVE
JUMPN T1,%POPJ
LOAD T2,STAT(D) ;Unless STATUS='SCRATCH'
CAIN T2,ST.SCR
SKIPA T1,[DS.EXP] ; Then it's /DISPOSE:EXPUNGE
MOVEI T1,DS.SAVE
STORE T1,DISP(D)
POPJ P,
;DFFORM - IF THE FORM IS SET AND THE MODE IS NOT, SET THE MODE
;TO BINARY
SETMOD:
DFFORM: LOAD T1,FORM(D) ;GET FORM
JUMPE T1,%POPJ ;NOT DEFAULTED UNTIL LATER
LOAD T2,MODE(D) ;FORM IS SET. GET MODE
JUMPN T2,%POPJ ;ALREADY SET BY OPEN
MOVEI T3,MD.ASC ;ASSUME ASCII
CAIE T1,FM.FORM ;FORM=FORMATTED?
MOVEI T3,MD.BIN ;NO. USE MODE=BINARY
STORE T3,MODE(D) ;STORE IT
POPJ P,
;SET MODE AND FORM - DONE JUST BEFORE THE FILE IS OPENED, TO AVOID
;FORMATTED/UNFORMATTED CONFLICTS FOR OPERATIONS WHICH DON'T OPEN
;THE FILE (REWIND, UNLOAD, ETC.) FOLLOWED BY UNFORMATTED I/O.
SETMAF: LOAD T1,MODE(D) ;MODE SET YET?
JUMPN T1,SETFRM ;YES. GO SET FORM
MOVEI T1,MD.ASC ;NO. SET MODE TO ASCII
STORE T1,MODE(D)
MOVEI T1,FM.FORM ;AND SET FORM=FORMATTED
STORE T1,FORM(D)
POPJ P, ;WE'RE DONE
;IF MODE SET, CHECK FOR EBCDIC (IMPLIES TAPEMODE=INDUSTRY)
;AND SETUP DEFAULT FORM.
DFMODE: LOAD T1,MODE(D) ;GET FILE MODE
JUMPE T1,%POPJ ;NONE. DON'T DEFAULT IT NOW
CAIE T1,MD.EBC ;/MODE:EBCDIC?
JRST SETFRM ;NO. GO SETUP FORM
MOVEI T2,TM.IND ;YES, IMPLIES /TAPEMODE:INDUSTRY
STORE T2,TAPM(D)
JRST SETFRM ;GO SETUP FORM
SMBA: LOAD T1,MODE(D) ;GET MODE
JUMPN T1,SETFRM ;IF SET, GO SET FORM
LOAD T1,FORM(D) ;GET FORM
JUMPN T1,SETMOD ;IF SET, GO SET MODE
LOAD T1,ACC(D) ;GET ACCESS
MOVEI T2,MD.ASC ;ASSUME ASCII
CAIE T1,AC.RIO ;RANDOM?
CAIN T1,AC.RIN ;OR RANDIN?
MOVEI T2,MD.BIN ;YES. SET TO BINARY
STORE T2,MODE(D) ;STORE MODE
SETFRM: LOAD T1,FORM(D) ;FORM SET YET?
JUMPN T1,%POPJ ;Already set
MOVEI T1,FM.FORM ;ASSUME FORMATTED
LOAD T2,MODE(D) ;GET MODE
CAIE T2,MD.BIN ;BINARY?
CAIN T2,MD.IMG ;OR IMAGE?
MOVEI T1,FM.UNF ;YES. SET UNFORMATTED
CAIN T2,MD.DMP ;OR DUMP
MOVEI T1,FM.UNF ;YES. SET UNFORMATTED
STORE T1,FORM(D)
POPJ P,
DFPAD: LOAD T1,PADSP(U) ;WAS A PADCHAR SPECIFIED?
JUMPN T1,%POPJ ;YES. DON'T DEFAULT IT
LOAD T1,FORM(D) ;GET FORM=
CAIE T1,FM.FORM ;FORMATTED?
POPJ P, ;NO. DON'T DEFAULT IT
MOVEI T1,40 ;SPACE IS DEFAULT PADCHAR
STORE T1,PADCH(U)
POPJ P,
;Default STATUS
DFSTAT: LOAD T1,STAT(D) ;GET /STATUS
JUMPN T1,DFSTAX ;IF SET, NO DEFAULT
MOVEI T1,ST.UNK ;DEFAULT IS /STATUS:UNKNOWN
STORE T1,STAT(D) ;SET DEFAULT
DFSTAX: SUBI T1,ST.DISP ;CONVERT TO /DISP:SOMETHING
JUMPLE T1,%POPJ ;WASN'T A /STAT THAT'S REALLY /DISP, DONE
STORE T1,DISP(D) ;ELSE JUST STORE NEW DISP
POPJ P, ;RETURN
;FIXDEF DOES FINAL DEFAULT PROCESSING AFTER EVERYTHING IS IN PLACE
;INITIALIZES TTYW TO 72 OR RECORD SIZE, IF NOT YET SET UP
FIXDEF: MOVE T1,RSIZE(D) ;GET RECORD SIZE
JUMPE T1,TTWSET ;NONE
LOAD T2,MODE(D) ;GET FILE MODE
CAIE T2,MD.ASL ;LINE-SEQUENCED ASCII?
JRST NOTLSN ;NO
ADDI T1,6 ;YES. ADD 6 FOR LSN AND TAB
MOVEI T3,6 ;SAVE FOR RECORD OFFSET
MOVEM T3,ROFSET(D)
NOTLSN: MOVEM T1,FRSIZB(D) ;SAVE FORMATTED RECORDSIZE IN BYTES
MOVE T2,T1 ;COPY RSIZE
LOAD T0,MODE(D) ;GET DATA MODE
CAIE T0,MD.IMG ;IMAGE?
ADDI T2,2 ;NO. ADD 2 FOR LSCW'S
MOVEM T2,URSIZW(D) ;SAVE UNFORMATTED RECSIZ IN WORDS
IMUL T2,BPW(D) ;GET UNFORMATTED RECSIZ IN BYTES
MOVEM T2,URSIZB(D) ;SAVE IT
LOAD T2,TAPM(D) ;GET TAPEMODE
CAIN T2,TM.IND ;INDUSTRY?
JRST TTWSET ;YES. DON'T ROUND UP RECSIZ IN BYTES
;IT IS ASSUMED THAT (AT LEAST FOR THIS VERSION) FIXED-LENGTH RECORDS
;ARE WORD-ALIGNED ON DISK, WITH CRLF ATTACHED, BUT THAT ON INDUSTRY
;TAPES THAT NONE OF THIS IS TRUE, I.E., ONLY THE DATA IS WRITTEN.
;ALSO, CARRIAGECONTROL=FORTRAN WITH FIXED-LENGTH RECORDS DOES
;NOTHING AT ALL FOR NOW. IF AND WHEN THERE IS A CARRIAGE-CONTROL
;BIT IN THE FDB, WE WILL LIGHT IT.
ADDI T1,2 ;ADD 2 FOR CRLF
ADD T1,BPW(D) ;NOW ADD BPW-1 TO ROUND UP TO WORDS
SUBI T1,1
IDIV T1,BPW(D) ;GET # WORDS
MOVEM T1,FRSIZW(D) ;STORE RECORD SIZE IN WORDS
IMUL T1,BPW(D) ;GET IT IN BYTES
MOVEM T1,FRSIZB(D) ;SAVE RECORD SIZE IN BYTES
TTWSET: LOAD T1,TTYW(D) ;GET LINE WIDTH
JUMPN T1,%POPJ ;GOT ONE ALREADY. LEAVE
SKIPN T1,RSIZE(D) ;USE RECSIZ IF SPECIFIED
MOVEI T1,^D72 ;OR 72 IF NOT
STORE T1,TTYW(D) ;SAVE LINE WIDTH FOR LIST-DIRECTED OUTPUT
POPJ P,
;FIXU - Routine to fixup U after OPEN is done.
; Called with FIXDEF, for every "U" that applies.
;SETS /CARRIAGE:DEVICE TO APPROPRIATE DEVICE DEFAULT
; and other stuff
FIXU: LOAD T1,CC(U) ;GET CC
CAIE T1,CC.DEV ;DEVICE DEFAULT?
POPJ P, ;NO, DONE
LOAD T1,DVTYP(D) ;GET DEVICE TYPE
IF10,< CAIE T1,.TYTTY ;TERMINAL?
CAIN T1,.TYLPT > ;OR PRINTER?
IF20,< CAIE T1,.DVTTY ;TERMINAL?
CAIN T1,.DVLPT > ;OR PRINTER?
SKIPA T1,[CC.FORT] ;YES, CC=FORT
MOVEI T1,CC.LIST ;NO, CC=LIST
STORE T1,CC(U) ;STORE DEFAULT CC
POPJ P, ;Return
;LOOK UP SWITCH IN TABLE
;ARGS: T1 = NUMBER TO FIND IN RH OF TABLE ENTRY
; T2 = (18-bit) ADDRESS OF TBLUK-FORMAT TABLE
;RETURN: T1 = STRING ADDRESS (FROM RH OF TABLE ENTRY)
;USES T1 THRU T4
FNDSWT: HRRZ T3,(T2) ;GET LENGTH OF TABLE
HRLI T2,(IFIW (T3)) ;PUT T3 INDEX IN LH OF T2
FSWLP: HRRZ T4,@T2 ;GET A TABLE ENTRY
CAIE T4,(T1) ;DOES IT MATCH THE ONE WE WANT?
SOJG T3,FSWLP ;NO, KEEP LOOKING
HLRZ T1,@T2 ;GET STRING POINTER
JUMPG T3,%POPJ ;RETURN UNLESS SWITCH WAS NOT FOUND IN TABLE
$SNH ;Switch not found, internal error
SUBTTL CHECK JFN FOR TTY:
IF20,<
; This routine is called after a GTJFN is done, to see
; if the filespec was actually TTY:. If this is true, and
; the user has no logical name TTY:, IJFN and OJFN are changed to
; .PRIIN and .PRIOU, respectively. This way TOPS-20 allows you
; to DETACH and REATTACH somewhere else, and the TTY output will
; follow you around (just like on the -10).
;Input:
; T1/ JFN
;Call:
; PUSHJ P,CTTYJF
; <return here always>
;Returns:
; T1/ JFN (if TTY:, .PRIIN is returned)
;Uses T2, T3
CTTYJF: MOVE T2,T1 ;Copy JFN
SETZM TDHOLD ;Clear device field
HRROI T1,TDHOLD ;Temp HOLD area
MOVX T3,FLD(.JSAOF,JS%DEV) ;Output device name
JFNS% ;** Return ASCIZ device name **
MOVE T1,T2 ;JFN back in T1
;If device is exactly "TTY", set .PRIIN and .PRIOU,
; and just release the JFN
MOVE T3,TDHOLD ;What did we get?
CAME T3,[ASCIZ /TTY/] ;TTY:?
POPJ P, ;No, return
RLJFN% ;Release old JFN
$SNH ;?Should work
MOVEI T1,.PRIOU ;How about that.
STORE T1,OJFN(D) ;Store in DDB.
MOVEI T1,.PRIIN ;This gets returned in T1
STORE T1,IJFN(D) ; . .
POPJ P, ;Return
SEGMENT DATA
TDHOLD: BLOCK <^D79+1>/5 ;Up to 39 characters in device name
SEGMENT CODE
>;END IF20
SUBTTL DIALOG SCANNER
FILSTR: MOVE T1,FILSAG ;GET ARG POINTER
MOVEM T1,STRARG ;SAVE IT
XMOVEI P3,@T1 ;GET ITS ADDRESS
SETZM FILSAG ;CLEAR IT NOW
SETZM DIARRY ;CANNOT BE AN ARRAY
TXO F,F%INDST ;SET NOW DOING DIALOG=STRING
XMOVEI T1,[ASCIZ /FILE=/] ;SAVE NAME FOR ERRORS
JRST COMDIA
DLGSTR: MOVE T1,DIASAG ;GET DIALOG=STRING ARG POINTER
MOVEM T1,STRARG ;SAVE IT
XMOVEI P3,@T1 ;GET ITS ADDRESS
SETZM DIASAG ;CLEAR IT NOW
SETOM DIARRY ;CAN BE AN ARRAY
TXO F,F%INDST ;Set flag saying we're now doing DIALOG='string'
XMOVEI T1,[ASCIZ /DIALOG=/] ;SAVE NAME FOR ERRORS
JRST COMDIA
IF20,<
DIALOG: XMOVEI T1,[ASCIZ /DIALOG/]
COMDIA: MOVEM T1,%ARGNM ;SAVE NAME FOR ERRORS
PUSHJ P,SAVERR ;DIVERT ERR MSGS TO TTY
TXNE F,F%INDST ;DIALOG FROM STRING?
JRST DIASK1 ;YES, SKIP PREFIX
SKIPN EFSFLG ;SKIP IF PREFIX ALREADY TYPED
; IOERR (EFS,,,[,Enter correct file specs)
$ECALL EFS
SETOM EFSFLG ;SUPPRESS PROMPT NEXT TIME
DIASK1: MOVEI T1,REPARSE ;FILL IN CSB
MOVEM T1,CSB+.CMFLG
TXNE F,F%INDST ;DIALOG COMING FROM STRING?
SKIPA T1,[.NULIO,,.NULIO] ;YES, NO JFNS
MOVE T1,[.PRIIN,,.PRIOU] ;NO, NORMAL JFNS
MOVEM T1,CSB+.CMIOJ
HRROI T1,[ASCIZ /*/] ;PROMPT STRING
MOVEM T1,CSB+.CMRTY
HRROI T1,TXTBUF ;TEXT BUFFER
MOVEM T1,CSB+.CMBFP
MOVEM T1,CSB+.CMPTR
MOVEI T1,LTEXT*5 ;CHARS IN TEXT BUFFER
MOVEM T1,CSB+.CMCNT
HRROI T1,ATMBUF ;ATOM BUFFER
MOVEM T1,CSB+.CMABP
MOVEI T1,LATOM*5-1 ;CHARS IN ATOM BUFFER
MOVEM T1,CSB+.CMABC ; (-1 BECAUSE OF COMND JSYS BUG)
MOVEI T1,JFNBLK ;GTJFN BLOCK
MOVEM T1,CSB+.CMGJB
MOVX T1,<<.CMKEY>B8> ;FILL IN SWITCH-KEYWORD FLDDB BLOCK
MOVEM T1,SWTDDB+.CMFNP
MOVX T1,<<.CMSWI>B8> ;Fill in FLDDB block for switches
MOVEM T1,FLDSWT+.CMFNP
MOVEI T1,OPNSWT ;Assume OPEN
TXNE F,F%CLS ;CLOSE?
MOVEI T1,CLSSWT ; Yes, get alternate switches
MOVEM T1,FLDSWT+.CMDAT ;Store in block
;STILL IF20
PUSHJ P,%SAVE4
RESCN: MOVEI T1,CSB ;POINT TO CSB
MOVEI T2,[FLDDB.(.CMINI)] ;INITIALIZE IT
PUSHJ P,COMAND
TXNE F,F%INDST ;DIALOG FROM STRING?
PUSHJ P,DIABLT ;YES, GO FAKE A TEXTI
MOVEM P,SAVEP ;SAVE P FOR REPARSE
REPARSE:
MOVE P,SAVEP ;RESTORE P
PUSHJ P,SETJFN ;FILL IN GTJFN BLOCK
MOVE T1,[GJ%OLD!GJ%NEW!GJ%FOU!777777] ;Clear stuff that
ANDCAM T1,JFNBLK+.GJGEN ; gets us an actual generation number
TXNE F,F%CLS ;In CLOSE?
HLLOS JFNBLK+.GJGEN ;[3150] Yes, default generation number to -1.
MOVX T1,GJ%OFG ;Don't get link to actual file yet
IORM T1,JFNBLK+.GJGEN ;(Incase he changes /ACCESS after typing
; the filespec).
MOVX T1,G1%SLN ;[2041] Don't expand logical names either
IORM T1,JFNBLK+.GJF2 ;[2041] . .
MOVEI T1,CSB ;RESTORE T1
MOVEI T2,FLDFNS ;Parse file name or switches
PUSHJ P,COMAND ;** Go do parse **
HRRZ P1,T3 ;See what it was
CAIN P1,FLDFNS ;CRLF?
POPJ P, ;Yes, just return
CAIN P1,FLDSWT ;Switch?
JRST DIASWG ;Yes, go process
;Filename was parsed
DIAFNM: MOVX T0,D%RJN ;Clear flag, this is not a JFN
ANDCAM T0,FLAGS(D) ; that can be "OPENF'd".
TXO F,F%FSS ;Set "Filespec info given" flag
STORE T2,IJFN(D) ;STORE JFN IN DDB
STORE T2,OJFN(D) ; . .
PUSHJ P,DOJFNS ;STORE NEW DEVICE, FILENAME, ... IN DDB
HRRZ T1,T2 ;Copy JFN
PUSHJ P,CTTYJF ;Check to see if TTY: is used,
; if so, possibly change to .PRIOU, .PRIIN
DIASWT: MOVEI T1,CSB ;POINT TO CSB
MOVEI T2,[FLDDB.(.CMCFM,,,,,FLDSWT)]
PUSHJ P,COMAND ;PARSE A SWITCH OR A CRLF
TSC T3,T3 ;SEE WHAT WAS ACTUALLY PARSED
JUMPE T3,%POPJ ;CRLF, DONE WITH DIALOG
DIASWG: MOVEI T1,CSB ;Point to COMND block
HRRZ P1,(T2) ;GET KEYWORD NUMBER OF SWITCH
HRRZ T2,OPNDSP(P1) ;Point to switch value handler
TXNE F,F%CLS ;In CLOSE?
HRRZ T2,CLSDSP(P1) ;Yes, separate handler
JUMPN T2,DIASWD ;IF ANY
$SNH ;No handler, internal error
DIASWD: MOVE T3,(T2) ;GET ROUTINE ADDRESS OR TOP OF KEYWORD TABLE
TLNN T3,-1 ;SEE WHICH IT IS
JRST (T3) ;SUBROUTINE, GO TO IT
DIAKWD: MOVEM T2,SWTDDB+.CMDAT ;KEYWORD TABLE, STORE ADDRESS
MOVEI T2,SWTDDB ;POINT TO KEYWORD FLDDB
PUSHJ P,COMAND ;PARSE SWITCH KEYWORD
HRRZ T2,(T2) ;GET VALUE
XCT OPSTOR(P1) ;STORE IN DDB
JRST DIASWT ;LOOP
;Routine to ignore the next keyword
;P1 = Switch number
DIAIGN: PUSHJ P,CLIGN ;Type "%Ignoring <KEYWORD>"
MOVEI T2,SWACC ;Get a random switch table
MOVEM T2,SWTDDB+.CMDAT ;Store address
MOVEI T1,CSB
MOVEI T2,SWTDDB
COMND%
ERJMP CMDER1 ;?Funny error
JRST DIASWT ;Don't care whether it parsed or not
DIAINT: SKIPA T2,[[FLDDB.(.CMNUM,,^D10)]] ;GET A DECIMAL NUMBER
DIAOCT: MOVEI T2,[FLDDB.(.CMNUM,,^D8)] ;GET AN OCTAL NUMBER
PUSHJ P,COMAND
XCT OPSTOR(P1) ;STORE IN DDB
JRST DIASWT
DIACHR: MOVEI T2,[FLDDB.(.CMQST,,,single character)] ;GET A SINGLE CHAR
PUSHJ P,COMAND
LDB T2,[POINT 7,ATMBUF,6] ;GET CHAR FROM ATOM BUFFER
CAIN T2,"" ;QUOTING CHAR?
LDB T2,[POINT 7,ATMBUF,13] ;YES, GET CHAR IT QUOTED
XCT OPSTOR(P1) ;STORE IN DDB
JRST DIASWT
DIASET: MOVEI T2,1 ;SET BIT TO 1
XCT OPSTOR(P1)
JRST DIASWT
;CRLF or Filespec or switch
FLDFNS: FLDDB. (.CMCFM,CM%SDH,,,,FLDFNM)
FLDFNM: FLDDB. (.CMFIL,CM%SDH,,<file name>,,FLDSWT)
SEGMENT DATA
FLDSWT: BLOCK .CMDAT+1 ;Allocate space for FLDDB. block
SEGMENT CODE
COMAND: COMND% ;PARSE THE WHATEVER-IT-IS
ERJMP CMDERR ;ERROR IN COMND
TXNE T1,CM%NOP ;DID IT PARSE CORRECTLY?
JRST CMDERR ;NO
POPJ P, ;YES
CMDERR: ADJSP P,-1 ;DISCARD RETURN ADDRESS
CMDER1: MOVEI T1,.FHSLF ;SEE WHAT ERROR WE GOT
GETER% ;GET LAST ERROR
MOVEI T1,(T2) ;DISCARD JUNK IN LH
CAIN T1,IOX4 ;END OF COMMAND FILE?
JRST DIAEOF ;CANNOT RECOVER FROM THAT WITH MORE DIALOG
TXNN F,F%INDST ;Are we parsing DIALOG= argument?
JRST CMDER2 ;No
CAIE T1,NPXNOM ;"Does not match switch or keyword"?
CAIN T1,NPXAMB ; or "Ambiguous"?
JRST CMDER4 ;Yes
; IOERR (EDS,,,?,Error in dialog string - $J,,REQDIA)
$ECALL EDS,REQDIA
CMDER4: XMOVEI T1,ATMBUF ;Point to atom buffer
$ECALL EDA,REQDIA ;Type EDS + atom buffer
;Not DIALOG = 'string'
CMDER2: PUSH P,T1 ;Save error code
PUSHJ P,COL1 ;GET TERMINAL TO COL 1 IF IT ISN'T ALREADY
POP P,T1
;See if we should type out the atom buffer with this error
CAIE T1,NPXNOM ;Does not match switch or keyword
CAIN T1,NPXAMB ;Ambigous
JRST CMDERA ;Yes
CAIN T1,NPXNC
JRST CMDERA
; IOERR (JSE,30,,?,$J)
$ECALL JSE,RESCN ;Type JSYS error and go try again
;Type error and type out atom buffer
CMDERA: XMOVEI T1,ATMBUF ;Point to atom buffer
$ECALL JSA,RESCN ;Type JSYS error and go try again
;Routine to get termiinal to column 1
COL1: MOVE T1,CSB+.CMINC ;GET CHAR COUNT FROM CSB
MOVE T2,CSB+.CMPTR ;GET BYTE POINTER
C1LP: SOJL T1,C1CRLF ;IF NO CHARS LEFT, GO TYPE CRLF
ILDB T3,T2 ;GET A CHAR FROM TEXTI BUFFER
CAIN T3,12 ;A LF?
POPJ P, ;YES, TERMINAL IS ALREADY AT COL 1
JRST C1LP ;NO, SEARCH SOME MORE
C1CRLF: HRROI T1,%CRLF ;GET TO COLUMN 1 BY TYPING CRLF
PSOUT%
POPJ P, ;RETURN
DIAEOF: TXNE F,F%INDST ;DIALOG FROM STRING?
POPJ P, ;YES, DIALOG IS COMPLETE
JRST %ABORT ;END OF COMMAND FILE, FATAL ERROR
> ;IF20
IF10,<
DMSK==1_':' + 1_'.' + 1_'/' + 1_'=' ;BREAKS
DIALOG: XMOVEI T1,[ASCIZ/DIALOG/]
COMDIA: MOVEM T1,%ARGNM ;Store arg name incase errors
PUSHJ P,SAVERR ;DIVERT ERR MSGS TO TTY
PUSHJ P,%SAVE4 ;SAVE P ACS
TXNE F,F%INDST ;DIALOG FROM STRING?
JRST DIABLT ;YES, SKIP PROMPT
RESCN: SKIPN EFSFLG ;SKIP IF ALREADY TYPED ONCE
; IOERR (EFS,,,[,Enter correct file specs)
$ECALL EFS
SETOM EFSFLG ;SUPPRESS NEXT TIME
OUTCHR ["*"] ;PROMPT
MOVE P3,[POINT 7,TXTBUF] ;POINT TO TEXT DESTINATION
MOVEI P4,LTEXT*5-1
DIAINP: INCHWL T1 ;READ CHAR
CAIE T1," " ;SPACE?
CAIN T1,15 ;CR?
JRST DIAINP ;YES, SKIP IT
CAIN T1,11 ;TAB TOO
JRST DIAINP
CAIN T1,33 ;ALT?
JRST DIAALT ;YES
CAIN T1,12 ;LF?
JRST DIALF ;YES
IDPB T1,P3 ;ELSE STORE IN BUFFER
SOJG P4,DIAINP ;READ WHOLE STRING
; IOERR (DTL,,,?,Dialog string too long,,%RESCN)
$ECALL DTL,RESCN
DIAEND: SETZ T1, ;TERMINATE WITH NULL
IDPB T1,T2
JRST DIASC2 ;DONE
;STILL IF10
DIAALT: OUTSTR %CRLF ;TYPE CRLF AFTER ALT
DIALF: LDB T1,P3 ;CHECK LAST CHAR IN BUFFER
CAIE T1,"-" ;CONTINUATION?
JRST DIASC1 ;NO, GO PARSE DIALOG STRING
ADD P3,[47B5] ;DECREMENT P3 TO OVERWRITE -
TLCN P3,(1B0)
SUB P3,[430000,,1]
JRST DIAINP ;KEEP READING
DIASC1: SETZ T1, ;FLAG END OF ASCIZ STRING
IDPB T1,P3
;Now string has been stored in TXTBUF.
DIASC2: MOVE P3,[POINT 7,TXTBUF] ;POINT TO TEXT BUFFER
MOVEM P3,SRCBP
SETZM %NCHRR ;# chars read so far = 0
MOVEI P4,LTEXT*5-1 ;MAX STRING LENGTH IS SIZE OF BUFFER
;SRCBP = current bp to source string.
DIASCN: PUSHJ P,DPRS1 ;Parse filename or device ...
JRST RESCN ;Error, let him try again
CAIN T1,":" ;Colon terminator?
JRST DIADEV ;Yes, we just got a device
DIASN1: SKIPE T2,ATMBUF ;Filename?
MOVEM T2,FILE(D) ;Yes, store it
SKIPE T2,ATMBUF
TXO F,F%FSS ;Got filespec info
JUMPE T1,%POPJ ;Return if at end
CAIN T1,"." ;Extension coming?
JRST DIAEXT ;Yes
CAIN T1,"[" ;Path coming?
JRST DIAPTH ;Yes
CAIN T1,.CHLAB ;Protection coming?
JRST DIAPRO ;Yes
CAIN T1,"/" ;Switch coming?
JRST DIASW1 ;Yes
$ECALL IDD,RESCN ;?Illegal character
;Got a device (":" was delimiter)
DIADEV: SKIPN T2,ATMBUF ;DEV
$ECALL NDI,RESCN ;?Null device
MOVEM T2,DEV(D)
TXO F,F%DSS ;He specified a device
PUSHJ P,DPRS1 ;Parse filename..
JRST RESCN ;Error, let him try again
CAIE T1,":" ;Another device?
JRST DIASN1 ;No, ok
$ECALL IDD,RESCN ;?Illegal character
;Next thing is extension ("." seen)
DIAEXT: PUSHJ P,DPRS2 ;Parse extension
JRST RESCN ;Error, let him try again
TXO F,F%EXT!F%FSS ;EXT IS EXPLICITLY SPECIFIED, EVEN IF NULL
HLLZ T2,ATMBUF
MOVEM T2,EXT(D)
JUMPE T1,%POPJ ;Return if at end
CAIN T1,"[" ;Path coming?
JRST DIAPTH ;Yes
CAIN T1,.CHLAB ;Start of protection
JRST DIAPRO
CAIN T1,"/" ;Switch coming?
JRST DIASW1 ;Yes
$ECALL IDD,RESCN ;?Illegal character
;STILL IF10
;Parse a protection (Left angle bracket seen).
DIAPRO: PUSHJ P,DOCT ;Read protection
CAIE T1," " ;space?
CAIN T1,.CHRAB ;End of field?
PUSHJ P,DPRCHR ;Yes, get next char.
JUMPE T1,DIPROK ;Jump if ok delimiter
CAIE T1,"[" ;Start of PPN
CAIN T1,"/" ; or switch is ok
JRST DIPROK
$ECALL IDD,RESCN ;Else "illegal character"
DIPROK: DPB T2,[POINTR (PROT(D),RB.PRV)] ;STORE IN DDB
JUMPE T1,%POPJ ;Return if end of string
CAIN T1,"/" ;Switch coming?
JRST DIASW1 ;Yes
;Must be "["
; CAIN T1,"[" ;Start of PPN?
JRST DIAPTH ;Yes
;STILL IF10
DIAPTH: PUSHJ P,DPTH ;READ PATH
JRST RESCN ;Error
CAIE T1,"]" ;End square bracket?
CAIN T1," " ; or space?
PUSHJ P,DPRCHR ;Yes, get next char
JUMPE T1,%POPJ ;Return if at end
CAIN T1,.CHLAB ;Protection coming?
JRST DIAPRO ;Yes
CAIN T1,"/" ;Switch coming?
JRST DIASW1 ;Yes
$ECALL IDD,RESCN ;?Illegal character
;Routine to parse a path
;Reads from SRCBP updates %NCHRR
;Puts path in DDB.
;If errors, returns .+1 ($ECALL given)
; if ok, returns .+2
DPTH: PUSHJ P,DOCT ;READ PPN
CAIN T2,0 ;ALLOW [P,] AND [,PN] AND [,,SFD]
HLRZ T2,G.PPN
CAIN T1,0
; IOERR (IPP,,,?,Illegal PPN,,REQDIA)
$ECALL IPP,%POPJ
CAIE T1,","
$ECALL IDD,%POPJ
PUSH P,T2
PUSHJ P,DOCT
CAIN T2,0
HRRZ T2,G.PPN
HRLM T2,(P)
POP P,T2
MOVSM T2,PTHB+.PTPPN(D)
TXO F,F%FSS ;"Filespec info seen"
MOVEI P2,PTHB+.PTPPN+1(D) ;POINT TO SFD BLOCK
DIASFD: SETZM (P2) ;FLAG END OF SFD LIST
JUMPE T1,%POPJ1 ;CHECK DELIMITER. END OF STRING IS OK
CAIE T1,"]" ;RIGHT BRACKET TERMINATES PATH
CAIN T1," " ;SO DOES SPACE
JRST %POPJ1
CAIE T1,"," ;COMMA MEANS SFDS COMING
$ECALL IDD,%POPJ ;ELSE ILL DELIMITER IN DIALOG
CAIL P2,PTHB+.PTPPN+6(D) ;CHECK SFD COUNT
; IOERR (TMF,,,?,Too many SFDs,,REQDIA)
$ECALL TMF,%POPJ
PUSHJ P,DPRS3 ;READ SFD NAME
POPJ P, ;Error
SKIPN T2,ATMBUF ;GET SFD
; IOERR (NSI,,,?,Null SFD,,REQDIA)
$ECALL NSI,%POPJ
MOVEM T2,(P2) ;STORE IN PATH BLOCK
AOJA P2,DIASFD ;KEEP GOING
;STILL IF10
;Parsing routines for DIALOG mode
;Read DEV or FILESPEC or delimiter
DPRS1: MOVE T3,[POINT 6,ATMBUF] ;Store sixbit in atom buffer
SETZM ATMBUF
DPRS1A: PUSHJ P,DPRCHR ;Get next char, ignore spaces
JUMPE T1,%POPJ1 ;0 ok
CAIE T1,":" ;COLON
CAIN T1,"." ;Dot
JRST %POPJ1 ;Are ok
CAIE T1,"[" ;Start of PPN
CAIN T1,"/" ;Start of switch
JRST %POPJ1 ;Are ok
CAIN T1,.CHLAB ;And start of protection
JRST %POPJ1
PUSHJ P,DPRCSX ;Convert char to sixbit
POPJ P, ;Problem, return
TLNE T3,770000 ;Room?
IDPB T1,T3 ;Yes, store in BP
JRST DPRS1A ;Loop
;Same as DPRS1 except ":" and "." are not legal delimiters
DPRS2: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF
DPRS2A: PUSHJ P,DPRCHR ;Get next char, ignore spaces
JUMPE T1,%POPJ1 ;Return if done
CAIE T1,"[" ;Start of PPN
CAIN T1,"/" ;Start of switch
JRST %POPJ1 ;Are ok
CAIN T1,.CHLAB ;Start of protection
JRST %POPJ1
PUSHJ P,DPRCSX ;Convert char to sixbit
POPJ P, ;Problem, return
TLNE T3,770000 ;Room?
IDPB T1,T3 ;Yes, store in BP
JRST DPRS2A ;Loop
;Parse SFD names (sixbit)
DPRS3: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF
DPRS3A: PUSHJ P,DPRCHS ;Get next char (space not ignored)
JUMPE T1,%POPJ1 ;Return if done
CAIE T1,"]" ;End of PPN ok
CAIN T1,"," ;Comma ok
JRST %POPJ1
CAIN T1," " ;Space ok
JRST %POPJ1
PUSHJ P,DPRCSX ;Convert char to sixbit
POPJ P, ;Problem, return
TLNE T3,770000 ;Room?
IDPB T1,T3 ;Yes, store in BP
JRST DPRS3A ;Loop
;Parse a switch
DPRSWT: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF
DPRSW1: PUSHJ P,DPRCHR ;Get char
JUMPE T1,%POPJ1 ;End ok
CAIE T1,"=" ;Delimiters for switch value ok
CAIN T1,":"
JRST %POPJ1
CAIN T1,"/" ;Another switch ok
JRST %POPJ1
PUSHJ P,DPRCSX ;Convert char to sixbit
POPJ P, ;Error
TLNE T3,770000 ;If room,
IDPB T1,T3 ;Store in BP
JRST DPRSW1 ;Loop
;Parse a switch value
DPRSWV: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF
DPRSV1: PUSHJ P,DPRCHR ;Get char
JUMPE T1,%POPJ1 ;END ok
CAIN T1,"/" ;Another switch ok
JRST %POPJ1
PUSHJ P,DPRCSX ;Convert to sixbit
POPJ P, ;?Error
TLNE T3,770000 ;If room,
IDPB T1,T3 ;Store char
JRST DPRSV1 ;Loop
;Parse a switch value in OPEN keyword arg.
;Leading spaces are ignored.
PRSSWV: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF
PRSSV1: PUSHJ P,DPRCHR ;Get next char
JUMPE T1,%POPJ1 ;END ok
JRST PRSSV3 ;Got 1st char
PRSSV2: PUSHJ P,DPRCHS ;Get next char (don't ignore spaces)
JUMPE T1,%POPJ1 ;Null ends it
CAIN T1," " ; and space ends it
JRST %POPJ1
PRSSV3: PUSHJ P,DPRCSX ;Convert to sixbit
POPJ P, ;?error
TLNE T3,770000 ;If room,
IDPB T1,T3 ;Store char
JRST PRSSV2 ;Loop for all chars
;Translate char in T1 to sixbit
;Must be a letter or number
;Returns .+1 if problem (IDD error given), .+2 if ok
DPRCSX: CAIL T1,"A"+40 ;Check for lowercase letter
CAILE T1,"Z"+40
CAIA ;not
SUBI T1,40 ;Translate to upper case
CAIL T1,"A" ;Letter?
CAILE T1,"Z"
JRST DPRCS1 ;No
DPRCS2: SUBI T1,40 ;Translate to sixbit
JRST %POPJ1 ;Return ok
DPRCS1: CAIL T1,"0" ;Digit?
CAILE T1,"9"
$ECALL IDD,%POPJ ;No, return
JRST DPRCS2 ;Yes, Ok
;STILL IF10
DIASWT: PUSHJ P,DPRCHR ;Get next non-space char.
DIASW1: JUMPE T1,%POPJ ;NONE, DONE
CAIE T1,"/" ;BEGINNING OF SWITCH?
$ECALL IDD,RESCN ;NO, BAD
PUSHJ P,DPRSWT ;Parse a switch
JRST RESCN ;Error - bad char
DSWOK: MOVEI T1,OPNSWT ;LOOK UP KEYWORD
MOVEI T2,ATMBUF
MOVE T5,ATMBUF ;Get sixbit word to type incase error
PUSHJ P,TABLK
; IOERR (USW,,,?,Unknown switch /$S,T5,%RESCN)
$ECALL USW,RESCN
; IOERR (ASW,,,?,Ambiguous switch /$S,T5,%RESCN)
$ECALL ASW,RESCN
HRRZ P1,(T1) ;GET KEYWORD NUMBER
HRRZ T2,OPNDSP(P1) ;POINT TO SWITCH VALUE HANDLER
TXNE F,F%CLS ;CLOSE?
HRRZ T2,CLSDSP(P1) ;Yes, different action routines
JUMPN T2,.+2 ;IF ANY
$SNH ;None, internal error
MOVE T3,(T2) ;GET ROUTINE ADDRESS OR KEYWORD TABLE
TLNN T3,-1 ;SEE WHICH
JRST (T3) ;ROUTINE, GO TO IT
DIAKWD: SETZM ATMBUF ;Clear buffer
PUSH P,T2 ;SAVE KWD TABLE ADDRESS
LDB T1,%SRCBP ;See if last char was end of switch
JUMPE T1,DIAKWW ;Yes, no switch value (gets "?Ambigous")
PUSHJ P,DPRSWV ;Parse switch value
JRST [POP P,(P) ;Error, fix stack
JRST RESCN] ; and go try again
; SETZM ATMBUF+1 ;MAKE SURE STRING IS TERMINATED WITH NULL
DIAKWW: POP P,T1 ;GET KWD TABLE ADDRESS
MOVEI T2,ATMBUF
PUSHJ P,TABLK
JRST KWDUNK ;UNKNOWN
JRST KWDAMB ;AMBIGUOUS
HRRZ T2,(T1) ;GET VALUE
XCT OPSTOR(P1) ;STORE IN TABLE
LDB T1,SRCBP ;RELOAD DELIMITING CHAR
JRST DIASW1 ;READ ON
;STILL IF10
DIAOCT: PUSHJ P,DOCT ;READ NUMBER, THEN RETURN TO LOOP
XCT OPSTOR(P1)
JRST DIASW1
DIAINT: PUSHJ P,DINT
XCT OPSTOR(P1)
JRST DIASW1
DOCT: SKIPA T5,[^D8] ;RADIX 8
DINT: MOVEI T5,^D10 ;RADIX 10
SETZ T2, ;CLEAR RESULT
DINT1: ILDB T1,SRCBP ;GET CHAR
AOS %NCHRR
CAIL T1,"0" ;DIGIT?
CAIL T1,"0"(T5)
POPJ P, ;NO, RETURN
IMULI T2,(T5) ;ADD THIS DIGIT IN
ADDI T2,-"0"(T1)
JRST DINT1 ;LOOP
DIACHR: PUSHJ P,DPRCHS ;Get char
CAIE T1,"""" ;STARTING QUOTE?
; IOERR (NQS,,,?,PADCHAR must be single char in double quotes,,%RESCN)
EENQS: $ECALL NQS,RESCN
PUSHJ P,DPRCHS ;Get PAD char
CAIN T1,"" ;QUOTING CHAR?
PUSHJ P,DPRCHS ;YES, GET CHAR IT QUOTES
JUMPE T1,EENQS ;END OF STRING HERE IS AN ERROR
XCT OPSTOR(P1) ;STORE IN DDB
PUSHJ P,DPRCHS ;Get closing quote
CAIE T1,"""" ;CLOSING QUOTE?
$ECALL NQS,RESCN ;No, complain
JRST DIASWT
DIASET: MOVEI T2,1 ;SET BIT TO 1
XCT OPSTOR(P1)
JRST DIASWT ;RETURN
;IGNORE THE ARGUMENT
DIAIGN: PUSHJ P,CLIGN ;Say "%ignoring.."
PUSHJ P,DPRSWT ;Parse switch
JRST RESCN ;?error
CAIE T1,"=" ;If there is a switch value,
CAIN T1,":"
JRST DIAIG1 ;Ignore that too
JRST DIASW1
DIAIG1: PUSHJ P,DPRSWV ;Parse switch value
JRST RESCN ;?Error
JRST DIASW1 ;Go on
> ;IF10
;ROUTINE TO PUSH U.ERR SO DIALOG IS WITH TTY, NOT FILE
;DOES NOT HANDLE SKIP RETURNS
SAVERR: SKIPN U.ERR ;ERR UNIT SET?
POPJ P, ;NO, NOTHING TO DO
PUSH P,U.ERR ;SAVE IT
SETZM U.ERR ;CLEAR IT SO WE USE TTY
PUSHJ P,@-1(P) ;CALL CALLER
POP P,U.ERR ;RESTORE U.ERR
POP P,(P) ;Discard one return so don't return
; after "PUSHJ P,SAVERR".
POPJ P, ;DONE
SUBTTL DO OPEN
;Call:
; MOVX T1,GTJFN bits GJ%NEW or GJ%FOU or 0
; PUSHJ P,DOOPEN
; <return here if error, f%DRE set>
; <return here if ok>
IF20,<
DOOPEN: MOVEM T1,GJBTS ;Save GTJFN bits
PUSHJ P,SETMAF ;LAST MINUTE MODE= AND FORM=
PUSHJ P,CNFDEV ;CHECK FOR DEVICE CONFLICTS
POPJ P, ;ERROR, GO DO DIALOG
LOAD T1,IJFN(D) ;Get JFN
MOVE T2,FLAGS(D) ;Get DDB flags
TXNE T2,D%RJN ;Do we have a real JFN already?
JRST DOOPN1 ;Yes
CAIN T1,.PRIIN ;Controlling TTY:?
JRST DOOPN2 ;Yes, bypass a lot of this..
SKIPE T2,T1 ;Skip if no JFN at all, get in T2
PUSHJ P,DOJFNS ;Get info in file block
PUSHJ P,SETJFN ;Setup JFN info
MOVE T1,GJBTS ;Get JFN bits to set
TXO T1,GJ%XTN ;Extended GTJFN
HLLM T1,JFNBLK+.GJGEN ;Store away
MOVEI T1,JFNBLK ;Get a JFN
MOVEI T2,[0]
GTJFN%
ERJMP GJERR1 ;Failure return
;Here when got real JFN in T1
DOOPN1:
GTJOK: STORE T1,IJFN(D) ;Store
STORE T1,OJFN(D)
PUSHJ P,CTTYJF ;Get .PRIIN if TTY:
MOVX T0,D%RJN ;"Got a real JFN now"
CAIE T1,.PRIIN ;Skip if controlling TTY:
IORM T0,FLAGS(D) ;Set the flag
DOOPN2: PUSHJ P,GMODBY ;Get DMABS, BPW
;Do OPENF
PUSHJ P,%CHKNR ;Check data mode
POPJ P, ;Illegal, go have DIALOG
LOAD T1,INDX(D) ;GET DEVICE INDEX
PUSHJ P,@SABDT(T1) ;SET ACCESS BY DEVICE TYPE
OR T2,DMABS(D) ;SET DATA MODE, BYTE SIZE
LOAD T1,IJFN(D) ;GET JFN
;T1= JFN
;T2= proper OPENF flag bits
CAIE T1,.PRIIN ;Don't OPENF TTY:
OPENF% ;OPEN file
ERJMP OPFERR ;Can't
OKOPNF: MOVEI T2,AC.SOU ;Change ACCESS to SEQOUT
LOAD T1,INDX(D) ; If device was a TTY
CAIN T1,DI.TTY
STORE T2,ACC(D)
LOAD T1,ACC(D) ;GET ACCESS
MOVE T2,ACCTAB(T1) ;Get bits to set in DDB flags
IORM T2,FLAGS(D) ; Set 'em
;OPFSTT - called when OPENF% is successful to finish setup.
OPFSTT: LOAD T2,INDX(D) ;Get device index
PUSHJ P,@[
IFIW TTYSET
IFIW DSKSET
IFIW MTASET
IFIW XXXSET
IFIW E.SNH](T2) ;Do device-dependent stuff
PJRST REQDIA ;Failed, request DIALOG
PUSHJ P,FIXU ;Fixup this unit block
PUSHJ P,FIXDEF ;Defaults after everything is in place.
PUSHJ P,DOCONS ;Do consolidation of DDB's if necessary
TXNN F,F%CTTY ;Is this the controlling TTY:?
JRST %POPJ1 ;No. Skip return
MOVEM D,D.TTY ;Yes, store the TTY's DDB address
MOVEM U,U.TTY ;And unit block
AOS (P) ;SKIP RETURN
POPJ P,
SABDT: IFIW TTYSA ;TTY
IFIW DSKSA ;DSK
IFIW MTASA ;MTA
IFIW XXXSA ;OTHER
TTYSA: MOVX T2,OF%RD+OF%WR ;READ + WRITE ACCESS
POPJ P,
XXXSA:
DSKSA: LOAD T2,ACC(D) ;GET ACCESS TYPE
HRRZ T2,FILTAB(T2) ;GET ACCESS BITS
JUMPE T2,CHKIO ;IF NONE, GO SET FROM CURRENT DIRECTION
TXNN T2,OF%WR ;GOT SOME. IS WRITE SET?
POPJ P, ;NO. NOTHING ELSE TO DO
JRST SETWR ;YES. GO SET FLAG THAT WE HAVE WRITE ACCESS
CHKIO: MOVX T2,OF%RD ;ASSUME READ
MOVE T0,FLAGS(D) ;Get DDB flags
TXNN T0,D%IO ;ARE WE WRITING?
POPJ P, ;NO
MOVX T2,OF%WR ;SETUP FOR WRITE ACCESS
SETWR: MOVX T0,D%WRT ;FLAG WE HAVE WRITE ACCESS
IORM T0,FLAGS(D)
POPJ P,
MTASA: LOAD T2,ACC(D) ;GET ACCESS
CAIN T2,AC.APP ;APPEND?
JRST MTAPP ;YES. GET WRITE ACCESS INSTEAD
HRRZ T2,FILTAB(T2) ;GET ACCESS BITS
JUMPN T2,%POPJ ;LEAVE IF WE GOT ANY
MOVX T2,OF%RD ;NONE. TRY READ
MOVE T0,FLAGS(D) ;Get DDB flags
TXNE T0,D%IO ;UNLESS WE'RE WRITING
MTAPP: MOVX T2,OF%WR
POPJ P,
;Routine to get DMABS, BPW based on /MODE
GMODBY: LOAD T1,MODE(D) ;GET /MODE
LOAD T0,INDX(D) ;GET DEVICE INDEX
MOVE T2,BSTAB(T1) ;GET BYTE SIZE
CAIN T0,DI.MTA ;MAGTAPE?
MOVEI T2,^D36 ;YES. ALWAYS OPEN WITH 36 BITS
STORE T2,BSIZ(D) ;SAVE IT FOR OPENF%
CAIN T2,^D36 ;IS IT 36?
SETOM B36FLG(D) ;YES. SET 36-BIT MODE FLAG
MOVEI T1,5 ;5 BYTES/WORD FOR NOW FOR ALL FILES
MOVEM T1,BPW(D) ;SAVE IT
MOVEI T1,(POINT 7,0,34) ;GET A RIGHT-JUSTIFIED BP
STORE T1,BYTPT(D) ;SAVE IT FOR FORIO
MOVE T1,[ASCII / /] ;STORE A WORD OF SPACES
MOVEM T1,SPCWD(D) ;SAVE IT FOR RECORD FILL
POPJ P, ;Return
SEGMENT DATA
GJBTS: BLOCK 1 ;GTJFN bits for DOOPEN
SEGMENT CODE
;ERRORS - UNDO JSYSES THAT HAVE SUCCEEDED, THEN GO HAVE DIALOG
FDBERR: LOAD T1,IJFN(D) ;GET THE JFN
CLOSF% ;CLOSE THE FILE
JSHALT ;SHOULDN'T FAIL
JRST OPFER1 ;NO NEED TO RELEASE JFN
;WE REACH HERE IF THE OPENF FAILED. IF SO, WE HAVE TO CHECK IF
;THE ERROR WAS "FILE DOES NOT EXIST". IF SO, AND AN OPEN STATEMENT
;WAS DONE, WE SET THE ACCESS BITS TO OF%RD+OF%WR (CREATE IF NOT
;THERE) AND TRY AGAIN. THIS IS TO SATISFY THE -77 STANDARD,
;WHICH STATES THAT A FILE EXISTS AFTER A SUCCESSFUL OPEN STATEMENT.
OPFERR: CAIE T1,OPNX2 ;FILE DOES NOT EXIST ERROR?
JRST OPFER0 ;NO. RELEASE JFN AND GIVE MSG
MOVE T1,FLAGS(D) ;GET DDB FLAGS
TXNN T1,D%OPEN ;OPEN STATEMENT EXECUTED?
JRST OPFER0 ;NO. DIE
LOAD T1,IJFN(D) ;GET JFN AGAIN
TXO T2,OF%WR ;TURN ON WRITE ACCESS
OPENF% ;TRY OPENF AGAIN
ERJMP OPFER0 ;STILL FAILED
JRST OKOPNF ;SUCCESS!
OPFER0: LOAD T1,IJFN(D) ;GET THE JFN BACK
JUMPE T1,OPFER1 ;IF WE HAVE ONE
RLJFN% ;RELEASE THE UNOPENED JFN
JSHALT ;SHOULD NOT FAIL
OPFER1: SETZ T1, ;CLEAR JFN STORED IN DDB
STORE T1,IJFN(D)
STORE T1,OJFN(D)
MOVX T1,D%RJN ;TURN OFF "WE HAVE REAL JFN"
ANDCAM T1,FLAGS(D)
GJERR1: CAIE T1,GJFX18 ;NO SUCH FILENAME?
CAIN T1,GJFX19 ;OR FILE TYPE?
JRST TRYNOB ;TRY GTJFN AGAIN WITH NO BITS
CAIN T1,GJFX24 ;OR FILE NOT FOUND
JRST TRYNOB ;TRY NO BITS
GJERR: $ECALL OPE,REQDIA ;NO. TYPE MSG, TRY AGAIN
TRYNOB: MOVX T1,GJ%OLD ;TURN OFF "OLD"
ANDCAM T1,JFNBLK+.GJGEN ;IN THE FLAG WORD
MOVEI T1,JFNBLK ;AND TRY GTJFN AGAIN
GTJFN%
$EJCAL OPE,REQDIA ;STILL NO GOOD. TYPE MSG, TRY AGAIN
JRST GTJOK ;SUCCESS. PROBABLY WILL FAIL AT OPENF
;AND CREATE NEW FILE.
;ROUTINE TO SET UP TERMINAL
TTYSET: MOVX T1,D%SEOL ;Suppress initial CRLF for terminals
IORM T1,FLAGS(D) ; . .
SKIPE T1,RSIZE(D) ;RECORD SIZE SPECIFIED?
JRST STOTTW ;YES. GO STORE AS TTYW
LOAD T1,OJFN(D) ;GET JFN
MOVEI T2,.MORLW ;READ LINE WIDTH
MTOPR%
ERJMP TTY72 ;CAN'T. USE 72
CAIN T3,0 ;LINE WIDTH SET?
TTY72: MOVEI T3,^D72 ;NO, GUESS 72
STOTTW: STORE T3,TTYW(D) ;STORE LINE SIZE FOR NAMELIST AND LIST-DIRECTED
JRST %POPJ1 ;DONE
;ROUTINE TO SET UP DISK
;READ THE FDB, THEN CALCULATE EOFN, THE NUMBER OF
;FORTRAN CHARACTER BYTES IN THE FILE. THIS IS DONE BY MULTIPLYING THE
;NUMBER OF FILE BYTES (FROM THE FDB) IN THE FILE BY THE NUMBER OF
;FORTRAN BYTES PER WORD, THEN DIVIDING BY THE NUMBER OF ORIGINAL FILE
;BYTES PER WORD.
DSKSET: LOAD T1,ACC(D) ;GET ACCESS
CAIN T1,AC.APP ;APPEND?
JRST XXXSET ;YES. PRETEND IT'S A CDP
LOAD T1,IJFN(D) ;GET JFN
MOVSI T2,1+.FBSIZ ;READ UP THROUGH FILE SIZE
MOVEI T3,FDB ;POINT TO DEST BUFFER
GTFDB% ;READ FDB
ERJMP FDBERR ;CAN'T
LDB T1,[POINTR (FDB+.FBBYV,FB%BSZ)] ;GET FILE BYTE SIZE
CAIN T1,0 ;ZERO?
MOVEI T1,^D36 ;YES, SET 36-BIT BYTES
LOAD T2,BSIZ(D) ;GET MODE-IMPLIED BYTE SIZE
MOVEI T3,^D36 ;GET # BITS/WORD
IDIVM T3,T1 ;GET # BYTES/WORD IN FILE IMPLIED BY FDB
IDIVM T3,T2 ;GET # BYTES/WORD FOR THIS MODE
MOVE T3,FDB+.FBSIZ ;GET NUMBER OF OLD BYTES IN THE FILE
MULI T3,(T2) ;GET # OLD BYTES * MODE BYTES/WORD
ADDI T4,-1(T1) ;ROUND UP
DIVI T3,(T1) ;GET # STANDARD BYTES
MUL T3,BPW(D) ;MULTIPLY BY STANDARD BYTES/WORD
DIVI T3,(T2) ;GET # STANDARD BYTES
MOVEM T3,EOFN(D) ;STORE IN DDB
ADD T3,BPW(D) ;GET # WORDS IN FILE
SUBI T3,1
IDIV T3,BPW(D)
ADDI T3,777 ;ROUND UP TO # GET # PAGES
LSH T3,-9 ;GET # PAGES IN FILE
SUBI T3,1 ;GET TOP PAGE # (-1 FOR NULL FILE)
MOVEM T3,TPAGE(D) ;SAVE IT
LOAD T1,BUFCT(D) ;GET BUFFER (PAGE) COUNT
PUSHJ P,%GTPGS ;ALLOCATE THAT MANY PAGES
$ECALL MFU,%ABORT ;?Can't, memory full
MOVEM T1,WPTR(D) ;SAVE PAGE POINTER
MOVE T0,FLAGS(D) ;Get DDB flags
TXNN T0,D%RAN ;Is this a RANDOM file?
JRST DSET2 ;no
LOAD T1,BPW(D) ;GET BYTES/WORD
LSH T1,9 ;GET # BYTES IN A PAGE
MOVEM T1,WSIZ(D) ;STORE AS WINDOW SIZE
LOAD T1,BUFCT(D) ;get page count
PUSHJ P,%GTBLK ;get a block for the page table
MOVEM T1,WTAB(D) ;STORE PNTR
LOAD T2,BUFCT(D) ;GET BUFFERCOUNT YET AGAIN
DSET3: SETOM (T1) ;SET PAGE NUMBER TO ILLEGAL ONE
ADDI T1,1 ;FOR ENTIRE TABLE
SOJG T2,DSET3 ;LOOP
LOAD T1,BUFCT(D) ;GET BUFFERCOUNT AGAIN!
PUSHJ P,%GTBLK ;ALLOCATE PAGE FLAG TABLE
MOVEM T1,PFTAB(D) ;SAVE ADDR
JRST %POPJ1 ;ALL SET
DSET2: MOVE T1,WPTR(D) ;GET PAGE ADDRESS
LSH T1,9 ;SAVE LOCAL CORE ADDR
HRRZM T1,WADR(D)
LOAD T1,BUFCT(D) ;GET BUFFER COUNT
LSH T1,9 ;GET WORD COUNT IN WINDOW
IMUL T1,BPW(D) ;GET # BYTES IN WINDOW
MOVEM T1,WSIZ(D) ;STORE AS WINDOW SIZE
JRST %POPJ1
;ROUTINE TO SET UP MTA
MTASET: PUSHJ P,%SAVE1 ;SAVE P1
HRLOI T1,377777 ;MARK FILE NOT AT EOF YET
MOVEM T1,EOFN(D)
LOAD T1,IJFN(D) ;GET LABEL TYPE OF TAPE
MOVEI T2,.MORLI ;READ LABEL INFO
MOVEI T3,2 ;SET ARG BLOCK LENGTH
MOVEM T3,LABINF
XMOVEI T3,LABINF ;POINT TO ARG BLOCK
MTOPR% ;READ LABEL INFO
ERJMP [MOVEI T3,1 ;CAN'T, ASSUME UNLABELED
MOVEM T3,1+LABINF
JRST .+1]
MOVE T1,1+LABINF ;GET LABEL TYPE
STORE T1,LTYP(D) ;STORE FOR LATER
CAIE T1,.LTUNL ;LABELED TAPE?
JRST LABSKP ;YES, DO NOT TRY TO SET UP DENSITY AND FRIENDS
LOAD T1,IJFN(D) ;GET JFN OF TAPE
MOVEI T2,.MOSDN ;SET DENSITY
LOAD T3,DEN(D) ;GET /DENSITY
MOVEI P1,[ASCIZ /density/] ;GET TEXT FOR ERR MESSAGE
MTOPR% ;SET IT
ERCAL MOPERR ;SHOULDN'T FAIL, BUT DON'T DIE
MOVEI T2,.MOSPR ;SET PARITY
LOAD T3,PAR(D) ;GET /PARITY
MOVEI P1,[ASCIZ /parity/]
MTOPR% ;SET IT
ERCAL MOPERR
LOAD T2,TAPM(D) ;GET /TAPEMODE
SETZ T3, ;USERS DEFAULT TAPE MODE
CAIN T2,TM.IND ;INDUSTRY COMPATIBLE?
MOVEI T3,.SJDM8 ;YES, SET 8-BIT BYTES
CAIN T2,TM.DMP ;COREDUMP?
MOVEI T3,.SJDMC ;YES, SET CORE DUMP
CAIN T2,TM.ANS ;ANSI-ASCII?
MOVEI T3,.SJDMA ;YES, 7-BITS IN 8 BIT BYTES
JUMPE T3,NOTAPM ;NO EXPLICIT MODE
MOVEI T2,.MOSDM ;SET HARDWARE DATA MODE
MOVEI P1,[ASCIZ /data mode/]
MTOPR% ;SET IT
ERCAL MOPERR
;FOR PDP-10 CORE DUMP MODE, ROUND THE NUMBER OF BYTES TO A WORD
;BOUNDARY, SINCE THAT'S WHAT THE HARDWARE DOES. OTHERWISE,
;STORE IT DIRECTLY AND ROUND UP FOR THE BUFFER SIZE.
NOTAPM:
LABSKP: LOAD T1,BLKSZ(D) ;GET BLOCKSIZE SET BY USER
MOVEM T1,WSIZ(D) ;SAVE AS WINDOW SIZE FOR NOW
LOAD T1,IJFN(D) ;GET JFN
MOVEI T2,.MORDM ;GET DATA MODE
MTOPR% ;GET STATUS INFO
ERJMP MOPERR
CAIN T3,.SJDM8 ;INDUSTRY?
JRST TAPCM8 ;YES. GO SET 8-BIT BYTES, ETC.
CAIN T3,.SJDMA ;ANSI-ASCII?
JRST TAPCMA ;YES. DON'T DO ROUNDUP
;CORE-DUMP, SIXBIT, OR HIGH-DENSITY MODE. WE CANNOT DO ANYTHING
;WITH THIS DATA OTHER THAN RETURN IT IN 36-BIT QUANTITIES, WITH
;THE ASSUMPTION THAT THE USER KNOWS WHAT IS GOING ON. SINCE THE
;HARDWARE ROUNDS UP THE NUMBER OF BYTES TO A WORD BOUNDARY
;WHEN WRITING, WE DO THE SAME HERE. THIS HAS THE UNFORTUNATE
;APPEARANCE OF DOING SOMETHING BEHIND THE BACK OF THE USER,
;BUT IT'S NOT OUR FAULT. SEE FIGURE 1.
SKIPN T1,WSIZ(D) ;GET BLOCKSIZE SPECIFIED BY USER
JRST CDNBS ;NONE. GO GET IT FROM MONITOR
LOAD T2,FORM(D) ;GET FORM=
CAIE T2,FM.FORM ;FORMATTED?
IMUL T1,BPW(D) ;NO. GET # BYTES
ADD T1,BPW(D) ;ROUND IT UP TO A WORD BOUNDARY
SUBI T1,1
IDIV T1,BPW(D) ;GET # WORDS
MOVEI T3,(T1) ;RECORD # WORDS FOR MTOPR
IMUL T1,BPW(D) ;GET ROUNDED-UP # BYTES
MOVEM T1,WSIZ(D) ;SAVE WINDOW SIZE
PUSHJ P,MTASRS ;SET RECORD SIZE IN WORDS IN MONITOR
JRST GTMBUF ;GO GET MAGTAPE BUFFER
CDNBS: PUSHJ P,MTARRS ;GET BLOCKSIZE IN WORDS FROM MONITOR
IMUL T3,BPW(D) ;GET IT IN BYTES
MOVEM T3,WSIZ(D) ;SAVE AS WINDOW SIZE
JRST GTMBUF ;GO GET MAGTAPE BUFFER
;ANSI-ASCII TAPE MODE. THIS IS OF LIMITED UTILITY, SINCE NOT
;ALL MAGTAPE DRIVES SUPPORT IT, AND IT CANNOT SUPPORT 8-BIT
;ASCII. HOWEVER WE WILL DO OUR BEST...
TAPCMA: SKIPE T3,WSIZ(D) ;DID USER SPECIFY BLOCKSIZE?
JRST CMAGBS ;YES. GO PUT IT IN MONITOR
PUSHJ P,MTARRS ;NO. GET IT FROM MONITOR
MOVEM T3,WSIZ(D) ;STORE IT
CMAGBS: PUSHJ P,MTASRS ;SET BLOCKSIZE IN MONITOR
SETZM B36FLG(D) ;THE MONITOR IGNORED 36-BIT BYTESIZE!
MOVEI T1,TM.ANS ;STORE FACT THAT IT'S ANSI-ASCII
STORE T1,TAPM(D)
JRST GTMBUF ;GO STORE MAGTAPE RECORD SIZE
;8-BIT MAGTAPE, EITHER ANSI OR EBCDIC. SET BPW=4, SETUP AN 8-BIT
;DEFAULT BYTE POINTER FOR USE BOTH AS THE BUFFER POINTER FOR
;READING CHARACTERS TO/FROM THE MAGTAPE BUFFER FOR FOROTS AND
;AS THE SINR/SOUTR BUFFER POINTER FOR THE MONITOR WHEN READING
;IN IMAGE MODE. STORE THE RECORDSIZE DIRECTLY AS THE WINDOW SIZE,
;AND ONLY ROUND UP TO GET THE BUFFERSIZE IN WORDS.
TAPCM8: SKIPE T3,WSIZ(D) ;DID USER SPECIFY BLOCKSIZE?
JRST CM8GBS ;YES. GO PUT IT IN MONITOR
PUSHJ P,MTARRS ;NO. GET IT FROM MONITOR
MOVEM T3,WSIZ(D) ;STORE IT
CM8GBS: PUSHJ P,MTASRS ;SET BLOCKSIZE IN MONITOR
MOVEI T1,(POINT 8,0,31) ;8-BIT END-OF-WORD PNTR
STORE T1,BYTPT(D) ;SAVE IT
MOVEI T1,4 ;4 BYTES/WORD
MOVEM T1,BPW(D)
SETZM B36FLG(D) ;THE MONITOR IGNORE 36-BIT BYTESIZE!
MOVEI T1,TM.IND ;STORE FACT THAT IT'S INDUSTRY TAPE
STORE T1,TAPM(D)
MOVE T1,[BYTE (8)" "," "," "," "] ;GET A WORD OF BLANKS
MOVEM T1,SPCWD(D) ;SAVE FOR RECORD FILL
LOAD T1,MODE(D) ;GET MODE=
CAIE T1,MD.IMG ;IMAGE?
$ECALL IMO ;NO. IMAGE MODE ONLY FOR INDUSTRY TAPES
GTMBUF: MOVE T1,WSIZ(D) ;GET WINDOW SIZE AGAIN
ADD T1,BPW(D) ;ROUND UP TO WORDS FOR BUFFER SIZE
SUBI T1,1
IDIV T1,BPW(D) ;GET # WORDS
PUSHJ P,%GTBLK ;ALLOCATE A BLOCK
HRRZM T1,WADR(D) ;SAVE THE ADDRESS OF THE BUFFER
MOVE T0,FLAGS(D) ;Get DDB flags
TXNN T0,D%APP ;Are we appending?
JRST MTANAP ;NO
LOAD T1,IJFN(D) ;GET JFN AGAIN
MOVEI T2,.MOFWF ;FORWARD ONE FILE
MTOPR%
ERJMP APPERR
MOVEI T2,.MOBKR ;BACK OVER TAPE MARK
MTOPR%
ERJMP APPERR
MTANAP: JRST %POPJ1
;SET MTA BLOCKSIZE. T3=DESIRED SIZE
MTASRS: LOAD T1,LTYP(D) ;GET LABEL TYPE
CAIE T1,.LTUNL ;UNLABELED?
POPJ P, ;NO. DON'T TRY TO SET BLKSIZ
LOAD T1,IJFN(D) ;GET JFN
MOVEI T2,.MOSRS ;SET RECORD SIZE
XMOVEI P1,[ASCIZ /block size/]
MTOPR% ;SET IT
ERCAL MOPERR
POPJ P,
MTARRS: LOAD T1,IJFN(D) ;GET JFN
MOVEI T2,.MORRS ;READ RECORD SIZE
MTOPR%
ERJMP MOPERR ;SHOULDN'T EVER FAIL...
POPJ P,
XXXSET: HRLOI T1,377777 ;SET FILE VERY LARGE
MOVEM T1,EOFN(D)
MOVEI T1,1 ;GET A BUFFER PAGE
STORE T1,BUFCT(D) ;STORE BUFFER COUNT
LSH T1,9 ;MAKE # WORDS
MOVEI T2,(T1) ;COPY IT
IMUL T2,BPW(D) ;GET # BYTES/BUFFER
MOVEM T2,WSIZ(D) ;STORE AS WINDOW SIZE
PUSHJ P,%GTBLK
HRRZM T1,WADR(D) ;STORE ADDRESS OF BUFFER
JRST %POPJ1 ;ALL SET
SEGMENT DATA
LABINF: BLOCK 2 ;LABEL INFO
SEGMENT CODE
MOPERR:; IOERR (UMO,30,,%,$J trying to set tape $A,<P1>,%POPJ)
$ECALL UMO,%POPJ
APPERR:; IOERR (APP,30,,?,$J,,%POPJ)
$ECALL APP,%POPJ
;ROUTINE TO FILL IN GTJFN BLOCK FROM DDB
;POINTS DEFAULTS AT THE STRINGS STORED IN THE DDB
;SETS UP THE FLAGS APPROPRIATELY FROM /ACCESS AND /STATUS
SETJFN: LOAD T2,IJFN(D) ;ALREADY HAVE A JFN?
JUMPE T2,SETJ1 ;NO, SKIP
PUSHJ P,DOJFNS ;CONVERT JFN TO ASCIZ, STORE IN GTJFN BLOCK
MOVE T1,T2 ;RELEASE THE JFN
CAIE T1,.PRIIN ;If not real JFN,
CAIN T1,.PRIOU ;. .
JRST SETJF0 ;Don't release it
RLJFN%
JSHALT ;SHOULD NOT FAIL
SETJF0: MOVX T1,D%RJN ;Clear "Got a real JFN" flag
ANDCAM T1,FLAGS(D) ; if set.
SETZ T1, ;CLEAR JFN FIELDS IN DDB
STORE T1,IJFN(D)
STORE T1,OJFN(D)
MOVEI T1,ATMBUF ;POINT TO ASCIZ GENERATION NUMBER
PUSHJ P,ASCDEC ;CONVERT TO BINARY
$SNH ;Shouldn't fail
HRRZM T1,XGEN(D) ;Store in DDB
SETJ1: LOAD T1,ACC(D) ;GET /ACCESS
HLLZ T1,FILTAB(T1) ;GET SOME APPROPRIATE FLAG BITS
HRR T1,XGEN(D) ;PUT IN DEFAULT GENERATION NUMBER
LOAD T2,DVTYP(D) ;GET DEV TYPE
CAIE T2,.DVDSK ;DISK?
TXZ T1,GJ%OFG ;NO, CLEAR PARSE-ONLY BIT
LOAD T2,STAT(D) ;GET /STATUS
CAIN T2,ST.OLD ;/STATUS:OLD?
TXO T1,GJ%OLD ;YES, IMPLIES GTJFN BIT
CAIN T2,ST.NEW ;/STATUS:NEW?
TXO T1,GJ%NEW ;YES, IMPLIES GTJFN BIT
TXNE T1,GJ%OLD ;KEEP FLAG BITS CONSISTENT
TXZ T1,GJ%NEW+GJ%FOU ;IF OLD, THEN NOT NEW AND NOT FOR OUTPUT
TXO T1,GJ%MSG!GJ%XTN ;ALWAYS TYPE CONFIRMATION MESSAGE
; and use extended GTJFN block
MOVEM T1,JFNBLK+.GJGEN ;STORE IN FLAG WORD
MOVEI T1,<.GJATR-.GJF2> ;No flags,,# of words to follow extended word
MOVEM T1,JFNBLK+.GJF2
MOVE T1,[.NULIO,,.NULIO] ;NO JFNS
MOVEM T1,JFNBLK+.GJSRC
SKIPE T1,DEV(D) ;DEVICE
HRROI T1,DEV(D)
MOVEM T1,JFNBLK+.GJDEV
SKIPE T1,DIR(D) ;DIRECTORY
HRROI T1,DIR(D)
MOVEM T1,JFNBLK+.GJDIR
SKIPE T1,FILE(D) ;FILENAME
HRROI T1,FILE(D)
MOVEM T1,JFNBLK+.GJNAM
SKIPE T1,EXT(D) ;EXT
HRROI T1,EXT(D)
MOVEM T1,JFNBLK+.GJEXT
SKIPE T1,PROT(D) ;PROT
HRROI T1,PROT(D)
MOVEM T1,JFNBLK+.GJPRO
;SOMETHING LIKE THE FOLLOWING WHEN /TAPEMODE WORKS.
; It can't be done now because you get GTJFN error
; for disk ("?Attribute illegal for this device")
REPEAT 0,<
XMOVEI T1,[EXP 2 ;2 words in attribute block
POINT 7,[ASCIZ/FORMAT:F/]] ;For MAGTAPE
MOVEM T1,JFNBLK+.GJATR
>;end repeat 0
POPJ P, ;ALL SET
;Routine to get the ASCII filespec fields back out of the JFN
;Call:
; T2/ JFN
; PUSHJ P,DOJFNS
; <return here, ASCII strings in DDB set up>
; Uses T1, T3
DOJFNS: CAIE T2,.PRIOU ;TTY:?
CAIN T2,.PRIIN ; . .
JRST DOJFN1 ;Yes, don't use JFNS%
;"REAL" JFN in T2.
DOJFNR: HRROI T1,DEV(D) ;STORE DEVICE AS SUBSEQUENT DEFAULT
MOVX T3,FLD(.JSAOF,JS%DEV)
JFNS%
HRROI T1,DIR(D) ;STORE DIRECTORY
MOVX T3,FLD(.JSAOF,JS%DIR)
JFNS%
HRROI T1,FILE(D) ;STORE FILENAME
MOVX T3,FLD(.JSAOF,JS%NAM)
JFNS%
HRROI T1,EXT(D) ;STORE EXTENSION
MOVX T3,FLD(.JSAOF,JS%TYP)
JFNS%
HRROI T1,ATMBUF ;STORE GENERATION NUMBER IN ASCIZ
MOVX T3,FLD(.JSAOF,JS%GEN)
JFNS%
SETZM PROT(D) ;Clear old protection, if set.
HRROI T1,PROT(D) ;STORE PROTECTION
MOVX T3,FLD(.JSAOF,JS%PRO)
JFNS%
; HRROI T1,ACCT(D) ;DO SOMETHING REASONABLE ABOUT THIS
; MOVX T3,FLD(.JSAOF,JS%ACT)
; JFNS%
POPJ P,
;JFN in T2 was .PRIIN or .PRIOU
;Store filespec as TTY:FORTTY.DAT
DOJFN1: SETZM DIR(D) ;No directory
SETZM ATMBUF ;No generation number
SETZM PROT(D) ;No protection
; SETZM ACCT(D) ;No account
MOVE T1,[ASCIZ /TTY/]
MOVEM T1,DEV(D) ;Store device name
MOVE T1,[ASCII /FORTT/]
MOVEM T1,FILE(D) ;Store file name..
MOVE T1,[ASCIZ /Y/]
MOVEM T1,FILE+1(D)
MOVE T1,[ASCIZ /DAT/]
MOVEM T1,EXT(D) ;Store extension
POPJ P, ;Done, return
>;END IF20
IF10,<
;Call:
; T1/ BITS TO SET WHEN FILE GETS OPENED
; PUSHJ P,DOOPEN
; <here if OPEN failed, F%DRE set (unless ERR= taken)>
; <here if worked>
DOOPEN: PUSHJ P,%SAVE1 ;Get a free ac
MOVE P1,T1 ;Save bits in P1
PUSHJ P,SETMAF ;LAST MINUTE SET MODE= AND FORM=
PUSHJ P,CNFDEV ;CHECK FOR DEVICE CONFLICTS
POPJ P, ;ERROR, GO DO DIALOG
LOAD T1,MODE(D) ;Get /MODE
MOVE T2,MODTAB(T1) ;AND DATA MODE
STORE T2,DMODE(D)
PUSHJ P,%CHKNR ;Check data mode
JRST REQDIA ;Illegal, go have dialog
PUSHJ P,SETOCH ;Set OPEN channel
;May take ERR= branch
LOAD T2,ACC(D) ;Get ACCESS mode
CAIE T2,AC.RIN ;RANDOM IO?
CAIN T2,AC.RIO
JRST [ TXO P1,D%RAN ;Yes, will set "RANDOM" if file opened
MOVEI T2,.IODMP ;And set "DUMP MODE"
STORE T2,DMODE(D)
JRST .+1]
;Do some setup depending on device type
MOVEI T2,5 ;FOR NOW, 5 BYTES/WORD DEFAULT
MOVEM T2,BPW(D) ;SAVE FOR MANY CALCS
MOVEI T1,(POINT 7,0,34) ;DEFAULT IS 7-BIT BYTES
STORE T1,BYTPT(D) ;SAVE BP FOR FORIO
MOVE T1,[ASCII / /] ;GET A WORD OF SPACES
MOVEM T1,SPCWD(D) ;SAVE FOR RECORD FILL
LOAD T2,INDX(D) ;Get device index
PUSHJ P,@[
IFIW TTYSET
IFIW DSKSET
IFIW MTASET
IFIW XXXSET
IFIW E.SNH](T2) ;Do dev-dependent stuff
JRST [PUSHJ P,RETOCH ;?Failed, Return OPEN channel
PJRST REQDIA] ;Go request DIALOG and return .+1
;Warning-- errors from now on must first un-do the above, for
; example the allocation of buffers for disk, etc.
MOVE T1,P1 ;Get flags to set in T1
PUSHJ P,ALLBUF ;Allocate buffers
MOVE T5,P1 ;Get fresh flags in T5
PUSHJ P,CALOF ;Call OPEN routine based on flags, ACC, STAT
POPJ P, ;error, return .+1
MOVEI T2,AC.SOU ;Change ACCESS to SEQOUT
LOAD T1,INDX(D) ; If device was a TTY
CAIN T1,DI.TTY
STORE T2,ACC(D)
PUSHJ P,FIXU ;Fix unit block stuff too
PUSHJ P,FIXDEF ;Defaults after everything is in place.
PUSHJ P,DOCONS ;Do consolidation of DDB's if necessary
TXNN F,F%CTTY ;Is this the controlling TTY:?
JRST NOCTTY ;NO
MOVEM D,D.TTY ;Yes, store its DDB address.
MOVEM U,U.TTY ;AND ITS UNIT BLOCK ADDR
NOCTTY: LOAD T2,ACC(D) ;GET ACCESS TYPE
CAIE T2,AC.APP ;APPEND?
JRST %POPJ1 ;Return success
MOVE T1,SIZ(D) ;GET RBSIZ
ADDI T1,177 ;ROUND UP FOR BLOCKS
LSH T1,-7 ;GET # BLOCKS
MOVEM T1,BLKN(D) ;WE ARE AT EOF!
JRST %POPJ1
;Routine to clean up from OPEN error (deallocate buffers, channel)
; This is called prior to IOERR call incase the ERR= branch is taken,
;therefore it doesn't need to be called above if CALOF returns .+1.
OFCLNU: LOAD T1,WADR(D) ;Deallocate buffer (if any)
JUMPE T1,OFCLN1 ; None
PUSHJ P,%FREBLK
SETZ T1,
STORE T1,WADR(D)
OFCLN1: MOVEI T1,FBLK(D) ;Point to FILOP. block
SETZM .FONBF(T1) ;Clear buffer counts
SETZM .FOBRH(T1) ;Clear buffer headers
;Deallocate stuff gotten by DSKSET
LOAD T1,INDX(D) ;What type of device
CAIE T1,DI.DSK ; If not disk,
JRST OFCLN2 ;No more core to deallocate
LOAD T1,ACC(D) ;Get ACCESS type
MOVE T3,ACCTAB(T1) ;See if random file
TXNN T3,D%RAN ; Skip if random
JRST OFCLN2 ;No, we didn't allocate any more core
MOVE T1,WPTR(D) ;GET PAGE # OF RANDOM ACCESS PAGES
LOAD T2,BUFCT(D) ;GET # BLOCKS
PUSHJ P,%FREPGS ;Free up the core
MOVE T1,WTAB(D) ;Now free the page table
PUSHJ P,%FREBLK ; . .
MOVE T1,PFTAB(D) ;AND FREE THE PAGE FLAG TABLE
PUSHJ P,%FREBLK
SETZM WPTR(D) ;Clear all indication that we had memory
OFCLN2: PUSHJ P,RETOCH ;Return OPEN channel
SETZM FBLK(D) ; Forget file was opened
POPJ P, ;Return
;Routine to do general FILOP. setup.
;T1= flags to set.
;Returns .+1 always
ALLBUF: PUSH P,T1 ;Save flags a sec
LOAD T1,ACC(D) ;Get ACCESS
MOVE T3,ACCTAB(T1) ;Get flags by ACCESS type
TXNE T3,D%RAN ;RANDOM I/O?
JRST NOABUF ;Yes, don't allocate buffer here
MOVEI T2,DMOD(D) ;Point ot OPEN block
DEVSIZ T2, ;Get buffer size
JRST NOABUF ;No buffers
JUMPE T2,NOABUF
LOAD T1,BUFCT(D) ;Get /BUFFERCOUNT
CAIN T1,0 ; If set
HLRZ T1,T2 ;Else get default
LOAD T3,INDX(D) ;GET DEVICE INDEX
CAIN T3,DI.TTY ;TTY?
MOVEI T1,1 ;YES. ONLY 1 BUFFER IN EACH DIRECTION
STORE T1,BUFCT(D) ;Store it back
CAIN T3,DI.TTY ;TTY?
LSH T1,1 ;YES. ONE IN EACH DIRECTION
IMULI T1,(T2) ;Get total space needed by buffers
NOTIN: PUSHJ P,%GTBLK ;Allocate buffers
STORE T1,WADR(D) ;Save for CLOSE
NOABUF:
MOVEI T1,FBLK(D) ;T1 points to FILOP. block
MOVEI T2,LKPB(D) ;Set pointers
MOVEM T2,.FOLEB(T1)
MOVEI T2,LLEN
MOVEM T2,LKPB+.RBCNT(D)
MOVEI T2,PTHB(D)
HRLI T2,9
MOVEM T2,.FOPAT(T1)
PUSHJ P,SETPPB ;Set ptr to path block
POP P,T5 ;Get flags in T5
PJRST %ST10B ;Setup .FOBRH, .FONBF and return
;Routine to setup part of TOPS-10 FILOP. block based on IO flags
; Sets up .FOBRH, .FONBF
;Call:
; MOVX T5,D%IN or D%OUT (flags to set on OPEN)
; PUSHJ P,SET10F
; <return here always>
;If DUMP mode is set, no buffer pointers are setup.
%ST10B: MOVEI T1,FBLK(D) ;T1 points to FILOP. block
SETZ T2, ;IBCB or OBCB or both
LOAD T3,DMODE(D) ;Unless dump mode
CAIN T3,.IODMP
POPJ P, ;Then no ptrs setup
LOAD T4,INDX(D) ;Get type of device
CAIN T4,DI.TTY ;TTY?
TXO T5,D%IN+D%OUT ;Yes, will be both input and output
TXNE T5,D%IN
HRRI T2,IBCB(D)
TXNE T5,D%OUT
HRLI T2,OBCB(D)
MOVEM T2,.FOBRH(T1)
LOAD T3,BUFCT(D) ;Set buffer count
TLNE T2,-1
HRLI T2,(T3)
TRNE T2,-1
HRRI T2,(T3)
MOVEM T2,.FONBF(T1)
POPJ P, ;Return
;Routine to call the appropriate OPEN routine based on flags in T5,
; ACCESS and STATUS.
;Returns .+1 if error, F%DRE set (unless ERR= taken)
;Returns .+2 if success, DDB flags set.
CALOF: LOAD T2,INDX(D) ;Get type of device
CAIN T2,DI.TTY ;TTY:?
SKIPA T1,[AC.SOU] ;Yes, use SEQOUT access.
LOAD T1,ACC(D) ;T1= access
LOAD T2,STAT(D) ;T2= STATUS
CAILE T2,ST.UNK ;Must be OLD, NEW, SCRATCH, or UNKNOWN
$SNH ;NO, ERROR
MOVE T2,STIDX(T2) ;Get index
JUMPL T2,E.SNH ;?Must be good status
MOVE T1,OPACTB(T1) ;Get table by access
JUMPE T1,E.SNH ;? Illegal access
ADD T1,T2 ;Get address of place to go
JRST CALOF1 ;Go call routine
;Enter here when the FBLK word is all setup.
; Called from FORIO when the file is closed and re-opened.
;T5= flags to set when file gets opened.
%CALOF: MOVEI T1,OPGFB ;Routine to call
JRST CALOF1 ;Continue here
;Here is the routine for CLOSE/OPEN when FBLK is already setup.
OPGFB: PUSHJ P,DOFLP ;Do the FILOP.
JRST FLPFL ;Failed, go restore stuff and give error
JRST %POPJ1 ;Success, done.
;** Common code for CALOF **
CALOF1: PUSHJ P,(T1) ;Call appropriate routine
JRST OFAIL ;Failed, go clear stuff and return .+1
IORM T5,FLAGS(D) ;Success: Set DDB flag bits
LOAD T2,INDX(D) ;GET DEVICE INDEX
CAIE T2,DI.DSK ;DISK?
JRST %POPJ1 ;NO. DON'T CALC EOFN!
MOVE T2,SIZ(D) ;Incase this is an input file,
IMUL T2,BPW(D) ; get number of bytes and store in EOFN.
MOVEM T2,EOFN(D)
MOVE T2,SIZ(D) ;GET .RBSIZ AGAIN
ADDI T2,777 ;ROUND UP TO PAGE
LSH T2,-9 ;GET TOP BLOCK NUMBER
SUBI T2,1 ;(IF NULL FILE, THIS WILL BE -1!)
MOVEM T2,TPAGE(D) ;SAVE AS TOP PAGE OF FILE
JRST %POPJ1 ;Return success
;"Dialog requested" bit set.
OFAIL: ;; ** UNDO STUFF **
POPJ P, ;Failure return
;Index into tables by STATUS
STIDX: -1 ;?Must be set
0 ;OLD
1 ;NEW
3 ;SCRATCH
2 ;UNKNOWN
OPACTB: 0 ;0- illegal
OTBSIN ;1- SEQIN
OTBSOU ;2- SEQOUT
OTBSIO ;3- SEQINOUT
OTBRIN ;4- RANDIN
OTBRIO ;5- RANDOM
OTBAPP ;6- APPEND
;SEQIN ACCESS
OTBSIN: JRST OPRD ;OLD
$SNH ;NEW
JRST OPRD ;UNKNOWN
$SNH ;SCRATCH
;SEQOUT ACCESS
OTBSOU: JRST OPSO ;OLD
JRST OPSWN ;NEW
JRST OPSW ;UNKNOWN
$SNH ;SCRATCH
;SEQINOUT ACCESS
OTBSIO: JRST OPRD ;OLD
JRST OPSWN ;NEW
JRST OPSIOU ;UNKNOWN (DEPENDS ON VERB)
JRST OPSIOS ;SCRATCH
;RANDIN ACCESS
OTBRIN: JRST OPRD ;OLD
$SNH ;NEW
JRST OPRD ;UNKNOWN
$SNH ;SCRATCH
;RANDOM ACCESS
OTBRIO: JRST OPRO ;OLD
JRST OPRN ;NEW
JRST OPRU ;UNKNOWN
JRST OPRS ;SCRATCH
;APPEND ACCESS
OTBAPP: JRST OPAO ;OLD
JRST OPAN ;NEW
JRST OPAU ;UNKNOWN
$SNH ;SCRATCH
;OPEN file that must exist for READ.
OPRD: MOVEI T1,.FORED ;Simple READ function
HRRM T1,FBLK(D) ;Set it
PUSHJ P,DOFLP ;Do the FILOP.
JRST FLPFL ;Failed, go restore stuff and give error
JRST %POPJ1 ;Success, done.
;OPEN file that must exist for WRITE (it will be superseded!)
OPSO: MOVEI T1,.FOCRE ;CREATE function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;Do the FILOP.
JRST OPRD1 ;Failed, check out error code
PUSHJ P,CLDISC ;OOPS, create succeeded!
; CLOSE file and discard it.
MOVEI T1,ERFNF% ;Pretend he got FILOP. error "File not found"
JRST FLPFL ;Go process the error
;The CREATE FILOP. failed. See if the error code = 'FILE ALREADY EXISTS'
OPRD1: CAIE T1,ERAEF% ;Already exists?
JRST FLPFL ;No, unexpected error
MOVEI T1,.FOWRT ;OK, plain WRITE
HRRM T1,FBLK(D) ;Set function
PUSHJ P,DOFLP
JRST FLPFL ;?failed
JRST %POPJ1 ;Succeeded, return
;OPEN file that must not exist for WRITE
OPSWN: MOVEI T1,.FOCRE ;Create function
HRRM T1,FBLK(D) ;Set function
PUSHJ P,DOFLP
JRST FLPFL ;?failed
JRST %POPJ1 ;Succeeded, return
;OPEN file for WRITE. If it exists, it is superseded.
OPSW: MOVEI T1,.FOWRT ;Write function
HRRM T1,FBLK(D) ;Set it
PUSHJ P,DOFLP
JRST FLPFL ;?failed
JRST %POPJ1 ;Succeeded, return
;OPEN SEQINOUT (SEQUENTIAL) file with UNKNOWN status.
;T5= the way we want it opened.
;D%IN= want it opened for input.
;D%OUT= want it opened for output.
; If neither set, don't care.
OPSIOU: TXNE T5,D%OUT ;Want it opened for output?
JRST OPSW ;yes
;See if file exists.
; If it exists, it will be opened for input.
; If it doesn't exist, and an OPEN statement has been done,
; it will be created and opened for input.
MOVEI T1,.FORED ;Try to read file
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;If succeeds, set file opened for input
JRST OPSIC1 ;Failed, maybe file not found?
TXO T5,D%IN ;Set opened for input if successful
JRST %POPJ1 ;Return
;Note: If the directory is protected WRITE-ONLY, then he will get
; an error from READ or CLOSE because the file could not be created!
OPSIC1: MOVE T2,FLAGS(D) ;GET DDB FLAGS
TXNE T2,D%OPEN ;OPEN STATEMENT DONE?
CAIE T1,ERFNF% ;File not found?
JRST FLPFL ;No, bad error
MOVEI T1,.FOSAU ;Create file
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;** Do FILOP. **
JRST FLPFL ;All errors are fatal
TXO T5,D%IN ;Set file opened for output
JRST %POPJ1 ;Return
;OPEN RANDOM file that must exist.
OPRO: PUSHJ P,CHKEXI ;Make sure file exists
POPJ P, ;It doesn't
OPRGO: MOVEI T1,.FOSAU ;OK, do an update
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST FLPFL ;?failed
JRST %POPJ1 ;Succeeded, return
;OPEN RANDOM file that must not exist.
OPRN: MOVEI T1,.FOCRE ;Set CREATE function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;Do FILOP.
JRST FLPFL ;?failed
;File did not exist. Now CLOSE and OPEN it again for updating.
MOVEI T2,.FOCLS
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR
JRST OPRGO
;OPEN RANDOM file, STATUS='UNKNOWN'
OPRU: MOVEI T1,.FOCRE ;Set CREATE Function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST OPRUCF ;Failed, go check error
;File did not exist. Close, re-open for updating.
MOVEI T2,.FOCLS
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1, ;Do CLOSE FILOP.
PUSHJ P,CLSERR
JRST OPRGO ;Go open for updating now
;Here if OPEN For RANDOM, STATUS='UNKNOWN' and FILOP. CREATE failed.
OPRUCF: CAIE T1,ERAEF% ;Already exists?
JRST FLPFL ;No, funny failure
JRST OPRGO ;Go open for updating now
;OPEN APPEND, file must exist
OPAO: PUSHJ P,CHKEXI ;Make sure file exists
POPJ P, ;It doesn't
OPAGO: MOVEI T1,.FOAPP ;Set APPEND function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST FLPFL ;?Failed
JRST %POPJ1 ;Succeeded, return
;OPEN APPEND, file must not exist
OPAN: MOVEI T1,.FOCRE ;Set CREATE function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST FLPFL ;?failed
JRST %POPJ1 ;Succeeded, return
;OPEN APPEND, status='UNKNOWN'
OPAU: MOVEI T1,.FOCRE ;Try a create
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST OPAUCF ;Failed, go see why
;Hey we just succeeded in creating a new file. We
; could probably just return "successfully" now, but
; some people claim it is "more consistant" to CLOSE
; this channel and re-open with the APPEND FILOP.
MOVEI T2,.FOCLS ;CLOSE channel
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1, ;Do CLOSE FILOP.
PUSHJ P,CLSERR ;Failed, give warning
JRST OPAGO ;OK, now re-open with "APPEND" FILOP.
OPAUCF: CAIE T1,ERAEF% ;Already exists?
JRST FLPFL ;No, funny failure
JRST OPAGO ;Go do APPEND function
;OPEN SCRATCH SEQINOUT file
OPSIOS: PUSHJ P,SETSCN ;Set scratch name
SETZ T3, ;Count # tries
OPSIS1: MOVEI T1,.FOCRE ;Get new file
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;Try a CREATE
JRST OPSIS2 ;Failed, go see why
JRST %POPJ1 ;Succeeded, file opened for output
OPSIS2: ADDI T3,1 ;Count # of attempts
CAIE T1,ERAEF% ;File already exists?
JRST FLPFL ;No, bad error
CAILE T3,^D10 ;Tried too many times?
JRST FLPFL ;Yes, just give error
PUSHJ P,SETSCN ;Try another name
JRST OPSIS1 ; . .
;OPEN SCRATCH RANDOM file
OPRS: PUSHJ P,SETSCN ;Set scratch name
SETZ T3, ;Count # of tries
OPRS1: MOVEI T1,.FOCRE ;Set CREATE function
HRRM T1,FBLK(D)
PUSHJ P,DOFLP
JRST OPRS2 ;Maybe file does exist already
;File did not exist. CLOSE and OPEN again for updating.
MOVEI T2,.FOCLS
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR
JRST OPRGO ;Go open random file.
OPRS2: CAIE T1,ERAEF% ;File already exists error?
JRST FLPFL ;No, the OPEN fails.
ADDI T3,1 ;Count # attempts
CAILE T3,^D10 ;Too many?
JRST FLPFL ;Yes, just give FILOP error
PUSHJ P,SETSCN ;Get another name for SCRATCH
JRST OPRS1 ;Try again
;Routine to set a name for a SCRATCH file
;Uses T1,T2 only
SETSCN: PUSHJ P,GTMWRD ;Get random sixbit
MOVEM T1,FILE(D)
MOVSI T1,'TMP' ;Extension .TMP
MOVEM T1,EXT(D)
POPJ P, ;Return
;Routine to get random sixbit word in T1
GTMWRD: SKIPE SEED ;Already have a random seed?
JRST GTMWR1 ;Yes
MSTIME T1, ;Get time of day in milliseconds
HRRM T1,SEED ;Save random-number seed
HRLM T1,SEED ;. .
GTMWR1: MOVE T1,I.JOB ;[2064] Get SIXBIT job number in RH
DMOVEM T3,GTMSV3 ;Save acs
MOVEI T4,3 ;[2064] # chars to get
GTMWR2: PUSHJ P,GTMCHR ;Get random char
LSH T1,6 ;Shift left six
ADDI T1,(T2) ;Add in char
SOJG T4,GTMWR2 ;Loop
DMOVE T3,GTMSV3 ;Restore acs
POPJ P, ;And return
;Routine to get random sixbit letter in T2
;Uses t3
GTMCHR: MOVE T3,SEED ;Get current seed
ANDI T3,17 ;Just save last 4 bits
MOVEI T2,'A'(T3) ;Get letter
MOVE T3,SEED ;Get current seed
ROT T3,7 ;Rotate
ADD T3,T2 ;Add in value of letter
MOVEM T3,SEED ;Store new seed
POPJ P, ;Return
SEGMENT DATA
GTMSV3: BLOCK 2 ;Saved acs for GTMWRD
SEED: BLOCK 1 ;Random-number seed
SEGMENT CODE
;Routine to make sure file exists.
; If it doesn't, return .+1, error given (or ERR= taken)
; If it does, return .+2
CHKEXI: MOVEI T1,.FOCRE ;Try to create file
HRRM T1,FBLK(D) ;Set function
PUSHJ P,DOFLP
JRST CHKEX2 ;Failed, make sure error is correct
PUSHJ P,CLDISC ;OOPS, create succeeded!
; CLOSE file and discard it.
;Give error message
MOVEI T1,ERFNF% ;Pretend we got "file not found" error
PJRST FLPFL
;The CREATE FILOP. failed. See if the error code = 'FILE ALREADY EXISTS'
CHKEX2: CAIE T1,ERAEF% ;Already exists?
PJRST FLPFL ;No, unexpected error
PJRST %POPJ1 ;Return ok
;Routine to get an OPEN channel
; Goes to %ABORT or ERR= if can't get
SETOCH: SKIPE %EXCHN ;EXTENDED CHANNELS AVAILABLE?
JRST GTXCHN ;Yes, use them
PUSHJ P,ALCHN ;Get a channel
$ECALL NFC,%ABORT ;?Too many OPEN units
TXOA T1,(FO.PRV) ;Request use of privs incase we have any
GTXCHN: MOVEI T1,(FO.PRV+FO.ASC) ;"Allocate any channel"
HRLM T1,CHAN(D) ;Store channel number
POPJ P, ;Return
;Routine to deallocate OPEN channel if necessary
RETOCH: HLRZ T1,CHAN(D) ;Get channel number
TRZE T1,(FO.ASC) ;Extended channel not assigned yet?
POPJ P, ;yes, nothing to do
PUSH P,T1 ;Save bits
MOVEI T2,.FOREL ;Release it
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
JFCL ; (If the OPEN failed, channel not assigned.)
POP P,T1 ;Restore channel stuff
TRZ T1,(FO.PRV) ;Clear PRIV bit
CAILE T1,17 ; Did we have to allocate chan ourselves?
POPJ P, ;No, nothing to do
PJRST DECHN ;Yes, go deallocate it and return
;Routine to do some kind of OPEN FILOP.
;Clears .RBALC word after a successful OPEN
; (so further FILOP's don't set it by mistake).
;Uses T1, T2 only
DOFLP: PUSH P,.JBFF
LOAD T1,WADR(D) ;Point .JBFF at buffers
HRRZM T1,.JBFF
MOVEI T1,FBLK(D) ;Point to FILOP. block
HRLI T1,FLEN ;Set length
FILOP. T1, ;** Do FILOP. **
JRST DOFLP1 ;Failed
POP P,.JBFF ;Succeeded, restore .JBFF
SETZM LKPB+.RBALC(D) ; so it won't be an arg to further FILOP's
PUSHJ P,SETPPB ;Store correct path stuff
LOAD T1,BYTPT(D) ;GET BYTE POINTER
LDB T1,[POINT 6,T1,29] ;GET BYTE SIZE
STORE T1,IBSIZ(D) ;Save
STORE T1,OBSIZ(D)
LOAD T1,FORM(D) ;GET FORM=
CAIE T1,FM.UNF ;UNFORMATTED?
JRST %POPJ1 ;NO. NOTHING MORE TO DO
MOVE T1,BPW(D) ;YES. CORRECT OUTPUT COUNT IN CASE APPEND
IMULM T1,OCNT(D)
JRST %POPJ1 ; And skip return
;Here if the OPEN FILOP. failed
;If the error was "not enough free channels",
; try to allocate a low channel.
DOFLP1: POP P,.JBFF ;Failed, restore .JBFF
CAIE T1,ERNFC% ;Not enough channels?
PJRST SETPPB ;No, store correct path stuff and return
PUSHJ P,ALCHN ;Go allocate a channel
$ECALL NFC,%ABORT ;?Too many OPEN units
TXO T1,(FO.PRV) ;Request use of privs incase we have any
HRLM T1,CHAN(D) ;Try again with this channel
JRST DOFLP ;Try again
;Routine to setup correct path stuff
; If there is a specified path, point to it.
; Else store zero in the PPN word of the lookup block.
;Uses T2 only
SETPPB: MOVEI T2,PTHB(D)
SKIPN PTHB+.PTPPN(D) ;If PATH set, put PATH dir in LOOKUP block
SETZ T2, ; Else store zero
HRRZM T2,PPN(D)
POPJ P, ;Return
;Routine to CLOSE file and discard old stuff
; If errors, the program is aborted.
CLDISC: MOVE T1,[2,,T2] ;Setup for CLOSE
MOVEI T2,.FOCLS
HLL T2,CHAN(D)
MOVX T3,CL.RST ; Discard new file
FILOP. T1,
PUSHJ P,CLSERR ;Type error message
POPJ P, ;Return
;Come here if the FILOP. failed and this means that the operation failed.
; Clean up, give standard FILOP. error, and if the ERR= branch is not
; taken, return .+1 to go to request dialog
FLPFL: PUSH P,T1 ;Save FILOP. error code
PUSHJ P,OFCLNU ;Cleanup (deallocate buffers, etc.)
POP P,T1 ;Re-get FILOP. error
$ECALL OPN,REQDIA ;FILOP. error - reason
;Prior-to-OPEN-FILOP setup routines for devices.
XXXSET==%POPJ1
TTYSET: MOVX T1,D%SEOL+D%INT ;Suppress initial CRLF for terminals
IORM T1,FLAGS(D) ;SET TO INTERACTIVE DEVICE ALSO
SKIPE T1,RSIZE(D) ;RECORD SIZE SPECIFIED?
JRST STOTTW ;YES. STORE AS TTYW
MOVE T1,[2,,T2] ;LEN,,ADDRESS OF TRMOP BLOCK
MOVEI T2,.TOWID ;LINE WIDTH
MOVE T3,DEV(D) ;GET DEVICE NAME
IONDX. T3, ;CONVERT TO TERMINAL UDX
JRST TTY72 ;CAN'T GUESS 72 COLS
TRMOP. T1, ;READ LINE WIDTH
JRST TTY72 ;CAN'T
CAIN T1,0 ;IS IT SET?
TTY72: MOVEI T1,^D72 ;GUESS 72 COLS
STOTTW: STORE T1,TTYW(D) ;STORE LINE SIZE FOR NAMELIST/LIST-DIRECTED
JRST %POPJ1 ;DONE
DSKSET: TXNN P1,D%RAN ;RANDOM?
JRST %POPJ1 ;NO
MOVE T1,BPW(D) ;GET BYTES/WORD
LSH T1,9 ;GET BYTES/PAGE
MOVEM T1,WSIZ(D) ;SAVE AS WINDOW SIZE
LOAD T1,BUFCT(D) ;GET BUFFERCOUNT, BLOCKS
JUMPN T1,DSKNZB ;OK IF NON-ZERO
MOVEI T1,^D4 ;USE 4 PAGES IF ZERO
STORE T1,BUFCT(D) ;STORE THIS DEFAULT
DSKNZB: PUSHJ P,%GTPGS ;ALLOCATE PAGES FOR BUFFERING DUMP IO
$ECALL MFU,%ABORT ;?Can't, mem full
MOVEM T1,WPTR(D) ;SAVE PAGE ADDRESS
LOAD T1,BUFCT(D) ;GET BUFFERCOUNT AGAIN
PUSHJ P,%GTBLK ;ALLOCATE PAGE TABLE
MOVEM T1,WTAB(D) ;SAVE IT
LOAD T2,BUFCT(D) ;GET BUFFERCOUNT YET AGAIN
DSETL: SETOM (T1) ;SET FILE BLOCK TO NG ONE
ADDI T1,1
SOJG T2,DSETL ;LOOP
LOAD T1,BUFCT(D) ;GET BUFFERCOUNT AGAIN!
PUSHJ P,%GTBLK ;ALLOCATE PAGE FLAG TABLE
MOVEM T1,PFTAB(D) ;SAVE ADDR
JRST %POPJ1 ;DONE
MTASET: PUSHJ P,%SAVE1
MOVEI T1,1 ;BUFFERCOUNT IS ALWAYS 1
STORE T1,BUFCT(D) ;BECAUSE PULSAR DOESN'T WORK
MOVE T2,DEV(D) ;GET DEVICE NAME
MOVEI T1,.TFDEN+.TFSET ;SET DENSITY
LOAD T3,DEN(D) ;GET /DENSITY
JUMPE T3,MTAST1 ;IF UNIT DEFAULT, LEAVE ALONE
CAIN T3,DN.SYS ;SYSTEM DEFAULT?
MOVEI T3,.TFD00 ;YES, SET THAT
MOVEI P1,[ASCIZ /density/]
MOVE T0,[3,,T1] ;SET POINTER FOR TAPOP
TAPOP. T0, ;SET IT
JRST TOPERR ;Shouldn't fail
MTAST1: MOVEI T1,.TFPAR+.TFSET ;SET PARITY
LOAD T0,PAR(D) ;GET /PARITY
JUMPE T0,NOPAR ;NO PARITY GIVEN
SETZ T3, ;ASSUME ODD
CAIN T0,PR.EVEN ;EVEN?
MOVEI T3,1 ;YES. SET TO EVEN PARITY
MOVEI P1,[ASCIZ /parity/]
MOVE T0,[3,,T1] ;SET POINTER FOR TAPOP
TAPOP. T0, ;SET IT
JRST TOPERR ;?Shouldn't fail
NOPAR: LOAD T1,TAPM(D) ;GET /TAPEMODE
JUMPE T1,NOMODE ;NONE GIVEN. DON'T DO IT!
MOVEI T3,.TFMDD ;GET DEFAULT
CAIN T1,TM.IND ;INDUSTRY COMPATIBLE?
MOVEI T3,.TFM8B ;YES, READ 8-BIT BYTES
CAIN T1,TM.ANS ;ANSI-ASCII?
MOVEI T3,.TFM7B ;YES, 7-BITS IN 8-BIT BYTES
MOVEI T1,.TFMOD+.TFSET ;SET HARDWARE DATA MODE
MOVEI P1,[ASCIZ /data mode/]
MOVE T0,[3,,T1] ;SET POINTER FOR TAPOP
TAPOP. T0, ;SET IT
JRST TOPERR ;?Shouldn't fail
NOMODE: LOAD T3,BLKSZ(D) ;GET /BLOCKSIZE, BYTES
JUMPE T3,GETMDM ;IF SET
;Compute bytes/per/word, not normally done until FIXDEF called.
LOAD T1,MODE(D) ;GET FILE MODE
MOVE T2,BSTAB(T1) ;GET BYTE SIZE
MOVEI T1,^D36 ;DIVIDE INTO 36 TO GET # BYTES/WORD
IDIVI T1,(T2)
MOVE T4,T1 ;Copy to T4
MOVEI T1,.TFBSZ+.TFSET ;SET BLOCK SIZE
MOVE T2,DEV(D) ;GET DEVICE NAME AGAIN
ADDI T3,-1(T4) ;ROUND UP BLOCKSIZE
IDIVI T3,(T4) ;GET # WORDS
ADDI T3,1 ;ADD 1 MORE BECAUSE UUO WANTS IT
MOVEI P1,[ASCIZ /block size/]
MOVE T0,[3,,T1] ;SET POINTER FOR TAPOP
TAPOP. T0, ;SET IT
JRST TOPERR ;?Shouldn't fail
GETMDM: MOVEI T1,.TFMOD ;GET DATA MODE
TAPOP. T0,
JFCL
CAIE T0,.TFM7B ;ANSI-ASCII
JRST TRYM8B ;NO
MOVEI T1,TM.ANS ;YES. SET TO ANSI-ASCII MODE
STORE T1,TAPM(D)
JRST %POPJ1
TRYM8B: CAIE T0,.TFM8B ;INDUSTRY?
JRST %POPJ1 ;NO.
;WE HAVE AN INDUSTRY-MODE TAPE. SET THE BYTE POINTER TO 8-BIT, SET
;BPW TO 4. EVERYTHING ELSE WILL FALL OUT.
MOVEI T1,TM.IND ;SET TAPEMODE TO INDUSTRY
STORE T1,TAPM(D)
MOVEI T1,(POINT 8,0,31) ;RIGHT-JUSTIFIED 8-BIT PNTR
STORE T1,BYTPT(D)
MOVEI T1,4 ;SET 4 BYTES/WORD
MOVEM T1,BPW(D)
MOVE T1,[BYTE (8)" "," "," "," "] ;GET A WORD OF SPACES
MOVEM T1,SPCWD(D) ;SAVE FOR RECORD FILL
JRST %POPJ1 ;ALL SET
;Error on TAPOP. from a device that we haven't OPENED yet.
; This could be caused by someone else assigning the device
; and we don't have privs to set the functions.
TOPERR: CAIN T0,TPPRV% ;Not enough privs?
JRST TOPERP ;Yes
MOVE T3,T0 ;PUT ERROR CODE IN SAFE AC
; IOERR (UTO,30,,?,Unexpected TAPOP. error $O trying to set $A,<T3,P1>)
$ECALL UTO,%POPJ ;"? Unexpected TAPOP. error.."
;Return to DIALOG if no ERR= taken
TOPERP: MOVEI T1,ERDAJ% ;Pretend it was a FILOP. error
; "Device allocated to another job"
$ECALL OPN,%POPJ ;Give error and return
>;END IF10
;TABLES
IF20,<
DEFINE X (G,F,D) <XWD <(G)>,F> ;XWD GTJFN BITS, ACCESS BITS
>
IF10,<
DEFINE X (G,F,D) <D> ;FILOP FUNCTION
>
FILTAB: X GJ%OFG,0,.FORED ;SEQINOUT
X GJ%OLD,OF%RD,.FORED ;SEQIN
X GJ%FOU,OF%WR,.FOWRT ;SEQOUT
X GJ%OFG,0,.FORED ;SEQINOUT
X GJ%OLD,OF%RD,.FORED ;RANDIN
X 0,OF%RD+OF%WR,.FOSAU ;RANDOM
X 0,OF%APP,.FOAPP ;APPEND
ACCTAB: 0 ;SEQINOUT
0 ;SEQIN
0 ;SEQOUT
0 ;SEQINOUT
D%RAN ;RANDIN
D%RAN ;RANDOM
D%APP ;APPEND
;BYTE SIZE, DATA MODE
BSTAB: 0
^D36 ;IMAGE
^D36 ;BINARY
^D36 ;DUMP
7 ;ASCII 7-BIT
7 ;LINED
8 ;EBCDIC
MODTAB: 0
10 ;IMAGE
14 ;BINARY
17 ;DUMP
0 ;ASCII
0 ;LINED
10 ;EBCDIC
;ROUTINE TO CHECK DATA MODE BEFORE OPENING FILE
%CHKNR:: LOAD T1,DMODE(D) ;GET DATA MODE
MOVEI T2,1 ;GET A BIT
LSH T2,(T1) ;SHIFT INTO POSITION FOR REQUESTED MODE
LOAD T3,LGLM(D) ;GET LEGAL DATA MODES FOR THIS DEVICE
TRNE T2,(T3) ;CHECK THAT DATA MODE IS LEGAL
JRST %POPJ1 ;YES, FINE
LOAD T1,MODE(D) ;GET DATA MODE
MOVEI T2,SWMODE ;POINT TO TABLE
PUSHJ P,FNDSWT ;FIND NAME OF REQUESTED MODE
; IOERR (IDM,30,249,?,/MODE:$Z illegal for this device,<T1>,%POPJ)
$ECALL IDM,%POPJ
SUBTTL SWITCH TABLES
IF20,<
DEFINE X (NAME,VAL) <
XWD [ASCIZ \NAME\],VAL
>
>
IF10,<
DEFINE X (NAME,VAL) <
XWD [SIXBIT \NAME \],VAL
>
>
OPNSWT: XWD LSWT,LSWT+1
X ACCESS:,OK.ACC
X BLANK:,OK.BLNK
X BLOCKSIZE:,OK.BLK
X BUFFERCOUNT:,OK.BFC
X CARRIAGECONTROL:,OK.CC
X DENSITY:,OK.DEN
X DISPOSE:,OK.DISP
X FILESIZE:,OK.FLS
X FORM:,OK.FORM
; X LABELS:,OK.LBL
X MODE:,OK.MOD
X PADCHAR:,OK.PAD
X PARITY:,OK.PAR
X PROTECTION:,OK.PROT
X READONLY,OK.RO
X RECL:,OK.REC
X RECORDSIZE:,OK.REC
X STATUS:,OK.STAT
; X TAPEMODE:,OK.TAPM
X VERSION:,OK.VER
LSWT==.-OPNSWT-1
;Legal DIALOG CLOSE switches
CLSSWT: XWD CSWT,CSWT
X DISPOSE:,OK.DISP
X PROTECTION:,OK.PROT
X STATUS:,OK.STAT
CSWT==.-CLSSWT-1
SWACC: XWD LACC,LACC
X APPEND,AC.APP
X DIRECT,AC.RIO
X RANDIN,AC.RIN
X RANDOM,AC.RIO
X SEQIN,AC.SIN
X SEQINOUT,AC.SIO
X SEQOUT,AC.SOU
X SEQUENTIAL,AC.SIO
LACC==.-SWACC-1
SWBLNK: XWD LBLNK,LBLNK
X NULL,BL.NULL
X ZERO,BL.ZERO
LBLNK==.-SWBLNK-1
SWCC: XWD LCC,LCC
X DEVICE,CC.DEV
X FORTRAN,CC.FORT
X LIST,CC.LIST
LCC==.-SWCC-1
SWDEN: XWD LDEN,LDEN
IF10,< X SYSTEM,DN.SYS >
X 1600,DN.1600
X 200,DN.200
X 556,DN.556
X 6250,DN.6250
X 800,DN.800
IF20,< X SYSTEM,DN.SYS >
LDEN==.-SWDEN-1
;OPEN DISPOSE values
SWDSPO: XWD LDISPO,LDISPO
X DELETE,DS.DEL
X EXPUNGE,DS.EXP
X KEEP,DS.SAVE
X LIST,DS.LIST
X PRINT,DS.PRNT
X PUNCH,DS.PNCH
X SAVE,DS.SAVE
X SUBMIT,DS.SUB
LDISPO==.-SWDSPO-1
;CLOSE dispose values
SWDISC: XWD LDISPC,LDISPC
X DELETE,DS.DEL
X EXPUNGE,DS.EXP
X KEEP,DS.SAVE
X LIST,DS.LIST
X PRINT,DS.PRNT
X PUNCH,DS.PNCH
X RENAME,DS.REN
X SAVE,DS.SAVE
X SUBMIT,DS.SUB
LDISPC==.-SWDISC-1
SWFORM: XWD LFORM,LFORM
X FORMATTED,FM.FORM
X UNFORMATTED,FM.UNF
LFORM==.-SWFORM-1
SWLBL: XWD LLBL,LLBL
X ANSI,LB.ANSI
X DEC,LB.DEC
; X EBCDIC,LB.IBM
X NONE,LB.NONE
LLBL==.-SWLBL-1
SWMODE: XWD LMODE,LMODE
X ASCII,MD.ASC
X BINARY,MD.BIN
IF10,< X DUMP,MD.DMP >
; X EBCDIC,MD.EBC
X IMAGE,MD.IMG
X LINED,MD.ASL
LMODE==.-SWMODE-1
SWPAR: XWD LPAR,LPAR
X EVEN,PR.EVEN
X ODD,PR.ODD
LPAR==.-SWPAR-1
SWRECT: XWD LRECT,LRECT
X FIXED,RT.FIX
X SPANNED,RT.SPN
X VARIABLE,RT.VAR
LRECT==.-SWRECT-1
;OPEN STATUS values
SWSTAT: XWD LSTAT,LSTAT
X DELETE,ST.DISP+DS.DEL
X EXPUNGE,ST.DISP+DS.EXP
X KEEP,ST.DISP+DS.SAVE
X NEW,ST.NEW
X OLD,ST.OLD
X SAVE,ST.DISP+DS.SAVE
X SCRATCH,ST.SCR
X UNKNOWN,ST.UNK
LSTAT==.-SWSTAT-1
;LEGAL STATUS VALUES FOR CLOSE
SWSTTC: XWD LSTTC,LSTTC
X DELETE,ST.DISP+DS.DEL
X EXPUNGE,ST.DISP+DS.EXP
X KEEP,ST.DISP+DS.SAVE
X SAVE,ST.DISP+DS.SAVE
LSTTC==.-SWSTTC-1
;/TAPEMODE
SWTAPM: XWD LTAPM,LTAPM
X ANSI-ASCII,TM.ANS
X COREDUMP,TM.DMP
X INDUSTRY,TM.IND
X SYSTEM,TM.SYS
LTAPM==.-SWTAPM-1
;DISPATCH TABLES FOR OPEN SWITCHES, INDEXED BY SWITCH NUMBER
;
;OPNDSP:
; LH = ROUTINE TO CONVERT PROGRAM-SUPPLIED ARGUMENT TO INTERNAL FORMAT
; RH = ROUTINE TO PARSE DIALOG-MODE ARGUMENT
; OR ADDRESS OF SWITCH-VALUE TABLE IF SWITCH TAKES ASCII KEYWORDS
;
;OPSTOR:
; INSTRUCTION TO STORE SWITCH VALUE IN T2 INTO DDB
OPNDSP: XWD %POPJ, ;(0) IGNORED
XWD OPNDIA, ;(1) DIALOG=
XWD OPNKWD,SWACC ;(2) ACCESS=
XWD OPNDEV, ;(3) DEVICE=
XWD OPNZOK,[DIAINT] ;(4) BUFFER COUNT=
XWD OPNINT,[DIAINT] ;(5) BLOCK SIZE=
XWD OPNFIL, ;(6) FILE NAME=
XWD OPNZOK,[DIAOCT] ;(7) PROTECTION=
XWD OPNDIR, ;(10) DIRECTORY=
XWD OPNINT,[DIAINT] ;(11) LIMIT=
XWD OPNKWD,SWMODE ;(12) MODE=
XWD OPNINT,[DIAINT] ;(13) FILE SIZE=
XWD OPNINT,[DIAINT] ;(14) RECORD SIZE=
XWD OPNKWD,SWDSPO ;(15) DISPOSE=
XWD OPNZOK,[DIAOCT] ;(16) VERSION=
XWD OPNERR, ;(17) REELS=
XWD OPNERR, ;(20) MOUNT=
XWD OPNADR, ;(21) IOSTAT=
XWD OPNADR, ;(22) ASSOCIATE VARIABLE=
XWD OPNKWD,SWPAR ;(23) PARITY=
XWD OPNKWD,SWDEN ;(24) DENSITY=
XWD OPNKWD,SWBLNK ;(25) BLANK=
XWD OPNKWD,SWCC ;(26) CARRIAGE CONTROL=
XWD OPNKWD,SWFORM ;(27) FORM=
XWD OPNKWD,SWLBL ;(30) LABELS=
XWD PADCHR,[DIACHR] ;(31) PADCHAR=
XWD OPNKWD,SWRECT ;(32) RECTYPE=
XWD OPNKWD,SWSTAT ;(33) STATUS=
XWD OPNKWD,SWTAPM ;(34) TAPE MODE=
XWD OPNSET,[DIASET] ;(35) READONLY
XWD OPNUNT, ;(36) UNIT=
XWD OPNADR, ;(37) ERR=
OPNMAX==.-OPNDSP-1
;Switch values (used for error messages)
OPARGN: [ASCIZ/?/] ;(0) IGNORED
[ASCIZ/?/] ;(1) DIALOG (no parsing)
[ASCIZ/ACCESS=/]
[ASCIZ/DEVICE=/]
[ASCIZ/BUFFER COUNT=/]
[ASCIZ/BLOCK SIZE=/]
[ASCIZ/FILENAME=/]
[ASCIZ/PROTECTION=/]
[ASCIZ/DIRECTORY=/]
[ASCIZ/LIMIT=/]
[ASCIZ/MODE=/]
[ASCIZ/FILE SIZE=/]
[ASCIZ/RECORD SIZE=/]
[ASCIZ/DISPOSE=/]
[ASCIZ/VERSION=/]
[ASCIZ/REELS=/]
[ASCIZ/MOUNT=/]
[ASCIZ/?/] ;(21) IOSTAT (no parsing)
[ASCIZ/?/] ;(22) ASSOCIATEVARIABLE (no parsing)
[ASCIZ/PARITY/] ;(23)
[ASCIZ/DENSITY=/] ;(24)
[ASCIZ/BLANK=/] ;(25)
[ASCIZ/CARRIAGE CONTROL=/] ;(26)
[ASCIZ/FORM=/] ;(27)
[ASCIZ/LABELS=/] ;(30)
[ASCIZ/PADCHAR=/]
[ASCIZ/RECTYPE=/]
[ASCIZ/STATUS=/]
[ASCIZ/TAPE MODE=/]
[ASCIZ/?/] ;(35) READONLY (no parsing)
[ASCIZ/?/] ;(36) UNIT (no parsing)
[ASCIZ/?/] ;(37) ERR= (no parsing)
OPMSMX==.-OPARGN-1
;Guard against maintainer errors
IFN <OPNMAX-OPMSMX>,<PRINTX ?OPNMAX .NE. OPMSMX>
;The list for CLOSE
CLSDSP: XWD %POPJ, ;(0) IGNORED
XWD OPNDIA, ;(1) DIALOG
XWD CLIGN,[DIAIGN] ;(2) ACCESS=
XWD OPNDEV, ;(3) DEVICE=
XWD CLIGN,[DIAIGN] ;(4) BUFFERCOUNT
XWD CLIGN,[DIAIGN] ;(5) BLOCKSIZE
XWD OPNFIL, ;(6) FILE NAME=
XWD OPNINT,[DIAOCT] ;(7) PROTECTION
XWD OPNDIR, ;(10) DIRECTORY
XWD CLIGN,[DIAIGN] ;(11) LIMIT
XWD CLIGN,[DIAIGN] ;(12) MODE
XWD CLIGN,[DIAIGN] ;(13) FILESIZE
XWD CLIGN,[DIAIGN] ;(14) RECORDSIZE
XWD CLSKWD,SWDISC ;(15) DISPOSE
XWD CLIGN,[DIAIGN] ;(16) VERSION
XWD OPNERR, ;(17) REELS
XWD OPNERR, ;(20) MOUNT
XWD OPNADR, ;(21) IOSTAT
XWD OPNADR, ;(22) ASSOCIATEVARIABLE
XWD CLIGN,[DIAIGN] ;(23) PARITY
XWD CLIGN,[DIAIGN] ;(24) DENSITY
XWD CLIGN,[DIAIGN] ;(25) BLANK
XWD CLIGN,[DIAIGN] ;(26) CARRIAGECONTROL
XWD CLIGN,[DIAIGN] ;(27) FORM
XWD CLIGN,[DIAIGN] ;(30) LABELS
XWD CLIGN,[DIAIGN] ;(31) PADCHAR
XWD CLIGN,[DIAIGN] ;(32) RECTYPE
XWD CLSKWD,SWSTTC ;(33) STATUS
XWD CLIGN,[DIAIGN] ;(34) TAPEMODE
XWD CLIGN,[DIAIGN] ;(35) READONLY
XWD OPNUNT, ;(36) UNIT=
XWD OPNADR, ;(37) ERR=
CLSMAX==.-CLSDSP-1
;Guard against maintainer errors
IFN <OPNMAX-CLSMAX>,<PRINTX ?OPNMAX .NE. CLSMAX>
OPSTOR: $SNH ;(0)
$SNH ;(1) DIALOG=
STORE T2,ACC(D) ;(2) ACCESS=
$SNH ;(3) DEVICE=
STORE T2,BUFCT(D) ;(4) BUFFER COUNT=
STORE T2,BLKSZ(D) ;(5) BLOCK SIZE=
$SNH ;(6) FILE=
PUSHJ P,SETPROT ;(7) PROTECTION=
$SNH ;(10) DIRECTORY=
STORE T2,LIM(D) ;(11) LIMIT=
STORE T2,MODE(D) ;(12) MODE=
MOVEM T2,EST(D) ;(13) FILE SIZE=
MOVEM T2,RSIZE(D) ;(14) RECORD SIZE=
STORE T2,DISP(D) ;(15) DISPOSE=
MOVEM T2,VERN(D) ;(16) VERSION=
$SNH ;(17) REELS=
$SNH ;(20) MOUNT=
MOVEM T2,A.IOS ;(21) IOSTAT=
MOVEM T2,AVAR(D) ;(22) ASSOCIATE VARIABLE=
STORE T2,PAR(D) ;(23) PARITY=
STORE T2,DEN(D) ;(24) DENSITY=
STORE T2,BLNK(U) ;(25) BLANK=
STORE T2,CC(U) ;(26) CARRIAGE CONTROL=
STORE T2,FORM(D) ;(27) FORM=
STORE T2,LBL(D) ;(30) LABELS=
STORE T2,PADCH(U) ;(31) PADCHAR=
STORE T2,RECFM(D) ;(32) RECTYPE=
STORE T2,STAT(D) ;(33) STATUS=
STORE T2,TAPM(D) ;(34) TAPE MODE=
STORE T2,RO(D) ;(35) READONLY
STORE T2,UNUM(U) ;(36) UNIT=
MOVEM T2,A.ERR ;(37) ERR=
;DEFAULT DEVICE TABLE
[ASCIZ /PLOT/] ;-7
[ASCIZ /REREAD/] ;-6
[ASCIZ /READ/] ;-5: CDR
[ASCIZ /ACCEPT/] ;-4
[ASCIZ /PRINT/] ;-3
[ASCIZ /PUNCH/] ;-2
[ASCIZ /TYPE/] ;-1
%UNNAM=.
IF10,<DEFINE X (A) <EXP SIXBIT /A/>>
IF20,<DEFINE X (A) <EXP ASCII /A/>>
X PLT ;-7 FOR USE BY FORPLT
X REREAD ;-6 REREAD
X CDR ;-5 READ
X TTY ;-4 ACCEPT
X LPT ;-3 PRINT
X PTP ;-2 PUNCH
X TTY ;-1 TYPE
DEVTAB:
IFE FTDSK,<
X DSK ;00 DISK
X DSK ;01 DISK
X CDR ;02 CARD READER
X LPT ;03 LINE PRINTER
X CTY ;04 CONSOLE TELETYPE
X TTY ;05 USER'S TELETYPE
X PTR ;06 PAPER TAPE READER
X PTP ;07 PAPER TAPE PUNCH
X DIS ;08 DISPLAY
X DTA1 ;09 DECTAPE
X DTA2 ;10
X DTA3 ;11
X DTA4 ;12
X DTA5 ;13
X DTA6 ;14
X DTA7 ;15
X MTA0 ;16 MAG TAPE
X MTA1 ;17
X MTA2 ;18
X FORTR ;19
X DSK ;20
X DSK ;21
X DSK ;22
X DSK ;23
X DSK ;24
X DEV1 ;25 ASSIGNABLE DEVICES
X DEV2 ;26
X DEV3 ;27
X DEV4 ;28
X DEV5 ;29
>
MAXDEV==.-DEVTAB ;MAXDEV & UP DISK
SUBTTL DDB CONSOLIDATION ROUTINES
;Routine to mark DDB for consolidation if the device is the
; same. If there is an error, the program is aborted.
;Called for all generic OPEN's.
MARKCS: MOVEI T1,1 ;Set use count to 1
MOVEM T1,USCNT(D) ; (Probably won't be consolidated)
LOAD T1,DVTYP(D) ;Get device type
IF10, CAIN T1,.TYDSK ;DSK: doesn't get consolidated
IF20,<
CAIE T1,.DVNUL ;NUL: doesn't get consolidated
CAIN T1,.DVDSK ;DSK: doesn't get consolidated
>;END IF20
POPJ P, ; Return; not consolidated
;See if we can find another DDB with same device.
MOVE T1,DVICE(D) ;Get device info to compare
MOVE T2,[MINUNIT-MAXUNIT-1,,MINUNIT] ;Loop thru all units
MRKSC1: MOVE T3,%DDBTAB(T2) ;Get a unit block address
JUMPE T3,MRKSC2 ;None, skip
MOVE T4,DDBAD(T3) ;Get DDB addr.
CAMN T1,DVICE(T4) ;Same device?
JRST MRKSCS ;Yes
MRKSC2: AOBJN T2,MRKSC1 ;Not the same, loop
POPJ P, ;This device not used yet, no consolidation
MRKSCS: CAMN U,T3 ;Same unit?
JRST MRKSC2 ;Yes, skip it
;We found the device in another DDB
;T3= new unit address
;T4= DDB address for it
MOVEM T3,CNSUNT ;Save unit address
PUSHJ P,CNSCHK ;Make sure something isn't incompatible
; (if so, take ERR= or abort)
MOVE T3,CNSUNT ;T3= address of unit to consolidate
MOVE T2,DDBAD(T3) ;T2= DDB address of it
MOVE T1,FLAGS(T2) ;Get DDB flags
TXNE T1,D%IN+D%OUT ;OPEN already?
JRST MRKCNS ;Yes, consolidate now
;Can't really consolidate yet (since an OPEN failure might get us to DIALOG
; mode where the guy might change some DDB parameters, including the
; device). So we have to "mark" the DDB for consolidation, which will
; happen for all unopened DDB's when any one of them is really OPENed.
;This is done by inserting this DDB in a doublyinked list.
;T3= unit address
LOAD T1,CNSL1(T3) ;See if any consolidated yet..
JUMPE T1,NOTCYT ;No
STORE U,CNSL1(T3) ;Store new "next" link in old previous
; unit block
STORE T3,CNSL2(U) ;Store new "previous" link in added unit block
STORE T1,CNSL1(U) ;Store new "next" link in added unit block
STORE U,CNSL2(T1) ;Store new "previous" link in old next
; unit block
POPJ P, ;Return
;Set up initial doubly-linked list (two items in it)
;Next and previous links are the same for each item - they just point
;to the other one.
NOTCYT: STORE T3,CNSL1(U)
STORE T3,CNSL2(U)
STORE U,CNSL1(T3)
STORE U,CNSL2(T3)
POPJ P, ;Linked to each other
;The device is already OPEN on another DDB
MRKCNS: MOVEI T1,(D) ;Throw away this DDB
PUSHJ P,%FREBLK
MOVE T1,CNSUNT ;Get unit address that points to common DDB
MOVE D,DDBAD(T1) ;Get DDB
AOS USCNT(D) ;Increment use count
PJRST FIXU ;Fixup "U" and return.
SEGMENT DATA
CNSUNT: BLOCK 1 ;Address of the unit that might point
SEGMENT CODE
;DOCONS: Routine to do consolidation of DDB's (when an OPEN was successful)
; If any DDB's are linked in the "consolidation" chain (waiting for
; one of the units to actually get "OPEN'ed"), they are thrown away
; and the use count of the one that is opened reflects the number
; that are attached.
; This routine returns .+1 always.
DOCONS: LOAD T1,CNSL1(U) ;Get "next" unit in chain, if any
JUMPE T1,%POPJ ;Return if none -- nothing to do.
PUSHJ P,%SAVE2 ;Free up a perm ac
SETZ P2, ;P2= permanently zero ac.
MOVE P1,T1 ;Get unit block address
;P1= address of unit block to consolidate with this one
DOCNS1: MOVE T1,DDBAD(P1) ;Throw away it's DDB
PUSHJ P,%FREBLK
MOVEM D,DDBAD(P1) ;Store consolidated DDB address
AOS USCNT(D) ;Increment use count
PUSH P,U ;Save "u"
MOVE U,P1 ;Get unit to setup
PUSHJ P,FIXU ;Fixup the unit block (OPENED)
POP P,U ;Restore "u"
LOAD T1,CNSL1(P1) ;Get "next" unit in chain
CAMN T1,U ;Wrapped around to beginning?
JRST DOCNS2 ;Yes
STORE P2,CNSL1(P1) ;Clear the links..
STORE P2,CNSL2(P1) ; . .
MOVE P1,T1 ;P1= next unit
JRST DOCNS1 ;Loop
;Clear links in the current unit block also.
DOCNS2: STORE P2,CNSL1(U)
STORE P2,CNSL2(U)
POPJ P, ;Return
;Routine to see if we can successfully consolidate a DDB.
; The parameters must match in the DDB.
;If they don't, the program takes ERR= branch or is aborted.
;Call:
; CNSUNT/ address of unit that points to DDB to check
; D/ current (set-up) DDB
; PUSHJ P,CNSCHK
; <return here if ok>
;
CNSCHK: MOVE T1,CNSUNT ;Point to unit block
HXRE T2,UNUM(T1) ;T2= unit number for error message [3111]
MOVE T1,DDBAD(T1) ;T1= DDB address to check
LOAD T3,MODE(T1) ;Get old mode
LOAD T4,MODE(D) ;Get new mode
JUMPE T4,%POPJ ;NOT SET UP IS OK
CAME T3,T4 ;The same?
$ECALL SDO,%ABORT ;?No, give error
POPJ P, ;Return
;Routine to clear consolidation pointers for this DDB (if any).
;If a DDB has consolidation pointers, it is because there
; are other DDB's that refer to the same device, although they
; have not yet been OPEN'ed.
CLRCNS: LOAD T1,CNSL1(U) ;Get "next" link
JUMPE T1,%POPJ ;Return if none
LOAD T2,CNSL2(U) ;Get "previous" link
SETZ T3, ;Get a clear ac
CAMN T1,T2 ;The same? (just two unit blocks in link)
JRST CLRCN1 ;Yes, delete all ptrs.
STORE T1,CNSL1(T2) ;Store new "next" link in old previous
STORE T2,CNSL2(T1) ;Store new "previous" link in old next
JRST CLRCN2 ;Delete links of this DDB
;Delete all ptrs.
CLRCN1: STORE T3,CNSL1(T1)
STORE T3,CNSL2(T1)
;Delete ptrs in this unit block.
CLRCN2: STORE T3,CNSL1(U)
STORE T3,CNSL2(U)
POPJ P, ;Return
SUBTTL CLOSE
FENTRY (CLOSE)
PUSHJ P,%SAVAC ;SAVE USER'S ACS
PUSHJ P,%CPARG ;AND COPY ARGS
SETZM EFSFLG ;FLAG FOR [ENTER CORRECT FILE SPECS]
SETZM FILSAG ;CLEAR FILE=STRING
SETZM DIASAG ;CLEAR DIALOG=STRING
XMOVEI T1,[ASCIZ /CLOSE/] ;SET STATEMENT NAME FOR ERR MESSAGES
MOVEM T1,%IONAM
PUSHJ P,CLSCNV ;CONVERT OLD ARG BLOCK FORMAT
;Get %CUNIT= unit #, A.ERR= "ERR=" address, A.IOS= "IOSTAT=" address
RCONT: PUSHJ P,FNDAGL ;Find UNIT=, ERR=, IOSTAT=
;If no UNIT= given, gets abortive error.
PUSHJ P,UNRNGE ;Check for unit out of range
; Only return if in range, unit # in T2.
SKIPE T1,A.IOS ;Any IOSTAT variable?
SETZM (T1) ;Yes, initialize to zero
MOVE T2,%CUNIT ;GET THE UNIT
MOVE P1,%DDBTAB(T2) ;Get ptr to unit block
MOVEM P1,%UDBAD ;SAVE OLD UDB ADDRESS FOR MSGS
JUMPE P1,%POPJ ; If not open, this is a no-op
;Close an opened unit
MOVE P2,DDBAD(P1) ;P2= ptr to old DDB
MOVEI T1,ULEN ;Allocate a blank unit
PUSHJ P,%GTBLK
MOVE U,T1
MOVEI T1,DLEN ; and DDB
PUSHJ P,%GTBLK
MOVE D,T1
MOVEM D,DDBAD(U) ;SAVE IN UDB
PUSHJ P,COPFDD ;Copy file-spec info from old DDB
;D and U are pointers to blocks that get the arg-list info.
; The real unit block pointer and DDB pointer are in P1 and P2.
MOVEM D,RENAMD ;Save here incase of errors
MOVEM U,RENAMU ; (ERR routine will deallocate them)
TXO F,F%CLS ;NOW IN CLOSE
PUSH P,P1 ;STACK-1 = Unit block
PUSH P,P2 ;STACK-0 = DDB block
PUSHJ P,CLSARG ;MOVE ARGS TO DDB
; (possibly take ERR= branch)
SKIPE FILSAG ;FILE=STRING SEEN?
PUSHJ P,FILSTR ;YES. PROCESS IT
SKIPE DIASAG ;DIALOG=STRING SEEN?
PUSHJ P,DLGSTR ;Yes, do it
;(possibly take ERR= branch)
TXZ F,F%INDST ;Clear flags
JRST CLOS.1 ;Go to main CLOSE code.
;Here with:
; STACK-0 = old DDB block
; STACK-1 = old Unit block
; D = new DDB block
; U = new Unit block
;Final CLOSE statement processing is done here, then
; we "PJRST" off to %CLOSX (the generic CLOSE routine).
CLOS.1: PUSHJ P,CHKDLG ;Do DIALOG mode if necessary
DMOVE P1,-1(P) ;P1= old unit block, P2= OLD DDB
PUSHJ P,CKCARG ;Check CLOSE args for problems,
; issue errors and warnings
TXNE F,F%DRE ;Might have to go to dialog mode again
JRST CLOS.1 ; (user has to fix stuff)
TXNE F,F%FSS!F%DSS ;Dispose='rename' to be done?
JRST CLOS.2 ;Yes, the dummy blocks hold
; the new filespec info- don't deallocate
MOVEI T1,(D) ;Deallocate the dummy DDB and unit blocks
PUSHJ P,%FREBLK ;. .
MOVEI T1,(U) ; . .
PUSHJ P,%FREBLK
SETZM RENAMD
SETZM RENAMU ;Clear ptrs
CLOS.2: POP P,D ;Re-get unit and DDB block ptrs.
POP P,U
PJRST CLOSE1 ;Go close an opened unit and return
SUBTTL %CLOSX: GENERIC CLOSE ROUTINE
;Routine to close an opened unit
;Call:
; D/ ptr to DDB block
; U/ ptr to unit block
;
; If F%FSS!F%DSS is set, then RENAMD and RENAMU contain ptrs to
;the D and U block that holds a new filespec to RENAME to.
; Note: This is called from %ABORT and %EXIT-- flags
;F%FSS and F%DSS must be OFF.
;
; ERR= and IOSTAT= args must have been put in the unit block (U).
;
%CLOSX: MOVE T1,FLAGS(D) ;Get DDB flags
TXOE T1,D%NCLS ;Did a CLOSE error happen before?
POPJ P, ;Yes, forget it
MOVEM T1,FLAGS(D) ;Set the flag incase an error happens
; But if it's a RENAME error, the flag
;should be turned off.
MOVEM U,%UDBAD ;TELL ERROR HANDLER WE HAVE A DDB
LOAD T1,DISP(D) ;Get /DISPOSE to set
MOVEM T1,DSPV
;Entry from CLOSE statement
;DSPV has been set.
CLOSE1: PUSHJ P,%SAVE2 ;Free up P1 and P2
;We have to open the file if an explicit OPEN statement
; has been done.
MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%IN!D%OUT ;Was file ever opened?
JRST CLSITA ;Yes
SKIPN %ABFLG ;ABORTING?
TXNN T1,D%OPEN ;Was explicit OPEN done?
JRST CLOSNO ;NO. JUST DO CLEANUP
;File must be opened since an explicit OPEN was done.
; If file exists, open for input.
;Else create a null file and open for input.
LOAD T1,INDX(D) ;What type of device?
CAIN T1,DI.DSK
JRST CLSITY ;Yes, must do this.
IF10,<
LOAD T1,DVTYP(D) ;Not disk, but for DECtape have to do it too
CAIN T1,.TYDTA ;DECTAPE?
JRST CLSITY ;Yes, must do it.
>
CLOSNO: PJRST CLSCLN ;Cleanup after CLOSE (core, etc.)
;Here if file is on Disk or DECtape, and
;an OPEN was done but the file is not open now.
;Actually get the file opened.
; Note; No worry about sharing DDB's.
;The ACCESS must be SEQINOUT and the STATUS must be UNKNOWN (else
; the file would have been opened at the OPEN statement!)
;If file already exists, open for input.
;Else open for output.
CLSITY: PUSHJ P,CLOPNK ;Do the CLOSE-OPEN kludge
JRST CSTYDL ;?Failed, go into DIALOG mode
MOVE T1,FLAGS(D) ;Get DDB flags
TXNN T1,D%IN!D%OUT ;Was file ever opened?
POPJ P, ;NO
JRST CLSITA ;Go on
;Have to go into DIALOG mode because OPEN failed.
; (how ironic!)
CSTYDL: PUSH P,F ;Save flags
TXZ F,F%CLS ;Forget we are in CLOSE
PUSHJ P,OPENX ;Go do the default OPEN
TXO F,F%CLS ;Back to being in CLOSE
POP P,T1 ;Get back old flags
TXZ F,F%DSS!F%FSS ;Clear "filespec info seen"
TXNE T1,F%DSS ; Set them again
TXO F,F%DSS ;If they were set at CLOSE
TXNE T1,F%FSS
TXO F,F%FSS
JRST CLOSE1 ;Go back and try again
;Here when file is open, to close it.
CLSITA: MOVE T1,USCNT(D) ;GET DDB USE COUNT
CAILE T1,1 ;MORE THAN 1?
JRST XCLSDN ;YES. DON'T DO ANYTHING NOW!
LOAD T1,INDX(D) ;GET DEV INDEX
LOAD T0,ACC(D) ;GET ACCESS
CAIE T0,AC.APP ;APPEND?
CAIE T1,DI.DSK ;DISK?
JRST OTHCLS ;APPEND OR NON-DISK
PUSHJ P,DSKCLS ;Write out changed pages, throw away WTAB info.
JRST XCLSDN ;SKIP NON-DISK STUFF
OTHCLS: CAIE T1,DI.TTY ;TTY?
JRST XXXCLS ;NO. OTHER DEVICE
LOAD T1,CC(U) ;GET CARRIAGECONTROL
CAIE T1,CC.FORT ;FORTRAN?
JRST XCLSDN ;NO. SKIP OTHER NON-DISK STUFF
MOVE T1,FLAGS(D) ;GET FLAGS
TXNN T1,D%SEOL ;SUPPRESS CR/LF?
PUSHJ P,%OCRLF ;NO. OUTPUT ENDING CRLF
JRST XCLSDN ;SKIP OTHER NON-DISK STUFF
XXXCLS: MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%OUT ;Was file open for output?
PUSHJ P,%LSTBF ;YES. GO WRITE LAST BUFFER
XCLSDN: LOAD T1,UNUM(U) ;Get unit number
HRRE T1,T1 ;Negative or positive, get full word value
MOVE T2,[RRUNIT] ;GET FLAG FOR NO REREAD UNIT
CAMN T1,U.RERD ;Is it the last successful READ unit?
MOVEM T2,U.RERD ;Yes, save flag so REREAD fails.
TXNN F,F%FSS!F%DSS ;Implied DISPOSE='RENAME'?
JRST XCLSDS ;No, go finish CLOSE
PUSHJ P,CLREN ;Yes, rename it
JRST CLGDLG ;Error, go to DIALOG mode
TXZ F,F%FSS!F%DSS ;Clear flags
XCLSDS: MOVE T1,DSPV ;[3230] Get value of /DISPOSE to do
CAIL T1,DS.QUEUE ;DOES IT IMPLY QUEUEING?
MOVEI T1,DS.QUEUE ;YES
PUSHJ P,@CLSDIS(T1) ;DISPOSE OF FILE SOMEHOW
JRST CLGDLG ;Error, go to DIALOG mode
PJRST CLSCLN ;Cleanup and return
;Note: For files where a DDB is shared by more than 1 unit block,
; the only possible value is "SAVE".
CLSDIS: IFIW E.SNH ;0--?DSPV must be set
IFIW CLSAVE ;SAVE
IFIW CLDEL ;DELETE
IFIW CLEXP ;EXPUNGE
IFIW E.SNH ;RENAME (?can't get here)
IFIW CLSQ ;ALL OTHERS MEAN QUEUE
;Come here to go into DIALOG for CLOSE.
;IOERR has been given, but ERR= branch was not taken.
CLGDLG: PUSHJ P,CLSDLG ;Prepare for CLOSE dialog
; (Get D and U pointing to the New blocks,
; P1 AND P2 are the old blocks).
CLGDLA: PUSHJ P,CHKDLG ;Go do it
PUSHJ P,CKCARG ;Check CLOSE args for problems,
; issue errors and warnings
TXNE F,F%DRE ;Might have to go to dialog mode again
JRST CLGDLA ; ..
TXNE F,F%FSS!F%DSS ;Filespec given?
JRST CLGDL1 ;Yes, have to store new blocks.
MOVEI T1,(D) ;Deallocate the dummy blocks
PUSHJ P,%FREBLK
MOVEI T1,(U)
PUSHJ P,%FREBLK
MOVE U,P1 ;U= old unit block
MOVE D,P2 ;D= old DDB block
SETZM RENAMD
SETZM RENAMU ;No alternate blocks
JRST CLGDL2 ;Continue
;Here if filespec info given. (Implied RENAME)
CLGDL1: MOVEM D,RENAMD ;Save RENAME info
MOVEM U,RENAMU ; .. away
MOVE U,P1 ;Reget old block ptrs
MOVE D,P2
CLGDL2: MOVX T1,D%NCLS ;Set the error flag again (it could
; have been turned off by CLREN).
IORM T1,FLAGS(D) ;(So any real CLOSE error will not
; cause a loop with %ABORT).
JRST CLSITA ;Go restart generic CLOSE routine
;Routine to clean up after CLOSE (successfully) done.
; Throws away core not used, DDB and unit blocks.
CLSCLN: CAMN U,U.ERR ;ERROR MESSAGE UNIT?
SETZM U.ERR ;YES, NO MORE ERR MESSAGE UNIT
PUSHJ P,CLRCNS ;Clear consolidation ptrs if any
; (for un-opened units on same device)
SOSGE T1,USCNT(D) ;This DDB no longer in use
$SNH ;??USE count went negative
JUMPN T1,CLSCL1 ;DDB still in use, don't deallocate it
CAME D,D.TTY ;Is this the TTY DDB?
JRST NOTETT ;NO
SETZM D.TTY ;Yes, no more.
SETZM U.TTY ;CLEAR UNIT BLOCK ADDR ALSO
NOTETT: HRRZ T1,IRBUF(D) ;GET INPUT REC ADDR-1
JUMPE T1,NOIRB ;NONE
ADDI T1,1 ;CORRECT IT
PUSHJ P,%FREBLK ;DEALLOCATE BUFFER
NOIRB: HRRZ T1,ORBUF(D) ;GET OUTPUT REC ADDR-1
JUMPE T1,NOORB ;NONE
ADDI T1,1 ;CORRECT IT
PUSHJ P,%FREBLK ;DEALLOCATE BUFFER
NOORB: SKIPE T1,WADR(D) ;ANY BUFFER TO DEALLOCATE?
PUSHJ P,%FREBLK ;YES. DO IT
SETZM WADR(D) ;Clear core pointer
IF10,<
HRRZ T1,FBLK(D) ;GET FILOP FUNCTION
JUMPE T1,NDECHN ;IF NOT SET, CHANNEL WAS NEVER ALLOCATED
LDB T1,[POINTR CHAN(D),FO.CHN] ;GET CHANNEL NUMBER
CAIG T1,17 ;IF NONEXTENDED,
PUSHJ P,DECHN ;DEALLOCATE IT
NDECHN:
> ;IF10
MOVEI T1,(D) ;Throw away DDB
PUSHJ P,%FREBLK
JRST CLSCL2
;Here if DDB is in use by another unit.
CLSCL1: MOVX T1,D%NCLS ;Turn off error flag
ANDCAM T1,FLAGS(D)
;Unit is now closed. Throw away the unit block and ptr in DDBTAB.
CLSCL2: HXRE T2,UNUM(U) ;Get unit number
SETZM %DDBTAB(T2) ;Clear entry in DDBTAB
MOVEI T1,(U) ;Throw away unit block
PUSHJ P,%FREBLK
SETZM %UDBAD ;NO MORE DDB FOR THIS STATEMENT
POPJ P, ;Return
;Routine to get ready for dialog mode in CLOSE statement.
; This routine saves the old DDB and unit block addresses
; in P1 and P2, respectively, and sets D and U pointing to dummy
; blocks (to get the args from DIALOG mode).
;
;If DISPOSE='RENAME' was set, use the blocks we kept around to hold
; the filespecs.
;Else
; Allocate new blocks.
CLSDLG: MOVE P1,U ;Set P1, P2 to OPEN blocks
MOVE P2,D
TXNE F,F%FSS!F%DSS ;Rename DDB blocks setup?
JRST CLSDL1 ;Yes, use them
MOVEI T1,ULEN ;No, allocate new ones
PUSHJ P,%GTBLK
MOVE U,T1
MOVEI T1,DLEN
PUSHJ P,%GTBLK
MOVE D,T1
PJRST COPFDD ;Copy filespec info from old DDB
; and return
;Come here if we can use those old blocks
; we kept around for the RENAME info.
CLSDL1: MOVE D,RENAMD ;Use same blocks we kept around
MOVE U,RENAMU
SETZM RENAMD ;Clear ptrs
SETZM RENAMU
POPJ P, ;Return
;TOPS-10 routine to OPEN a file in the CLOSE statement.
; This makes sure that the file gets created if it does not exist.
;Return:
; .+1 if error happened, no flags set.
; .+2 if ok, with either D%IN or D%OUT set.
;only called if device is DSK or DTA.
IF10,<
CLOPNK: SETZ T1, ;Don't care whether D%IN or D%OUT set.
PUSHJ P,DOOPEN ; Open file for input
POPJ P, ;?Failed, go into DIALOG
JRST %POPJ1 ;Worked, return success
>
;TOPS-20 routine to OPEN a file in the CLOSE statement.
; This makes sure that the file gets created if it does not exist.
;Only called if device is DSK.
IF20,<
CLOPNK: LOAD T1,INDX(D) ;Get device index
CAIE T1,DI.DSK ;Don't do it unless disk
JRST %POPJ1
LOAD T2,IJFN(D) ;Get JFN
SKIPE T2 ;Skip if any..
PUSHJ P,DOJFNS ;Get info in file block
PUSHJ P,SETJFN ;Get JFN
MOVX T1,GJ%NEW ;Get a new JFN
HLLM T1,JFNBLK+.GJGEN
MOVEI T1,JFNBLK ;Get a JFN
MOVEI T2,[0]
GTJFN%
ERJMP CLOPK2 ;Already exists, go open for input
MOVX T2,D%OUT ;Set this flag if all goes well
CLOPK1: MOVEM T2,SVCLKB ;Save bits
STORE T1,IJFN(D)
STORE T1,OJFN(D) ;Store away JFN
MOVX T1,D%RJN ;"Got a real JFN now"
IORM T1,FLAGS(D) ; Set the flag in the DDB
PUSHJ P,GMODBY ;Get DMABS
PUSHJ P,%CHKNR ;Check data mode
POPJ P, ;?illegal, go have dialog
LOAD T1,IJFN(D) ;Get JFN again
MOVX T2,OF%WR ;Assume he wants WRITE access
MOVE T3,SVCLKB ;Get bits
TXNE T3,D%IN ;Want to open for input?
MOVX T2,OF%RD ;Yes, set READ access
OR T2,DMABS(D) ;Set data mode, byte size
OPENF% ;Get file opened
ERJMP OPFERR ;Failed, give error
MOVE T1,SVCLKB ;Set "File opened" for either input or output
IORM T1,FLAGS(D) ; in the DDB
JRST %POPJ1 ;Return success
CLOPK2: CAIE T1,GJFX27 ;"File already exists"?
JRST GJERR ;No, bad error
MOVX T1,GJ%OLD ;Try old file this time
HLLM T1,JFNBLK
MOVEI T1,JFNBLK
MOVEI T2,[0]
GTJFN%
ERJMP GJERR ;?Failed
MOVX T2,D%IN ;Set "FILE OPENED FOR INPUT" if successful
JRST CLOPK1
SEGMENT DATA
SVCLKB: BLOCK 1 ;D%IN or D%OUT
SEGMENT CODE
>;END IF20
;Routine to copy filespec info from old DDB to new one.
; (as defaults for DIALOG, etc.)
;Inputs:
; P1 & P2/ old unit & DDB blocks
; U & D/ new unit & DDB blocks
;Call:
; PUSHJ P,COPFDD
; <return here always>
COPFDD: LOAD T1,INDX(P2) ;Device index is copied
STORE T1,INDX(D)
LOAD T1,UNUM(P1) ;Unit number is copied
STORE T1,UNUM(U)
IF20,<
HRLI T1,DEV(P2) ;Copy a bunch of stuff
HRRI T1,DEV(D)
BLT T1,DEV+.FSSLN-1(D) ;. .
>
IF10,<
LOAD T1,DVTYP(P2) ;Device-type code
STORE T1,DVTYP(D)
MOVE T1,DEV(P2) ;Device name
MOVEM T1,DEV(D)
MOVE T1,FILE(P2) ;Filename
MOVEM T1,FILE(D)
HLLZ T1,EXT(P2) ;Extension
HLLM T1,EXT(D)
HRLI T1,PTHB(P2) ;Path
HRRI T1,PTHB(D)
BLT T1,PTHB+^D9-1(D)
LDB T1,[POINTR (PROT(P2),RB.PRV)] ;Protection
DPB T1,[POINTR (PROT(D),RB.PRV)]
>;end IF10
POPJ P, ;Return
;Reconcile CLOSE args with the OPEN unit info.
; Errors and warnings are issued (possibly ERR= branch taken).
;If DISPOSE='RENAME', the new filespec is remembered.
; Possibly set F%DRE to get him to DIALOG mode.
;Inputs:
; p1 and p2 point to old unit and DDB blocks
; U and D point to new ones.
; PUSHJ P,CKCARG
; <return here> (or take ERR=).
CKCARG: PUSHJ P,DFDEV1 ;Get device info, skip if ok
POPJ P, ;No, error
PUSHJ P,CKCCNF ;Check CLOSE arg conflicts
POPJ P, ;Error, return immediately
PUSHJ P,CKDPSR ;Check DISPOSE='RENAME'
; Remembers filespec if necessary.
PJRST SETCDS ;Set disposition of file and return
; (could get error)
;Routine to check for CLOSE arg conflicts
; and issue errors and warnings.
;Returns .+2 if no problems,
; else returns .+1 with F%DRE set (unless ERR= taken)
CKCCNF: LOAD T1,STAT(D) ;Get STATUS
JUMPE T1,CKCCN1 ; If not specified, no conflict
LOAD T2,DISP(D) ;Get DISPOSE
JUMPE T2,CKCCN1 ; If not specified, no conflict
CAILE T2,DS.EXP ;[3230] Is DISPOSE = to RENAME, PRINT
JRST CKCCN1 ;[3230] LIST or PUNCH?
SUBI T1,ST.DISP ;Get /DISPOSE value
SKIPG T1 ;Better be positive
$SNH ;?OOPS what's this??
CAMN T1,T2 ;Does it match?
CKCCN1: JRST %POPJ1 ;Yes, no conflict
CKCCN2: PUSH P,T2 ;Save DISPOSE value
IF20,< XMOVEI T3,[ASCIZ/STATUS:/] > ; [3214]
IF10,< XMOVEI T3,[SIXBIT/STATUS:/] > ; [3214]
MOVEM T3,%OPNK1 ;Save string address of first switch
IF20,< XMOVEI T3,[ASCIZ/DISPOSE:/] > ; [3214]
IF10,< XMOVEI T3,[SIXBIT/DISPOSE:/] > ; [3214]
MOVEM T3,%OPNK2 ; and string address of second switch
MOVEI T3,OK.DISP ;Look in DISPOSE table for switch values
HRRZ T2,CLSDSP(T3)
PUSH P,T2 ;Save address of switch table
PUSHJ P,FNDSWT ;Find STATUS value
MOVEM T1,%OPNV1 ;Save it
POP P,T2 ;Get addr of switch table
POP P,T1 ;Get DISPOSE value
PUSHJ P,FNDSWT ;Find DISPOSE keyword
MOVEM T1,%OPNV2 ;Save for error
$ECALL ICA,REQDIA ;?Incompatible attributes
;Routine to set disposition of file
; Possibly ERR= taken.
SETCDS: LOAD T1,DISP(P2) ;T1:= OPEN DISPOSE value
MOVEM T1,DSPV ;Use that if nothing else specified
LOAD T1,DISP(D) ;T1:= Get new DISPOSE value
; Cannot be "RENAME"
JUMPN T1,COPDSP ;[3230] Jump if something specified
LOAD T1,STAT(D) ;No, get status
JUMPE T1,COPDSP ;[3230] If that also isn't specified, forget it
SUBI T1,ST.DISP ;Get DS.xxx value
;Copy disposition (if specified)
;T1= DISPOSITION specified in CLOSE.
;[3230] Here the disposition specification is checked.
;[3230] If DISPOSE='PRINT' and STATUS='DELETE' or 'EXPUNGE',
;[3230] the disposition will be changed to LIST.
;[3230] If DISPOSE='LIST' and STATUS='SAVE', the disposition
;[3230] will be changed to PRINT.
COPDSP: LOAD T3,STAT(P2) ;Get OPEN STATUS value
JUMPE T1,COPDS1 ;Jump if no disposition specified
PUSHJ P,DISPCK ;Check disposition conflict with device
LOAD T2,STAT(D) ;[3230] Get CLOSE STATUS
SKIPE T2 ;[3230] If not specified skip
SUBI T2,ST.DISP ;[3230] Get DS.xxx value
MOVEM T1,DSPV ;Store dispose value
CAIN T3,ST.SCR ;STATUS='SCRATCH'?
JRST SCRCK ;[3230] Yes
CAIN T1,DS.PRNT ;[3230] Does DISPOSE='PRINT'?
JRST PRNTCK ;[3230] Yes
CAIE T1,DS.LIST ;[3230] Does DISPOSE='LIST'?
POPJ P, ;[3230] No
MOVEI T1,DS.PRNT ;[3230] Yes
CAIN T2,DS.SAVE ;[3230] Check for STATUS='SAVE'
MOVEM T1,DSPV ;[3230] Don't delete file after print
POPJ P, ;[3230] Return
PRNTCK: MOVEI T1,DS.LIST ;[3230] Set up for changing to LIST
CAIE T2,DS.DEL ;[3230] Does STATUS='DELETE'?
CAIN T2,DS.EXP ;[3230] Does STATUS='EXPUNGE'?
MOVEM T1,DSPV ;[3230] Yes, delete file after printing
POPJ P, ;[3230] Return
SCRCK: CAIE T1,DS.SAVE ;[3230] Does STATUS or DISPOSE ='SAVE'
CAIN T2,DS.SAVE ;[3230]
JRST SAVSCR ;[3230] Yes, set up to save scratch file
CAIE T1,DS.PRNT ;[3230] Does DISPOSE='PRINT'?
POPJ P, ;[3230] Return
SCRCK1: MOVEI T3,DS.LIST ;[3230]
MOVEM T3,DSPV ;[3230] Yes, delete file after printing
POPJ P, ;[3230] Return
SAVSCR: MOVEI T3,DS.PRNT ;[3230]
CAIN T1,DS.LIST ;[3230] Does DISPOSE='LIST'?
MOVEM T3,DSPV ;[3230] Yes, don't delete file after printing
POPJ P, ;[3230] Return
;[3230] Here if no disposition and no status specified on CLOSE
;[3230] or if RENAME specified on CLOSE.
;[3230] If a SCRATCH file and OPEN DISP was DELETE or EXPUNGE,
;[3230] set to "SAVE".
COPDS1: CAIN T3,ST.SCR ;[3230] STATUS='SCRATCH'?
TXNN F,F%FSS!F%DSS ;[3230] Implied rename?
POPJ P, ;No, done
MOVEI T1,DS.SAVE ;[3230] Get "SAVE"
MOVE T2,DSPV ;Get OPEN dispose value
CAIE T2,DS.DEL ;DELETE
CAIN T2,DS.EXP ; or EXPUNGE
MOVEM T1,DSPV ;Yes, set to "SAVE"
POPJ P, ;Return
SEGMENT DATA
DSPV: BLOCK 1 ;DISPOSE value, also 1B0="delete after dispose"
SEGMENT CODE
;Routine to check disposition to make sure it is ok for that device
;Call:
; T1/ Disposition value requested
; D/ ptr to DDB (used to get INDX)
; PUSHJ P,DISPCK
; <return here, T1= disposition to set>
;A warning is given if the disposition is not allowed (and SAVE is used).
;
;If device is disk, everything is ok.
;(10) If device is dectape, everything is ok too.
;If device is anything else, only "SAVE" is allowed.
;Uses T1,T2
DISPCK: CAIN T1,DS.SAVE ;SAVE is always allowed
POPJ P,
LOAD T2,INDX(D) ;T2= device index
; Note INDX field copied to dummy DDB.
CAIN T2,DI.DSK ;DEVICE-type = disk?
POPJ P, ;Yes, all dispositions allowed
IF10,<
LOAD T2,DVTYP(D) ;Check device type
CAIN T2,.TYDTA ;DECTAPE can get any dispose
POPJ P, ; . .
>
MOVEI T1,DS.SAVE ;Set DISPOSE='SAVE'
$ECALL DSS ;%DISPOSE='SAVE' assumed for non-disk device
POPJ P,
;Check for DISPOSE='RENAME' .. if specified, get the
;RENAME arguments out of the DDB block.
;If DISPOSE='RENAME' specified but no new filename
; is given, a warning is given.
CKDPSR: TXNE F,F%FSS!F%DSS ;Implied?
JRST CKDPS1 ;Yes
LOAD T1,DISP(D) ;Get value of /DISPOSE
CAIE T1,DS.REN ;RENAME?
POPJ P, ;No, just return
;DISPOSE='RENAME' given but no filespec info (??).
$ECALL RND ;%DISPOSE='RENAME' ignored
SETZ T1, ;Set DISPOSE value to "not specified"
STORE T1,DISP(D) ;. .
POPJ P,
;Implied rename
;Remember the new filespec, by storing away the addresses
; of the "D" and "U" used to read the CLOSE arguments with the
; new filespec. (We won't release the core for them until after the RENAME
;is successfully completed!).
CKDPS1: MOVEM D,RENAMD ;Save info from the dummy blocks
MOVEM U,RENAMU ; . .
LOAD T1,DISP(D) ;If DISP:/RENAME, set to "not specified"
SETZ T2,
CAIN T1,DS.REN
STORE T2,DISP(D)
POPJ P, ;Return
SEGMENT DATA
EFSFLG: BLOCK 1 ;FLAG FOR [Enter correct file specs]
%RNAMD::
RENAMD: BLOCK 1 ;Address of dummy "D" with rename filespec
%RNAMU::
RENAMU: BLOCK 1 ;Address of dummy "U" with rename filespec
SEGMENT CODE
IF20,<
CLSAVE: MOVE T1,USCNT(D) ;Get use count
CAIE T1,1 ; Only CLOSE file if open on just 1 unit
JRST %POPJ1
LOAD T1,IJFN(D) ;GET JFN
CAIN T1,.PRIIN ;If TTY:, don't close it
JRST %POPJ1 ; or release it
GTSTS% ;GET FILE STATUS
JUMPGE T2,CLNCL ;IF NOT OPEN, DON'T CLOSE IT
CLOSF% ;CLOSE FILE
ERJMP CLF ;FAILED
JRST %POPJ1 ;All done, file saved
CLNCL: RLJFN% ;GIVE JFN BACK
JFCL ;NOTHING YOU CAN DO
JRST %POPJ1 ;Done
CLF1: POP P,(P) ;FIX STACK
CLF: SETZ T1, ;DISCARD JFN SO WE NEVER TRY TO CLOSE IT AGAIN
STORE T1,IJFN(D)
STORE T1,OJFN(D)
; IOERR (CLF,34,,?,$J,%POPJ)
$ECALL CLF,REQDIA
RNFL: SETZ T1, ;Same as CLF, but
STORE T1,IJFN(D) ;Different error msg
STORE T1,OJFN(D)
MOVX T1,D%NCLS ;Turn off CLOSE error flag
ANDCAM T1,FLAGS(D) ; (RENAME failed)
$ECALL RNM,REQDIA
; TOPS-20 /DISPOSE:DELETE and EXPUNGE
CLDEL: TDZA T0,T0 ;SET TO JUST DELETE
CLEXP: MOVX T0,DF%EXP ;SET TO EXPUNGE
LOAD T1,OJFN(D) ;GET JFN
CAIN T1,.PRIOU ;If TTY:,
JRST %POPJ1 ;Nothing to do
PUSH P,T1 ;SAVE FOR DELF
GTSTS% ;SEE IF OPEN
JUMPGE T2,CLDEL1 ;IF NOT OPEN, DON'T CLOSE IT
HRLI T1,(CO%NRJ) ;CLOSE FILE, KEEP JFN
CLOSF%
ERJMP CLF1
CLDEL1: POP P,T1 ;GET DELF ARG BACK
HLL T1,T0 ;PUT IN EXPUNGE BIT, IF /DISP:EXPUNGE
DELF% ;DELETE FILE, MAYBE EXPUNGE
ERJMP CLF
JRST %POPJ1 ;Ok, file deleted
;Routine to RENAME file prior to close.
;On TOPS-20 this requires that the CLOSF be done.
;Also only DISK devices are allowed.
;D/ U/ old DDB block.
;RENAMD/ RENAMU/ new DDB block.
CLREN: LOAD T1,IJFN(D) ;Get JFN
GTSTS%
JUMPGE T2,RNNCL ;IF NOT OPEN, DON'T CLOSE IT
LOAD T1,IJFN(D) ;CLOSE FILE, KEEP JFN
HRLI T1,(CO%NRJ)
CLOSF%
ERJMP CLF ;Can't
RNNCL: EXCH D,RENAMD ;SWITCH TO DATA SPECIFIED IN CLOSE STMT
PUSHJ P,SETJFN ;SET UP JFNBLK WITH FILENAME
EXCH D,RENAMD
MOVX T1,GJ%FOU ;NEXT HIGHER GENERATION NUMBER ON
HLLM T1,JFNBLK+.GJGEN
MOVEI T1,JFNBLK ;GET JFN ON DESTINATION FILE
HRROI T2,[0]
GTJFN%
ERJMP RNFL
MOVEI T2,(T1) ;COPY DESTINATION JFN
LOAD T1,IJFN(D) ;GET SOURCE JFN
RNAMF% ;RENAME THE FILE
ERCAL RNFL
STORE T2,IJFN(D) ;Store new JFN in old DDB
STORE T2,OJFN(D) ; The JFN is CLOSE'd.
;Throw away the RENAMD and RENAMU blocks; done with them
PJRST RNME1 ;Go throw away core, etc.
>;END IF20
;Routine to throw away the RENAMD and RENAMU blocks because
; they are no longer needed. Also clears F%FSS and F%DSS.
;Returns .+2 always
RNME1: TXZ F,F%FSS!F%DSS ;RENAME no longer necessary
MOVE T1,RENAMD
PUSHJ P,%FREBLK ;Throw away blocks
MOVE T1,RENAMU
PUSHJ P,%FREBLK
SETZM RENAMD ;Clear ptrs
SETZM RENAMU ; . .
AOS (P) ;Return ok
POPJ P, ;DONE
IF20,<
;TOPS-20 routine to prepare for disk close.
; It un-maps any mapped pages and throws away the core.
DSKCLS: MOVE T2,WPTR(D) ;GET PAGE NUMBER OF 1ST PAGE
JUMPE T2,%POPJ ;IF ANY
HRLI T2,.FHSLF ;PUT FORK HANDLE IN LH
LOAD T3,BUFCT(D) ;GET LENGTH OF WINDOW, PAGES
HRLI T3,(PM%CNT) ;THAT'S THE REPEAT COUNT
SETO T1, ;SET TO UNMAP
PMAP% ;UNMAP THE FILE PAGES
MOVE T1,WPTR(D)
LOAD T2,BUFCT(D) ;GET PAGE COUNT OF WINDOW
PUSHJ P,%FREPGS ;DEALLOCATE IT
SETZM WPTR(D) ;Note we threw it away
SETZM WADR(D) ;CLEAR REFILL POINTER
SKIPE T1,WTAB(D) ;FREE THE MAP TABLE, IF ANY
PUSHJ P,%FREBLK
SKIPE T1,PFTAB(D) ;AND THE PAGE FLAG TABLE, IF ANY
PUSHJ P,%FREBLK
MOVE T1,FLAGS(D) ;Get DDB flags
TXNN T1,D%MOD ;WAS FILE MODIFIED?
POPJ P, ;NO, DONE
LOAD T1,IJFN(D) ;GET FILE JFN
HRLI T1,.FBBYV+<(CF%NUD)> ;SET TO CHANGE BYTE SIZE
MOVX T2,FB%BSZ ;SET FILE BYTE SIZE
LOAD T3,BSIZ(D) ;GET BYTE SIZE WE USED
LSH T3,^D24 ;PUT IN POSITION
CHFDB% ;CHANGE FDB
LOAD T1,IJFN(D) ;GET FILE JFN
HRLI T1,.FBBYV+<(CF%NUD)> ;SET TO CHANGE BYTE SIZE
MOVX T2,FB%MOD ;SET DATA MODE
LOAD T3,DMODE(D) ;GET DATA MODE
MOVSI T3,(T3) ;IN POSITION
CHFDB% ;CHANGE FDB
MOVE T3,EOFN(D) ;GET FILE SIZE, BYTES
LOAD T1,FORM(D) ;GET FORM=
CAIE T1,FM.UNF ;UNFORMATTED?
JRST CLDFRM ;NO. USE AS IS
ADD T3,BPW(D) ;YES. ROUND UP
SUBI T3,1
IDIV T3,BPW(D) ;GET # WORDS
CLDFRM: LOAD T1,IJFN(D) ;GET FILE JFN
HRLI T1,.FBSIZ+<(CF%NUD)> ;SET FILE SIZE
SETO T2, ;WHOLE WORD
CHFDB% ;CHANGE FDB
MOVE T2,EOFN(D) ;NO. GET FILE SIZE AGAIN
SUBI T2,1 ;MAKE IT THE BYTE #
IDIV T2,BPW(D) ;MAKE IT THE WORD NUMBER
LSH T2,-9 ;GET TOP PAGE # OF FILE
LOAD T1,IJFN(D) ;GET JFN
HRLI T1,(T1) ;IN LEFT HALF
HRRI T1,1(T2) ;GET PAGE # + 1 OF EOFN
UNMPLP: FFUFP% ;GET NEXT USED PAGE
JRST %POPJ ;DONE. NO MORE USED PAGES
PUSH P,T1 ;SAVE FOR NEXT CALL
LOAD T2,IJFN(D) ;GET JFN
HRLI T2,(T2) ;SETUP PMAP CALL
HRRI T2,(T1) ;PAGE # IN RH
SETZ T3, ;NO REPEAT COUNT
SETO T1, ;SETUP FOR UNMAP FUNCTION
PMAP%
POP P,T1 ;GET JFN,,PAGE BACK
JRST UNMPLP ;BACK FOR MORE
> ;IF20
IF10,<
CLSAVE: HRRZ T1,FBLK(D) ;IF FILE WAS NEVER OPENED
JUMPE T1,%POPJ1 ;RETURN NOW
MOVE T1,USCNT(D) ;Get use count
CAIE T1,1 ; Only CLOSE file if open on just 1 unit
JRST %POPJ1
MOVEI T2,.FOCLS ;Close first
HLL T2,CHAN(D) ; to get the data out
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR ;Get error message on write-locked tape
MOVEI T2,.FOREL ;Now release the channel
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
JRST CLSERR
JRST %POPJ1
%CLSER:
CLSERR: TXNE T1,IO.ERR ;JUST EOF?
; IOERR (CLS,,,%,$I,<T1>) ;NO, TYPE MESSAGE
$ECALL CLS,%ABORT ;AND DIE
POPJ P, ;DONE
;"EXPUNGE" and "DELETE" are the same on TOPS-10
CLEXP:
CLDEL: HRRZ T1,FBLK(D) ;RETURN NOW IF FILE NOT REALLY OPEN
JUMPE T1,%POPJ1
MOVEI T2,.FOCLS ;Close it
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
PUSHJ P,CLSERR ;Get error message
SETZM FBLK+.FOBRH(D) ;CLEAR THE BLOCK HEADERS
SETZM FBLK+.FONBF(D) ;AND # BUFFERS
MOVEI T1,.FODLT ;DELETE FILE
HRRM T1,FBLK(D)
MOVEI T1,FBLK(D)
HRLI T1,FLEN
FILOP. T1,
; IOERR (DEL,,,%,$E,<T1>,REQDIA)
$ECALL DEL,REQDIA
MOVEI T2,.FOREL ;Now release the channel
HLL T2,CHAN(D)
MOVE T1,[1,,T2]
FILOP. T1,
JRST CLSERR ;?Shouldn't ever happen
JRST %POPJ1 ;Ok, return
;TOPS-10 routine to RENAME prior to CLOSE.
;D/ U/ old DDB block.
;RENAMD/ RENAMU/ new DDB block
CLREN: PUSHJ P,RNFCHK ;Check for invalid RENAMEs
POPJ P, ; Invalid, return to DIALOG mode.
;Don't care if files are on same device type even if they are not
; disk or MTA-- TOPS-10 monitor doesn't give an error unless the
; devices are different.
MOVE T1,RENAMD ;Point to new DDB
MOVEI T1,LKPB(T1) ;POINT TO LOOKUP BLOCK IN NEW DDB
HRLM T1,FBLK+.FOLEB(D) ;STORE IN OLD DDB
MOVEI T2,LLEN ;SET LENGTH OF RENAME BLOCK
MOVEM T2,.RBCNT(T1)
PUSH P,D ;[2112] SAVE OLD DDB POINTER VERY TEMPORARILY
MOVE D,RENAMD ;[2112] POINT TO NEW DDB
PUSHJ P,SETPPB ;[2112] RESET THE PATH BLOCK
POP P,D ;[2112] RESTORE D
MOVEI T1,.FORNM ;SET TO RENAME FILE
HRRM T1,FBLK(D)
SETZM FBLK+.FOBRH(D) ;CLEAR THE BLOCK HEADERS
SETZM FBLK+.FONBF(D) ;AND # BUFFERS
MOVEI T1,FBLK(D) ;DO THE RENAME
HRLI T1,FLEN
FILOP. T1, ;** Do RENAME, closes file **
JRST CLRENF ;?failed, give error
MOVE T1,RENAMD ;T1 points to new DDB.
HRLI T2,LKPB(T1) ;Copy RENAME block
HRRI T2,LKPB(D) ; To LOOKUP block (so subsequent LOOKUP's
BLT T2,LKPB+LLEN-1(D) ;Finds the file!
HRLI T2,PTHB(T1) ;Copy PATH. block From new DDB
HRRI T2,PTHB(D) ;To old DDB
BLT T2,PTHB+^D9-1(D) ; . .
PUSHJ P,SETPPB ;Reset path block
HRRZS FBLK+.FOLEB(D) ;CLEAR RENAME BLOCK POINTER
PJRST RNME1 ; Throw away RENAMD and RENAMU; return .+2
CLRENF: MOVX T2,D%NCLS ;Turn off CLOSE error flag
ANDCAM T2,FLAGS(D)
$ECALL RNM,REQDIA ;?failed, give error
;STILL IF10
;TOPS-10 routine to prepare for CLOSE of disk file.
;If file is random, it writes out altered pages and throws away
; the core used by WTAB.
DSKCLS: MOVE T1,FLAGS(D) ;Get DDB flags
TXNN T1,D%RAN ;Is this a RANDOM file?
POPJ P, ;NO, NOTHING SPECIAL
PUSHJ P,%RANWR ;WRITE ALTERED PAGES
MOVE T1,WPTR(D) ;GET PAGE POINTER
JUMPE T1,%POPJ ;IF ANY
LOAD T2,BUFCT(D) ;GET LENGTH IN PAGES
PUSHJ P,%FREPGS
MOVE T1,WTAB(D) ;POINT TO TABLE
PUSHJ P,%FREBLK ;FREE IT
MOVE T1,PFTAB(D) ;FREE PAGE FLAG TABLE
PUSHJ P,%FREBLK
SETZM WPTR(D) ;Note we threw it away
SETZM WADR(D) ;CLEAR BOOT PNTR
POPJ P,
;Routine to check for invalid RENAMEs.
; Returns .+1 and F%DRE set if invalid.
; if ok returns .+2
;Returns T1= device type
RNFCHK: LOAD T1,DVTYP(D) ;Get device type of 1st file
MOVE T2,RENAMD ;T2 points to new DDB
LOAD T3,DVTYP(T2) ;Get it's device type
CAMN T1,T3 ;Same?
JRST %POPJ1 ;Yes, say it's ok.
CAIE T1,.TYDSK ;DISK Ok
CAIN T1,.TYDTA ;DTA ok
JRST RNFCH1
$ECALL FD1,REQDIA ;?File not on disk- can't RENAME
RNFCH1:
CAIE T3,.TYDSK ;DISK OK
CAIN T3,.TYDTA ; DECTAPE OK
JRST %POPJ1
$ECALL FD1,REQDIA ;?File 2 not on disk or dectape
> ;END IF10
SUBTTL QUASAR INTERFACE
;ROUTINE TO SEND A QUEUE REQUEST OFF TO QUASAR
;ARGS: JFN, QUEUE NUMBER
;RETURN: PACKET SENT
CLSQ: PUSHJ P,%SAVE3 ;SAVE P ACS
MOVE P3,DSPV ;[3230] Get disposition
IF10,<
PUSHJ P,CLSAVE ;CLOSE FILE, SAVE IT
POPJ P, ;?error, single return
;See if GALAXY V2 is running.
MOVX T1,%SIOPR ;Look for ORION's PID
GETTAB T1, ; (only present if GALAXY R4)
JRST OLDGLX ;Gettab failed, assume R2
JUMPE T1,OLDGLX ;If 0 returned, R2.
;GALAXY V4 - try to do a QUEUE. UUO.
MOVEI P2,QBLK-1 ;POINT TO QUEUE. ARG BLOCK
PUSH P2,QFNC(P3) ;PUSH FUNCTION CODE
MOVSI T1,(QF.RSP) ;REQUEST RESPONSE
IORM T1,(P2)
PUSH P2,[-1] ;NODE ID
PUSH P2,[LRESP,,%RESP] ;RESPONSE BLOCK LENGTH,,ADDRESS
MOVEI T1,FD-1 ;FILL IN FILE DESCRIPTOR
PUSH T1,PTHB(D) ;STRUCTURE NAME
PUSH T1,FILE(D) ;FILE NAME
PUSH T1,EXT(D) ;EXTENSION
HLLZS (T1)
PUSH T1,PTHB+.PTPPN(D) ;PPN
MOVEI T2,PTHB+.PTPPN+1(D)
Q1SFD: SKIPN (T2) ;SFDS, IF ANY
JRST Q1SFDE
PUSH T1,(T2)
AOJA T2,Q1SFD
Q1SFDE: SUBI T1,FD-1 ;GET FD LENGTH
PUSH P2,[.QBFIL] ;ARG IS AN FD
HRLM T1,(P2) ;SET LENGTH
PUSH P2,[FD] ;AND ADDRESS
HLRZ T1,EXT(D) ;[2062] GET EXTENSION
CAIE T1,'DAT' ;[2062] IS IT ".DAT"
JRST Q1NDAT ;[2062] NO
PUSH P2,[QA.IMM+.QBPTP] ;[2062] ARG IS FILE FORMAT
PUSH P2,[.QBPFR] ;[2062] SET /FILE:FORTRAN
Q1NDAT: MOVE T1,SIZ(D) ;GET # WORDS IN FILE
ADDI T1,177 ;ROUND UP TO BLOCKS
LSH T1,-7 ;CALC # BLOCKS
ADDI T1,10 ;USE # BLOCKS + 8
PUSH P2,[QA.IMM+.QBLIM] ;SET LIMIT
PUSH P2,T1
CAIE P3,DS.LIST ;/DISP:LIST?
JRST Q1NLST ;NO
PUSH P2,[QA.IMM+.QBODP] ;ARG IS DISPOSITION
PUSH P2,[1] ;DISP IS DELETE
Q1NLST:
SUBI P2,QBLK-1 ;GET LENGTH OF QUEUE. ARG BLOCK
MOVEI T1,QBLK ;GET LENGTH,,ADDRESS
HRLI T1,(P2)
QUEUE. T1, ;DO IT
JRST Q1CANT ;FAILED, GO SEE WHY
XMOVEI T1,%RESP ;GET ADDR OF RESPONSE MESSAGE
MOVEI T2,"[" ;INFO ONLY
MOVE T3,%RESP ;GET FIRST WORD OF RESPONSE
TLNE T3,774000 ;SEE IF ANY TEXT IS PRESENT
; IOERR (QUE,-1,0,$,$A,<T2,T1>) ;YES, TYPE IT
$ECALL QUE
JRST %POPJ1 ;Done
Q1CANT: TLNN T1,-1 ;IS UUO IMPLEMENTED?
; IOERR (CQF,,,%,<Can't queue file, QUEUE. error $D>,<T1>,%POPJ)
$ECALL CQF,%POPJ1
;NO UUO, SEND QUASAR A (GALAXY VERSION 2) PACKET
SEGMENT DATA
QBLK: BLOCK 17 ;QUEUE. BLOCK, LENGTH 3 + 2 MAX-POSSIBLE-ARGS
FD: BLOCK 10 ;FILE DESCRIPTOR
SEGMENT CODE
> ;IF10
;Here for TOPS20 or pre-version 4 GALAXY on TOPS-10.
;Use IPCF sends.
OLDGLX: MOVEI T1,1 ;GET A PAGE TO SEND TO QUASAR
PUSHJ P,%GTPGS##
POPJ P, ;CAN'T
MOVEI P1,(T1) ;COPY PAGE NUMBER
LSH P1,9 ;MAKE INTO ADDRESS
;Clear out the page (%GTPGS doesn't do it automatically).
SETZM (P1) ;Clear out the page
HRLZ T1,P1 ;Starting addr,,
HRRI T1,1(P1) ; .+1
BLT T1,777(P1) ;** Clear one page **
XMOVEI P2,-1(P1) ;COPY ADDRESS
;MAKE PACKET
IF20,< ;GALAXY RELEASE 4 PACKET FORMAT
;The format of a Release 4 packet is the standard GALAXY header
;(3 words), a flag word, a count word, and then argument-type/argument-data
;pairs.
PUSH P2,[.QOCQE] ;CREATE QUEUE ENTRY
PUSH P2,[MF.ACK] ;REQUEST ACK
PUSH P2,[0] ;SET UNIQUE ID TO 0 SINCE WE SEND
;ONE MESSAGE AT A TIME
PUSH P2,[0] ;FLAGS, 0
PUSH P2,[0] ;COUNT IS 0 FOR NOW
AOS .OARGC(P1) ;COUNT ARG
PUSH P2,[2,,.QCQUE] ;ARG IS QUEUE TYPE
PUSH P2,QOT(P3) ;QUEUE TYPE DEPENDS ON DISPOSITION
HRROI T1,.FDFIL(P2) ;[2062] POINT TO DESTINATION (OVERWRITTEN)
LOAD T2,IJFN(D) ;[2062] GET JFN
MOVX T3,FLD(.JSAOF,JS%TYP) ;[2062] FILE TYPE ONLY
JFNS% ;[2062] MAKE TYPE STRING
JSHALT ;[2062] SHOULD NEVER FAIL
MOVE T1,.FDFIL(P2) ;[2062] GET 1ST WORD OF TYPE
CAME T1,[ASCIZ /DAT/] ;[2062] IS TYPE "DAT"
JRST QNDAT ;[2062] NO
AOS .OARGC(P1) ;[2062] COUNT ARG
PUSH P2,[2,,.QCPTP] ;[2062] ARG IS FILE FORMAT
PUSH P2,[.FPFFO] ;[2062] SET /FILE:FORTRAN
QNDAT: ;[2062]
AOS .OARGC(P1) ;COUNT ARG
PUSH P2,[.QCFIL] ;ARG IS FILE DESCRIPTOR (FD)
HRROI T1,.FDFIL(P2) ;POINT TO FILE SPEC DESTINATION
LOAD T2,IJFN(D) ;GET JFN
MOVX T3,11111B14+JS%PAF
JFNS% ;MAKE FULL FILESPEC STRING
JSHALT ;SHOULD NEVER FAIL
SETZ T2, ;FOLLOW WITH A NULL
IDPB T2,T1
SUBI T1,-1(P2) ;GET LENGTH OF FD
HRLM T1,.FDLEN(P2) ;STORE IN LENGTH WORD
ADDI P2,-1(T1) ;BUMP POINTER PAST FD
CAIE P3,DS.LIST ;/DISP:LIST?
JRST QNLST ;NO
AOS .OARGC(P1) ;COUNT ARG
PUSH P2,[2,,.QCODP] ;ARG IS DISPOSITION
PUSH P2,[1] ;DISP IS DELETE
QNLST:
MOVE T1,EOFN(D) ;GET FILE SIZE IN BYTES
IDIV T1,BPW(D) ;GET APPROX # WORDS
ADDI T1,777 ;ROUND UP TO PAGES
LSH T1,-9 ;CALC # PAGES
IMULI T1,G.LPTM ;DO QUEUE MAGIC TO GET LIMIT
IDIVI T1,G.LPTD
AOS .OARGC(P1) ;COUNT ARG
PUSH P2,[2,,.QCLIM] ;SET OUTPUT LIMIT
PUSH P2,T1
SUBI P2,-1(P1) ;GET LENGTH OF MESSAGE
HRLM P2,(P1) ;STORE IN HEADER
> ;IF20
IF10,< ;GALAXY RELEASE 2 PACKET
;P1 points to the message block, initially all zero.
;Users who have their own modified version of QSRMAC should
;reassemble FOROPN using their QSRMAC. If they have added fields
;that should be filled in (instead of left 0), they must add code
;here.
;Store message header
MOVX T1,MS.ACK ;Request an acknowledgement
MOVEM T1,.MSTYP(P1)
MOVEI T1,.QOCRE ;Create message
DPB T1,[POINTR .MSTYP(P1),MS.TYP]
;Length is filled in later
;Store CREATE header
MOVE T1,['FOROTS'] ;Internal task name
MOVEM T1,.EQITN(P1)
MOVEI T1,%%.QSR ;QUASAR version number
DPB T1,[POINTR .EQLEN(P1),EQ.VRS]
MOVEI T1,EQHSIZ ;Length of the header (including MSHSIZ)
DPB T1,[POINTR .EQLEN(P1),EQ.LOH]
MOVE T1,QDEV(P3) ;Requested processing device
MOVEM T1,.EQRDV(P1)
MOVE T1,FILE(D) ;Job name (SIXBIT) - use file name
MOVEM T1,.EQJOB(P1)
MOVEI T1,^D10 ;Priority
DPB T1,[POINTR .EQSEQ(P1),EQ.PRI]
HRROI T1,.GTLOC ;Get location
GETTAB T1,
SETZ T1,
DPB T1,[POINTR .EQSEQ(P1),EQ.DSN]
MOVEI T1,055 ;Protection
DPB T1,[POINTR .EQSPC(P1),EQ.PRO]
MOVEI T1,1 ;File count
DPB T1,[POINTR .EQSPC(P1),EQ.NUM]
MOVEI T1,EQ.UNO ;/UNIQUE:NO
DPB T1,[POINTR .EQLM1(P1),EQ.UNI]
CAIN P3,DS.SUB ;DISPOSE='SUBMIT'?
JRST NOLIM2 ;Yes, don't set a LIMIT in that case.
;Compute number of blocks written from EOFN and BPW.
MOVE T2,EOFN(D) ;Get # bytes written
IDIV T2,BPW(D) ;Get # words written
SKIPE T3 ; round up
ADDI T2,1
IDIVI T2,^D128 ;# blocks written
SKIPE T3 ; Round up
ADDI T2,1
DPB T2,[POINTR .EQLM2(P1),EQ.NBL] ;Output number of blocks
NOLIM2: HRROI T1,.GTNM1 ;USER NAME
GETTAB T1,
SETZ T1,
HRROI T2,.GTNM2
GETTAB T2,
SETZ T2,
DMOVEM T1,.EQUSR(P1) ;Store user name
MOVE T1,G.PPN ;Get my PPN
MOVEM T1,.EQOWN(P1) ; Store that in owner ID word
;Store filespec info.
MOVEI T4,EQHSIZ(P1) ;T4: = ptr to file info
MOVEI T1,FPMSIZ ;Size of FP area
DPB T1,[POINTR .FPSIZ(T4),FP.FHD]
;FD size is stored later.
MOVEI T1,.FPFAS ;/FILE:ASCII
HLRZ T3,EXT(D) ;[2062] GET FILE EXTENSION
CAIN T3,'DAT' ;[2062] IS EXTENSION "DAT"
MOVEI T1,.FPFFO ;[2062] YES, SET /FILE:FORTRAN
DPB T1,[POINTR .FPINF(T4),FP.FFF] ;File format
MOVEI T1,%FPLAS ;/PRINT:ASCII
DPB T1,[POINTR .FPINF(T4),FP.FPF] ;Paper format
MOVEI T1,1 ;/COPIES:1
DPB T1,[POINTR .FPINF(T4),FP.FCY]
MOVEI T1,1 ;/SPACING:1
DPB T1,[POINTR .FPINF(T4),FP.FSP]
MOVX T1,FP.DEL
CAIN P3,DS.LIST ;or /DISP:LIST?
IORM T1,.FPINF(T4) ;Yes, set /DELETE bit
MOVEI T1,1 ;Starting point information
MOVEM T1,.FPFST(T4)
MOVEI T3,FPMSIZ(T4) ;T3 points to start of filespec block
MOVEI T0,.FDPPN+1 ;T0 counts how many words in this
MOVE T1,PTHB(D) ;STR
MOVEM T1,.FDSTR(T3)
MOVE T1,FILE(D) ;FILENAME
MOVEM T1,.FDNAM(T3)
HLLZ T1,EXT(D) ;EXT
HLLZM T1,.FDEXT(T3)
MOVE T1,PTHB+.PTPPN(D) ;PPN
MOVEM T1,.FDPPN(T3)
MOVEI T2,PTHB+.PTPPN+1(D)
MOVEI T3,.FDPAT(T3) ;Point to place to store SFD words
QSFD: SKIPN T1,(T2) ;SFDS, IF ANY
JRST QSFDE
ADDI T0,1 ;Count words
MOVEM T1,(T3) ;Store that SFD
ADDI T3,1 ;Bump ptr incase more SFD's.
AOJA T2,QSFD
QSFDE: DPB T0,[POINTR .FPSIZ(T4),FP.FFS] ;Store size of the FD block
ADDI T0,FPMSIZ ;Get total size of FP+FD
ADDI T0,EQHSIZ ;Get total size of packet
DPB T0,[POINTR .MSTYP(P1),MS.CNT] ;Store length of the message
> ;IF10
IF20,< PUSHJ P,CLSAVE ;CLOSE FILE (DEFERRED UNTIL NOW BECAUSE OF JFNS%)
POPJ P, > ;?Error, single return
PUSHJ P,QSND ;SEND PACKET TO QUASAR
JRST %POPJ1 ;Failed, but just return "successfully"
PUSHJ P,QACK ;WAIT FOR ACK AND TYPE RESPONSE
MOVEI T1,(P1) ;GET ADDRESS OF PAGE WE ALLOCATED
LSH T1,-9 ;MAKE PAGE NUMBER
MOVEI T2,1 ;SET LENGTH, 1 PAGE
PUSHJ P,%FREPGS ;Free page
JRST %POPJ1 ; and return
IF20,<
QOT=.-DS.QUEUE ;QUEUE OBJECT TYPE, INDEXED BY DISP
EXP .OTLPT ;PRINT
EXP .OTPTP ;PUNCH
EXP .OTLPT ;LIST
EXP .OTBAT ;SUBMIT
> ;IF20
IF10,<
QFNC=.-DS.QUEUE ;QUEUE. FUNCTIONS FOR GALAXY 4+
EXP .QUPRT ;PRINT
EXP .QUPTP ;PUNCH
EXP .QUPRT ;LIST
EXP .QUBAT ;SUBMIT
QDEV=.-DS.QUEUE ;QUEUE NAMES FOR GALAXY 2
SIXBIT /LPT/ ;PRINT
SIXBIT /PTP/ ;PUNCH
SIXBIT /LPT/ ;LIST
SIXBIT /INP/ ;SUBMIT
> ;IF10
IF20,<
;ROUTINE TO SEND PAGE TO QUASAR
;ARGS: P1 = ADDRESS (ON PAGE BOUNDARY) OF MESSAGE
;SKIP RETURN IF SUCCESSFUL
;WHETHER SUCCESSFUL OR NOT, MESSAGE IS GONE ON RETURN
QSND: SKIPE T1,QSRPID ;GET QUASAR'S PID, IF WE KNOW IT ALREADY
JRST GOTQSR ;GOT IT, SKIP
MOVEI T1,3 ;SET LENGTH, ADDRESS OF BLOCK
MOVEI T2,IPCBLK
MOVEI T3,.MURSP ;READ SYSTEM PID
MOVEM T3,(T2)
MOVEI T3,.SPQSR ;OF <SYSTEM>QUASAR
MOVEM T3,1(T2)
MUTIL%
JSHALT
MOVE T1,IPCBLK+2 ;GET PID
MOVEM T1,QSRPID
GOTQSR: MOVEM T1,IPCBLK+.IPCFR ;SET RECIEVER PID
MOVE T1,I.PID ;GET MY PID
MOVEM T1,IPCBLK+.IPCFS ;SET SENDER PID
MOVEI T1,(P1)
LSH T1,-9
HRLI T1,1000 ;SET LENGTH,,ADDRESS OF PACKET
MOVEM T1,IPCBLK+.IPCFP
QTRY: MOVX T1,IP%CFV ;PAGE MODE
SKIPN IPCBLK+.IPCFS ;IF WE DON'T HAVE A PID,
TXO T1,IP%CPD ; CREATE ONE
MOVEM T1,IPCBLK+.IPCFL
MOVEI T1,4 ;SEND PAGE TO QUASAR
MOVEI T2,IPCBLK
MSEND%
ERJMP QSNDF ;FAILED, SEE WHY
SKIPE T1,IPCBLK+.IPCFS ;GET RETURNED PID
MOVEM T1,I.PID ;SAVE IT
JRST %POPJ1
QSNDF: CAIL T1,IPCFX6 ;CHECK ERROR CODE
CAILE T1,IPCFX8
$ECALL IJE
SKIPE T1,IPCBLK+.IPCFS ;GET RETURNED PID
MOVEM T1,I.PID ;SAVE IT
MOVEI T1,^D3000 ;WAIT 3 SECONDS
DISMS%
JRST QTRY ;TRY AGAIN
;ROUTINE TO WAIT FOR ACK FROM QUASAR AND TYPE RESPONSE
;IF QUASAR SENDS BACK AN ERROR, BUILD A FOROTS ERROR MESSAGE
;AND ENTER DIALOG MODE (??)
QACK: XMOVEI T1,IPCBLK-1
PUSH T1,[0] ;CLEAR FLAGS
PUSH T1,[0] ;CLEAR SENDER
PUSH T1,I.PID ;RECIEVE MESSAGE TO ME ONLY
MOVEI T2,(P1) ;POINT TO PAGE WE USED FOR SENDING
HRLI T2,1000 ;LENGTH IS 1000
PUSH T1,T2
RCVAGN: MOVEI T1,4 ;GET RESPONSE FROM QUASAR
MOVEI T2,IPCBLK
MRECV%
JSHALT
MOVE T1,IPCBLK+.IPCFS ;GET SENDER
CAME T1,QSRPID ;QUASAR?
JRST RCVAGN ;NO, DISCARD JUNK
HRRZ P1,IPCBLK+.IPCFP ;POINT TO MESSAGE
MOVE P2,.MSFLG(P1) ;GET MESSAGE FLAGS
TXNE P2,MF.NOM ;ACK TEXT PRESENT?
JRST NOMSG ;NO, DON'T TYPE ANYTHING
XMOVEI T1,.OHDRS+ARG.DA(P1) ;GET ADDR OF ACTUAL MESSAGE
MOVEI T2,"[" ;ASSUME INFO MESSAGE
TXNE P2,MF.FAT+MF.WRN ;ERROR?
MOVEI T2,"%" ;YES, CHANGE PREFIX CHAR
$ECALL QUE ;OUTPUT MESSAGE
NOMSG: TXNE P2,MF.MOR ;MORE COMING?
JRST RCVAGN ;YES, GO GET IT
POPJ P, ;NO, RETURN
> ;IF20
IF10,<
;ROUTINE TO SEND PAGE TO QUASAR
;ARGS: P1 = ADDRESS (ON PAGE BOUNDARY) OF MESSAGE
;SKIP RETURN IF SUCCESSFUL
;WHETHER SUCCESSFUL OR NOT, MESSAGE IS GONE ON RETURN
QSND: SKIPE T1,QSRPID ;GET QUASAR'S PID, IF KNOWN
JRST GOTQSR ;KNOWN, SKIP
MOVE T1,[%SIQSR] ;GETTAB QSRPID
GETTAB T1,
$SNH
MOVEM T1,QSRPID
GOTQSR: MOVEM T1,IPCBLK+.IPCFR ;SET RECIEVER PID
SETZM IPCBLK+.IPCFS ;NO SENDER PID
MOVEI T1,(P1) ;SET SEND ADDRESS
LSH T1,-9 ;MAKE PAGE NUMBER
HRLI T1,1000 ;SET LENGTH,,ADDRESS OF PACKET
MOVEM T1,IPCBLK+.IPCFP
MOVX T1,IP.CFV ;FLAGS: PAGE MODE
MOVEM T1,IPCBLK+.IPCFL
QTRY: MOVE T1,[4,,IPCBLK] ;SEND PAGE TO QUASAR
IPCFS. T1,
JRST QSNDF ;FAILED, SEE WHY
JRST %POPJ1 ;PAGE SUCCESSFULLY SENT
QSNDF: CAIL T1,IPCDD% ;RECOVERABLE?
CAILE T1,IPCRY%
$SNH ;NO, QUIT
MOVEI T1,3 ;WAIT 3 SECONDS
SLEEP T1,
JRST QTRY ;TRY AGAIN
;ROUTINE TO WAIT FOR ACK FROM QUASAR AND TYPE RESPONSE
;IF QUASAR SENDS BACK AN ERROR, BUILD A FOROTS ERROR MESSAGE
QACK: MOVE T1,[4,,IPCBLK] ;INSPECT RECIEVE QUEUE
IPCFQ. T1,
JRST QSLP ;NOTHING THERE, GO WAIT
SKIPN IPCBLK+.IPCFP ;[Q10-5204]
JRST QSLP ;[Q10-5204]
MOVE T1,IPCBLK+.IPCFS ;GET SENDER PID
CAMN T1,QSRPID ;FROM QUASAR?
JRST RCV ;YES, GO READ MESSAGE
MOVE T1,IPCBLK+.IPCFL ;GET FLAGS
ANDI T1,IP.CFV ;CLEAR ALL BUT PAGE-MODE
TXO T1,IP.CFT ;TRUNCATE IF TOO LONG
MOVEM T1,IPCBLK+.IPCFL
SETZM IPCBLK+.IPCFP ;CLEAR LENGTH,,ADDRESS
MOVE T1,[4,,IPCBLK]
IPCFR. T1, ;RECIEVE MESSAGE AND IGNORE IT
$SNH
JRST QACK ;KEEP TRYING
QSLP: MOVE T1,[HB.IPC+^D3000] ;WAIT FOR IPCF ACTIVITY
HIBER T1,
JFCL
JRST QACK ;GO SEE WHAT THE ACTIVITY WAS
RCV: MOVX T1,IP.CFV ;PAGE MODE
ANDB T1,IPCBLK+.IPCFL ;GET JUST THAT BIT FROM IPCFQ. INFO
MOVEI T3,(P1) ;GET DEST ADDRESS
LSH T3,-9 ;CONVERT TO PAGE NUMBER
JUMPN T1,RCVX ;IF PAGE-MODE MESSAGE, GO RECIEVE IT
MOVE T1,[.PAGCD,,T2] ;WORD-MODE, MUST CREATE PAGE FIRST
MOVEI T2,1 ;1 PAGE, PAGE NUMBER IN T3
PAGE. T1, ;DO IT
JFCL ;PAGE IS ALREADY THERE
MOVEI T3,(P1) ;GET DEST ADDRESS
RCVX: HRLI T3,1000 ;SET LENGTH,,ADDRESS
MOVEM T3,IPCBLK+.IPCFP
MOVE T1,[4,,IPCBLK]
IPCFR. T1, ;GET MESSAGE
$SNH ;SHOULDN'T FAIL
MOVE T1,IPCBLK+.IPCFS ;GET SENDER
CAME T1,QSRPID ;QUASAR?
JRST RCV ;NO, DISCARD JUNK
MOVE P2,TEX.ST(P1) ;GET STATUS WORD
TXNE P2,TX.NMS ;ACK TEXT PRESENT?
JRST NOMSG ;NO, DON'T TYPE ANYTHING
XMOVEI T1,TEX.MS(P1) ;GET ADDR OF MESSAGE
MOVEI T2,"[" ;ASSUME INFO
TXNE P2,TX.FAT!TX.WRN ;ERROR?
MOVEI T2,"%" ;YES. CHANGE PREFIX CHAR
$ECALL QUE ;OUTPUT MESSAGE
NOMSG: TXNE P2,TX.MOR ;MORE COMING?
JRST QACK ;YES, GO GET IT
POPJ P, ;NO, RETURN
> ;IF10
SEGMENT DATA
LRESP==20 ;LENGTH OF RESPONSE BLOCK
%RESP:: BLOCK LRESP ;RESPONSE BLOCK
QSRPID: BLOCK 1 ;QUASAR PID
IPCBLK: BLOCK 4 ;CONTROL BLOCK FOR IPCF FUNCTIONS
SEGMENT CODE
;ROUTINE TO CLOSE ALL FILES
FENTRY (EXIT1)
SETZM %UDBAD ;NO I/O IN PROGRESS
PUSHJ P,%SAVAC ;SAVE USER'S ACS
%EXIT1: SETZ F, ;CLEAR FLAG AC
XMOVEI T1,[ASCIZ /CLOSE/] ;FOR ERROR MESSAGES, WE'RE A CLOSE STMT
MOVEM T1,%IONAM
MOVE P1,[MINUNIT-MAXUNIT-1,,MINUNIT] ;LOOP THROUGH ALL UNITS
EX1L: MOVE U,%DDBTAB(P1) ;GET A Unit block ADDRESS
JUMPE U,EX1N ;NONE, SKIP
MOVE D,DDBAD(U) ;Get DDB address
PUSHJ P,%CLOSX ;Close the DDB
EX1N: AOBJN P1,EX1L ;DO THEM ALL
IF20,<
SKIPE DBSTP. ;Skip if no DBMS loaded with FORLIB.
PUSHJ P,@DBSTP. ;If DBMS around, leave databases in
> ; a CLOSEd state.
POPJ P, ;DONE
SUBTTL RANDOM ROUTINES
IF10,<
;ALLOCATE I/O CHANNEL
;THREE ENTRY POINTS:
;ALCHN%: STANDARD FORTRAN CALLING SEQUENCE, ONE ARG POINTED TO BY L
; ARG = 0 TO FIND A FREE CHANNEL, 1-17 TO ALLOCATE THAT SPECIFIC CHANNEL
;RETURN: T0 = CHANNEL NUMBER ALLOCATED, OR -1 IF NO FREE CHANNELS
;%ALCHF: T1 = 0 TO FIND A FREE CHANNEL, 1-17 TO ALLOCATE THAT SPECIFIC CHANNEL
;RETURN: T1 = CHANNEL NUMBER ALLOCATED. NONSKIP RETURN IF NO FREE CHANNELS
;ALCHN: JUST FINDS A FREE CHANNEL
;RETURN: T1 = CHANNEL NUMBER. NONSKIP RETURN IF NO FREE CHANNELS
FENTRY (ALCHN)
PUSHJ P,%SAVAC ;SAVE USER'S ACS
MOVE T1,@0(L) ;GET USER'S ARG
TDNE T1,[-20] ;IF NEGATIVE OR OVER 17, ERROR
JRST ALCHNX
PUSHJ P,%ALCHF ;TRY TO ALLOCATE CHANNEL
ALCHNX: SETO T1, ;CAN'T
MOVEM T1,@AU.ACS ;STORE FOR USER
POPJ P, ;RETURN
%ALCHF: JUMPN T1,ALCHN1 ;IF SPECIFIC REQUEST, GO TRY TO ALLOCATE IT
ALCHN: MOVE T0,%CHMSK ;GET ALLOCATED CHANNEL MASK
JFFO T0,ALCHN1 ;FIND FIRST FREE CHANNEL
POPJ P, ;NONE, ERROR RETURN
ALCHN1: MOVNI T3,(T1) ;GET SHIFT COUNT FOR CHANNEL
MOVSI T2,(1B0) ;GET A 1 BIT
LSH T2,(T3) ;SHIFT INTO POSITION
TDNN T2,%CHMSK ;CHANNEL FREE?
POPJ P, ;NO, ERROR RETURN
ANDCAM T2,%CHMSK ;MARK IT ALLOCATED
JRST %POPJ1 ;SUCCESS RETURN
;DEALLOCATE CHANNEL
;THREE ENTRY POINTS:
;DECHN%: STANDARD FORTRAN CALLING SEQUENCE, ONE ARG POINTED TO BY L
; ARG = CHANNEL NUMBER TO DEALLOCATE
;RETURN: T0 = 0 IF DEALLOCATED OK, -1 IF CHANNEL WASN'T ALLOCATED
;%DECHF: T1 = CHANNEL NUMBER TO DEALLOCATE
;NONSKIP RETURN IF CHANNEL NOT ALLOCATED, SKIP RETURN IF OK
;DECHN: T1 = CHANNEL NUMBER TO DEALLOCATE
;INTERNAL ERROR HALT IF CHANNEL NOT ALLOCATED, NONSKIP RETURN IF OK
FENTRY (DECHN)
PUSHJ P,%SAVAC ;SAVE USER'S ACS
MOVE T1,@0(L) ;GET ARG
TDNE T1,[-20] ;RANGE CHECK
JRST DECHNX ;ILLEGAL CHANNEL, ERROR
PUSHJ P,%DECHF ;DEALLOCATE THE CHANNEL
DECHNX: SKIPA T1,[-1] ;CAN'T
SETZ T1, ;CAN, DID
MOVEM T1,@AU.ACS ;STORE FOR RETURN TO USER
POPJ P, ;RETURN
DECHN: PUSHJ P,%DECHF ;DEALLOCATE CHANNEL
$SNH ;NOT ALLOCATED, ERROR
POPJ P, ;RETURN
%DECHF: MOVNI T1,(T1) ;GET SHIFT COUNT
MOVSI T2,(1B0) ;GET A 1 BIT
LSH T2,(T1) ;SHIFT INTO POSITION
TDNE T2,%CHMSK ;CHANNEL ALLOCATED?
POPJ P, ;NO, ERROR
IORM T2,%CHMSK ;DEALLOCATE IT
JRST %POPJ1 ;SUCCESS
SEGMENT DATA
%CHMSK: BLOCK 1 ;BIT 1B<N> ON IF CHAN N FREE
SEGMENT CODE
>;END IF10
IF20,<
FENTRY (ALCHN)
SETO T0, ;NO CHANNELS AVAILABLE ON -20
%ALCHF: POPJ P, ;SAY SO AND RETURN
FENTRY (DECHN)
SETO T0, ;NO CHANNEL CAN BE ALLOCATED
%DECHF: POPJ P, ;ERROR RETURN
>;END IF20
SUBTTL INQUIRE
FENTRY (INQ)
$ECALL INI,%ABORT ;?INQUIRE not implemented
SEGMENT DATA
IF20,<
CSB: BLOCK 12 ;COMMAND STATE BLOCK
JFNBLK: BLOCK .GJATR+1 ;GTJFN ARG BLOCK
FDB: BLOCK 1+.FBSIZ ;FDB, UP THROUGH FILE SIZE
SWTDDB: BLOCK 2 ;FLDDB FOR SWITCHES
>;END IF20
SAVEP: BLOCK 1 ;TEMP FOR STACK POINTER
PFXCHR: BLOCK 1 ;FIRST CHAR OF ERROR MESSAGE
LTEXT==100
TXTBUF: BLOCK LTEXT ;TEXT BUFFER
LATOM==40
ATMBUF: BLOCK LATOM ;ATOM BUFFER
%IONAM:: BLOCK 1 ;ADDRESS OF ASCIZ STATEMENT NAME
%OPNK1:: BLOCK 1 ;FIRST CONFLICTING SWITCH NUMBER
%OPNV1:: BLOCK 1 ;FIRST CONFLICTING SWITCH VALUE
%OPNK2:: BLOCK 1 ;SECOND CONFLICTING SWITCH NUMBER
%OPNV2:: BLOCK 1 ;SECOND CONFLICTING SWITCH VALUE
FORPRG
END