github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-18 17:16:59 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/syseng/file.591
Lars Brinkhoff 21896d5513 FILE - Chaosnet file server. 
Also FILEI/FILEO.
2017-01-28 12:16:28 -08:00

8586 lines
221 KiB
Plaintext
Executable File
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; -*- Mode: MIDAS -*-
;;; PDP-10 Chaosnet file server
;;; The source file for this program is kept in the following places
;;; on the MIT Chaosnet:
;;;
;;; AI: SYSENG; FILE >
;;; OZ:SS:<SYS.SYSTEM>FILE.MID
;;; SCRC:<CHAOS>FILE.MID
;;; SPEECH:SSY:<SYMBOLICS.CHAOS.SERVER>FILE.MID
;;; XX:SRC:<SYS.CHAOS>FILE.MID
;;;
;;; Send mail regarding this program to BUG-FILE at MIT-MC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; ****
;; **** Changes that have been made:
;; ****
;;
;; Wednesday, 21 July 1982 --Gren
;;
;; If OPEN/DELETE/RENAME/CHANGE-PROPERTIES fails for access
;; violation, will try and CONNECT no password then try again
;; (see TRYCON - Must immediately proceed the failing JSYS).
;;
;; Conditionally assembling the Chaosnet-user-Capability checking,
;; since you could always just login as Anonymous, which has it.
;; See the $$CCUC
;;
;; Make a DIRECTORY command not return ?NO FILES MATCH THIS
;; SPECIFICATION as an error, but just give an empty list.
;;
;; Thursday, 29 July 1982 --Gren
;;
;; Make GTJFN errors "NO SUCH FILENAME", "NO SUCH FILE TYPE", and
;; "NO SUCH VERSION NUMBER" come back as FNF, but with the original
;; error text.
;;
;; If you get auto-CONNECTed to a directory, you will disconnect
;; back to your home dir after done with whatever file. See the
;; CNCTED flag.
;;
;; Noticed this was already done (taken from SHOULD list):
;;
;; "COMRFO should quote embedded spaces, colons, semicolons, ideally."
;;
;; Friday, 30 July 1982 --Gren
;;
;; Instead of hassling you about logging in all the time, you will
;; be logged in as ANONYMOUS if it all possible, and only pestered
;; if it can't be done. The LOGIN command then does the same as an
;; ACCESS
;;
;; Wednesday, 4 August 1982 --Gren
;;
;; Better yet than just logging you in as ANONYMOUS by default, it
;; tries to log you in as <Q.hostname>, and only if that fails does
;; it try ANONYMOUS. The <Q> directory also has files of the form
;; <Q>hostname.PASSWORD, which are analagous to ANONYMOUS.USERFILE.
;; Note that these <Q> dirs have NOT-TTY-LOGINABLE set, so only the
;; FILE server or other detached creatures can use them. You may
;; not explicitly give a N-T-L account with LOGIN - It is rejected.
;;
;; "COMPFN should become more robust." - I poked at it some. Looks
;; fine to me. Have yet to try it out tho.
;;
;; In COMPFN, FN2 now defaults to ">" (it was left 0 before, and
;; would choke).
;;
;; Saturday, 21 August 1982 --Gren
;; Make the DIRECTORY command default FN1 and FN2 to "*" so that
;; just saying "DIR" or "DIR FOO" will work.
;;
;;
;; Monday, 23 August 1982 --Gren
;; Added support for SUBMIT OPEN option, conditionalized with the
;; $$SUBM flag.
;;
;; Tuesday, 14 September 1982 --Gren
;; Response to an OPEN is now:
;; ... QFASLP<SP>CHARACTERP<SP>"writer"<NL> ...
;; where "writer" is the last writer of the file, in Lisp-READable
;; format, with "'s and /'s quoted.
;;
;; Thursday, 16 September 1982 --Gren
;; Fixed some of the COMPLETE code so it wouldn't blow up and
;; cause the program to die horribly, and merged in Moon's time
;; fixes.
;;
;; 9/20/82 Moon Merged Gren's version and the Symbolics version
;; into one
;;
;; Monday, 27 September 1982 --Gren
;; Added support for ENABLE-CAPABILITIES.
;;
;; 9/27/82 Moon Fix bugs in cross-device/directory rename checking on
;; ITS. Make CWD and ENABLE-CAPABILITIES work on Tenex
;; Fix command name comparison so CREATE-LINK is not
;; mis-parsed as CREATE-DIRECTORY
;; Add CREATE-LINK command for ITS
;;
;; Saturday, 2 October 1982 --Gren
;; Have ENABLE/DISABLE commands take arguments of which privs to
;; toggle (currently only WHEEL, OPERATOR, or ALL), and have both
;; return the state of your privs as <priv allowed> <T if enabled
;; else NIL> ...
;;
;; 10/9/82 Moon Send new standard 3-letter error codes
;; Put error messages in upper and lower case
;; Include disk free space in directory list, for Tenex
;; (TOPS-20 should probably do it the way ITS does)
;;
;; Sunday, 10 October 1982 --Gren
;; Scrapped assorted experimental OZ things, put in some 20X
;; directory space listing stuff.
;;
;; Tuesday, 12 October 1982 --Gren
;; Doing SETNMs now for clarity's sake, added NLI LispM suicide
;; timout code, and conditionalized logging of activity, for
;; debugging porpoises ($$LOG).
;;
;; Thursday, 14 October 1982 --Gren
;; TWENEX returns freespace for all structures in directory stream
;; as STRUCTURE1:free1 STRUCTURE2:free2 ...
;;
;; Friday, 15 October 1982 --Gren
;; Conditionized out suicide stuff for now, since there don't seem
;; to be any interrupt channels to do it on, and it's no solution
;; anyway. $$SUE
;;
;; 18 Oct 82 Moon
;; Made it work again for ITS
;; Added INHIBIT-LINKS option for OPEN (ignored by systems without links)
;; Made OPEN options 10 characters instead of 5
;; IFN 0'ed GTDAL in 20X directory header, commented why
;; Got upset stomach from reading code in mixed case
;; Fixed ITS error messages
;;
;; Tuesday, 19 October 1982 --Gren
;; Put back in fixed GTDAL, Meta-C'd entire buffer.
;;
;; 10/21/82 Moon
;; Fix IOC errors to send proper 3-letter code.
;; Fix ITS error messages which I broke on 18 Oct.
;; Remodularize the error-message code to be more host-independent
;;
;; 10/26/82 MT
;; For 20X rel 5: use FB%NDL instead of FB%UND, if it's defined.
;;
;; Thursday, 28 October 1982 --Gren
;; Get writes to a specific version of a file go through a scratch
;; file, so there is no chance of clobbering the old copy.
;;
;; Saturday, 30 October 1982 --Gren
;; Try to DWIM if you DIRECTORY a <dir> without the *'s.
;;
;; Monday, 1 November 1982 --Gren
;; Put the directory-listing stuff on a separate GTJFN routine
;; (COMGDJ - uses Long Form) to avoid that DWIM kludge.
;;
;; Tuesday, 9 November 1982 --Gren
;; Change all ERJMP JSYSER's to ERCAL JSYSER's and include the
;; address of JSYS error along with the error string. JSYSER
;; should only be called via ERCAL since it expects TOS to be
;; the PC and such. If you want to do like JRST JSYSER, JRST
;; to COMFER instead. [Inoperative!]
;;
;; Saturday, 13 November 1982 --Gren
;; Switch file-overwriting back to the old catch-OPNX27-error
;; scheme, make sure JFNs released when erroring, fix delete/
;; temporary-file dual usage of DATRFJ. Ran out of usable bits
;; in DATSTA LH!
;;
;; Monday, 15 November 1982 --Ian
;; Various bug fixes having to do with when to release leftover
;; JFNs (now only done at close time). Returning number-of-
;; LM-characters-received on a CLOSE reply. No more $$SUE.
;;
;; Tuesday, 16 November 1982 --Ian
;; Centralized most of the Closing/Releasing of JFNs at RELDJF
;; and RELRJF
;;
;; 11/17/82 Moon -- fixed bugs I noticed
;; $$LOG should not be on by default
;; NOTNEW was not always initialized before calling COMGJF/COMGJG
;; COMOPN needs to release any JFNs held even if ST.ACT is not set
;; TRYCON thought A was 1 and also broke ERCAL
;; RLJFN fails if the JFN is open, so try CLOSF and RLJFN both
;; Fix errors in TNX/ITS conditionalization, Tenex timebombs
;; Use BUG 3-letter code for all unexpected errors
;; Make SYSBUG bug-tracing message not be as mysterious to users
;;
;; 11/19/82 Moon
;; Fix TRYCON more.
;; Don't call RELDJF when not supposed to, at CNGERR
;;
;; 12/1/82 Moon
;; If closing in abort mode, set CZ%ABT to suppress generation-retention-count
;; Send an async mark if data packet discarded for any reason
;; Send OPEN reply only after all done, in case interrupt accidentally
;; left enabled, so data packets don't arrive early (especially
;; when transaction-logging is turned on, making COMSND slow)
;;
;; 12/4/82 Moon
;; Fix clobbering of error code introduced by centralized closing of JFNS
;;
;; (some time) Gren (I assume)
;; OZ INQUIR data base has user groups
;; Default version for directory to * when user is not a Lisp machine
;; (unfortunately this was done in such a way that it can only work on OZ)
;;
;; 12/29/82 Moon
;; Recognize BIN files
;; Remove timebombs put in by previous modification
;;
;; 1/5/83 Moon
;; Put more wheel/operator capability required 20X error codes into ERRTAB
;;
;; 2/15/83 Moon
;; Revise error reporting. Include octal PC for all file-system bugs.
;; Normal expected errors from the file system are reported
;; via PUSHJ P,FILERR (on 10X/20X this is ERCAL JSYSER or PUSHJ P,JSYSER
;; usually, however JSYSER and FILERR are the same).
;; For ITS, ERRCOD must have been set up (via .CALL error return value)
;; PUSHJ P,SYSBUG is used for unexpected errors from the file system.
;; In DEBUG mode, even non-bug error messages include the octal PC.
;; You can also patch the JRST at BUGPAT to a JFCL to get this.
;; Also fix commands that use IDX without initializing it.
;;
;; 5/18/83 Moon v.508
;; Probe opening allowed for files that are off-line on Twenex
;;
;; Monday, 23 May 1983 --Ian
;; Fix another case for directory-empty: GJFX19 (No such file type)
;; is what you get if you directory "*.BAR" and there are no matching
;; files.
;;
;; 5 June 1983 Moon
;; Tops-20 needs to access other structure in COMPLETE command
;;
;; Wednesday, 8 June 1983 CSTACY
;; Fix INQUIR kludges, use proper LSRTNS routines.
;;
;; 9 June 83 Moon v.514
;; ACCCHK in COMPLETE command for Tops-20
;;
;; 14 June 83 Moon v.515
;; Do ACCESS to foreign structures once, at login time, instead
;; of all over the place. This avoids the problem that there were
;; lots of places that forgot to call ACCCHK.
;;
;; 16 June 83 Moon v.516
;; Return truenames from RENAME command (not finished for ITS yet)
;;
;; 13 July 83 Moon v.519
;; Don't return bogus file dates from ITS files that have never
;; been referenced.
;; More ACCESS/CONNECT fixes for Twenex
;;
;; 19 July 1983, GZ, v.519
;; Process LOGICALS.CMD on login, under $$LNM switch (off except on OZ).
;;
;; 19 July 83 Moon v.520
;; Merge my changes and GZ's changes
;; EXPUNGE command ignored by ITS
;; DELETED open option ignored by ITS
;; HOMEDIR, FILE-SYSTEM-INFO commands
;; Directory of FOO > on ITS matches only files with all-numeric FN2
;;
;; 23 August 83 Ian / Moon v.524
;; Missing ERCAL after RCDIR in EXPUNGE command
;;
;; Sunday, 4 September 1983 --Ian (524)
;; COMPFN defaults FN2 to ">" if STARF2/ 0 else "*" (for the sake
;; of directory listings)
;;
;; 9/6/83 Moon v.526
;; New OPEN options: ESTIMATED-LENGTH, PROBE-DIRECTORY,
;; IF-EXISTS, IF-DOES-NOT-EXIST (except for rename and rename-and-delete)
;; For ITS, the latter two aren't implemented yet
;;
;; 9 September 1983 --Ian (527,531)
;; Fixed 20X EXPUNGE not to need filename and to handle
;; wildcarded directories; Fix EXPUNGE code which somehow
;; reverted to a non-working test version (11-Sep)
;;
;; 9/12/83 Moon
;; Put back kludges needed to make EXPUNGE work on Tenex
;;
;; 9/19/83 Marty v533
;; Turned on $$LNM for all Top-20 versions.
;;
;; 9/23/83 Moon v.534
;; SFUSX6 gives a CSP error (mainly of use for Tenex)
;; Undefined 10X/20X error codes don't give a blank error message!
;;
;; 3 October 1983 --Ian
;; OZ Inquire support.
;;
;; 10/21/83 Moon
;; Add IF-EXISTS TRUNCATE (sets file length but doesn't return disk pages!)
;; Replace DATDEL, DATRFJ, and ST.OVW with DATDSP, to implement
;; IF-EXISTS RENAME and IF-EXISTS RENAME-AND-DELETE
;; Don't send bogus months in dates (can exist in ITS dates sometimes)
;; Still can send bogus days, though, but I think that's okay for
;; the moment. Dates should really be transmitted as universal times.
;; IF-EXISTS, IF-DOES-NOT-EXIST still not implemented for ITS
;;
;; 10/27/83 Moon v.543
;; Merge SCRC and OZ versions
;; Fix typo in HOMEDIR command when no Inquir entry found
;;
;; 10/31/83 Moon v.545
;; Ian's changes of 3 October broke users not registered in INQUIR on OZ
;; Ian's changes since last assembled on ITS broke ITS assembly
;;
;; 11/28/83 Moon v.547
;; PROBE-DIRECTORY bugs: release JFN, return truename, work on TOPS-20
;;
;; 12/06/83 Marty v. 546 (v. 548)
;; Make Tops-20 abort all open connections upon logout.
;;
;; 12/13/83 Moon v.549
;; Code was all scrambled in EXPUNGE command somehow
;;
;; 12/21/83 Moon v.551
;; IF-EXISTS SUPERSEDE ignored on ITS since system 243.369 sends it
;; Real implementation of IF-EXISTS, IF-DOES-NOT-EXIST for ITS still not done
;;
;; 1/4/84 Moon v.555
;; PROPERTIES command
;;
;; 1/16/84 Moon v.556
;; Merge the following changes from UTexas
;;
;; 12/13/83 C.Dawson (UTexas) v. 10547
;; Fix lossage when number of structures on system is exactly
;; equal to monitor's STRN. In this case, the GETAB table will
;; NOT contain a structure named STRnnn, and this can't be checked
;; for loop termination.
;;
;; 12/13/83 B. Brown (UTexas) v. 20547
;; Set session remark to "CHAOS SERVER" at startup. Useful for
;; Exec's who discriminate among various flavors of detached jobs.
;;
;; 1/29/84 Moon v.557
;; Lisp machine has gotten more picky about only accepting well-formed
;; dates, so put in more checks for bogus dates in date printer.
;;
;; 2/21/84 Moon v.558
;; Allow superseding a Tops-20 offline or archived file
;;
;; 20 June 1984 --Ian
;; For OZ, make the session-remark "CHAOS SERVER hostname" so FINGER
;; can show it.
;;
;; Monday, 9 July 1984, CJL
;; For TWENEX, If the RETENA is nonzero, for opens that would normally
;; bomb out will "File is off-line", a file retrieval is automatically
;; run, and the open is retried. For OZ, RETENA is set to -1.
;; Someday I hope there will be some way to change the value of RETENA
;; so this feature can be enabled and disabled at runtime. Insrts also
;; to LIB: instead of SYSTEM:, on OZ
;;
;; 9/7/84 MMcM v.567
;; :CHARACTERS :DEFAULT re-OPENF should respect PRESERVE-DATES.
;; Anonymous and archive retrieval changes weren't properly conditionalized.
;; 19-Nov-84, GZ, v.568
;; Adopt to hakinq library changes (OZ only).
;; Enable self at PURIFY so can dump file.
;;
;; 31 January 1985 --Ian v.569
;; Set XUNAME on ITS to name logging in as, fixed accumulated
;; ITS-assembly problems.
;;
;; 23-Feb-85, GZ, v.570
;; Add FILE-BYTE-SIZE open option on TNX
;;
;; 4/8/85, Alan, v.571 (ITS)
;; Set HSNAME on ITS.
;;
;; 5/02/85, CStacy (apparently), v.572 (ITS)
;; God only knows what he did.
;;
;; 20-May-86, COLE, v.571 (20X) (renamed v.573 after the fact on OZ)
;; FILE now computes byte size even when not in binary mode
;;
;; 2-July-86, SRA, v.574
;; Make session remark hack work for XX, without all the host
;; table mapping crud fer gossake. Added XX conditional.
;; Make OZ and XX conditional IFNDEFs work in domainland.
;; Merge OZ, XX, AI versions together again.
;;
;; 5-Oct-86 JTW v.575
;; Set file byte size only on BINARY WRITE operations (undo 571,
;; really). Fix incompatability with Symbolics Rel-7 which wants
;; to set character files to 8-bit bytes.
;;
;; 8-Dec-86 GLR v.576
;; Make open for output return filelength if file is old
;; 8-Dec-86 GLR v.582
;; hack filepos to work for output files -- this has timing screws in it
;; 8-Dec-86 GLR v.586
;; increase NIMPUR -- so it compiles on ITS
;;
;; 12/19/86 Alan v.587 (ITS)
;; Fixed code in ITS directory creation that tried to assure that only
;; people with directories can create directories. I'll bet this is
;; what CStacy did in v.572.
;;
;; 6/2/88 Alan v.591 (20X)
;; Return .FBTP1 .FBSS1 .FBTP2 .FBSS2 file properties.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
IFNDEF ITS,[
IFE .OSMID-SIXBIT/ITS/,ITS==1
.ELSE ITS==0
];IFNDEF ITS
IFNDEF 10X,[
IFE .OSMID-SIXBIT/TENEX/,10X==1
.ELSE 10X==0
];IFNDEF 10X
IFNDEF 20X,[
IFE .OSMID-SIXBIT/TWENEX/,20X==1
.ELSE 20X==0
];IFNDEF 20X
IFNDEF TNX, TNX==1-ITS
IFN ITS, TITLE FILE JOB FOR ITS
IFN 20X, TITLE FILE JOB FOR TOPS-20
IFN 10X, TITLE FILE JOB FOR TENEX
IFE <<<SIXBIT/MIT-OZ/>-<.SITE >>*<<SIXBIT/OZ.AI./>-<.SITE >>>, OZ==1
.ELSE OZ==0
IFN OZ, PRINTX /(OZ's munched on version)
/
IFE <<<SIXBIT/MIT-XX/>-<.SITE >>*<<SIXBIT/XX.LCS/>-<.SITE >>>, XX==1
.ELSE XX==0
IFN XX, PRINTX /(XX'S slightly munched on version)
/
DEFINE INFORM A,B,C,D,E,F,G
PRINTX /A!B!C!D!E!F!G
/
TERMIN
DEFINE CONC A,B,C,D,E,F,G
A!B!C!D!E!F!G!TERMIN
IFN ITS,[
NIMPUR==2 ;Number of low impure pages (ran over by 1 word)
PURBEG==NIMPUR*2000
] ;END IFN ITS
IFN TNX,[
.DECSAV
NIMPUR==4 ;Number of low impure pages
PURBEG==NIMPUR*1000
JOBSYM=116 ;Pointer to symbol table, in our own core
NSYMPG==3 ;Number of pages left for symbol table
IFN OZ,[
NSYMPG==4 ;doesn't quite fit otherwise
IPAGE==400 ;map in inquire database here
];End OZ
];END IFN TNX
;AC definitions
F=0 ;FLAGS ET AL.
;;; AC's 1 thru 3 (and sometimes 4) are used for Tops-20 JSYS'
;;; On Tenex, the GETER JSYS will smash AC's 4-10 as well.
T=4 ;SUPER TEMPORARIES
TT=5
A=6 ;NOT SO SUPER TEMPORARIES, BUT FOR GENERAL USE
B=7
C=10
D=11
IDX=12 ;INDEX INTO TABLES POINTING TO FILE CURRENTLY BEING HACKED
; LOW ORDER BIT 0=INPUT, 1=OUTPUT
BP=13 ;POINTER INTO PACKET
BYTE=14 ;CURRENT BYTE BEING HACKED
FHN=15 ;CURRENT FILE HANDLE
BC=16 ;BYTE COUNT REMAINING IN CONTROL PACKET
P=17 ;PDL POINTER, OF COURSE (THIS BETTER BE 17 FOR TOPS-20)
IFN ITS,[
;Get CHAOS definitions
.INSRT SYSTEM;CHSDEF
] ;END IFN ITS
IFN 20X,[
LOC 140
IFE OZ\XX,[
.INSRT SYSTEM:CHSDEF
];NOT OZ\XX
IFN OZ\XX,[
.INSRT MID:CHSDEF
];OZ\XX
] ;END IFN 20X
IFN 10X,[
LOC 140
.INSRT FILDEF
] ;END IFN 10X
%CPMXW== 126. ;Note: we want max over ALL systems here ...
%CPMXC== 488.
;IFNDEF CHPMXW, CHPMXW==%CPMXW-%CPKDT
;IFNDEF CHPMXC, CHPMXC==%CPMXC
;; Flag bits
F.FHN==:1_0 ;IF SET THERE WAS A VALID FILE HANDLE IN THE CONTROL REQUEST
F.NWL==:1_1 ;COMEUS HAS SEEN A NEWLINE
F.PRB==:1_2 ;DOING A PROBE
F.QFP==:1_3 ;QFASLP
F.FN1==:1_4 ;Guess....
F.FN2==:1_5
F.DEV==:1_6
F.DIR==:1_7
IFN TNX,[
F.SPAC==:1_8 ;A space has been seen while building error code
F.NRJ==:1_9 ;Don't release JFN in CLOSIT
F.ENA==:1_10. ;Enable after login
] ;END IFN TNX
F.DEF==:1_11. ;:CHARACTERS :DEFAULT
IFN OZ,[
F.LSP==:1_12. ;Coming from a LispMachine
];OZ
F.PDR==:1_13. ;PROBE-DIRECTORY
;; Flag bits in LH(F) controlling file creation options for OPEN
F.CRE==:1_18. ;Create file if does not exist (for overwrite/append)
F.SUP==:1_19. ;Supersede even if ask for newest version
F.APP==:1_20. ;Append to file
F.OVW==:1_21. ;Overwrite file
F.NEW==:1_22. ;File must be new, error if already exists
F.REN==:1_23. ;Rename existing file
F.RND==:1_24. ;Rename and delete existing file
F.TRU==:1_25. ;Truncate existing file and overwrite
IFN ITS,[
DEFINE SYSCAL OP,ARGS
.CALL [SETZ ? SIXBIT /OP/ ? ARGS ((SETZ))]
TERMIN
;; I/O CHANNELS
UTILCH==0 ;UTILITY CHANNEL: PROBES, TTY
;;; The CHAOS channels must be contiguous
CTRLI==1 ;CONTROL CONNECTION INPUT
CTRLO==2 ;CONTROL CONNECTION OUTPUT
ERRCH==17 ;Error channel
;; REMAINING CHANNELS FOR USE FOR REAL I/O
;; GROUP 1:
;; 3, DATA CONNECTION IN. 4, DATA CONNECTION OUT
;; 11, INPUT FILE. 12, OUTPUT FILE
;; GROUP 2:
;; 5, DATA CONNECTION IN. 6, DATA CONNECTION OUT
;; 13, INPUT FILE. 14, OUTPUT FILE
;; GROUP 3:
;; 7, DATA CONNECTION IN. 10, DATA CONNECTION OUT
;; 15, INPUT FILE. 16, OUTPUT FILE
;; EXTRA ENTRY FOR PROBING
CHACHN: 3 ? 4 ? 5 ? 6 ? 7 ? 10 ? -1
CHALOW==:1
CHAHIG==:10
CHABIT: 10 ? 20 ? 40 ? 100 ? 200 ? 400
DATCHN: 11 ? 12 ? 13 ? 14 ? 15 ? 16 ? UTILCH
MAXIDX==6 ;NUMBER OF INFORMATION CHANNELS. N/2 INPUT, N/2 OUTPUT
;LOW ORDER BIT 0=INPUT, 1=OUTPUT
] ;END IFN ITS
IFN TNX,[
GDACC=<JSYS 331> ;Gotta add this to MIDAS's symbol table.
PRILE1: 0 ;Three locations for storage of old PC at interrupt time
PRILE2: 0
PRILE3: 0
LV1ACS: BLOCK 20 ;Room for the ACs
LV1SAC: 0 ;Routine to be JSR'ed to to save AC's at level 1
MOVEM 0,LV1ACS
MOVE 0,[1,,LV1ACS+1]
BLT 0,LV1ACS+17
MOVE 0,LV1ACS
JRST @LV1SAC
MAXIDX==16.
CHABIT: IRPS BITPOS,,[0,1,2,3,4,5,23,24,25,26,27,28,29,30,31,32,33]
1_<35.-BITPOS!.>
TERMIN
CHAICN: 0,,1
2,,3
4,,5
23.,,24.
25.,,26.
27.,,28.
29.,,30.
31.,,32.
33.,,33.
;; Channels 34. and 35. are reserved by monitor for toplevel job!
CHAJFN: BLOCK MAXIDX+1
] ;END IFN TNX
;;; Impure tables
;;; Per data-connection tables
DATFHN: BLOCK MAXIDX+1 ;File handle
DATSTA: BLOCK MAXIDX+1 ;Status
DATBYT: BLOCK MAXIDX+1 ;Byte-size
DATBPW: BLOCK MAXIDX+1 ;Bytes per word
DATBUF: BLOCK MAXIDX+1 ;Buffer
DATBPT: BLOCK MAXIDX+1 ;Buffer pointer
DATBCT: BLOCK MAXIDX+1 ;Buffer count
DATIOC: BLOCK MAXIDX+1 ;Storage over IOC errors
DATLEN: BLOCK MAXIDX+1 ;File bytes remaining (Text)
DATRCV: BLOCK MAXIDX+1 ;LM bytes received (Text)
DATSYA: BLOCK MAXIDX+1 ;Synch mark routine
DATSYN: BLOCK MAXIDX+1 ;Synch mark routine arg
DATLWD: BLOCK MAXIDX+1 ;Last word
DATICN: BLOCK MAXIDX+1 ;IOC error continuation address
IFN ITS,[
DATDEV: BLOCK MAXIDX+1 ;Device
DATFN1: BLOCK MAXIDX+1 ;First filename
DATFN2: BLOCK MAXIDX+1 ;Second filename
DATSNM: BLOCK MAXIDX+1 ;Sname (directory)
];ITS
IFN TNX,[
DATJFN: BLOCK MAXIDX+1 ;JFN
DATDSP: BLOCK MAXIDX+1 ;Disposition of file when closed
;RH is JFN of file being replaced
;LH is flag bits:
DD.SUP==:1 ;Supersede old file by renaming to JFN in RH
DD.REN==:2 ;Rename old file, then rename new file
DD.RND==:4 ;Same as DD.REN, but delete old file too
DD.ABT==:10 ;Close in abort mode, delete the new file
DD.OPN==:20 ;File in RH is open (to lock it), remember to close it
DATFBS: BLOCK MAXIDX+1 ;File byte size
];TNX
;Status contains:
ST%CLO==:0 ;Closed state (initial state)
ST%OPN==:1 ;Open state
ST%ASY==:2 ;Asynchronous marked state
ST%SYN==:3 ;Synchronous marked state
ST%EOF==:4 ;Eof state
ST.SYN==:(1_22) ;Synchronous mark (expected, on input; needed, on output)
ST.BIN==:(1_23) ;Binary mode
ST.UNC==:(1_24) ;The last asynchronous error is uncontinuable
ST.DEL==:(1_25) ;Deleted files are ok
IFN TNX,[
ST.TEM==:(1_26) ;Temporary file
] ;END IFN TNX
ST.OUT==:(1_27) ;COMGJF wants file for output
ST.RAW==:(1_30) ;Raw: no character translation whatsoever
ST.SUI==:(1_31) ;Super-image: don't treat rubouts specially
ST.DIR==:(1_32) ;This channel is in use for directory hackery
ST.ACT==:(1_43) ;This channel is active (sign bit!)
IFN TNX,[
ST.PON==:(1_33) ;COMGJF should do parse only
];TNX
ST.NOK==:(1_34) ;New file ok for completion, also used by COMPR4
ST.FST==:(1_35) ;Fast directory listing option
ST.ALD==:(1_36) ;Directories only listing option (ALL-DIRECTORIES)
ST.PDT==:(1_37) ;Don't update access dates, etc.
ST.SUB==:(1_40) ;Submit this file as batch
ST.PRO==:(1_40) ;Doing PROPERTIES rather than DIRECTORY (same as ST.SUB!!)
ST.INL==:(1_41) ;Inhibit links
IFN 20X,[
ST.RET==:(1_42) ;WE RETRIEVED THIS FILE
];20X
;Opcodes:
CO%SYN==:%CODAT+1 ;Synchronous mark
CO%ASY==:%CODAT+2 ;Asynchronous mark
CO%NOT==:%CODAT+3 ;Notification
CO%BDT==:%CODAT\100 ;Binary data
CO%TXT==:%CODAT ;Text opcode
CO%EOF==:%COEOF ;EOF opcode
%CLEND==400000
; Packets
CTLPKI: BLOCK %CPMXW ;control in
CTLPKO: BLOCK %CPMXW ;control out
REAPKT: BLOCK %CPMXW
WRIPKT: BLOCK %CPMXW
ASYPKT: BLOCK %CPMXW
;;; Random impure data
DEBUG: 0 ;-1 if debugging, +1 means dump ourselves if error (-20 only)
;Set to zero if you purify, unless you change that
CHPMXW: %CPMXW-%CPKDT ; Left as-is for ITS, but adjusted for TOPS-20
CHPMXC: %CPMXC
IFN TNX,[
IFE OZ\XX,[
IFNDEF $$SUBM, $$SUBM==1 ;Allowing people to SUBMIT files to us?
IFNDEF $$CCUC, $$CCUC==1 ;Check Chaosnet-User-Capability?
IFNDEF $$LOG, $$LOG==0 ;Write log files
IFNDEF $$LNM, $$LNM==0 ;Parse logical-name definitions file at login time
];Not OZ\XX
IFN OZ\XX,[
IFNDEF $$SUBM, $$SUBM==1
IFNDEF $$CCUC, $$CCUC==0
IFNDEF $$LOG, $$LOG==0
IFNDEF $$LNM, $$LNM==0
];OZ\XX
ANONUM: 0 ;ANONYMOUS's user#
IFN 20X,[
DEVDEG: 0 ;[UTexas] for saving device designator
STRNAM: BLOCK 5 ;For converting sixbit structures to ascii
CNCTED: 0 ;are you foreignly connected?
CONFNM: BLOCK 10. ;Made by JFNS (for trying to CONNECT)
RETENA: 0 ;AUTOMATIC FILE RETRIEVALS ENABLED?
$$LNM==1 ;Process LOGICALS.CMD on login?
];20X
IFNDEF .SFCHA,$$CCUC==0 ;Only if MIDAS knows about Chaos capability do we care
IFE 20X,$$CCUC==0 ;No chaos checking on 10X
IFE 20X,$$SUBM==0 ;Or batch (of QUASAR sort)
IF1,[
IFN $$SUBM, INFORM Ability to submit batch jobs included
IFN $$CCUC, INFORM Checking of chaosnet-user capability included
IFN $$LOG, INFORM Log-file writing included
IFN $$LNM, INFORM Reading of LOGICALS.CMD file included
];IF1
TMPFIL: BLOCK 20 ;Temporary filename, for overwriting.
DMPACS: BLOCK 20 ;Save ACs when we dump ourselves
OZ$LOG==OZ*$$LOG
];TNX
IFE OZ,OZ$LOG==0
PDLEN==170
PDL: -PDLEN,,.+1 ;Size carefully chosen to give 1K impure
BLOCK PDLEN
FHNOUT: BLOCK 1 ;WORD TO OUTPUT FILE HANDLE FROM
0
PTCVER: 0 ;Protocol version number
IFN ITS, MACNAM: 0 ;The machine we are on
CLODAT: 0 ;Temporary storage by CLOSE operation
CLOLEN: 0
ERRCOD: 0 ;Error code returned by .CALL OPEN
SYSBGF: 0 ;Flag set to force 3-letter code to BUG
ERRLEN==:100.
ERRBUF: BLOCK ERRLEN/5
IFN ITS, SSYDF2: 0 ;Temporary storage of old DF2 word
TRANID: 0 ;Transaction ID
0
PKTLOC: CTLPKO ;COMCTL (et al.) use this as packet address
USERID: 0 ;User ID, set by LOGIN. Must be non-zero to do OPEN's
DIRPDL: 0 ;Saved stack for unwinding directory output
IFN ITS,[
STARF2: 0 ;Non-0 want "*" for default FN2, else ">"
HSNAME: 0 ;User HSNAME, sets files' authors
DIRLCK: 0 ;Only one channel can use DIRBUF
WRITER: BLOCK 2
] ;END IFN ITS
IFN TNX,[
RESLEN==:200
RESBLK: BLOCK RESLEN/5
CTLJFN: 0
WILDIR: 0 ;Temporary for EXPFNM
NOTNEW: 0 ;Flag for COMGJF - No GJ%NEW, please (ran out
;of bits for doing this in DATSTA, foo)
;0 => ST.OUT => GF%FOU and GJ%NEW
;1 => no GJ%FOU
;-1 => GJ%OLD (ignore ST.OUT)
INQBLK:
GTJBLK: ;For long call GTJFN for completion
CRDBLK: ;Argument block for CRDIR
DIRINF: BLOCK 50 ;For GTDIR info (in LOGIN command) and GTFDB
JFNSTR: BLOCK 30. ;For building JFN's, 149 chars should be ok
INQBLL==.-INQBLK
USRNUM: BLOCK 1
UDRNUM: BLOCK 1 ;Your home dir#
CWDNUM: BLOCK 1 ;dir# you have explicitly connected to
DWNTIM: BLOCK 1
IFN 10X, BLOCK 1
TIMINF: BLOCK 1
SAVEBP: BLOCK 1
WRITER: BLOCK 40./5
JFNBLK: .GJDEF ;Can be changed to .GJALL later
.NULIO,,.NULIO
0 ;Connected structure
0 ;Connected directory
-1,,[Ascii /*/] ;Default FILENAME,
-1,,[Ascii /*/] ;EXTENSION,
0 ;Default protection,
0 ;and account.
0 ;Not used (.GJJFN)
IFN $$SUBM,[
.QOCQE==37
.QCFIL==10
.QCQUE==24
.OTBAT==4
QUTILB: .MURSP ;Get PID of...
.SPQSR ;QUASAR...
QSRPID: 0 ;<here>
MSendB: 0 ;Arg block for the SUBMIT MSEND
YerPID: 0 ;Your PID
0 ;QUASAR's PID
1000,,QSRPAG ;1 page from here (saved, then restored).
];$$SUBM
IFN $$LNM,[
strbsz==200.
strbuf: block strbsz/5
atmbuf: block strbsz/5
cmdblk: 0,,lnm10
0,,.nulio ;.CMIOJ
440700,,[0] ;.CMRTY - no prompt
440700,,strbuf ;.CMBFP
440700,,strbuf ;.CMPTR
strbsz ;.CMCNT
strbsz ;.CMINC
440700,,atmbuf ;.CMABP
strbsz ;.CMABC
0 ;.CMGJB
];$$LNM
IFN $$SUBM,[
QPBLK: 0,,.QOCQE ;Create Queue Entry
0 ? 0 ;Unused header words.
0 ;Unused flag word
2 ;Two arg blocks...
2,,.QCQUE ;[#1] 2-word block: QUE type is...
.OTBAT ;BATCH
0,,.QCFIL ;[#2] n word block... a filespec.
BLOCK 12.
];$$SUBM
IFN OZ\XX,[
KSITE: BLOCK 10. ;Your site, like /MIT-LISPM-12/
Remark: Block 20. ;Session remark, "CHAOS SERVER " + KSITE
HostN: 0 ;Host number... hoo summoned us?
]
IFN OZ,[
GOTINQ: 0 ;Non-0 if have Inquire mapped in.
INQADR: 0 ;Address of user's Inquire entry (or 0 if none)
TimeOn: 0 ;Suicide TIMER is on.
DownpT: 0 ;System is going down, and channel 33 is in use.
LispMf: 0 ;Non-0 if connected from a LispM
LogJFN: 0 ;JFN for hangers-on log
IFN $$LOG,[
TriJFN: 0 ;Trickle file JFN
Trikle: Block 20 ;Trickle filename
];$$LOG
];OZ
];END IFN TNX
IMPLOC==.
LOC PURBEG
;;; Pure tables
IFN ITS,[
CTLOUT: SETZ
SIXBIT /PKTIOT/
%CLIMM,,CTRLO
%CLIMM+%CLEND,,CTLPKO
CTLINP: SETZ
SIXBIT /PKTIOT/
%CLIMM,,CTRLI
%CLIMM+%CLEND,,CTLPKI
] ;END IFN ITS
IFN OZ,[ ;NETWRK is pure code
.INSRT MID:MACROS
HOSTSP==100 ;Map HOSTS2 at this page.
$$CHAOS==1 ;We only want chaosnet.
$$HSTMAP==1 ;Map/unmap file utils;
$$HOSTNM==1
$$SYMLOOK==1
NETWRK"E=IDX
IFN NETWRK"E-<D+1>, .ERR NETWRK wants E to be D+1
.INSRT MID:NETWRK
%%T==T ? %%TT==TT ;HAKINQ expects AC4 to be available
T=C ? TT=D ;and since T=4, it loses very badly.
$$MAP==1
$$READ==1
$$XLATE==1
$$NPNAME==1
.INSRT MID:HAKINQ
T=%%T ? TT=%%TT
];OZ
;;; Macros
DEFINE CERR CODE,TEXT
JSP D,COMERR
SKIPA
'!CODE,,[ASCIZ \F TEXT\]
TERMIN
DEFINE AERR CONTIN,CODE,TEXT
JSP D,ASYERR
JRST .+3
'!CODE,,[ASCIZ \F TEXT\]
CONTIN
TERMIN
DEFINE IOCERR ADR
JSP D,ICCERR
SKIPA
ADR
TERMIN
;;; Main program. Startup, initialization, control connection main loop
FILE:
IFN ITS,SETZB F,DIRLCK
IFN TNX,SETZ F,
MOVE P,PDL
IFN ITS,[
.SUSET [.ROPTION,,T]
TLO T,OPTINT\OPTOPC ;TURN ON NEW STYLE INTERRUPTS
.SUSET [.SOPTION,,T]
.SUSET [.SDF1,,[%PIDBG+%PIDWN]] ;DEFER SYS DOWN, SYS DEBUG
.SUSET [.SMASK,,[%PIIOC+%PIDBG+%PIDWN]] ;ENABLE INTERRUPTS
.CALL [ SETZ ;GET OUT MACHINE'S NAME
SIXBIT /SSTATU/
MOVEM A ? MOVEM B ? MOVEM T ? MOVEM T ? MOVEM T
SETZM MACNAM]
.LOSE %LSSYS
SKIPLE A ;GET INITIAL HIT OF DOWN/DEBUG INTERRUPTS
.SUSET [.SIPIRQC,,[%PIDWN]]
SKIPE B
.SUSET [.SIPIRQC,,[%PIDBG]]
.CALL [ SETZ ;ASSIGN CHAOSNET CONTROL CHANNELS
SIXBIT /CHAOSO/
%CLIMM,,CTRLI
%CLIMM,,CTRLO
%CLIMM,,5 ((SETZ))]
.LOGOUT 1,
MOVEI T,%COLSN ;LISTEN FOR OUR CONTACT NAME
DPB T,[CTLPKO+$CPKOP]
MOVE T,[.BYTE 8 ? "F ? "I ? "L ? "E]
MOVEM T,CTLPKO+%CPKDT
MOVEI T,4
DPB T,[CTLPKO+$CPKNB]
.CALL CTLOUT ;OUTPUT THE LISTEN
.LOSE %LSSYS
MOVEI T,30.*30. ;30. SEC TIMEOUT
SKIPGE DEBUG ;UNLESS DEBUGGING
HRLOI T,177777
.CALL [ SETZ ;WAIT FOR A RESPONSE OR TIMEOUT
SIXBIT /NETBLK/
%CLIMM,,CTRLO
%CLIMM,,%CSLSN
T
SETZM TT]
.LOSE %LSSYS
CAIE TT,%CSRFC ;RFC RECEIVED?
.VALUE
.CALL CTLINP ;READ RFC PACKET
.LOSE %LSSYS
LDB T,[CTLPKI+$CPKOP]
CAIE T,%CORFC
.VALUE
MOVE P,PDL
PUSHJ P,CHKPVR ;CHECK PROTOCOL VERSION NUMBER
.VALUE ;ALREADY WILL HAVE SENT CLS IF NO GOOD
MOVEI T,%COOPN ;SEND OPN BACK
DPB T,[CTLPKO+$CPKOP]
.CALL CTLOUT
.LOSE %LSSYS
SKIPGE DEBUG ;DEBUGGING?
JRST CTLLOP ;YES, SO DON'T TRY TO LOGIN
LDB T,[$CPKSA CTLPKI] ;GET SOURCE HOST ADDRESS
MOVE TT,[SIXBIT /000C00/] ;CONVERT HOST NUMBER TO SIXBIT
DPB T,[220300,,TT]
LSH T,-3
DPB T,[300300,,TT]
LSH T,-3
DPB T,[360300,,TT]
.SUSET [.RUIND,,T] ;INCORPORATE USER INDEX ALSO
DPB T,[000300,,TT]
LSH T,-3
DPB T,[060300,,TT]
LSH T,-3
DPB T,[170100,,TT] ;C77 + 1 = K00 TO AVOID DUPLICATIONS
MOVE T,TT ;SAVE COPY FOR XUNAME
MOVEI A,100(TT) ;DON'T LOOP FOREVER, ONLY 100 TIMES
CHALS1: CAIN A,(TT)
.VALUE ;I DON'T THINK THIS CAN HAPPEN, BUT IT DOES ANYWAY
.CALL [SETZ
SIXBIT /LOGIN/
TT ? [SIXBIT /CHAOS/] ? SETZ T]
AOJA TT,CHALS1 ;ERROR, PERHAPS NEED TO TRY OTHER UNAME
.SUSET [.SJNAME,,[SIXBIT /FILE/]]
.CALL [SETZ ? 'DETACH ? MOVEI %JSELF ? ANDI 3 ]
.LOSE %LSSYS ;MAKE SELF SYSTEM-DAEMON FOR FAST RESPONSE
CTLLOP: MOVE P,PDL ;IN CASE OF ERROR, RESTORE PDL
SETZ F, ;CLEAR FLAGS
.SUSET [.SDF1,,[0]] ;ALLOW SYS DOWN, SYS DEBUG INTERRUPTS NOW
.CALL CTLINP ;GET NEXT CONTROL PACKET, HANG IF NECESSARY
.LOSE %LSSYS
.SUSET [.SDF1,,[%PIDBG+%PIDWN]] ;DEFER THESE INTS WHILE PROCESSING
LDB T,[CTLPKI+$CPKOP]
CAIL T,%CODAT ;THIS A DATA PACKET?
JRST COMMAN ;YES, OK, GO DO A COMMAND FROM IT
CAIE T,%COEOF ;LISP MACHINE WANT TO CLOSE THE CONNECTION?
JRST CTLLOP ;HMMM, BAD PACKET, IGNORE IT FOR NOW
CTLERR:
CTLDON: .LOGOUT 1, ;Go away immediately, do not RENMWO any output files
] ;END IFN ITS
IFN TNX,[
RESET ;Reset the Universe
MOVEI 1,.FHSLF ;Setup our interrupt vector
MOVE 2,[LEVTAB,,CHNTAB]
SIR
MOVEI 1,.FHSLF ;Turn on interrupt system
EIR
MOVEI 1,.FHSLF ;Enable interesting interrupts
MOVE 2,[000747,,000004]
AIC
IFN 20X,[
MOVE 1,[SIXBIT /CHPMXT/] ; Get max packet size
SYSGT
TLNE 1,-1
JRST [ MOVE 1,[SIXBIT /LHOSTN/] ; Old flavor monitor
SYSGT
CAIE 1,54 ; XX ?
SKIPA 1,300 ; no - size is 300
MOVEI 1,488. ; yes - size is max
JRST .+1 ]
MOVEM 1,CHPMXC ; Set max # chars
LSH 1,-2
MOVEM 1,CHPMXW ; Set max # words
]
MOVE 1,[SIXBIT /FILE/]
IFN 10X,SETNM
IFN 20X,[
MOVE 2,1
SETSN
JFCL
IFE OZ\XX,[
SETO 1, ;THIS JOB
MOVEI 2,.SJSRM ;SET SESSION REMARK
HRROI 3,[ASCIZ /CHAOS SERVER/]
SETJB ;DO IT
ERJMP .+1 ;OR DON'T
];IFE OZ\XX
];20X
HRLZI 1,(GJ%SHT) ;Short GTJFN to get the control channel
HRROI 2,[ASCIZ \CHA:.FILE\]
GTJFN
ERCAL CTLDON
HRRZM 1,CTLJFN ;JFN for control channel
MOVE 2,[100000,,OF%RD\OF%WR]
OPENF ;Listen for connection
ERCAL CTLDON
MOVEI 2,.MOPKR
MOVEI 3,CTLPKI
MTOPR
ERCAL CTLDON
MOVE P,PDL
PUSHJ P,CHKPVR ;CHECK PROTOCOL VERSION NUMBER
JRST CTLDN0 ;ALREADY WILL HAVE SENT CLS IF NO GOOD
MOVE 1,CTLJFN
MOVEI 2,.MOOPN ;Accept the connection
MTOPR
ERCAL CTLDON
PUSHJ P,TIMIN1 ;Turn on timer interrupts
IFN OZ,[
SETOM RETENA ;CHEAP WAY TO ENABLE FILE RETRIEVALS
MOVEI A,HOSTSP
PUSHJ P,NETWRK"HSTMAP ;Map in HOSTS2 database
JRST CTLLOP ; oops
];IFN OZ
IFN OZ\XX,[
LDB B,[$CPKSA+CTLPKI] ;SOURCE ADDRESS
Movem B,HostN ;Save for later.
];IFN OZ\XX
IFN OZ,[
PUSHJ P,NETWRK"HSTSRC ;Look up name of who's knocking
JRST CTLLOO
HRRO 2,A ;-1,,(A) in AC2
HRROI 1,KSITE ;Get the host-name in KNAME
SETZ 3,
SOUT
];IFN OZ
IFN XX,{ ;There's a perfectly good jsys,
MOVEI 1,.CHNNS ;why map host tables?
HRROI 2,KSITE
MOVE 3,HostN
CHANM%
ERJMP [HRROI 1,KSITE ;Lookup failed, use octal number
MOVE 2,B
MOVEI 3,8
NOUT%
ERJMP .+1 ;this shouldn't ever fail
JRST .+1]
};IFN XX
IFN OZ\XX,[
HRROI 1,REMARK
HRROI 2,[ASCIZ "CHAOS SERVER "]
SETZ 3,
SOUT
HRROI 2,KSITE
SOUT
SETO 1, ;THIS JOB
MOVEI 2,.SJSRM ;SET SESSION REMARK
HRROI 3,REMARK
SETJB ;DO IT
ERJMP .+1 ;OR DON'T
];IFN OZ\XX
IFN OZ,[
HLRZ A,1(D) ;Address of system-name
ADD A,NETWRK"HSTADR
MOVE T,(A)
CAMN T,[ASCII /LISPM/]
JRST [ TRO F,F.LSP ;We are a LispMachine
MOVEI 1,.FHSLF
SETO 3,
EPCAP ;Enable!!
JRST CTLLOO ]
Movei 1,.GJALL ;Known not to be a Lisp machine, use * as default vers
Movem 1,JFNBLK+.GJGEN
IFN $$LOG,[
Setom LispMf
GJINF
Move T,3
Hrroi 1,Trikle
Hrroi 2,[Asciz "SS:<TRIKLE>"]
Setz 3,
SOUT
Hrroi 2,KSite
SOUT
; Hrroi 2,[Asciz "-JOB-"]
; SOUT
; Move 2,T
; Movei 3,10.
; NOUT
; Jfcl
Hrroi 2,[Asciz ".LOG"]
Setz 3,
SOUT
Movsi 1,(GJ%SHT\GJ%FOU)
Hrroi 2,Trikle
GTJFN
Jrst CTLLOO ;No biggie (if it fails)
Movem 1,TriJFN
Move 2,[70000,,OF%WR]
OPENF
Jrst [Move 1,TriJFN
RLJFN
Jfcl
Setzm TriJFN
Jrst CTLLOO]
Seto 2, ;Now
Setz 3,
ODTIM
Hrroi 2,[Asciz " Log started
"]
Setz 3,
SOUT
];$$LOG
CTLLOO: PUSHJ P,NETWRK"HSTUNMAP ;We don't need those pages anymore
];OZ
CTLLOP: MOVE P,PDL ;For safety, reset the world
SETZ F,
SETO A, ;Allow timer interrupts
EXCH A,TIMINF ;See if timer went off
SKIPE A
PUSHJ P,DWNCHK ;It did, do check now
MOVE 1,CTLJFN ;Wait for a control packet
MOVEI 2,.MOPKR
MOVEI 3,CTLPKI
MTOPR
ERCAL CTLERR ;Flush ourselves if any error
IFN OZ$LOG,[
Skipn 1,TriJFN
Jrst CTLLOR
Seto 2,
Setz 3,
ODTIM
Hrroi 2,[Asciz " <==
"] ? Setz 3,
SOUT
Skipe TimeOn ;Activity! Turn off pending
Jrst [Move 1,[.FHSLF,,.TIMAL] ;suicide interrupt (actually
TIMER ;turn them all off)
Setzm TimeOn
Jrst .+1]
CTLLOR:
];OZ$LOG
SETZM TIMINF ;No longer allow timer interrupts
LDB T,[CTLPKI+$CPKOP]
CAIL T,%CODAT ;THIS A DATA PACKET?
JRST COMMAN ;YES, OK, GO DO A COMMAND FROM IT
CAIE T,%COEOF ;LISP MACHINE WANT TO CLOSE THE CONNECTION?
JRST CTLLOP ;HMMM, BAD PACKET, IGNORE IT FOR NOW
PUSHJ P,CTLDON ;Does not return.
CTLDON: SKIPG DEBUG ;Dump ourselves
JRST CTLDN0
MOVEM 0,DMPACS
MOVE 0,[1,,DMPACS+1]
BLT 0,DMPACS+17
MOVE 1,[GJ%SHT+GJ%FOU+GJ%NEW]
IFN 20X,HRROI 2,[ASCIZ \PS:<CRASH>DEAD-FILEJOB.EXE\]
IFN 10X,HRROI 2,[ASCIZ \DSK:<CHAOS>DEAD-FILEJOB.SAV\]
GTJFN
JRST CTLDN0
HRLI 1,.FHSLF
MOVE 2,[777760,,20]
SAVE
CTLDN0:
IFN OZ$LOG,[
Skipn 1,TriJFN
Jrst ZZZ
Seto 2,
Setz 3,
ODTIM
Hrroi 2,[Asciz " Closing log file - EOF received"]
Setz 3,
SOUT
CLOSF
Jfcl
ZZZ:
];OZ$LOG
IFN 10X,[ ;Tenex LGOUT doesn't do this itself
MOVEI IDX,MAXIDX-1 ;Last output channel
CTLDN1: HRRZ 1,DATSTA(IDX)
JUMPE 1,CTLDN2 ;ST%CLO
MOVE 1,DATJFN(IDX)
HRLI 1,(CO%NRJ) ;Close file, but keep around JFN
CLOSF
ERJMP CTLDN2 ;Ain't much else we can do...
DELF ;Delete the file and release JFN
ERJMP CTLDN2
CTLDN2: SUBI IDX,2
JUMPGE IDX,CTLDN1
];IFN 10X
IFN 20X,[
MOVEI 1,.FHSLF
HRLI 1,(CZ%ABT+CZ%NUD) ;Abort all output operations +
; don't update disk copy of directory
CLZFF ; and close all files
ERJMP .+1 ;oh well, we tried.
];IFN 20X
MOVNI 1,1 ;-1 means log us out
SKIPL DEBUG ;If debugging, just stop, will die if top-level
LGOUT ;Bye-bye
HALTF
JRST .-1
CTLERR: MOVEI 1,.FHSLF
PUSHJ P,$GETER
PUSHJ P,CTLDON ;Punt if no err
MOVE 1,[441000,,CTLPKO+%CPKDT]
MOVSI 3,-%CPMXC
ERSTR
PUSHJ P,CTLDON
JFCL
CTLER1: SETZ BC,
IFN 10X,IDPB BC,1 ;Put in null at end
MOVE 1,[441000,,CTLPKO+%CPKDT]
ILDB 2,1
CAIE 2,0
AOJA BC,.-2 ;Get real size
MOVEI T,%COLOS ;Send LOS packet
DPB T,[$CPKOP+CTLPKO]
DPB BC,[$CPKNB+CTLPKO]
MOVE 1,CTLJFN
MOVEI 2,.MOPKS
MOVEI 3,CTLPKO
MTOPR
ERCAL CTLDON
PUSHJ P,CTLDON
] ;END IFN TNX
;;; Called c(D)+1 has code,,pointer-to-asciz-string
COMERR: MOVEI A,[ASCIZ \ERROR \] ;INDICATE AN ERROR TO THE REQUESTOR
PUSHJ P,COMCTL
HLLZ A,1(D) ;GET ERROR CODE
PUSHJ P,COMSXO
MOVEI BYTE,40
PUSHJ P,COMCHO
HRRZ A,1(D) ;NOW OUTPUT THE ERROR STRING
PUSHJ P,COMSTO
PUSHJ P,COMSND
JRST CTLLOP
MINPTC==0
MAXPTC==1
;;; Check protocol version number
CHKPVR: MOVE BP,[441000,,CTLPKI+%CPKDT]
LDB BC,[CTLPKI+$CPKNB]
PUSHJ P,COMRD5 ;SHOULD BE FILE
TDZA A,A
PUSHJ P,COMDCI ;GET NUMBER INTO A
MOVEM A,PTCVER
CAIL A,MINPTC
CAILE A,MAXPTC
SKIPA
JRST POPJ1
MOVEI A,[ASCIZ \PROTOCOL VERSION \]
PUSHJ P,COMCTL
MOVE A,PTCVER
PUSHJ P,COMDCO
MOVEI A,[ASCIZ \ NOT SUPPORTED\]
PUSHJ P,COMSTO
MOVEI T,%COCLS
JRST COMSN1
;;; Here to handle a command over the control connection
COMBAD: CERR BUG,[Illegal request format]
COMMAN:
IFN OZ$LOG,[
SKIPN TRIJFN
JRST XXX2
LDB A,[$CPKNB+CTLPKI] ;Byte-count
MOVE B,[441000,,CTLPKI+%CPKDT]
PUSHJ P,PKTPRT
XXX2:
];OZ$LOG
MOVE BP,[441000,,CTLPKI+%CPKDT]
LDB BC,[CTLPKI+$CPKNB]
PUSHJ P,COMRD5 ;Get transaction ID
JRST CTLLOP ;Error, ignore this request (what else?)
MOVEM A,TRANID
TRZ F,F.FHN ;NO FILE HANDLE SEEN YET
MOVEI B,5 ;MAXIMUM FILE-HANDLE SIZE
SETZ FHN,
MOVE A,[440700,,FHN] ;ACCUMULATE FILE HANDLE
COMFHL: SOJL BC,COMBAD ;BAD CONTROL PACKET: PROTOCOL VIOLATION
ILDB BYTE,BP ;GET THE NEXT CHARACTER
CAIN BYTE,40 ;SPACE TERMINATES FILE HANDLE
JRST COMMA1 ;KEEP PROCESSING
IDPB BYTE,A
SOJG B,COMFHL ;ONLY READ FIRST 5 CHARACTERS
PUSHJ P,COMEUS ;EAT UNTIL SPACE SEEN
JRST COMBAD ;NON-SKIP, HIT END OF PACKET OR NEWLINE, ERROR
COMMA1: JUMPE FHN,COMMA2 ;DON'T HAVE A FILE HANDLE AFTER ALL
TRO F,F.FHN
MOVEI IDX,MAXIDX-1 ;LOOP OVER ALL INDICIES
COMMA3: CAMN FHN,DATFHN(IDX) ;MATCH?
JRST COMMA2 ;YUP, LEAVE IDX IN IDX
SOJGE IDX,COMMA3
CERR BUG,[Unknown file handle]
COMMA2: PUSHJ P,COMR10 ;READ 10 CHARACTERS INTO A AND B
JFCL
JUMPE A,[CERR BUG,[Null command name]]
MOVSI T,-COMTAL ;AOBJN POINTER
COMCO1: CAMN A,COMTAB(T) ;MATCH?
CAME B,COMTAB+1(T)
AOJA T,COMCO2 ;NO, TRY NEXT
HRRZS T ;YES, RUN THE COMMAND
LSH T,-1
JRST @COMDSP(T)
COMCO2: AOBJN T,COMCO1
CERR UKC,[Unknown command]
;;; Command table
COMTAB: ASCII \DATA-CONNE\ ;DATA-CONNECTION
ASCII \UNDATA-CON\ ;UNDATA-CONNECTION
ASCII \OPEN\ ? 0 ;OPEN
ASCII \CLOSE\ ? 0 ;CLOSE
ASCII \FILEPOS\ ;FILEPOS
ASCII \DELETE\ ;DELETE
ASCII \RENAME\ ;RENAME
ASCII \CONTINUE\ ;CONTINUE
ASCII \SET-BYTE-S\ ;SET-BYTE-SIZE
ASCII \LOGIN\ ? 0 ;LOGIN
ASCII \DIRECTORY\ ;DIRECTORY
ASCII \COMPLETE\ ;COMPLETE
ASCII \CHANGE-PRO\ ;CHANGE-PROPERTIES
ASCII \CREATE-DIR\ ;CREATE-DIRECTORY
ASCII \EXPUNGE\ ;EXPUNGE
ASCII \HOMEDIR\ ;HOMEDIR
ASCII \FILE-SYSTE\ ;FILE-SYSTEM-INFO
ASCII \PROPERTIES\ ;PROPERTIES
IFN ITS,ASCII \CREATE-LIN\ ;CREATE-LINK
IFN TNX,[
ASCII \CWD\ ? 0 ;CHANGE WORKING DIRECTORY (CONNECT)
IFN 20X,ASCII \ACCESS\ ;ACCESS DIRECTORY
ASCII \ENABLE-CAP\ ;ENABLE-CAPABILITIES
ASCII \DISABLE-CA\ ;DISABLE-CAPABILITIES
];TNX
COMTAL==<.-COMTAB>/2
COMDSP: COMDCN
COMUDC
COMOPN
COMCLO
COMFIL
COMDEL
COMREN
COMCON
COMSBS
COMLOG
COMDIR
COMCPL
COMCNG
COMCRD
COMEXP
COMHOM
COMFSI
COMPRO
IFN ITS,COMCRL
IFN TNX,[
COMCWD
IFN 20X,COMACD
COMENA
COMDIS
];TNX
IFN .-COMDSP-COMTAL, .ERR COMDSP and COMTAB lengths disagree
;;; Subroutines
;Read the next token from the stream. Reads the first 5 bytes, and throws away the rest.
; Destroys T, TT, and BYTE; result in A. Tail recurses to COMEUS
COMR10: MOVEI T,10. ;ALLOW 10 CHARACTERS INTO A AND B
TDZA B,B
COMRD5: MOVEI T,5
TRZ F,F.NWL
SETZ A,
MOVE TT,[440700,,A] ;ACCUMULATE TOKEN IN A
COMR5A: SOJL BC,CPOPJ ;END OF PACKET, HAVE TOKEN
ILDB BYTE,BP ;GET THE NEXT CHARACTER
CAIN BYTE,215 ;NEWLINE TERMINATES
JRST COMEUN
CAIN BYTE,40 ;SPACE TERMINATES THE TOKEN
JRST COMEUR
IDPB BYTE,TT
SOJG T,COMR5A ;ONLY READ FIRST 5 CHARACTERS
; JRST COMEUS ;FALL INTO COMEUS
;Eats until end of stream, space, or newline seen
; Non-skip return if end of packet or newline seen, skip return if space seen
COMEUS: SOJL BC,COMEUP ;IF END OF STREAM, RETURN
ILDB BYTE,BP ;NEXT BYTE
COMEUA: CAIN BYTE,215 ;NEWLINE
JRST COMEUN
CAIE BYTE,40 ;SPACE
JRST COMEUS ;NOPE, KEEP GOING
COMEUR: AOS (P) ;SKIP RETURN
COMEUP: TRZA F,F.NWL
COMEUN: TRO F,F.NWL
CPOPJ: POPJ P,
;Single byte output
;Must preserve TT
COMCHO: CAML BC,CHPMXC
CERR BUG,[Too much information to fit in a packet]
IDPB BYTE,BP
AOJA BC,CPOPJ
;;; For TOPS-20, output from RESBLK, where lots of interesting things get returned
IFN TNX, COMRES: SKIPA A,[440700,,RESBLK]
;String out, string address in A, COMST0 if already byte pointer
COMSTO: HRLI A,440700 ;MAKE A A STRING POINTER
COMST0: ILDB BYTE,A ;GET NEXT CHARACTER
COMST1: JUMPE BYTE,CPOPJ ;TERMINATE ON NULL
XCT CHR2LM(BYTE) ;CONVERT TO LISP MACHINE CHARACTER SET
PUSHJ P,COMCHO ;NON-SKIP, JUST OUTPUT
JRST COMST0
JRST COMST0 ;IGNORE RUBOUT ESCAPE, SHOULDN'T HAPPEN HERE
MOVEI BYTE,115 ;POSSIBLY STRAY RETURN, OUTPUT M TO BE SAFE NOW
PUSHJ P,COMCHO
ILDB BYTE,A ;AND ABSORB FOLLOWING LINE FEED
CAIE A,12
JRST COMST1
MOVEI BYTE,215 ;CARRIAGE RETURN FOR CRLF
DPB BYTE,BP ;REPLACE M IN PACKET
JRST COMST0
;Decimal output, value in A, destroys A and B
COMDCO: JUMPL A,CPOPJ ;IGNORE NEGATIVE NUMBERS
PUSH P,[-1] ;FLAG BOTTOM OF STACK
COMDO0: IDIVI A,10.
PUSH P,B
JUMPN A,COMDO0
COMDO1: POP P,BYTE
JUMPL BYTE,CPOPJ ;DO UNTIL NO MORE DIGITS
ADDI BYTE,"0
PUSHJ P,COMCHO
JRST COMDO1
;Octal output, value in A, destroys A
COMOCO: PUSH P,[-1] ;FLAG BOTTOM OF STACK
COMOO0: PUSH P,A
ANDI A,7 ;SAVE BOTTOM DIGIT
EXCH A,(P)
LSH A,-3
JUMPN A,COMOO0
COMOO1: POP P,BYTE
JUMPL BYTE,CPOPJ ;DO UNTIL NO MORE DIGITS
ADDI BYTE,"0
PUSHJ P,COMCHO
JRST COMOO1
;Sixbit output, sixbit in A, destroys A and B. Quotes funny characters.
COMSXO: MOVE B,A
COMSO0: JUMPE B,CPOPJ ;TERMINATE WHEN NO MORE BYTES
SETZ A,
LSHC A,6 ;GET NEXT BYTE
JUMPE A,COMSOQ ;QUOTE LEADING SPACES
CAIE A,': ;AND : OR ;
CAIN A,';
JRST COMSOQ
COMSO1: MOVEI BYTE,40(A) ;MAKE ASCII
PUSHJ P,COMCHO ;OUTPUT THE BYTE
JRST COMSO0
COMSOQ: MOVEI BYTE,"
PUSHJ P,COMCHO
JRST COMSO1
;Output date/time from A
COMDTO: PUSH P,D
MOVEI D,COMCHO ;Output char in BYTE to command response
JRST COMDT0
DIRDTO: PUSH P,D
MOVEI D,DIRCHO ;Output char in BYTE to directory listing
COMDT0:
IFN TNX,[
;; Internal date/time in A -- convert to ITS format
MOVE 2,A
AOSN A ;If -1, then use 0
SETZ 2,
SETZ 4,
ODCNV ;Convert internal date/time to printable format
ERCAL SYSBUG
HRRZ A,4 ;Local time in seconds
LSH A,1 ;Number of half-seconds since midnight
HLRZ T,2 ;The year
SUBI T,1900.
DPB T,[330700,,A]
AOS 2
DPB 2,[270400,,A] ;The month
HLRZ T,3 ;The day
AOS T
DPB T,[220500,,A]
] ;END IFN TNX
IFN ITS,[
HLRZ B,A
ANDI B,177777
CAIN B,-1
MOVEI A,0 ;Unknown => start of century
]
PUSH P,A
LDB A,[270400,,0 (P)] ;MONTH 3.9-3.6
CAIG A,12.
CAIG A,0
MOVEI A,1 ;Lisp machine barfs if month is bogus
IDIVI A,10.
MOVEI BYTE,"0(A)
PUSHJ P,(D)
MOVEI BYTE,"0(B)
PUSHJ P,(D)
MOVEI BYTE,"/
PUSHJ P,(D)
LDB A,[220500,,0 (P)] ;DAY 3.5-3.1
CAIG A,31.
CAIG A,0
MOVEI A,1 ;Lisp machine barfs at bogus days now, too
IDIVI A,10.
MOVEI BYTE,"0(A)
PUSHJ P,(D)
MOVEI BYTE,"0(B)
PUSHJ P,(D)
MOVEI BYTE,"/
PUSHJ P,(D)
LDB A,[330700,,0 (P)] ;YEAR 4.7-4.1
IDIVI A,100.
MOVE A,B ;Ignore overflow if 3-digit year (garbage)
IDIVI A,10.
MOVEI BYTE,"0(A)
PUSHJ P,(D)
MOVEI BYTE,"0(B)
PUSHJ P,(D)
MOVEI BYTE,40
PUSHJ P,(D)
HRRZ A,(P) ;TIME
LSH A,-1 ;Half-seconds since midnight, HOW RANDOM!
CAIL A,86400.
MOVEI A,0 ;I suppose the Lisp machine probably checks this too
IDIVI A,60. ;Get number of seconds
PUSH P,B ;Save them
IDIVI A,60. ;Get number of minutes
PUSH P,B ;Save them
REPEAT 3,[ ;Output each of the sections with intervening colons
IDIVI A,10.
MOVEI BYTE,"0(A)
PUSHJ P,(D)
MOVEI BYTE,"0(B)
PUSHJ P,(D)
IFN .RPCNT-2,[
MOVEI BYTE,":
PUSHJ P,(D)
POP P,A
] ;End IFN
] ;End REPEAT
POP P,A
POP P,D
POPJ P,
;Setup for returning a control packet
COMCTL: MOVE BP,[441000,,%CPKDT]
ADD BP,PKTLOC
SETZ BC,
PUSH P,A
MOVEI A,TRANID ;Get current transaction ID
PUSHJ P,COMSTO ;This heads all replies
MOVEI BYTE,40
PUSHJ P,COMCHO
TRNN F,F.FHN ;FILE HANDLE?
JRST COMCT0
MOVE A,DATFHN(IDX) ;YES, GET THE FILE HANDLE
MOVEM A,FHNOUT
MOVEI A,FHNOUT ;AND LEAD WITH IT
PUSHJ P,COMSTO
COMCT0: POP P,A
MOVEI BYTE,40
PUSHJ P,COMCHO ;LEADING SPACE
JRST COMSTO ;OUTPUT THE APPROPRIATE COMMAND AND RETURN
;Send or expect synchronous mark. For output files, A is pointer to routine to be run
; when mark arrives. NOTE: this routine will not work recursivly
COMSSY:
IFN ITS,[
.SUSET [.SPICLR,,[0]] ;To prevent timing screws, turn off all interrupts
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF ;Disable interrupts temporarily to prevent timing lossage
DIR
] ;END IFN TNX
MOVE T,DATSTA(IDX)
TLO T,ST.SYN ;Send synchronous mark
JRST @SSYDSP(T) ;Dispatch on current state
SSYDSP: SSYCLO ;Closed
SSYOPN ;Open
SSYASY ;Async marked
SSYSYN ;Sync marked
SSYEOF ;EOF state
;Sync marked state means that the mark has arrived already. Run the routine here and now.
; A gets replaced with the channel status
SSYSYN: EXCH T,A ;Meanings are reversed
TLZ A,ST.SYN ;No longer marked
IFN ITS,[
.SUSET [.SDF2,,[-1]] ;Defer all channel interrupts
.SUSET [.SPICLR,,[-1]] ;Reenable things like IOC et al
] ;END IFN ITS
PUSHJ P,(T) ;Call routine
MOVEM A,DATSTA(IDX) ;May have changed channel state
IFN TNX,[
;; Since on Tops-20 there is no way to defer only a certain set of interrupts, they
;; will all be left defered. This is a total loss.
MOVEI 1,.FHSLF ;Turn interrupt back on
EIR
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
AIC ;Reenable interrupts on this channel
; MOVEI 1,.FHSLF
; MOVE 2,CHABIT(IDX)
IIC ;Force interrupt on channel to start ball rolling
] ;END IFN TNX
IFN ITS,[
.SUSET [.SDF2,,SSYDF2] ;Restore old DF2 value
MOVE T,CHABIT(IDX)
TRNN IDX,1 ;This an output idx?
JRST SSYSY0 ;Nope, need to cause interrupt to get ball rolling
ANDCAM T,SSYDF2 ;This interrupt is no longer deffered
.SUSET [.SDF2,,SSYDF2]
;;; NOTE: Due to the fact that some packets may be sitting in the buffers but not
;;; interrupting (if we dismissed the interrupt with packets lying around), we
;;; better cause an interrupt to let them get processed
SSYSY0: .SUSET [.SIIFPIR,,T]
] ;END IFN ITS
POPJ P,
;Closed or in EOF state
SSYCLO:
SSYEOF: TRNN IDX,1 ;An input channel?
JRST SSYAS0 ;Yes, cause an interrupt to get the ball rolling
JRST SSYOPN
;Async marked means that interrupts (for output channels) have been deffered.
SSYASY:
IFN ITS,[
TRNN IDX,1 ;This an output channel?
JRST SSYAS0 ;Nope, so no need to undefer
MOVE TT,CHABIT(IDX) ;Get mask bit
ANDCAM TT,SSYDF2 ;Undefer
.SUSET [.SDF2,,SSYDF2]
SSYAS0: MOVE TT,CHABIT(IDX)
.SUSET [.SIIFPIR,,TT] ;Cause interrupt to happen right now
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
AIC ;Reenable interrupts on this channel
SSYAS0: MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
IIC ;Force interrupt on channel to start ball rolling
] ;END IFN TNX
; JRST SSYOPN ;Fall into SSYOPN
;Open just needs to set bit
SSYOPN: MOVEM T,DATSTA(IDX)
MOVEM A,DATSYA(IDX) ;A is pointer to action to be taken upon receipt/transmission
IFN ITS,[
.SUSET [.SPICLR,,[-1]] ;Reenable the world
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
EIR ;Turn the interrupt system back on
] ;END IFN TNX
POPJ P,
;;; Send the control packet that has been built in CTLPKO
COMSND: MOVEI T,CO%TXT
COMSN1: DPB T,[$CPKOP+CTLPKO]
DPB BC,[$CPKNB+CTLPKO]
IFN ITS,[
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIMM,,CTRLO
%CLIMM+%CLEND,,CTLPKO]
.LOSE %LSSYS
POPJ P,
] ;END IFN ITS
IFN TNX,[
MOVE 1,CTLJFN
MOVEI 2,.MOPKS
MOVEI 3,CTLPKO
MTOPR
ERCAL CTLERR
IFN $$LOG,[
SKIPN 1,TRIJFN
POPJ P,
SETO 2,
SETZ 3,
ODTIM
HRROI 2,[ASCIZ " ==>
"] ? SETZ 3,
SOUT
LDB A,[$CPKNB CTLPKO]
MOVE B,[441000,,CTLPKO+%CPKDT]
PUSHJ P,PKTPRT
];$$LOG
POPJ P,
] ;END IFN TNX
IFN ITS,[
;File name reader. Returns in DAT???(IDX)
COMPFN: MOVSI TT,'DSK ;Default device is DSK
MOVEM TT,DATDEV(IDX)
SETZM DATSNM(IDX) ;Default directory is last-used
SETZM DATFN1(IDX) ;No default FN1
MOVSI TT,(SIXBIT />/)
SKIPE STARF2
MOVSI TT,(SIXBIT /*/)
MOVEM TT,DATFN2(IDX)
TRZ F,F.FN1+F.FN2+F.DEV+F.DIR
COMPF0: PUSHJ P,COMSYL ;Read next sixbit frob, BYTE has terminator
JUMPE A,COMPF1
CAIN BYTE,":
JRST [ MOVEM A,DATDEV(IDX) ? TRO F,F.DEV ? JRST COMPF0 ]
CAIN BYTE,";
JRST [ MOVEM A,DATSNM(IDX) ? TRO F,F.DIR ? JRST COMPF0 ]
SKIPN DATFN1(IDX)
JRST [ MOVEM A,DATFN1(IDX) ? TRO F,F.FN1 ? JRST COMPF1 ]
MOVEM A,DATFN2(IDX)
TRO F,F.FN2
COMPF1: CAIN BYTE,215 ;Terminate on newline
JRST COMEUN
JRST COMPF0
] ;END IFN ITS
IFN TNX,[
;;Look for a full file specification
COMGJF: MOVE 2,BP ;Source of filename
PUSHJ P,COMEUS ;Find end of filename
JRST [TRZN F,F.NWL ;Must be terminated with a newline
JRST COMBAD
JRST .+2]
JRST .-2 ;Terminated by space, so keep searching
SETZ 1,
DPB 1,BP ;Insure terminating NULL
COMGJG: PUSH P,2 ;Save BP in case we need to re-try something.
MOVE 1,[GJ%SHT+.GJDEF] ;Setup flags to GTJFN
TLNE D,ST.OUT
SKIPGE NOTNEW
TLOA 1,(GJ%OLD) ;Input or know-to-be-existing file...
JRST [ TLO 1,(GJ%NEW)
SKIPG NOTNEW
TLO 1,(GJ%FOU)
JRST .+1 ]
TLNE D,ST.DIR
JRST [ TLO 1,(GJ%IFG)
JRST COMGJ1] ;Allow wild cards for directory
TLNE D,ST.TEM ;Temporary file?
TLO 1,(GJ%TMP)
COMGJ1: TLNE D,ST.DEL ;Permit deleted file?
TLO 1,(GJ%DEL)
TLNE D,ST.PON
JRST [ TLO 1,(GJ%OFG)
TLZ 1,(GJ%OLD)
JRST .+1] ;Parse only if so desired
COMGJ2: GTJFN
SKIPA ;JSYS error, return it to user
AOS -1(P)
POP P,2 ;Leave AC2 pointing to the filename...
POPJ P,
COMGDJ: MOVE 2,BP ;Source of filename
PUSH P,2
PUSHJ P,COMEUS ;Find end of filename
JRST [TRZN F,F.NWL ;Must be terminated with a newline
JRST COMBAD
JRST .+2]
JRST .-2 ;Terminated by space, so keep searching
SETZ 1,
DPB 1,BP ;Insure terminating NULL
MOVSI 1,(GJ%OLD\GJ%IFG)
TLNE D,ST.DEL ;Permit deleted file?
TLO 1,(GJ%DEL)
TLNE D,ST.PON ;Parse-only?
TLC 1,(GJ%OFG\GJ%OLD\GJ%IFG)
HLLM 1,JFNBLK
MOVEI 1,JFNBLK
JRST COMGJ2
] ;END IFN TNX
;Read a syllable
COMSYL: SETZ A,
MOVE TT,[440600,,A]
COMSY3: SOJL BC,COMBAD ;If no more bytes then done
ILDB BYTE,BP
CAIE BYTE,^Q ;Allow ^V to quote too, for the sake of
CAIN BYTE,^V ;20's on which ^Q is an interrupt character.
SKIPA
JRST COMSY1 ;Not quoted char
SOJL BC,COMBAD
ILDB BYTE,BP
JRST COMSY2
COMSY1: CAIE BYTE,": ;Colon, semicolon and space and control chars end syllable
CAIN BYTE,";
JRST CPOPJ
CAIN BYTE,215
JRST COMEUN
CAIN BYTE,40 ;Space ends syllable if not quoted
JRST CPOPJ
COMSY2: CAIGE BYTE,40 ;Control chars end syllable even if ^Q'd.
POPJ P,
CAIGE BYTE,140 ;Skip if "lower case"
SUBI BYTE,40
TLNE TT,770000
IDPB BYTE,TT
JRST COMSY3
COMOCI: SKIPA T,[8]
;;; Decimal number reader
COMDCI: MOVEI T,10. ;Read in BASE 10
COMNUI: SETZ A,
COMNU0: SOJL BC,CPOPJ
ILDB BYTE,BP
CAIL BYTE,"0
CAIL BYTE,"0(T)
JRST COMEUA
IMULI A,(T)
ADDI A,-"0(BYTE)
JRST COMNU0
;;; Sixbit input. Raise case of letters. Terminate on space or non-sixbit.
COMSXI: MOVEI T,6. ;Maximum of 6 chars
MOVE TT,[440600,,A] ;Collect in A
SETZ A,
COMSI0: SOJL BC,CPOPJ ;Return if nothing more to read
ILDB BYTE,BP
CAIL BYTE,"a
CAILE BYTE,"z
SKIPA
SUBI BYTE,"a-"A
SUBI BYTE,40 ;Convert to sixbit
JUMPLE BYTE,CPOPJ ;Return if it's a non-sixbit character or space
CAILE BYTE,77
POPJ P,
SOJL T,COMSI0 ;Don't stick in if no more room
IDPB BYTE,TT
JRST COMSI0
;;; Date input
IFN ITS,[ ;This only allows MM/DD/YY HH:MM:SS
COMDTI: SETZ A,
PUSHJ P,COMDT1
DPB T,[270400,,A] ;Month 3.9-3.6
PUSHJ P,COMDT1
DPB T,[220500,,A] ;Day 3.5-3.1
PUSHJ P,COMDT1
DPB T,[330700,,A] ;Year 4.7-4.1
CAIN BYTE,215 ;If no newline, then no time
JRST COMEUN
PUSHJ P,COMDT1 ;Hours
MOVE B,T
PUSHJ P,COMDT1 ;Minutes
IMULI B,60.
ADD B,T
PUSHJ P,COMDT1 ;Seconds
IMULI B,60.
ADD B,T
LSH B,1 ;Half seconds
HRR A,B
POPJ P,
COMDT1: SETZ T,
COMDT2: SOJL BC,CPOPJ
ILDB BYTE,BP
CAIL BYTE,"0
CAILE BYTE,"9
POPJ P,
IMULI T,10.
ADDI T,-"0(BYTE)
JRST COMDT2
] ;END IFN ITS
IFN TNX,[
COMDTI: MOVE 1,BP ;Source of date
PUSHJ P,COMEUS ;Find end
JRST [TRZN F,F.NWL ;Must be terminated with a newline
JRST COMBAD
JRST .+2]
JRST .-2 ;Terminated by space, so keep searching
SETZ 2,
DPB 2,BP ;Insure terminating NULL
IDTIM
ERCAL JSYSER
MOVE A,2
POPJ P,
] ;END IFN TNX
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; For a JSYS that might get an access violation, try it, and if it
;;; fails, see if you can CONNECT no password, and if so, try the
;;; JSYS again.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
IFN 20X,[
TRYCON: PUSH P,1 ;Save arg in AC1 which might be clobbered by error.
PUSH P,A ;Save temp
HRRZ A,-2(P) ;Get return addr, which should be addr of JSYS
XCT (A)
ERJMP [CAIN 1,DELFX1 ;DELF errors (delete access required)
JRST CONECT
CAIN 1,RNAMX8 ;RNAMF errors (write or owner on source)
JRST CONECT
CAIE 1,OPNX3 ;OPENF errors (read, write, execute,
CAIN 1,OPNX4 ;or append access required).
JRST CONECT
CAIE 1,OPNX5
CAIN 1,OPNX6
JRST CONECT
CAIN 1,CFDBX3 ;CHFDB error (write or owner access)
JRST CONECT
JRST CONLUZ ] ;Not an error we know.
POP P,A ;We win. Clean the stack,
POP P,1
AOS (P) ;and skip-return past the JSYS (and its
JRST POPJ1 ;trailing error jump)
CONECT: PUSH P,2
HRROI 1,CONFNM
MOVEM 1,RESBLK+.ACDIR
HRRZ 2,DATJFN(IDX) ;JFN
MOVE 3,[.JSAOF_33.+.JSAOF_30.+JS%PAF]
JFNS ;Get DEV:<DIRECTORY> into CONFNM
ERJMP CONLZ1
SETZM RESBLK+.ACPSW ;No password ...
SETOM RESBLK+.ACJOB ;This job.
MOVE 1,[AC%CON+3] ;AC%CONnext to dir, 3 word arg block.
MOVEI 2,RESBLK ;Address of block.
ACCES
ERJMP CONLZ1
SETOM CNCTED
POP P,2 ;Clean the stack...
POP P,A ;and return to the JSYS
POP P,1
POPJ P,
CONLZ1: POP P,2 ;CONECT failed
CONLUZ: AOS -2(P) ;Address of instruction after JSYS
HLRZ A,@-2(P)
CAIN A,(ERCAL) ;Simulate ERCAL
JRST [ HRRZ A,@-2(P)
AOS -2(P) ;Return address for ERCAL
MOVEM A,-1(P)
POP P,A
POPJ P, ]
CAIN A,(ERJMP) ;Simulate ERJMP
JRST [ HRRZ A,@-2(P)
MOVEM A,-2(P)
JRST .+1 ]
POP P,A
SUB P,[1,,1] ;Return error code, not saved 1
POPJ P,
DISCON: SKIPN CNCTED
POPJ P,
SKIPN 1,CWDNUM ;If you are in an explicit CONNECT
MOVE 1,UDRNUM ;state, then return there, else it
MOVEM 1,RESBLK+.ACDIR ;an implicit one, so return to home
SETZM RESBLK+.ACPSW ;dir.
SETOM RESBLK+.ACJOB
MOVE 1,[AC%CON+3]
MOVEI 2,RESBLK
ACCES
ERJMP CPOPJ
SETZM CNCTED
POPJ P,
];20X
;;; Create a new data connection
COMDCN: TRZN F,F.FHN ;MUST NOT HAVE A FILE HANDLE
TRZE F,F.NWL ;NEWLINE TERMINATES COMMAND?
JRST COMBAD ;ILLEGAL REQUEST FORMAT
PUSHJ P,COMRD5 ;READ THE NEXT TOKEN, WHICH SHOULD BE THE INPUT FILE HANDLE
JRST COMBAD
PUSH P,A ;SAVE ON STACK
PUSHJ P,COMRD5 ;NEXT TOKEN AS WELL
TRZE F,F.NWL ;BETTER HAVE GOTTEN TO END OF PACKET
JRST COMBAD ;NOT END OF PACKET, BUT DIDN'T WANT ANY MORE CRUFT
MOVEI IDX,MAXIDX-2 ;CHECK FOR A FREE DATA CONNECTION
COMDC2: SKIPN DATFHN(IDX) ;BOTH FILE HANDLE'S NULL MEANS A FREE ONE
SKIPE DATFHN+1(IDX)
JRST COMDC1 ;NOT FREE, CONTINUE SEARCHING
MOVEM A,DATFHN+1(IDX) ;OUTPUT FILE HANDLE
POP P,DATFHN(IDX) ;AND INPUT FILE HANDLE
MOVEM A,FHNOUT ;FILE HANDLE TO RFC TO: USE THE OUTPUT SIDE
IFN ITS,[
.CALL [ SETZ
SIXBIT /CHAOSO/
%CLIN,,CHACHN+1(IDX)
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,15.]
JRST [ SETZM DATFHN(IDX) ;IDX's not really in use
SETZM DATFHN+1(IDX)
CERR NER,[Not enough Chaosnet channels]]
MOVEI A,FHNOUT ;POINT TO IT
SETZ BC,
MOVE BP,[441000,,CTLPKO+%CPKDT]
PUSHJ P,COMSTO ;STRING-OUT TO PACKET, POINTER TO STRING IN A
MOVEI T,%CORFC
DPB T,[CTLPKO+$CPKOP] ;RFC
DPB BC,[CTLPKO+$CPKNB] ;NUMBER OF BYTES
LDB T,[CTLPKI+$CPKSA]
DPB T,[CTLPKO+$CPKDA]
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,CTLPKO]
.LOSE %LSSYS
MOVE T,CHABIT(IDX) ;Get input channel bit
IOR T,CHABIT+1(IDX) ;And output channel bit
.SUSET [.SIMSK2,,T] ;Enable interrupts on these channels
] ;END IFN ITS
IFN TNX,[
HRROI 1,JFNSTR ;Build output string
HRROI 2,[ASCIZ \CHA:\]
SETZB 3,4
SOUT
ERCAL SYSBUG
LDB 2,[CTLPKI+$CPKSA] ;Source address
MOVEI 3,8.
NOUT
ERCAL SYSBUG
MOVEI 2,".
IDPB 2,1
HRROI 2,FHNOUT
SOUT ;Now have: CHA:<host>.<contact name>
ERCAL SYSBUG
HRLZI 1,(GJ%SHT) ;Short GTJFN to get the channel
HRROI 2,JFNSTR
GTJFN
ERCAL SYSBUG
HRRZM 1,CHAJFN(IDX) ;This is this idx's input and output JFN
HRRZM 1,CHAJFN+1(IDX)
MOVE 2,[100000,,OF%RD\OF%WR]
OPENF ;Listen for connection
ERCAL SYSBUG
MOVE 1,CHAJFN(IDX) ;Set input window size
MOVEI 2,.MOSWS
MOVEI 3,15
MTOPR
ERCAL SYSBUG
MOVE 1,CHAJFN(IDX) ;Assign interrupt channel
MOVEI 2,.MOACN
MOVE 3,IDX
LSH 3,-1
MOVE 3,CHAICN(3) ;Output,,Input channels
MTOPR
ERCAL SYSBUG
MOVEI 1,.FHSLF ;Activate the interrupt channel
MOVE 2,CHABIT(IDX)
AIC
SETZM DATJFN(IDX)
SETZM DATDSP(IDX)
] ;END IFN TNX
MOVEI A,[ASCIZ \DATA-CONNECTION\]
PUSHJ P,COMCTL ;SEND RESPONSE
PUSHJ P,COMSND ;SEND THE CONTROL PACKET
JRST CTLLOP ;RETURN TO MAIN CONTROL CONNECTION WAIT
COMDC1: SUBI IDX,2
JUMPGE IDX,COMDC2 ;LOOP IF MORE CHANNELS TO CHECK
CERR NER,[Not enough I/O channels]
;;; Destroys a data connection
COMUDC: TRNE F,F.FHN ;Must have a file handle
TRZE F,F.NWL ;Not terminated by newline
JRST COMBAD
JUMPGE BC,COMBAD ;But that's all there is
TRO IDX,1 ;Point to top of two channel pair
SKIPGE DATSTA(IDX) ;Channel active?
PUSHJ P,CLOSIT ;Yes, close it
SETZM DATSTA(IDX) ;Make sure channel is deactivated
TRZ IDX,1 ;Now point to bottom of pair
SKIPGE DATSTA(IDX) ;What about this on. Is it active?
PUSHJ P,CLOSIT ;Yes, close it
SETZM DATSTA(IDX) ;Make sure channel is deactivated
MOVEI A,[ASCIZ \UNDATA-CONNECTION\]
PUSHJ P,COMCTL ;Setup control packet
PUSHJ P,CHNFLS ;Flush the chaos channels
PUSHJ P,COMSND ;Send it
JRST CTLLOP ;Return to main loop
;;; Flush chaos net channels pointed to by IDX. IDX assumed to point
;;; to the input (even) side.
CHNFLS:
IFN ITS,[
MOVE T,CHABIT(IDX)
IOR T,CHABIT+1(IDX)
.SUSET [.SAMSK2,,T] ;Turn off interrupts for the two chaos channels of interest
.CALL [ SETZ
SIXBIT /CLOSE/ ;Close the chaos channels
%CLIN+%CLEND,,CHACHN(IDX)]
.LOSE %LSSYS
.CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,CHACHN+1(IDX)]
.LOSE %LSSYS
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
DIC ;Disable the interrupt channel
HRRZ 1,CHAJFN(IDX) ;Close and release JFN
CLOSF
JFCL
] ;END IFN TNX
SETZM DATFHN(IDX) ;Make this pair available for a new data connection
SETZM DATFHN+1(IDX)
POPJ P,
;;; LOGIN command
COMLOG: TRZN F,F.FHN ;No file handle
TRZE F,F.NWL ;No newline
JRST COMBAD
IFN ITS,[
PUSHJ P,COMSXI ;Read user id in sixbit
MOVEM A,USERID ;Remember for later
MOVEI A,[ASCIZ \LOGIN \]
PUSHJ P,COMCTL
SKIPE A,USERID
PUSHJ P,GETNAM ;Output uname, hsname and personal name
.SUSET [.SSNAME,,HSNAME] ;Initialize default directory
.SUSET [.SHSNAM,,HSNAME] ; and home directory
.SUSET [.SXUNAM,,USERID] ; and user name
] ;END IFN ITS
IFN TNX,[
SKIPN ANONUM
JRST [MOVSI 1,(RC%EMO)
HRROI 2,[ASCIZ "ANONYMOUS"]
RCUSR
TLNE 1,(RC%NOM)
SETO 3,
MOVEM 3,ANONUM ;Anonymous's user#
JRST .+1]
JUMPLE BC,CTLDN0 ;Really logout if no arguments
MOVE 2,BP ;Save copy of byte pointer
PUSHJ P,COMEUS ;Eat until space, newline, or end
JUMPL BC,COMBAD ;End of packet is no good
SETZ T, ;Deposit null to terminate string
DPB T,BP
IFN OZ,[
Push P,2
Skipn GOTINQ ;Inquire database here?
Jrst [Movei A,IPAGE ;No, so map it in now.
Pushj P,HAKINQ"MAPIN
Jrst BADINQ
Setom GOTINQ
Move A,(P)
Jrst .+2]
Move A,2
Pushj P,HAKINQ"XLATE ;Lookup and turn into user#
Jrst BADINQ
Movem A,INQADR ;Save address of inquire entry
Movem B,USRNUM ;and user#
Pop P,2
Jrst COMLCC
BADINQ: Setzm INQADR ;0 means we have no Inquire information.
Pop P,2
];OZ Inquire login
MOVSI 1,(RC%EMO) ;Exact match
RCUSR
ERJMP .+2
TLNE 1,(RC%NOM) ;Matched?
CERR UNK,[User not known]
MOVEM 3,USRNUM ;Save user number
COMLCC:
IFN 20X,[
IFN $$CCUC,[ ;and then only if turned on at assembly time
MOVEI 1,.FHSLF ;Must enable for GTDIR
RPCAP
MOVE 3,2
EPCAP
MOVEI 1,0
MOVE 2,USRNUM
RCDIR ;Get dir number
MOVE 1,3
MOVEI 2,DIRINF ;Discover user's capabilities
MOVEI 3,0
SETZM DIRINF
GTDIR
ERCAL SYSBUG
MOVEI 1,.SFCHA ;See if Chaosnet checking is on
TMON
ERJMP COMLG1 ;Not even implemented - skip check
JUMPE 2,COMLG1 ;It's off - skip the check
MOVE 1,DIRINF+.CDPRV ;Check for Chaos net privilege
TRNN 1,SC%CHA
CERR LIP,[No Chaosnet privileges]
COMLG1:
] ;END IFN $$CCUC
] ;END IFN 20X
PUSHJ P,ANONPW
JRST COMLGP ;Need a password, rats.
HRROI 2,JFNSTR
SETZB 3,T ;No account given
JRST COMLG4
COMLGP: MOVE 1,USRNUM ;Recover your old usernumber.
MOVE 2,BP ;Beginning of password string
ILDB 3,2 ;Get and save first char
TRZ F,F.ENA
CAIN 3,"* ;Is first letter * ?
TROA F,F.ENA ;Enable
SKIPA 2,BP ;Remember unbumped version
MOVE BP,2 ;Update BP to skip *
IFN 10X, MOVE 3,BP ;Keep a copy to do uppercasing
PUSHJ P,COMEUS ;Find next terminating character
JFCL
IFN 10X,[ ;Tenex LOGIN expects uppercase?
COMLGU: CAMN 3,BP ;Until end of this string
JRST COMLG0
ILDB T,3 ;Get a character of the password
CAIL T,"a ;and force it to be uppercase
CAILE T,"z
CAIA
SUBI T,40
DPB T,3 ;Store back the uppercased char
JRST COMLGU
COMLG0:
];END IFN 10X
SETZ T,
DPB T,BP ;Terminate password with null byte
MOVE 3,BP ;This is account string
PUSHJ P,COMEUS ;Then find end of string
JUMPGE BC,COMBAD
SETZ T,
DPB T,BP ;Terminate with null byte
IDPB T,BP ;In case no acct string given
MOVE T,3
ILDB T,T
IFN 20X,[
SKIPN T
SETZ 3, ;Use default if empty string
];20X
COMLG4:
IFN 10X,[
JUMPN T,COMLG3
PUSH P,2 ;Save password string
MOVEI 1,DIRINF ;Where to put account designator if string
MOVE 2,USRNUM
GDACC
SETZ 1, ;Doesn't seem to have a default, will get error
MOVE 3,1 ;Number or byte pointer
POP P,2 ;Get back password
COMLG3: MOVE 1,USRNUM
];10X
SKIPGE DEBUG
JRST [ PUSHJ P,$HELLO ;If debugging, don't do real login, or enable
JRST COMLG2]
PUSHJ P,$LOGIN
PUSHJ P,JSYSER
IFN OZ,[ ;This doesn't do what we want, alas.
IFN 0,[
TRNE F,F.LSP
JRST [MOVEI 1,.FHSLF ;((IFF LISPMACHINE)) --
RPCAP ;Now that you're logged in, read your
MOVE 3,2 ;capabilities, and limit yourself to
EPCAP ;them.
JRST .+1]
];IFN 0
];OZ
COMLG2: MOVEI A,[ASCIZ \LOGIN \] ;Success reply
PUSHJ P,COMCTL
PUSHJ P,GETNAM
] ;END IFN TNX
PUSHJ P,COMSND ;Completion reply
JRST CTLLOP ;Then we are done
;;; Auto-login (as Q.SITE or failing that, ANONYMOUS)
;;; This was not thought out. It needs to be redone.
IFN OZ,[
AUTLOG: CERR NLI,[Not logged in]
IFN 0,[
AUTLOG: PUSHJ P,SITEPW ;try to login as <Q.hostname>
JRST ANNLOG ;Urg, no password file.
HRROI 2,JFNSTR
PUSHJ P,$LOGIN
SKIPA ;double urg, it's WRONG!!
POPJ P, ;ahhh...
ANNLOG: SETZM USRNUM
PUSHJ P,ANONPW ;Can we can login as Anonymous w/o Password?
CERR NLI,[Can't defaultly log you in - no password file]
HRROI 2,JFNSTR
PUSHJ P,$LOGIN ;Login then,
CERR NLI,[Can't defaultly log you in - incorrect password file]
];IFN 0
POPJ P,
];OZ
IFN TNX,[
;;; Log you in as user#(USERNUM), and turn on what privs you have (or else
;;; leave them all on - See the F.ENA flag in F) - Also, set USERID to
;;; reflect loggedinness. Set subsystem name to "FILE".
$LOGIN: LOGIN ;Login with specified parameters
POPJ P, ; LOSSAGE
AOS (P) ;Will take success return
GJINF ;Directory# in AC2
MOVEM 1,USRNUM
MOVEM 2,UDRNUM
TRZN F,F.ENA ;If you want to be priv, don't limit
JRST $HELLO ; yourself, but keep full privs.
MOVEI 1,.FHSLF
RPCAP
MOVE 3,2
EPCAP ;Enable what capabilities you have.
$HELLO: SETOM USERID ;Means we are logged in
;Now attempt to access all structures
IFN 20X,[
PUSH P,C
PUSH P,D
MOVE 1,[SIXBIT /DEVNAM/]
SYSGT
HRRZ D,2 ;Table#
MOVEI C,1 ;Should be 1st device name.
ACCST1: HRLZ 1,C
HRR 1,D ;Offset,,table#
GETAB
JFCL
;;[UTexas] The following won't work if # of strs is maximum allowed by monitor
;; HLRZ 2,1 ;If no more devices, it's SIXBIT/STRnnn/
;; CAIN 2,(SIXBIT /STR/)
;; JRST ACCST9
MOVE 3,[440700,,DIRINF]
ACCST2: SETZ 2, ;Turn sixbit structure name into asciz
ROTC 1,6 ;string.
ADDI 2,40
IDPB 2,3
JUMPN 1,ACCST2
MOVEI 1,":
IDPB 1,3
MOVEI 1,"<
IDPB 1,3
MOVE 1,3 ;Set directory name from our user name
MOVE 2,USRNUM
DIRST
ERJMP ACCST9
MOVEI 3,">
IDPB 3,1 ;Terminate user directory
SETZ 3, ;Null to terminate string
IDPB 3,1
;;Start of UTexas change
PUSH P,1 ;Save BP
HRROI 1,DIRINF ;Set up to get device designator
STDEV
ERJMP [POP P,1
JRST ACCST9]
MOVE 1,2 ;Set up device designator
DVCHR ;Check device type
ERJMP [POP P,1
JRST ACCST9]
POP P,1 ;Restore BP
LDB 3,[221100,,2] ;Get DV%TYP
CAIE 3,.DVDSK ;Is it a disk?
JRST ACCST9 ;No, done
;;End of UTexas changes
HRRZ 2,1 ;Get argument block after dir name
ADDI 2,1 ;First unused word after dir that is
MOVE 1,[440700,,DIRINF] ;Directory name string
MOVEM 1,0(2) ;Store as first word of arg block
SETZM 1(2) ;No password supplied
SETOM 2(2) ;And for this job
MOVE 1,[200000,,3] ;Setup for ACCES call
ACCES ;Attempt the Access
ERJMP .+1 ;So what if it fails
ACCST8: AOJA C,ACCST1 ;Step to next structure.
ACCST9: POP P,D
POP P,C
IFN $$LNM,[ ;Maybe Process LOGICALS.CMD
lnm: move 2,USRNUM
hrli 2,540000 ;Make into directory #
hrroi 1,strbuf
DIRST
erjmp lnm11
move 2,[440700,,[asciz/LOGICALS.CMD/]]
ildb 3,2
idpb 3,1
jumpn 3,.-2
hrroi 2,strbuf
movsi 1,(gj%sht\gj%old)
GTJFN
erjmp lnm11
hrlm 1,cmdblk+.CMIOJ
move 2,[.dpb 7,.bp of%bsz,of%rd]
OPENF
erjmp [hlrz 1,cmdblk+.CMIOJ
RLJFN
erjmp lnm11
jrst lnm11]
lnm1: movei 1,strbsz
movem 1,cmdblk+.CMABC
move 1,[440700,,atmbuf]
movem 1,cmdblk+.CMABP
movei 1,cmdblk
movei 2,[.cmini_9,,0 ? 0 ? 0 ? 0 ? 0]
COMND
erjmp lnm10
movei 2,[.cmkey_9,,0 ? [1,,1 ? [asciz/DEFINE/],,0] ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
;Some people like to put in the noise words in the command file
movei 2,[.cmnoi_9,,0 ? 440700,,[asciz/logical name/] ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
movei 2,[<(cm%po)\.cmdev_9>,,[.cmtok_9,,0 ? 440700,,[asciz/*/] ? 0 ? 0 ? 0]
0 ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
hlrz 3,(3)
movei 4,.CLNJA ;"def *" means delete all logical names
cain 3,.cmtok_9
jrst lnm4 ;Yup
move 3,cmdblk+.CMABC ;Else find end of the device name
move 4,cmdblk+.CMABP
ildb 2,4
soj 3,
jumpn 2,.-2
movem 3,cmdblk+.CMABC ;Will put equivalent name after the device
movem 4,cmdblk+.CMABP
movei 2,[.cmnoi_9,,0 ? 440700,,[asciz/as/] ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
movei 2,[.cmcfm_9,,[.cmtxt_9,,0 ? 0 ? 0 ? 0 ? 0] ? 0 ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
hlrz 3,(3)
movei 4,.CLNJ1 ;"def name:<cr>" means just delete the name
cain 3,.cmcfm_9
jrst lnm5 ;Yup
movei 4,.CLNJB ;Else have a name to define
lnm4: movei 2,[.cmcfm_9,,0 ? 0 ? 0 ? 0 ? 0]
COMND
erjmp lnm10
tlne 1,(cm%nop)
jrst lnm1
lnm5: move 1,4
move 2,[440700,,atmbuf]
move 3,cmdblk+.CMABP
CRLNM
erjmp .+1
jrst lnm1
lnm10: hlrz 1,cmdblk+.CMIOJ
CLOSF
erjmp lnm11
lnm11:
];$$LNM
];20X
POPJ P,
];TNX
;;; HOMEDIR command
COMHOM: TRZN F,F.FHN ;No file handle
TRZE F,F.NWL ;No newline
JRST COMBAD
IFN ITS,[
PUSHJ P,COMSXI ;Read user id in sixbit
PUSH P,A ;Save uname
PUSHJ P,GETINQ ;Get inquir entry address in B
SETZ B, ;Not found
POP P,A
SETZ C, ;Now find HSNAME for local host.
MOVEI D,ERRCH
PUSHJ P,LSRTNS"LSRHSN ;D gets the sixbit HSNAME.
JFCL
MOVEI A,[ASCIZ \HOMEDIR \]
PUSHJ P,COMCTL
MOVE A,D ;HSNAMEP
PUSHJ P,COMSXO
MOVEI BYTE,";
PUSHJ P,COMCHO
PUSHJ P,UNGINQ
PUSHJ P,COMSND
JRST CTLLOP
];ITS
IFN TNX,[
MOVE 2,BP ;BP to start of user name
PUSHJ P,COMEUS ;Eat until space, newline, or end
SKIPGE BC
IBP BP ;No delimiter
SETZ T, ;Deposit null to terminate string
DPB T,BP
IFE OZ,[
MOVSI 1,(RC%EMO) ;Exact match
RCUSR
ERCAL SYSBUG ;Monitor internal errors I guess
TLNE 1,(RC%NOM) ;Matched?
CERR UNK,[User not known]
PUSH P,3 ;Save user number
MOVEI A,[ASCIZ \HOMEDIR \] ;Always succeeds if we get here
PUSHJ P,COMCTL
MOVSI 1,(GJ%OLD\GJ%SHT)
IFN 20X,HRROI 2,[ASCIZ /SYS:PEOPLE.DATA/]
IFN 10X,HRROI 2,[ASCIZ /<INQUIR>PEOPLE.DATA/]
PUSH P,[0]
GTJFN
JRST COMHM3
MOVEM 1,(P) ;Save jfn
MOVE 2,[440000,,OF%RD]
OPENF
JRST COMHM3
HRRZ 3,-1(P) ;User number
RIN
JUMPE 2,COMHM3 ;No information on this user
HLRZ 3,2
HRRZS 2
SFPTR
JRST COMHM3
CAILE 3,INQBLL
MOVEI 3,INQBLL
MOVN 3,3
MOVE 2,[444400,,INQBLK]
SIN ;Get all data on the person
MOVE A,[440600,,INQBLK+1] ;Byte counts
MOVE B,[440700,,INQBLK+4] ;String starts
SETZ C, ;Current field.
MOVEI T,$DNAME
PUSHJ P,GETFLD ;Output directory name followed by a CR
COMHM2: SKIPE 1,(P) ;Release inquir file
CLOSF
JFCL
PUSHJ P,COMSND
JRST CTLLOP
COMHM3: HRROI 1,RESBLK ;No inquir entry, default to user's name
MOVE 2,-1(P) ;User number
IFN 20X,TLO 2,40000
DIRST
JFCL
PUSHJ P,COMRES
JRST COMHM2
];Regular TOPS-20
IFN OZ,[
Push P,2 ;Save copy of BP
Skipn GOTINQ ;Inquire database here?
Jrst [Movei A,IPAGE ;No, so map it in now.
Pushj P,HAKINQ"MAPIN
Jrst NoSUsr
Setom GOTINQ
Jrst .+1]
Move A,(P)
Pushj P,HAKINQ"XLATE ;Lookup and turn into user#
Jrst NoSUsr
Move 3,B
Adjsp P,-1
Jrst UserNo
NoSUsr: Movsi 1,(RC%EMO)
Pop P,2
RCUSR
Erjmp .+2
Tlne 1,(RC%NOM)
CERR UNK,[User not known]
UserNo: Hrroi 1,RESBLK
Move 2,3
Hrli 2,540000 ;PS: LH
DIRST
Nop
Movei A,[Asciz "HOMEDIR "]
Pushj P,COMCTL
Pushj P,COMRES
Pushj P,COMSND
Pushj P,CLOINQ
Jrst CTLLOP
];OZ HOMEDIR from new Inquire
];TNX
IFN ITS,[
;;; INQUIR hacking
$$ULNM==0
$$ULNP==0
$$UNAM==0
$$HSNM==1
LSRTNS"E==T
LSRPGS==200 ;Pages for LSRTNS hacking
NLSPGS==20 ;Reserve 20 of them
.INSRT SYSENG;LSRTNS >
;;; Output UNAME<SP>HSNAME<NL>PERNAM<NL>GROUP
GETNAM: PUSH P,B
PUSH P,C
PUSH P,D
PUSH P,A
PUSHJ P,GETINQ
JRST [SETZ B, ;No entry there
MOVE A,(P) ;UNAME
PUSH P,B
PUSHJ P,COMSXO
JRST GETNM1] ;And go compute HSNAME.
MOVE A,(P) ;UNAME in A, core addr still in B.
PUSH P,B ;Save INQUIRE entry address
PUSHJ P,COMSXO ;Output UNAME.
GETNM1: MOVEI BYTE,40
PUSHJ P,COMCHO ;SP.
MOVE A,-1(P) ;Username
MOVE B,(P) ;INQUIR entry
SETZ C, ;Now find HSNAME for local host.
MOVEI D,ERRCH
PUSHJ P,LSRTNS"LSRHSN ;D gets the sixbit HSNAME.
JFCL
MOVE A,D ;Get answer.
MOVEM A,HSNAME
PUSHJ P,COMSXO ;Output HSNAME or nothing.
MOVEI BYTE,215
PUSHJ P,COMCHO ;NL.
MOVEI A,LSRTNS"I$NAME
MOVE B,(P) ;INQUIRE entry
PUSHJ P,LSRTNS"LSRITM ;Get personal name.
JRST [ MOVE A,[440700,,[ASCIZ /???/]]
JRST .+1 ]
PUSHJ P,COMST0 ;Output PERNAM or nothing.
MOVEI BYTE,215
PUSHJ P,COMCHO ;NL
MOVEI A,LSRTNS"I$GRP
POP P,B ;INQUIRE entry
PUSHJ P,LSRTNS"LSRITM ;Get Group affiliation.
JRST [ MOVE A,[440700,,[ASCIZ /-/]]
JRST .+1 ]
PUSHJ P,COMST0 ;Output GROUP.
UNMAPL: PUSHJ P,UNGINQ
POP P,A
POP P,D
POP P,C
POP P,B
POPJ P,
;Get INQUIR entry for uname on the stack, and skip return with inquir entry address in B
GETINQ: MOVEI A,UTILCH ;Channel for LSRTNS
MOVE B,[-NLSPGS,,LSRPGS]
PUSHJ P,LSRTNS"LSRMAP
JRST [CERR NER,[Cannot map INQUIR database]] ;Random error
MOVEI A,UTILCH ;Channels for INQUIR database
MOVE B,-1(P) ;B gets sixbit UNAME.
JRST LSRTNS"LSRUNM ;Map in the LSRTNS entry
;Flush inquir data base
UNGINQ: MOVE B,[-NLSPGS,,LSRPGS]
.CALL [ SETZ ;Done with these
SIXBIT /CORBLK/
%CLIMM,,0
%CLIMM,,%JSELF
SETZ B]
JFCL
.CLOSE UTILCH,
.CLOSE ERRCH,
POPJ P,
] ;END IFN ITS
IFN TNX,[
;;; INQUIR hacking
;;; Output USERNAME<SP>DIRECTORY<NL>PERSONAL NAME<NL>GROUP
IFE OZ,[
$DNAME==0
$HNAME==1
$GROUP==14
GETNAM: HRROI 1,RESBLK
MOVE 2,USRNUM
DIRST
JFCL
MOVEI 2,0
IDPB 2,1
PUSHJ P,COMRES ;Output user name
MOVEI BYTE,40
PUSHJ P,COMCHO
MOVSI 1,(GJ%OLD\GJ%SHT)
IFN 20X,HRROI 2,[ASCIZ /SYS:PEOPLE.DATA/]
IFN 10X,HRROI 2,[ASCIZ /<INQUIR>PEOPLE.DATA/]
PUSH P,[0]
GTJFN
JRST GETNM3
MOVEM 1,(P) ;Save jfn
MOVE 2,[440000,,OF%RD]
OPENF
JRST GETNM3
HRRZ 3,USRNUM
RIN
JUMPE 2,GETNM3 ;No information on this user
HLRZ 3,2
HRRZS 2
SFPTR
JRST GETNM3
CAILE 3,INQBLL
MOVEI 3,INQBLL
MOVN 3,3
MOVE 2,[444400,,INQBLK]
SIN ;Get all data on the person
MOVE A,[440600,,INQBLK+1] ;Byte counts
MOVE B,[440700,,INQBLK+4] ;String starts
SETZ C, ;Current field.
MOVEI T,$DNAME
PUSHJ P,GETFLD
MOVEI T,$HNAME
PUSHJ P,GETFLD
IFN OZ,[ ;Only OZ has groups, but OZ doesn't use this code anymore
MOVEI T,$GROUP
PUSHJ P,GETFLD
];OZ
GETNM2: POP P,1
JUMPE 1,CPOPJ
CLOSF
JFCL
POPJ P,
GETFLD: CAMN C,T
JRST GETFL1
ILDB 1,A
GETFL0: SKIPG 1
AOJA C,GETFLD
ILDB 2,B
SOJA 1,GETFL0
GETFL1: ILDB T,A
GETFL2: SKIPG T
AOJA C,GETFL3
ILDB BYTE,B
PUSHJ P,COMCHO
SOJA T,GETFL2
GETFL3: MOVEI BYTE,215
JRST COMCHO
];Non-OZ TOPS-20 Inquire lookup stuff
IFN OZ,[
GETNAM: Skipn INQADR ;We have Inquire information?
Jrst GETNM3 ; Nope.
IFN 0,[
Move A,INQADR ;Address of start of entry
ADD A,HAKINQ"SRDAT ;point to data portion
repeat hakinq"%uname,[ ;Find uname
ildb 1,A
jumpn 1,.-1
]
Pushj P,COMSTO
]
.ELSE [
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Hrroi 1,RESBLK ;** Flush
Move 2,USRNUM ;** this
DIRST ;** when
Nop ;** LMs
Pushj P,COMRES ;** no
Move A,INQADR ;** longer
Add A,HAKINQ"SRDAT ;** compare
repeat hakinq"%dname,[ ;** usernames
Ildb 1,A ;**
Jumpn 1,.-1 ;**
]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
]
Movei Byte,40
Pushj P,COMCHO
Pushj P,COMST0 ;(cheat, 'cause directory's next)
Movei Byte,215
Pushj P,COMCHO
Move B,A ;Yet MORE cheating, 'cause personal-name
Hrroi A,RESBLK ;comes next
Pushj P,HAKINQ"NPNAME ;(translate into human form)
Jfcl
Pushj P,COMRES ;Output from RESBLK
Movei Byte,215
Pushj P,COMCHO
Movei 2,HAKINQ"%GROUP-HAKINQ"%PNAME ;Number of fields we need to skip
Sojl 2,COMLGG
Ildb 1,B
Jumpn 1,.-1
Jrst .-3
COMLGG: Ildb Byte,B ;First character of group.
Skipe Byte ;No group?
Pushj P,COMCHO ; Yes, so output character.
Movei Byte,215
Pushj P,COMCHO ;then all done.
CLOINQ: Skipn GOTINQ ;If have Inquire database open
Popj P, ; (we don't)
Call HAKINQ"MAPOUT ;then unmap
Skipa ; (failed??)
Setzm GOTINQ ; and mark as disposed of.
Popj P,
];OZ Inquire lookup.
;;; No INQUIR information
GETNM3:
IFN OZ,[ ;OZ forgot to send this already
HRROI 1,RESBLK ;User name
MOVE 2,USRNUM
DIRST
JFCL
PUSHJ P,COMRES
MOVEI BYTE,40
PUSHJ P,COMCHO
];OZ
HRROI 1,RESBLK ;Directory name
MOVE 2,USRNUM
IFN 20X,TLO 2,40000
DIRST
JFCL
PUSHJ P,COMRES
MOVEI BYTE,215
PUSHJ P,COMCHO
MOVEI A,[ASCIZ /???/]
PUSHJ P,COMSTO
MOVEI BYTE,215
PUSHJ P,COMCHO
IFE OZ, JRST GETNM2
IFN OZ, Jrst CLOINQ
;;; Before auto-logging as ANONYMOUS, try to login as Q.yourhostname,
;;; which is easier to track. The password is in <Q>yourhostname.PASSWORD.
IFN OZ,[
IFN 0,[
SITEPW: SKIPE KLOGIN
JRST SITEP2
HRROI 1,KLOGIN
HRROI 2,[ASCIZ /Q./]
SETZ 3,
SOUT
HRROI 2,KSITE
SOUT ;Q.hostname in KSITE
SITEP2: MOVSI 1,(RC%EMO)
HRROI 2,KLOGIN
RCUSR
ERJMP CPOPJ ;make sure it exists.
TLNE 1,(RC%NOM)
POPJ P, ; nope. oh well...
MOVEM 3,USRNUM
SKIPE KPASSF
JRST SITEP3
HRROI 1,KPASSF
HRROI 2,[ASCIZ /PS:<Q>/]
SETZ 3,
SOUT
HRROI 2,KSITE
SOUT
HRROI 2,[ASCIZ /.PASSWORD/]
SOUT
SITEP3: HRROI 2,KPASSF
JRST GETPSW
];IFN 0
];OZ
;;; Check out the possibilities of an Anonymous login. If the file seen
;;; below exists, then it contains the password for the Anon account. We
;;; skip-return with password in JFNSTR if we find it, else non-skip. The
;;; user# is stored in USRNUM.
ANONPW: MOVE 1,ANONUM
CAMN 1,[-1]
POPJ P,
SKIPE USRNUM ;If logging in normally, (we already got the USRNUM
CAMN 1,USRNUM ;just return, unless want to be "Anonymous".
SKIPA
POPJ P,
MOVEM 1,USRNUM
IFN 20X,HRROI 2,[ASCIZ /SYSTEM:ANONYMOUS.USERFILE/]
.ELSE HRROI 2,[ASCIZ /<SYSTEM>ANONYMOUS.USERFILE/]
GETPSW: MOVSI 1,(GJ%OLD\GJ%SHT)
GTJFN
POPJ P, ;File not there - Must specify password.
PUSH P,1 ;Save JFN
MOVE 2,[070000,,OF%RD]
OPENF
JRST [ POP P,1 ;Clean stack,
RLJFN ;release JFN,
JFCL
POPJ P, ] ;and fail-return
MOVE 3,[440700,,JFNSTR]
MOVEI 4,39.
COMLA1: BIN
ERJMP COMLA2
CAIG 2,40
JRST COMLA2
IDPB 2,3
SOJG 4,COMLA1
COMLA2: SETZ 2,
IDPB 2,3 ;Make the password string ASCIZ
POP P,1 ;Get back JFN,
CLOSF ;and close the Anonymous userfile.
JFCL
MOVE 1,USRNUM
JRST POPJ1 ;Skip-return -> We win, have Anonymous's password.
];IFN TNX
;;; Open a file
COMOPN: SKIPN USERID ;Has the user logged in?
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
TRZ F,F.PRB\F.DEF\F.PDR
TLZ F,(F.CRE\F.SUP\F.APP\F.OVW\F.NEW\F.REN\F.RND\F.TRU)
TRNN F,F.FHN ;MUST HAVE A FILE HANDLE FOR NORMAL OPEN
JRST OPNPRB ;ELSE MUST BE A PROBE
SKIPGE DATSTA(IDX) ;THIS CHANNEL CURRENTLY ACTIVE?
PUSHJ P,CLOSIT ;YES, CLOSE IT
IFN TNX,[
PUSHJ P,RELDJF ;Dispose of any left-over JFNs this channel is holding
PUSHJ P,RELRJF ;if it err'ed out of a previous open
];TNX
OPNPR0: SETZB D,DATSTA(IDX) ;START OUT FRESH, D WILL CONTAIN NEW LH OF DATSTA
MOVEI T,16. ;DEFAULT DATBYT
MOVEM T,DATBYT(IDX)
MOVEI T,2. ;NUMBER OF BYTES PER WORD
MOVEM T,DATBPW(IDX)
IFN TNX,[
MOVEI T,36. ;Default file byte size
MOVEM T,DATFBS(IDX)
];TNX
SETZM DATRCV(IDX) ;Start at zero bytes received.
OPNOPT: TRNE F,F.NWL ;NEW LINE TERMINATED OPEN COMMAND?
JRST OPNFNM ;YES, DEFAULT OPTIONS, PARSE FILENAME
PUSHJ P,COMR10 ;GET NEXT TOKEN INTO A,B
JUMPL BC,COMBAD
OPNOLP: MOVSI T,-OPNLEN ;LENGTH OF OPEN OPTION TABLE
OPNOL1: CAMN A,OPNTAB(T) ;MATCH?
CAME B,OPNTAB+1(T)
AOBJN T,[AOJA T,OPNOL1]
JUMPGE T,[CERR UUO,[Unknown OPEN option]]
HRRZS T
LSH T,-1
XCT OPNACT(T) ;PERFORM APPROPRIATE ACTION
JRST COMBAD ;ERROR
JRST OPNOPT
OPNTAB: ASCII \READ\ ? 0 ;Read
ASCII \WRITE\ ? 0 ;Write
ASCII \PROBE\ ? 0 ;Probe
ASCII \CHARACTER\ ;Character mode
ASCII \BINARY\ ;Binary mode
ASCII \DEFAULT\ ;Default mode
ASCII \BYTE-SIZE\ ;Byte size specification
ASCII \RAW\ ? 0 ;Raw mode (the bytes as they come)
ASCII \SUPER-IMAG\ ;Super-image -- don't treat rubouts specially
ASCII \SUPER\ ? 0 ;Documented as SUPER-IMAGE but some people send SUPER
ASCII \PRESERVE-D\ ;Preserve-dates
ASCII \INHIBIT-LI\ ;Inhibit-links (ignored except on ITS)
ASCII \DELETED\ ;Deleted files are ok (ignored on ITS)
IFN TNX,[
ASCII \TEMPORARY\ ;Temporary file
ASCII \FILE-BYTE-\ ;file-byte-size
IFN $$SUBM,[
ASCII \SUBMIT\
];$$SUBM
] ;END IFN TNX
ASCII \ESTIMATED-\ ;estimated-length
ASCII \PROBE-DIRE\ ;probe-directory
ASCII \IF-EXISTS\
ASCII \IF-DOES-NO\ ;if-does-not-exist
OPNLEN==<.-OPNTAB>/2
OPNACT: TRNE IDX,1
TRNN IDX,1
TROA F,F.PRB
TLZA D,ST.BIN
TLOA D,ST.BIN
JRST [ TRO F,F.DEF
TLO D,ST.BIN
JRST OPNOPT]
JRST OPNBYS
TLOA D,ST.RAW
TLOA D,ST.SUI
TLOA D,ST.SUI
TLOA D,ST.PDT
TLOA D,ST.INL
TLOA D,ST.DEL
IFN TNX,[
TLOA D,ST.TEM
JRST OPNFBS
IFN $$SUBM,[
JRST OPNSUB
];$$SUBM
] ;END IFN TNX
JRST OPNELN
TROA F,F.PDR
JRST OPNIFE
JRST OPNIDN
IFN <.-OPNACT>-OPNLEN, .ERR OPNTAB and OPNACT not same length
OPNBYS: TRNE F,F.NWL ;BETTER NOT HAVE A NEWLINE
JRST COMBAD
PUSHJ P,COMDCI ;READ A NUMBER FROM THE STREAM
JUMPL BC,COMBAD ;MUST HAVE STUFF LEFT
SKIPLE A ;BYTE-SIZE MUST BE BETWEEN 0 AND 16.
CAILE A,16.
CERR IBS,[Illegal byte size]
MOVEM A,DATBYT(IDX) ;SAVE THE BYTE SIZE
ifn tnx,[
MOVEM A,DATFBS(IDX) ;Save here too
]
MOVE B,A
MOVEI A,36.
IDIV A,B
MOVEM A,DATBPW(IDX) ;REMEMBER BYTES PER WORD
JRST OPNOPT ;AND CONTINUE
IFN TNX,[
OPNFBS: TRNN IDX,1
JRST COMBAD
TRNE F,F.NWL
JRST COMBAD
PUSHJ P,COMDCI
JUMPL BC,COMBAD
SKIPLE A ;File byte size must be between 1 and 36.
CAILE A,36.
CERR IBS,[Illegal file byte size]
MOVEM A,DATFBS(IDX) ;Save it
JRST OPNOPT ;and continue
];TNX
OPNELN: TRNE F,F.NWL ;BETTER NOT HAVE A NEWLINE
JRST COMBAD
PUSHJ P,COMDCI ;READ A NUMBER FROM THE STREAM
JUMPL BC,COMBAD ;MUST HAVE STUFF LEFT
JRST OPNOPT ;Ignore the estimated length and continue
OPNIFE: TRNE F,F.NWL ;Better not have a newline
JRST COMBAD
PUSHJ P,COMR10 ;Get IF-EXISTS mode into A and B
JUMPL BC,COMBAD
MOVSI T,-IFETBL
OPNIF1: CAMN A,IFETAB(T)
CAME B,IFETAB+1(T)
JRST [ ADDI T,2
AOBJN T,OPNIF1
CERR UUO,[Unknown IF-EXISTS option] ]
IOR F,IFETAB+2(T)
JRST OPNOPT
IFN TNX,[
IFN $$SUBMIT,[
OPNSUB: MOVE A,USRNUM
CAMN A,ANONUM
CERR UUO,[Can't SUBMIT when logged in as Anonymous]
TLO D,ST.SUB
JRST OPNOPT
];$$SUBMIT
];IFN TNX
IFETAB: ASCII /SUPERSEDE/ ? F.SUP
IFN TNX,[ ;not implemented for ITS yet
ASCII /APPEND/ ? F.APP
ASCII /OVERWRITE/ ? F.OVW
ASCII /TRUNCATE/ ? F.TRU
ASCII /RENAME/ ? F.REN
ASCII /RENAME-AND/ ? F.RND ;RENAME-AND-DELETE
ASCII /ERROR/ ? 0 ? F.NEW
];TNX
IFETBL==<.-IFETAB>/3
OPNIDN: TRNE F,F.NWL ;Better not have a newline
JRST COMBAD
PUSHJ P,COMRD5 ;Get IF-DOES-NOT-EXIST mode into A
JUMPL BC,COMBAD
CAMN A,[ASCII/ERROR/]
JRST OPNOPT ;ERROR is the default
IFN TNX,[ ;not implemented for ITS yet
CAME A,[ASCII/CREAT/]
];TNX
JRST [ CERR UUO,[Unknown IF-DOES-NOT-EXIST option] ]
TLO F,(F.CRE)
JRST OPNOPT
OPNPRB: MOVEI IDX,MAXIDX ;SPECIAL PROBE INDEX
TRO F,F.PRB ;DOING A PROBE
TRNN F,F.NWL ;IF NO OPTIONS, THAT'S OK
JRST OPNPR0 ;Now process options
OPNFNM: HLLM D,DATSTA(IDX)
IFN ITS,[
PUSHJ P,COMPFN ;PARSE THE FILENAME
SKIPE T,DATSNM(IDX) ;KEEP STICKY DEFAULT DIRECTORY
.SUSET [.SSNAME,,T]
TRNE IDX,1 ;OUTPUT INDEX?
JRST OPNOUT ;YES, HAS TO HAPPEN SOMEWHAT DIFFERENTLY
MOVEI T,.UAI ;ASSUME TEXT MODE
TLNE D,ST.BIN ;UNLESS REALLY BINARY
MOVEI T,.UII
TLNE D,ST.PDT
TRO T,10
TLNE D,ST.INL
TRO T,20
TRNE F,F.PDR ;PROBE-DIRECTORY MODE
JRST [ MOVE TT,[SIXBIT/.FILE./]
MOVEM TT,DATFN1(IDX)
MOVE TT,[SIXBIT/(DIR)/]
MOVEM TT,DATFN2(IDX)
JRST .+1 ]
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW,,T ;Appropriate mode
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR
.CALL [ SETZ ;GET TRUENAME TO RETURN TO USER
SIXBIT /RFNAME/
%CLIN,,DATCHN(IDX)
%CLOUT,,DATDEV(IDX)
%CLOUT,,DATFN1(IDX)
%CLOUT,,DATFN2(IDX)
%CLOUT+%CLEND,,DATSNM(IDX)]
JFCL ;WELL, IT SHOULDN'T BUT...
TLNN D,ST.BIN ;Don't try to QFASLP for text files
JRST OPNFN0
MOVEI T,1 ;READ THE FIRST WORD OF THE FILE FOR QFASLP
MOVE TT,[444400,,B] ;ONE BYTE INTO B
.CALL [ SETZ
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,TT
%CLIN+%CLEND,,T]
SETZ B, ;HMMM....
CAMN B,[SIXBIT/QFASL/] ;QFASL OR QBIN FILE?
JRST OPNQFA ;YES
TRZ B,77_4 ;ALLOW ANY VERSION BELOW 100
CAMN B,[.BYTE 16. ? 170023 ? 0] ;BIN FILE?
OPNQFA: TROA F,F.QFP ;YES
JRST [TRNN F,F.DEF ;CHARACTERS DEFAULT?
JRST .+1 ;NO
TLZ D,ST.BIN ;YES, NOT BINARY THEN
HLLM D,DATSTA(IDX)
TRNE F,F.PRB
JRST .+1
JRST OPNACF] ;And need to reopen in case it matters
TRNE F,F.PRB ;This a probe?
JRST OPNFN0 ;Yup, don't bother setting the access pointer back
.CALL [ SETZ ;RESET POINTER TO BEGINNING OF FILE
SIXBIT /ACCESS/
%CLIN,,DATCHN(IDX)
%CLIMM+%CLEND,,0]
JRST OPNACF ;ACCESS can fail on things like job devices
JRST OPNFN0
OPNACF: .CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL ;It can't fail...
MOVEI T,.UAI ;ACCESS failed, so do it the slow way (reopen file)
TLNE D,ST.BIN ;UNLESS REALLY BINARY
MOVEI T,.UII
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW,,T ;Appropriate mode
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR
JRST OPNFN0
OPNOUT: MOVEI T,.UAO ;ASSUME TEXT MODE
TLNE D,ST.BIN ;UNLESS REALLY BINARY
MOVEI T,.UIO
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD ;Error code
%CLBTW,,T ;Appropriate mode
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,[SIXBIT \_LSPM_\]
%CLIN,,[SIXBIT \OUTPUT\]
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR
SETZM DATLEN(IDX) ;Due to ITS lossage must keep our own length for output files
] ;END IFN ITS
IFN TNX,[
SETZM DATDSP(IDX) ;No delete or rename when closed (so far)
TRNE F,F.PDR
JRST OPNPDR ;PROBE-DIRECTORY
TRNE IDX,1
TLO D,ST.OUT ;COMGJF wants output file
SETZM NOTNEW
TLNE F,(F.SUP\F.APP\F.OVW\F.NEW\F.TRU\F.REN\F.RND)
AOS NOTNEW ;Don't create a new version
TLNE F,(F.APP\F.OVW\F.TRU)
TLNE F,(F.CRE)
CAIA
SETOM NOTNEW ;Must have an old file to append to or write over
PUSHJ P,COMGJF ;Get JFN in AC1
SKIPA
JRST GTRLFL
TLNN F,(F.NEW)
CAIE 1,GJFX27 ;File already exists (new file required)
PUSHJ P,JSYSER ;Error: return it to the user
;We have an existing file
SETOM NOTNEW
PUSHJ P,COMGJG ;Try opening again, as an old file...
PUSHJ P,JSYSER ; Oh well...
TLNE F,(F.APP\F.OVW\F.TRU)
JRST GTRLFL ;Use the old file
MOVE T,1 ;Supersede the old file
HRLI T,DD.SUP+DD.OPN ;Remember that we need to close it first
TLNE F,(F.REN) ;Set flags for rename/delete of old file
TLO T,DD.REN
TLNE F,(F.RND)
TLO T,DD.RND
MOVEM T,DATDSP(IDX)
TLNN D,ST.BIN
SKIPA 2,[070000,,OF%RD+OF%PLN+OF%RTD] ;Input/ASCII/no line numbers!
MOVE 2,[440000,,OF%RD+OF%RTD] ;Input, 36-bit
OPENF ;Open file, to lock it.
ERCAL [ MOVSI T,DD.OPN
ANDCAM T,DATDSP(IDX)
CAIE 1,OPNX30 ;"CAN'T OPEN WHEN ARCHIVED"
CAIN 1,OPNX31 ;"FILE OFFLINE"
POPJ P, ;Ignore these errors and supersede without locking
JRST JSYSER ] ;Probably invalid simultaneous access
HRROI 1,TMPFIL ;Then make a temporary file in the same
HRRZ 2,DATDSP(IDX) ;directory you want the final one...
MOVE 3,[110000,,JS%PAF]
JFNS ;dev:<dir>
HRROI 2,[ASCIZ /-TEMPORARY-FILE-./]
SETZ 3,
SOUT
PUSH P,1
GTAD
MOVE 2,1
POP P,1
MOVEI 3,8.
NOUT
JFCL
HRROI 2,[ASCIZ /.-1/]
SETZ 3,
SOUT
SETZM NOTNEW
HRROI 2,TMPFIL ;and we will write to that one instead.
PUSHJ P,COMGJG
PUSHJ P,JSYSER
GTRLFL: HRRZM 1,DATJFN(IDX) ;JFN for this index
TRNN IDX,1
JRST [TLNN D,ST.BIN
SKIPA 2,[070000,,OF%RD+OF%PLN];Input/ASCII, no line numbers!
MOVE 2,[440000,,OF%RD] ;Input, 36-bit
JRST .+4]
TLNN D,ST.BIN
SKIPA 2,[070000,,OF%WR] ;Output, ASCII
MOVE 2,[440000,,OF%WR] ;Output, 36-bit
TLNE F,(F.APP)
TRC 2,OF%WR+OF%APP ;Open for append instead
TLNE F,(F.OVW)
TRO 2,OF%RD ;Open for both read and write => don't truncate
TLNE D,ST.PDT
TRO 2,OF%PDT
IFN 20X,PUSHJ P,TRYCON
OPENF ;Open the file
ERCAL OPNJER ;Here if some error
SETZM DATLEN(IDX) ;Will keep track of file lengths ourself
TRNN IDX,1 ;Output file, don't do QFASL-P check
TLNN D,ST.BIN ;Don't try to QFASLP for text files
JRST OPNFN0
MOVE 1,DATJFN(IDX)
BIN ;Read byte for QFASL-P
ERJMP OPNNBN ;EOF, not binary
CAMN 2,[SIXBIT/QFASL/] ;QFASL OR QBIN FILE?
JRST OPNQFA ;YES
TRZ 2,77_4 ;ALLOW ANY VERSION BELOW 100
CAMN 2,[.BYTE 16. ? 170023 ? 0] ;BIN FILE?
OPNQFA: TROA F,F.QFP ;YES
JRST OPNNBN ;NO
OPNNB0: TRNE F,F.PRB ;If a probe, no need to set file pointer back
JRST OPNFN0
SETZ 2, ;Set pointer back to beginning of file
SFPTR
JRST OPNACF ;For files that can't be set back, just reopen
JRST OPNFN0
;Analyze OPENF failure
OPNJER:
IFN 20X,[
TRNE F,F.PRB ;If probe, don't care if file is unavailable
JRST OPNJE1 ;SO SKIP THIS STUFF
CAIE 1,OPNX31 ;IS THE FILE OFFLINE?
JRST JSYSER ;NO, SIGNAL THE ERROR
SKIPN RETENA ;ARE AUTOMATIC RETRIEVALS ENABLED?
JRST JSYSER ;NO, SIGNAL THE ERROR
TLNE D,ST.RET ;HAVE WE ALREADY TRIED RETRIEVING THIS FILE?
JRST JSYSER ;YES, SIGNAL THE ERROR
MOVE 1,DATJFN(IDX) ;JFN OF FILE TO BE RETRIEVED
HRRZI 2,.ARRFR ;ARCF RETRIEVAL FUNCTION CODE
MOVE 3,[AR%WAT] ;WE WANNA WAIT FOR THE RETRIEVAL
ARCF% ;RETRIEVE THE FILE
ERJMP .+1 ;IGNORE ANY ERRORS
TLO D,ST.RET ;INDICATE THAT WE HAVE TRIED RETRIEVING FILE
MOVE 1,DATJFN(IDX) ;JFN OF FILE
JRST GTRLFL ;AND RETRY OPENING THE FILE
OPNJE1:
];20X
MOVSI 2,-LERRTB
HLRZ 3,ERRTAB(2)
CAIE 3,(1)
AOBJN 2,.-2
JUMPGE 2,JSYSER
HRRZ 3,ERRTAB(2)
CAIE 3,'NAV
JRST JSYSER
POP P,3 ;Flush return PC
;Fall into OPNNBN
OPNNBN: TRNN F,F.DEF ;CHARACTERS DEFAULT?
JRST OPNNB0 ;NO
TLZ D,ST.BIN ;YES, NOT BINARY THEN
HLLM D,DATSTA(IDX)
TRNE F,F.PRB
JRST OPNNB0
JRST OPNACF ;And need to reopen in case it matters
OPNACF: MOVE 1,DATJFN(IDX)
HRLI 1,(CO%NRJ) ;Don't release the JFN
CLOSF
ERCAL SYSBUG
HRRZS 1
TLNN D,ST.BIN
SKIPA 2,[070000,,OF%RD+OF%PLN] ;Input, ASCII, no line numbers!
MOVE 2,[447400,,OF%RD] ;Input, dump mode
TLNE D,ST.PDT
TRO 2,OF%PDT
OPENF ;Re-open file
ERCAL JSYSER ;Shouldn't happen, but...
];END IFN TOP20
OPNFN0: MOVEI A,[ASCIZ \OPEN \]
PUSHJ P,COMCTL
SKIPE PTCVER
JRST OPNFN3
TRNE F,F.PDR
JRST [ MOVEI BYTE,"1
PUSHJ P,COMCHO
JRST .+2 ]
PUSHJ P,COMVRS
MOVEI BYTE,40
PUSHJ P,COMCHO
OPNFN3:
IFN ITS,[
.CALL [ SETZ
SIXBIT /RFDATE/
%CLIN,,DATCHN(IDX)
%CLOUT+%CLEND,,A]
SETZ A, ;ASSUME 0 IF CALL FAILS
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVEI 2,A ;Return values starting in A
MOVEI 3,1 ;Want one values (last write date)
SETZ A,
RFTAD
ERCAL ERRPDR
] ;END IFN TNX
PUSHJ P,COMDTO ;OUTPUT DATE/TIME FROM A
MOVEI BYTE,40
PUSHJ P,COMCHO
IFN ITS,[
TRNN IDX,1 ;RETURN 0 LENGTH FOR OUTPUT FILES
.CALL [ SETZ
SIXBIT /FILLEN/
%CLIN,,DATCHN(IDX)
%CLOUT+%CLEND,,A] ;SIZE IN 36 BIT BYTES
SETZ A, ;HMM...
] ;END IFN ITS
IFN TNX,[
SETZ A,
TRNE IDX,1
skipge notnew ;GLR output file
caia ; that already exists -- calculate length
JRST OPNFN1 ;Output file, return 0 length
MOVE 1,DATJFN(IDX)
MOVE 2,[2,,.FBBYV] ;Read two words: byte size info, and number of bytes
MOVEI 3,T ;Return info in T and TT
SETZB T,TT
GTFDB
ERCAL ERRPDR
MOVE A,TT
LDB TT,[300600,,T] ;Get byte size
HRLZI T,ST.BIN
TDNN T,DATSTA(IDX) ;If binary mode, do calculation
JRST [CAIN TT,7 ;ASCII mode, was original byte size 7 bits?
JRST OPNFN1 ;Yes, then A contains exact number of bytes
IMULI A,5 ;Else fudge multiplying by number of bytes per word
JRST .+1] ;And do harder calculation
MOVEI T,36.
IDIVI T,(TT) ;And calculate number of bytes per word
ADDI A,-1(T) ;Roundoff correctly
IDIVI A,(T) ;A gets number of words in the file
] ;END IFN TNX
HRLZI T,ST.BIN ;BINARY MODE MULTIPLIES BY APPROPRIATE AMOUNT
TDNN T,DATSTA(IDX)
JRST OPNFN1 ;A HAS ACTUAL LENGTH
IMUL A,DATBPW(IDX)
OPNFN1: MOVEM A,DATLEN(IDX)
PUSHJ P,COMDCO ;OUTPUT IN DECIMAL
MOVEI A,[ASCIZ \ NIL\] ;ASSUME NOT QFASL
TRZE F,F.QFP
MOVEI A,[ASCIZ \ T\]
PUSHJ P,COMSTO ;STRING-OUT THE APPROPRIATE RESPONSE
MOVEI A,[ASCIZ \ NIL\] ;ASSUME NOT CHARACTERS
HRLZI T,ST.BIN
TDNN T,DATSTA(IDX)
MOVEI A,[ASCIZ \ T\]
PUSHJ P,COMSTO
OPNFN2: MOVEI A,[ASCIZ / "/] ;SEND AUTHOR
PUSHJ P,COMSTO
IFN TNX,[
MOVE 1,DATJFN(IDX)
HRLI 1,.GFLWR
HRROI 2,WRITER
GFUST
ERJMP OPNFN4
MOVE A,[440700,,WRITER]
];20X
IFN ITS,[SYSCAL RAUTH,[DATCHN(IDX)
%CLOUT,,WRITER]
JRST OPNFN4
MOVE A,[440600,,WRITER]
];ITS
OPNF2L: ILDB BYTE,A
JUMPE BYTE,OPNFN4
IFN ITS,ADDI BYTE,40 ;Factor for 6bit -> 7bit
CAIE BYTE,""
CAIN BYTE,"/
JRST [PUSH P,BYTE
MOVEI BYTE,"/
PUSHJ P,COMCHO
POP P,BYTE
JRST .+1]
PUSHJ P,COMCHO
JRST OPNF2L
OPNFN4: MOVEI BYTE,""
PUSHJ P,COMCHO
MOVEI BYTE,215 ;A NEWLINE
PUSHJ P,COMCHO
PUSHJ P,COMRFO ;OUTPUT THE REAL FILENAMES
MOVEI BYTE,215
PUSHJ P,COMCHO
TRZN F,F.PRB
JRST OPNFPS ;IF NOT A PROBE, THEN WE ARE DONE
PUSHJ P,COMSND ;PROBE: REPLY QUICKLY
IFN ITS,[
.CALL [ SETZ ;A PROBE, SO CLOSE THE CHANNEL, AS WE ARE DONE WITH IT
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL ;HMM...OH WELL
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX) ;A probe, so close channel
CLOSF
JRST [ MOVE 1,DATJFN(IDX) ;Might not be open
RLJFN
JFCL
JRST .+1 ]
SETZM DATJFN(IDX)
] ;END IFN TNX
SETZM DATSTA(IDX) ;MAKE SURE WORLD KNOWS CHANNEL IS CLOSED
JRST CTLLOP
OPNFPS: PUSHJ P,BUFALO ;ALLOCATE A BUFFER
MOVEI T,ST%OPN ;STATE IS NOW OPEN
HRRM T,DATSTA(IDX)
HRLZI T,ST.ACT ;CHANNEL IS NOW ACTIVE
IORM T,DATSTA(IDX)
PUSHJ P,COMSND
IFN ITS,[
MOVE T,CHABIT(IDX)
.SUSET [.SIMSK2,,T] ;ENABLE INTERRUPTS ON THE CHAOS CHANNEL
ANDCAM T,SSYDF2 ;Update saved copy of DS2
.SUSET [.SADF2,,T]
.SUSET [.SIIFPIR,,T] ;Start the ball rolling with an interrupt
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
AIC ;Enable interrupts on this channel
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
IIC ;Force interrupt on channel to start ball rolling
] ;END IFN TNX
JRST CTLLOP ;WAIT FOR MORE WORK
IFN ITS,[
;Send version number over
COMVRS: MOVE TT,DATFN2(IDX) ;RETURN FN2 AS VERSION
;SEND THE VERSION NUMBER IN DECIMAL OR -1 IF NOT A NUMBER
;IF PARTIAL NUMBER SEND THAT
MOVEI A,0 ;SET IF ANY DIGITS OUTPUT
COMVR0: MOVEI T,0
LSHC T,6
MOVEI BYTE,40(T)
CAIL BYTE,"0
CAILE BYTE,"9
JRST COMVR1
PUSHJ P,COMCHO
MOVEI A,1
JUMPN TT,COMVR0
COMVR1: JUMPN A,CPOPJ
MOVEI BYTE,"-
PUSHJ P,COMCHO
MOVEI BYTE,"1
PUSHJ P,COMCHO
POPJ P,
;Output filespec to the control stream from DATxxx
COMRFO: MOVE A,DATDEV(IDX) ;DEVICE NAME
CAMN A,[SIXBIT /DSK/] ;If DSK, then send machine name
MOVE A,MACNAM
PUSHJ P,COMSXO
MOVEI A,[ASCIZ \: \] ;COLON TERMINATES DEVICE
PUSHJ P,COMSTO
COMRF2: SKIPN A,DATSNM(IDX) ;THEN SNAME
JRST .+4
PUSHJ P,COMSXO
MOVEI A,[ASCIZ \; \] ;SEMICOLON TERMINATES SNAME
PUSHJ P,COMSTO
TRNE F,F.PDR
POPJ P,
SKIPN A,DATFN1(IDX) ;FIRST FILENAME
JRST [ SKIPN A,DATFN2(IDX)
POPJ P,
MOVEI BYTE,"
PUSHJ P,COMCHO
JRST COMSXO ]
PUSHJ P,COMSXO
SKIPN A,DATFN2(IDX) ;FINALLY, SECOND FILENAME
POPJ P,
MOVEI BYTE,40 ;SPACE ENDS FN1
PUSHJ P,COMCHO
JRST COMSXO ;TAIL RECURSIVE CALL TO SIXBIT OUTPUT
;Version of COMRFO which omits the default device entirely rather than plugging in the host
COMRF1: MOVE A,DATDEV(IDX) ;DEVICE NAME
CAMN A,[SIXBIT /DSK/] ;If DSK, then send nothing
JRST COMRF2
JRST COMRFO
] ;END IFN ITS
IFN TNX,[
COMRFO: SKIPA 3,[111110,,JS%PAF] ;Device, directory, filename, file type, version
COMVRS: MOVE 3,[000010,,0] ;Only return generation
TRNE F,F.PDR
TLZ 3,001110 ;Probe-directory gives only device and directory
HRROI 1,RESBLK ;Output to canonical place
MOVE 2,DATJFN(IDX)
JFNS
ERCAL SYSBUG
JRST COMRES ;Output result block to control packet
;;; 10X/20X PROBE-DIRECTORY
OPNPDR: TRNN F,F.PRB
JRST COMBAD
PUSHJ P,PRSDIR ;Return JFN in 1, directory number in 3
PUSHJ P,OPNPD1 ;Error
HRRZM 1,DATJFN(IDX) ;Really got some JFN, hang onto it
SETZM DATLEN(IDX)
JRST OPNFN0
OPNPD1: CAIE 1,GJFX32 ;Directory empty (no files match specification)
CAIN 1,GJFX19 ;No such file type
JRST POPJ1
CAIE 1,GJFX24 ;Both Tenex and TOPS-20 can give GJFX24 randomly
CAIN 1,GJFX20 ;I think only Tenex gives GJFX20
JRST POPJ1
JRST JSYSER ;Some other error - Complain.
ERRPDR: TRNN F,F.PDR
JRST SYSBUG
POPJ P,
] ;END IFN TNX
;PUSHJ P, for errors that are bugs in the system or in this program
SYSBUG: SETOM SYSBGF ;Set flag and drop into normal routine
;Handle failing .CALLs or JSYSes
FILERR: PUSHJ P,OPNERP ;Setup error packet
PUSHJ P,COMSND ;Send the packet
JRST CTLLOP ;Then wait for more work
IFN TNX,JSYSER=FILERR
OPNERP: MOVEI A,[ASCIZ \ERROR \]
PUSHJ P,COMCTL ;Start off error packet, open failed error code
IFN TNX,[
MOVEI 1,.FHSLF
PUSHJ P,$GETER ;Get last error that happened
PUSHJ P,CTLERR
HRRZM 2,ERRCOD ;The number of the error
];TNX
MOVE D,ERRCOD ;Send 3 letter code for this error
PUSHJ P,ERR3
PUSH P,A ;Save 3-letter code
MOVSS A
PUSHJ P,COMSXO ;Output the 3-letter code
MOVEI A,[ASCIZ \ F \] ;Fatal error
PUSHJ P,COMSTO
PUSHJ P,ERRMSG ;Send the error message
POP P,A ;Restore 3-letter code
CAIE A,'BUG ;If it's a bug, include octal PC
BUGPAT: JRST [ SKIPN DEBUG ;Always include PC if in debugging mode
POPJ P, ;or if BUGPAT is patched to JFCL
JRST .+1 ]
MOVEI A,[ASCIZ \ (at \]
PUSHJ P,COMSTO
HRRZ A,-1(P) ;Caller of FILERR
SUBI A,2 ;Address of errored JSYS or other call
PUSHJ P,COMOCO
MOVEI A,[ASCIZ/ inside FILE server)/]
PUSHJ P,COMSTO
POPJ P,
;Move 3-letter code for error in D to A
ERR3: MOVEI A,'BUG ;Any errors not in our table must be file server bugs
AOSN SYSBGF
POPJ P,
MOVSI TT,-LERRTB ;Search table for appropriate 3 letter code
ERR3A: HLRZ T,ERRTAB(TT)
CAME T,D
AOBJN TT,ERR3A
HRRZ A,ERRTAB(TT)
POPJ P,
;Transmit error message to command packet, D has error code.
IFN ITS,[
ERRMSG: .SUSET [.SPICLR,,[0]] ;ERR device can be used at interrupt level
.CALL [ SETZ ;Now open ERR device to get error message
SIXBIT /OPEN/
%CLBIT,,.UAI
%CLIMM,,ERRCH
%CLIN,,[SIXBIT /ERR/]
%CLIMM,,4
%CLIN+%CLEND,,D]
.LOSE %LSSYS
ERRMS1: .IOT ERRCH,BYTE
JUMPLE BYTE,ERRMS2 ;EOF
CAIN BYTE,15 ;CR turns into Return
MOVEI BYTE,215
CAIL BYTE,40 ;Other control characters are ignored
PUSHJ P,COMCHO
JRST ERRMS1
ERRMS2: .CLOSE ERRCH,
.SUSET [.SPICLR,,[-1]] ;Done with use of any shared resources
POPJ P,
];ITS
IFN TNX,[
ERRMSG: MOVEI 1,.FHSLF ;ERRBUF can be used at interrupt level
DIR
MOVE 2,D
HRLI 2,.FHSLF
HRROI 1,ERRBUF ;Output to canonical place, error in AC2
SETZM ERRBUF
MOVEI 3,ERRLEN-1 ;Maximum number of bytes we can handle
ERSTR
JFCL ;Undefined error number??
JFCL ;Won't fit -- too bad
SKIPE ERRBUF
JRST ERRMS1
HRROI 1,ERRBUF
HRROI 2,[ASCIZ/Undefined system error code /]
MOVEI 3,0
SOUT
HRRZ 2,D
MOVEI 3,8
NOUT
JFCL
ERRMS1:
IFN 10X,[
SETZ 3,
IDPB 3,1 ;Put in null
];IFN 10X
MOVEI A,ERRBUF
PUSHJ P,COMSTO ;Output the error string
MOVEI 1,.FHSLF ;Okay turn interrupts back on
EIR
POPJ P,
];END IFN TNX
;;; Close a data channel
COMCLO: TRNN F,F.FHN ;HAVE A FILE HANDLE?
JRST COMBAD ;NOPE, ERROR
JUMPGE BC,COMBAD ;NO OPTIONS TO THE CLOSE COMMAND
SKIPL T,DATSTA(IDX) ;CHANNEL ACTIVE?
CERR BUG,[Channel not open]
TLNE T,ST.DIR ;Was it a directory listing?
JRST COMCLD
MOVEI A,[ASCIZ \CLOSE \];SUCCESSFUL RESPONSE
PUSHJ P,COMCTL ;SETUP CONTROL PACKET
IFN ITS,[
.CALL [ SETZ
SIXBIT /RFDATE/
%CLIN,,DATCHN(IDX)
%CLOUT+%CLEND,,CLODAT]
SETZM CLODAT ;ASSUME 0 IF CALL FAILS
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVEI 2,A ;Return values starting in A
MOVEI 3,1 ;Want one value (last write date)
RFTAD
ERCAL SYSBUG
MOVEM A,CLODAT
] ;END IFN TNX
TRNE IDX,1 ;Input file?
JRST CLOLE0 ;Nope, output, use calculated length
IFN ITS,[
.CALL [ SETZ
SIXBIT /FILLEN/
%CLIN,,DATCHN(IDX)
%CLOUT+%CLEND,,A] ;SIZE IN 36 BIT BYTES
SETZ A, ;HMM...
] ;END IFN ITS
IFN TNX,[
SETZ A,
MOVE 1,DATJFN(IDX)
MOVE 2,[2,,.FBBYV] ;Read two words: byte size info, and number of bytes
MOVEI 3,T ;Return info in T and TT
GTFDB
ERCAL SYSBUG
MOVE A,TT
LDB TT,[300600,,T] ;Get byte size
HRLZI T,ST.BIN
TDNN T,DATSTA(IDX) ;If binary mode, do calculation
JRST [CAIN TT,7 ;ASCII mode, was original byte size 7 bits?
JRST CLOLE1 ;Yes, then A contains exact number of bytes
JRST .+1] ;And do harder calculation
MOVEI T,36.
IDIVI T,(TT) ;And calculate number of bytes per word
ADDI A,-1(T)
IDIVI A,(T) ;A gets number of words in the file
] ;END IFN TNX
HRLZI T,ST.BIN ;BINARY MODE MULTIPLIES BY 2, TEXT MODE BY 5
TDNN T,DATSTA(IDX)
SKIPA T,[5] ;TEXT: 5
MOVEI T,2 ;BINARY: 2
IMULI A,(T)
JRST CLOLE1
CLOLE0: MOVE A,DATLEN(IDX) ;Actual number of bytes in file
HRLZI T,ST.BIN
TDNN T,DATSTA(IDX) ;If not binary mode then this is the number we want
JRST CLOLE1
MOVE T,DATBPW(IDX)
ADDI A,-1(T) ;In order to round up
IDIVI A,(T) ;Calculate number of words in file
IMULI A,(T) ;Then calculate number of bytes rounded up
; JRST CLOLE1
CLOLE1: MOVEM A,CLOLEN
IFN ITS, PUSHJ P,CLOSIT ;Close the channel
IFN TNX, PUSHJ P,CLONRJ ;Close, but don't release JFN
SKIPE PTCVER
JRST CLOLE2
PUSHJ P,COMVRS
MOVEI BYTE,40
PUSHJ P,COMCHO
CLOLE2: MOVE A,CLODAT
PUSHJ P,COMDTO ;OUTPUT DATE/TIME FROM A
MOVEI BYTE,40
PUSHJ P,COMCHO
MOVE A,CLOLEN ;FILE LENGTH
PUSHJ P,COMDCO ;OUTPUT IN DECIMAL
MOVEI BYTE,40
PUSHJ P,COMCHO
MOVE A,DATRCV(IDX)
PUSHJ P,COMDCO
;; Don't send QFASL info
MOVEI BYTE,215 ;A NEWLINE
PUSHJ P,COMCHO
PUSHJ P,COMRFO ;OUTPUT THE REAL FILENAMES
MOVEI BYTE,215
PUSHJ P,COMCHO
CLOLED: MOVEI A,CPOPJ ;Routine to call in case mark already received
PUSHJ P,COMSSY ;Send/receive synchronous mark
PUSHJ P,COMSND ;Send control response
HRLZI T,ST.SYN ;Wait for mark to go out, or mark to come in
IFN ITS,[ ; (for output, mark supposed to be here already!)
TDNE T,DATSTA(IDX)
.HANG
] ;END IFN ITS
IFN TNX,[
PUSHJ P,RELDJF
;; Nothing winning like .HANG, so use small sleeps
PUSHJ P,$HANG
TDNE T,DATSTA(IDX)
] ;END IFN TNX
SETZM DATSTA(IDX) ;Done with channel now, deactivate it
JRST CTLLOP
IFN TNX,[
$HANG: TIME ;Don't wait forever
IMULI 2,30. ;Just 30 seconds
ADD 1,2
MOVE TT,1
$HANG1: XCT @(P)
CAIA
JRST POPJ1
MOVEI 1,1
DISMS
TIME
CAMG 1,TT
JRST $HANG1
MOVE 1,[441000,,CTLPKO+%CPKDT]
HRROI 2,[ASCIZ/Timed out waiting for synchronous mark on close/]
SETZ 3,
Sout
IDPB 3,1
JRST CTLER1
];TNX
IFN TNX, CLONRJ: TROA F,F.NRJ
CLOSIT:
IFN TNX, TRZ F,F.NRJ
MOVE T,DATSTA(IDX)
TLNE T,ST.DIR ;Directory command?
JRST CLODIR ;Yes, finish up specially
TRNN IDX,1 ;Output file?
JRST CLOSE0 ;Nope, proceed
HRRZ T,DATSTA(IDX)
CAIN T,ST%OPN ;Write out in-core buffer if channel state is OPEN
PUSHJ P,WRIFOR
IFN ITS,[
SKIPN DATFN1(IDX) ;Has file been DELEWO'ed?
JRST CLOSE1 ;Yes, don't RENMWO or set author
.CALL [ SETZ
SIXBIT /RENMWO/
%CLIN,,DATCHN(IDX)
%CLIN,,DATFN1(IDX)
%CLIN+%CLEND,,DATFN2(IDX)]
CERR CRF,[Cannot rename output file to real names]
.CALL [ SETZ
SIXBIT /SAUTH/
%CLIN,,DATCHN(IDX)
%CLIN+%CLEND,,HSNAME]
JFCL ;Unusual, but not fatal
CLOSE1: .CALL [ SETZ ;GET TRUENAME TO RETURN TO USER
SIXBIT /RFNAME/
%CLIN,,DATCHN(IDX)
%CLOUT,,DATDEV(IDX)
%CLOUT,,DATFN1(IDX)
%CLOUT,,DATFN2(IDX)
%CLOUT+%CLEND,,DATSNM(IDX)]
JFCL ;WELL, IT SHOULDN'T BUT...
] ;END IFN ITS
IFN TNX,[
CLOSE0: MOVE 1,DATJFN(IDX)
HRLI 1,(CO%NRJ) ;Close file, but keep around JFN
MOVSI TT,DD.ABT
TDNE TT,DATDSP(IDX)
TLO 1,(CZ%ABT) ;If going to delete, close in abort mode
CLOSF
ERCAL SYSBUG ;Ain't much else we can do...
TDNE TT,DATDSP(IDX) ;Delete?
JRST [MOVE 1,DATJFN(IDX) ; Yes
HRLI 1,(DF%NRJ)
DELF
ERCAL JSYSER
PUSHJ P,RELRJF ;Not going to rename to real name
JRST CLOSE2]
MOVE 1,DATDSP(IDX)
TLNE 1,DD.OPN ;Before we can RNAMF this temporary
JRST [ HRLI 1,(CO%NRJ) ;file, it must be closed.
CLOSF
ERCAL SYSBUG
JRST .+1 ]
MOVE TT,DATSTA(IDX)
HRRZ 1,DATFBS(IDX)
CAIN 1,36. ;Wants fullword?
JRST CLSIT0 ;Yes, no conversison necessary
TLNE TT,ST.BIN ;Is this a binary...
TRNN IDX,1 ; ... WRITE operation?
JRST CLSIT0 ;No, so don't hack the file size
MOVE T,DATLEN(IDX) ;Number of transmission bytes in file
MOVE 3,DATBPW(IDX) ;(do it this way in case lhs is used)
IDIVI T,(3) ;T=number of words
MOVE 3,DATBYT(IDX)
IMULI TT,(3) ;TT=number of bits left over
MOVEI 2,36. ;Convert it all to the file byte size
IDIVI 2,(1)
IMULI T,(2)
MOVE 2,TT
ADDI 2,-1(1)
IDIVI 2,(1)
ADD T,2
HRRZ 1,DATJFN(IDX) ;Set the byte count
HRLI 1,.FBSIZ\(CF%NUD) ;(minimize the non-atomicity...)
SETO 2,
MOVE 3,T
CHFDB
ERCAL SYSBUG
HRLI 1,.FBBYV ;And now the byte size
MOVSI 2,(FB%BSZ)
SETZ 3,
MOVE T,DATFBS(IDX)
DPB T,[.BP FB%BSZ,3]
CHFDB
ERCAL SYSBUG
CLSIT0:
MOVE TT,DATDSP(IDX)
TLNN TT,DD.REN\DD.RND ;Get rid of existing file?
JRST CLOSE1
HRROI 1,RESBLK ;Get a name to rename it to
HRRZ 2,TT
MOVE 3,[111000,,JS%PAF]
JFNS ;dev:<dir>name
ERCAL SYSBUG
HRROI 2,[ASCIZ /.REPLACED-FILE/]
SETZ 3,
SOUT
MOVE 1,[GJ%FOU+GJ%NEW+GJ%SHT+.GJDEF] ;Setup flags to GTJFN
HRROI 2,RESBLK
GTJFN
ERCAL SYSBUG
PUSH P,1
HRROI 1,RESBLK ;Make a copy of the JFN so we can rename it
HRRZ 2,TT
MOVE 3,[111110,,JS%PAF] ;Device, directory, filename, file type, version
JFNS
ERCAL SYSBUG
MOVE 1,[GJ%OLD+GJ%SHT+.GJDEF] ;Setup flags to GTJFN
HRROI 2,RESBLK
GTJFN
ERCAL SYSBUG
POP P,2
RNAMF
ERCAL SYSBUG
MOVE 1,2
HRLI 1,(DF%NRJ)
TLNE TT,DD.RND
DELF
ERCAL SYSBUG
HRRZS 1
RLJFN
JFCL
CLOSE1: MOVSI TT,DD.SUP
TDNN TT,DATDSP(IDX) ;Rename over existing file?
JRST CLOSE2 ; No.
MOVE 1,DATJFN(IDX) ;Old name...
HRRZ 2,DATDSP(IDX) ;...New name
RNAMF
ERCAL JSYSER
HRRZ 1,DATDSP(IDX)
MOVEM 1,DATJFN(IDX)
CLOSE2: SETZM DATDSP(IDX) ;Mark JFN in RH as released.
TRNN F,F.NRJ
PUSHJ P,RELDJF
] ;END IFN TNX
IFN ITS, CLOSE0:
CLODON: MOVE T,DATSTA(IDX) ;Get channel status
IFN TNX,[
IFN $$SUBM,[
TLNN T,ST.SUB
JRST SUBM2
SKIPE A,QSRPID
JRST SUBM1
SUBM0: MOVEI 1,3 ;Get QUASAR's PID.
MOVEI 2,QUTILB
MUTIL
JRST [MOVEI A,^D3000 ;Sleep for three seconds
DISMS
JRST SUBM0]
MOVE TT,QSRPID
MOVEM TT,MSENDB+2 ;Save QUASAR's pid in MSEND block.
SUBM1: MOVE TT,[QPBLK,,QSRLOC] ;Blit in the args
BLT TT,QSRLOC+19
HRROI 1,QSRLOC+8.
MOVE 2,DATJFN(IDX)
MOVE 3,[111110,,JS%PAF]
JFNS
HRRZ 1,1 ;A has last word written.
SUBI 1,QSRLOC+6 ;Number of words plus 1.
HRLM 1,QSRLOC+7 ;Length of block#2
ADDI 1,7
HRLM 1,QSRLOC ;Total length of block.
SKIPN YERPID
SKIPA 1,[IP%CFV\IP%CPD] ;Page-long and make us a PID.
MOVEI 1,IP%CFV ;Just page-long send
MOVEM 1,MSENDB+.IPCFL
MOVEI 1,4
MOVEI 2,MSENDB
MSEND
CERR BUG,[Can't submit file]
SUBM2:
];$$SUBM
];TNX
MOVEI TT,(T)
CAIN TT,ST%OPN ;Was the channel open?
HRRI T,ST%CLO ;Yes, then close it
MOVEM T,DATSTA(IDX)
PUSHJ P,BUFDAL ;DEALLOCATE THE CORE BUFFER
IFN ITS,[
.CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL ;HMMMM...."I GUESS WE'LL SURVIVE"
] ;END IFN ITS
POPJ P,
IFN TNX,[
RELDJF: SKIPN 1,DATJFN(IDX) ;Release data-file JFN, and mark as such.
POPJ P,
HRLI 1,(CZ%ABT) ;Try closing since RLJFN fails if it's open
CLOSF
JFCL
RELDJ1: MOVE 1,DATJFN(IDX) ;Here when not open, to not clobber error code
RLJFN
JFCL
SETZM DATJFN(IDX)
POPJ P,
RELRJF: HRRZ 1,DATDSP(IDX)
JUMPE 1,CPOPJ
HRLI 1,(CZ%ABT)
CLOSF
JFCL
RELRJ1: HRRZ 1,DATDSP(IDX) ;Here when not open, to not clobber error code
JUMPE 1,CPOPJ
RLJFN
JFCL
SETZM DATDSP(IDX)
POPJ P,
];TNX
;;; FILEPOS: for input files only
COMFIL: TRNN F,F.NWL ;Can't have a newline
TRNN F,F.FHN ;And must have a file handle
JRST COMBAD
SKIPGE DATSTA(IDX) ;IDX must be active
caia ;GLR And ok if it is write
CERR BUG,[Illegal file handle for FILEPOS]
trne idx,1 ;GLR if output,
pushj p,wrifor ;GLR send out the leftover characters in buffer
JUMPL BC,COMBAD ;Also need an argument
PUSHJ P,COMDCI ;Read the arg in decimal
JUMPGE BC,COMBAD ;Better be the end
HRLZI T,ST.BIN ;Is this a binary channel?
TDNN T,DATSTA(IDX)
JRST FILNBN ;Nope, filepos is in A
IDIV A,DATBPW(IDX) ;A is number of words in, B is number of bytes after that
DPB B,[360600,,A] ;Need to save this for interrupt routine
FILNBN: MOVEM A,DATSYN(IDX) ;Location reserved for synchronous routines
MOVEI A,FILSYN ;Routine to call
PUSHJ P,COMSSY ;Setup for the sync mark
MOVEI A,[ASCIZ \FILEPOS\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
HRLZI T,ST.SYN ;Wait for mark to go out
IFN ITS,[
TDNE T,DATSTA(IDX)
.HANG
] ;END IFN ITS
IFN TNX,[
;; Nothing winning like .HANG, so use small sleeps
PUSHJ P,$HANG
TDNE T,DATSTA(IDX)
] ;END IFN TNX
JRST CTLLOP ;Ok, all done, go back for more
;;; Here after sync mark gets sent. Called from interrupt and main program level
FILSYN: MOVE T,DATSYN(IDX) ;Get word (byte in text mode) address to ACCESS to
TLZ T,770000 ;Clear sub-word
IFN ITS,[
.CALL [ SETZ
SIXBIT /ACCESS/
%CLIN,,DATCHN(IDX)
%CLIN+%CLEND,,T]
AERR CPOPJ,WKF,[Cannot set pointer]
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,T ;Where pointer is to get set to
SFPTR
AERR CPOPJ,FOR,[Cannot set pointer] ;COULD BE WKF ALSO---
] ;END IFN TNX
SETZM DATBPT(IDX) ;No state is left
SETZM DATBCT(IDX)
SETZM DATLWD(IDX)
HRRI A,ST%OPN ;Channel is now in open state
TRNE IDX,1 ;Output channel?
POPJ P, ;Yes, then we are done
LDB T,[360600,,DATSYN(IDX)] ;Get number of bytes into first word
JUMPE T,CPOPJ ;If none, then just return.
PUSHJ P,REABUF ;Else read in the next bufferful
SKIPG T,DATBCT(IDX) ;Any bytes to hack?
POPJ P, ;Nope, just return, EOF will be sent next interrupt
LDB TT,[360600,,DATSYN(IDX)]
SUBI T,(TT) ;Calculate number of bytes that will remain in buffer
JUMPLE T,FILSY0 ;If it's gonna be 0 or negative, then EOF
MOVEM T,DATBCT(IDX) ;Else this is the new count
IBP DATBPT(IDX) ;Step the pointer to the appropriate spot
SOJG TT,.-1
POPJ P,
FILSY0: SETZM DATBPT(IDX)
SETZM DATBCT(IDX)
SETZM DATLWD(IDX)
POPJ P,
;;; SET-BYTE-SIZE <new-byte-size> <new-filepos-in-terms-of-old-byte-size-for-input-files>
COMSBS: JUMPL BC,COMBAD ;End of packet, losing format
TRZE F,F.NWL ;Can't have new line either
JRST COMBAD
SKIPGE T,DATSTA(IDX) ;This channel active?
TLNN T,ST.BIN ;And a binary channel?
CERR WKF,[SET-BYTE-SIZE only allowed for binary file]
PUSHJ P,COMDCI ;Read new byte size in decimal
JUMPL BC,COMBAD
TRZE F,F.NWL
JRST COMBAD
HRLM A,DATBYT(IDX) ;Remember new byte size
TRNE IDX,1 ;Need to set a filepos?
JRST SBSNFP ;Nope, ignore rest of packet
PUSHJ P,COMDCI ;Else read the filepos
IDIV A,DATBPW(IDX) ;A is number of words in, B is number of bytes after that
; of current position in file
DPB B,[360600,,A] ;Need to save this for interrupt routine
MOVEM A,DATSYN(IDX)
SBSNFP: MOVEI A,SBSSYN ;Routine to call
PUSHJ P,COMSSY ;Setup for the sync mark
MOVEI A,[ASCIZ \SET-BYTE-SIZE\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
HRLZI T,ST.SYN ;Wait for mark to go out
IFN ITS,[
TDNE T,DATSTA(IDX)
.HANG
] ;END IFN ITS
IFN TNX,[
;; Nothing winning like .HANG, so use small sleeps
PUSHJ P,$HANG
TDNE T,DATSTA(IDX)
] ;END IFN TNX
JRST CTLLOP ;Ok, all done, go back for more
;;; Here upon receipt of synchronous mark
SBSSYN: HLRZS TT,DATBYT(IDX) ;Set up new byte size as current byte size
TRNN IDX,1 ;If reading from file do filepos and return
JRST FILSYN
SKIPE DATBPT(IDX) ;If a byte pointer is around, change its byte size
DPB TT,[360600,,DATBPT(IDX)]
HRRI A,ST%OPN ;Channel is now in open state
MOVEI T,36. ;Calculate and remember number of bytes per word
IDIVI T,(TT)
MOVEM T,DATBPW(IDX)
POPJ P, ;Then we are done
;;; DELETE, RENAME and other sundry file operations
;;; DELETE
COMDEL: TRNN F,F.FHN ;Did we have a file handle?
JRST DELFIL ;Nope, filename must be specified
JUMPGE BC,COMBAD ;Must be end of command string here
IFN ITS,[
.CALL [ SETZ
SIXBIT /DELEWO/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL ;Can't fail, can it??
SETZM DATFN1(IDX) ;Flag file as deleted
] ;END IFN ITS
IFN TNX,[
MOVSI TT,DD.ABT
IORM TT,DATDSP(IDX) ;Flag for deletion later
] ;END IFN TNX
MOVEI A,[ASCIZ \DELETE\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP
DELFIL: TRZN F,F.NWL ;Newline?
JRST COMBAD ;Nope, bad command format
MOVEI IDX,MAXIDX ;Use the temporary channel for this
IFN ITS,[
PUSHJ P,COMPFN ;Parse the filename to be deleted
TRZN F,F.NWL ;Check for correct format
JRST COMBAD
SKIPE T,DATSNM(IDX) ;Keep sticky default directory
.SUSET [.SSNAME,,T]
.CALL [ SETZ
SIXBIT /DELETE/
%CLERR,,ERRCOD ;Error code
%CLIN,,DATDEV(IDX)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR ;File error, tell about it
] ;END IFN ITS
IFN TNX,[
SETZ D, ;COMGJF wants input file
PUSHJ P,COMGJF ;Get JFN
PUSHJ P,JSYSER ;Error, return it to the user
HRRZM 1,DATJFN(IDX) ;Save JFN
IFN 20X,PUSHJ P,TRYCON
DELF
ERCAL JSYSER
] ;END IFN TNX
MOVEI A,[ASCIZ \DELETE\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP
;;; RENAME
COMREN: TRZN F,F.NWL ;Both formats require newline
JRST COMBAD
TRNN F,F.FHN ;Use an open file?
JRST RENFIL ;Nope, need two filenames
IFN ITS,[
PUSH P,DATDEV(IDX)
PUSH P,DATSNM(IDX)
PUSHJ P,COMPFN ;Parse the filename
TRZN F,F.NWL ;Must be terminated by newline
JRST COMBAD
POP P,B ;Old directory
POP P,A ;Old device
PUSHJ P,RNMCHK
TRNE IDX,1 ;An output file?
JRST RENCOM ;Yes, using a temp name anyway, just proceed
.CALL [ SETZ
SIXBIT /RENMWO/
%CLERR,,ERRCOD ;Error code
%CLIN,,DATCHN(IDX)
%CLIN,,DATFN1(IDX)
%CLIN+%CLEND,,DATFN2(IDX)]
PUSHJ P,FILERR
MOVEI A,[ASCIZ \RENAME\]
PUSHJ P,COMCTL
MOVEI BYTE,215 ;A NEWLINE
PUSHJ P,COMCHO
.CALL [ SETZ ;GET TRUENAME TO RETURN TO USER
SIXBIT /RFNAME/
%CLIN,,DATCHN(IDX)
%CLOUT,,DATDEV(IDX)
%CLOUT,,DATFN1(IDX)
%CLOUT,,DATFN2(IDX)
%CLOUT+%CLEND,,DATSNM(IDX)]
JFCL ;WELL, IT SHOULDN'T BUT...
PUSHJ P,COMRFO ;OUTPUT THE REAL FILENAMES
PUSHJ P,COMSND
JRST CTLLOP
;Here, the real filenames are not known yet.
RENCOM: MOVEI A,[ASCIZ \RENAME\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP
] ;END IFN ITS
IFN TNX,[
HRLZI D,ST.OUT ;COMGJF wants output file
SETZM NOTNEW
PUSHJ P,COMGJF ;Get a JFN for the file
PUSHJ P,JSYSER
MOVE 2,DATDSP(IDX) ;2 gets "current" (may not have that name yet really)
TLNN 2,DD.SUP
MOVE 2,DATJFN(IDX)
PUSHJ P,RENTNM ;Build return packet
HRLI 1,DD.SUP
PUSH P,1 ;Save new name
PUSHJ P,RELRJF ;Dispose of old DATDSP file name
POP P,DATDSP(IDX) ;Defer processing until file gets closed
PUSHJ P,COMSND
JRST CTLLOP
];END IFN TNX
RENFIL: MOVEI IDX,MAXIDX ;A phony IDX to use
IFN ITS,[
PUSHJ P,COMPFN ;Parse the from filename
TRZN F,F.NWL ;Must have trailing newline
JRST COMBAD
SKIPE T,DATSNM(IDX) ;Keep sticky default directory
.SUSET [.SSNAME,,T]
IRPS WHAT,,[DATDEV,DATFN1,DATFN2,DATSNM]
PUSH P,WHAT(IDX)
TERMIN
PUSHJ P,COMPFN ;Parse the next filespec
TRZN F,F.NWL
JRST COMBAD
MOVE A,-3(P) ;DATDEV
MOVE B,0(P) ;DATSNM
PUSHJ P,RNMCHK
.CALL [ SETZ
SIXBIT /RENAME/
%CLERR,,ERRCOD
%CLIN,,A
%CLIN,,-2(P)
%CLIN,,-1(P)
%CLIN,,B
%CLIN,,DATFN1(IDX)
%CLIN+%CLEND,,DATFN2(IDX)]
PUSHJ P,FILERR ;Report file error
SUB P,[4,,4] ;Not really necessary, but get rid of pushed cruft
JRST RENCOM
RNMCHK: MOVE T,DATDEV(IDX) ;Both devices must be the same.
CAMN T,MACNAM
MOVE T,[SIXBIT/DSK/]
CAMN A,MACNAM
MOVE A,[SIXBIT/DSK/]
CAME A,T
JRST [ CERR RAD,[Cannot rename across devices] ]
SKIPN B
.SUSET [.RSNAME,,B]
SKIPN DATSNM(IDX)
MOVEM B,DATSNM(IDX) ;dir of second file defaults to the first one's.
CAMN B,DATSNM(IDX)
POPJ P, ;They must also be the same.
CERR RAD,[Cannot rename across directories]
] ;END IFN ITS
IFN TNX,[
SETZ D, ;Get input file first
PUSHJ P,COMGJF ;Get JFN for file
PUSHJ P,JSYSER ;Can't get JFN, so return
MOVEM 1,DATDSP(IDX) ;Save source JFN
TLO D,ST.OUT ;Next file is 'output' file
SETZM NOTNEW
PUSHJ P,COMGJF
PUSHJ P,RELINF ;Can't get output JFN, so release input JFN (doesn't return)
MOVE 2,DATDSP(IDX)
PUSHJ P,RENTNM ;Build response packet presuming success
MOVE 2,1
MOVE C,1 ;Remember target in case of error
MOVE 1,DATDSP(IDX)
IFN 20X,[
MOVEM 1,DATJFN(IDX) ;Implicit arg to TRYCON
PUSHJ P,TRYCON
];20X
RNAMF
ERCAL [MOVE 1,C
RLJFN
JFCL
IFN 20X,SETZM DATJFN(IDX)
JRST RELINF]
MOVE 1,C
RLJFN
JFCL
IFN 20X,SETZM DATJFN(IDX)
PUSHJ P,COMSND
JRST CTLLOP
RELINF: PUSHJ P,RELRJ1 ;Release DATDSP(IDX)
JRST JSYSER
;Store target truename from JFN in 1, and source truename from 2
;into success packet, to be sent later if we succeed. Preserves 1.
RENTNM: PUSH P,1
PUSH P,2
MOVEI A,[ASCIZ \RENAME\]
PUSHJ P,COMCTL
MOVEI BYTE,215
PUSHJ P,COMCHO
HRROI 1,RESBLK ;Target truename
MOVE 2,-1(P)
MOVE 3,[111110,,JS%PAF] ;Device, directory, filename, file type, version
JFNS
ERCAL SYSBUG
PUSHJ P,COMRES
MOVEI BYTE,215
PUSHJ P,COMCHO
HRROI 1,RESBLK ;Source truename
POP P,2
MOVE 3,[111110,,JS%PAF] ;Device, directory, filename, file type, version
JFNS
ERCAL SYSBUG
PUSHJ P,COMRES
POP1J: POP P,1
POPJ P,
];END IFN TNX
;;; CONTINUE command. Continue processing after a recoverable asynchronous error
COMCON: JUMPGE BC,COMBAD ;Better not have any more stuff
TRNN F,F.FHN ;Need a file handle
JRST COMBAD
SKIPL A,DATSTA(IDX) ;Channel must be active
CONCCC: CERR BUG,[Channel cannot continue]
MOVEI T,ST%ASY ;Must be in async mark state
CAIN T,(A)
TLNE A,ST.UNC ;And must be continuable
JRST CONCCC
HRRI A,ST%OPN ;Ok, so fix up
MOVEM A,DATSTA(IDX)
MOVEI A,[ASCIZ \CONTINUE\]
PUSHJ P,COMCTL ;Send completion response
PUSHJ P,COMSND
IFN ITS,[
.CALL [ SETZ ;Continue the interrupted I/O operation
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,DATBPT(IDX)
%CLIN+%CLEND,,DATBCT(IDX)]
JRST CONERR ;Another IOC error, didn't really fix the problem
.SUSET [.SPICLR,,[0]] ;Don't allow interrupts, and the continuation better not
; do anything that causes them!
] ;END IFN ITS
IFN TNX,[
PUSHJ P,DOSIO ;Continue I/O operation
JRST CONERR
MOVEI 1,.FHSLF
DIR
] ;END IFN TNX
MOVE A,DATSTA(IDX)
PUSHJ P,@DATICN(IDX)
MOVEM A,DATSTA(IDX)
IFN ITS,[
.SUSET [.SPICLR,,[-1]]
MOVE T,CHABIT(IDX)
ANDCAM T,SSYDF2 ;Update saved copy of DF2 (can't hurt even if not masked)
TRNE IDX,1 ;Undefer interrupts if necessary
.SUSET [.SADF2,,T]
.SUSET [.SIIFPIR,,T] ;Cause interrupt to start the ball rolling
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF ;Turn interrupt system back on
EIR
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
AIC ;Reenable interrupts on this channel
IIC ;Force interrupt on channel to start ball rolling
] ;END IFN TNX
JRST CTLLOP ;Then done
CONERR:
IFN ITS,[
.SUSET [.SPICLR,,[0]] ;Using shared resources, prevent timing screws
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
DIR
] ;END IFN TNX
PUSH P,DATICN(IDX) ;Save important stuff over the IOC error emission
MOVE A,DATSTA(IDX) ;ICCERR wants status in A
MOVEI D,DATICN-1(IDX) ;And continuation in c(1(D))
PUSHJ P,[PUSHJ P,ICCERR] ;*K*L*U*D*G*E*
POP P,DATICN(IDX)
IFN ITS,[
.SUSET [.SPICLR,,[-1]]
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
EIR
] ;END IFN TNX
JRST CTLLOP ;Then done
IFN TNX,[
DOSIO: MOVE 1,DATJFN(IDX)
MOVE 2,DATBPT(IDX)
MOVN 3,DATBCT(IDX)
JUMPE 3,DOSIO1
TRNE IDX,1
JRST DOSIOO ;Output
SIN
ERJMP .+1
DOSIO1: PUSHJ P,ITSBP ;Turn BP in AC2 into an ITS standard byte pointer
MOVEM 2,DATBPT(IDX)
MOVNM 3,DATBCT(IDX)
SKIPN 3 ;Means we didn't make it all out
AOS (P)
POPJ P,
DOSIOO: SOUT
ERJMP DOSIO1
JRST DOSIO1
ITSBP: PUSH P,T
LDB T,[360600,,2] ;PP field of BP in AC2
JUMPN T,ITSBP0 ;Some bits left, so is ok
MOVEI T,44 ;Make agree with ITS -- point off left of next word
DPB T,[360600,,2]
AOS 2
ITSBP0: POP P,T
POPJ P,
] ;END IFN TNX
;;; Directory command
DATNDR==:DATBYT ;Next directory, 0 = start, -1 = done
IFN ITS,[
DATDRP==:DATBPW ;File being processed (index to UFD)
.INSRT SYSTEM;FSDEFS
] ;END IFN ITS
IFN TNX,[
DATDRN==:DATBPW ;Directory number being processed
]
COMPRO: TRZA F,F.DIR
COMDIR: TRO F,F.DIR
SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
TRNN F,F.FHN ;Must have file handle
CERR BUG,[Must have a file handle]
TRNE IDX,1 ;Input index?
CERR BUG,[Channel wrong direction]
SKIPGE DATSTA(IDX)
PUSHJ P,CLOSIT ;Close open channel
SETZM DATSTA(IDX)
MOVSI D,ST.DIR
TRZN F,F.DIR
TLO D,ST.PRO
DIROPT: TRNE F,F.NWL ;End of options? Or no file handle in PROPERTIES
JRST DIRFNM
TLNE D,ST.PRO
JRST COMPR1 ;PROPERTIES command with a file handle
PUSHJ P,COMRD5 ;Get token
JUMPL BC,COMBAD
DIROLP: MOVEI T,DIRLEN-1
DIROL1: CAME A,DIRTAB(T)
SOJGE T,DIROL1
JUMPL T,[CERR UUO,[Unknown DIRECTORY option]]
XCT DIRACT(T)
JRST COMBAD
JRST DIROPT
DIRTAB: ASCII \DELET\ ;Allow deleted files as well
ASCII \FAST\
ASCII \NO-EX\
ASCII \DIREC\
Ascii \SORTE\
DIRLEN==.-DIRTAB
DIRACT: TLOA D,ST.DEL
TLOA D,ST.FST
SKIPA
TLOA D,ST.ALD
SKIPA
;PROPERTIES command with a file handle
COMPR1: PUSHJ P,COMRD5 ;Get file handle
JFCL
JUMPGE BC,COMBAD ;Shouldn't have anything left over
MOVEI B,MAXIDX-1 ;LOOP OVER ALL INDICES
COMPR2: CAMN A,DATFHN(B) ;MATCH?
JRST COMPR3 ;YUP
SOJGE B,COMPR2
CERR BUG,[Unknown file handle argument to PROPERTIES]
COMPR3:
IFN TNX,[
MOVE 1,DATJFN(B)
TLZ D,ST.NOK
JRST SVDFLG
;PROPERTIES command with a file name joins
COMPR4: TLO D,ST.DEL\ST.NOK ;ST.NOK means we have a JFN to get rid of
PUSHJ P,COMGJF ;Get JFN in AC1
PUSHJ P,JSYSER
JRST SVDFLG
];TNX
IFN ITS,[
MOVE B,DATCHN(B)
.CALL [ SETZ ;Need device and directory names
SIXBIT /RFNAME/
%CLIN,,B
%CLOUT,,DATDEV(IDX)
%CLOUT,,DATFN1(IDX)
%CLOUT,,DATFN2(IDX)
%CLOUT+%CLEND,,DATSNM(IDX)]
PUSHJ P,SYSBUG
JRST COMPR5
;PROPERTIES command with a file name joins
COMPR4: .CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW,,.UAI+30 ;preserve dates, inhibit links
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR
MOVE B,DATCHN(IDX)
COMPR5: MOVEM B,DATFN1(IDX) ;Save channel number in weird place
JRST COMPR6
];ITS
DIRFNM:
IFN ITS,[
TLNN D,ST.PRO
SETOM STARF2 ;We want * for default FN2
PUSHJ P,COMPFN ;Parse the filename spec
SETZM STARF2
SKIPE T,DATSNM(IDX) ;KEEP STICKY DEFAULT DIRECTORY
.SUSET [.SSNAME,,T]
TLNE D,ST.PRO
JRST COMPR4
MOVSI T,(SIXBIT/*/)
SKIPN DATFN1(IDX)
MOVEM T,DATFN1(IDX)
COMPR6: PUSHJ P,LCKDIR ;Get DIRLCK
PUSHJ P,GETMFD ;Read in the MFD
PUSHJ P,[ HLRZ A,DATDEV(IDX) ;Archive devices just say they cannot work.
TRZ A,77
CAIE A,(SIXBIT /AR/)
JRST [ SETZM DIRLCK ? JRST FILERR ]
MOVEI A,[ASCIZ \ERROR \]
PUSHJ P,COMCTL ;Start off error packet, open failed error code
MOVEI A,[ASCIZ \WKF F CANNOT LIST ARCHIVE DEVICE\]
PUSHJ P,COMSTO
PUSHJ P,COMSND
JRST CTLLOP ]
;The following might be nice, but the directory format of archives is evidently
;not 100% compatible since we get an MPV trying to look at the descriptors.
;So we give an error if we try to take the directory of an archive.
;Note that it is necessary to read in the MFD even if the sname is not wildcarded,
;since the MFD is needed to decode file authors.
IFN 0,[ PUSHJ P,[ HLRZ A,DATDEV(IDX) ;Kludge around for archives
TRZ A,77
CAIE A,(SIXBIT/AR/)
JRST [ SETZM DIRLCK ? JRST FILERR ] ;Device doesn't exist?
PUSH P,DATDEV(IDX)
MOVSI A,'DSK
MOVEM A,DATDEV(IDX)
PUSHJ P,GETMFD
JRST [ POP P,DATDEV(IDX) ? SETZM DIRLCK ? JRST FILERR ]
POP P,DATDEV(IDX)
POPJ P, ]
];IFN 0
;; Allocate space for directory mapping
MOVEI T,DIRBUF/2000
PUSHJ P,PAGALO
SETZM DATDRP(IDX)
] ;END IFN ITS
IFN TNX,[
TLNE D,ST.PRO
JRST COMPR4
TLNE D,ST.ALD
JRST [ TLO D,ST.PON ;Do parse only
SETZM DATDRN(IDX)
JRST .+1]
PUSHJ P,COMGDJ ;Get directory JFN, with wildcards
JRST DIREMP
SVDFLG: MOVEM 1,DATJFN(IDX) ;Save it,
DRNFIL:
] ;END IFN TNX
IFN ITS,[
PUSHJ P,DIRSI2 ;See if dir exists.
PUSHJ P,FILERR ;Failure.
];ITS
SETZM DATNDR(IDX) ;Success, or hard to tell. Will start listing next time around
HLLM D,DATSTA(IDX) ;Save status bits
MOVEI A,[ASCIZ \DIRECTORY\]
TLNE D,ST.PRO
MOVEI A,[ASCIZ \PROPERTIES\]
PUSHJ P,COMCTL
JRST OPNFPS ;Finish up like open
IFN TNX,[
;GTJFN error code in 1
DIREMP: SETZM DATJFN(IDX) ;Make sure cleared out from last time.
CAIE 1,GJFX32 ;Directory empty (no files match specification)
CAIN 1,GJFX19 ;No such file type
JRST DRNFIL ;Yes, give directory stream with no files in it
CAIE 1,GJFX24 ;Both Tenex and TOPS-20 can give GJFX24 randomly
CAIN 1,GJFX20 ;I think only Tenex gives GJFX20
JRST DRNFIL
PUSHJ P,JSYSER ;Some other error - Complain.
];TNX
IFN ITS,[
;Skip if requesting either multiple directories or a single directory which exists.
;Do not skip if requesting a single directory which does not exist.
;If requesting a single directory which exists,
;we also read it in, so you can omit doing so later.
DIRSI2: MOVE TT,DATSNM(IDX) ;Get directory requested
DIRSI0: JUMPE TT,DIRSI1 ;Simple case, no directory wildcards
SETZ T,
LSHC T,6
CAIE T,'* ;A wildcard specifier?
JRST DIRSI0
JRST POPJ1
;; Simple case, only one directory
;; Try to read it in now; if we fail, report an error now.
DIRSI1: MOVE A,DATSNM(IDX)
MOVSI T,ST.ALD
TDNE T,DATSTA(IDX) ;Just wants directory names, not contents, => skip.
JRST POPJ1
PUSHJ P,GETUF1
POPJ P,
JRST POPJ1
];ITS
;;; Come here from REABUF when need some more input from a directory listing
;;; T has byte pointer to store into, TT has byte count
REDRBF: PUSH P,A
PUSH P,B ;Save some ac's
PUSH P,BC
PUSH P,BP
;; Directory loop, try to fill buffer with all info on one file, if we run out of room,
;; we back up the pointer to before the current file and return with that
MOVE BP,T
MOVE BC,TT
MOVE D,DATSTA(IDX)
SKIPN DATNDR(IDX) ;First time?
PUSHJ P,DIRHED ;Yes, print header
PUSH P,BP ;Save byte pointer
PUSH P,BC ;and counter
MOVEM P,DIRPDL ;Save stack pointer
REDRB0: PUSHJ P,DIRFIL ;Do one file
JRST REDBF1 ;No file to do
MOVEM BP,-1(P) ;Save updated byte pointer
MOVEM BC,(P) ;and count
JRST REDRB0
;; Done filling buffer, restore state and return
REDBF1: MOVE P,DIRPDL
POP P,TT ;Restore byte count
POP P,T ;and pointer
POP P,BP
POP P,BC
POP P,B
POP P,A
JRST REABF3 ;Return to main body of code
;;; Come here from COMCLO for directory channel
COMCLD: PUSHJ P,CLOSIT
MOVEI A,[ASCIZ \CLOSE\]
PUSHJ P,COMCTL
JRST CLOLED
;;; Come here from CLOSIT when done with a directory channel
CLODIR:
IFN ITS,[
MOVE TT,DATFN1(IDX)
TLNE T,ST.PRO
CAME TT,DATCHN(IDX)
JRST CLODI1
.CALL [ SETZ ;If we opened a file, close it
SIXBIT/CLOSE/
SETZ DATCHN(IDX) ]
JFCL
CLODI1: MOVEI T,MFDBUF/2000
PUSHJ P,PAGDAL
MOVEI T,DIRBUF/2000
PUSHJ P,PAGDAL
SETZM DIRLCK
MOVE T,DATSTA(IDX) ;Restore channel status
];END IFN ITS
IFN TNX,[
TLNE T,ST.PRO
TLNN T,ST.NOK
JRST CLODI1
MOVE 1,DATJFN(IDX) ;If we got a JFN, release it
RLJFN
ERJMP .+1
CLODI1:
];TNX
MOVEI TT,(T)
CAIN TT,ST%OPN ;Was the channel open?
HRRI T,ST%CLO ;Yes, then close it
MOVEM T,DATSTA(IDX)
JRST BUFDAL ;Deallocate the core buffer and return
IFN ITS,[
;; Lock the lock for the MFD and UFD pages and associated variables
LCKDIR: SKIPE T,DIRLCK
CAIN IDX,(T)
SKIPA
CERR NER,[Can't have more than one directory open at a time]
HRROM IDX,DIRLCK ;Something random
POPJ P,
;; Map in the MFD
GETMFD: MOVEI T,MFDBUF/2000
PUSHJ P,PAGALO
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW+%CLIMM,,.UII
%CLIMM,,UTILCH
%CLIN,,DATDEV(IDX)
%CLIN,,[SIXBIT /M.F.D./]
%CLIN,,[SIXBIT /(FILE)/]
%CLIN+%CLEND,,DATSNM(IDX)]
POPJ P,
MOVEI T,2000
MOVE TT,[444400,,MFDBUF]
.CALL [ SETZ
SIXBIT /SIOT/
%CLERR,,ERRCOD
%CLIMM,,UTILCH
%CLIN,,TT
%CLIN+%CLEND,,T]
SETZM MFDBUF+MDCHK ;Normally 'M.F.D.
.CLOSE UTILCH,
JFCL
MOVE T,MFDBUF+MDCHK
CAMN T,[SIXBIT /M.F.D./]
AOS (P)
POPJ P,
];ITS
;;; Printing routines
IFN ITS,[
;;; Print directory header info
DIRHED: MOVEI A,[ASCIZ \DONT-REAP NOT-BACKED-UP AUTHOR CREATION-DATE REFERENCE-DATE\]
TLNE D,ST.PRO
JRST DIRSCL ;PROPERTIES command has abbreviated header
PUSHJ P,DIRCLF ;Empty pathname for special information
TLNE D,ST.FST\ST.ALD ;Fast option?
JRST DIRHDE ;Yes, skip rest of heading
MOVEI A,[ASCIZ \SETTABLE-PROPERTIES DONT-REAP NOT-BACKED-UP AUTHOR CREATION-DATE REFERENCE-DATE\]
PUSHJ P,DIRSCL
MOVEI T,2000*36.
MOVEI A,[ASCIZ \BLOCK-SIZE\]
PUSHJ P,DIRDEC
PUSHJ P,DIRFSI
PUSHJ P,DIRCLF
DIRHDE: JRST DIRCLF
;;; Print one file
DIRFIL: SKIPGE DATDRP(IDX) ;Anything left at all to do?
POPJ P, ;No
SKIPE DATNDR(IDX) ;Initialized?
JRST DIRFL1
PUSHJ P,DIRINI ;No, do so
JRST DIRFIL
DIRFL1: PUSHJ P,DIR1FL ;Directory of one file
PUSHJ P,DIRNFL ;Step to next file
POPJ1: AOS (P)
POPJ P,
DIRINI: MOVE TT,DATSNM(IDX) ;Get directory requested
DIRIN1: JUMPE TT,DIRSIM ;Simple case, no directory wildcards
SETZ T,
LSHC T,6
CAIE T,'* ;A wildcard specifier?
JRST DIRIN1
;; The directory has some wildcards, figure out which ones to do
CNT==:1 ;Temporary AC's for sort
LST==:2
DIRWLD: SETO LST, ;LIST _ NIL
SETZ CNT, ;COUNT _ 0
SKIPA D,MFDBUF+MDNAMP
DIRWL1: ADDI D,LMNBLK
CAIL D,2000
JRST DIRWL2 ;End of MFD, go sort
SKIPN TT,MFDBUF(D)
JRST DIRWL1
MOVE B,DATSNM(IDX)
PUSHJ P,DIRMAT ;Star match
JRST DIRWL1 ;No good, try next
MOVEM LST,MFDBUF+1(D)
MOVEI LST,MFDBUF(D) ;LIST _ CONS(D,LIST)
AOJA CNT,DIRWL1
;;; Attempt star matching, pattern in B, test in TT. Clobbers A,T,TT
DIRMAT: CAME B,[SIXBIT /*/] ;Just * matches all
DIRMT1: CAMN B,TT ;The same now?
JRST POPJ1 ;A winner
SETZB A,T
LSHC A,6
LSHC T,6
CAIE A,(T) ;Same character
CAIN A,'* ;Or * in patter
JRST DIRMT1 ;Yes, go on
POPJ P, ;No, a loser
;;; Have all the matching entries linked thru LST, sort them
DIRWST: CAIN CNT,1 ;At end of list?
JRST DRWSTR ;Yes, return it
PUSH P,CNT ;Save count
LSH CNT,-1
PUSHJ P,DIRWST ;Recurse for first section
POP P,CNT
PUSH P,A ;Save value
ADDI CNT,1
LSH CNT,-1
PUSHJ P,DIRWST ;Recurse for second section
POP P,B ;Get first value
MOVEI C,D-1 ;Where to accumulate list
;; Merge two sublists
DIRWSM: JUMPL B,DRWST1 ;No first arg, maybe use second
JUMPL A,DRWSTB ;No second, use first
MOVE T,(A) ;Get second name
MOVE TT,(B) ;Get first name
;; Do magnitude comparison
JUMPL T,DRWSM2 ;T neg?
JUMPL TT,DRWSTA ;No, and TT neg => TT greater
JRST DRWSMC ;Both pos, just compare
DRWSM2: JUMPGE TT,DRWSTB ;T neg and TT pos => T greater
EXCH T,TT ;Both negative, reverse comparison
DRWSMC: CAML T,TT
JRST DRWSTA ;1st greater => take it
DRWSTB: MOVEM B,1(C)
MOVEI C,(B)
MOVE B,1(C)
JRST DIRWSM
DRWSTA: MOVEM A,1(C) ;Enter 1st at head
MOVEI C,(A) ;Transfer it to tail
MOVE A,1(C) ;Get next one
JRST DIRWSM ;And continue
DRWST1: JUMPGE A,DRWSTA ;Use 2nd if any
SETOM 1(C)
MOVE A,D
POPJ P,
DRWSTR: MOVEI A,(LST) ;A _ CAR(LIST)
MOVE LST,1(LST) ;LIST _ CDR(LIST)
SETOM 1(A) ;RPLACD(A,NIL)
POPJ P, ;RETURN(A)
;; Simple case, only one directory
DIRSIM: SETOM DATNDR(IDX) ;Flag that there is no next directory
MOVE T,DATSTA(IDX)
MOVE A,DATSNM(IDX)
TLNE T,ST.ALD
JRST [ MOVEM A,DATFN1(IDX) ;Someplace to store directory name
AOS DATDRP(IDX)
POPJ P,] ;Directories only, skip mapping ufd
;In this special case, we already read in the directory
;when the directory command was processed. So don't call DIRMAP now.
MOVE D,DIRBUF+UDNAMP ;Initialize pointer to first file
TLNN T,ST.PRO
JRST DIRNF1 ;Then advance to next file
MOVEI D,2000-LUNBLK ;Make dummy file block for PROPERTIES command
.CALL [ SETZ
'FILBLK
%CLIN,,DATFN1(IDX)
%CLOUT,,DIRBUF+0(D)
%CLOUT,,DIRBUF+1(D)
%CLOUT,,DIRBUF+2(D)
%CLOUT,,DIRBUF+3(D)
%CLOUT+%CLEND,,DIRBUF+4(D)]
JRST DIRDIE
JRST DIRNF4
DIRWL2: SKIPL A,LST ;If there is anything there,
PUSHJ P,DIRWST ;sort it
MOVEM A,DATNDR(IDX) ;DATNDR _ SORT(LIST)
;; Step to next directory
DIRNDR: SKIPG A,DATNDR(IDX) ;Next directory link
JRST [ SETOM DATDRP(IDX) ;Flag that no files are left to do
POPJ P,] ;Single return for no more
MOVE T,1(A)
MOVEM T,DATNDR(IDX)
MOVE A,(A) ;Sixbit directory name
;; Start going on directory in A
DIRMAP: MOVSI T,ST.ALD
TDNE T,DATSTA(IDX)
JRST [ MOVEM A,DATFN1(IDX) ;Someplace to store directory name
AOS DATDRP(IDX)
POPJ P,] ;Directories only, skip mapping ufd
PUSHJ P,GETUF1
JRST DIRDIE
MOVE D,DIRBUF+UDNAMP ;Initialize pointer to first file
JRST DIRNF1 ;Then advance to next file
;;; Here if we can't get a directory. Give an error over the connection and punt.
DIRDIE: PUSH P,PKTLOC ;Direct data to the async packet
MOVEI T,ASYPKT
MOVEM T,PKTLOC
MOVE A,DATSTA(IDX)
HRRI A,ST%ASY ;Channel now in ASYNC-MARKED state
TLO A,ST.UNC ;Not continuable
MOVEM A,DATSTA(IDX)
TRO F,F.FHN ;Force outputting of a file handle
PUSH P,[DIRDIE+2]
PUSHJ P,OPNERP
PUSHJ P,ICCERP
POP P,PKTLOC
SETOM DATDRP(IDX)
POPJ P,
;;; Map in directory in A
GETUFD: MOVEI T,DIRBUF/2000 ;Allocate space for directory mapping
PUSHJ P,PAGALO
GETUF1: .CALL [ SETZ
SIXBIT /IOPUSH/
%CLIN+%CLEND,,DATCHN(IDX) ]
PUSHJ P,SYSBUG
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW+%CLIMM,,.UII
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,[SIXBIT /.FILE./]
%CLIN,,[SIXBIT /(DIR)/]
%CLIN+%CLEND,,A]
JRST GETUF2
MOVEI T,2000
MOVE TT,[444400,,DIRBUF]
.CALL [ SETZ
SIXBIT /SIOT/
%CLERR,,ERRCOD
%CLIN,,DATCHN(IDX)
%CLIN,,TT
%CLIN+%CLEND,,T]
SETZM DIRBUF+UDNAME
.CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL
SKIPE DIRBUF+UDNAME
AOS (P)
GETUF2: .CALL [ SETZ
SIXBIT /IOPOP/
%CLIN+%CLEND,,DATCHN(IDX) ]
PUSHJ P,SYSBUG
POPJ P,
;;; Step to next file
DIRNFL: MOVE D,DATDRP(IDX)
MOVSI T,ST.ALD
TDNE T,DATSTA(IDX)
JRST [ JUMPE D,DIRNDR ;If directory already done, move to next
POPJ P,] ;Else continue with it
DIRNF0: ADDI D,LUNBLK
DIRNF1: TLNE D,-1
HLRZS D ;D now points to next file to do
CAIL D,2000 ;Off the end?
JRST DIRNDR ;Yes, step to next directory
MOVE B,DATFN1(IDX) ;Match FN1
MOVE TT,DIRBUF+UNFN1(D)
PUSHJ P,DIRMAT
JRST DIRNF0
MOVS B,DATFN2(IDX) ;Newest or oldest version requested?
CAIE B,(SIXBIT/</)
CAIN B,(SIXBIT/>/)
JRST DIRNF2
MOVE B,DATFN2(IDX) ;Match FN2
MOVE TT,DIRBUF+UNFN2(D)
PUSHJ P,DIRMAT
JRST DIRNF0
DIRNF4: MOVEM D,DATDRP(IDX)
POPJ P,
;;; Next file when only want newest or oldest version of each file.
;;; Matching -only- files with numeric versions seems to be what people want.
;;; We used to include every file with a non-numeric FN2, to be conservative.
;;; DATDRP(IDX) is either the index of the file, or the index
;;; of the next file group in the LH and garbage in the RH.
DIRNF2: MOVE TT,DIRBUF+UNFN2(D)
PUSHJ P,DIRNMP ;Is this a group of versions?
JRST DIRNF0 ;No, just a single file, skip it
MOVE A,DIRBUF+UNFN1(D) ;Yes, find end of the group
MOVEI B,(D)
DIRNF3: ADDI B,LUNBLK
CAIGE B,2000
CAME A,DIRBUF+UNFN1(B)
JRST DIRNF5
MOVE TT,DIRBUF+UNFN2(B)
PUSHJ P,DIRNMP
CAIA
JRST DIRNF3
DIRNF5: HRL D,B ;File to look at next time
MOVS TT,DATFN2(IDX) ;Want oldest of these or newest?
CAIN TT,(SIXBIT/>/)
SKIPA C,[CAMGE TT,A]
MOVE C,[CAMLE TT,A]
MOVE A,DIRBUF+UNFN2(D) ;Get right-adjusted version of first file
TRNN A,77
JUMPN A,[ LSH A,-6
JRST .-1 ]
MOVEI T,(D)
DIRNF6: ADDI T,LUNBLK
CAIL T,(B) ;More versions in group?
JRST DIRNF4 ;No, D points at best one found
MOVE TT,DIRBUF+UNFN2(T) ;Get right-adjusted version of this file
TRNN TT,77
JUMPN TT,[ LSH TT,-6
JRST .-1 ]
XCT C ;Skip if TT is better than A
JRST DIRNF6 ;A,D is still best version
MOVE A,TT ;New best version
HRRI D,(T) ;New file to put in dir listing
JRST DIRNF6
;Skip if sixbit in TT is purely numeric
DIRNMP: MOVEI T,0
LSHC T,6
CAIL T,'0
CAILE T,'9
POPJ P,
JUMPN TT,DIRNMP
JRST POPJ1
;;; Process one file
DIR1FL: MOVE TT,DATSTA(IDX)
TLNE TT,ST.ALD
JRST DIR1AD
MOVE T,DIRBUF+UNRNDM(D)
TLNE T,UNIGFL ;This file deleted?
TLNE TT,ST.DEL\ST.PRO ;Yes, list anyway?
SKIPA A,DATDEV(IDX)
POPJ P, ;No, don't output anything
PUSHJ P,DIRSXO
MOVEI A,[ASCIZ \: \]
PUSHJ P,DIRSTR
MOVE A,DIRBUF+UDNAME
PUSHJ P,DIRSXO
MOVEI A,[ASCIZ \; \]
PUSHJ P,DIRSTR
MOVE D,DATDRP(IDX) ;Get pointer to file
MOVE A,DIRBUF+UNFN1(D)
PUSHJ P,DIRSXO
MOVEI BYTE,40
PUSHJ P,DIRCHO
MOVE A,DIRBUF+UNFN2(D)
PUSHJ P,DIRSXO
PUSHJ P,DIRCLF
MOVSI TT,ST.FST
TDNE TT,DATSTA(IDX) ;Fast option?
JRST DIR1FE ;Yes, skip rest
MOVE T,DIRBUF+UNRNDM(D)
TLNE T,UNLINK ;Is this file a link?
JRST DIR1LN ;Yes, special processing
TLNN T,UNIGFL ;* file?
JRST DIR1F1 ;No, ordinary
MOVEI A,[ASCIZ \DELETED\]
PUSHJ P,DIRSCL
DIR1F1: TLNN T,UNREAP
JRST DIR1F2
MOVEI A,[ASCIZ \DONT-REAP\]
PUSHJ P,DIRSCL
DIR1F2: TLNE T,UNDUMP
JRST DIR1F3
MOVEI A,[ASCIZ \NOT-BACKED-UP\]
PUSHJ P,DIRSCL
DIR1F3: LDB T,[UNPKN DIRBUF+UNRNDM(D)]
MOVEI A,[ASCIZ \PHYSICAL-VOLUME\]
PUSHJ P,DIRDEC
MOVEI T,2000*36.
MOVEI A,[ASCIZ \BLOCK-SIZE\]
PUSHJ P,DIRDEC
PUSHJ P,DIRLN0 ;Length in blocks into T
MOVSI TT,ST.PRO
TDNE TT,DATSTA(IDX)
PUSHJ P,DIR1F5 ;PROPERTIES command, dir may have changed
PUSH P,T ;Save it
MOVEI A,[ASCIZ \LENGTH-IN-BLOCKS\]
PUSHJ P,DIRDEC
POP P,T ;Length in blocks
LDB TT,[UNWRDC DIRBUF+UNRNDM(D)] ;Word count of last block
SKIPE TT
SUBI T,1
LSH T,10.
ADDI T,(TT) ;Word count now in T
PUSH P,T
LDB T,[UNBYTE DIRBUF+UNREF(D)] ;Byte size info
TRZE T,400
JRST [ IDIVI T,100 ;400+100xS+C
JRST DIR1F4]
TRZE T,200
JRST [ IDIVI T,20 ;200+20xS+C
JRST DIR1F4]
SUBI T,36.
JUMPGE T,[IDIVI T,4 ;44+4xS+C
JRST DIR1F4]
MOVMS T ;44-S
SETZ TT, ;C=0
DIR1F4: PUSH P,TT ;Save number of extra bytes
PUSH P,T ;Save byte size
MOVEI A,[ASCIZ \BYTE-SIZE\]
PUSHJ P,DIRDEC
MOVEI T,36.
IDIV T,(P) ;Number of words per byte
IMUL T,-2(P) ;Times number of words
SUB T,-1(P) ;Less number of extra bytes
SUB P,[3,,3]
MOVEI A,[ASCIZ \LENGTH-IN-BYTES\]
PUSHJ P,DIRDEC
DIR1FD: MOVE T,DIRBUF+UNDATE(D)
MOVEI A,[ASCIZ \CREATION-DATE\]
PUSHJ P,DIRDAT
HLLZ T,DIRBUF+UNREF(D)
MOVEI A,[ASCIZ \REFERENCE-DATE\]
PUSHJ P,DIRDAT
LDB T,[UNAUTH DIRBUF+UNREF(D)]
CAIN T,777 ;No author?
JRST DIR1FE
SUB T,MFDBUF+MDNUDS
ASH T,1
SKIPN T,MFDBUF+2000(T) ;Get sixbit directory name
JRST DIR1FE
MOVEI A,[ASCIZ \AUTHOR\]
PUSHJ P,DIRIND
MOVE A,T
PUSHJ P,DIRSXO
PUSHJ P,DIRCLF
DIR1FE: JRST DIRCLF
DIR1F5: .CALL [ SETZ
'FILLEN
%CLIN,,DATFN1(IDX)
%CLOUT,,T ;Length in bytes
%CLOUT+%CLEND,,TT] ;Byte size
JRST DIRDIE
MOVEI A,36.
IDIVM A,TT
IDIV T,TT ;Length in words
ADDI T,1777
LSH T,-10.
POPJ P,
;; Link info output
DIR1LN: MOVEI A,[ASCIZ \LINK-TO\]
PUSHJ P,DIRIND
PUSHJ P,DIRDSC ;Get link descriptor
PUSHJ P,DIRLXO
MOVEI BYTE,";
PUSHJ P,DIRCHO
MOVEI BYTE,40
PUSHJ P,DIRCHO
PUSHJ P,DIRLXO
MOVEI BYTE,40
PUSHJ P,DIRCHO
PUSHJ P,DIRLXO
PUSHJ P,DIRCLF
JRST DIR1FD ;Return to main body
;;; Output link atom b.p. in A
DIRLXO: MOVEI T,6 ;End on six characters
DIRLX0: ILDB BYTE,A
JUMPE BYTE,CPOPJ
CAIN BYTE,'; ; ; ends
POPJ P,
CAIN BYTE,': ; : quotes
ILDB BYTE,A
ADDI BYTE,40
PUSHJ P,DIRCHO
SOJG T,DIRLX0
POPJ P,
;;; Get length in blocks into T
DIRLN0: PUSHJ P,DIRDSC ;Get ufd descriptor
MOVEI T,0
DIRLN1: ILDB B,A
JUMPE B,CPOPJ ;End by 0
CAILE B,UDTKMX ;1-UDTKMX
JRST DIRLN2
ADDI T,(B) ;Take N
JRST DIRLN1
DIRLN2: CAIGE B,UDWPH
AOJA T,DIRLN1 ;Take 1
CAIN B,UDWPH ;Write place holder
JRST DIRLN1
IBP A
IBP A
AOJA T,DIRLN1
;;; Get file descriptor into A. Clobbers B
DIRDSC: LDB A,[UNDSCP DIRBUF+UNRNDM(D)] ;Get link descriptor
IDIVI A,UFDBPW
ADD A,[ 440600,,DIRBUF+UDDESC
360600,,DIRBUF+UDDESC
300600,,DIRBUF+UDDESC
220600,,DIRBUF+UDDESC
140600,,DIRBUF+UDDESC
060600,,DIRBUF+UDDESC](B)
POPJ P,
;;; Directory output, just listing all directories.
;;; DATDRP is the directory name while it is pending, 0 while waiting for the next one.
DIR1AD: MOVE A,DATDEV(IDX)
PUSHJ P,DIRSXO
MOVEI A,[ASCIZ \: \]
PUSHJ P,DIRSTR
MOVE A,DATFN1(IDX)
PUSHJ P,DIRSXO
MOVEI A,[ASCIZ \; \]
PUSHJ P,DIRSTR
PUSHJ P,DIRCLF
PUSHJ P,DIRCLF
SETZM DATDRP(IDX)
POPJ P,
;;; SIXBIT output from A
DIRSXO: MOVE B,A
DIRSO0: JUMPE B,CPOPJ
SETZ A,
LSHC A,6
JUMPE A,DIRSOQ
CAIE A,':
CAIN A,';
JRST DIRSOQ
DIRSO1: MOVEI BYTE,40(A)
PUSHJ P,DIRCHO
JRST DIRSO0
DIRSOQ: MOVEI BYTE,"
PUSHJ P,DIRCHO
JRST DIRSO1
] ;END IFN ITS
IFN TNX,[
DIRHED:
IFN 20X,MOVEI A,[ASCIZ \NOT-BACKED-UP AUTHOR CREATION-DATE REFERENCE-DATE BYTE-SIZE LENGTH-IN-BYTES PROTECTION GENERATION-RETENTION-COUNT ACCOUNT TEMPORARY DELETED DONT-DELETE DONT-REAP\]
IFN 10X,MOVEI A,[ASCIZ \NOT-BACKED-UP AUTHOR CREATION-DATE REFERENCE-DATE BYTE-SIZE LENGTH-IN-BYTES PROTECTION GENERATION-RETENTION-COUNT ACCOUNT TEMPORARY DELETED DONT-DELETE\]
TLNE D,ST.PRO
JRST DIRSCL ;PROPERTIES command has abbreviated header
PUSHJ P,DIRCLF ;Empty pathname for special information
TLNE D,ST.FST\ST.ALD ;Fast option?
JRST DIRHDE ;Yes, skip rest of heading
MOVEI A,[ASCIZ \SETTABLE-PROPERTIES NOT-BACKED-UP AUTHOR CREATION-DATE REFERENCE-DATE BYTE-SIZE LENGTH-IN-BYTES PROTECTION GENERATION-RETENTION-COUNT ACCOUNT TEMPORARY DELETED DONT-DELETE\]
IFN 20X,[
PUSHJ P,DIRSTR
MOVEI A,[ASCIZ \ DONT-REAP\]
];20X
PUSHJ P,DIRSCL
PUSHJ P,DIRFSI
PUSHJ P,DIRCLF
DIRHDE: PUSHJ P,DIRCLF
AOS DATNDR(IDX)
POPJ P,
DIRFIL: SKIPN DATJFN(IDX) ;Still have a file?
POPJ P, ;No, cannot fill in anything
MOVSI TT,ST.ALD
TDNE TT,DATSTA(IDX)
JRST DIRALD
HRROI 1,RESBLK
HRRZ 2,DATJFN(IDX)
MOVE 3,[111110,,JS%PAF]
JFNS
PUSHJ P,DIRRES
PUSHJ P,DIRCLF
MOVSI TT,ST.FST
TDNE TT,DATSTA(IDX) ;Fast option?
JRST DIRFLE ;Yes, skip rest
HRRZ 1,DATJFN(IDX)
IFN 20X,MOVSI 2,.FBLEN
.ELSE, MOVSI 2,.FBUSW+1
MOVEI 3,DIRINF
GTFDB
ERCAL JSYSER
MOVE T,DIRINF+.FBCTL ;Get control bits
MOVSI TT,-NDBITS
DIRFLL: TDNN T,DIRBIT(TT)
JRST DIRFL1
MOVE A,DIRBST(TT)
PUSHJ P,DIRSCL
DIRFL1: AOBJN TT,DIRFLL
HRRZ T,DIRINF+.FBPRT
MOVEI A,[ASCIZ \PROTECTION\]
PUSHJ P,DIROCT
LDB T,[<.BP FB%RET> DIRINF+.FBBYV]
MOVEI A,[ASCIZ \GENERATION-RETENTION-COUNT\]
PUSHJ P,DIRDEC
LDB T,[<.BP FB%BSZ> DIRINF+.FBBYV]
MOVEI A,[ASCIZ \BYTE-SIZE\]
PUSHJ P,DIRDEC
MOVE T,DIRINF+.FBSIZ
MOVEI A,[ASCIZ \LENGTH-IN-BYTES\]
PUSHJ P,DIRDEC
MOVEI T,1000*36.
MOVEI A,[ASCIZ \BLOCK-SIZE\]
PUSHJ P,DIRDEC
LDB T,[<.BP FB%PGC> DIRINF+.FBBYV]
MOVEI A,[ASCIZ \LENGTH-IN-BLOCKS\]
PUSHJ P,DIRDEC
MOVE T,DIRINF+.FBWRT ;Really time of last write
MOVEI A,[ASCIZ \CREATION-DATE\]
PUSHJ P,DIRDAT
MOVEI A,[ASCIZ \REFERENCE-DATE\]
SKIPE T,DIRINF+.FBREF
PUSHJ P,DIRDAT
MOVEI A,[ASCIZ \NOT-BACKED-UP\]
SKIPN DIRINF+.FBBK0
PUSHJ P,DIRSCL
MOVSI T,(AR%NAR)
MOVEI A,[ASCIZ \DONT-REAP\]
TDNE T,DIRINF+.FBBBT
PUSHJ P,DIRSCL
HRRZ 1,DATJFN(IDX)
IFN 20X,[
HRLI 1,.GFLWR ;Really last writer
HRROI 2,RESBLK
GFUST
MOVEI A,[ASCIZ \AUTHOR\]
PUSHJ P,DIRRCL
IRP NAM,,[FBTP1,FBSS1,FBTP2,FBSS2]
MOVEI A,[ASCIZ \NAM\]
SKIPE T,DIRINF+.!NAM
PUSHJ P,DIROCT
TERMIN
]
IFN 10X,[
HRROI 1,RESBLK
HLRZ 2,DIRINF+.FBUSE ;Author
DIRST
JRST .+3
MOVEI A,[ASCIZ \AUTHOR\]
PUSHJ P,DIRRCL
HRROI 1,RESBLK
HRRZ 2,DIRINF+.FBUSE ;Last reader
DIRST
JRST .+3
MOVEI A,[ASCIZ \READER\]
PUSHJ P,DIRRCL
]
HRROI 1,RESBLK
HRRZ 2,DATJFN(IDX)
MOVEI 3,JS%ACT
JFNS
MOVEI A,[ASCIZ \ACCOUNT\]
PUSHJ P,DIRRCL
;; Done with this file, output blank line
DIRFLE: MOVE 1,DATJFN(IDX)
GNJFN
SETZM DATJFN(IDX)
DIRFE1: PUSHJ P,DIRCLF
AOS DATNDR(IDX)
POPJ1: AOS (P) ;Skip return for full file
POPJ P,
DIRALD: SKIPE 2,DATDRN(IDX) ;Have a directory number already?
JRST DIRAL1
PUSHJ P,DIRSTP
POPJ P,
DIRAL1: HRROI 1,RESBLK
DIRST
JRST DIRAL2
IFN 10X,[
MOVEI A,[ASCIZ /DSK:</] ;>
PUSHJ P,DIRSTR
];10X
MOVEI A,RESBLK
PUSHJ P,DIRSTR
IFN 10X,[ ;<
MOVEI BYTE,">
PUSHJ P,DIRCHO
];10X
PUSHJ P,DIRCLF
DIRAL2: PUSHJ P,DIRSTP
SETZM DATDRN(IDX)
JRST DIRFE1
DIRSTP: HRROI 1,RESBLK
MOVE 2,DATJFN(IDX)
IFN 10X,MOVSI 3,(JS%DIR)
.ELSE MOVE 3,[JS%DEV+JS%DIR+JS%PAF]
JFNS
MOVSI 1,(RC%AWL)
HRROI 2,RESBLK
SKIPE 3,DATDRN(IDX)
TLO 1,(RC%STP)
RCDIR
MOVEM 3,DATDRN(IDX)
MOVE 2,3 ;Return in 2
TLNN 1,(RC%NMD\RC%NOM)
JRST POPJ1
PUSHJ P,RELDJF
POPJ P,
DIRBIT: FB%TMP
FB%DEL
IFN 20X,[
FB%DIR
FB%NOD
FB%OFF
IFDEF FB%NDL,FB%NDL ; Twenex release 5 has new name and value
.ELSE [
IFDEF FB%UND,FB%UND
.ELSE FB%PRM
]
];20X
.ELSE 400,,0
NDBITS==:.-DIRBIT
DIRBST: [ASCIZ \TEMPORARY\]
[ASCIZ \DELETED\]
IFN 20X,[
[ASCIZ \DIRECTORY\]
[ASCIZ \DONT-DUMP\]
[ASCIZ \OFFLINE\]
];20X
[ASCIZ \DONT-DELETE\]
;;; Output string in A, then RESBLK, then newline
DIRRCL: PUSHJ P,DIRIND
PUSHJ P,DIRRES
JRST DIRCLF
] ;END IFN TNX
;;; Output indicator
DIRIND: PUSHJ P,DIRSTR
MOVEI BYTE,40
JRST DIRCHO
;;; Output date in T with indicator in A
DIRDAT: PUSHJ P,DIRIND
MOVE A,T
PUSHJ P,DIRDTO
JRST DIRCLF
;;; Output octal number in T for property indicator in A
;;; NOTE: This function knows about returning from its caller
DIROCT: SKIPA B,[8]
DIRDEC: MOVEI B,10.
PUSHJ P,DIRIND
PUSHJ P,DIRNUM
JRST DIRCLF
;;; Just output number in T base in B
DIRNUM: PUSH P,[-1]
JUMPGE T,DIRNM0
MOVEI BYTE,"-
PUSHJ P,DIRCHO
MOVNS T
TLZ T,400000
DIRNM0: IDIVI T,(B)
PUSH P,TT
JUMPN T,DIRNM0
DIRNM1: POP P,BYTE
JUMPL BYTE,CPOPJ
ADDI BYTE,"0
PUSHJ P,DIRCHO
JRST DIRNM1
DIRSCL: PUSHJ P,DIRSTR
DIRCLF: MOVEI A,[.BYTE 7 ? ^M ? ^J]
JRST DIRSTR
IFN TNX,DIRRES: SKIPA A,[440700,,RESBLK]
DIRSTR: HRLI A,440700
DIRST1: ILDB BYTE,A ;Get next character
JUMPE BYTE,CPOPJ ;Terminate on null
PUSHJ P,DIRCHO
JRST DIRST1
DIRCHO: SOJLE BC,REDBF1 ;Unwind when buffer filled
IDPB BYTE,BP
POPJ P,
;;; FILE-SYSTEM-INFO command
;;; The info had better all fit in one packet, or all hell will break loose!
COMFSI: MOVEI A,[ASCIZ \FILE-SYSTEM-INFO \]
PUSHJ P,COMCTL
MOVEI BYTE,215
PUSHJ P,COMCHO
SUBI BC,CHPMXC
MOVNS BC ;So DIRCHO will act like COMCHO
IFN 20X,MOVEI IDX,MAXIDX
PUSHJ P,DIRFSI
SUBI BC,CHPMXC
MOVNS BC
PUSHJ P,COMSND
JRST CTLLOP
DIRFSI:
IFN 10X,[
MOVEI A,[ASCIZ\DISK-SPACE-DESCRIPTION \]
PUSHJ P,DIRSTR
HRLOI 1,.DVDES+.DVDSK ;DSK: DESIGNATOR
GDSKC ;1 gets pages used, 2 gets pages left
ADD 1,2
MOVEI B,10.
MOVE T,2
PUSHJ P,DIRNUM
MOVEI A,[ASCIZ\ disk pages free out of \]
PUSHJ P,DIRSTR
MOVE T,1
PUSHJ P,DIRNUM
MOVEI A,[ASCIZ\ (\]
PUSHJ P,DIRSTR
MOVE T,1
SUB T,2
IMULI T,100.
IDIV T,1
PUSHJ P,DIRNUM
MOVEI A,[ASCIZ\% full)\]
JRST DIRSTR
];10X
IFN 20X,[
MOVEI A,[ASCIZ\DISK-SPACE-DESCRIPTION \]
PUSHJ P,DIRSTR
HRRZ 2,DATJFN(IDX)
JUMPE 2,FRESTR ;Not really anything here, no JFN.
MOVSI 1,(RC%EMO)
RCDIR
TLNE 1,(RC%NOM)
JRST FRESTR ;No match, presumably wildcard was used.
MOVE 1,3
GTDAL ;Get directory allocation.
MOVEI B,10.
MOVE T,2 ;Permanent quota
PUSHJ P,DIRNUM
MOVEI A,[ASCIZ / used, /]
PUSHJ P,DIRSTR
CAML 3,[377777,,0]
JRST [MOVEI A,[ASCIZ /+INF/]
PUSHJ P,DIRSTR
JRST .+3]
MOVE T,3
PUSHJ P,DIRNUM
MOVEI A,[ASCIZ / allowed. /]
PUSHJ P,DIRSTR
FRESTR: MOVE 1,[SIXBIT /DEVNAM/]
SYSGT
HRRZ D,2 ;Table#
MOVEI C,1 ;Should be 1st device name.
GSTRNM: HRLZ 1,C
HRR 1,D ;Offset,,table#
GETAB
JFCL
;;This won't work if # of structures = STRN!
;; HLRZ 2,1 ;If no more devices, it's SIXBIT/STRnnn/
;; CAIN 2,(SIXBIT /STR/)
;; JRST [ MOVEI A,[ASCIZ/ disk pages free./]
;; JRST DIRSTR ]
MOVE 3,[440700,,STRNAM]
ST6TO7: SETZ 2, ;Turn sixbit structure name into asciz
ROTC 1,6 ;string.
ADDI 2,40
IDPB 2,3
JUMPN 1,ST6TO7
SETZ 2,
IDPB 2,3 ;Null terminate.
;;Start of UTexas change
HRROI 1,STRNAM ;Set up to get device designator
STDEV
ERJMP ENDSTR
MOVE 1,2 ;Set up device designator
MOVEM 1,DEVDEG ;Save device designator for later
DVCHR ;Check device type
ERJMP ENDSTR
LDB 3,[221100,,2] ;Get DV%TYP
CAIE 3,.DVDSK ;Is it a disk?
JRST ENDSTR ;No
;;End of UTexas change
MOVEI BYTE,40
PUSHJ P,DIRCHO
PUSHJ P,DIRCHO
MOVEI A,STRNAM
PUSHJ P,DIRSTR
MOVEI BYTE,": ;<sp><sp>STRUCTURE:<sp>nnnnn
PUSHJ P,DIRCHO
MOVEI BYTE,40
PUSHJ P,DIRCHO
MOVE 1,DEVDEG ;[UTexas] Restore device designator
GDSKC
MOVE T,2 ;Free
MOVEI B,10.
PUSHJ P,DIRNUM
GNSTRN: AOJA C,GSTRNM ;Step to next structure.
ENDSTR: MOVEI A,[ASCIZ/ disk pages free./]
JRST DIRSTR
];20X
IFN ITS,[
MOVEI A,[ASCIZ \PHYSICAL-VOLUME-FREE-BLOCKS\]
PUSHJ P,DIRSTR
MOVE T,[SQUOZE 0,NQS]
.EVAL T,
.LOSE %LSSYS
MOVSI C,-1
TLC C,-1(T) ;AOBJN pointer
MOVE T,[SQUOZE 0,QSFT]
.EVAL T,
.LOSE %LSSYS
PUSH P,T
MOVE T,[SQUOZE 0,QPKID]
.EVAL T,
.LOSE %LSSYS
PUSH P,T
MOVEI B,10.
DIRFR0: MOVE TT,(P) ;QPKID
ADDI TT,(C) ;(Q)
MOVSS TT
HRRI TT,T
.GETLOC TT,
JUMPL T,DIRFR1
MOVEI BYTE,",
TRNN C,-1
MOVEI BYTE,40
PUSHJ P,DIRCHO
PUSHJ P,DIRNUM
MOVEI BYTE,":
PUSHJ P,DIRCHO
MOVE TT,-1(P) ;QSFT
ADDI TT,(C) ;(Q)
MOVSS TT
HRRI TT,T
.GETLOC TT,
PUSHJ P,DIRNUM
DIRFR1: AOBJN C,DIRFR0
SUB P,[2,,2]
POPJ P,
];ITS
;;; Filename completion command
COMCPL: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
SETZ D, ;Clear options here
CPLOPT: TRNE F,F.NWL ;End of options?
JRST CPLFNM
PUSHJ P,COMRD5 ;Get token
JUMPL BC,COMBAD
CPLOLP: MOVEI T,CPLLEN-1
CPLOL1: CAME A,CPLTAB(T)
SOJGE T,CPLOL1
JUMPL T,[CERR UUO,[Unknown COMPLETE option]]
XCT CPLACT(T)
JRST COMBAD
JRST CPLOPT
CPLTAB: ASCII \DELET\
ASCII \READ\
ASCII \WRITE\
ASCII \OLD\
ASCII \NEW-O\
CPLLEN==.-CPLTAB
CPLACT: TLOA D,ST.DEL
TLZA D,ST.OUT
TLOA D,ST.OUT
TLZA D,ST.NOK
TLOA D,ST.NOK
IFN TNX,[
;;; Local storage
DEFDEV==RESBLK
DEFDIR==DEFDEV+1
DEFNAM==DEFDIR+1
DEFTYP==DEFNAM+1
DEFSTR==DEFTYP+1
;Parse only GTJFN doesn't quite work on Tenex
;So, if we get no such device or no such directory, flush that all together and
;hope the system defaults help.
IFN 10X,[
CPLFIX: MOVEI BYTE,215
DPB BYTE,BP ;Put back old end of line
MOVE BP,3 ;Get old byte pointer
MOVE BC,4
CPLFX1: SOJL BC,CPLFX2
ILDB BYTE,BP
JUMPN BYTE,CPLFX3
CPLFX2: PUSHJ P,JSYSER ;End and no special character
CPLFX3: CAIN BYTE,^V
JRST [ IBP BP
SOJA BC,CPLFX1]
CAIE BYTE,(1) ;One we want
JRST CPLFX1
]
CPLFNM:
IFN 10X,MOVE 3,BP ;Save current byte pointer
.ALSO MOVE 4,BC
TLO D,ST.PON
PUSHJ P,COMGJF ;Get JFN for default
IFE 10X, PUSHJ P,JSYSER
.ELSE [ JRST [ CAIN 1,GJFX16 ;No such device
JRST [ MOVEI 1,":
JRST CPLFIX]
CAIN 1,GJFX17 ;No such directory <
JRST [ MOVEI 1,">
JRST CPLFIX]
IRPS STR,,[DEV DIR NAME TYP]
SETZM DEF!STR ;Forget the damned defaults
TERMIN
JRST CPLFN1]
];10X
MOVE 2,1 ;Setup for JFNS
MOVEI 1,DEFSTR ;Some string space
SETZ A,
MOVSI 3,100000 ;Device initially...
IRPS STR,,[DEV DIR NAM TYP]
MOVEI 1,1(1) ;Make sure pointing to fresh word...
HRLI 1,440700
MOVEM 1,DEF!STR ;Save pointer to this section.
JFNS
IDPB A,1
LSH 3,-3 ;Shift down file-part field...
TERMIN
HRROI 1,1(1)
PUSH P,1
MOVSI 3,000010 ;Generation field...
JFNS
POP P,1
HRLI 1,440700
ILDB 1,1
CAIN 1,"*
TLO D,ST.DIR ;Remember if should have wild default
MOVE 1,2
RLJFN ;Done with this JFN
JFCL
CPLFN1: SETZM GTJBLK
MOVE A,[GTJBLK,,GTJBLK+1]
BLT A,GTJBLK+.GJBFP ;Clear out long call GTJFN block
MOVEM BP,DEFSTR ;Save user's string
PUSHJ P,COMEUS ;Find end of it
JRST [TRZN F,F.NWL ;Must be terminated with a newline
JRST COMBAD
JRST .+2]
JRST .-2 ;Terminated by space, so keep searching
MOVEI 1,33 ;Put in escape to get completion
DPB 1,BP
SETZ 1,
IDPB 1,BP
;;; Now have defaults and user's string. If this is an input file, the idea is to
;;; keep trying GTJFN without allowing new files and various default conditions
;;; until we manage to win.
TLNN D,ST.OUT
SKIPA C,[-NCPLMT,,CPLMTH] ;Completion method routines
HRROI C,CPLOUT ;Completion for output
TLNN D,ST.NOK ;New file ok?
ADD C,[1,,0] ;No, skip last method
;;; Here to try next method
CPLLUP:.GJTYP==.GJEXT ;Nothing is consistent
IRPS STR,,[DEV DIR NAM TYP]
MOVE 1,DEF!STR
MOVEM 1,GTJBLK+.GJ!STR
TERMIN
MOVE 1,[.NULIO,,.NULIO]
MOVEM 1,GTJBLK+.GJSRC
MOVEI 1,2 ;Two extra words
MOVEM 1,GTJBLK+.GJF2
HRROI 1,JFNSTR
MOVEM 1,GTJBLK+.GJCPP
MOVEI 1,30.*5
MOVEM 1,GTJBLK+.GJCPC
MOVSI 1,(GJ%OLD\GJ%FLG\GJ%XTN)
TLNE D,ST.DEL
TLO 1,(GJ%DEL)
TLNE D,ST.DIR
IOR 1,[GJ%IFG+.GJALL]
XCT (C)
MOVEM 1,GTJBLK+.GJGEN
MOVEI 1,GTJBLK
MOVE 2,DEFSTR
GTJFN
JRST CPLNXT ;Failed, try next method
MOVE 3,[111110,,JS%PAF] ;Device, directory, filename, file type, version
;;; Now, if the user didn't really type the generation number, don't give it back
SKIPL GTJBLK+.GJGEN ;GJ%FOU supplied?
JRST [ TLNE 1,(GJ%UHV) ;No, highest existing = 0
JRST .+2
JRST .+3]
TLNE 1,(GJ%NHV) ;Yes, next higher = 0
TLZ 3,(JS%GEN)
MOVE 2,1 ;Jfn
HRROI 1,JFNSTR
JFNS
MOVE 1,2
RLJFN
JFCL
MOVEI A,[ASCIZ \OLD\]
MOVSI 1,(GJ%OLD)
TDNN 1,GTJBLK+.GJGEN
MOVEI A,[ASCIZ \NEW\]
JRST CPLDON
CPLNXT: AOBJN C,CPLLUP ;Keep trying and finally return typescript as is
LDB 1,GTJBLK+.GJCPP
SETZ 2,
CAIN 1,33 ;Clear altmode from user's typescript
DPB 2,GTJBLK+.GJCPP
MOVEI A,[ASCIZ \NIL\]
CPLDON: PUSH P,A
MOVEI A,[ASCIZ \COMPLETE \]
PUSHJ P,COMCTL
POP P,A
PUSHJ P,COMSTO
MOVEI BYTE,215
PUSHJ P,COMCHO
MOVEI A,JFNSTR
PUSHJ P,COMSTO
MOVEI BYTE,215
PUSHJ P,COMCHO
PUSHJ P,COMSND
JRST CTLLOP
CPLMTH: JFCL
SETZM GTJBLK+.GJEXT
SETZM GTJBLK+.GJNAM
PUSHJ P,CPLNBT
TLZ 1,(GJ%OLD)
NCPLMT==.-CPLMTH
CPLOUT: TLC 1,(GJ%FOU\GJ%OLD\GJ%NEW)
CPLNBT: SETZM GTJBLK+.GJNAM
SETZM GTJBLK+.GJEXT
POPJ P,
];END OF COMPLETION COMMAND FOR TNX
IFN ITS,[
;;; ITS COMPLETION COMMAND
CPLFNM: MOVEI IDX,MAXIDX ;Use probe variables for filename parsing etc.
HLLM D,DATSTA(IDX) ;Save status bits
SETZM DATSNM(IDX)
SETZM DATFN2(IDX)
PUSHJ P,COMPFN ;Parse the filename spec for the default
IRPS SYL,,[SNM FN1 FN2]
MOVE TT,DAT!SYL(IDX) ;Save the defaults
MOVEM TT,DEF!SYL'
TERMIN
SETZM DATSNM(IDX)
SETZM DATFN2(IDX)
PUSHJ P,COMPFN ;Parse the user's string
PUSHJ P,LCKDIR ;Get DIRLCK
;; First, find the directory
SKIPN A,DATSNM(IDX) ;Start from any specified directory
MOVE A,DEFSNM ;None, start from default
SKIPN A
MOVE A,HSNAME ;If no default, use default default: user's homedir
PUSHJ P,GETUFD ;Read in the directory
CAIA
JRST CPLFN3
;; Directory doesn't exist, try completion on it
PUSHJ P,GETMFD ;Read in the MFD
JRST CPLFN9 ;Can't do much without any dirs
PUSHJ P,CMPLT0
SKIPA D,MFDBUF+MDNAMP
CPLFN1: ADDI D,LMNBLK
CAIL D,2000
JRST CPLFN2
MOVE A,MFDBUF(D)
PUSHJ P,CMPLT1
JRST CPLFN1
CPLFN2: MOVE A,CMPLTW ;Result of directory completion
MOVEM A,DATSNM(IDX) ;Return it whether or not directory exists
PUSHJ P,GETUFD
JRST CPLFN9 ;Directory doesn't exist, stop now
CPLFN3: MOVEM A,DATSNM(IDX)
;; Now scan the directory. First we plug in the defaults and complete.
;; If that yields an existent file, or this is for output, take that as
;; the result. Otherwise complete without plugging in the defaults.
;; If that yields an existent file, take it. Otherwise take the results
;; of plugging in the defaults and completing if new-file is okay.
;; We don't distinguish defaulting FN1 and defaulting FN2.
SKIPN A,DATFN1(IDX)
MOVE A,DEFFN1
SKIPN B,DATFN2(IDX)
JRST [ MOVE B,DEFFN2 ;Note, never take ">" from the defaults
CAMN B,[SIXBIT/>/]
SETZ B,
JRST .+1 ]
PUSHJ P,CPLDIR
JRST [ MOVSI T,ST.OUT ;No existent file, doing output?
TDNN T,DATSTA(IDX)
JRST CPLFN4 ;No, try without defaults
JRST CPLFN7 ] ;Matches non-existent file
JRST CPLFN7 ;Matches possibly-existent file
CPLFN4: PUSH P,A ;Save results of completion with default
PUSH P,B
MOVE A,DATFN1(IDX) ;Try again without defaults
MOVE B,DATFN2(IDX)
PUSHJ P,CPLDIR
JRST [ MOVSI T,ST.NOK ;That didn't work either, new file okay?
TDNN T,DATSTA(IDX)
JRST CPLFN9 ;No, no completions found
POP P,B ;Yes, take the completion-with-defaults
POP P,A
JRST .+2 ]
SUB P,[2,,2]
; A and B now have the result of the completion. Determine NEW/OLD status.
CPLFN7: MOVEM A,DATFN1(IDX)
MOVEM B,DATFN2(IDX)
SKIPA D,DIRBUF+UDNAMP ;See if completed file really exists
CPLF7A: ADDI D,LUNBLK
CAIL D,2000
JRST CPLF7B
CAME A,DIRBUF+UNFN1(D)
JRST CPLF7A
CAMN B,DIRBUF+UNFN2(D)
JRST CPLF7C
JUMPE B,CPLF7C ;The file exists
CAME B,[SIXBIT/>/]
CAMN B,[SIXBIT/</]
JRST CPLF7C
JRST CPLF7A
CPLF7B: SKIPA A,[[ASCIZ/NEW/]]
CPLF7C: MOVEI A,[ASCIZ/OLD/]
JRST CPLDON
;Failure return
CPLFN9: MOVEI A,[ASCIZ/NIL/]
CPLDON: PUSH P,A
MOVEI T,MFDBUF/2000
PUSHJ P,PAGDAL
MOVEI T,DIRBUF/2000
PUSHJ P,PAGDAL
SETZM DIRLCK
MOVEI A,[ASCIZ \COMPLETE \]
PUSHJ P,COMCTL
POP P,A
PUSHJ P,COMSTO
MOVEI BYTE,215
PUSHJ P,COMCHO
PUSHJ P,COMRF1 ;Read back completed file name (sans host)
MOVEI BYTE,215
PUSHJ P,COMCHO
PUSHJ P,COMSND
JRST CTLLOP
;Complete A and B against the directory in DIRBUF, return results in A and B
;Skip-return if any completions found
;Note that cannot complete FO BA to FOO BAR if FORD 1 also exists, i.e.
;it completes the two filenames separately. Hopefully this is all right,
;although the Lisp machine completing reader is smarter.
;No attempt to do binary search although system has sorted the dir.
CPLDIR: PUSHJ P,CMPLT0 ;Start completing FN1
SKIPA D,DIRBUF+UDNAMP
CPLDR1: ADDI D,LUNBLK
CAIL D,2000
JRST CPLDR2
MOVE A,DIRBUF+UNFN1(D)
PUSHJ P,CMPLT1
JRST CPLDR1
CPLDR2: MOVE C,CMPLTW ;Completed FN1
SKIPGE CMPLTF ;Any completions found?
JRST CPLDR5 ;Nope
CAME B,[SIXBIT/>/] ;FN2 of < or > always matches
CAMN B,[SIXBIT/</]
JRST CPLDR5
MOVE A,B ;Start completing FN2 against files with that FN1
PUSHJ P,CMPLT0
SKIPA D,DIRBUF+UDNAMP
CPLDR3: ADDI D,LUNBLK
CAIL D,2000
JRST CPLDR4
MOVE A,DIRBUF+UNFN2(D)
CAMN C,DIRBUF+UNFN1(D)
PUSHJ P,CMPLT1
JRST CPLDR3
CPLDR4: JUMPN B,CPLDR6 ;When completing a blank FN2, special hair
SKIPE CMPLTF ;Exactly one match?
JRST CPLDR5 ;No, result remains blank (i.e. ">")
MOVE B,CMPLTW ;Yes, is it all numeric?
CPLDR7: MOVEI A,0 ;If so, we won't count it since it's a version not a type
LSHC A,6
CAIL A,'0
CAILE A,'9
JRST CPLDR6 ;Blank FN2 matches a single filetype
JUMPN B,CPLDR7
TDZA B,B ;Result remains blank
CPLDR6: MOVE B,CMPLTW ;Completed FN2
CPLDR5: MOVE A,C ;Completed FN1
SKIPL CMPLTF ;Any completions found?
AOS (P) ;Yes, take skip return
POPJ P,
CMPLTA==CLODAT ;Trying to keep the impure down to one page
CMPLTM==CLOLEN
;;; Completion of sixbit words
;;; Set up to complete the word in A
;;; After calling this, call CMPLT1 any number of times then pick
;;; up your result out of CMPLTW, which is either the original argument
;;; (in which case CMPLTF is negative), or else is the shortest existent
;;; extension of that.
CMPLT0: MOVEM A,CMPLTA ;Word to match
SETO T,
TDNE A,T
JRST [ LSH T,-6
JRST .-1 ]
SETCAM T,CMPLTM ;Mask for fixed characters
SETOM CMPLTF' ;No completions found yet
MOVEM A,CMPLTW' ;Word found so far (result of completion)
SETCAM T,CMPLTX' ;Mask for valid characters in that
POPJ P,
;;; Use the sixbit in A as a possible completion.
CMPLT1: MOVE TT,A
XOR TT,CMPLTA
TDNE TT,CMPLTM ;Does it match the fixed characters?
POPJ P, ;No.
AOSE CMPLTF ;First completion found?
JRST CMPLT2 ;No
MOVEM A,CMPLTW ;Yes, save as result
SETO T, ;and compute its length
TDNE A,T
JRST [ LSH T,-6
JRST .-1 ]
SETCAM T,CMPLTX
POPJ P,
CMPLT2: MOVE TT,A ;Two completions, take their common prefix
XOR TT,CMPLTW
MOVE T,CMPLTX
TDNE TT,T
JRST [ LSH T,6
JRST .-1 ]
MOVEM T,CMPLTX
ANDM T,CMPLTW
POPJ P,
];ITS
;;; Property changing command
COMCNG: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
TRZN F,F.NWL ;Should be newline
JRST COMBAD
TRNN F,F.FHN ;Use an open file?
JRST CNGFIL ;Nope, need a filename
PUSHJ P,CNGLOP
PUSHJ P,FILERR ;Failed
JRST CNGDN1
CNGFIL: MOVEI IDX,MAXIDX ;Use dummy IDX
IFN ITS,[
PUSHJ P,COMPFN
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBIT,,.UAI
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR
]
IFN TNX,[
MOVSI D,ST.DEL
PUSHJ P,COMGJF
PUSHJ P,JSYSER
MOVEM 1,DATJFN(IDX) ;Save jfn
]
PUSHJ P,CNGLOP
CAIA
JRST CNGDON
IFN ITS,[
.CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL
];ITS
IFN TNX,PUSHJ P,RELDJ1 ;Failed, release file
PUSHJ P,FILERR
;;; Done changing things, close the file, etc.
CNGDON:
IFN ITS,[
.CALL [ SETZ
SIXBIT /CLOSE/
%CLIN+%CLEND,,DATCHN(IDX)]
JFCL
];ITS
IFN TNX,PUSHJ P,RELDJ1
CNGDN1: MOVEI A,[ASCIZ \CHANGE-PROPERTIES\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP
CNGLOP: JUMPLE BC,POPJ1 ;Done when end or just blank line
TRZ F,F.NWL
PUSHJ P,COMR10 ;Get property name
JRST COMBAD
CNGOLP: MOVEI C,CNGLEN
CNGOL1: SOJL C,[CERR UKP,[Unknown property]]
CAMN A,CNGTAB-1(C)
CAME B,CNGTAB(C)
SOJA C,CNGOL1
HRRZ T,CNGACT(C) ;Get routine
PUSHJ P,(T)
IFN 20X,[
SKIPL CNGACT(C) ;If sign (flag) bit on, then we want
JRST CNGLOP ;to do something else besides this
HRRZ T,CNGALT(C) ;operation, so look in the parallel
PUSHJ P,(T) ;table for de poop.
];20X
JRST CNGLOP
;;; NOTE: If you change this, be sure to update the list of settable properties at
;;; the start of DIRHED.
CNGTAB:
IFN 20X+ITS, ASCII \DONT-REAP\ ;DONT-REAP
ASCII \NOT-BACKED\ ;NOT-BACKED-UP
ASCII \AUTHOR\ ;AUTHOR
ASCII \CREATION-D\ ;CREATION-DATE
ASCII \REFERENCE-\ ;REFERENCE-DATE
IFN TNX,[
ASCII \BYTE-SIZE\ ;BYTE-SIZE
ASCII \LENGTH-IN-\ ;LENGTH-IN-BYTES
ASCII \PROTECTION\ ;PROTECTION
ASCII \GENERATION\ ;GENERATION-RETENTION-COUNT
ASCII \ACCOUNT\ ;ACCOUNT
ASCII \TEMPORARY\ ;TEMPORARY
ASCII \DELETED\ ;DELETED
ASCII \DONT-DELET\ ;DONT-DELETE
]
CNGLEN==.-CNGTAB
IFN ITS,[
CNGACT: SIXBIT /SREAPB/ ? -1,,CNGBIT ;DONT-REAP
SIXBIT /SDMPBT/ ? 0,,CNGBIT ;NOT-BACKED-UP
SIXBIT /SAUTH/ ? CNGAUT ;AUTHOR
SIXBIT /SFDATE/ ? CNGDAT ;CREATION-DATE
SIXBIT /SRDATE/ ? CNGDAT ;REFERENCE-DATE
CNGBIT: HLRE A,CNGACT(C)
PUSH P,A ;Get sense of boolean
PUSHJ P,COMRD5
JFCL
CAMN A,[ASCII /NIL/]
SETCMM (P)
POP P,A
;; Perfor system call for this routine, argument in A
CNGCAL: MOVE B,CNGACT-1(C)
.CALL [ SETZ
SIXBIT /CALL/
%CLERR,,ERRCOD
%CLIN,,B
%CLIN,,DATCHN(IDX)
%CLIN+%CLEND,,A]
JRST CNGERR
POPJ P,
CNGAUT: PUSHJ P,COMSXI ;Read sixbit author name
JRST CNGCAL
CNGDAT: PUSHJ P,COMDTI ;Read a date
JRST CNGCAL
] ;END IFN ITS
IFN TNX,[
CNGACT:
IFN 20X,-1 ? .ARNAR,,CNGABT ;DONT-REAP
-1 ? .FBBK0,,CNGBIT ;NOT-BACKED-UP
SFUST ? 400000\.SFLWR,,CNGSTR ;AUTHOR (Sign bit means dualistic)
-1 ? 400000\.FBWRT,,CNGDAT ;CREATION-DATE
-1 ? .FBREF,,CNGDAT ;REFERENCE-DATE
FB%BSZ ? .FBBYV,,CNGDEC ;BYTE-SIZE
-1 ? .FBSIZ,,CNGDEC ;LENGTH-IN-BYTES
IFN 20X,[77,,-1] .ELSE [0,,-1] ? .FBPRT,,CNGOCT ;PROTECTION
FB%RET ? .FBBYV,,CNGDEC ;GENERATION-RETENTION-COUNT
SACTF ? CNGSTR ;ACCOUNT
FB%TMP ? .FBCTL,,CNGBIT ;TEMPORARY
FB%DEL ? .FBCTL,,CNGBIT ;DELETED
IFDEF FB%NDL,FB%NDL ; Twenex release 5 has new name and value
.ELSE [
IFDEF FB%UND,FB%UND
.ELSE FB%PRM
]
.FBCTL,,CNGBIT ;DONT-DELETE
IFN 20X,[
CNGALT: 0 ? 0
0 ? 0
SFUST ? .SFAUT,,CNGST1 ;real 20X AUTHOR
-1 ? .FBCRV,,CNGDA1 ;real 20x CREATION-DATE
;there had better not be any more sign bits!
];20X
CNGBIT: PUSHJ P,COMRD5
CAMN A,[ASCII \NIL\]
TDZA A,A
SETO A,
CNGFDB: HRRZ 1,DATJFN(IDX)
HLL 1,CNGACT(C)
TLZ 1,400000 ;Remove that flag bit.
MOVE 2,CNGACT-1(C) ;Mask
MOVE 3,A ;New value
IFN 20X,PUSHJ P,TRYCON
CHFDB
ERJMP CNGERR
POPJ P,
IFN 20X,[
CNGABT: PUSHJ P,COMRD5 ;Modify archival information via ARCF
CAMN A,[ASCII \NIL\]
SKIPA 3,[.ARCLR]
MOVEI 3,.ARSET
HRRZ 1,DATJFN(IDX)
HLRZ 2,CNGACT(C)
ARCF
ERJMP CNGERR
POPJ P,
];20X
CNGDAT: PUSHJ P,COMDTI
JRST CNGFDB
IFN 20X,[
CNGDA1: HRRZ 1,DATJFN(IDX)
HLL 1,CNGALT(C)
MOVE 2,CNGALT-1(C) ;Mask
MOVE 3,A ;Old value (had better still be there)
PUSHJ P,TRYCON
CHFDB
ERJMP .+1 ;OK if we fail.
POPJ P,
];20X
CNGDEC: PUSHJ P,COMDCI
JRST CNGRFD
CNGOCT: PUSHJ P,COMOCI
;;Here if right justified
CNGRFD: MOVE T,CNGACT-1(C) ;Mask
JFFO T,.+1
SETCM T,CNGACT-1(C)
LSH T,(TT)
MOVNS TT
LSH T,(TT)
JFFO T,.+2
JRST CNGFDB ;No shifting necessary
MOVEI T,36.
SUBI T,(TT)
LSH A,(T)
JRST CNGFDB
CNGSTR: MOVE 2,BP
MOVEM 2,SAVEBP
PUSHJ P,COMEUS ;Find end
SKIPA
JRST .-2 ;Terminated by space, so keep searching
SETZ 1,
DPB 1,BP ;Insure terminating NULL
HRRZ 1,DATJFN(IDX)
HLL 1,CNGACT(C)
TLZ 1,400000 ;Make sure that flag bit is off...
XCT CNGACT-1(C)
ERJMP CNGERR
POPJ P,
IFN 20X,[
CNGST1: HRRZ 1,DATJFN(IDX)
HLL 1,CNGALT(C)
MOVE 2,SAVEBP
XCT CNGALT-1(C)
ERJMP .+1 ;OK if we fail...
POPJ P,
];20X
];END IFN TNX
;;; Error, take error return from CNGLOP
CNGERR: SUB P,[1,,1] ;Flush return to CNGLOP
POPJ P,
;;; Expunge directory command
COMEXP: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
SETZ D, ;Clear options here
MOVEI IDX,MAXIDX ;Use the temporary channel for this
EXPOPT: TRNE F,F.NWL ;End of options?
JRST EXPFNM
PUSHJ P,COMRD5 ;Get token
JUMPL BC,COMBAD
IFN ITS,CERR UUO,[Unknown EXPUNGE option]
IFN TNX,[
EXPOLP: MOVEI T,EXPLEN-1
EXPOL1: CAME A,EXPTAB(T)
SOJGE T,EXPOL1
JUMPL T,[CERR UUO,[Unknown EXPUNGE option]]
XCT EXPACT(T)
JRST COMBAD
JRST EXPOPT
EXPTAB: ASCII \TEMPO\ ;TEMPORARY
EXPLEN==.-EXPTAB
EXPACT: SKIPA
EXPFNM: TLO D,ST.ALD ;Allow wildcards
PUSHJ P,PRSDIR ;Return JFN in 1, directory number in 3
PUSHJ P,JSYSER
RLJFN ;Don't need that JFN anymore.
JFCL
PUSH P,[0] ;Initial sum of freed pages.
EXPFN0: MOVEM 3,WILDIR
MOVE 1,3 ;Directory#
GTDAL
ERCAL JSYSER
PUSH P,2 ;Returns allocated pages in AC2
IFN 10X,[
HRRZ 1,WILDIR ;Directory number
DELDF ;Expunge (never skips, and blows it on ERCAL)
];10X
IFN 20X,[
SETZ 1,
MOVE 2,WILDIR
DELDF ;Expunge.
ERCAL JSYSER
];20X
MOVE 1,WILDIR
GTDAL ;Get new allocation
ERCAL JSYSER
POP P,1 ;Old allocation
SUB 1,2 ;1/ pages freed
ADDM 1,(P) ;Accumulate.
IFN 20X,[
MOVSI 1,(RC%STP\RC%AWL) ;Step to next directory
HRROI 2,RESBLK ;Pointer to directory string
MOVE 3,WILDIR ;Old dir#
RCDIR
ERCAL JSYSER
TLNN 1,(RC%NMD\RC%NOM) ;No More Directories?
JRST EXPFN0 ; Yes more, so go do next.
];20X
];TNX
IFN ITS,[ ;Always returns success
EXPFNM: PUSHJ P,COMPFN ;PARSE THE FILENAME
PUSH P,[0] ;No space is ever reclaimed
];ITS
MOVEI A,[ASCIZ \EXPUNGE \]
PUSHJ P,COMCTL
POP P,A
PUSHJ P,COMDCO
MOVEI BYTE,215 ;<freed pages>NL<directory expunged>NL
PUSHJ P,COMCHO
IFN TNX,PUSHJ P,COMRES
IFN ITS,[
MOVE A,DATSNM(IDX)
PUSHJ P,COMSXO
MOVEI BYTE,";
PUSHJ P,COMCHO
];ITS
MOVEI BYTE,215
PUSHJ P,COMCHO
PUSHJ P,COMSND
JRST CTLLOP
IFN TNX,[
;Return JFN in 1, directory number in 3 (skip on success)
;Allows wildcard directories on Tops-20 if ST.ALD is set
;Failure takes non-skip return with error code in 1, or blows out
PRSDIR: TLO D,ST.PON ;Parse only: don't care if there are no files in dir
PUSHJ P,COMGDJ ;Get JFN
POPJ P,
PUSH P,1 ;Save JFN
HRROI 1,RESBLK
MOVE 2,(P)
IFN 10X,MOVSI 3,(JS%DIR) ;Tenex wants directory with no delimiters
.ELSE MOVE 3,[110000,,JS%PAF] ;Just want device and directory
JFNS
ERCAL SYSBUG
HRRZS (P) ;Kill flags in LH(JFN)
IFN 20X,[
MOVSI 1,(RC%AWL) ;Recognize directory, allowing wildcards
TLNN D,ST.ALD
MOVSI 1,(RC%EMO)
];20X
IFN 10X,MOVSI 1,(RC%EMO) ;Tenex's RC%AWL is too slow, even when no wildcards present
HRROI 2,RESBLK
RCDIR ;Get dir# (initial if wildcard)
ERJMP PRSDI2 ;Syntax error
TLNE 1,(RC%NOM)
JRST PRSDI1
POP P,1
JRST POPJ1
PRSDI1: MOVEI 1,.FHSLF ;Fake error return from RCDIR
MOVEI 2,GJFX17
SETER
PRSDI2: MOVEI 1,.FHSLF ;Get last error
PUSHJ P,$GETER
MOVEI 2,GJFX17 ;If no error code, use No Such Directory
POP P,1 ;Release the parse-only JFN
RLJFN
JFCL
HRRZ 1,2 ;Return just error number
POPJ P,
];TNX
IFN TNX,[
;;; Enable your capabilities.
COMENA: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
SETZ D, ;Mask of priv bits.
COMEN1: JUMPLE BC,DOENA ;Jump if no options left
PUSHJ P,COMRD5
JFCL
MOVEI T,ENALEN-1 ;Number of ENABLE options
COMEN2: CAME A,ENATAB(T) ;Match?
SOJGE T,COMEN2 ; No, keep checking.
JUMPL T,[CERR UUO,[Unknown ENABLE/DISABLE option]]
XCT ENAACT(T)
JRST COMEN1
ENATAB: ASCII /ALL/
ASCII /OPERA/
ASCII /WHEEL/
ENALEN==.-ENATAB
ENAACT: SETO D,
TRO D,SC%OPR
TRO D,SC%WHL
DOENA: MOVEI 1,.FHSLF
RPCAP ;Get your capabilities.
IOR 3,D ;Turn on requested bits.
EPCAP
MOVEI A,[ASCIZ /ENABLE-CAPABILITIES/]
DOEN1: PUSHJ P,COMCTL
MOVEI 1,.FHSLF
RPCAP ;Possible in 2, enabled in 3.
MOVSI T,-NPRIVS ;Return state of your priviledges.
DOEN2: HRRZ TT,PRVTAB(T)
TRNN 2,(TT)
JRST DOEN3 ; You don't have this priv.
MOVEI BYTE,40
PUSHJ P,COMCHO
HLRZ A,PRVTAB(T)
PUSHJ P,COMSTO ;You do, so send the name and then T if
MOVEI BYTE,40 ;it's on, else NIL.
PUSHJ P,COMCHO
MOVEI A,[ASCIZ /NIL/] ;This priv is disabled...
TRNE 3,(TT)
MOVEI A,[ASCIZ /T/] ;(and this is is enabled)
PUSHJ P,COMSTO
DOEN3: AOBJN T,DOEN2
MOVEI BYTE,215
PUSHJ P,COMCHO
PUSHJ P,COMSND
JRST CTLLOP
PRVTAB: [ASCIZ /WHEEL/],,SC%WHL ;Privs whose status we
[ASCIZ /OPERATOR/],,SC%OPR ;will return
[ASCIZ /CONFIDENTIAL-INFORMATION-ACCESS/],,SC%CNF
[ASCIZ /MAINTENANCE/],,SC%MNT
[ASCIZ /IPCF/],,SC%IPC
[ASCIZ /ENQ-DEQ/],,SC%ENQ
[ASCIZ /ARPANET-WIZARD/],,SC%NWZ
[ASCIZ /ABSOLUTE-ARPANET-SOCKETS/],,SC%NAS
NPRIVS==.-PRVTAB
COMDIS: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
MOVEI 1,.FHSLF
RPCAP
MOVE D,3 ;What you have on now.
COMDI1: JUMPLE BC,DODIS ;Jump if no options left
PUSHJ P,COMRD5
JFCL
MOVEI T,ENALEN-1
COMDI2: CAME A,ENATAB(T)
SOJGE T,COMDI2 ; No, keep checking.
JUMPL T,[CERR UUO,[Unknown ENABLE/DISABLE option]]
XCT DISACT(T)
JRST COMDI1
DISACT: TRZ D,SC%WHL+SC%OPR
TRZ D,SC%WHL
TRZ D,SC%OPR
DODIS: MOVEI 1,.FHSLF
RPCAP
MOVE 3,D
EPCAP
MOVEI A,[ASCIZ /DISABLE-CAPABILITIES/]
JRST DOEN1
];TNX (ENABLE AND DISABLE COMMANDS)
;;; Connect/access directory commands
IFN 20X,[
COMCWD: PUSH P,[[ASCIZ/CWD/]]
PUSH P,[AC%CON] ;Just want to connect
JRST .+3
COMACD: PUSH P,[[ASCIZ/ACCESS/]]
PUSH P,[AC%OWN] ;Want ownership access to a directory
];20X
IFN 10X,COMCWD:
IFN TNX,[
SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
JUMPLE BC,CWDIRF ;No good
MOVE 2,BP ;Save byte ref copy
PUSHJ P,COMEUS ;Eat till end of line, hopefully
JUMPL BC,CWDIRF ;Should be a password following
SETZ T, ;Tie it off
DPB T,BP
MOVE 3,2 ;Get start of fellow
ILDB 3,3 ;See if null
JUMPE 3,[GJINF ;Sure enough, get user number into 1
MOVE 2,1 ;Do an RCDIR on that
JRST .+1]
MOVSI 1,(RC%EMO) ;See if it exists
RCDIR
ERCAL JSYSER
TLNE 1,(RC%NOM) ;Did it?
CERR DNF,[No such directory]
MOVEM 3,RESBLK+.ACDIR ;Save directory number
MOVEM BP,RESBLK+.ACPSW ; and password start
MOVE 3,BP ;See if password is null
ILDB 3,3
SKIPN 3
SETZM RESBLK+.ACPSW ;Don't include a pointer if null password
SETOM RESBLK+.ACJOB ;-1 means current job
PUSHJ P,COMEUS ;Scan until end of password
SETZ T, ; and tie it off as usual
DPB T,BP
IFN 20X,[
POP P,1 ;Get back connect/access code
HRRI 1,3 ;3 elements
MOVEI 2,RESBLK ; here
ACCES
];20X
IFN 10X,[
HRRZ 1,RESBLK+.ACDIR ;Directory number and no options
MOVE 2,RESBLK+.ACPSW ;String pointer to password
CNDIR
];10X
ERCAL JSYSER ;Give an error return here
IFN 20X,POP P,A ;Name of command for success reply
IFN 10X,MOVEI A,[ASCIZ \CWD\]
PUSHJ P,COMCTL
MOVEI BYTE,215 ;ACCESS<NL>directory name
PUSHJ P,COMCHO
HRROI 1,RESBLK ;Build full directory specification
MOVE 2,RESBLK+.ACDIR ;Get directory number
DIRST
JFCL ;Ignore errors
PUSHJ P,COMRES ;Send the directory spec
PUSHJ P,COMSND
JRST CTLLOP ;All done
CWDIRF: CERR BUG,[Illegal request format (no directory name)]
];END IFN TNX
;;; Create directory
COMCRD: SKIPN USERID
IFN OZ, PUSHJ P,AUTLOG
.ELSE CERR NLI,[Not logged in]
IFN TNX,[
IFN 10X,[
MOVE T,[-777,,1] ;MUST FIND A FREE DIRECTORY SLOT
CRDFND: HRROI 1,JFNSTR
HRRZ 2,T
DIRST
SKIPA
AOBJN T,CRDFND
JUMPGE T,[CERR CCD,[No free directory slots]]
HRRZM T,CRDBLK+.CDNUM
MOVSI 2,(CD%NUM)
];IFN 10X
.ELSE SETZ 2, ;DEFAULT OPTIONS
SETZM CRDBLK+.CDMOD ;JUST IN CASE
CRDOPT: TRNE F,F.NWL ;NEW LINE TERMINATED OPEN COMMAND?
JRST CRDNAM
PUSHJ P,COMRD5 ;GET NEXT TOKEN
JUMPL BC,COMBAD
CRDOLP: MOVEI T,CRDLEN-1 ;LENGTH OF OPTION TABLE
CRDOL1: CAME A,CRDTAB(T) ;MATCH?
SOJGE T,CRDOL1 ;NOPE, KEEP ON
JUMPL T,[CERR UUO,[Unknown CREATE-DIRECTORY option]]
ASH T,1
MOVE TT,CRDACT(T) ;GET BIT TO SET
IOR 2,TT
XCT CRDACT+1(T) ;CALL PARSER
JRST COMBAD ;PARSING ERROR
MOVEM A,CRDBLK(TT) ;STICK INTO PARAMETER BLOCK
JRST CRDOPT
CRDTAB: ASCII \PASSW\
ASCII \WORKI\
ASCII \CAPAB\
ASCII \FILES\
ASCII \REPEA\
ASCII \PERMA\
ASCII \FILE-\
ASCII \PROTE\
ASCII \GENER\
ASCII \USER-\
ASCII \DIREC\
ASCII \SUBDI\
ASCII \ACCOU\
CRDLEN==.-CRDOPT
CRDACT: CD%PSW+.CDPSW ? PUSHJ P,CRDPSW
CD%LIQ+.CDLIQ ? PUSHJ P,CRDLIQ
CD%PRV+.CDPRV ? PUSHJ P,CRDPRV
CD%MOD+.CDMOD ? PUSHJ P,CRDDIR
CD%MOD+.CDMOD ? PUSHJ P,CRDRLM
CD%LOQ+.CDLOQ ? PUSHJ P,CRDLOQ
CD%FPT+.CDFPT ? PUSHJ P,CRDFPT
CD%DPT+.CDDPT ? PUSHJ P,CRDDPT
CD%RET+.CDRET ? PUSHJ P,CRDRET
CD%UGP+.CDUGP ? PUSHJ P,CRDUGP
CD%DGP+.CDDGP ? PUSHJ P,CRDDGP
CD%SDQ+.CDSDQ ? PUSHJ P,CRDSDQ
CD%DAC+.CDDAC ? PUSHJ P,CRDDAC
CRDPSW:
CRDDAC: MOVE A,BP
PUSHJ P,COMEUS
JFCL
SETZ B,
DPB B,BP
JRST POPJ1
CRDLIQ: CRDLOQ: CRDRET:
CRDSDQ: PUSHJ P,COMDCI
JRST POPJ1
CRDPRV: PUSHJ P,COMOCI
JRST POPJ1
CRDDIR: MOVE A,CRDBLK+.CDMOD
TLO A,(CD%DIR)
JRST POPJ1
CRDRLM: MOVE A,CRDBLK+.CDMOD
TLO A,(CD%RLM)
JRST POPJ1
CRDFPT:
CRDDPT: PUSHJ P,COMOCI
HLL A,500000
JRST POPJ1
IFN 10X,[
CRDUGP:
CRDDGP: SETZ B,
CRDGRP: PUSHJ P,COMDCI
MOVEI C,1
LSH 1,(A)
IORI B,C
TRNN F,F.NWL
JRST CRDGRP
JRST POPJ1
];10X
.ELSE [
CRDUGP: SKIPA A,[JFNSTR]
CRDDGP: MOVEI A,JFNSTR+11.
PUSH P,A
MOVE B,A
HRLI B,-10.
CRDGRP: AOBJP B,[CERR BUG,[Too many directory groups]]
PUSHJ P,COMDCI
MOVEM A,(B)
TRNN F,F.NWL
JRST CRDGRP
POP P,A
SUBI B,-1(A)
HRRM B,(A)
JRST POPJ1
];NOT 10X
CRDNAM:
IFN 20X,[
MOVE 1,BP
PUSHJ P,COMEUS
];20X
.ELSE [
CRDNM1: SOJL BC,COMBAD
ILDB BYTE,BP
CAIE BYTE,"<
JRST CRDNM1
MOVE 1,BP
CRDNM2: SOJL BC,COMBAD
ILDB BYTE,BP
CAIE BYTE,">
JRST CRDNM2
];NOT 20X
SETZ T,
DPB T,BP
HRRI 2,CRDBLK
SETZ 3, ;NO PASSWORD
CRDIR
ERCAL JSYSER
];IFN TNX
IFN ITS,[
TRNN F,F.NWL ;MUST END IN NEWLINE
JRST COMBAD
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW+%CLIMM,,.UAI
%CLIMM,,UTILCH
%CLIN,,[SIXBIT /DSK/]
%CLIN,,[SIXBIT /.FILE./]
%CLIN,,[SIXBIT /(DIR)/]
%CLIN+%CLEND,,USERID]
JRST [ MOVEI A,%ENSDR
JRST CRDNM4 ]
.CLOSE UTILCH,
MOVEI IDX,MAXIDX ;Use the temporary channel for this
PUSHJ P,COMPFN ;PARSE THE FILENAME
.CALL [ SETZ
SIXBIT /OPEN/
%CLERR,,ERRCOD
%CLBTW+%CLIMM,,.UII
%CLIN,,DATCHN(IDX)
%CLIN,,DATDEV(IDX)
%CLIN,,[SIXBIT /..NEW./]
%CLIN,,[SIXBIT /(UDIR)/]
%CLIN+%CLEND,,DATSNM(IDX)]
SKIPA A,ERRCOD
MOVEI A,%ENSFL ;NO ERROR IF DIR ALREADY EXISTS
CAIE A,%ENSFL
CRDNM4: PUSHJ P,FILERR ;WRONG ERROR => CANNOT CREATE DIR
];IFN ITS
MOVEI A,[ASCIZ \CREATE-DIRECTORY\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP ;All done
IFN ITS,[
COMCRL: TRZN F,F.NWL ;Newline?
JRST COMBAD ;Nope, bad command format
MOVEI IDX,MAXIDX ;Use the temporary channel for this
PUSHJ P,COMPFN ;Parse the filename for the link
TRZN F,F.NWL ;Check for correct format
JRST COMBAD
PUSH P,DATDEV(IDX) ;Save link name
PUSH P,DATFN1(IDX)
PUSH P,DATFN2(IDX)
PUSH P,DATSNM(IDX)
MOVE T,BC ;Compensate for incompetently-defined protocol
IDIVI T,4 ;by appending NL to end of command
ADD T,BP
IBP T
SOJGE TT,.-1
MOVEI TT,215
DPB TT,T
AOS BC
PUSHJ P,COMPFN ;Parse the name to link to
TRZN F,F.NWL ;Check for correct format
JRST COMBAD
JUMPG BC,COMBAD
.CALL [ SETZ
SIXBIT /MLINK/
%CLERR,,ERRCOD ;Error code
%CLIN,,-3(P)
%CLIN,,-2(P)
%CLIN,,-1(P)
%CLIN,,0(P)
%CLIN,,DATFN1(IDX)
%CLIN,,DATFN2(IDX)
%CLIN+%CLEND,,DATSNM(IDX)]
PUSHJ P,FILERR ;File error, tell about it
SUB P,[4,,4]
MOVEI A,[ASCIZ \CREATE-LINK\]
PUSHJ P,COMCTL
PUSHJ P,COMSND
JRST CTLLOP
] ;END IFN ITS
;;; Core buffer allocator
BUFALO: MOVEI T,BUFBAS(IDX) ;Index
SETZM DATBPT(IDX) ;Pointer is zero, meaning virgin buffer
SETZM DATBCT(IDX) ;No room left in buffer
SETZM DATLWD(IDX) ;No last word
IFN ITS,PUSHJ P,PAGALO
LSH T,10. ;Make into address
IFN TNX,[
SETMM (T) ;Access page to create it
SETMM 1000(T) ;Both half-pages
] ;END IFN TNX
MOVEM T,DATBUF(IDX) ;Remember base of buffer
POPJ P,
IFN ITS,[
PAGALO: .CALL [ SETZ
SIXBIT /CORBLK/
%CLIMM,,%CBNDW+%CBNDR ;Write and read access
%CLIMM,,%JSELF ;Into own job
%CLIN,,T ;c(T) is page number
%CLIMM+%CLEND,,%JSNEW] ;Fresh page
CERR NER,[System virtual memory full]
POPJ P,
] ;END IFN ITS
;;; Core buffer deallocator
BUFDAL: MOVEI T,BUFBAS(IDX)
SETZM DATBPT(IDX)
SETZM DATBCT(IDX)
SETZM DATLWD(IDX) ;No last word
SETZM DATBUF(IDX)
IFN ITS,PUSHJ P,PAGDAL
IFN TNX,[
MOVNI 1,1 ;-1 means unmapping a page
MOVE 2,T ;Page number in right half
ADD 2,T ;in half-pages
HRLI 2,.FHSLF ;Process handle in left half
IFN 20X,[
MOVE 3,[SETZ 2] ;Remove 2 half-pages
PMAP
ERCAL CTLERR
];20X
IFN 10X,[
SETZ 3, ;Delete page
PMAP
ERCAL CTLERR
AOS T ;Other half page
PMAP
ERCAL CTLERR
];10X
] ;END IFN TNX
POPJ P,
IFN ITS,[
PAGDAL: .CALL [ SETZ
SIXBIT /CORBLK/
%CLIMM,,0 ;Delete page
%CLIMM,,%JSELF
%CLIN+%CLEND,,T]
.LOSE %LSSYS
POPJ P,
] ;END IFN ITS
;;; IOC error and asynchronous mark transmitters
;;; Both of these routines get called with all interrupts deffered and therefore can use a
;;; shared packet
;;; A contains DATSTA(IDX)
;;; This must be called so that a POPJ returns to "top level".
;;; c(D)+1 contains error code,,pointer to asciz string
;;; c(D)+2 has return address
ASYERR: PUSH P,PKTLOC ;Direct data to the async packet
MOVEI T,ASYPKT
MOVEM T,PKTLOC
HRRI A,ST%ASY ;Channel now in ASYNC-MARKED state
TLO A,ST.UNC ;But uncontinuable
MOVEM A,DATSTA(IDX)
TRO F,F.FHN ;Force outputting of a file handle
MOVEI A,[ASCIZ \ERROR \]
PUSHJ P,COMCTL ;This will output a transaction ID, which will be ignored
HLLZ A,1(D) ;Get error code
PUSHJ P,COMSXO
MOVEI BYTE,40
PUSHJ P,COMCHO
HRRZ A,1(D) ;Now output the error string
PUSHJ P,COMSTO
MOVEI T,CO%ASY
DPB T,[$CPKOP+ASYPKT]
DPB BC,[$CPKNB+ASYPKT]
IFN ITS,[
MOVEI T,CTRLO ;Perhaps have to send this over the control connection
TRNN IDX,1 ;Except if we are already sending data, use IDX's channel
MOVE T,CHACHN(IDX)
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,T
%CLIMM+%CLEND,,ASYPKT]
.LOSE %LSSYS
TRNN IDX,1 ;if more packets might come in, defer interrupts
JRST ASYRET
MOVE T,CHABIT(IDX) ;Defer interrupts on this channel until continued
IORM T,SSYDF2 ;Update saved copy of DF2
.SUSET [.SIDF2,,T]
] ;END IFN ITS
IFN TNX,[
MOVE 1,CTLJFN
TRNN IDX,1
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKS
MOVEI 3,ASYPKT
MTOPR
ERCAL CTLERR
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
DIC
] ;END IFN TNX
ASYRET: POP P,PKTLOC
MOVE A,DATSTA(IDX) ;Insure A stays set up correctly
JRST @2(D)
;;; c(D)+1 contains continuation address
ICCERR: PUSH P,PKTLOC ;Direct data to the async packet
MOVEI T,ASYPKT
MOVEM T,PKTLOC
HRRI A,ST%ASY ;Channel now in ASYNC-MARKED state
TLZ A,ST.UNC ;They are continuable
MOVEM A,DATSTA(IDX)
HRRZ T,1(D) ;Get continuation address
MOVEM T,DATICN(IDX) ;Remember in case user end asks us to go on
TRO F,F.FHN ;Force outputting of a file handle
MOVEI A,[ASCIZ \ERROR \]
PUSHJ P,COMCTL ;Start off error packet, open failed error code
IFN ITS,[
.CALL [ SETZ
'STATUS
%CLIN,,DATCHN(IDX)
%CLOUT+%CLEND,,C ]
.LOSE %LSSYS
HLRZ D,C ;Get just the IOC error
ANDI D,37000
PUSHJ P,ERR3 ;Get the 3-letter code
HLRZ D,C ;Put error code in standard place
];END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
PUSHJ P,$GETER ;Get last error that happened
PUSHJ P,CTLERR
HRRZM 2,D ;The number of the error
PUSHJ P,ERR3 ;Get the 3-letter code
];TNX
MOVSS A
PUSHJ P,COMSXO
MOVEI A,[ASCIZ \ R \] ;Recoverable error (probably)
PUSHJ P,COMSTO
PUSHJ P,ERRMSG ;Output the error message now
PUSHJ P,ICCERP ;Send packet
POP P,PKTLOC
SUB P,[1,,1] ;Flush the old return address
POPJ P, ;And return to "superior" of routine that had error
;;; Send IOC error packet
ICCERP: MOVEI T,CO%ASY
DPB T,[$CPKOP+ASYPKT]
DPB BC,[$CPKNB+ASYPKT]
IFN ITS,[
MOVEI T,CTRLO ;Perhaps have to send this over the control connection
TRNN IDX,1 ;Except if we are already sending data, use IDX's channel
MOVE T,CHACHN(IDX)
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,T
%CLIMM+%CLEND,,ASYPKT]
.LOSE %LSSYS
TRNN IDX,1 ;If more packets might come in, defer interrupts
JRST ICCRET
MOVE T,CHABIT(IDX) ;Defer interrupts on this channel until continued
IORM T,SSYDF2 ;Update saved copy of DF2
; Runs at interrupt level -- the interrupt top-level
; will setup the saved defer word before dismissing.
] ;END IFN ITS
IFN TNX,[
MOVE 1,CTLJFN
TRNN IDX,1
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKS
MOVEI 3,ASYPKT
MTOPR
ERCAL CTLERR
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
DIC
] ;END IFN TNX
ICCRET: MOVE A,DATSTA(IDX) ;Insure A stays set up correctly
POPJ P,
;;; Recieved a new packet. Write it to the appropriate file. IDX set up, but packet
;;; not read from system. Since we can only get one interrupt at a time, we can use a
;;; common packet buffer for the data until/unless we get an IOC error in which case
;;; the data must be saved in the allocated buffer.
WRIONE:
IFN ITS,[
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,WRIPKT]
.LOSE %LSSYS ;HMM...THIS BETTER NOT HAPPEN
] ;END IFN ITS
IFN TNX,[
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKR
MOVEI 3,WRIPKT
MTOPR
ERCAL CTLERR
] ;END IFN TNX
SKIPL A,DATSTA(IDX) ;CHANNEL ACTIVE?
JRST WRIBAD ;HMMM...CHANNEL NOT ACTIVE, IGNORE THE PACKET
LDB T,[WRIPKT+$CPKOP] ;GET THE OPCODE
CAIN T,CO%SYN ;Synchronous mark, process it (ignoring channel state)
JRST WRIOSY
JRST @WRIDSP(A) ;ACTIONS TO FOLLOW DEPEND UPON CHANNEL STATE
;Dispatch table
WRIDSP: WRICLO ;CHANNEL CLOSED
WRIOPN ;CHANNEL OPEN, NORMAL PROCESSING
WRIASY ;ASYNCHRONOUS MARKED
WRISYN ;SYNCHRONOUS MARKED STATE
WRIEOF ;EOF STATE
;Channel closed, at eof, or sync or asynch mark. Interrupts shouldn't happen
; Channel cannot stay in synchronous mark state for any amount of time, so this shouldn't
; happen either
;These are all reasons a data packet can get thrown away
WRICLO: AERR WRILUZ,BUG,[Data packet being discarded because channel closed]
WRIASY: AERR WRILUZ,BUG,[Data packet being discarded because channel async-marked]
WRISYN: AERR WRILUZ,BUG,[Data packet being discarded because channel sync-marked]
WRIEOF: AERR WRILUZ,BUG,[Data packet being discarded because channel at eof]
WRIBAD: AERR WRILUZ,BUG,[Data packet being discarded because channel not active]
WRILUZ: TLNN A,ST.SYN ;Expecting sync mark?
AOS (P) ;Nope, don't take any more interrupts
POPJ P, ;Return and perform appropriate action
;Channel in open state, only one allowed to receive a new packet
WRIOPN: CAIN T,CO%BDT ;BINARY DATA
JRST WRIBIN
CAIN T,CO%TXT ;TEXT DATA
JRST WRITXT
CAIN T,CO%EOF ;END OF FILE?
JRST WRIOEO
AERR WRILUZ,BUG,[Illegal packet opcode]
;Synchronous mark received
WRIOSY: TLZE A,ST.SYN ;WAS ONE EXPECTED
JRST WRISY0 ;YES, THROW IT AWAY AND PREPARE FOR MORE DATA
HRRI A,ST%SYN ;ELSE PUT CHANNEL INTO SYNC MARKED STATE
MOVEM A,DATSTA(IDX)
IFN ITS,[
MOVE T,CHABIT(IDX) ;Defer interrupts on this channel until mark processed
IORM T,SSYDF2 ;Update saved DF2
.SUSET [.SIDF2,,T]
] ;END IFN ITS
IFN TNX,[
MOVEI 1,.FHSLF
MOVE 2,CHABIT(IDX)
DIC
] ;END IFN TNX
AOS (P)
POPJ P, ;RETURN AND DISMISS INTERRUPT
WRISY0: TLZ A,ST.SYN ;Make sure sync mark is no longer expected
PUSHJ P,@DATSYA(IDX) ;Call routine to handle receipt of sync mark
MOVEM A,DATSTA(IDX) ;Routine may have altered status
POPJ P,
;EOF received
WRIOEO: PUSHJ P,WRIFOR ;FORCE OUT ANY REMAINING BUFFERS
HRRI A,ST%EOF ;PUT CHANNEL IN EOF STATE
MOVEM A,DATSTA(IDX)
POPJ P, ;RETURN AND DISMISS INTERRUPT
;Text data received
;Note: ITS SIOT is much faster if you always send a multiple of 5 characters
;so that everything stays on word boundaries. So we will move any residual
;part word down to the front of the buffer and save it for next time, setting
;DATBCT to the number of characters saved and DATBPT to point after them.
WRITXT: TLNE A,ST.BIN ;FILE OPEN IN BINARY MODE?
WRIIDO: AERR WRILUZ,BUG,[Illegal data opcode]
SETZ BC,
MOVE BP,DATBUF(IDX) ;USE BUFFER TO HOLD BYTES
HRLI BP,440700 ;7 BIT BYTES
SKIPE DATBPT(IDX)
MOVE BP,DATBPT(IDX) ;POINT AFTER OLD STUFF IN BUFFER
LDB T,[WRIPKT+$CPKNB] ;NUMBER OF BYTES
ADDM T,DATRCV(IDX)
MOVE TT,[441000,,WRIPKT+%CPKDT]
;;; Note: Assumption is that even if the packet consisted of all newlines the buffer could
;;; not be overflowed. If this is not the case, then something else has to be hacked
;;; here.
WRITX1: SOJL T,WRITX0 ;DONE WHEN NO MORE BYTES
ILDB BYTE,TT ;ELSE GET NEXT BYTE
TLNN A,ST.RAW ;If raw mode, don't translate
XCT CHR210(BYTE) ;Convert to PDP-10 code
SKIPA ;Non-skip means character not processed
JRST WRITX1 ;Skip means character has been processed
IDPB BYTE,BP
AOJA BC,WRITX1
WRITX0: JUMPE BC,CPOPJ ;If no bytes to write out (0 length packet), return and dismis
ADDM BC,DATLEN(IDX) ;Keep track of number of bytes written
MOVE BP,DATBUF(IDX) ;Write starting from beginning of buffer
HRLI BP,440700
ADD BC,DATBCT(IDX) ;Include characters left over from last time
MOVE T,BC ;Round down to multiple of a word
IDIVI T,5
IMULI T,5
SUB BC,T ;Number of characters that will be left over
MOVEM BC,DATIOC(IDX)
IFN ITS,[
.CALL [ SETZ
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,BP
%CLIN+%CLEND,,T]
JFCL ;Here if IOC error
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,BP
MOVN 3,T
JUMPE 3,.+3
SOUT
ERJMP .+1
MOVN T,3
MOVE BP,2
] ;END IFN TNX
MOVEM T,DATBCT(IDX) ;Save the byte count remaining within the word-aligned part
MOVEM BP,DATBPT(IDX) ;and the byte pointer to not-yet-output chars
JUMPE T,WRITX2 ;If everything SIOT'ed, go handle residue
IOCERR WRITX2 ;Else IOC error, continuation when fixed up after SIOT done
WRITX2: SKIPN BC,DATIOC(IDX) ;Get number characters to be saved for next time
JRST [ SETZM DATBPT(IDX) ? POPJ P, ] ;No characters
CAIL BC,5
PUSHJ P,CTLERR ;This can't happen
MOVEM BC,DATBCT(IDX)
MOVE T,DATBPT(IDX)
;; Don't need to make BP agree with ITS on TOPS-20, since this IBP equalizes them
IBP T ;Points to first byte to be saved for next time
MOVE TT,(T) ;Move that word down to the front
MOVE BP,DATBUF(IDX) ;Make a byte pointer to after them
HRLI BP,440700
IBP BP
SOJG BC,.-1
MOVEM BP,DATBPT(IDX)
MOVEM TT,(BP)
POPJ P,
;Binary data received
WRIBIN: TLNN A,ST.BIN ;MUST BE A BINARY MODE FILE
JRST WRIIDO
SKIPE T,DATBPT(IDX) ;ARE WE IN THE MIDDLE OF A PREVIOUS OPERATION?
JRST WRIBI0 ;YES, SO CONTINUE PROCESSING IT
HRRZ T,DATBYT(IDX)
CAIE T,16. ;16 BIT BYTE MODE?
JRST WRIBI1 ;NOPE, SO NEED SPECIAL HANDLING ANYWAY
LDB T,[WRIPKT+$CPKNB] ;NUMBER OF BYTES
MOVEI D,(T) ;COPY INTO D
LSH T,-1 ;Number of bytes getting written
ADDM T,DATLEN(IDX)
LSH T,-1 ;NUMBER OF PDP-10 WORDS, ROUNDED DOWN
MOVE TT,[444400,,WRIPKT+%CPKDT]
IFN ITS,[
.CALL [ SETZ ;WRITE THE DATA DIRECTLY FROM THE PACKET
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,TT ;POINTER
%CLIN+%CLEND,,T]
SKIPA ;IOC error
JUMPE T,WRIBI2 ;WROTE OUT ALL THE DATA, PROCEED
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,TT ;Pointer
MOVN 3,T ;Negative count -- output this many bytes
JUMPE 3,.+3
SOUT
ERJMP .+2
JRST [PUSHJ P,ITSBP
MOVE TT,2 ;Get updated pointer
JRST WRIBI2]
MOVN T,3
MOVE TT,2
] ;END IFN TNX
MOVE B,DATBUF(IDX) ;SAVE PACKET IN IDX BUFFER
MOVEI C,(B) ;COPY FOR TERMINATION CONDITION
HRLI B,WRIPKT
BLT B,%CPMXW-1(C) ;SAVE ALL OF PACKET
SUBI C,WRIPKT ;OFFSET FOR BYTE POINTER
ADD TT,C
MOVEM TT,DATBPT(IDX) ;SAVE POINTER
MOVEM T,DATBCT(IDX) ;AND SAVE COUNT
IOCERR WRIBI5 ;GIVE THE IOC ERROR, CONTINUATION
WRIBI5: MOVE TT,DATBPT(IDX) ;IOC ERROR RECOVERY PUTS FINAL BP HERE
SETZM DATBPT(IDX) ;No longer need pointer
MOVE D,DATBUF(IDX) ;SAVED PACKET, AND NEED TO GET BYTE COUNT BACK
LDB D,[$CPKNB (D)]
WRIBI2: TRNN D,3 ;DID WE GET AN ODD NUMBER OF BYTES?
POPJ P, ;NOPE, THEN DONE WITH PACKET
;Here if 16 bit byte mode, but have an odd number of bytes. Next packet will have to do
; it slowly
LSH D,-2 ;NUMBER OF WORDS - 1
IBP TT ;POINT AT NEXT BYTE TO BE DONE
MOVE T,(TT) ;GET THE BYTE
MOVE TT,DATBUF(IDX) ;ADDRESS IN WHICH TO SAVE
MOVEM T,(TT) ;SAVE THE WORD CONTAINING THE BYTE IN THE BUFFER
HRLI TT,242000 ;A POINTER TO IT
MOVEM TT,DATBPT(IDX)
MOVEI T,1 ;ONE BYTE REMAINS
MOVEM T,DATBCT(IDX)
POPJ P, ;THEN WE ARE DONE
;Here if non-16bit byte mode but no bytes left over from last time, byte size in T
WRIBI1: SETZM DATBCT(IDX) ;Make sure byte count is 0
HRLI T,440000 ;Prototype byte pointer
DPB T,[300600,,T] ;Deposit correct byte size into pointer
HRR T,DATBUF(IDX) ;Pointer to buffer
;;; Fall into WRIBI0
;Here if had some bytes left over from last time, T has the pointer to last byte written
WRIBI0: LDB BC,[WRIPKT+$CPKNB] ;COUNT OF BYTES IN PACKET
LSH BC,-1 ;16 bit mode only has half as many
ADDM BC,DATLEN(IDX) ;Keep track of number of more bytes to write
MOVEI C,(BC) ;Save number of bytes
ADD C,DATBCT(IDX) ;Add in number of bytes left over
HRRZ TT,DATBUF(IDX) ;Pointer for SIOT (used later)
HRLI TT,444400
JUMPE BC,WRIBI6 ;If no bytes in packet, finish up here and now
HRRI B,(T) ;THIS IS THE FIRST WORD TO SIOT OUT OF
MOVE BP,[442000,,WRIPKT+%CPKDT]
WRIBI4: SOJL BC,WRIBI3 ;LOOP OVER ALL BYTES
ILDB BYTE,BP
IDPB BYTE,T
JRST WRIBI4
WRIBI3: HRRZ D,DATBPW(IDX)
CAIGE C,(D) ;Enough bytes to make up a word?
JRST WRIBI6 ;Nope
MOVE D,T ;Must increment byte pointer in case last byte was written
IBP D
SUBI D,(B)
HRRZI B,(D) ;Get rid of byte pointer part
IFN ITS,[
.CALL [ SETZ
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,TT
%CLIN+%CLEND,,B]
SKIPA ;IOC error
JUMPE B,WRIBI6 ;Done writing successfully, so go on
MOVEM TT,DATBPT(IDX)
MOVEM B,DATBCT(IDX)
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,TT
MOVN 3,B
JUMPE 3,.+3
SOUT
ERJMP .+2
JRST [PUSHJ P,ITSBP
MOVE TT,2 ;Rest of code needs updated pointer
JRST WRIBI6]
MOVEM 2,DATBPT(IDX)
MOVNM 3,DATBCT(IDX)
] ;END IFN TNX
HLL C,T ;Save final byte pointer
MOVEM C,DATIOC(IDX) ;Remember total number of bytes in buffer for continuation
IOCERR WRIBI7 ;IOC ERROR, CONTINUATION TO WRIBI7
WRIBI7: MOVE TT,DATBPT(IDX) ;Restore byte pointer, IOC error handler leaves final ptr here
HRRZ C,DATIOC(IDX) ;Restore total number of bytes that were in buffer
HLLZ T,DATIOC(IDX) ;Also restore left half of final byte pointer
;Here after IOC error fixed or after normal completion of output operation
WRIBI6: SETZM DATBPT(IDX) ;Assume no bytes left
IDIV C,DATBPW(IDX) ;Remainder is number of bytes left over in last word
JUMPE D,CPOPJ ;We assumed correctly, no extra words
HRR T,DATBUF(IDX) ;Pointer to buffer
IBP TT ;Point at next byte to go out
MOVE C,(TT) ;Get the last word which has extra bytes in it
MOVEM C,(T) ;Store as first word in buffer
MOVEM T,DATBPT(IDX) ;New byte pointer
MOVEM D,DATBCT(IDX) ;And character count
POPJ P,
;;; Force out any data remaining in the buffer. Called from main program level.
;;; This is -NOT- for continuing from IOC errors, which is done by a different routine.
;;; It is for writing out a residual half-word in binary mode, or for
;;; writing out residual part-word characters in text mode.
WRIFOR: SKIPN T,DATBPT(IDX) ;Any bytes in buffer?
POPJ P, ;Nope, then done right now
MOVE TT,DATSTA(IDX) ;Binary mode?
TLNN TT,ST.BIN
JRST [ MOVE TT,DATBUF(IDX) ;Pointer to beginning of buffer
HRLI TT,440700
MOVE T,DATBCT(IDX) ;Number of bytes now in buffer
JRST WRIFR1 ]
HRRZS T ;Get rid of byte position and size info
MOVE TT,DATBUF(IDX) ;To build byte pointer
HRLI TT,444400
SUBI T,1(TT) ;First calculate actual number of words to SIOT
MOVMS T
WRIFR1:
IFN ITS,[
.CALL [ SETZ
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,TT
%CLIN+%CLEND,,T]
JFCL ;IOC errors will get handled in the wash
MOVEM T,DATBCT(IDX) ;This will be 0 if no IOC error
MOVEM TT,DATBPT(IDX)
JUMPN T,CPOPJ ;If got IOC error, return now
SETZM DATBPT(IDX) ;Else leave pointer zeroed out
POPJ P,
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,TT
MOVN 3,T
JUMPE 3,.+3
SOUT
ERJMP .+2
JRST [SETZM DATBPT(IDX)
POPJ P,]
MOVEM TT,DATBPT(IDX)
MOVNM T,DATBCT(IDX)
POPJ P,
] ;END IFN TNX
;;; Here to send one packet over a data conneciton. IDX is set up. Called with interrupts
;;; off so that the shared packet buffer may be used
REAONE: MOVE A,DATSTA(IDX) ;Get channel state
TLZE A,ST.SYN ;Is a synchronous mark required on this channel?
JRST REASSY ;Yes, send it (ignoring channel state)
JRST @READSP(A) ;Actions to follow depend upon channel state
;Dispatch table
READSP: REACLO ;Channel closed
REAOPN ;Channel open, normal processing
REAASY ;Asynchronous marked (should never happen)
REASYN ;Synchronous marked state
REAEOF ;EOF state
;Channel closed, at eof, or sync or asynch mark. Interrupts shouldn't happen
; Channel cannot stay in synchronous mark state for any amount of time, so this shouldn't
; happen either
REACLO:
REAASY:
REASYN:
REAEOF: AOS (P)
POPJ P,
;Here to send sync mark
REASSY: MOVEI T,CO%SYN ;Synchronous mark opcode
HRRI A,ST%SYN ;Now in sync mark state
PUSHJ P,REAEPK ;Output the packet, but return here
JFCL
PUSHJ P,@DATSYA(IDX) ;Call the routine to process the synchronous mark
MOVEM A,DATSTA(IDX)
POPJ P,
;Here to send an empty packet, opcode is in T
REAEPK: DPB T,[$CPKOP+REAPKT] ;Deposit in packet
SETZ T,
DPB T,[$CPKNB+REAPKT] ;Packet contains no information other than opcode
IFN ITS,[
.CALL [ SETZ
SIXBIT/PKTIOT/
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,REAPKT]
.LOSE %LSSYS
] ;END IFN ITS
IFN TNX,[
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKS
MOVEI 3,REAPKT
MTOPR
ERCAL CTLERR
] ;END IFN TNX
MOVEM A,DATSTA(IDX) ;Remember to save new status word
AOS (P) ;Skip return
POPJ P,
;Here when hit EOF. Put channel into EOF state and send EOF packet
REAOEO: HRRI A,ST%EOF ;EOF state
MOVEI T,%COEOF ;Send eof packet
IFN ITS,[
JRST REAEPK
] ;END IFN ITS
IFN TNX,[
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOEOF
MTOPR
ERCAL CTLERR
MOVEM A,DATSTA(IDX)
AOS (P)
POPJ P,
] ;END IFN TNX
;Here to send more data over the data connection
REAOPN: TLNE A,ST.BIN ;Binary mode?
JRST REABIN ;Yes, requires different code
SKIPG DATBCT(IDX) ;Any bytes left in buffer?
PUSHJ P,REABUF ;Nope, fill up buffer
SKIPG T,DATBCT(IDX) ;Did we get any bytes?
JRST REAOEO ;Nope, put channel into EOF state and send an EOF packet
MOVE TT,DATBPT(IDX) ;Pointer into buffer
SETZ BC, ;No bytes in packet
MOVE BP,[441000,,REAPKT+%CPKDT] ;Pointer to start of data in packet
REATXT: ILDB BYTE,TT ;Get next byte from file
TLNN A,ST.RAW ;Raw mode means don't translate
XCT CHR2LM(BYTE) ;Check if any special processing is needed
AOJA BC,REATX0 ;None needed, just output character
JRST REATX1 ;Special processing is done, so just punt the byte
JRST REATX4 ;Skipped twice, a rubout escape.
MOVEI BYTE,"M ;CR, store as M for now in case no LF
IDPB BYTE,BP
ADDI BC,1
SOJLE T,REATX5 ;and absorb following linefeed if any
REATX6: ILDB BYTE,TT
CAIN BYTE,12
JRST [ MOVEI BYTE,215
DPB BYTE,BP
JRST REATX1]
ADD TT,[070000,,] ;Not a line feed, put it back
AOJA T,REATX1 ;Treat stray CR as CRLF
REATX5: PUSHJ P,REABUF ;Get next buffer, first char follows a CR
SKIPG T,DATBCT(IDX)
JRST REATXS ;End of file
MOVE TT,DATBPT(IDX)
JRST REATX6
REATX4: TLNE A,ST.SUI ;Super-image mode means just send rubouts
AOJA BC,[MOVEI BYTE,177 ? JRST REATX0]
SOJLE T,REATX2 ;Jump if end of file-buffer
REATX3: ILDB BYTE,TT ;Get the byte that follows the rubout
XCT CHRQLM(BYTE) ;Convert. Will need no special processing
ADDI BC,1
REATX0: IDPB BYTE,BP ;Store the byte
REATX1: CAML BC,CHPMXC ;Have we written the maximum number of bytes?
SOJA T,REATXS ;Yes, send the packet and return (account for byte as well)
SOJG T,REATXT ;If more characters in buffer just go on
PUSHJ P,REABUF ;Read a new bufferful
SKIPG T,DATBCT(IDX) ;Did we get any more data?
JRST REATXS ;Nope, just send what we have so far
MOVE TT,DATBPT(IDX) ;Else get the byte pointer
JRST REATXT ;And proceed with the transmission
REATX2: PUSHJ P,REABUF ;Get next buffer, first char is quoted with rubout
SKIPG T,DATBCT(IDX)
JRST REATXS ;Oops, end of file in bad place, ignore the stray rubout
MOVE TT,DATBPT(IDX)
JRST REATX3
;Here to store T and TT and send the packet
REATXS: MOVEM T,DATBCT(IDX) ;Save byte count
MOVEM TT,DATBPT(IDX) ;And pointer
JUMPE BC,CPOPJ ;Don't bother transmitting if the packet is null
MOVEI T,CO%TXT ;Data opcode
TLNE A,ST.BIN ;Except if binary mode
TRO T,100 ;This is the correct opcode
DPB T,[REAPKT+$CPKOP]
DPB BC,[REAPKT+$CPKNB]
IFN ITS,[
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,REAPKT]
.LOSE %LSSYS
] ;END IFN ITS
IFN TNX,[
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKS
MOVEI 3,REAPKT
MTOPR
ERCAL CTLERR
] ;END IFN TNX
POPJ P, ;Packet has been transmitted, so return
;Here to read in binary mode
REABIN: HRRZ T,DATBYT(IDX) ;Get byte size
SKIPG DATBCT(IDX) ;If bytes in the buffer
CAIE T,16. ; or if not 16 bit bytes, use slow mode
JRST REABIS
MOVE T,CHPMXW ;Maximum number of words in a packet
MOVE TT,[444400,,REAPKT+%CPKDT]
IFN ITS,[
.CALL [ SETZ ;Read data into the packet
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,TT
%CLIN+%CLEND,,T]
JRST REABI0 ;Ioc error
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,TT
MOVN 3,T ;Negative count is number of bytes we want
SIN
ERCAL REAIOC ;Skips if IOC error as opposed to EOF
SKIPA
JRST REABI0
MOVN T,3
MOVE TT,2
] ;END IFN TNX
CAMN T,CHPMXW ;Did we get any data at all?
JRST REAOEO ;Nope, EOF: send EOF packet, change channel state, and return
MOVE BC,CHPMXW ;Calculate actual number of bytes read
SUBI BC,(T)
LSH BC,2
SETZB T,TT ;Don't get faked into thinking stuff is buffered
JRST REATXS ;Send the packet
;Here on IOC error
REABI0: MOVE B,DATBUF(IDX) ;SAVE PACKET IN IDX BUFFER
MOVEI C,(B) ;COPY FOR TERMINATION CONDITION
HRLI B,REAPKT
BLT B,%CPMXW-1(C) ;SAVE ALL OF PACKET
SUBI C,WRIPKT ;OFFSET FOR BYTE POINTER
ADD TT,C
MOVEM TT,DATBPT(IDX) ;SAVE POINTER
MOVEM T,DATBCT(IDX) ;AND SAVE COUNT
IOCERR REABI1 ;GIVE THE IOC ERROR, CONTINUATION
;IOC error continuation
REABI1: MOVE BC,CHPMXW ;Calculate actual number of bytes read
SUB BC,DATBCT(IDX)
LSH BC,1
MOVEI T,CO%BDT ;Data opcode
DPB T,[REAPKT+$CPKOP]
DPB BC,[REAPKT+$CPKNB]
IFN ITS,[
.CALL [ SETZ
SIXBIT /PKTIOT/
%CLIN,,CHACHN(IDX)
%CLIMM+%CLEND,,DATBUF(IDX)]
.LOSE %LSSYS
] ;END IFN ITS
IFN TNX,[
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOPKS
MOVEI 3,DATBUF(IDX)
MTOPR
ERCAL CTLERR
] ;END IFN TNX
POPJ P, ;Packet has been transmitted, so return
;Slow binary mode. Read block into buffer and use ILDB/IDPB loop to fill packet
REABIS: SKIPG DATBCT(IDX) ;Any bytes left in buffer?
PUSHJ P,REABUF ;Nope, fill up buffer
SKIPG T,DATBCT(IDX) ;Did we get any bytes?
JRST REAOEO ;Nope, put channel into EOF state and send an EOF packet
MOVE TT,DATBPT(IDX) ;Pointer into buffer
SETZ BC, ;No bytes in packet
MOVE BP,[442000,,REAPKT+%CPKDT] ;Pointer to start of data in packet
REABS0: ILDB BYTE,TT ;Get next byte from file
IDPB BYTE,BP ;Store the byte
ADDI BC,2 ;Two more bytes
CAML BC,CHPMXC ;Have we written the maximum number of bytes?
SOJA T,REATXS ;Yes, send the packet and return
SOJG T,REABS0 ;If more characters in buffer just go on
HRRZ T,DATBYT(IDX) ;This 16 bit byte mode?
CAIN T,16.
JRST REABS1 ;Yup, send a small packet and do the rest quickly
PUSHJ P,REABUF ;Read a new bufferful
SKIPG T,DATBCT(IDX) ;Did we get any more data?
JRST REATXS ;Nope, just send what we have so far
MOVE TT,DATBPT(IDX) ;Else get the byte pointer
JRST REABS0 ;And proceed with the transmission
REABS1: SETZB T,TT ;Make sure we go through fast path next time
JRST REATXS
;;; Routine to fill up in-core buffer
;;; Destroy's: B, C, D, T, TT
REABUF: MOVE T,DATBUF(IDX) ;Pointer to the buffer
HRLI T,440700 ;Assume 7 bit bytes
TLNE A,ST.BIN ;Binary mode?
HRLI T,444400 ;Yes, really 36 bit bytes
MOVEM T,DATBPT(IDX) ;Byte pointer if no IOC error
MOVEI TT,2000*5 ;This is correct number of bytes for text mode
TLNE A,ST.BIN ;But is it binary mode?
MOVEI TT,2000 ;Yes, then this is correct byte count
MOVEI B,(TT) ;Count expected maximally
TLNN A,ST.BIN ;Can't have saved word in binary mode
SKIPN D,DATLWD(IDX) ;Do we have a saved last word?
JRST REABF6 ;Nope, proceed normally
SETZM DATLWD(IDX) ;No more last word
MOVEM D,(T) ;Save the word as first buffer word
ADDI T,1 ;Increment pointer
SUBI TT,5 ;Read 5 fewer bytes
REABF6: TLNE A,ST.DIR ;Directory listing?
JRST REDRBF ;Yes, handled specially
IFN ITS,[
.CALL [ SETZ
SIXBIT /SIOT/
%CLIN,,DATCHN(IDX)
%CLIN,,T
%CLIN+%CLEND,,TT]
JRST REABF1 ;IOC error
] ;END IFN ITS
IFN TNX,[
MOVE 1,DATJFN(IDX)
MOVE 2,T
MOVN 3,TT ;Negative count is number of bytes we want
SIN
ERCAL REAIOC ;Skips if IOC error as opposed to EOF, sets up T and TT
SKIPA
JRST REABF1
MOVN TT,3
MOVE T,2
] ;END IFN TNX
REABF3: SUBI B,(TT) ;Actual number of bytes read
TLNN A,ST.BIN ;Binary mode?
JRST REABF4 ;Nope, no special processing
HRRZ D,DATBYT(IDX)
DPB D,[300600,,DATBPT(IDX)] ;Correct size bytes
MOVEI C,36. ;Have number of 36 bit words, need number of real bytes
IDIVI C,(D)
IMULI B,(C) ;Calculate actual number of bytes read
REABF4: MOVEM B,DATBCT(IDX) ;Remember count
IFN TNX,[
POPJ P, ;No need to do trailing control-C checking here
] ;END IFN TNX
IFN ITS,[
SKIPE B ;Return right away if we read nothing
TLNE A,ST.BIN ;If binary mode then done
POPJ P,
IFN ITS,[
;; TT has number of bytes we tried to read, T has pointer to last byte hacked (almost...)
;; Due to gross ITS lossage, check for initial special case of 440700,, and
;; fix it
HLRZ TT,T
CAIN TT,440700
SUB T,[430000,,1]
] ;END IFN ITS
CAIE TT,(B) ;If we got less than we wanted, we hit EOF
JRST READLC
;; We got a full bufferload, but we may have hit EOF! So, must save last word and tack
;; it on next time when we'll know for sure whether we got to EOF
MOVE TT,(T) ;Get the last word
TRO TT,1 ;Force it to be non-zero by setting bit 35 (argghh!)
MOVEM TT,DATLWD(IDX) ;Save the "Last word"
SUBI B,5
MOVEM B,DATBCT(IDX)
POPJ P,
;; Search backwards removing trailing eof chars from the last word
;; T has BP to last byte read, B has count of bytes
READLC: LDB TT,T ;Get last character
CAIE TT,^C
CAIN TT,^L
SOJG B,[ ADD T,[070000,,]
JUMPGE T,READLC
SUB T,[430000,,1]
JRST READLC]
JUMPE B,REABUF ;Get another bufferful if no valid bytes found
MOVEM B,DATBCT(IDX) ;Store number of bytes in buffer
POPJ P, ;Then return
] ;END IFN ITS
REABF1: POP P,DATIOC(IDX) ;Save address of our caller
HRLM B,DATIOC(IDX) ;Also save total number of bytes to be read
MOVEM T,DATBPT(IDX) ;Pointer
MOVEM TT,DATBCT(IDX) ;Remaining bytes to read
IOCERR REABF2
REABF2: PUSH P,DATIOC(IDX) ;Restore adr of our caller
HLRZ B,DATIOC(IDX) ;Total number of bytes expected
MOVE TT,DATBCT(IDX) ;Need bytes left to read
JRST REABF3
IFN TNX,[
REAIOC: MOVE T,2 ;Updated byte pointer
MOVN TT,3 ;Updated count
MOVEI 1,.FHSLF ;Get last error
PUSHJ P,$GETER
JFCL
HRRZS 2 ;Only error number
CAIE 2,IOX4 ;EOF, so non-skip
AOS (P)
MOVE 2,T ;Callers expect these results in 2 and 3
MOVN 3,TT
POPJ P,
$GETER:
IFN 10X,[
PUSH P,4
PUSH P,5
PUSH P,6
PUSH P,7
PUSH P,10
]
GETER
ERJMP .+2
IFN 10X,[
AOS -5(P)
POP P,10
POP P,7
POP P,6
POP P,5
POP P,4
]
.ELSE AOS (P)
POPJ P,
] ;END IFN TNX
;Interrupt table
IFN ITS,[
INTTAB:
LOC 42
-INTLEN,,INTTAB
LOC INTTAB
17,,P
%PIIOC ? 0 ? %PIIOC+%PIDBG+%PIDWN ? 177777 ? IOCINT
%PIDBG ? 0 ? %PIDBG+%PIDWN ? 0 ? DBGINT
%PIDWN ? 0 ? %PIDBG+%PIDWN ? 0 ? DWNINT
REPEAT MAXIDX,[
0 ? 1_<.RPCNT+3> ? %PIDBG+%PIDWN ? 177777 ? CHAINT+<2*.RPCNT>
]
INTLEN==.-INTTAB
;;; Here on receipt of channel interrupt from one of the chaosnet channels.
;;; Figure out which one, and perform the appropriate actions. All AC's saved by system.
;;; All other channel interrupts deffered
CHAINT: MOVEI IDX,0 ;IDX will contain index that got interrupt
JRST CHAIN0
MOVEI IDX,1
JRST CHAIN0
MOVEI IDX,2
JRST CHAIN0
MOVEI IDX,3
JRST CHAIN0
MOVEI IDX,4
JRST CHAIN0
MOVEI IDX,5
; JRST CHAIN0
CHAIN0: PUSHJ P,CHALOP ;Handle this IDX
MOVE T,SSYDF2 ;Cause correct DF2 when dismissed
MOVEM T,-20(P) ;Correct offset: all AC's, the old PC
.CALL [ SETZ
SIXBIT /DISMIS/
%CLBTW,,INTTAB
%CLIN+%CLEND,,P]
.LOSE %LSSYS
;Here with IDX properly set up
CHALOP: .CALL [ SETZ ;Find out why the interrupt happened
SIXBIT /WHYINT/
%CLIN,,CHACHN(IDX)
%CLOUT,,T ;%WYCHA
%CLOUT,,T ;State
%CLOUT+%CLEND,,TT] ;#in packets available ,, #out packets available
.LOSE %LSSYS ;Hmm...
JRST CHAIND(T) ;Dispatch on state
] ;END IFN ITS
;Dispatch table for channel state
CHAIND: JRST CHACLS ;Closed, so close down the channel (protocol violation!!)
JRST CHALSN ;Listen!!
JRST CHARFC ;RFC received!!(!!)
JRST CHARFS ;RFC SENT!!!!!! (This is getting out of hand...)
JRST CHAOPN ;Open ("Better, better")
JRST CHALOS ;Hmm...LOS received
JRST CHAINC ;Incomplete [poor Lisp Machine died....]
CHARFS: POPJ P,
CHALSN:
CHARFC:
CHALOS:
CHAINC:
CHACLS:
;;; Hmmm...Lisp Machine went down or forgot us. Go away if it was a channel in active
;;; use. If not, it is possible that it was a channel that failed to open correctly,
;;; in which case it was just timing out. That's probably ok.
TRZ IDX,1 ;Check input and output
SKIPL DATSTA(IDX)
SKIPGE DATSTA+1(IDX)
PUSHJ P,CTLDON ;If either channel in use, Lisp Machine must have gone away.
JRST CHNFLS ;Flush channels, then return
CHAOPN: TRNE IDX,1 ;Reading or writing?
JRST CHAOPO ;Writing, handle slightly differently
TRNN TT,-1 ;Any output packets available?
POPJ P, ;Nope, then done...just return
PUSHJ P,REAONE ;Handle the packet
JRST CHALOP ;Loop if no error
POPJ P, ;Else return
CHAOPO: TLNN TT,-1 ;Any packets to read?
POPJ P, ;Nope
PUSHJ P,WRIONE
JRST CHALOP
POPJ P, ;Error, return right away
IFN ITS,[
;;; IOC error handler
IOCINT: .SUSET [.RBCHN,,T] ;Get channel that had error
CAIL T,CHALOW
CAILE T,CHAHIG
JRST IOCDAT ;Not CHAOS channel, must be data error
PUSHJ P,CTLDON ;Else something happened to Lisp Machine, we are done
IOCDAT: AOS -17(P) ;Setup to return to location after call which caused error
.CALL [ SETZ
SIXBIT /DISMIS/
%CLBTW,,INTTAB
%CLIN+%CLEND,,P]
.LOSE %LSSYS
;;; System going down and system being debugged inform user then exit to CTLLOP
DBGINT: PUSHJ P,DWNIN1 ;Set up to return notification
MOVEI A,[ASCIZ/system being debugged./]
SKIPN C
MOVEI A,[ASCIZ/system no longer being debugged./]
DWNIN2: PUSHJ P,COMSTO
DWNIN9: .CLOSE ERRCH,
MOVEI T,CO%NOT
PUSHJ P,COMSN1
JRST CTLLOP
DWNIN1: MOVE BP,[441000,,%CPKDT+CTLPKO]
SETZ BC,
.CALL [ SETZ ? 'SSTATU ? MOVEM B ? SETZM C ]
.LOSE %LSSYS
POPJ P,
DWNINT: PUSHJ P,DWNIN1
MOVEI A,[ASCIZ/system revived./]
JUMPL B,DWNIN2
MOVEI A,[ASCIZ/system going down in /]
PUSHJ P,COMSTO
IDIVI B,30.
IDIVI B,60. ;B minutes until down, C seconds
SKIPN A,B
JRST DWNIN3
PUSHJ P,COMDCO
MOVEI A,[ASCIZ/ minutes, /]
PUSHJ P,COMSTO
DWNIN3: MOVE A,C
PUSHJ P,COMDCO
MOVEI A,[ASCIZ/ seconds./]
PUSHJ P,COMSTO
.OPEN ERRCH,[.UAI,,'SYS ? SIXBIT/DOWN/ ? SIXBIT/MAIL/]
JRST DWNIN9
MOVEI BYTE,215
DWNIN4: CAMGE BC,CHPMXC
CAIGE BYTE,40
CAIA
PUSHJ P,COMCHO
.IOT ERRCH,BYTE
JUMPL BYTE,DWNIN9 ;EOF
CAIN BYTE,15
MOVEI BYTE,215
JRST DWNIN4
] ;END IFN ITS
IFN TNX,[
LEVTAB: 0,,PRILE1
0,,PRILE2
0,,PRILE3
CHNTAB: 3,,INTID0 ;Interrupt IDX 0 (channel 0)
3,,INTID1 ;Interrupt IDX 1
3,,INTID2
3,,INTID3
3,,INTID4
3,,INTID5 ;Interrupt IDX 5 (channel 6)
0 ;Arithmetic overflow
0 ;Floating overflow
0 ;Reserved for D.E.C.
1,,CTLERR ;PDL overflow
1,,CTLERR ;EOF
1,,CTLERR ;Data error
1,,CTLERR ;Disk full or quota exceeded
0 ? 0 ;Reserved
1,,CTLERR ;Illegal instruction
1,,CTLERR ;Illegal read
1,,CTLERR ;Illegal write
0 ;Reserved
1,,CTLERR ;Inferior termination or freeze
1,,CTLERR ;System resources exhausted
0 ;Reserved
0 ;Reference to non-existant page
3,,INTID6 ;Interrupt IDX 6 (channel 23.)
3,,INTID7
3,,INTID8
3,,INTID9
3,,INTIDA ;Interrupt IDX 10. (channel 27.)
3,,INTIDB
3,,INTIDC ;IDX 12.
3,,INTIDD ;IDX 13.
3,,INTIDE ;IDX 14.
3,,INTIDF ;IDX 15.
3,,TIMINT ;Timer interrupt
0 ? 0 ;34. and 35. reserved by monitor if
; the job runs at toplevel
INDEX=0
IRPS NAME,,[0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F]
INTID!NAME: JSR LV1SAC ;Save AC's
MOVEI IDX,INDEX
JRST CHAIN0
INDEX=INDEX+1
TERMIN
CHAIN0: PUSHJ P,CHALOP
INTDEB: MOVE 0,[LV1ACS+1,,1]
BLT 0,17
MOVE 0,LV1ACS
DEBRK
;Here with IDX properly set up
CHALOP: MOVE 1,CHAJFN(IDX)
GDSTS ;This gets state in 2, and number of input packets in 3
ERCAL CTLERR
MOVE T,2
HRLZ TT,3
MOVE 1,CHAJFN(IDX)
MOVEI 2,.MOAWS
MTOPR
ERCAL CTLERR
HRR TT,3
JRST CHAIND(T) ;Dispatch on state
;Timer interrupt
TIMINT: JSR LV1SAC
PUSHJ P,TIMIN1
JRST INTDEB ;Dismiss interrupt
;;;Here to initialize the timer
TINTVL==2*60.*1000. ;Every two minutes
TIMRKS: 30. ? 15. ? 10. ? 5. ? 1. ? -30. ;Times at which to notify
TIMIN1: SKIPL TIMINF ;Ok for timer interrupt?
JRST [ AOS TIMINF ;No, note that one went off
JRST SETTIM] ;And skip downtime check for now
PUSHJ P,DWNCHK
JRST SETTIM
DWNCHK:
IFN 10X,MOVE 1,[SIXBIT /SYSTAT/]
.ELSE MOVE 1,[SIXBIT /DWNTIM/]
SYSGT
HRRZ A,2 ;Table number
MOVE 1,A
IFN 10X,HRLI 1,27
GETAB
SETZ 1,
JUMPE 1,NODWNT
MOVE C,1
GTAD
SUB C,1 ;Get time until shutdown
TLNE C,-1 ;More than a day?
JRST NODWNT
IFN 10X,IDIVI C,60. ;Into minutes
.ELSE [
IMULI C,24.*60.
HLRZS C
]
SETZ D,
CAMG C,TIMRKS(D) ;Find range of time
AOJA D,.-1
JUMPE D,NODWNT ;More than maximum time
CAMN D,DWNTIM ;Same as last notification?
POPJ P, ;Yes
MOVEM D,DWNTIM
IFN 10X,SETOM DWNTIM+1
PUSHJ P,DWNIN1
MOVEI A,[ASCIZ /system going down in /]
PUSHJ P,COMSTO
MOVE A,C
PUSHJ P,COMDCO
MOVEI A,[ASCIZ / minute/]
PUSHJ P,COMSTO
MOVEI BYTE,"s
CAIE C,1
PUSHJ P,COMCHO
MOVEI BYTE,".
PUSHJ P,COMCHO
JRST DWNIN2
NODWNT: SKIPN DWNTIM
POPJ P,
IFN 10X,[
AOSN DWNTIM+1 ;Tenex cancels shutdown just before shutting down
POPJ P, ;So don't say it's cancelled until it's cancelled twice
];10X
SETZM DWNTIM
PUSHJ P,DWNIN1 ;Set up to return notification
MOVEI A,[ASCIZ/shutdown cancelled./]
PUSHJ P,COMSTO
DWNIN2: MOVEI T,CO%NOT
JRST COMSN1
DWNIN1: MOVE BP,[441000,,%CPKDT+CTLPKO]
SETZ BC,
POPJ P,
;; Setup timer interrupt
SETTIM:
IFN 20X,[
MOVE 1,[.FHSLF,,.TIMEL] ;Tick the timer
MOVE 2,[TINTVL]
MOVEI 3,33. ;On channel 33
TIMER
JFCL
];IFN 20X
.ELSE [
IFNDEF IIT,IIT=JSYS 630
MOVEI 1,.FHSLF ;This fork
MOVEI 2,4 ;On channel 33.
MOVE 3,[TINTVL]
IIT ; Set to trigger it
];10X
POPJ P,
;;; Print the contents of a Chaosnet packet. A has the byte-count,
;;; and B a BP to the data area.
IFN $$LOG,[
PktPrt: Move 1,TriJFN
Movei 2,^I
BOUT
Setz 3,
PP0:: Sojl A,PP1
Ildb 2,B
Cain 2,215
Jrst [Hrroi 2,[Asciz "<NL>"]
SOUT
Jrst PP0]
BOUT
Jrst PP0
PP1: Hrroi 2,[Asciz "<EOP>
"] ? SOUT
Popj P,
];$$LOG
];END IFN TNX
;;; Character translation tables
;Byte is a pdp10 character to be sent to Lisp machine.
;This table used when not preceded by rubout escape.
;Skip once to ignore it, twice if this is rubout escape, three times for CR.
CHR2LM: REPEAT 10, JFCL ;0 through 7, leave alone
REPEAT 3, ADDI BYTE,200 ;10 through 12 turn into backspace, tab, linefeed
JFCL ;13 stays as uparrow
ADDI BYTE,200 ;14 form
JSP BYTE,[JRST 3(BYTE)] ;15 skip three times for carriage return
REPEAT 177-16, JFCL ;16-176 unchanged
JSP BYTE,[JRST 2(BYTE)] ;177 skip twice for quoting special character
IFN .-CHR2LM-200, .ERR CHR2LM table not 200 long
;This table used when preceded by rubout escape.
CHRQLM: REPEAT 10, ADDI BYTE,200 ;0-7 => 200-207
REPEAT 3,JFCL ;10-12 self
ADDI BYTE,200 ;13 => 213
REPEAT 2, JFCL ;14, 15 self
REPEAT 177-16, ADDI BYTE,200 ;16-176 => 216-376
JFCL ;177 self
IFN .-CHRQLM-200, .ERR CHRQLM table not 200 long
;BYTE is a lisp-machine character to be put into pdp10 buffer via BP and BC
;Skip to ignore it.
CHR210: REPEAT 10, JFCL ;0 through 7, leave alone
REPEAT 3, PUSHJ P,CHRQ10 ;10, 11, 12 hidden under backspace, tab, lf
JFCL ;13 stays as uparrow
REPEAT 2, PUSHJ P,CHRQ10 ;14, 15 hidden under form, cr
REPEAT 177-16, JFCL ;No change to 16 through 176
REPEAT 11, PUSHJ P,CHRQ10 ;177-207 quoted
REPEAT 3, SUBI BYTE,200 ;Scale down to PDP-10 equivalents for 210 - 212
PUSHJ P,CHRQ10 ;213 quoted
SUBI BYTE,200 ;Scale down to PDP-10 equivalent for 214
PUSHJ P,[MOVEI BYTE,15 ;Insert <CR><LF> for newline
IDPB BYTE,BP
ADDI BC,1
MOVEI BYTE,12
POPJ P,]
REPEAT 377-216, PUSHJ P,CHRQ10 ;216-376 quoted
SKIPA ;377 ignored
IFN .-CHR210-400, .ERR CHR210 table not 400 long
CHRQ10: TLNE A,ST.SUI ;Super-image mode
POPJ P, ;Just output byte with no quoting in super-image mode
HRLM BYTE,(P) ;Output this byte preceded by 177 to quote it
MOVEI BYTE,177
IDPB BYTE,BP
ADDI BC,1
HLRZ BYTE,(P)
POPJ P,
;Error code table
IFN ITS,[
ERRTAB: %ERODV,,'ACC ;ACCESS ERROR--DEVICE WRITE-LOCKED
%ELCDV,,'ACC ;ACCESS ERROR--LOCAL DEVICE ONLY
%EMCHN,,'ACC ;ACCESS ERROR--DEVICE NOT ASSIGNABLE TO THIS PROCESSOR
%ETMDR,,'CCD ;CANNOT CREATE DIRECTORY--MFD FULL
%ETMLK,,'CIR ;CIRCULAR LINK
%ETMTR,,'CIR ;CIRCULAR "LINK"--TOO MANY TRANSLATIONS
%ENSDV,,'DEV ;DEVICE NOT FOUND
%ENSDR,,'DNF ;DIRECTORY NOT FOUND
%ENSFL,,'FNF ;FILE NOT FOUND
%ENAFL,,'LCK ;FILE LOCKED
%EBDLK,,'LNF ;LINK TO NONEXISTENT FILE
%ENRDV,,'NAV ;EXISTS BUT NOT AVAILABLE--DEVICE NOT READY
%ENAPK,,'NAV ;--PACK NOT MOUNTED
%ENADV,,'NAV ;--DEVICE NOT AVAILABLE
%ENACR,,'NER ;NOT ENOUGH RESOURCES--NO CORE AVAILABLE
%EFLDR,,'NMR ;NO MORE ROOM--DIRECTORY FULL
%EFLDV,,'NMR ;NO MORE ROOM--DEVICE FULL (SHOULD BE NER SOMETIMES!)
%EEXFL,,'REF ;RENAME TO EXISTING FILE
%ENSMD,,'WKF ;WRONG KIND OF FILE--MODE NOT AVAILABLE
%EBDDV,,'WKF ;WRONG KIND OF DEVICE
;IOC errors. These don't seem to have symbolic names.
1000,,'MSC ;DEVICE HUNG OR REPORTING NON-DATA ERROR
2000,,'FOR ;END OF FILE
3000,,'DAT ;NON-RECOVERABLE DATA ERROR
4000,,'DEV ;NON-EXISTENT SUB-DEVICE (?)
;5000,,'BUG ;OVER IOPOP
;6000,,'BUG ;OVER IOPUSH
7000,,'WKF ;USR OP CHNL DOES NOT HAVE USR OPEN
;10000,,'BUG ;CHNL NOT OPEN
11000,,'NMR ;DEVICE FULL
12000,,'WKF ;CHNL IN ILLEGAL MODE ON IOT
13000,,'DAT ;ILLEGAL CHR AFTER CNTRL P ON TTY DISPLAY (?)
14000,,'NMR ;DIRECTORY FULL
LERRTB==.-ERRTAB
];ITS
IFN TNX,[
ERRTAB: GJFX29,,'ACC ;ACCESS ERROR--DEVICE NOT AVAILABLE TO THIS JOB
ACESX7,,'ACC ;ACCESS ERROR--DIRECTORY IS FILES-ONLY
CFDBX2,,'ACC ;ACCESS ERROR--INVALID TO CHANGE SPEC'D BITS
CFDBX3,,'ACC ;ACCESS ERROR--WRITE OR OWNER ACCESS REQUIRED
CRDIX1,,'ACC ;ACCESS ERROR--WHEEL/OPERATOR REQUIRED
DELFX1,,'ACC ;ACCESS ERROR--DELETE ACCESS REQUIRED
OPNX12,,'ACC ;--LIST ACCESS REQUIRED
OPNX25,,'ACC ;--DEVICE WRITE-LOCKED
CAPX1,,'ACC ;--WHEEL/OPERATOR
CAPX2,,'ACC ;--WHEEL/OPERATOR/MAINTENANCE
DELDX1,,'ACC ;--WHEEL/OPERATOR
WHELX1,,'ACC ;--WHEEL/OPERATOR
GTDIX1,,'ACC ;--WHEEL/OPERATOR
MTOX7,,'ACC ;--WHEEL/OPERATOR
CNDIX2,,'ACC ;--WHEEL/OPERATOR
IFDEF ACJX01,[ ;MIT addition: access control job
ACJX01,,'ACC
]
GJFX35,,'ATD ;INCORRECT ACCESS TO DIRECTORY
ACESX3,,'ATD ;INCORRECT ACCESS TO DIRECTORY--PASSWORD REQUIRED
OPNX3,,'ATF ;ACCESS TO FILE--READ
OPNX4,,'ATF ;ACCESS TO FILE--WRITE
OPNX5,,'ATF ;ACCESS TO FILE--EXECUTE
OPNX6,,'ATF ;ACCESS TO FILE--APPEND
OPNX15,,'ATF ;ACCESS TO FILE--READ/WRITE
RNAMX3,,'ATF ;ACCESS TO FILE--RENAME DESTINATION
RNAMX8,,'ATF ;ACCESS TO FILE--RENAME SOURCE
CRDI10,,'CCD ;CANNOT CREATE DIR--MAX DIR NUM EXCEEDED
CRDI13,,'CCD ;--EXCEEDS WORKING QUOTA
CRDI14,,'CCD ;--EXCEEDS PERMANENT QUOTA
CRDI15,,'CCD ;--EXCEEDS SUBDIRECTORY QUOTA
CRDI16,,'CCD ;--INVALID USER GROUP
CRDI17,,'CCD ;--ILLEGAL LOGIN SUBDIR UNDER FILES-ONLY
CRDI20,,'CCD ;--CANNOT CREATE DIR WITH NOT-HELD CAPABILITY
CRDI21,,'CCD ;--WORKING SPACE TOO SMALL
CRDI22,,'CCD ;--SUBDIR QUOTA TOO SMALL
CRDI24,,'CCD ;--INVALID SUBDIR QUOTA
CRDIX4,,'CCD ;--SUPERIOR DIRECTORY FULL
IFDEF CRDX01,[ ;MIT addition: more CRDIR errors with inconsistent names
CRDX01,,'CCD ;--SUPERIOR MAY NOT HAVE LOGIN SUBDIRECTORIES
CRDX02,,'CCD ;--CREATE-LOGIN-SUBDIRECTORIES CAP REQUIRED
CRDX03,,'CCD ;--DIRECTORY MUST BE FILES-ONLY
];CRDX01
SFUSX6,,'CSP ;CAN'T SET PROPERTY--NO SUCH USER
GJFX39,,'CIR ;CIRCULAR "LINK"--LOGICAL NAME LOOP
CRDIX2,,'DAE ;DIR ALREADY EXISTS--ILLEGAL TO CHANGE DIR NUMBER
IOX5,,'DAT ;DATA ERROR
OPNX16,,'DAT ;DATA ERROR--INDEX BLOCK BAD
GJFX16,,'DEV ;DEVICE NOT FOUND
DELX13,,'DND ;DONT-DELETE SET--PERPETUAL
GJFX17,,'DNF ;DIRECTORY NOT FOUND
CRDI23,,'DNF ;SUPERIOR DIRECTORY NOT FOUND (CRDIR)
GJFX27,,'FAE ;FILE ALREADY EXISTS
GJFX18,,'FNF ;FILE NOT FOUND--NO SUCH NAME
GJFX19,,'FNF ;FILE NOT FOUND--NO SUCH TYPE
GJFX20,,'FNF ;FILE NOT FOUND--NO SUCH VERSION
GJFX24,,'FNF ;FILE NOT FOUND
GJFX52,,'FNF ;FILE NOT FOUND--END OF TAPE REACHED WHILE SEARCHING
OPNX2,,'FNF ;FILE NOT FOUND--DOES NOT EXIST
GJFX10,,'IPS ;INVALID PATHNAME SYNTAX--NON-NUMERIC VERSION
GJFX11,,'IPS ;--MORE THAN ONE VERSION NUMBER
GJFX33,,'IPS ;--FILENAME NOT SPECIFIED
GJFX4,,'IPS ;--INVALID CHARACTER
GJFX6,,'IPS ;--DEVICE FIELD MISPLACED
GJFX7,,'IPS ;--DIRECTORY FIELD MISPLACED
GJFX8,,'IPS ;--GREATER THAN MISPLACED
GJFX9,,'IPS ;--MORE THAN ONE NAME
GJFX40,,'IPS ;--UNDEFINED ATTRIBUTE
GJFX5,,'IPS ;--FIELD LONGER THAN 39 CHARS
CFDBX4,,'IPV ;INVALID PROPERTY VALUE
LGINX4,,(SIXBIT/IP?/) ;INVALID PASSWORD
CRDIX6,,'LCK ;FILE LOCKED--DIRECTORY FILE IS MAPPED
CRDIX7,,'LCK ;--FILES OPEN IN DIR
CRDI18,,'LCK ;--LOGIN DIR
CRDI19,,'LCK ;--CONNECTED DIR
OPNX9,,'LCK ;--INVALID SIMULTANEOUS ACCESS
RNMX10,,'LCK ;FILE LOCKED--RENAME SOURCE IS OPEN
LGINX1,,'LIP ;LOGIN PROBLEM--INVALID ACCOUNT
LGINX2,,'LIP ;--FILES-ONLY
LGINX3,,'LIP ;--DIRECTORY FUKT
GJFX28,,'NAV ;NOT AVAILABLE--DEVICE NOT ONLINE
OPNX7,,'NAV ;--ASSIGNED TO OTHER JOB
OPNX8,,'NAV ;--NOT ONLINE
DELX11,,'NAV ;--CAN'T DELETE WHEN ARCHIVED
OPNX30,,'NAV ;--CAN'T OPEN WHEN ARCHIVED
OPNX31,,'NAV ;--FILE OFFLINE
CRDI12,,'NAV ;STRUCTURE IS NOT MOUNTED
IFDEF IOX35,[ ;20X Release 5 addition
IOX35,,'NAV ;Disk structure damaged--cannot allocate space
];IOX35
LGINX6,,'NER ;NOT ENOUGH RESOURCES--NO JOB SLOTS
CRDIX3,,'NER ;NOT ENOUGH RESOURCES--JSB FULL
OPNX17,,'NER ;NOT ENOUGH RESOURCES--NO ROOM FOR LONG FILE PAGE TABLE
GJFX22,,'NER ;NOT ENOUGH RESOURCES--JSB FULL
GJFX3,,'NER ;NOT ENOUGH RESOURCES--NO JFN SLOTS
ACESX2,,'NER
IOX12,,'NER ;--SWAP SPACE FULL
MONX01,,'NER
MONX02,,'NER ;--JSB FULL
MONX04,,'NER ;--SWAP SPACE FULL
MONX05,,'NER ;--NO RESIDENT FREE SPACE
RNMX13,,'NER
GJFX23,,'NMR ;NO MORE ROOM--DIRECTORY FULL
IOX11,,'NMR ;NO MORE ROOM--QUOTA EXCEEDED OR DISK FULL
OPNX10,,'NMR ;NO MORE ROOM--STRUCTURE FULL
OPNX23,,'NMR ;NO MORE ROOM--QUOTA EXCEEDED
RNAMX4,,'NMR ;NO MORE ROOM--QUOTA EXCEEDED IN RENAME DESTINATION
IFDEF IOX34,[ ;20X Release 5 addition
IOX34,,'NMR ;Disk structure completely full
];IOX34
RNAMX1,,'RAD ;RENAME ACROSS DIRECTORIES--ACROSS DEVICES ACTUALLY
RNMX12,,'REF ;RENAME TO EXISTING FILE--SELF
RNAMX2,,'REF ;--FILE NOT CLOSED
GJFX38,,'WKF ;WRONG KIND OF FILE--OUTPUT-ONLY DEVICE
OPNX13,,'WKF ;--"INVALID ACCESS REQUESTED" (Read of a dir gives this)
OPNX14,,'WKF ;--"INVALID MODE REQUESTED"
GJFX31,,'WNA ;WILDCARD NOT ALLOWED--INVALID WILDCARD DESIGNATOR
GJFX34,,'WNA ;--INVALID QUESTION MARK
LERRTB==.-ERRTAB
];TNX
0,,'BUG ;If run off end of table
PAT:
PATCH: BLOCK 100
;;; Start here to install
PURIFY: SETZM DEBUG
IFN ITS,[
MOVE T,[-<PURPND-NIMPUR>,,NIMPUR]
.CALL [ SETZ ? 'CORBLK ? MOVEI %CBNDR ? MOVEI %JSELF ? T ? SETZI %JSELF ]
.LOSE %LSSYS
.VALUE [ASCIZ/:PDUMP DSK:DEVICE;CHAOS FILE/]
];END IFN ITS
IFN TNX,[
HLRO 1,JOBSYM ;Find end of symbol table
MOVNS 1
ADD 1,JOBSYM
HRRZS 1
CAIG 1,PURPND*1000
JRST PURIF1
HRROI 1,[ASCIZ/Not enough space left for symbol table/]
PSOUT
HALTF
PURIF1: MOVEI 1,.FHSLF
MOVE 2,[1,,FILE]
SEVEC
SETOB 2,3
EPCAP
MOVSI 1,(GJ%SHT+GJ%FOU+GJ%NEW)
RADIX 10.
IFN 20X,HRROI 2,[CONC [ASCIZ /SYSTEM:CHAOS.FILE.],\.FVERS,/]
IFN 10X,HRROI 2,[CONC [ASCIZ /DSK:<SYSTEM>CHAOS.FILE;],\.FVERS,/]
RADIX 8
GTJFN
HALTF
HRLI 1,.FHSLF
MOVEI 2,[ -NIMPUR,,520000 ;Low impure copy on write
-<PURPND-NIMPUR>,,120000+NIMPUR ;Pure pages
0 ] ;End
SSAVE
HRROI 1,[ASCIZ/Saved.
/]
PSOUT
HALTF
] ;END IFN TNX
CONSTANTS
IFN ITS,[
MFDBUF==:.\1777+1
PURPND==:MFDBUF/2000
DIRBUF==:MFDBUF+2000
BUFBAS==:<DIRBUF+2000>/2000
];END IFN ITS
IFN TNX,[
PURPND==:<<.+777>/1000>+NSYMPG
IFN $$SUBM,[
QSRPAG==:PURPND
QSRLOC==:QSRPAG*1000
BUFBAS==:<QSRLOC+1777>/2000
];$$SUBM
.ELSE BUFBAS==:<PURPND*1000+1777>/2000
];TNX
BUFLOC==:BUFBAS*2000
PURLOC==.
LOC IMPLOC
VARIABLES
IMPLOC==.
IFG .-PURBEG,[
INFORM Impure is ,\<.-PURBEG>, words too long!
.FATAL Too much impure, increase NIMPUR
]
IF2,[
INFORM END OF IMPURE=,\IMPLOC
INFORM START OF PURE=,\PURBEG
INFORM END OF PURE=,\PURLOC
IFN TNX,[
IFN $$SUBM,[
INFORM QUASAR IPCP LOC=,\QSRLOC
];$$SUBM
];TNX
INFORM FIRST BUFFER LOC=,\BUFLOC
];IF2
IFN TNX, LOC PURLOC ;SEEMS TO CONTROL SYMBOL TABLE LOCATION
END FILE
Reference in New Issue View Git Blame Copy Permalink