Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-ots-debugger/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 ,6(2033)
;COPYRIGHT (C) 1981 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;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.
***** End Revision History *****
\
FSRCH
SEARCH QSRMAC
IF20,< SEARCH GLXMAC >
ENTRY OPEN%,CLOSE%,RELEA%,ALCHN%,DECHN%,INQ%
INTERN EXIT1%,%EXIT1
INTERN %ALCHN,%DECHN
INTERN %SETIN,%SETOUT,%CHKNR
IF10,< INTERN %CHMSK,%CLSER,%ST10B,%CALOF >
IF20,< INTERN %OCCOC,%CCMSK,%CLSOP >
INTERN %TERR,%TIOS,%TEND
INTERN %OPENX,%LSTBF
IF10,< INTERN %ARGNM > ;name of arg for ERROR
EXTERN %POPJ,%POPJ1,%POPJ2
EXTERN %SAVE1,%SAVE2,%SAVE3,%SAVE4,%SAVE,%PUSHT,%POPT
EXTERN %GTBLK,%FREBLK,%GTPGS,%FREPGS
EXTERN %IREC,%OREC,%OCRLF
IF20,< EXTERN %PTOF,%FTOP >
EXTERN %CRLF,G.EFS,G.FERR
EXTERN %ABORT
EXTERN %DDBTAB,%UDBAD,I.PID,%SIZTB,I.FLAG
EXTERN D.TTY,U.ERR,U.ACS,U.PDL
IF10,< EXTERN G.PPN,%RANWR,I.MVER,%CLRBC,%BACKB,%BAKEF,%ISET >
IF20,< EXTERN G.LJE >
EXTERN %ERRST,%EMSGT,%FOREC,%ERSVV,%ERRRS
EXTERN %LTYPE
EXTERN %SETD,%SETAV
EXTERN U.RERD
IF20,< EXTERN DBSTP.> ;Close out DBMS databases
SEGMENT CODE
SUBTTL OPEN
SIXBIT /OPEN./
OPEN%: PUSHJ P,%SAVE ;SAVE USER'S ACS, COPY ARG LIST
XMOVEI T1,[ASCIZ /OPEN/] ;SET STATEMENT NAME FOR ERROR MESSAGES
MOVEM T1,%IONAM
PUSHJ P,OPNCNV ;CONVERT OLD ARG BLOCK FORMAT
;Get TUNIT= unit #, %TERR= "ERR=" address, %TIOS= "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,%TIOS ;Any IOSTAT variable?
SETZM (T1) ;Yes, initialize to zero
; See if unit is already OPEN, if so do a CLOSE.
OPENA0: SKIPE U,%DDBTAB(T2) ;Get unit block, skip if not OPEN
PUSHJ P,CLZUNT ;Close it
;(Errors take ERR= branch)
;Unit is now closed and deallocated.
;Get a new one.
OPENA1: MOVEI T1,ULEN ;Length of a unit block
PUSHJ P,%GTBLK ;Allocate it
MOVE U,T1 ;Point to empty unit block
MOVE T2,TUNIT ;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
;Set ERR= and IOSTAT= in the unit block
MOVE T1,%TERR ;Set ERR=
MOVEM T1,ERRAD(U)
MOVE T1,%TIOS ;Set IOSTAT=
MOVEM T1,IOSAD(U)
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,CKSCRT ;See if he specified STATUS='SCRATCH'
;if so, filename is not allowed.
PUSHJ P,DFBSTS ;Set defaults based on STATUS
; (probably FORnn.DAT)
TXNN F,F%DSTRG ;"DIALOG='string'" seen?
JRST OPENA2 ;No
PUSHJ P,DLGSTR ;Yes, do it
; (possibly take ERR= branch)
TXZ F,F%DSTRG!F%INDST ;Clear flag if set
PUSHJ P,CKSCRT ;Check STATUS='SCRATCH' conflict
PUSHJ P,DFBSTS ;Set defaults based on STATUS
OPENA2: PUSHJ P,CHKDLG ;Go do DIALOG if necessary
PUSHJ P,CKSCRT ;Check STATUS='SCRATCH' conflict
;OPEN args all read in (including "DIALOG" if specified).
OPENA3: 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
;Return from OPEN
PJRST %SETAV ;Set AVAR if given; clear ERRAD, etc.
; in UDB; return from OPEN.
;%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,CNFDEV ;Check conflicts with device type
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 ;* UNKNOWN ACCESS TYPE *
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,BLNK(U)
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:
; TUNIT/ 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,TUNIT ;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
;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: MOVE D,DDBAD(U) ;Get old DDB block
MOVE T1,%TERR ; Use ERR= from open
MOVEM T1,ERRAD(U)
MOVE T1,%TIOS ; Use IOSTAT= from open
MOVEM T1,IOSAD(U)
PJRST %CLOSE ;Go close it and return.
;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 (ISW,30,506,?,Incompatible attributes /$Z$Z /$Z$Z,<%OPNK1,%OPNV1,%OPNK2,%OPNV2>,REQDIA)
$ECALL ISW,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 TUNIT, %TERR, and %TIOS respectively.
;
;Called by OPEN% and CLOSE%
;
;Inputs:
; L points to argument list
;Uses T1, T2, T3
;Leaves L intact
FNDAGL: SETZM %TERR ;Not specified yet..
SETZM %TIOS
;"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 @%LTYPE,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 unit is a constant
LDB T3,[POINTR @%LTYPE,ARGTYP]
CAIE T3,0 ;Is it a constant?
MOVE T2,@0(L) ;No, get it
MOVEM T2,TUNIT ;Store UNIT= arg.
MOVE L,T1 ;Restore L
;Find ERR= and IOSTAT= if specified.
FAGL2A: LDB T2,[POINTR @%LTYPE,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,%TERR ;save it
JRST FAGL2E
;IOSTAT=
FAGL2C: XMOVEI T2,@0(L) ;Get address
MOVEM T2,%TIOS ;Save it
JRST FAGL2E ;Continue
SEGMENT DATA
;Stuff from OPEN and CLOSE arg list
%TERR: BLOCK 1 ;ERR= from arg list
%TIOS: BLOCK 1 ;IOSTAT= from arg list
TUNIT: BLOCK 1 ;UNIT= from arg list
%TEND: BLOCK 1 ;END=
SEGMENT CODE
;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
;OPNIN - Open file for input
; This is called from IO statements (but not OPEN) to open
;a file for input. The file must exist.
OPNIN:
IF20,< MOVX T1,GJ%OLD> ;"File must exist"
PJRST OPCMI ;Go to common input 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,DMBS(D)
OPENF%
ERJMP OTME02 ;?Can't
JRST OPSCRA
OPSCR: MOVX T2,OF%RD+OF%WR ;Get initial bits for OPENF
OR T2,DMBS(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 ;(D%IO may have been set by OPENX for TTYs,
MOVEM T1,FLAGS(D) ; even if the statement was "READ")
;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> ;File must exist
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: MOVE T1,WSIZ(D) ;GET WINDOW SIZE
SUB T1,ICNT(D) ;GET # ACTIVE BYTES
SKIPE IPTR(D) ;IF WE WROTE ANY DATA
MOVEM T1,WCNT(D) ;PRETEND WE READ THEM
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.
;FOR DISK AND MAGTAPE, TRUNCATE FILE AT CURRENT INPUT POINTER,
;OPEN FOR OUTPUT, AND COPY THE DATA INTO THE OUTPUT BUFFER.
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
IF20,<
DSKOSW: MOVE T1,FLAGS(D) ;GET FLAGS
TXZE T1,D%END ;END OF FILE?
SOS NREC(D) ;YES. DECR THE RECORD COUNT
MOVEM T1,FLAGS(D) ;SAVE FLAGS WITHOUT EOF
PUSHJ P,%SAVE3 ;SAVE P ACS
SKIPN IPTR(D) ;Any IO done yet?
JRST CHKWRT ;Maybe REWIND just done..
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
MOVE T1,WSIZ(D) ;YES. GET SIZE OF WINDOW
SUB T1,WCNT(D) ;GET # UNUSED BYTES IN WINDOW
ADDM T1,OCNT(D) ;RESTORE FULL WINDOW SIZE
MOVE T1,FLAGS(D) ;Get DDB flags now
CHKWRT: TXNN T1,D%WRT ;Do we have WRITE access?
PUSHJ P,CLSOUT ;No, CLOSE, reopen for OUTPUT
MOVX T1,D%WRT ;We have WRITE access now
IORM T1,FLAGS(D)
POPJ P, ;Return
CLSOUT:
SETO T1, ;SET TO UNMAP FILE FOR CLOSING
MOVE T2,WTAB(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,DMBS(D) ;GET DATA MODE AND BYTE SIZE
TRO T2,OF%RD+OF%WR ;GET READ+WRITE ACCESS
OPENF% ;REOPEN FILE
; IOERR (OSW,30,,?,$J,,%ABORT) ;CAN'T
$ECALL OSW,%ABORT
HRRZ P1,IPTR(D) ;GET PROCESS ADDRESS OF FILE POINTER
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
PUSH P,P1 ;SAVE FILE POSITION
MOVE P1,(P) ;GET FILE ADDRESS BACK
PUSHJ P,%FTOP ;MAP IT
ADDI P1,1 ;MAPW LEFT US AT ADDR-1
SUBI P2,1 ;AND WITH CURRENT WORD AS AVAILABLE
HRRM P1,IPTR(D) ;STORE ADDRESS IN FILE POINTER
POP P,P1 ;GET FILE ADDRESS ONE MORE TIME
ADDI P1,1(P2) ;GET WORD NUMBER OF END+1 OF WINDOW
LOAD T1,BPW(D) ;GET BYTES PER WORD
IMULI P1,(T1) ;GET BYTE NUMBER OF END+1 OF WINDOW
MOVEM P1,BYTN(D) ;STORE FOR NXTW
CAIG T1,1 ;UNFORMATTED? (1 BYTE PER WORD)
JRST [MOVEM P2,ICNT(D) ;YES, STORE WORDS LEFT
POPJ P,]
HLL P2,IPTR(D) ;PUT LH OF BYTE POINTER INTO P2
MULI P2,(T1) ;CONVERT BYTE POINTER TO BYTE COUNT IN RH(P3)
ADDI P3,(P2) ;ADD # BYTES LEFT IN WORD
HRRZM P3,ICNT(D) ;STORE NUMBER OF BYTES LEFT IN WINDOW
POPJ P, ;DONE
ZERPNT: SETZM IPTR(D) ;CLEAR PNTR/COUNT
SETZM ICNT(D)
POPJ P,
> ;IF20
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,OSWDEL ;YES. DELETE FILE
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,BUFAD(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,OSWDEL ;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
MOVEI T1,1 ;START RECORD COUNTER FRESH ALSO
MOVEM T1,NREC(D)
POPJ P,
YESBAK: PUSHJ P,%BAKEF ;BACK OVER EOF
SOS NREC(D) ;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
LOAD T2,BPW(D) ;GET THE # BYTES/WORD
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
IMULI T1,(T2) ;GET THE # BYTES IN THIS BUFFER
SUB T1,ICNT(D) ;GET THE # BYTES USED
MOVEM T1,PATCNT ;SAVE FOR LATER
LOAD T2,MODE(D) ;GET FILE MODE
CAIE T2,MD.ASC ;ASCII?
JRST WORDS ;NO
MOVE T2,IPTR(D) ;GET BYTE PNTR
SETZ T3, ;WE HAVE TO CLEAR SOME BYTES(ARGH!!!)
ZBYTLP: TLNN T2,760000 ;LAST BYTE?
JRST DEPBP
IDPB T3,T2 ;NO. DEPOSIT A NULL
JRST ZBYTLP ;THIS WILL NOT WORK FOR XTENDED ADDRESS
DEPBP: MOVEM T2,IPTR(D) ;SAVE THE NEW B.P.
WORDS: 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,
OSWDEL: LOAD T1,INDX(D) ;GET DEVICE INDEX
CAIE T1,DI.DSK ;DISK?
POPJ P, ;NO. DON'T DELETE THE MAGTAPE
MOVEI T1,.FODLT ;DELETE THE 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
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 ;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
MOVE T1,WSIZ(D) ;GET WINDOW SIZE
SUB T1,ICNT(D) ;GET # ACTIVE BYTES
SKIPE IPTR(D) ;IF WE WROTE ANY DATA
MOVEM T1,WCNT(D) ;PRETEND WE READ THEM
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
XMOVEI T1,(P1) ;GET JUST ADDRESS OF LAST DATA
CAMGE T1,WADR(D) ;ANY DATA IN WINDOW?
JRST LSBCLS ;NO. JUST WRITE EOF MARK
LOAD T1,IJFN(D) ;GET JFN
HRRO T2,WADR(D) ;GET BUFFER ADDR
MOVE T3,FLAGS(D) ;Unformatted?
TXNE T3,D%UNF ; ?
HRLI T2,(POINT 36) ;YES. GET 36-BIT PNTR
MOVN T3,WSIZ(D) ;GET WINDOW SIZE
JUMPLE P2,.+2 ;IF MIDDLE OF WINDOW, DECREMENT BYTE COUNT
ADD T3,P2
SOUTR% ;OUTPUT THE 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,DMBS(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 BLKN(D) ;IF IT WAS EOF, NEW FILE!
MOVEI T1,1 ;SET RECORD NUMBER FRESH ALSO
MOVEM T1,NREC(D)
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%
MOVE T1,WSIZ(D) ;GET WINDOW SIZE
SUB T1,WCNT(D) ;GET UNUSED BYTES IN WINDOW
ADDM T1,OCNT(D) ;RESTORE FULL WINDOW SIZE
MTACLO: LOAD T1,IJFN(D) ;REOPEN FILE FOR OUTPUT
HRLI T1,(CO%NRJ)
CLOSF%
$ECALL OSW,%ABORT
LOAD T1,OJFN(D)
MOVE T2,DMBS(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 @%LTYPE,ARGKWD] ;GET NEXT ARG KEYWORD
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 @%LTYPE,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: 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: SKIPA T2,[1] ;GET A TURNED-ON BIT
OPNCHR: LDB T2,[POINT 7,@(L),6] ;GET FIRST CHAR OF STRING
OPNDPB: XCT OPSTOR(P1) ;STORE IN DDB
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,<
MOVE T1,ATMBUF ;Put in DEV(D)
MOVEM T1,DEV(D)
>
IF20,<
MOVE T1,[POINT 7,ATMBUF]
MOVE T2,[POINT 7,DEV(D)]
ILDB T3,T1
IDPB T3,T2
JUMPN T3,.-2
>
TXO F,F%DSS ;Remember device specified
POPJ P, ;Return
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]
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,< ;to be fixed later..
OPNFIL: TXO F,F%FSS ;Remember filespec stuff supplied
XMOVEI T1,FILE(D) ;POINT TO PLACE TO PUT FILENAME
MOVX T2,1_'.' ;TERMINATE ON DOT
PUSHJ P,MVARGX ;MOVE FILENAME TO DDB
CAIE T1,"." ;WAS IT TERMINATED BY DOT?
POPJ P, ;NO, THAT'S IT
TXO F,F%EXT ;REMEMBER EXTENSION SPECIFIED
XMOVEI T1,EXT(D) ;POINT TO PLACE FOR EXTENSION
MOVX T2,1_'.' ;TERMINATE ON DOT
PUSHJ P,MOVARG ;MOVE EXT TO DDB
IF20,<
CAIE T1,"." ;GENERATION NUMBER SPECIFIED?
POPJ P, ;NO, DONE
XMOVEI T1,ATMBUF ;POINT TO DEST FOR GENERATION NUMBER
PUSHJ P,MOVARG ;MOVE IT THERE
MOVEI T1,ATMBUF ;POINT TO IT AGAIN
PUSHJ P,ASCDEC ;CONVERT IT TO BINARY
; ERR (IGN,?,Illegal generation number $A,<0(L)>)
$ECALL IGN,REQDIA
JUMPL T1,GENNOK ;Jump if -n
TLNE T1,-1 ;IN RANGE?
$ECALL IGN,REQDIA ;No
GENNOK: HRRZM T1,xGEN(D) ;Store in DDB
>
POPJ P, ;DONE
>;END IF20 to be done later..
IF10,<
OPNFIL: PUSHJ P,MAKEBP ;Setup SRCBP
PUSHJ P,PRSFIL ;Parse the file info
JRST REQDIA ;?Error, request dialog
POPJ P, ;Ok, return
PRSFIL: PUSHJ P,DPRFNM ;Parse filename
POPJ P, ;?failed
MOVE T2,ATMBUF ;Get atom (sixbit filename)
MOVEM T2,FILE(D) ;Store filename
TXO F,F%FSS ;Remember filespec stuff
CAIE T1," " ;Space
CAIN T1,0 ; or null
JRST %POPJ1 ;means we're done.
CAIE T1,"." ;Must be "." then
$SNH
TXO F,F%EXT ;Remember extension specified
PUSHJ P,DPRFEX ;Parse extension
POPJ P, ;?Ill char
HLLZ T2,ATMBUF ;Get atom (sixbit ext.)
HLLZM T2,EXT(D) ;Store it
JRST %POPJ1 ;Return ok
;Parse a filename
DPRFNM: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF ;Ready for filename
DPRFN1: PUSHJ P,DPRCHS ;Get char
JUMPE T1,%POPJ1 ;Null ok end
CAIE T1," " ;Also space
CAIN T1,"." ; and dot (start of ext.)
JRST %POPJ1 ;Done
PUSHJ P,DPRCSX ;Else must be sixbit
POPJ P, ;?no, error
TLNE T3,770000 ;Store char if we can
IDPB T1,T3
JRST DPRFN1 ;Loop
;Parse a file extension
DPRFEX: MOVE T3,[POINT 6,ATMBUF]
SETZM ATMBUF ;Ready for filename
DPRFX1: PUSHJ P,DPRCHS ;Get char
CAIE T1," "
CAIN T1,0 ;Space or null ok
JRST %POPJ1
PUSHJ P,DPRCSX ;Else must be sixbit
POPJ P, ;?no, error
TLNE T3,770000 ;Room?
IDPB T1,T3 ;Yes, store char
JRST DPRFX1 ;Loop
>;END IF10
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
AOS (L) ;BUMP TO SECOND WORD
HRR T1,@(L) ;PUT IN 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,%SAVE3 ;SAVE P1-P2
LDB T1,[POINTR @%LTYPE,ARGTYP] ;GET ARG TYPE
CAIN T1,TP%LIT ;ASCIZ LITERAL?
JRST OPPNST ;YES
MOVE P1,%SIZTB(T1) ;GET ELEMENT SIZE IN WORDS
MOVE T1,@(L) ;GET FIRST WORD OF ARG
TLNE T1,-1 ;PROJECT NUMBER IN LH?
JRST OPNPP1 ;YES, XWD FORMAT
HRLZ T1,T1 ;NO, DOUBLEWORD FORMAT
AOS (L) ;BUMP TO SECOND WORD
HRR T1,@(L) ;PUT IN PROGRAMMER NUMBER
OPNPP1: JUMPE T1,%POPJ ;ZERO MEANS DEFAULT PATH
MOVEM T1,PTHB+.PTPPN(D) ;STORE PPN
MOVEI P2,.PTPPN+1 ;POINT TO PLACE FOR FIRST SFD
MOVEI P3,5 ;Max # SFD's.
AOSA (L) ;BUMP PAST PPN WORD
OPPNLP: ADDM P1,(L) ;BUMP TO NEXT ARGUMENT
SKIPN @(L) ;END OF LIST?
POPJ P, ;YES, DONE
XMOVEI T1,PTHB(D) ;POINT TO PATH BLOCK
ADDI T1,(P2) ;POINT TO DEST FOR SFD NAME
PUSHJ P,MVARG ;MOVE SFD NAME INTO PATH BLOCK
SOJLE P3,%POPJ ;If done 5 SFD's, return now.
AOJA P2,OPPNLP ;COPY WHOLE THING
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,
>
OPNDIA: XMOVEI P3,@0(L) ;Get arg address
JUMPE P3,RQDIAX ;IF DIALOG WITHOUT ARGUMENT, GO REQUEST DIALOG
TXO F,F%DSTRG ;SET DIALOG FROM STRING
MOVEM P3,DIASAG ;Save DIALOG string arg.
LDB T1,[POINTR @%LTYPE,ARGTYP] ;Get arg type
MOVEM T1,DIASAT ;Save arg type
POPJ P, ;Return for more args.
IF20,<
;PUSHJ HERE AFTER CSB INITIALIZED TO MOVE DIALOG ARG TO TEXTI BUFFER
DIABLT: $BLDBP P3 ;Get 7-bit byte ptr in P3
MOVEM P3,SRCBP ;Store BP to arg
MOVEI P4,LTEXT*5-1 ;MAX STRING LENGTH IS SIZE OF BUFFER
XMOVEI T1,TXTBUF ;POINT TO BUFFER
MOVX T2,1_' ' ;DIALOG STRING IS TERMINATED BY SPACE
MOVE T3,DIASAT ;Get arg type
CAIN T3,TP%LIT ;IS IT ASCIZ?
SETZ T2, ;YES, IT CAN INCLUDE IMBEDDED SPACES
PUSHJ P,MOVARG ;MOVE ARG TO BUFFER
JUMPGE T2,.+2 ;DID MOVARG TERMINATE NORMALLY?
; ERR (DTL,?,Dialog string too long) ;NO
$ECALL DTL ;?Dialog string too long
MOVEI T1,12 ;OVERWRITE TERMINATING NULL WITH A LF
DPB T1,DSTBP ; TO STOP COMND JSYS
SUBI P4,LTEXT*5 ;CALCULATE NUMBER OF CHARS IN STRING
MOVNM P4,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 P3 = 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: XMOVEI T0,@0(L) ;Point to arg
$BLDBP T0 ;Get a byte ptr.
MOVEM T0,SRCBP ;Store in SRCBP.
SETZM %NCHRR ;Clear char counter
LDB T0,[POINTR @%LTYPE,ARGTYP] ;GET ARG TYPE
MOVEI P4,^D10 ;GUESS DOUBLEWORD, 10 CHARS
CAIL T0,TP%DPR ;IS IT DOUBLE?
CAILE T0,TP%CPX
MOVEI P4,^D5 ;NO, SINGLE IS 5 CHARS
CAIN T0,TP%LIT ;LITERAL STRING?
MOVEI P4,^D79 ;YES, ONLY LIMIT IS SIZE OF DEST BUFFER
POPJ P, ;DONE
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)
IF10,<
%ARGNM:: BLOCK 1 ;Addr of ASCII name of arg.
>
DIASAG: BLOCK 1 ;Address of DIALOG='string'
DIASAT: BLOCK 1 ;Arg type for DIALOG='string' arg.
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 @%LTYPE,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 @%LTYPE,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
PUSH P,L
ADDI L,2 ;Point to /ERR arg
DPB T1,[POINTR @%LTYPE,ARGKWD] ;Store /ERR keyword
POP P,L
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 @%LTYPE,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.
&
;ROUTINE TO PUT DEFAULT FIELDS INTO A DDB
;ARGS: D = DDB ADDRESS
;(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,DFDIR ; DIRECTORY
; PUSHJ P,DFFILE ; FILENAME
PUSHJ P,DFBUF ; BUFFER COUNT
PUSHJ P,DFMODE ; MODE [CAN IMPLY /FORM, /TAPEMODE]
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 NOT SET ABOVE]
POPJ P, ;DONE
;*** 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
LOAD T3,ACC(D) ;Get ACCESS
CAIN T3,AC.APP ;APPEND?
CAIN T1,.DVMTA ;Yes, not tape?
JRST .+2 ;No
MOVEI T2,DI.OTHR ;Append and non-tape, use SOUTS
STORE T2,INDX(D) ; . .
JRST %POPJ1 ;No error--Skip return
DFDIR: 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.
DFDIR==%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
; IOERR (NSD,30,245,?,No such device $S,<DEV(D)>,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: LOAD T1,FORM(D) ;DEFAULT IS /FORM:FORMATTED
JUMPN T1,DFFRM1 ;Already set
MOVEI T1,FM.FORM
STORE T1,FORM(D)
DFFRM1: MOVE T2,FLAGS(D) ;Get DDB flags
CAIN T1,FM.FORM ;Formatted?
TXZA T2,D%UNF ;Yes, clear "unformatted" flag
TXO T2,D%UNF ;No, set "unformatted" flag
MOVEM T2,FLAGS(D) ;Store updated flags
POPJ P,
DFMODE: LOAD T1,MODE(D) ;GET FILE MODE
JUMPN T1,DFMOD0 ;IF SET, NO DEFAULT
MOVEI T1,1 ;SET FLAG XMODE TO REMEMBER WE DEFAULTED MODE
STORE T1,XMODE(D)
LOAD T1,FORM(D) ;GET /FORM
CAIN T1,FM.UNF ;/FORM:UNFORMATTED?
SKIPA T1,[MD.BIN] ;UNFORMATTED, DEFAULT IS /MODE:BINARY
MOVEI T1,MD.ASC ;FORMATTED, DEFAULT IS /MODE:ASCII
STORE T1,MODE(D) ;SET DEFAULT
DFMOD0: CAIE T1,MD.EBC ;/MODE:EBCDIC?
JRST DFMOD1 ;NO
MOVEI T2,TM.IND ;YES, IMPLIES /TAPEMODE:INDUSTRY
STORE T2,TAPM(D)
DFMOD1: CAIL T1,MD.ASC ;ASCII OR GREATER IMPLIES /FORM:F
JRST SETFORM
CAIL T1,MD.BIN ;BINARY OR GREATER IMPLIES /FORM:U
JRST SETUNF
;8-SEP-81 /DAW /MODE:IMAGE IMPLIES /FORM:UNF
; LOAD T1,FORM(D) ;ONLY THING LEFT IS /MODE:IMAGE
; JUMPN T1,%POPJ ;IF USER SPECIFIED /FORM, USE THAT
MOVEI T1,FM.UNF ;OTHERWISE /MODE:IMAGE IMPLIES /FORM:U
STORE T1,FORM(D)
POPJ P,
SETUNF: SKIPA T1,[FM.UNF] ;GET /FORM:U
SETFORM: MOVEI T1,FM.FORM ;GET /FORM:F
MOVEI T2,(T1) ;SET IT TO IMPLIED FORMAT
STORE T2,FORM(D)
POPJ P, ;Return
;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, IN CASE NON-TERMINAL
FIXDEF: MOVE T2,FLAGS(D) ;T2= DDB flags to update
IF10,<
MOVE T1,DEV(D) ;GET DEV AGAIN
DEVTYP T1, ;GET DEVTYP (AGAIN)
SETZ T1,
TXNE T1,TY.INT ;INTERACTIVE?
TXO T2,D%INT ;Yes, set flag
> ;IF10
LOAD T1,FORM(D) ;GET /FORM
CAIN T1,FM.UNF ;UNFORMATTED?
TXO T2,D%UNF ;Yes, file is now officially unformatted
LOAD T1,MODE(D) ;GET /MODE
CAIN T1,MD.BIN ;BINARY?
TXO T2,D%BIN ;YES, FLAG THAT TOO
MOVEM T2,FLAGS(D) ;Done with flags, free up T2
LOAD T1,BPW(D) ;IS BYTES/WORD NON-ZERO ALREADY?
JUMPN T1,GOTBPW ;YES. DON'T TOUCH IT
LOAD T1,MODE(D) ;GET FILE MODE
LDB T1,MODBYT ;GET BYTE SIZE
MOVEI T2,^D36 ;DIVIDE INTO 36 TO GET # BYTES/WORD
IDIVI T2,(T1)
STORE T2,BPW(D) ;MIGHT BE RECALCULATED AT READ/WRITE TIME
MOVE T1,T2 ;Put in T1
;Here with # of bytes/word in T1.
GOTBPW:
IF10,< MOVE T2,SIZ(D) ;Incase this is an input file,
IMUL T2,T1 ; get number of bytes and store in EOFN.
MOVEM T2,EOFN(D)
>;END IF10
MOVE T1,RSIZE(D) ;GET RECORD SIZE
JUMPE T1,NOSIZE
LOAD T3,BPW(D) ;GET # BYTES/WORD
LOAD T2,MODE(D) ;GET FILE MODE
CAIN T2,MD.ASL ;LINE-SEQUENCED ASCII?
ADDI T1,6 ;YES. ADD 6 FOR LSN AND TAB
CAIE T2,MD.IMG ;IMAGE?
ADDI T1,1(T3) ;NO. ADD IN FOR CRLF & NULLS, OR LSCW'S
IDIVI T1,(T3) ;GET # WORDS
STORE T1,RSIZW(D) ;STORE RECORD SIZE IN WORDS
repeat 0,<
NOSIZE: SKIPN T1,RSIZE(D) ;GET RECORD SIZE AGAIN
MOVEI T1,^D72 ;NO RECORD SIZE, LINES ARE 72 COLS
LOAD T2,TTYW(D) ;GET LINE SIZE
CAIN T2,0 ;ALREADY SET? (TERMINALS SET BY TTYSET)
STORE T1,TTYW(D) ;NO, SET DEFAULT LINE SIZE
>
NOSIZE: SKIPN T1,RSIZE(D) ;GET RECORD SIZE AGAIN
LOAD T1,TTYW(D) ; DEFAULT FROM TTYSET IF TERMINAL
CAIN T1,0 ;DO WE HAVE A VALUE?
MOVEI T1,^D72 ; NOW WE DO
STORE T1,TTYW(D) ;SET IT
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: MOVEI T1,1 ;INIT RECORD NUMBER TO 1
MOVEM T1,NREC(U)
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 <^D39+1>/5 ;Up to 39 characters in device name
SEGMENT CODE
>;END IF20
SUBTTL DIALOG SCANNER
IF20,<
DLGSTR: MOVE P3,DIASAG ;Get DIALOG='string' arg ptr.
TXO F,F%INDST ;Set flag saying we're now doing DIALOG='string'
DIALOG: PUSHJ P,SAVERR ;DIVERT ERR MSGS TO TTY
TXNE F,F%INDST ;DIALOG FROM STRING?
JRST DIASK1 ;YES, SKIP PREFIX
SKIPN G.EFS ;SKIP IF PREFIX ALREADY TYPED
; IOERR (EFS,,,[,Enter correct file specs)
$ECALL EFS
SETOM G.EFS ;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?
HLLOM JFNBLK+.GJGEN ;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).
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
DLGSTR: MOVE P3,DIASAG ;Get DIALOG='string' arg.
TXO F,F%INDST ;Set flag saying we're now doing DIALOG='string'
XMOVEI T1,[ASCIZ/DIALOG=/]
SKIPA
DIALOG: XMOVEI T1,[ASCIZ/DIALOG/]
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
SKIPN G.EFS ;SKIP IF ALREADY TYPED ONCE
; IOERR (EFS,,,[,Enter correct file specs)
$ECALL EFS
SETOM G.EFS ;SUPPRESS NEXT TIME
RESCN: 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
DIABLT: MOVEM P3,SRCBP
MOVE P3,[POINT 7,(P3)] ;Make pointer to arg
EXCH P3,SRCBP
MOVEI P4,LTEXT*5-1 ;MAX STRING LENGTH IS SIZE OF BUFFER
MOVE T2,[POINT 7,TXTBUF] ;POINT TO BUFFER
MOVE T3,DIASAT ;Get arg type
DIABL1: ILDB T1,SRCBP ;GET BYTE FROM ARG
JUMPE T1,DIABL3 ;NULL, DONE
CAIE T1," " ;SPACE?
JRST DIABL2 ;NO
CAIN T3,TP%LIT ;LITERAL ARG?
JRST DIABL1 ;YES, SUPPRESS SPACE
JRST DIABL3 ;NO, TERMINATES ARG
DIABL2: IDPB T1,T2 ;STORE CHAR
SOJG P4,DIABL1 ;LOOP
; IOERR (DTL,,,?,Dialog string too long)
$ECALL DTL,RESCN
DIABL3: 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%OLD or GJ%NEW or GJ%FOU
; PUSHJ P,DOOPEN
; <return here if error, f%DRE set>
; <return here if ok>
IF20,<
DOOPEN: MOVEM T1,GJBTS ;Save GTJFN bits
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 GJERR ;Failure return
;Here when got real JFN in T1
DOOPN1: 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 DMBS, 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,DMBS(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
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,FIXDEF ;Defaults after everything is in place.
PUSHJ P,FIXU ;Fixup this unit block
PUSHJ P,DOCONS ;Do consolidation of DDB's if necessary
TXNE F,F%CTTY ;Is this the controlling TTY:?
MOVEM D,D.TTY ;Yes, store the TTY's DDB address
JRST %POPJ1 ;Skip return
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
JUMPN T2,%POPJ ;LEAVE IF GOT ANY
MOVX T2,OF%RD ;NONE. TRY READ
MOVE T0,FLAGS(D) ;Get DDB flags
TXNE T0,D%IO ;UNLESS WE'RE WRITING
MOVX T2,OF%WR
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 DMBS, BPW based on /MODE
GMODBY: LOAD T1,MODE(D) ;GET /MODE
MOVE T1,MODTAB(T1) ;GET DATA MODE, BYTE SIZE
TLZ T1,(OF%MOD) ;USE DATA MODE 0 FOR ALL FILES
MOVEM T1,DMBS(D) ;STORE IN DDB
MOVEI T1,^D36 ;GET WORD SIZE
LOAD T2,BSIZ(D) ;GET BYTE SIZE
IDIVI T1,(T2) ;CALC BYTES/WORD
STORE T1,BPW(D) ;SAVE IT
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
OPFERR: 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)
GJERR:; IOERR (OPE,30,,?,$J,,REQDIA) ;TYPE ERROR MESSAGE, TRY AGAIN
$ECALL OPE,REQDIA
;ROUTINE TO SET UP TERMINAL
TTYSET: MOVX T1,D%SICR+D%SILF ;Suppress initial CRLF for terminals
IORM T1,FLAGS(D) ; . .
LOAD T1,IJFN(D) ;GET JFN
RFCOC% ;SAVE CCOC WORDS FOR USE DURING TEXTI
DMOVEM T2,CCOC(D)
AND T2,%CCMSK ;SET CCOC FOR CORRECT OUTPUT
IOR T2,%OCCOC ;LEAVE ^I AND ^L AS THEY WERE, SET OTHERS
MOVE T3,%OCCOC+1 ; TO SEND LITERALLY
SFCOC%
MOVE T1,RSIZE(D) ;RECORD SIZE SPECIFIED?
JUMPN T1,%POPJ1 ;YES, IT WINS; DON'T OVERWRITE LINE WIDTH
LOAD T1,OJFN(D) ;GET JFN
MOVEI T2,.MORLW ;READ LINE WIDTH
MTOPR%
ERJMP [SETZ T3, ;CAN'T, MAKE A GUESS
JRST .+1]
CAIN T3,0 ;LINE WIDTH SET?
MOVEI T3,^D72 ;NO, GUESS 72
STORE T3,TTYW(D) ;STORE LINE SIZE FOR NAMELIST AND LIST-DIRECTED
JRST %POPJ1 ;DONE
; @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \ ] ^ _
%OCCOC: BYTE (2)1,2,2,2,2,2,2,2,2,0,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
%CCMSK: BYTE (2)0,0,0,0,0,0,0,0,0,3,0,0,3,0,0,0,0,0
;ROUTINE TO SET UP DISK
DSKSET: 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
LOAD T1,STAT(D) ;GET /STAT
CAIE T1,ST.OLD ;/STAT:OLD?
CAIN T1,ST.NEW ;OR /STAT:NEW?
JRST .+2 ;YES, MUST CHECK IT
JRST DSET1 ;NO
MOVE T2,FDB+.FBCTL ;GET FILE BITS
CAIN T1,ST.OLD ;/STAT:OLD?
TXC T2,FB%NXF ;YES, FILE MUST EXIST
DSET1: 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 NUMBER OF BITS IN A WORD
IDIVM T3,T1 ;GET OLD BYTES PER WORD
IDIVM T3,T2 ;AND NEW BYTES PER WORD
STORE T2,BPW(D) ;REMEMBER NUMBER OF BYTES PER WORD
MOVE T3,FDB+.FBSIZ ;GET NUMBER OF OLD BYTES IN THE FILE
MULI T3,(T2) ;CONVERT TO NUMBER OF NEW BYTES IN THE FILE
ADDI T4,-1(T1) ;ROUND UP
DIVI T3,(T1)
MOVEM T3,EOFN(D) ;STORE IN DDB
LOAD T1,BUFCT(D) ;GET BUFFER (PAGE) COUNT
PUSHJ P,%GTPGS ;ALLOCATE THAT MANY PAGES
$ECALL MFU,%ABORT ;?Can't, memory full
MOVE T0,FLAGS(D) ;Get DDB flags
TXNN T0,D%RAN ;Is this a RANDOM file?
jrst dset2 ;no
push p,t1
load t1,bufct(d) ;get page count
pushj p,%gtblk ;get a block for the page table
pop p,t2 ;get first page number in window
hrloi t2,(t2) ;get process page,,impossible file page
load t3,bufct(d) ;get count again
movni t3,(t3) ;negate
hrli t1,(t3) ;make aobjn pointer
move t3,t1 ;copy
dset3: movem t2,(t3) ;store process page,,file page
add t2,[1,,0] ;bump to next process page in window
aobjn t3,dset3 ;loop
HRRZM T1,WPTR(D) ;store
MOVEM T1,WTAB(D)
LOAD T1,BPW(D) ;GET BYTES/WORD
LSH T1,9 ;GET # BYTES IN A PAGE
MOVEM T1,WSIZ(D) ;STORE AS WINDOW SIZE
JRST %POPJ1 ;ALL SET
DSET2: MOVEM T1,WTAB(D) ;SAVE PAGE ADDRESS
ANDI T1,777 ;Just local section's page #
LSH T1,9 ; Save local CORE ADDRESS
MOVEM T1,WADR(D)
LOAD T1,BUFCT(D) ;GET BUFFER COUNT
LSH T1,9 ;GET WORD COUNT IN WINDOW
LOAD T2,BPW(D) ;GET # BYTES/WORD
IMULI T1,(T2) ;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)
STKVAR <LABINF,> ;GET TWO TEMP WORDS
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
MOVEI 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
UNSTK ;DISCARD TEMP VARS
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,MTARS ;NO EXPLICIT MODE
MOVEI T2,.MOSDM ;SET HARDWARE DATA MODE
MOVEI P1,[ASCIZ /data mode/]
MTOPR% ;SET IT
ERCAL MOPERR
MTARS: MOVEI T2,.MOSRS ;SET RECORD SIZE
LOAD T3,BLKSZ(D) ;GET FILE BLOCK SIZE
JUMPE T3,MTANRS ;IF SET
MOVEI P1,[ASCIZ /block size/]
MTOPR% ;SET IT
ERCAL MOPERR
MTANRS: MOVE T0,FLAGS(D) ;Get DDB flags
TXNN T0,D%APP ;Are we appending?
JRST MTANAP ;NO
MOVEI T2,.MOFWF ;FORWARD ONE FILE
MTOPR%
ERJMP APPERR
MOVEI T2,.MOBKR ;BACK OVER TAPE MARK
MTOPR%
ERJMP APPERR
MTANAP:
LABSKP: LOAD T1,IJFN(D) ;GET JFN
MOVEI T2,.MORRS ;READ RECORD SIZE
MTOPR%
ERJMP MOPERR ;SHOULDN'T EVER FAIL...
LOAD T2,BPW(D) ;GET # BYTES/WORD
ADDI T3,-1(T2) ;GET # WORDS, ROUNDED UP
IDIVI T3,(T2)
MOVEI T1,(T3) ;RECORD # WORDS
IMULI T3,(T2) ;GET CHARS AGAIN
MOVEM T3,WSIZ(D) ;SAVE AS WINDOW SIZE
PUSHJ P,%GTBLK ;ALLOCATE A BLOCK
MOVEM T1,WADR(D) ;SAVE THE ADDRESS OF THE BUFFER
JRST %POPJ1
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
LOAD T2,BPW(D) ;GET # BYTES/WORD
IMULI T2,(T1) ;GET # BYTES/BUFFER
MOVEM T2,WSIZ(D) ;STORE AS WINDOW SIZE
PUSHJ P,%GTBLK
MOVEM T1,WADR(D) ;STORE ADDRESS OF BUFFER
JRST %POPJ1 ;ALL SET
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%
TXZ F,F%PPN ;DIRECTORY IS NOW NOT A PPN
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
LOAD T1,MODE(D) ;Get /MODE
LDB T2,[POINT 4,MODTAB(T1),9] ;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
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,FIXDEF ;Defaults after everything is in place.
PUSHJ P,FIXU ;Fix unit block stuff too
PUSHJ P,DOCONS ;Do consolidation of DDB's if necessary
TXNE F,F%CTTY ;Is this the controlling TTY:?
MOVEM D,D.TTY ;Yes, store its DDB address.
JRST %POPJ1 ;Return success
;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,BUFAD(D) ;Deallocate buffer (if any)
JUMPE T1,OFCLN1 ; None
PUSHJ P,%FREBLK
SETZ T1,
STORE T1,BUFAD(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
HRRZ T1,WTAB(D) ;Get address of page table
HLRZ T1,(T1) ;Get number of first block
LSH T1,-2 ;Get first page # allocated
HLRE T2,WTAB(D) ;Get -# words
MOVN T2,T2 ;# words
LSH T2,-2 ;# pages
PUSHJ P,%FREPGS ;Free up the core
HRRZ T1,WTAB(D) ;Now free the page table
PUSHJ P,%FREBLK ; . .
SETZM WTAB(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
STORE T1,BUFCT(D) ;Store it back
IMULI T1,(T2) ;Get total space needed by buffers
LOAD T2,INDX(D) ;GET DEVICE INDEX
CAIN T2,DI.TTY ;TTY?
LSH T1,1 ;Yes, one for input, one for output
NOTIN: PUSHJ P,%GTBLK ;Allocate buffers
STORE T1,BUFAD(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 T1,MODE(D) ;Get /MODE
LDB T2,MODBYT ;Get byte size
STORE T2,IBSIZ(D) ;Save
STORE T2,OBSIZ(D)
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: MOVE T1,FLAGS(D) ;Get DDB flags
TXNE T1,D%IO ;Doing a WRITE?
JRST OPSW ;Yes, do a plain WRITE
TXNE T5,D%IN ;Want it opened for input?
JRST OPRD ;Yes
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, it will be created and opened for output.
LOAD T1,DRDVF(D) ;T1= non-zero if this is a directory device
JUMPE T1,[TXO T5,D%IN ;No, just go open for read
JRST OPRD]
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 CLOSE because the file could not be created!
OPSIC1: CAIE T1,ERFNF% ;File not found?
JRST FLPFL ;No, bad error
MOVEI T1,.FOCRE ;Create file
HRRM T1,FBLK(D)
PUSHJ P,DOFLP ;** Do FILOP. **
JRST FLPFL ;All errors are fatal
TXO T5,D%OUT ;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: SETZ T1, ;Start with nothing
DMOVEM T3,GTMSV3 ;Save acs
MOVEI T4,6 ;# 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: TXNE F,F%XCHAN ;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,BUFAD(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
MOVEI T2,LKPB(D) ;Clear .RBALC word (returned by ENTER)
SETZM .RBALC(T2) ; so it won't be an arg to further FILOP's
PUSHJ P,SETPPB ;Store correct path stuff
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%SICR+D%SILF ;Suppress initial CRLF for terminals
IORM T1,FLAGS(D) ; . .
MOVE T1,RSIZE(D) ;RECORD SIZE SPECIFIED?
JUMPN T1,%POPJ1 ;YES, IT WINS; DON'T OVERWRITE LINE WIDTH
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 ;NO, USE 72
STORE T1,TTYW(D) ;STORE LINE SIZE FOR NAMELIST/LIST-DIRECTED
JRST %POPJ1 ;DONE
DSKSET: TXNN P1,D%RAN ;RANDOM?
JRST %POPJ1 ;NO
LOAD T1,BUFCT(D) ;GET BUFFERCOUNT, BLOCKS
JUMPN T1,DSKNZB ;OK IF NON-ZERO
MOVEI T1,^D16 ;USE 16 IF ZERO
STORE T1,BUFCT(D) ;STORE THIS DEFAULT
DSKNZB: ADDI T1,3 ;ROUND UP TO PAGES
LSH T1,-2
PUSH P,T1 ;SAVE PAGE COUNT
PUSHJ P,%GTPGS ;ALLOCATE PAGES FOR BUFFERING DUMP IO
$ECALL MFU,%ABORT ;?Can't, mem full
EXCH T1,(P) ;GET PAGE COUNT, SAVE PAGE ADDRESS
LSH T1,2 ;MAKE INTO BLOCKS
PUSH P,T1 ;SAVE AGAIN
PUSHJ P,%GTBLK ;ALLOCATE PAGE TABLE, ONE WORD PER BLOCK
POP P,T2 ;RESTORE BLOCK COUNT
MOVNI T3,(T2) ;GET NEGATIVE
HRLI T1,(T3) ;MAKE AOBJN POINTER TO PAGE TABLE
MOVEM T1,WTAB(D) ;SAVE IT
HRRZM T1,WPTR(D)
POP P,T2 ;RESTORE PAGE ADDRESS OF BUFFERS
LSH T2,2 ;MAKE BLOCK ADDRESS
HRLOI T2,(T2) ;MAKE PROCESS ADDRESS,,IMPOSSIBLE FILE ADDRESS
DSETL: MOVEM T2,(T1) ;STORE IN PAGE TABLE
ADD T2,[1,,0] ;BUMP TO NEXT PROCESS PAGE
AOBJN T1,DSETL ;LOOP
JRST %POPJ1 ;DONE
MTASET: PUSHJ P,%SAVE1
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,%POPJ1 ;IF SET
;Compute bytes/per/word, not normally done until FIXDEF called.
PUSH P,T2 ;Save device name
LOAD T1,MODE(D) ;GET FILE MODE
LDB T2,MODBYT ;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
POP P,T2 ;Restore device name
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
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
MODBYT: POINT 6,MODTAB(T1),5
IF20,<
MODTAB: 0
BYTE (6)44(4)10 ;IMAGE
BYTE (6)44(4)10 ;BINARY
BYTE (6)44(4)17 ;DUMP
BYTE (6)7(4)0 ;ASCII
BYTE (6)7(4)0 ;LINED
BYTE (6)8(4)10 ;EBCDIC
>
IF10,<
MODTAB: 0
BYTE (6)44(4)10 ;IMAGE
BYTE (6)44(4)14 ;BINARY
BYTE (6)44(4)17 ;DUMP
BYTE (6)7(4)0 ;ASCII
BYTE (6)7(4)0 ;LINED
BYTE (6)8(4)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
JRST DMERR ;NO, ERROR
SEGMENT ERR
DMERR: 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
SEGMENT CODE
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 OPNINT,[DIAINT] ;(4) BUFFER COUNT=
XWD OPNINT,[DIAINT] ;(5) BLOCK SIZE=
XWD OPNFIL, ;(6) FILE NAME=
XWD OPNINT,[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 OPNINT,[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 OPNCHR,[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
IF10,<
;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>
>;END IF10
;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,IOSAD(U) ;(21) IOSTAT=
MOVEM T2,AVAR(U) ;(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,ERRAD(U) ;(37) ERR=
;DEFAULT DEVICE TABLE
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
; to a "common" DDB.
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
LOAD T2,UNUM(T1) ;T2= unit number for error message
MOVE T1,DDBAD(T1) ;T1= DDB address to check
LOAD T3,MODE(T1) ;Get old mode
LOAD T4,MODE(D) ;Get new mode
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
SIXBIT /RELEA./
RELEA%: PUSHJ P,%SAVE ;SAVE USER'S ACS
XMOVEI T1,[ASCIZ /RELEASE/] ;SET STATEMENT NAME FOR ERR MESSAGES
MOVEM T1,%IONAM
PUSHJ P,RLSCNV ;CONVERT TO CLOSE STATEMENT
JRST RCONT ;CONTINUE AS IF CLOSE(UNIT=U)
SIXBIT /CLOSE./
CLOSE%: PUSHJ P,%SAVE ;SAVE USER'S ACS
XMOVEI T1,[ASCIZ /CLOSE/] ;SET STATEMENT NAME FOR ERR MESSAGES
MOVEM T1,%IONAM
PUSHJ P,CLSCNV ;CONVERT OLD ARG BLOCK FORMAT
;Get TUNIT= unit #, %TERR= "ERR=" address, %TIOS= "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,%TIOS ;Any IOSTAT variable?
SETZM (T1) ;Yes, initialize to zero
PUSHJ P,SETFCL ;Set flag if non-trivial CLOSE
; arguments were given
MOVE T2,TUNIT ;GET THE UNIT
MOVE P1,%DDBTAB(T2) ;Get ptr to unit block
JUMPE P1,CLSNOP ; If not open, this is a no-op
;Close an opened unit
MOVE P2,DDBAD(P1) ;P2= ptr to old DDB
;Set ERR= and IOSTAT= in the unit block
MOVE T1,%TERR ;Set ERR=
MOVEM T1,ERRAD(P1)
MOVE T1,%TIOS ;Set IOSTAT=
MOVEM T1,IOSAD(P1)
MOVEI T1,ULEN ;Allocate a blank unit
PUSHJ P,%GTBLK
MOVE U,T1
MOVEI T1,DLEN ; and DDB
PUSHJ P,%GTBLK
MOVE D,T1
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)
TXNE F,F%DSTRG ;DIALOG='string' seen?
PUSHJ P,DLGSTR ;Yes, do it
;(possibly take ERR= branch)
TXZ F,F%DSTRG!F%INDST ;Clear flags
JRST CLOS.1 ;Go to main CLOSE code.
;Here if unit was never opened.
;Unit number in TUNIT
CLSNOP: TXNN F,F%CLA ;Any CLOSE args given that we are ignoring?
POPJ P, ;No, just return from CLOSE
MOVE T2,TUNIT ;Get unit number to print in message
$ECALL CLA,%POPJ ;Give warning and return.
;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 %CLOSE (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
;Routine to set F%CLA if CLOSE args given besides UNIT, ERR, IOSTAT
;Call:
; TERR, TIOS, TUNIT set up.
; PUSHJ P,SETFCL
; <return here>
; L/ -# ARGS,,addr
;Preserves T2
SETFCL: HLRE T1,L ;Get -# args
ADDI T1,1 ;Account for unit=
SKIPE %TIOS ;IOSTAT=?
ADDI T1,1 ;Yes
SKIPE %TERR ;ERR=?
ADDI T1,1 ;Yes
SKIPGE T1 ;More args specified?
TXO F,F%CLA ;Yes, set flag
POPJ P, ;Return
SUBTTL %CLOSE: 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).
;
%CLOSE: 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.
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
TXNE T1,D%OPEN ;Was explicit OPEN done?
JRST CLSITO ;Yes, have to open file first.
CLOSNO: PUSHJ P,CLSCLN ;Cleanup after CLOSE (core, etc.)
JRST CLSNOP ; Return, give error if CLOSE
; arguments were specified and ignored.
;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.
CLSITO: 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.
>
JRST CLOSNO ;Else don't have to do this.
;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?
JRST CLSNOP ;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: LOAD T1,INDX(D) ;GET DEV INDEX
CAIE T1,DI.DSK ;DISK?
JRST XXXCLS ;NO.
PUSHJ P,DSKCLS ;Write out changed pages, throw away WTAB info.
JRST XCLSDN ;SKIP 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
IF20,<
SKIPE T1,WADR(D) ;ANY BUFFER TO DEALLOCATE?
PUSHJ P,%FREBLK ;YES. DO IT
SETZM WADR(D) ;Clear core pointer
> ;IF20
XCLSDN: LOAD T1,UNUM(U) ;Get unit number
HRRE T1,T1 ;Negative or positive, get full word value
CAMN T1,U.RERD ;Is it the last successful READ unit?
SETZM U.RERD ;Yes, clear 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
MOVX T1,1B0 ;Clear "Delete after dispose" bit, if set
ANDCAM T1,DSPV
XCLSDS: HRRZ T1,DSPV ;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
CAMN D,D.TTY ;Is this the TTY DDB?
SETZM D.TTY ;Yes, no more.
HRRZ T1,IRBUF(D) ;GET INPUT REC BUFFER ADDRESS
SOJL T1,.+2 ;REMOVE ZERO WORD, SKIP IF NO BUFFER YET
PUSHJ P,%FREBLK ;DEALLOCATE BUFFER
HRRZ T1,ORBUF(D) ;GET OUTPUT REC BUFFER ADDRESS
SOJL T1,.+2 ;REMOVE ZERO WORD, SKIP IF NO BUFFER YET
PUSHJ P,%FREBLK ;DEALLOCATE BUFFER
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: LOAD T1,BUFAD(D) ;GET ADDRESS OF BUFFERS
CAIE T1,0 ;IF SET
PUSHJ P,%FREBLK ;FREE THEM
> ;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
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 DMBS, BPW
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,DMBS(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
SUBI T1,ST.DISP ;Get /DISPOSE value
SKIPG T1 ;Better be positive
$SNH ;?OOPS what's this??
CAME T1,T2 ;Does it match?
JRST CKCCN2 ;?No, conflict
; JRST CKCCN1 ;Yes, no conflict
SEGMENT ERR
CKCCN2: PUSH P,T2 ;Save DISPOSE value
XMOVEI T3,[ASCIZ/STATUS:/]
MOVEM T3,%OPNK1 ;Save string address of first switch
XMOVEI T3,[ASCIZ/DISPOSE:/]
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 ISW,REQDIA ;?Incompatible attributes
SEGMENT CODE
CKCCN1: JRST %POPJ1 ;No conflicts, return .+2
;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,SETCD1 ;Jump if something specified
LOAD T1,STAT(D) ;No, get status
JUMPE T1,SETCD1 ;If that also isn't specified, forget it
SUBI T1,ST.DISP ;Get DS.xxx value
SETCD1: LOAD T2,STAT(P2) ;Get old STATUS
CAIE T2,ST.SCR ;Skip if scratch
JRST COPDSP ;Copy new disposition (if specified)
;Don't allow DISPOSE='SAVE' when STATUS='SCRATCH'
; unless the file is being renamed.
CAIN T1,DS.SAVE
JRST DSSCNF ;Conflict
; JRST COPDSP ;Not DISPOSE='SAVE'
SEGMENT ERR
DSSCNF: XMOVEI T1,[ASCIZ/DISPOSE:/]
LOAD T2,DISP(D) ;Was it really STATUS?
SKIPN T2
XMOVEI T1,[ASCIZ/STATUS:/] ;Yes, say conflict there
MOVEM T1,%OPNK1
XMOVEI T1,[ASCIZ/SAVE/]
MOVEM T1,%OPNV1
XMOVEI T1,[ASCIZ/STATUS:/]
MOVEM T1,%OPNK2
XMOVEI T1,[ASCIZ/SCRATCH/]
MOVEM T1,%OPNV2
$ECALL ISW,REQDIA ;?Incompatible attributes
SEGMENT CODE
;Copy disposition (if specified)
;T1= DISPOSITION specified in CLOSE.
COPDSP: LOAD T3,STAT(P2) ;Get OPEN STATUS value
MOVX T4,1B0 ;Get "delete after dispose" bit
JUMPE T1,COPDS1 ;Jump if no disposition specified
PUSHJ P,DISPCK ;Check disposition conflict with device
MOVEM T1,DSPV ;Store dispose value
CAIN T3,ST.SCR ;STATUS='SCRATCH'?
IORM T4,DSPV ;Yes, set "delete after dispose" bit
POPJ P, ;Return
;Here if no disposition specified on CLOSE
;If a SCRATCH file and beginning DISP was DELETE or EXPUNGE,
; set to "SAVE". This way if an implied RENAME is done then
; the "delete after dispose" bit is cleared and then the file
; is saved.
COPDS1: CAIE T3,ST.SCR ;STATUS='SCRATCH'?
POPJ P, ;No, done
MOVE T1,[1B0+DS.SAVE] ;Get "SAVE" + "delete after dispose"
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
RENAMD: BLOCK 1 ;Address of dummy "D" with rename filespec
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
SKIPGE DSPV ;Skip if not DELETE after close
JRST CLEXP ;DELETE needed, go expunge file
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: PUSHJ P,RNFCHK ;Check for RENAME on invalid devices
POPJ P, ;Error, go into DIALOG
CAIE T1,.DVDSK ;RENAME disk to disk?
JRST RNME1 ;No, just return success
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,WTAB(D) ;POINT TO IN-CORE WINDOW
JUMPE T2,%POPJ ;IF ANY
JUMPG T2,DCLS2 ;IF NEG
HLRZ T2,(T2) ;GET FIRST PAGE IN TABLE
DCLS2: 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,WTAB(D)
JUMPG T1,DCLS3 ;IF NEG
HLRZ T1,(T1) ;GET FIRST PAGE IN TABLE
DCLS3: LOAD T2,BUFCT(D) ;GET PAGE COUNT OF WINDOW
PUSHJ P,%FREPGS ;DEALLOCATE IT
SETZM WTAB(D) ;Note we threw it away
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+FB%MOD ;SET FILE BYTE SIZE AND DATA MODE
LOAD T3,BSIZ(D) ;GET FILE BYTE SIZE
LSH T3,30 ;PUT IN POSITION, CLEAR DATA MODE
CHFDB% ;CHANGE FDB
MOVE T3,EOFN(D) ;GET FILE SIZE, BYTES
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
LOAD T3,BPW(D) ;GET BYTES/WORD
IDIVI T2,(T3) ;GET # WORDS IN FILE
LSH T2,-9 ;GET # PAGES IN FILE
CAML T2,TPAGE(D) ;LESS THAN TOP PAGE ACCESSED?
POPJ P, ;NO. WE'RE OK
LOAD T1,IJFN(D) ;GET JFN
HRRI T1,(T2) ;GET PAGE # 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
SKIPGE DSPV ;Skip if not DELETE after close
JRST CLEXP ;DELETE needed, go expunge file
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
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)
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
; IOERR (RNM,,,?,$E,<T1>) ;FAILED
CLRENF: MOVX T2,D%NCLS ;Turn off CLOSE error flag
ANDCAM T2,FLAGS(D)
$ECALL RNM ;?failed, give error
EXCH D,RENAMD ;Point to this DDB to type RENAME filespec
$ECALL RFN ;Type renamed file's name
EXCH D,RENAMD ;Get original D back
JRST REQDIA ;Go request DIALOG
;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
HRRZ T1,WTAB(D) ;GET TABLE POINTER
JUMPE T1,%POPJ ;IF ANY
HLRZ T1,(T1) ;GET CORE POINTER FROM FIRST ENTRY
TRNE T1,3 ;MUST BE MULT OF 4
$SNH
TRZ T1,400000
LOAD T2,BUFCT(D) ;GET LENGTH
ADDI T2,3 ;ROUNDED UP
LSHC T1,-2
PUSHJ P,%FREPGS
HRRZ T1,WTAB(D) ;POINT TO TABLE
PUSHJ P,%FREBLK ;FREE IT
SETZM WTAB(D) ;Note we threw it away
POPJ P,
> ;IF10
;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.
IF20,<
CAIN T1,.DVDSK ;DISK ok
JRST RNFCH1 ;Yes
>
IF10,<
CAIE T1,.TYDSK ;DISK Ok
CAIN T1,.TYDTA ;DTA ok
JRST RNFCH1
>
$ECALL FD1 ;?File not on disk- can't RENAME
FNDERR: EXCH D,RENAMD
$ECALL RFN ;[RENAMING to file]
EXCH D,RENAMD ;Put D back
JRST REQDIA ;Go request dialog
RNFCH1:
IF20,<
CAIN T3,.DVDSK ;Only DISK allowed
JRST RNFCH2 ;Ok
>
IF10,<
CAIE T3,.TYDSK ;DISK OK
CAIN T3,.TYDTA ; DECTAPE OK
JRST RNFCH2
>
$ECALL FD2,FNDERR ;?File 2 not on disk or dectape
RNFCH2: JRST %POPJ1 ;Return .+2, rename OK
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
HRRZ P3,DSPV ;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,[0] ;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
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
MOVE T1,%RESP ;GET FIRST WORD OF RESPONSE
TLNE T1,774000 ;SEE IF ANY TEXT IS PRESENT
; IOERR (QUE,,,[,$A,<[%RESP]>) ;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 11 ;QUEUE. BLOCK, LENGTH 3 + 2 MAX-POSSIBLE-ARGS
LRESP==20 ;LENGTH OF RESPONSE BLOCK
%RESP:: BLOCK LRESP ;RESPONSE BLOCK
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
;Notice the PUSH's. This code should eventually be modified to use
; the symbolic names, because users who have modified QSRMAC may
; have to totally rearrange this code.
;To see how to do it "right", look at the GALAXY v2 code for TOPS-10
;on the next page. (There was no time to do the same thing here..)
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
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:
; AOS .OARGC(P1) ;COUNT ARG
; SET /LIMIT TO SOMETHING REASONABLE ... QUASAR DEFAULTS INADEQUATE
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
LOAD T1,BPW(D)
IDIV T2,T1 ;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
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
SKIPL DSPV ;Delete after dispose?
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
JRST E..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-4(P1) ;MAKE ARG BLOCK FOR FORERR
;ON TOP OF MESSAGE HEADER
PUSH T1,[PUSHJ P,%IOERR] ;START WITH CALL TO IOERR
MOVX T2,"["B6 ;ASSUME INFO MESSAGE
TXNE P2,MF.FAT+MF.WRN ;ERROR?
MOVX T2,"%"B6 ;YES, CHANGE PREFIX CHAR
PUSH T1,T2 ;SET PREFIX CHAR
MOVSI T2,(P2) ;GET SIXBIT ERROR PREFIX
CAIN T2,0 ;IF SET
MOVSI T2,'QUE' ;IF NOT, USE FRSQUE
PUSH T1,T2 ;SAVE THAT
;ASCII ERROR MESSAGE FOLLOWS IN PACKET
PUSHJ P,.OHDRS+ARG.DA-3(P1) ;CALL FORERR
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
TXNN P2,TX.FAT!TX.WRN ;ERROR?
OUTCHR ["["] ;NO, INFO
TXNE P2,TX.FAT!TX.WRN ;ERROR?
OUTCHR ["%"] ;YES
OUTSTR TEX.MS(P1) ;TYPE MESSAGE
TXNN P2,TX.FAT!TX.WRN ;INFO?
OUTCHR ["]"] ;YES, TYPE CLOSING BRACKET
OUTSTR %CRLF## ;TYPE CRLF
NOMSG: TXNE P2,TX.MOR ;MORE COMING?
JRST QACK ;YES, GO GET IT
POPJ P, ;NO, RETURN
> ;IF10
SEGMENT DATA
QSRPID: BLOCK 1 ;QUASAR PID
IPCBLK: BLOCK 4 ;CONTROL BLOCK FOR IPCF FUNCTIONS
SEGMENT CODE
;ROUTINE TO CLOSE ALL FILES
EXIT1%: PUSHJ P,%SAVE
%EXIT1: XMOVEI T1,[ASCIZ /CLOSE/] ;FOR ERROR MESSAGES, WE'RE A CLOSE STMT
MOVEM T1,%IONAM
PUSHJ P,%SAVE1
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,%CLOSE ;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
;%ALCHN: 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
SIXBIT /ALCHN./
ALCHN%: PUSHJ P,%SAVE
MOVE T1,@0(L) ;GET USER'S ARG
TDNE T1,[-20] ;IF NEGATIVE OR OVER 17, ERROR
JRST ALCHNX
PUSHJ P,%ALCHN ;TRY TO ALLOCATE CHANNEL
ALCHNX: SETO T1, ;CAN'T
MOVEM T1,U.ACS+T0 ;STORE FOR USER
POPJ P, ;RETURN
%ALCHN: 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
;%DECHN: 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
SIXBIT /DECHN./
DECHN%: PUSHJ P,%SAVE
MOVE T1,@0(L) ;GET ARG
TDNE T1,[-20] ;RANGE CHECK
JRST DECHNX ;ILLEGAL CHANNEL, ERROR
PUSHJ P,%DECHN ;DEALLOCATE THE CHANNEL
DECHNX: SKIPA T1,[-1] ;CAN'T
SETZ T1, ;CAN, DID
MOVEM T1,U.ACS+T0 ;STORE FOR RETURN TO USER
POPJ P, ;RETURN
DECHN: PUSHJ P,%DECHN ;DEALLOCATE CHANNEL
$SNH ;NOT ALLOCATED, ERROR
POPJ P, ;RETURN
%DECHN: 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,<
ALCHN%: SETO T0, ;NO CHANNELS AVAILABLE ON -20
%ALCHN: POPJ P, ;SAY SO AND RETURN
DECHN%: SETO T0, ;NO CHANNEL CAN BE ALLOCATED
%DECHN: POPJ P, ;ERROR RETURN
>;END IF20
SUBTTL INQUIRE
INQ%:; ERR (INI,,,?,INQUIRE not implemented,,%ABORT)
$ECALL INI,%ABORT ;?INQUIRE not implemented
SUBTTL I/O ERROR PREFIX LINE TYPER
SEGMENT ERR
$FTSHR==FTSHR ;PUSH PSECT FLAG
FTSHR==0 ;MACRO BUG PROBIBITS NESTED PSECTS WITH SAME NAME
ENTRY %IOERR
%IOERR: PUSHJ P,%ERRST ;Fix things up to start error
MOVE T1,0(P1) ;Get first word of arg block
TXNE T1,I%UNI ;No "D" and "U" setup?
JRST IOERR0 ; Right, get ERR=, IOSTAT= out of %TERR, etc.
MOVE T1,ERRAD(U) ;Get stuff from Unit block
MOVEM T1,%TERR
MOVE T1,ENDAD(U)
MOVEM T1,%TEND
MOVE T1,IOSAD(U)
MOVEM T1,%TIOS
IOERR0:
IF20,<
MOVEI T1,.FHSLF ;GET JSYS ERROR NUMBER FOR LAST ERROR
GETER%
ERJMP .+1
HRRZM T2,G.LJE ;STORE FOR FORERR
> ;IF20
LDB T1,[POINT 10,(P1),16] ;GET ERROR NUMBERS
LDB T2,[POINT 10,(P1),26]
CAIN T2,1777 ;N2= -1?
SETO T2, ;yes, error is -1
IF20,<
JUMPE T1,ZERN ;Zero error number
JUMPN T2,.+2 ;IF NO N2 SUPPLIED, USE MONITOR ERROR NUMBER
HRRZ T2,G.LJE
ZERN:
> ;IF20
HRLI T2,(T1) ;COMBINE ERROR NUMBERS
MOVEM T2,G.IS ;STORE FOR ERRSNS
HRRZ T2,T2 ;Get N2
CAIN T2,-1 ;EOF?
SETO T2, ;Yes, get whole word -1
SKIPE T1,%TIOS ;Any IOSTAT=?
MOVEM T2,(T1) ;Yes, store it
;Iff this is a "?" error, do the ERR= or END= stuff
LDB T1,[POINT 7,(P1),6] ;Get PREFIX char.
CAIE T1,"?" ;"?" says take ERR= if we can.
JRST NERR1 ;Not fatal, just go type message
;Fatal error. Clear %UDBAD
; This is so all the IOLST. calls that follow an IO call that gets
; a fatal error will not screw up things any more.
SETZM %UDBAD ;CLEAR THE UDB PNTR
SKIPGE T2 ;EOF?
SKIPN T1,%TEND ;Yes, use END= address not ERR=
;But if no END= specified, use ERR=
MOVE T1,%TERR ;Get ERR= Address
JUMPE T1,NERR ;IF ANY
;Take END= or ERR= branch.
;Address of where to go is in T1.
;T2 contains the error number
MOVE P,U.PDL ;Get old stack
MOVEM T1,(P) ;Store return address
ADJSP P,1 ; Fix so we get our acs back
PUSHJ P,%EMSGT ;Get error message text for ERSNS.
PUSHJ P,DEALCB ;Deallocate RENAMD, RENAMU if necessary
PJRST FXTRET ; Fixup stuff to return and return
; (to program)
;No END= or ERR= specified
NERR: SKIPN %TIOS ;How about IOSTAT=?
JRST NERR1 ;No
;Return to next statement in the program.
PUSHJ P,%EMSGT ;Get error message text for ERRSNS.
PUSHJ P,DEALCB ;Deallocate RENAMD, RENAMU if necessary
PUSHJ P,FXTRET ;Fixup stuff to return
MOVE P,U.PDL ;Reset stack
ADJSP P,1 ; Fix so we get our acs back
POPJ P, ;Return to next statement in pgm.
;Routine to fixup stuff to return from IO error.
FXTRET: MOVE T1,(P1) ;Get flags
TXNE T1,I%UNI ;No "U" or "D"?
POPJ P, ;Yes. Don't deallocate
TXNE F,F%DCU ;Deallocate "D" and "U"?
PUSHJ P,FXTRTD ;Yes, do that
FXTRT1: PJRST %SETAV ;Set associate-variable and return
; (also clears ERRAD, ENDAD, IOST)
;Deallocate "U" and "D" before returning.
FXTRTD: MOVEI T1,(U) ;Get address of "U"
PUSHJ P,%FREBLK ;Free it
MOVEI T1,(D) ;Get address of "D"
PJRST %FREBLK ;Free it and return
;Deallocate RENAMD, RENAMU if necessary
; having this routine here greatly simplifies error handling in CLOSE.
DEALCB: SKIPN T1,RENAMD
POPJ P, ;Not necessary
PUSHJ P,%FREBLK
MOVE T1,RENAMU
PJRST %FREBLK ;Deallocate and return
;Print out the error.
NERR1: MOVE T1,(P1) ;Get flags
TXNE T1,I%UNI ; No "U" or "D"?
PJRST %FOREC ;Right, Skip prefix line
TXNE F,F%NION ;First error in this statement?
PJRST %FOREC ;NO, SKIP PREFIX LINE
; From now on, this is just like an ERR call except
;that there is a first line of the message.
LDB T0,[POINT 7,(P1),6] ;GET FIRST CHAR OF ERROR MESSAGE
MOVEM T0,PFXCHR ;SAVE FOR OUR MESSAGE
PUSHJ P,%ERSVV ;Save parameters on stack from previous call
MOVE T1,PFXCHR ;GET PREFIX CHAR
HRRZ T3,U.PDL ;GET RETURN ADDRESS FOR MESSAGE
MOVE T3,(T3)
SUBI T3,1
MOVE T0,FLAGS(D) ;Get DDB flags
TXNE T0,D%ENC ;ENCODE/DECODE?
; ERR (EDE,$,$A error at $1L,<T1,%IONAM,T3>)
$ECALL EDE,IOCONT ;YES, SIMPLE MESSAGE
HXRE T1,UNUM(U) ;GET UNIT NUMBER
MOVE T2,PFXCHR ;GET PREFIX CHAR
; ERR (NAM,$,$A unit $D $F at $1L,<T2,%IONAM,T1,T3>)
$ECALL NAM
IF10,<
TXZE F,F%INDST ;DIALOG FROM STRING?
; ERR (DST,$,Error in dialog string,<T2>)
$ECALL DST
; JRST IOCONT
>
IOCONT: TXO F,F%NION ;Set flag so IONAM doesn't get printed again
PUSHJ P,%ERRRS ;Restore everything
PJRST %FOREC ;Go type regular message
FTSHR==$FTSHR ;POP PSECT FLAG
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
ERRBUF: BLOCK 40 ;BUFFER FOR ERROR-MESSAGE JFNS
>;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
G.IS:: BLOCK 1 ;ERROR NUMBERS FOR ERRSNS
%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
SEGMENT CODE
PURGE $SEG$
END