Google
 

Trailing-Edge - PDP-10 Archives - BB-M081Z-SM - monitor-sources/jsysf.mac
There are 53 other files named jsysf.mac in the archive. Click here to see a list.
; Edit= 9174 to JSYSF.MAC on 25-Jun-90 by GSCOTT
;In PWDICT, only check CD%PEN if CD%LEN is set. 
; Edit= 9169 to JSYSF.MAC on 17-May-90 by LOMARTIRE, for SPR #22083
;Prevent CRDIR% with CD%DAC from losing JSB freespace after edit 8856
; Edit= 9148 to JSYSF.MAC on 21-Feb-90 by GSCOTT
;Update copyright date. 
; Edit= 9125 to JSYSF.MAC on 29-Sep-89 by GSCOTT
;Prevent CFSMTOs when OPENF% fails for magtape with OPNX9.
; Edit= 9124 to JSYSF.MAC on 26-Sep-89 by GSCOTT
;Fix bug causing ILLUUOs if OPENF% blocked after edit 9122.
; Edit= 9123 to JSYSF.MAC on 22-Sep-89 by LOMARTIRE, for SPR #22073
;Allow SFBSZ% to update byte size for a new, empty file 
; Edit= 9122 to JSYSF.MAC on 22-Sep-89 by GSCOTT
;Prevent two systems from using a shared tape drive at the same time by
;returning OPNX32 (OPENF%) or ASNDX4 (ASND%).
; Edit= 9103 to JSYSF.MAC on 8-Jun-89 by GSCOTT
;Make proper check for both tape names the same when setting the first one at
;SET1ST in ARCF JSYS. 
; Edit= 9086 to JSYSF.MAC on 7-Apr-89 by GSCOTT
;Bug in edit 9077 caused extra punctuation on devices like NUL: and LPT:. 
; Edit= 9081 to JSYSF.MAC on 14-Mar-89 by GSCOTT
;Move a little JFNS code around to prevent calling JFNSAT while CSKED. 
; Edit= 9078 to JSYSF.MAC on 9-Mar-89 by GSCOTT
;PWDICT had a fencepost error causing 39 character passwords to be illegal.
; Edit= 9077 to JSYSF.MAC on 9-Mar-89 by GSCOTT
;Perform major surgery on JFNS to fix hangs and other bugs. 
; Edit= 9073 to JSYSF.MAC on 28-Feb-89 by RASPUZZI
;Yet another spot I forgot to use UNLOCK/LOCK for the JFN lock and file lock.
;Discovered while using TV. Your welcome, Sam. JFNS% is going to need a
;rewrite.
; Edit= 9063 to JSYSF.MAC on 26-Jan-89 by GSCOTT
;Always call ACJ when FB%SEC bit changes on a file.
; Edit= 9060 to JSYSF.MAC on 17-Jan-89 by RASPUZZI
;Let someone expire a password by setting the password expiration date and
;time to -1 in CRDPED. I didn't take into account this case in edit 9050,
;shame on me.
; Edit= 9054 to JSYSF.MAC on 10-Jan-89 by GSCOTT
;Search SYSTEM:PASSWORD.DICTIONARY when setting passwords to help prevent
;users from setting easily guessed passwords. 
; Edit= 9052 to JSYSF.MAC on 5-Jan-89 by RASPUZZI
;Clear the .CDPSW, .CDUGP and .CDDGP words for the ACJ if a user is clearing
;any of them. This is a hint so the ACJ can aid in determining if someone is
;compromising the system (ROOT-DIRECTORY in particular).
; Edit= 9050 to JSYSF.MAC on 5-Jan-89 by RASPUZZI
;Add code to check password expiration date and time setting so one can not
;set it too far in the future with the password expiration feature enabled.
; Edit= 9049 to JSYSF.MAC on 29-Dec-88 by RASPUZZI
;Have .GOCFD pass the .FBCTL bits instead of just 0 or 1. Also, have .GOOPN
;indicate to the ACJ whether the file being opened is new or not.
; Edit= 9046 to JSYSF.MAC on 22-Dec-88 by RASPUZZI
;Prevent RESCHK BUGHLTs by making sure we have the right size for freespace
;blocks!
; Edit= 9041 to JSYSF.MAC on 13-Dec-88 by RASPUZZI
;Finish off some of the security features that were started at one time (like
;password expiration). Also, add new features to help a system manager secure
;the system.
; Edit= 9025 to JSYSF.MAC on 8-Nov-88 by LOMARTIRE
;Merge Production changes to BUG text
; Edit= 8901 to JSYSF.MAC on 12-Aug-88 by RASPUZZI
;Update BUG. documentation.
; Edit= 8856 to JSYSF.MAC on 5-Jul-88 by GSCOTT
;Insure that no partial directory is built when CRDIR bombs in new directory. 
; Edit= 8844 to JSYSF.MAC on 19-May-88 by GSCOTT (TCO 7.1290)
;Prevent <OPERATOR> directory from getting full of zeroes when a new structure
;is created and minimum password length is greater than 6 by not checking
;minimum password length when CRDIR called from monitor mode. 
; Edit= 8831 to JSYSF.MAC on 15-Apr-88 by RASPUZZI
;Prevent bad error messages from JFNS% when COPYing from TTY:. Seems we are
;leaving the FILLCK set because UNLCKF does not undo FILLCK for TTYs. Make
;sure FILLCK is cleared before exitting JFNS%.
; Edit= 8829 to JSYSF.MAC on 14-Apr-88 by RASPUZZI
;Prevent more hung jobs by having JFNS% release the FILLCK along with the
;JFNLCK before potentially page faulting.
; Edit= 8820 to JSYSF.MAC on 7-Apr-88 by RASPUZZI
;Mr. VANISH is back! Fix yet another hung job case where JFNS% is using a copy
;on write page to barf the file name into. Release the JFNLCK before
;outputting characters.
; Edit= 8817 to JSYSF.MAC on 31-Mar-88 by RASPUZZI
;Prevent hung jobs because edit 8801 missed to exit points of JFNS% in the
;attribute handling routine.
; Edit= 8811 to JSYSF.MAC on 29-Mar-88 by RASPUZZI, for SPR #21880
;Install edit 8804 into 7.0 monitor. Note, there is no bug here, it has been
;installed to protect the monitor's innocence for later editting in case
;someone gets into edit 3062 dangerousness.
; Edit= 8801 to JSYSF.MAC on 17-Mar-88 by RASPUZZI
;Prevent ILMNRFs or RELBADs by having GNJFN% and JFNS% use the JFNLCK when
;dealing with important information in the JFN block. 
; UPD ID= 8684, RIP:<7.MONITOR>JSYSF.MAC.17,  17-Mar-88 19:12:21 by RASPUZZI
;TCO 7.1257 - Make DIRINI entry point for CRDIR%.
; UPD ID= 8665, RIP:<7.MONITOR>JSYSF.MAC.16,  24-Feb-88 17:40:48 by RASPUZZI
;More of TCO 7.1231 - Move CHPLEN out of the way of the mainline of code.
; UPD ID= 8650, RIP:<7.MONITOR>JSYSF.MAC.15,  18-Feb-88 15:33:40 by RASPUZZI
;TCO 7.1231 - Make CRDIR% enforce a minimum password length if it is
;	      set for the system.
; UPD ID= 8535, RIP:<7.MONITOR>JSYSF.MAC.14,   9-Feb-88 16:24:27 by GSCOTT
;TCO 7.1218 - Update copyright date.
; UPD ID= 8420, RIP:<7.MONITOR>JSYSF.MAC.13,   4-Feb-88 12:28:58 by GSCOTT
;TCO 7.1210 - Set CRDBAK, CRDBK1, DELBDD normally not dumpable.
; UPD ID= 8360, RIP:<7.MONITOR>JSYSF.MAC.11,  21-Jan-88 14:31:29 by EVANS
;TCO 7.1192 - Increase size of JSBVAR created by edit 7461, so we
;		don't overflow it and ILMNRF; also tell SOUT% how much to copy.
; UPD ID= 8342, RIP:<7.MONITOR>JSYSF.MAC.10,  15-Jan-88 10:56:51 by RASPUZZI
;TCO 7.1181 - Fix fencepost error in TCO 7.1044. Adjust count of words
;             initialized by RFTAD% before doing initialization.
; UPD ID= 248, RIP:<7.MONITOR>JSYSF.MAC.9,   4-Nov-87 16:40:52 by MCCOLLUM
;TCO 7.1112 - Fix up DELDIR, RCNUM, RCUSR% and SFUS10 to use LGSIDX
; UPD ID= 150, RIP:<7.MONITOR>JSYSF.MAC.8,  29-Sep-87 18:22:46 by MCCOLLUM
;More of TCO 7.1063 - Fix up misuse of STRSTS field in CRDIR%
; UPD ID= 129, RIP:<7.MONITOR>JSYSF.MAC.7,  23-Sep-87 15:44:52 by MCCOLLUM
;TCO 7.1063 - Check for STRX10 in CHFDB%, DELNF%, GTFDB%, RCDIR%, and SIZEF%.
; UPD ID= 118, RIP:<7.MONITOR>JSYSF.MAC.6,  17-Sep-87 17:54:31 by GSCOTT
;TCO 7.1059 - Preserve byte counts of 34359738367(36) used by COBOL
; UPD ID= 109, RIP:<7.MONITOR>JSYSF.MAC.5,  15-Sep-87 16:08:15 by RASPUZZI
;TCO 7.1055 - Before we delete a directory, we must uncache all OFNs that
;were refering to it so CFS will not allow the allocation token to be
;used for 2 resources.
; UPD ID= 92, RIP:<7.MONITOR>JSYSF.MAC.4,  28-Aug-87 09:05:21 by RASPUZZI
;TCO 7.1044 - Make sure that the RFTAD% JSYS can handle 30-bit argument
;blocks passed in from the user.
; UPD ID= 38, RIP:<7.MONITOR>JSYSF.MAC.3,  14-Jul-87 14:15:56 by RASPUZZI
;TCO 7.1020 - Don't allow non-WHEELs to set the password expiration date
;or the password usage count word in CRDIR%.
; *** Edit 7475 to JSYSF.MAC by EVANS on 4-May-87
; Change sense of test so as not to skip over new code.
; *** Edit 7461 to JSYSF.MAC by EVANS on 28-Apr-87, for SPR #19914
; Do not allow removal of Subdirectory-user-group-allowed if subdirectory has
; it as a current User Group 
; *** Edit 7460 to JSYSF.MAC by MCCOLLUM on 27-Apr-87, for SPR #21382
; In CLZFF6, call UNLCKF to unlock file and go OKINT instead of the
; OKINT/LUNLK0 combination. UNLCKF does the right thing for different types of
; JFNs. 
; *** Edit 7453 to JSYSF.MAC by THOUMIRE on 16-Apr-87
; Replace Comment line for edit 7451 
; *** Edit 7451 to JSYSF.MAC by THOUMIRE on 16-Apr-87, for SPR #21237
; Check if file is closed at UFPGS to prevent CFNLTK Bughlt
; *** Edit 7448 to JSYSF.MAC by MCCOLLUM on 14-Apr-87, for SPR #21382
; Do an OKINT in CLZFF6 to balance the NOINT done for a file lock in CHKJFD 
; *** Edit 7440 to JSYSF.MAC by RASPUZZI on 7-Apr-87, for SPR #21583
; Prevent ILMNRF BUGHLTs in CRDIR% by ignoring "quota exceeded" from PAGEM when
; the allocation is equal to file pages (directory creation is supposed to be
; free).
; *** Edit 7384 to JSYSF.MAC by MCCOLLUM on 15-Oct-86, for SPR #21288
; Add ASGF2 to FILST1. This bit should ALWAYS shadow the state of ASGF in
; FILSTS 
; *** Edit 7372 to JSYSF.MAC by RASPUZZI on 3-Oct-86
; TTPINI is now in GLOBS. We don't need it in EXTN. 
; *** Edit 7365 to JSYSF.MAC by RASPUZZI on 16-Sep-86, for SPR #21264
; Make sure ASND% sets up XON/XOFF recognition like OPENF% does for TTY device
; designators. 
; *** Edit 7355 to JSYSF.MAC by RASPUZZI on 20-Aug-86, for SPR #20454
; Make JFNS% print out 16-Nov-1858 19:00:00 correctly.
; *** Edit 7351 to JSYSF.MAC by EVANS on 12-Aug-86, for SPR #21270
; Remove edit 7117 - do not check for unmounted structure in RCDIR; RE edit 3045 to
; EXEC.
; *** Edit 7321 to JSYSF.MAC by WONG on 17-Jun-86, for SPR #20898 (TCO none)
; Rewrite .SFPTR JSYS to include LSN in its calculation of the byte count if
; bit SF%LSN is on.
; *** Edit 7304 to JSYSF.MAC by EVANS on 28-May-86, for SPR #20545
; Check for second opening bracket in wildcarded directory spec to prevent
; commands involving such a spec from appearing to hang.
; *** Edit 7276 to JSYSF.MAC by DMCDANIEL on 27-Mar-86, for SPR #20527
; Put in code to check JFNS flags to see if it needs to write a tab or not. 
; *** Edit 7253 to JSYSF.MAC by LOMARTIRE on 5-Mar-86, for SPR #21029
; Make .DELNF honor the FB%NDL bit 
; *** Edit 7207 to JSYSF.MAC by WAGNER on 9-Dec-85
; Fix RETRIEVAL so that multiple requests do not result in failures due to lack
; of free space. Reduce incidence of FSPOUT BUGINFs. 
; *** Edit 7196 to JSYSF.MAC by WONG on 19-Nov-85, for SPR #20883
; Fix JSYS FFUFP to return the correct error when JSB is full 
; Edit 7162 to JSYSF.MAC by PALMIERI on 21-Oct-85, for SPR #20445 (TCO 6.1.1539)
; Make WILD% understand OWGBPs.
; Edit 7161 to JSYSF.MAC by MAYO on 18-Oct-85 (TCO 6-1-1538)
; Allow modification of .FBBK1 by WHEEL users. 
; UPD ID= 2327, SNARK:<6.1.MONITOR>JSYSF.MAC.80,   6-Sep-85 12:25:51 by LOMARTIRE
;More TCO 6.1.1535 - Do not clobber T2 in SIZEF%
; UPD ID= 2325, SNARK:<6.1.MONITOR>JSYSF.MAC.79,   5-Sep-85 10:00:23 by LOMARTIRE
;TCO 6.1.1535 - Make CHFDB% broadcast EOF and make SIZEF% inquire about EOF
; Edit 7117 to JSYSF.MAC by EVANS on 8-Aug-85 (TCO none)
;      Do not display every dir name on expunge unmounted structure;
;      catch the error earlier, in RCDIR. This replaces edit 3060.
; Edit 7107 to JSYSF.MAC by LOMARTIRE on 26-Jul-85 (TCO 6-2192 )
; Add all the intended functionality of TCO 6.2192 
; Edit 7105 to JSYSF.MAC by MAYO on 25-Jul-85, for SPR #18595 (TCO 6-1-1499)
; Have ARCF% .ARDIS clear ALL the offline data when both tape pointers are
; cleared.
; Edit 7104 to JSYSF.MAC by MAYO on 24-Jul-85, for SPR #19052
; ARCF% .ARSST function should not check FB%NOD. Remove the test.
; Edit 7103 to JSYSF.MAC by LOMARTIRE on 24-Jul-85, for SPR #20325
; Make KILLing a new directory avoid races and directory damage
; UPD ID= 2093, SNARK:<6.1.MONITOR>JSYSF.MAC.78,   3-Jun-85 14:49:19 by MCCOLLUM
;TCO 6.1.1406  - Update copyright notice.
; UPD ID= 1969, SNARK:<6.1.MONITOR>JSYSF.MAC.77,  13-May-85 17:10:41 by GLINDELL
;TCO 6.1.1381 - fix SWJFN% for DECNET JFN's
; UPD ID= 1947, SNARK:<6.1.MONITOR>JSYSF.MAC.76,   9-May-85 17:12:51 by MCCOLLUM
;TCO 6.1.1238 - Fix more BUG. documentation
; UPD ID= 1884, SNARK:<6.1.MONITOR>JSYSF.MAC.75,   4-May-85 14:21:11 by MCCOLLUM
;TCO 6.1.1238 - Fix more BUG. documentation
; UPD ID= 1820, SNARK:<6.1.MONITOR>JSYSF.MAC.74,  24-Apr-85 19:54:30 by MCCOLLUM
;TCO 6.1.1238 - Fix more BUG. documentation
; UPD ID= 1714, SNARK:<6.1.MONITOR>JSYSF.MAC.73,   5-Apr-85 14:05:27 by MCCOLLUM
;TCO 6.1.1238 - Fix BUG. documentation
; UPD ID= 1566, SNARK:<6.1.MONITOR>JSYSF.MAC.72,  25-Feb-85 13:47:40 by WAGNER
;TCO 6.1.1219 - Do not allow negative quotas in directories, QAR 706383
; UPD ID= 1401, SNARK:<6.1.MONITOR>JSYSF.MAC.71,  24-Jan-85 16:41:53 by LOMARTIRE
;TCO 6.1.1132 - Prevent LCKDIRs from edit 2612 via RCUSR%
; UPD ID= 1400, SNARK:<6.1.MONITOR>JSYSF.MAC.70,  24-Jan-85 14:58:25 by LOMARTIRE
;TCO 6.2192 - Make DELETE, KEEP work with temp files of low generation
; UPD ID= 1398, SNARK:<6.1.MONITOR>JSYSF.MAC.69,  23-Jan-85 16:34:39 by HAUDEL
;TCO 6.1.1154 -  Add an ERJMPR after a RPACS%.
; UPD ID= 1366, SNARK:<6.1.MONITOR>JSYSF.MAC.68,  21-Jan-85 10:03:50 by MAYO
;tco 6.1.1147 - Have ARCF% discard function clear AR%WRN
; UPD ID= 1284, SNARK:<6.1.MONITOR>JSYSF.MAC.66,   7-Jan-85 16:23:44 by MCCOLLUM
;TCO 6.1.1118 - Don't CALL UPDDIR for ARCF% function .ARGST
; UPD ID= 4960, SNARK:<6.MONITOR>JSYSF.MAC.65,  18-Oct-84 15:46:51 by TBOYLE
;TCO 6.2244 (QAR 706222) - Make indexed byte pointers work for WILD%
; UPD ID= 4812, SNARK:<6.MONITOR>JSYSF.MAC.64,  17-Sep-84 10:02:11 by PURRETTA
;Update copyright notice
; UPD ID= 4774, SNARK:<6.MONITOR>JSYSF.MAC.63,  29-Aug-84 17:23:10 by TBOYLE
;TCO 6.2206 (QAR 706154) CHFDB WHELX1 error when needed.
; UPD ID= 4668, SNARK:<6.MONITOR>JSYSF.MAC.62,   8-Aug-84 15:29:03 by LEACHE
;TCO 6.2166 Fix problem in CRDIR PPN uniqueness check
; UPD ID= 4454, SNARK:<6.MONITOR>JSYSF.MAC.61,  12-Jul-84 10:38:23 by CDUNN
;More TCO 6.1127 Make call to SCSKIL in CLZFF% conform to new caller sequence
; UPD ID= 4294, SNARK:<6.MONITOR>JSYSF.MAC.60,   4-Jun-84 14:05:08 by TBOYLE
;TCO 6.2080 - Fix PPN setting on structure creation. At CRD3BC.
; UPD ID= 4248, SNARK:<6.MONITOR>JSYSF.MAC.59,  29-May-84 17:06:06 by TBOYLE
;TCO 6.2070 - Check NETN before calling RElIQ% in CLZFF% - QAR #706001
; UPD ID= 4049, SNARK:<6.MONITOR>JSYSF.MAC.58,   5-Apr-84 08:33:18 by PAETZOLD
;TCO 6.2022 - Remove call to MSTKOV as we now have global stack pointers.
; UPD ID= 4028, SNARK:<6.MONITOR>JSYSF.MAC.57,  31-Mar-84 20:26:46 by GRANT
;Remove definitions for FTCI, FTKLIPA, and CFSCOD
; UPD ID= 4020, SNARK:<6.MONITOR>JSYSF.MAC.56,  31-Mar-84 16:20:28 by PAETZOLD
;TCO 6.2019 - Use ADJSPs
; UPD ID= 3933, SNARK:<6.MONITOR>JSYSF.MAC.55,  15-Mar-84 17:45:50 by TGRADY
;TCO 6.2001 - Fix to last edit, don't call LCL2GL with invalid job index
; UPD ID= 3923, SNARK:<6.MONITOR>JSYSF.MAC.54,  14-Mar-84 10:50:47 by TGRADY
;TCO 6.1997 - Fix .DVCHR to return the global job number of the job that
; has the device assigned.
;
; UPD ID= 3486, SNARK:<6.MONITOR>JSYSF.MAC.53,  20-Jan-84 07:44:44 by MCINTEE
;TCO 6.1932 - JFNS%: allow password attribute to be returned when parse only.
; UPD ID= 3222, SNARK:<6.MONITOR>JSYSF.MAC.52,  28-Nov-83 11:00:49 by GLINDELL
;TCO 6.1882 - Allow MTOPR without JFN open if D1%MTO set for device
; UPD ID= 3188, SNARK:<6.MONITOR>JSYSF.MAC.51,  17-Nov-83 16:22:26 by CDUNN
;More TCO 6.1127 - Remove SCSKIL's dependancy on TRVAR in .CLZFF code.
; UPD ID= 3101, SNARK:<6.MONITOR>JSYSF.MAC.50,   4-Nov-83 17:00:54 by TSANG
;TCO 6.1807 - Update byte pointer in AC2 after .SFUST JSYS.
; UPD ID= 3087, SNARK:<6.MONITOR>JSYSF.MAC.48,  31-Oct-83 16:54:48 by CJOHNSON
;TCO 6.1845 - Add new error CFDBX5 for non disk CHFDB calls
; UPD ID= 3022, SNARK:<6.MONITOR>JSYSF.MAC.47,  10-Oct-83 17:31:46 by MOSER
;TCO 6.1747 - ALLOW WRITER TO CHFDB FB%FCF - MAKE BITS CONSISTENT FOR WHEELS
; UPD ID= 2982, SNARK:<6.MONITOR>JSYSF.MAC.46,   4-Oct-83 15:58:36 by TBOYLE
;TCO 6.1803 DELDI4 to call REMSDR for special dirs.
; UPD ID= 2954, SNARK:<6.MONITOR>JSYSF.MAC.45,  28-Sep-83 16:21:02 by MOSER
;TCO 6.1726 - MAKE CHFDB WORK FOR NEWLY CREATED FILE
; UPD ID= 2895, SNARK:<6.MONITOR>JSYSF.MAC.44,  16-Sep-83 08:44:06 by TBOYLE
;TCO 6.1799 - Don't check superior's quota if LIQ not being set by CRDIR%
; UPD ID= 2827, SNARK:<6.MONITOR>JSYSF.MAC.43,  11-Aug-83 15:34:14 by CDUNN
;More TCO 6.1127 - Add comment to CLZFF indicating SCSJSY dependancy on
;TRVAR in CLZFF
; UPD ID= 2796, SNARK:<6.MONITOR>JSYSF.MAC.42,   4-Aug-83 00:30:07 by LEACHE
;TCO 6.1641 Move swappable freespace out of section zero
; UPD ID= 2703, SNARK:<6.MONITOR>JSYSF.MAC.41,  18-Jul-83 16:13:58 by JCAMPBELL
;TCO 6.1729 - Allow CHFDB to modify FB%FOR (FORTRAN data) in .FBCTL in FDB.
; UPD ID= 2442, SNARK:<6.MONITOR>JSYSF.MAC.40,   6-May-83 13:34:51 by CHALL
;TCO 6.1644 - MORE TOPS-10 PPN STUFF - APPROVE A PPN OF 0,,0 (IE, NO PPN)
; UPD ID= 2285, SNARK:<6.MONITOR>JSYSF.MAC.39,  16-Apr-83 19:14:09 by PAETZOLD
;TCO 6.1557 - TCP Merge - Update copyright - Delete very old edit history.
; UPD ID= 2175, SNARK:<6.MONITOR>JSYSF.MAC.38,   6-Apr-83 07:16:31 by FLEMMING
; UPD ID= 2133, SNARK:<6.MONITOR>JSYSF.MAC.37,   2-Apr-83 22:50:20 by LEACHE
;TC0 6.1247 Add more password encryption
; UPD ID= 2104, SNARK:<6.MONITOR>JSYSF.MAC.36,  28-Mar-83 17:46:19 by MILLER
;TCO 6.1094. Don't need GETALF anymore
; UPD ID= 2100, SNARK:<6.MONITOR>JSYSF.MAC.35,  28-Mar-83 17:39:47 by MURPHY
;TCO 6.1472 - Minor cleanup re. LSTERR.
; UPD ID= 1924, SNARK:<6.MONITOR>JSYSF.MAC.34,   7-Mar-83 20:38:01 by CDUNN
;Make default be to get KLIPA code but not CI simulator code or CFS code
; UPD ID= 1918, SNARK:<6.MONITOR>JSYSF.MAC.33,   7-Mar-83 14:30:57 by WEETON
;TCO 6.1534 - Allow wild cards in logical names of directorys
; UPD ID= 1871, SNARK:<6.MONITOR>JSYSF.MAC.32,  23-Feb-83 15:13:22 by MAYO
;TCO 6.1524. Fix off by one at .ARCF+6 (edit 2918 to 5.1)
; UPD ID= 1806, SNARK:<6.MONITOR>JSYSF.MAC.31,  14-Feb-83 18:40:52 by MILLER
;TCO 6.1094. Improve call to GETALF
; UPD ID= 1778, SNARK:<6.MONITOR>JSYSF.MAC.30,  10-Feb-83 05:46:36 by CDUNN
;More TCO 6.1127 Add support to CLZFF% for cleaning up SCS% data
; UPD ID= 1708, SNARK:<6.MONITOR>JSYSF.MAC.29,  27-Jan-83 20:14:47 by MILLER
;TCO 6.1094. Code to do CFS directory allocation
; UPD ID= 1555, SNARK:<6.MONITOR>JSYSF.MAC.28,  21-Dec-82 11:25:19 by MAYO
;Edit 2612 - Fix RCUSR to return RC%NMD if trying to step non-wild string.
; UPD ID= 1518, SNARK:<6.MONITOR>JSYSF.MAC.27,   7-Dec-82 20:47:45 by COBB
;TCO 5.1.1112 - Check READF in SMAP%. -- on behalf of MURPHY
; UPD ID= 1508, SNARK:<6.MONITOR>JSYSF.MAC.26,   2-Dec-82 09:24:41 by MOSER
;TCO 6.1201 - RETURN CFDBX3 WHEN APPROPRIATE
; UPD ID= 1447, SNARK:<6.MONITOR>JSYSF.MAC.25,  16-Nov-82 14:00:57 by LOMARTIRE
;TCO 6.1358 - Add documentation to DELBDD BUGINF
; UPD ID= 1420, SNARK:<6.MONITOR>JSYSF.MAC.24,   5-Nov-82 15:07:43 by LEACHE
;TCO 6.1348 Fix use of password encryption version number
; UPD ID= 1252, SNARK:<6.MONITOR>JSYSF.MAC.23,  28-Sep-82 08:15:02 by MCINTEE
;The edit made on 21-Sep-82 was wiped out. Restore it !!
; UPD ID= 1244, SNARK:<6.MONITOR>JSYSF.MAC.22,  26-Sep-82 15:13:24 by LEACHE
;More 6.1247 Use T1 in call to CHKPEV
; UPD ID= 1241, SNARK:<6.MONITOR>JSYSF.MAC.21,  24-Sep-82 15:21:19 by LEACHE
;TCO 6.1247 - Add password encryption
; UPD ID= 1236, SNARK:<6.MONITOR>JSYSF.MAC.20,  24-Sep-82 12:26:12 by MILLER
;TCO 5.1.1070. Set GJ%ACC in CRDIR's GTJFN block
; UPD ID= 1207, SNARK:<6.MONITOR>JSYSF.MAC.19,  21-Sep-82 14:41:28 by MCINTEE
;TCO 6.1030 - DVCHR% correction
; UPD ID= 1108, SNARK:<6.MONITOR>JSYSF.MAC.18,  25-Aug-82 08:11:42 by MCINTEE
;TCO 6.1030 - Make CRDCMP global
; UPD ID= 1103, SNARK:<6.MONITOR>JSYSF.MAC.17,  23-Aug-82 12:59:21 by MCINTEE
;TCO 6.1230 - remote aliases support for CRDIR%
; UPD ID= 986, SNARK:<6.MONITOR>JSYSF.MAC.16,  13-Jul-82 15:49:40 by MCINTEE
;More of previous edit.
; UPD ID= 976, SNARK:<6.MONITOR>JSYSF.MAC.15,   6-Jul-82 16:12:55 by MCINTEE
;More TCO 6.1030 - Make DVCHR work for NFT device JFNs.
; UPD ID= 971, SNARK:<6.MONITOR>JSYSF.MAC.14,  30-Jun-82 11:17:00 by WALLACE
;TCO 6.1181 - Make JFNS% output all linked attributes for parse only JFN's
; UPD ID= 884, SNARK:<6.MONITOR>JSYSF.MAC.13,   9-Jun-82 16:02:02 by MCINTEE
;TCO 6.1030 - change some MDDOKs to DSKOK
; UPD ID= 846, SNARK:<6.MONITOR>JSYSF.MAC.12,   6-Jun-82 13:27:18 by MURPHY
;TCO 6.1147 - Move bugdefs from BUGS.MAC to here and put them in-line.
; UPD ID= 647, SNARK:<6.MONITOR>JSYSF.MAC.11,  15-Apr-82 15:55:11 by PAETZOLD
;TCO 5.1775 - Make UFPGS performance for short files improve
; UPD ID= 550, SNARK:<6.MONITOR>JSYSF.MAC.10,  24-Mar-82 10:32:53 by COBB
;TCO 5.1769 - Check for stepping directories at RCD550 to avoid LCKDIR bughalt
; UPD ID= 515, SNARK:<6.MONITOR>JSYSF.MAC.8,  16-Mar-82 20:34:16 by PAETZOLD
;TCO 5.1758 - Check SFTAD count
; UPD ID= 299, SNARK:<6.MONITOR>JSYSF.MAC.7,  14-Jan-82 08:58:32 by MCINTEE
;TCO 6.1056 - node control field in JFNS
; UPD ID= 277, SNARK:<6.MONITOR>JSYSF.MAC.6,   5-Jan-82 20:35:22 by MILLER
;TCO 6.1053. ALLOW WHOPER TO CHANGE FB%WNC
; UPD ID= 215, SNARK:<6.MONITOR>JSYSF.MAC.5,  20-Nov-81 16:46:36 by MCINTEE
;correction of TCO 6.1030; in DVCHR% change MDDOK to DSKOK
; UPD ID= 142, SNARK:<6.MONITOR>JSYSF.MAC.4,  19-Oct-81 16:06:52 by COBB
;TCO 6.1029 - CHANGE SE1CAL TO EA.ENT
; UPD ID= 115, SNARK:<6.MONITOR>JSYSF.MAC.3,  16-Oct-81 17:34:01 by MURPHY
;TCO 6.1030 - Node names in filespecs; etc.
; UPD ID= 97, SNARK:<6.MONITOR>JSYSF.MAC.2,   8-Oct-81 11:55:49 by MURPHY
;TCO 6.1028 - Fix bugs in CRDIR% checking of offline expiration date.
; UPD ID= 186, SNARK:<5.MONITOR>JSYSF.MAC.25,  16-Sep-81 15:36:44 by DONAHUE
;TCO 5.1513 - Increment subdirectory count in <ROOT-DIRECTORY> on CRDIR%
; UPD ID= 164, SNARK:<5.MONITOR>JSYSF.MAC.24,  10-Sep-81 14:41:29 by PAETZOLD
;TCO 5.1481 - Check for non-seven bit OWGBP's in JSYS calls
; UPD ID= 82, SNARK:<5.MONITOR>JSYSF.MAC.22,  27-Jul-81 15:19:54 by GROUT
; UPD ID= 54, SNARK:<5.MONITOR>JSYSF.MAC.21,  21-Jul-81 11:39:40 by GROUT
;TCO 5.1425 - Fix .RCUSR/.RCDIR for wild strings and .RCUSR for access checking
; UPD ID= 37, SNARK:<5.MONITOR>JSYSF.MAC.20,  16-Jul-81 10:55:56 by DONAHUE
;TCO 5.1413 - Return byte pointer to user at JFNSZ-2
; UPD ID= 2074, SNARK:<5.MONITOR>JSYSF.MAC.19,  25-May-81 11:33:03 by ZIMA
;TCO 5.1348 - Fix SIBE for LSTERR conditions.
; UPD ID= 2058, SNARK:<5.MONITOR>JSYSF.MAC.18,  21-May-81 11:04:50 by SCHMITT
;Tco 5.1340 - Release JFN if CHKOFN fails at DELDI6: + 20L
; UPD ID= 2033, SNARK:<5.MONITOR>JSYSF.MAC.17,  19-May-81 14:09:31 by ZIMA
;Correct typo in previous edit...
; UPD ID= 2006, SNARK:<5.MONITOR>JSYSF.MAC.16,  15-May-81 00:07:40 by ZIMA
;TCO 5.1329 - Recode GTSTS to consistently return status bits.
; UPD ID= 1981, SNARK:<5.MONITOR>JSYSF.MAC.15,  12-May-81 23:25:18 by ZIMA
;TCO 5.1323 - Fix CRDIR to preserve MAIL.TXT attributes - create only on
; directory creation.
; UPD ID= 1913, SNARK:<5.MONITOR>JSYSF.MAC.13,  30-Apr-81 16:49:13 by CHALL
;Make FB%NDL require operator/wheel privs
; UPD ID= 1508, SNARK:<5.MONITOR>JSYSF.MAC.12,  30-Jan-81 16:32:48 by ZIMA
;TCO 5.1255 - rewrite SACTF JSYS to fix GNJFN side-effects and other bugs.
; UPD ID= 1488, SNARK:<5.MONITOR>JSYSF.MAC.11,  25-Jan-81 01:26:36 by ZIMA
;TCO 5.1243 - Fix CRDIR to work with -1,,ADR pointer to password again.
; UPD ID= 1446, SNARK:<5.MONITOR>JSYSF.MAC.10,  15-Jan-81 15:58:24 by FLEMMING
;add code for SMAP/RSMAP
; UPD ID= 1304, SNARK:<5.MONITOR>JSYSF.MAC.9,  21-Nov-80 10:26:16 by DONAHUE
;TCO 5.1200 - Make ARACCK check for EXE access requested
; UPD ID= 1087, SNARK:<5.MONITOR>JSYSF.MAC.8,   1-Oct-80 12:06:29 by MURPHY
;FIX ACVAR
; UPD ID= 1008, SNARK:<5.MONITOR>JSYSF.MAC.7,  11-Sep-80 18:26:54 by GRANT
;Change MONX01 to MONX02 in .FFFFP routines
; UPD ID= 964, SNARK:<5.MONITOR>JSYSF.MAC.6,  25-Aug-80 16:27:47 by ENGEL
;TCO 5.1136 - ADD DEVLKK
; UPD ID= 756, SNARK:<5.MONITOR>JSYSF.MAC.5,  14-Jul-80 13:15:13 by GRADY
; Corrrection for TCO 5.1081, call USTDIR when CRDI19 error given.
; UPD ID= 713, SNARK:<5.MONITOR>JSYSF.MAC.4,  30-Jun-80 13:57:18 by GRADY
; UPD ID= 697, SNARK:<5.MONITOR>JSYSF.MAC.3,  25-Jun-80 17:05:26 by GRADY
; TCO 5.1081 - Recover FDB index in CHFDB1 before trying to use it.
; UPD ID= 684, SNARK:<5.MONITOR>JSYSF.MAC.2,  21-Jun-80 11:51:44 by SCHMITT
;TCO 5.1073 - Use TPRCYC for Def file Offline Exp if set at DIRINI+60L
; UPD ID= 279, SNARK:<4.1.MONITOR>JSYSF.MAC.115,  20-Feb-80 09:13:00 by MILLER
; UPD ID= 276, SNARK:<4.1.MONITOR>JSYSF.MAC.114,  19-Feb-80 11:02:20 by MILLER
;TCO 4.1.1083. MAKE CZ%ARJ BE FORCED CLOSE IF FROM LOGOUT
; UPD ID= 121, SNARK:<4.1.MONITOR>JSYSF.MAC.113,  10-Dec-79 11:35:49 by SANICHARA
; TCO 4.1.1053 - Restore file status properly before call to UNLCKF
; UPD ID= 82, SNARK:<4.1.MONITOR>JSYSF.MAC.112,   3-Dec-79 13:22:39 by SCHMITT
;TCO 4.1.1041 - Allow SWJFN JSYS to swap entire JFN blocks
; UPD ID= 63, SNARK:<4.1.MONITOR>JSYSF.MAC.111,  30-Nov-79 09:35:36 by MILLER
;FIX BLOCKING IN CLZFF2 WHEN MAP COUNT IS NON-ZERO
; UPD ID= 23, SNARK:<4.1.MONITOR>JSYSF.MAC.110,  27-Nov-79 14:20:26 by DBELL
;TCO 4.1.1032 - FIX SFTAD TO ALLOW SETTING INTERVALS PROPERLY.
;<4.1.MONITOR>JSYSF.MAC.109, 26-Nov-79 11:04:19, EDIT BY MILLER
;TCO 4.1.1026. LOCK FILLCK IN JFNDCR AND IN CLZMRC

;	COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1976, 1990.
;	ALL RIGHTS RESERVED.
;
;	THIS SOFTWARE IS FURNISHED UNDER A  LICENSE AND MAY BE USED AND  COPIED
;	ONLY IN  ACCORDANCE  WITH  THE  TERMS OF  SUCH  LICENSE  AND  WITH  THE
;	INCLUSION OF THE ABOVE  COPYRIGHT NOTICE.  THIS  SOFTWARE OR ANY  OTHER
;	COPIES THEREOF MAY NOT BE PROVIDED  OR OTHERWISE MADE AVAILABLE TO  ANY
;	OTHER PERSON.  NO  TITLE TO  AND OWNERSHIP  OF THE  SOFTWARE IS  HEREBY
;	TRANSFERRED.
;
;	THE INFORMATION IN THIS  SOFTWARE IS SUBJECT  TO CHANGE WITHOUT  NOTICE
;	AND SHOULD  NOT  BE CONSTRUED  AS  A COMMITMENT  BY  DIGITAL  EQUIPMENT
;	CORPORATION.
;
;	DIGITAL ASSUMES NO  RESPONSIBILITY FOR  THE USE OR  RELIABILITY OF  ITS
;	SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
	SEARCH PROLOG
	TTITLE JSYSF
	SWAPCD

;THIS FILE CONTAINS CODE WHICH IMPLEMENTS VARIOUS FILE JSYSES.
;ONLY JSYSES WHICH REQUIRE ONE OR MORE OF THE FILE-SPECIFIC AC
;DEFINITIONS (JFN, STS, ETC.) ARE HERE.

PPNLH==:4			;SYSTEM DEFINED PPN LHS


;FIRST PORTION OF THE FILE CONTAINES MISC SUBROUTINES USED HEREIN.
;SECOND (MAJOR) PORTION CONTAINES JSYSES ORDERED ALPHABETICALLY

;SPECIAL AC DEFINITIONS USED HEREIN

DEFAC (STS,P1)			;SEE GTJFN FOR FUNCTIONS
DEFAC (JFN,P2)
DEFAC (DEV,P4)
DEFAC (F1,P5)

;ERROR RETURNS AND TRAPS

ERUNLD::CALL UNLCKF
	RETERR()
	Subttl	Table of Contents

;		     Table of Contents for JSYSF
;
;				  Section		      Page
;
;
;    1. Utility Routines
;        1.1    Set Byte Number  . . . . . . . . . . . . . . .   5
;        1.2    Set Byte Number  . . . . . . . . . . . . . . .   6
;        1.3    Reduce Map Count . . . . . . . . . . . . . . .   7
;        1.4    Check TTY JFNs . . . . . . . . . . . . . . . .   8
;        1.5    Change JFN Ownership . . . . . . . . . . . . .  11
;    2. ARCF JSYS  . . . . . . . . . . . . . . . . . . . . . .  12
;    3. ASND JSYS  . . . . . . . . . . . . . . . . . . . . . .  27
;    4. BKJFN JSYS . . . . . . . . . . . . . . . . . . . . . .  29
;    5. CHFDB JSYS . . . . . . . . . . . . . . . . . . . . . .  30
;    6. CLOSF JSYS . . . . . . . . . . . . . . . . . . . . . .  40
;    7. CLZFF JSYS . . . . . . . . . . . . . . . . . . . . . .  43
;    8. CRDIR JSYS . . . . . . . . . . . . . . . . . . . . . .  51
;    9. DELF JSYS  . . . . . . . . . . . . . . . . . . . . . . 140
;   10. DELNF JSYS . . . . . . . . . . . . . . . . . . . . . . 141
;   11. DSMNT JSYS . . . . . . . . . . . . . . . . . . . . . . 143
;   12. DVCHR JSYS . . . . . . . . . . . . . . . . . . . . . . 144
;   13. ERSTR JSYS support . . . . . . . . . . . . . . . . . . 148
;   14. FFFFP JSYS . . . . . . . . . . . . . . . . . . . . . . 149
;   15. FFUFP JSYS . . . . . . . . . . . . . . . . . . . . . . 153
;   16. GACTF JSYS . . . . . . . . . . . . . . . . . . . . . . 156
;   17. GDSTS JSYS . . . . . . . . . . . . . . . . . . . . . . 157
;   18. GFUST JSYS . . . . . . . . . . . . . . . . . . . . . . 158
;   19. GTFDB JSYS . . . . . . . . . . . . . . . . . . . . . . 160
;   20. GTSTS JSYS . . . . . . . . . . . . . . . . . . . . . . 162
;   21. INIDR JSYS . . . . . . . . . . . . . . . . . . . . . . 163
;   22. JFNS JSYS  . . . . . . . . . . . . . . . . . . . . . . 164
;       22.1    JFN Supplied . . . . . . . . . . . . . . . . . 166
;           22.1.1    Copy Filename  . . . . . . . . . . . . . 167
;           22.1.2    FDB Items of Disk JFN  . . . . . . . . . 172
;           22.1.3    Dates for Disk JFN . . . . . . . . . . . 176
;           22.1.4    Parse Only JFN . . . . . . . . . . . . . 177
;           22.1.5    Non-Disk non-Parse Only JFN  . . . . . . 178
;           22.1.6    Attributes . . . . . . . . . . . . . . . 179
;           22.1.7    Display Routines . . . . . . . . . . . . 182
;           22.1.8    Store String . . . . . . . . . . . . . . 183
;           22.1.9    Store Number . . . . . . . . . . . . . . 185
;           22.1.10   Store Character  . . . . . . . . . . . . 186
;           22.1.11   Unlock and Free Space Return . . . . . . 187
;       22.2    String Supplied  . . . . . . . . . . . . . . . 188
;       22.3    Global Subroutines . . . . . . . . . . . . . . 192
;   23. MOUNT JSYS . . . . . . . . . . . . . . . . . . . . . . 194
;   24. MTOPR JSYS . . . . . . . . . . . . . . . . . . . . . . 195
;   25. OPENF JSYS . . . . . . . . . . . . . . . . . . . . . . 197
;   26. RCDIR JSYS . . . . . . . . . . . . . . . . . . . . . . 209
;   27. RCUSR JSYS . . . . . . . . . . . . . . . . . . . . . . 226
;   28. RDDIR JSYS . . . . . . . . . . . . . . . . . . . . . . 232
	Subttl	Table of Contents (page 2)

;		     Table of Contents for JSYSF
;
;				  Section		      Page
;
;
;   29. RFBSZ JSYS . . . . . . . . . . . . . . . . . . . . . . 233
;   30. RFPTR JSYS . . . . . . . . . . . . . . . . . . . . . . 234
;   31. RFTAD JSYS . . . . . . . . . . . . . . . . . . . . . . 235
;   32. RLJFN JSYS . . . . . . . . . . . . . . . . . . . . . . 236
;   33. RNAMF JSYS . . . . . . . . . . . . . . . . . . . . . . 238
;   34. SACTF JSYS . . . . . . . . . . . . . . . . . . . . . . 241
;   35. SDSTS JSYS . . . . . . . . . . . . . . . . . . . . . . 244
;   36. SFBSZ JSYS . . . . . . . . . . . . . . . . . . . . . . 245
;   37. SFPTR JSYS . . . . . . . . . . . . . . . . . . . . . . 246
;   38. SFTAD JSYS . . . . . . . . . . . . . . . . . . . . . . 249
;   39. SFUST JSYS . . . . . . . . . . . . . . . . . . . . . . 250
;   40. SIBE JSYS  . . . . . . . . . . . . . . . . . . . . . . 253
;   41. SIZEF JSYS . . . . . . . . . . . . . . . . . . . . . . 254
;   42. SMAP JSYS support  . . . . . . . . . . . . . . . . . . 256
;   43. STDIR JSYS . . . . . . . . . . . . . . . . . . . . . . 258
;   44. STPPN JSYS . . . . . . . . . . . . . . . . . . . . . . 259
;   45. STSTS JSYS . . . . . . . . . . . . . . . . . . . . . . 260
;   46. SWJFN JSYS . . . . . . . . . . . . . . . . . . . . . . 261
;   47. UFPGS JSYS . . . . . . . . . . . . . . . . . . . . . . 262
;   48. WILD% JSYS . . . . . . . . . . . . . . . . . . . . . . 264
;   49. End of JSYSF . . . . . . . . . . . . . . . . . . . . . 270
	SUBTTL Utility Routines -- Set Byte Number

; Set file byte number common code
; Call:	A	; Byte number
;	CALL SFBNR
; Return
;	+1	; Error of some sort, error number in a
;	+2	; Success
; Clobbers most temps

SFBNR::	TQNN <RNDF>
	JRST [	MOVEI A,SFPTX2
		RET]		; Illegal to reset pointer for this file
	CAMN A,[-1]
	MOVE A,FILLEN(JFN)	; Set to end of file if -1
	JUMPL A,[MOVEI A,SFPTX3
		RET]		; Illegal byte number
	MOVEM A,FILBYN(JFN)
	TQZ <EOFF>
	TQNE <WRTF>		;FILE OPEN FOR WRITING?
	JRST [	CAML A,FILLEN(JFN) ;YES, POINTER SET BEYOND CURRENT END?
		CALL [	MOVEM A,FILLEN(JFN)
			CALLRET UPDLEN]	;UPDATE END
		JRST SFBNR1]
	CAML A,FILLEN(JFN)
	JRST [	CALL GETLEN	;GET REAL FILLEN
		CAML A,FILLEN(JFN)
		TQO <EOFF>
		JRST SFBNR1]	;EXIT
SFBNR1:	SETZM FILCNT(JFN)	;FORCE NEW WINDOW NEXT OPERATION
	RETSKP
	SUBTTL Utility Routines -- Set Byte Number

NFBSZ::	CAIE B,7		;IF USER SWITCHES TO NON-ASCII,
	TQO <PASLSN>		;THEN ASSUME IT'S NOT AN EDIT FILE
	MOVEI C,^D36
	IDIVM C,A		; Number of bytes per word
	MOVEI C,^D36
	IDIV C,B		; New number of bytes per word
	PUSH P,C
	IMUL C,FILBYN(JFN)	; Adjust byte number
	IDIV C,A
	CAIE D,0
	AOS C
	MOVEM C,FILBYN(JFN)
	POP P,C
	IMUL C,FILLEN(JFN)	; And adjust file length
	IDIV C,A
	CAIE D,0
	AOS C
	MOVEM C,FILLEN(JFN)
	DPB B,PBYTSZ		; Deposit new byte size
	RET
	SUBTTL Utility Routines -- Reduce Map Count
; This routine is called from write copy code in pagem to reduce the
; The map count of a page
; Call:	1	; Ofn.pn
;	CALL JFNDCR
; Returns +1 always

JFNDCR::CALL OFNJXL
	 RET
	MOVSI B,-2
	ADDB B,FILLFW(A)	;REDUCE MAP COUNT
	TLNE B,777777		;COUNT NOW ZERO AND CLOSF DONE?
	JRST JFNDC0
	MOVX B,FRKF		;YES, UNRESTRICT FILE SO ANY CLZFF GETS IT
	ANDCAM B,FILSTS(A)
JFNDC0:	CALL LUNLKF		;UNLOCK JFN AND STRUCTURE LOCK'
	OKINT			;AND UNDO THE NOINT
	RET
	SUBTTL Utility Routines -- Check TTY JFNs

;ROUTINES TO CHECK TTY'S.

;CALL	JFN			;SOME KIND OF SOURCE/DESTINATION DESIGNATOR
;	CALL CHKTTR		;IS THIS A TERMINAL?
;RETURN
;	+1			;NO, ERROR CODE IN A.
;	+2			;YES
;ON SUCCESS, THE FOLLOWING ARE SET UP:
;	DEV			;CORRECT STUFF FOR REFERENCED TERMINAL
;	B			;LINE NUMBER
;	C			;0 IF JFN NOT GIVEN,  BYTE SIZE OF OPEN
;				;    IF A JFN WAS GIVEN

CHKTTR::UMOVE JFN,1		;GET DESIG
CHKTR1:	CAIGE JFN,1B18+NLINES	;TTY DESIG?
	CAIGE JFN,1B18
	JRST CHKTTC		;NO
	HRLI DEV,-1B18(JFN)	;YES, SET UP LINE #
CHKTC1:	HRRI DEV,TTYDTB		;SET UP TTY DISPATCH IN DEV
	MOVX STS,READF+WRTF+OPNF
	HLRZ B,DEV		;RETURN LINE NUMBER IN B
	SETZ C,			;NOT A JFN, NO BYTE SIZE
	RETSKP
CHKTTC:	HRLI DEV,(JFN)		;FIRST ASSUME TTY
	CAMGE JFN,[600000+.DVTTY,,NLINES]
	CAMGE JFN,[600000+.DVTTY,,0]
	CAIA
	JRST CHKTC1		;WE HAVE 600000+.DVTTY,,LINE #
	CALL CHKJFN
	 RETBAD(DESX1)		;GARBAGE
	 JRST CHKTT1		;TTY
	 RETBAD(DESX1)		;BYTE PTR
	CALL UNLCKF		;REGULAR JFN, UNLOCK IT
CHKTT1:	TQNE <ASTF>
	 RETBAD(DESX7)
	HRRZ A,DEV
	HLRZ 2,DEV		;GET LINE NUMBER
	CAIE 2,-1		;DETACHED INDICATION?
	CAIE A,TTYDTB
	 RETBAD (DESX6)		;NOT TTY
	LDB C,[POINT 4,STS,35]	;GET BYTE SIZE OF OPEN
	TXNE JFN,1B18		;SPECIAL DESIGNATOR (100 OR 101)?
	RETSKP			;YES. ALL DONE THEN
	SKIPN C,		;IF NONE...
	LDB C,PBYTSZ		;  GET THE BYTE SIZE FROM FILBYT(JFN)
	RETSKP
;CALL	JFN			;SOME KIND OF SOURCE/DESTINATION DESIGNATOR
;	CALL CHKTTR		;IS THIS AN AVAILABLE TERMINAL TO THIS JOB?
;RETURN
;	+1			;NO, ERROR CODE IN A.
;	+2			;YES
;ON SUCCESS, THE FOLLOWING ARE SET UP:
;	DEV			;CORRECT STUFF FOR REFERENCED TERMINAL
;	B			;LINE NUMBER

CHKTTM::SKIPA JFN,1		;GET DESIG
CHKTTY::UMOVE JFN,1
	STKVAR <LINENO>		;HOLDS TERMINAL LINE #
	CALL CHKTR1		;MAKE SURE IT'S A TERMINAL
	RETBAD ()		;IT'S NOT; ASSUME ERROR CODE IN T1.
	MOVEM B,LINENO		;SAVE THE LINE NUMBER
	MOVEI A,400000(B)	;MAKE TERMINAL DESIGNATOR
	CALL CHKDEV		;IS THIS DEVICE AVAILABLE ?
	RETBAD (DESX2)		;NOT AVAILABLE TO THIS JOB
	MOVE B,LINENO		;RESTORE THE LINE NUMBER
	RETSKP

;ROUTINE USED TO INCREMENT THE USE COUNT OF A JFN.
;	T1/ THE JFN
;	T2/ THE COUNT TO ADD TO CURRENT USE COUNT
;RETURNS:
;	+1 JFN VANISHED
;	+2 DONE

MJFCNT::SAVEP			;SAVE ALL VUNERABLE REGS
	SAVEAC <F>		;THIS IS VULNERABLE TOO
	LSH T2,1		;DOUBLE THE SHARE COUNT
	ASUBR <IJFN,COUNT>
	MOVE JFN,T1		;COPY JFN
	CALL DSKJFN		;VERIFY AND CONVERT JFN
	 RET			;WENT AWAY
	HRLZ T2,COUNT		;GET INCREMENT
	ADDM T2,FILLFW(JFN)	;APPLY IT
	CALL UNLCKF		;UNLOCK THE JFN
	RETSKP			;AND DONE
   REPEAT 0,<			;THIS IS INTENDED TO SUPPORT MULTIPLE
				;DISK UNITS BUT IS NOT PRESENTLY USED.
;SET UP UNIT
; A/	B17 ON IF NOT DEFAULT
; B/	DEVICE DESIGNATOR
; RETURNS +1 - FAIL
;	+2 - SUCCESS, U LOADED

SETUNT:	EXCH A,B
	MOVE U,JOBUNT
	TLNN B,(1B17)		;DEFAULT TAKEN IF B17 OFF
	RETSKP
	CALL CHKDEV
	 RET
	RETSKP
   >				;END OF REPEAT 0
	SUBTTL Utility Routines -- Change JFN Ownership

;ROUTINE TO REASSIGN OWNERSHIP OF A JFN. THIS IS USED WHENEVER
;A NEW FORK NEEDS TO ASSUME RESPONSIBILITY FOR THE JFN. EXAMPLES
;ARE: IF A FORK OTHER THAN THE CREATER ENABLES FOR PSI
;VIA THE JFN.

;	JFN/ THE JFN
;		IT MUST BE LOCKED

;RETURNS:	+1 FAILURE. NONE DEFINED YET
;		+2 DONE

REAJFN::HLRZ T1,FILVER(JFN)	;GET PRESENT OWNER
	CAMN T1,FORKN		;ALREADY OWNED BY THIS GUY?
	RETSKP			;DONE. NO CHANGE NEEDED
	MOVE T1,FORKN		;NO. GET THIS FORK'S NUMBER
	HRLM T1,FILVER(JFN)	;AND SET IT AS NEW OWNER
	RETSKP			;AND DONE
	SUBTTL ARCF JSYS

; ARCF Jsys
; 1:JFN, 2: Function code, 3: Function dependent, normally 0
; Returns +1 always

.ARCF::	TRVAR <ROFLG>
	MCENT
	HRRZ JFN,T1		; Copy JFN
	CALL CKJFN		; Verify the JFN
	MOVE P3,T1		; Save FDB offset
	XCTU [ MOVE T1,2]	; Get function code
	XCTU [ MOVE Q3,3]	; Get param - if any
	CAIL T1,0		; Check function request
	CAIL T1,NARFNS		; In range?
	ERRJMP ARGX02,ARCFX	; Invalid function
	SETZM ROFLG		;ASSUME NOT A READ ONLY FUNCTOIN
	CAIN T1,.ARGST		;JUST READING?
	 SETOM ROFLG		;YES
	CALL @ARCFF(T1)		; Do it
	 JRST ARCFX		; Failed for some reason
	SKIPN ROFLG		;DON'T UPDATE IF READING ONLY
	 CALL UPDDIR		; Update directory
	CALL USTDIR
	CALL UNLCKF
	MRETNG			; Done

ARCFX:	CALL USTDIR		; Unlock things
ARCFXY:	CALL UNLCKF
	ITERR ()

ARCFF:	IFIW!ARRAR		; 0 Request voluntary archive
	IFIW!ARRIV		; 1 Request involuntary migration
	IFIW!AREXM		; 2 File is exempt from migration
	IFIW!ARRFR		; 3 Request file contents be restored
	IFIW!ARDIS		; 4 Discard tape status
	IFIW!ARSST		; 5 Set tape status for file
	IFIW!ARRST		; 6 Restore contents of a file
	IFIW!ARGST		; 7 Get tape status for file
	IFIW!ARRFL		; 10 Restore failed, tell waiting fork
	IFIW!ARNAR		; 11 Please don't migrate this file

NARFNS==.-ARCFF
; Request voluntary archive; Please don't migrate this file

ARNAR:	LOAD T1,FBBBT,(P3)
	TXNE T1,AR%RIV		; Requested?
	RETBAD(ARCX19)		; Request pending
	CALL CKAROF
	 RETBAD()
	MOVX T2,AR%NAR
	JRST ARRAR1

ARRAR:	MOVX T2,AR%RAR		; Bit to set
	HRRZ T1,Q3		; Get set/clear flag
	CAIN T1,.ARCLR		; Request to clear request?
	JRST ARRAR1		; Yes, can always clear it
	LOAD T1,FBBBT,(P3)	; Get CTL bits
	TXNE T1,AR%EXM		; File exempt ?
	RETBAD(ARCX10)		; Yes, don't allow request
	LOAD T1,FBFLG,(P3)	; Check some others too
	TXNE T1,FB%OFF!FB%PRM!FB%DIR!FB%ARC!FB%TMP
	RETBAD(ARCX10)		; Can't do it
ARRAR1:	PUSH P,T2		; Our bits will be stomped on
	CALL CKWOWN		; Have write or owner access?
	 RETBAD(,<ADJSP P,-1>)	; No, fail
	POP P,T2		; Recover them
	HRRZ T1,Q3		; Get set/clear code
	CAIN T1,.ARSET		; Set it?
	IORM T2,.FBBBT(P3)	; Yes
	CAIN T1,.ARCLR		; Clear the bit?
	ANDCAM T2,.FBBBT(P3)	; Yes
	TXNE T2,AR%NAR		; Did we say please don't?
	RETSKP			; Yes, done here
	CAIN T1,.ARCLR		; Have cleared the request?
	JRST [	SETZRO <K0NAR,K0NDL>,(P3) ; Clear resist & don't flush
		RETSKP]		; And exit
	CALL CLRBOT		; Clear any previous stuff (migrated?)
	SETZRO K0NAR,(P3)	; Can't still be resist now
	MOVX T2,AR%NDL
	TXNE Q3,AR%NDL		; Caller want don't flush set?
	IORM T2,.FBBBT(P3)	; Yes, do that
	RETSKP
; Involuntary migration; File exempt from migration

ARRIV:	HRRZS Q3		; No options through here
				;  - we may exit through ARRAR
	CAIN Q3,.ARCLR		; Clear migration request?
	JRST ARRIV1		; Yes, always valid (gotta be WHOPR)
	LOAD T1,FBBBT,(P3)
	TXNE T1,AR%EXM!AR%RAR	; File exempt from migration?
	RETBAD(ARCX15)		; Yes, fail
	LOAD T1,FBFLG,(P3)
	TXNE T1,FB%OFF!FB%PRM!FB%DIR!FB%ARC!FB%TMP
	RETBAD(ARCX15)		; Can't if any of those
ARRIV1:	CALL CKARDF		; Archive default for directory?
	CAIA
	JRST ARRAR		; Yes, turn migration into archive
	MOVX T2,AR%RIV		; Invlountary migration
	JRST AREXM1		; Join farther down

AREXM:	LOAD T1,FBFLG,(P3)
	TXNE T1,FB%OFF		; Offline?
	RETBAD(ARCX16)		; One of the 3 anyway
	MOVX T2,AR%EXM		; Exempt
AREXM1:	MOVE T1,CAPENB
	TXNN T1,SC%WHL+SC%OPR	; Have necessary caps?
	RETBAD(CAPX1)		; No
	LOAD T1,FBFLG,(P3)	; Get ctl flags
	HRRZ T1,Q3		; Get set/clear flag
	CAIN T1,.ARSET		; Set it?
	IORM T2,.FBBBT(P3)	; Yes
	CAIN T1,.ARCLR		; Clear it?
	ANDCAM T2,.FBBBT(P3)	; Yes
	TXNE T2,AR%RIV		; Migration request?
	RETSKP
	CAIN T1,.ARCLR		; Clearing exempt?
	RETSKP			; Yes, done here
	SETZRO <K0RIV,K0RAR,K0NDL>,(P3) ; Clear migration request (if any)
	CALLRET CLRBOT		;  and discard any tape info
; Request file be retrieved from offline storage

ARRFR:	LOAD T1,FBFLG,(P3)
	TXNN T1,FB%OFF		; Offline?
	RETBAD(ARCFX9)		; No, fail
	TXNE Q3,AR%WAT		; Caller waiting?
	SKIPN NRTWTS		; Waits allowed?
	CAIA			; Not waiting, or waits allowed
	RETBAD(ARCX18)		; Say can't do it right now

; %%% check to see if caller has space left for this file

ARRFR3:	HRRI T1,.RETM		;[7207] Send a retrieve message
	HRLI T1,.RETR		; Default is normal request
	TXNE Q3,AR%WAT		; User waiting?
	HRLI T1,.RETRW		; Yes, relay that info
	MOVE T2,P3		; FDB offset
	CALL ARCMSG		; Send the msg
	 JRST ARRFR2		; [7207]Failed, IPCF message didn't happen
	MOVX T1,AR%RFL
	ANDCAM T1,.FBBBT(P3)	; Clear any old request failed flag
	TXNN Q3,AR%WAT		; Done?
	RETSKP			; Yes

ARRFR1:	CALL USTDIR		; Unlock & make ourself interruptable
	CALL UNLCKF
RETTST:	MOVX T1,^D2*^D60*^D1000	; Busy wait for file to appear
	DISMS
	XCTU [HRRZ JFN,1]	; Recover the JFN
	CALL CKJFN		; Re-check things, GET T1/ FDB ADDR
	LOAD T2,FBFLG,(T1)	; Get flags
	TXNN T2,FB%OFF		; Still offline?
	RETSKP			; Is back!
	MOVX T2,AR%RFL		; Restore failed bit
	TDNN T2,.FBBBT(T1)	; Did it?
	JRST ARRFR1		; No, wait some more
	ANDCAM T2,.FBBBT(T1)	; Yes, clear the failure bit
	CALL UPDDIR		; Get it back to disc
	RETBAD(ARCX14)		; Tell 'em it failed
	JRST ARRST		; [7207] restore the contents of offline file
ARRFR2:	CAIE T1,IPCFX7		; [7207] PID overquota?
	CAIN T1,MONX06		; [7207] or out of free space?
	SKIPA			; [7207] yes, wait for QUASAR to read a packet
	JRST ARRFR4		; [7207] no, wait a while
	CALL USTDIR		; [7207] Unlock and make us interruptable
	CALL UNLCKF		; [7207]
	AOS IPPKFR		; [7207] bump resource wait flag
	MOVEI T1,IPPKFR		; [7207] get address of flag
	CALL DISE		; [7207] wait until it gets cleared
	MOVEI T1,^D10000	; [7207] wait 10 seconds to "settle down"
	DISMS			; [7207]
	JRST ARRFR5		; [7207] then will retry
ARRFR4:	CALL USTDIR		; [7207] Unlock and make us interruptable
	CALL UNLCKF		; [7207]
	MOVX T1,^D2*^D60*^D1000	; [7207] wait for two minutes
	DISMS			; [7207] 
ARRFR5:	XCTU [HRRZ JFN,T1]	; [7207] get back the JFN
	CALL CKJFN		; [7207] re-check, get T1/ FDB addr
	MOVE P3,T1		; [7207] save FDB offset
	JRST ARRFR3		; [7207] retry ARCMSG
; Restore contents of an offline file

ARRST:	MOVE T1,CAPENB
	TXNN T1,SC%OPR+SC%WHL	; Permitted?
	RETBAD(CAPX1)		; No
	LOAD T1,FBFLG,(P3)	; Get flags
	TXNN T1,FB%OFF		; File offline?
	RETBAD(ARCFX9)		; No, fail here
	TQNE <OPNF>		; Cannot be open
	ERRJMP OPNX1,ARCFX
	SKIPE .FBADR(P3)	; File have contents?
	BUG.(HLT,OFFONX,JSYSF,SOFT,<ARRST - File marked offline has index block pointer>,,<

Cause:	In restoring an offline file, it was discovered the file already
	has some contents.
>)
	PUSH P,STS
	PUSH P,JFN		; Save stuff
	PUSH P,DEV
	CALL USTDIR		; Release it
	UMOVE JFN,3		; Get 2nd JFN
	CALL CHKJFN		; Can't use CKJFN
	 JRST ARCF1X		; Fails
	 JFCL
	 ERRJMP DESX4,ARCF1X
	TQNE <ASTF>		; Output *'s?
	ERRJMP DESX7,ARCFXX	; Yes, bomb
	BLCAL. DSKOK,<DEV>	;DISK?
	 ERRJMP ARCFX3,ARCFXX
	CALL GETFDB
	 ERRJMP DESX3,ARCFXX
	MOVE P3,T1		; Copy FDB offset
	TQNE <OPNF>
	ERRJMP OPNX1,ARCFXX	; Can't be open
	CAME DEV,0(P)		; Gotta be same device too
	ERRJMP ARCFX5,ARCFXX
	SKIPN Q1,.FBADR(P3)	; Get page tbl ptr from file w/ contents
	ERRJMP RNAMX9,ARCFXX	; Can't do that...
	CALL CKAROF		; Archived or offline?
	 JRST ARCFXX		; Yes, can't use that as a source
	MOVE T1,Q1		; Index block address
	TLO T1,(THAWB)		; Restrict access
	LOAD B,STR,(JFN)	; Get structure no. from JFN block
	CALL ASFOFN
	 JRST [ MOVE T2,T1	; Busy or bad PT
		SETO T1,
		CAIE T2,OPNX9	; Busy?
		 JRST .+1	; No, go ahead
		MOVEI T1,RNMX10
		JRST ARCFXX]	; Bomb
	PUSH P,T1		; Save OFN
; More of ARRST

	PUSH P,.FBCTL(P3)	; Save flags
	PUSH P,Q1		; Save addr
	PUSH P,.FBBYV(P3)	; # of pages etc.
	PUSH P,.FBSIZ(P3)	; And EOF
	SETZRO FBADR,(P3)	; Clear it, avoid multiple ptrs
	SETONE <FBNXF,FBDEL>,(P3) ; Delete the file
	LOAD T2,FBNPG,(P3)	; Get page count of source file
	MOVNS T2
	MOVE T3,DIRORA		; Base of directory area
	OPSTRM <ADDM T2,>,DRDCA,(T3) ; Reduce source dir pg cnt
	MOVE T4,P3
	CALL DELFIL		; Kill it
	 JFCL			; Was PRM???
	CALL UPDDIR		; Update source dir
	CALL USTDIR		; Done with it
	MOVE T1,-4(P)		; OFN of source we've clobbered
	SKIPL T1
	CALL RELOFN
	CALL UNLCKF
	CALL RELJFN		; Release it entirely
	MOVE STS,-7(P)
	MOVE JFN,-6(P)		; Now turn our attention to dest
	MOVE DEV,-5(P)
	CALL GETFDB
	 BUG.(HLT,ARSTXX,JSYSF,SOFT,<ARRST - FDB disappeared for destination file>,,<

Cause:	The FDB for a file being restored from offline does not exist.

>)
	POP P,.FBSIZ(T1)	; Fix up # of bytes
	POP P,.FBBYV(T1)	;  and # of pages
	POP P,.FBADR(T1)	;   and file address
	POP P,T2		; Flags from source
	TXZ T2,FB%TMP+FB%NEX+FB%NXF+FB%OFF ; Don't copy these over
	IORM T2,.FBCTL(T1)	; Put in dest
	MOVX T2,FB%INV		;GET SET
	ANDCAM T2,.FBCTL(T1)	;MAKE SURE THE FILE IS VISIBLE NOW
	ADJSP P,-1		; Dump OFN
	LOAD T2,FBNPG,(T1)	; Get no. pages in dest. file
	MOVE T3,DIRORA
	OPSTRM <ADDM T2,>,DRDCA,(T3) ; Update dir total
	SETZRO FBOFF,(T1)	; Is online now...
	POP P,DEV
	POP P,JFN
	POP P,STS
	RETSKP			; Done
ARCFXX:	CALL USTDIR		; Release current JFN
	CALL UNLCKF
ARCF1X:	POP P,DEV
	POP P,JFN
	POP P,STS
	CALL UNLCKF
	ITERR ()
; Discard tape status

ARDIS:	LOAD T1,FBFLG,(P3)
	TXNE T1,FB%OFF		; Offline?
	RETBAD(ARCFX4)		; File not online
	UMOVE Q1,3		; Get user's options
	ANDX Q1,AR%CR1+AR%CR2	; Take those we know about
	TXC Q1,AR%CR1+AR%CR2
	JUMPE Q1,CLRBOT		; Do both
	MOVE T1,CAPENB
	TXNN T1,SC%WHL+SC%OPR	; Allowed?
	RETBAD(CAPX1)		; No
	TXC Q1,AR%CR1+AR%CR2	; Restore request flags
	TXNE Q1,AR%CR2
	CALL CLR2ND
	TXNE Q1,AR%CR1
	CALL CLR1ST		; Do first set
	SKIPN .FBTP1(P3)	; 1st tape say anything?
	SKIPE .FBTP2(P3)	; 2nd?
	RETSKP			; Yes
	JRST CLRAAD		; Go clear common data since not offline

; Note that AREXM may enter at CLRBOT, also DSKOPN calls CLRBOT

CLRBOT::JE <FBARC>,.FBCTL(P3),CLRBO1 ; Archived file?
	MOVE T1,[.ACLR,,.NOTM]	; Notification: archive sts cleared
	MOVE T2,P3		; FDB offset
	CALL ARCMSG		; Send message to user
	 RETBAD(ARCX13)		; Say failed & why
CLRBO1:	CALL CLR1ST
	CALL CLR2ND
CLRAAD:	SETZRO FBTDT,(P3)	; Clear tape-write date & time
	SETZRO <K0RFL,K01ST,K0WRN,ARPSZ>,(P3) ; Clear tape-related data
	SETZRO FBARC,(P3)	; Clear archive status flag
	SETZRO FBFET,(P3)	; Clear meaningless expiry date
	RETSKP			; Finished

CLR1ST:	SETZRO TFN1,(P3)	; Clear tape file #
	SETZRO TSN1,(P3)	; Clear save set #
	SETZRO ARTP1,(P3)	; And tape #
	RET

CLR2ND:	SETZRO TFN2,(P3)	; Clear tape file #
	SETZRO TSN2,(P3)	; Clear save set #
	SETZRO ARTP2,(P3)	; Clear tape #
	RET
; Set archive status for a file

ARSST:	MOVE T1,CAPENB
	TXNN T1,SC%WHL+SC%OPR
	RETBAD(CAPX1)		; Not enough caps
	LOAD T1,FBFLG,(P3)
	TXNE T1,FB%OFF		; Off-line?
	RETBAD(ARCFX4)		; Not on-line
	TXNE T1,FB%DIR!FB%PRM!FB%TMP
	RETBAD(ARCFX7)		; Not allowed
	LOAD T1,FBBBT,(P3)	; Get archive bits
	TXNE T1,AR%EXM		; Exempt from archiving?
	RETBAD(ARCX10)		; Yes
	UMOVE Q2,.AROFL(Q3)	; Get flags
	TXNN Q2,AR%O1+AR%O2	; Asking for 1 or both passes?
	RETBAD(ARCFX7)		; Neither, garbage
ARSST1:	TXCE Q2,AR%O1		; Do run 1 stuff?
	CALL SET1ST		; Yes, do that pass
	TXCE Q2,AR%O2		; 2nd run stuff?
	CALL SET2ND		; Yes, do that too
	XCTU [SKIPN T1,.ARODT(Q3)] ; User supply a TAD?
	CALL LGTAD		; No, get now
	STOR T1,FBTDT,(P3)	; Set date & time
	CALL CKARDF		; Default to archive?
	CAIA			; No
	TXO Q2,AR%ARC		; Yes, force that option on
	MOVX T1,FB%ARC
	TXNE Q2,AR%ARC		; Mark as archived?
	IORM T1,.FBCTL(P3)	; Yes, do that
	SKIPN T1,ARRCYC		; Get archive recycle time
	MOVX T1,.STDAE		; NONE SET, USE DEFAULT
	TXNE Q2,AR%ARC		; Did we archive this?
	MOVEM T1,.FBFET(P3)	; Yes, put in special offline time
	LOAD T2,FBBBT,(P3)	; Get bits
	MOVX T1,.AREXP		; Assume file expired
	TXNE T2,AR%RAR
	MOVX T1,.ARARR		; File archived
	TXNE T2,AR%RIV
	MOVX T1,.ARRIR		; File migration requested
	STOR T1,K0RSN,(P3)	; Remember why we did this
	MOVX T1,AR%RAR!AR%RIV	; Request bits
	TXNE Q2,AR%CRQ		; Clear the requests?
	ANDCAM T1,.FBBBT(P3)	; Yes, clear migration & archive rq
	TXNN Q2,AR%OFL		; Want a flush?
	RETSKP			; No, done here
	;..
	;..
	SKIPE .FBTP1(P3)	; See if both sets of tape info set
	SKIPN .FBTP2(P3)
	RETSKP			; Not all tape info around
	MOVE T4,P3		;GET FDB ADDRESS IN T4 FOR FSHFIL
	CALL FSHFIL		; Delete contents of the file
	 RETBAD()		; Failed
	MOVE T4,P3		; FDB offset
	XCTU [SKIPE T1,.ARPSZ(Q3)] ; Get offline page count
	STOR T1,ARPSZ,(P3)	; If not 0, restore it into FDB
	RETSKP			; Done

SET1ST:	XCTU [MOVE T1,.ARTP1(Q3)] ; Get tape id
	LOAD T2,ARTP2,(P3)	; Get other tape ID (shouldn't be one)
	CAMN T2,T1		;[9103] A match?
	RETBAD(ARCFX7)		; Yes, not allowed
	STOR T1,ARTP1,(P3)	; Set tape tape id
	ULOAD T1,AR%TSN,.ARSF1(Q3) ; Get saveset #
	STOR T1,TSN1,(P3)	; And saveset #
	ULOAD T1,AR%TFN,.ARSF1(Q3) ; Get tape file #
	STOR T1,TFN1,(P3)	; And set tape file #
	RET

SET2ND:	XCTU [MOVE T3,.ARTP2(Q3)] ; Get tape #, run 2
	LOAD T2,ARTP1,(P3)	; Get run 1 tape #
	CAMN T2,T3		; Match?
	RETBAD(ARCFX7)		; Yes, not allowed
	ULOAD T1,AR%TFN,.ARSF2(Q3) ; Get tape file #
	STOR T1,TFN2,(P3)	; Set tape file #
	ULOAD T1,AR%TSN,.ARSF2(Q3) ; Get saveset #
	STOR T1,TSN2,(P3)	; Save set #
	STOR T3,ARTP2,(P3)	; And tape #
	RET
; Get tape info for caller

ARGST:	XCTU [	SETZM .AROFL(Q3)] ; Never return this word
	LOAD T1,ARTP1,(P3)	; Get tape #
	XCTU [	MOVEM T1,.ARTP1(Q3)] ; 1st tape #
	LOAD T1,TFN1,(P3)	; Tape file #
	USTOR T1,AR%TFN,.ARSF1(Q3) ; Return tape file # 1
	LOAD T1,TSN1,(P3)	; Get saveset #
	USTOR T1,AR%TSN,.ARSF1(Q3) ; Return it
	LOAD T1,ARTP2,(P3)	; Get 2nd tape #
	XCTU [	MOVEM T1,.ARTP2(Q3)]
	LOAD T1,TFN2,(P3)	; Get tape file #
	USTOR T1,AR%TFN,.ARSF2(Q3) ; Return it
	LOAD T1,TSN2,(P3)	; Get saveset # 2
	USTOR T1,AR%TSN,.ARSF2(Q3)
	LOAD T1,FBTDT,(P3)	; Get tape write
	XCTU [	MOVEM T1,.ARODT(Q3)]
	LOAD T1,ARPSZ,(P3)	; Get # of pages when pushed offline
	XCTU [	MOVEM T1,.ARPSZ(Q3)]
	RETSKP

; Flag that the restore failed (tell waiting process)

ARRFL:	MOVE T1,CAPENB
	TXNN T1,SC%WHL!SC%OPR	; Caller have caps necessary?
	RETBAD(CAPX1)		; No, tell him
	MOVX T1,AR%RFL
	IORM T1,.FBBBT(P3)	; Set it
	RETSKP
; Check for valid JFN etc.; also setup FDB

CKJFN:	CALL CHKJFN		; Check validity
	 ITERR ()		; Garbage
	 JFCL
	 ITERR (DESX4)		; Tty or byte ptr
	TQNE <ASTF>		; Output *'s?
	ERRJMP DESX7,ARCFXY	; Bomb with unlock
	BLCAL. DSKOK,<P3>	;DISK?
	 ERRJMP ARCFX3,ARCFXY	; No FDB for non MDD devices
	CALL GETFDB		; Get the FDB
	 ERRJMP DESX3,ARCFX	; No FDB
	LOAD T2,FBLEN,(T1)	; Get length
	CAIGE T2,.FBLXT		; Should be at least this big
	ERRJMP ARCX17,ARCFX	;  or we can't do anything with the file
	RET

; Check file for write or owner access

CKWOWN:	MOVE T2,CAPENB
	TXNE T2,SC%WHL+SC%OPR	; Have special privs?
	RETSKP			; Yes, win that way
	MOVE T1,P3		; FDB offset ptr
	MOVX T2,WRTF		; Check write access first
	CALL ACCCHK
	 CAIA			; Don't have that
	RETSKP			; Ok, go with write access
	MOVX T2,XCTF		; Check for owner like privs
	CALL DIRCHK
	 RETBAD(CFDBX2)		; No access to file
	RETSKP			; Ok, proceed with owner access

; Check to see if file has archive status, or is offline

CKAROF:	LOAD T1,FBFLG,(P3)	; Get bits
	TXNE T1,FB%ARC		; Archive status?
	RETBAD(ARCFX2)		; Right
	TXNE T1,FB%OFF		; Offline?
	RETBAD(ARCFX4)		; Yes it is
	RETSKP			; File is fine

CKNAON:	LOAD T1,FBFLG,(P3)
	TXNN T1,FB%ARC		; Archived?
	RETBAD(ARCFX6)		; No
	TXNN T1,FB%OFF		; Offline?
	RETBAD(ARCFX9)		; No
	RETSKP
; See if the default is to archive rather than migrate a file

CKARDF:	HRRZ T1,FILDDN(JFN)	; Get directory # file is from
	MOVE T3,DIRORA		; Where directories live
	LOAD T2,DRNUM,(T3)	; Get mapped directory #
	CAME T1,T2		; They match?
	 BUG.(CHK,ARCASS,JSYSF,HARD,<ARCF - File directory and mapped directory do not match>,,<

Cause:	The directory number of the currently mapped directory does not
	match the directory number of file that we are attempting to set
	tape information for in a ARCF% .ARRST request.
>)
	LOAD T1,DRMOD,(T3)	; Get mode bits
	TXNE T1,CD%DAR		; Is the default to archive ?
	RETSKP			; Yes
	RET			; No
;Routine to check read, write, execute, and append access restrictions imposed
;by the archive/virtual disk system.
;
;CALL:	T1/FDB address
;	T2/access request bits (FC%RD, FC%WR, FC%APP, FC%EX)
;	CALL ARACCK
;RETURNS T1/0 if OK, -1 if OK with discard of tape pointer,
;	    -2 if OK with discard of tape pointer and request bits,
;	    error code if not allowed.
;
ARACCK::PUSH P,T3
	PUSH P,T4
	SETZ T3,
	TXNN T2,FC%RD!FC%EX	;Read/Execute access requested?
	JRST CKARST		;No, check write, append
	JE FBOFF,(T1),CKARST	;Finished read/execute ck if online
	MOVEI T3,OPNX31		;Offline, fail (unless ret. wait set)
	JRST CKADON
CKARST:	TXNN T2,FC%WR!FC%APP	;Write or append requested?
	JRST CKADON		;No, done
	LOAD T4,FBLEN,(T1)
	CAIGE T4,.FBLXT		;FDB has tape info?
	JRST CKADON		;No
	LOAD T4,FBFLG,(T1)
	TXNE T4,FB%ARC		;Yes, File has archive status?
	MOVEI T3,OPNX30		;Yes, no modifications allowed
	LOAD T4,FBBBT,(T1)
	TXNE T4,AR%RAR		;File has archive request pending?
	MOVEI T3,OPNX30		;Yes, no modifications allowed
	JUMPG T3,CKADON		;Done with archived files
	SKIPN .FBTP1(T1)	;Ordinary file: tape 1 info there?
	SKIPE .FBTP2(T1)	;Tape 2 info there?
	CAIA			;Tape info exists, check further
	JRST CKADON		;Neither tape there
	TXNN T2,FC%WR		;Ordinary file: write access requested?
	JRST CKARAP		;No, check append
	SETO  T3,		;Yes, Ok with discard of tape info
	TXNN T3,FC%RD!FC%APP	;Read or append too?
	MOVNI T3,2		;No, discard migrate bit also
CKARAP:	TXNN T2,FC%APP		;Append requested?
	JRST CKADON		;No, done
	SETO T3,		;OK so far with discard of tape ptr
	JE FBOFF,(T1),CKADON	;Done if online
	MOVEI T3,OPNX31		;Offline, fail (unless ret. wait set)
CKADON:	MOVE T1,T3
	POP P,T4
	POP P,T3
	RET
	SUBTTL ASND JSYS

; Assign device
; 1/ DEVICE DESIGNATOR
;	ASND
; Return
;	+1	; Error, not assignable or bad designator etc.
;	+2	; Ok, the device specified is now assigned to this job

.ASND::	MCENT
	STKVAR <ASNPAS,ASNUAR,ASNDIX>
	MOVEM T1,ASNUAR		;SAVE USER ARG
	SETZM ASNPAS		;FIRST PASS
ASND0:	CALL LCKDVL
	CALL CHKDEV		;CHECK DEVICE AND SEE IF ALREADY ASSIGNED
	 RETERR(,<UNLOKK DEVLKK>)
	MOVEM T2,ASNDIX		;SAVE INDEX INTO DEVICE TABLES
	TXNN C,DV%AS		;ASSIGNABLE DEVICE?
	RETERR(ASNDX1,<UNLOKK DEVLKK>)
	SKIPE ASNPAS		;[9122] First pass?
	IFSKP.			;[9122] Yes
	  HLRZ T4,DEVUNT(T2)	;[9122] Get owning job
	  CAMN T4,JOBNO		;[9122] This job?
	  IFSKP.		;[9122] Not assigned to this job
	    UNLOKK DEVLKK	;[9122] Unlock device lock for ACJ call
	    OKINT		;[9122] Allow ints now
	    MOVE T1,ASNUAR	;[9122] Get user's arg
	    GTOKM (.GOASD,T1,[RETERR ()]) ;[9122] Do GETOK and return if error
	    MOVE T1,ASNUAR	;[9122] Get back user's arg
	    AOS ASNPAS		;[9122] On second pass now
	    JRST ASND0		;[9122] Restart on second pass
	  ENDIF.		;[9122] End of "dev not assigned to this job"
	ENDIF.			;[9122] End of "first pass" code
	MOVE T1,ASNDIX		;[9122] Get back the index into device tables
	CALL CFSMTA		;[9122] (T1/) Check for cluster MTA access
	 RETERR (ASNDX4,<UNLOKK DEVLKK>) ;[9122] Dev in use by another system
	HRRZ P3,DEV		;GET DISPATCH TABLE
	CAIE P3,TTYDTB		;[7365] Is this a terminal?
	IFSKP.			;[7365]
	  HLRZ B,DEV		;[7365] Yes, get the line number
	  CALL TTYASC		;[7365] (T2/T1) Assign the line
	   RETERR (,<UNLOKK DEVLKK>) ;[7365] Failed
	  MOVE B,ASNDIX		;[7365] Restore index to device tables
	  HLRE C,DEVUNT(B)	;[7365] Get current owner
	  IFL. C		;[7365] Previously not owned?
	    HLRZ B,DEV		;[7365] Yes, get line number again
	    CALL TTPINI		;[7365] (T2/) And init terminal parameters
	  ENDIF.		;[7365]
	  MOVE B,ASNDIX		;[7365] Restore index to device tables
	ENDIF.			;[7365]

	CALL DSMNT0		;DISMOUNT IT IF NECESSARY
	 JFCL
	MOVSI A,(DV%ASN)
	MOVE B,ASNDIX		;RESTORE INDEX TO DEVICE TABLES
	IORM A,DEVCHR(B)	; Mark this device as assigned by asnd
	MOVE A,JOBNO
	HRLM A,DEVUNT(B)	; Assign to this job
	UNLOKK DEVLKK
	SMRETN
	SUBTTL BKJFN JSYS

; Backup file pointer by 1 byte
; Call:	1	JFN
;	BKJFN
; Returns
;	+1	; Error, cannot backup this designator
;	+2	; Ok.

.BKJFN::MCENT
	MOVE JFN,1
	CALL CHKJFN
	 RETERR()
	 JRST BKJTTY
	 JRST BKJBYT
	HRRZ A,DEV
	CAIN A,TTYDTB		; Tty?
	JRST BKJTT1
	TQNN <OPNF>
	RETERR(DESX5,<CALL UNLCKF>)
	MOVE A,FILBYN(JFN)
	SOJL A,[RETERR(SFPTX3,<CALL UNLCKF>)]
	CALL SFBNR
	 RETERR(,<CALL UNLCKF>)
	CALL UNLCKF
	SMRETN

;DEVICE IS A TERMINAL. CALL DEVICE-SPECIFIC ROUTINE

BKJTT1:	CALL UNLCKF
BKJTTY:	HLRZ 2,DEV
	CAIN T2,-1		;DETACHED?
	 RETERR (DESX6)		;YES
	CALL TTBKPT
	 RETERR			;ROUTINE HAS SET UP ERROR CODE
	SMRETN

BKJBYT:	MOVE A,JFN
	CALL DBP
	UMOVEM A,1
	SMRETN
	SUBTTL CHFDB JSYS

; Change fdb
; Call:	LH(1)	; Offset
;	RH(1)	; Jfn
;	2	; Mask
;	3	; Data
;	CHFDB

.CHFDB::MCENT
	CALL CHFDB0		;DO THE WORK
	 ITERR ()		;ERROR OCCURED
	JRST MRETN		;SUCCESSFUL
CHFDB0:	STKVAR <CHFDBA,CHFDBD,CHFDBT>
	XCTU [HRRZ JFN,T1]	;SETUP THE JFN
	ULOAD T1,CF%DSP,T1	;GET DISPLACEMENT
	MOVEM T1,CHFDBD		;SAVE IT
	CAIL A,.FBLEN
	RETBAD(CFDBX1)		; Offset too big
	CALL CHKJFN		; Check jfn
	 RETBAD()		; Garbage
	 JFCL
	 RETBAD(DESX4)		; Tty or byte illegal
	TQNE <ASTF>
	ERRJMP DESX7,CHFDX
	BLCAL. DSKOK,<P3>	;DISK?
	 ERRJMP	CFDBX5,CHFDX	;No FDB for non-MDD devices
	LOAD A,STR,(JFN)	;[7.1063]Get the JFN's structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is the structure offline?
	 JRST CHFDX		;[7.1063]Return "structure is offline"
	UMOVE T1,T1		;[9041] Get user's AC 1
	LOAD T1,CF%DSP,T1	;[9041] Get word to be hacked
	CAIE T1,.FBCTL		;[9041] Attacking this word?
	IFSKP.			;[9041] If we are diddling .FBCTL,
	  UMOVE T2,T2		;[9041] Now get mask of things to be changed
	  TXNN T2,FB%SEC	;[9041] Diddling secure bit?
	  IFSKP.		;[9041] If so
	    UMOVE T3,T3		;[9041] Get user's AC 3
	    TXNN T3,FB%SEC	;[9041] Is this set to 1?
	    IFSKP.		;[9041] If so,
	      CALL CHFSET	;[9041] (JFN/) Say we are setting this
	       JRST CHFDX	;[9041] Failed, oh well
	    ELSE.		;[9041] Else we are clearing
	      CALL CHFCLR	;[9041] (JFN/) Can we clear it?
	       JRST CHFDX	;[9041] ACJ said no
	    ENDIF.		;[9041]
	  ENDIF.		;[9041]
	ENDIF.			;[9041]
	CALL GETFDB		; Get the fdb
	 ERRJMP DESX3,CHFDX
	MOVEM A,CHFDBA		; SAVE FDB ADDRESS
	LOAD B,FBLEN,(A)	; Get the length of this FDB
	CAMG B,CHFDBD		; Is it the FDB bigger than offset?
	ERRJMP CFDBX1,CHFDB9	; No, loose
	MOVE D,CHFDBD		; GET OFFSET
	UMOVE B,2		; Mask
	OPSTR <SKIPE>,FB%DIR,.FBCTL(A) ;A DIRECTORY FILE?
	CAIE D,.FBCTL		;YES. CHANGING FLAG WORD?
	SKIPA			;NO. PROCEED
	JRST CHFDB6		;YES. CAN'T DO IT
	ANDCM B,WRTR(D)		; Writer bits?
	JUMPN B,CHFDB1		; No, check owner and wheel
	JAND <OPNF,WRTF>,,CHFDB2 ;IF FILE IS OPEN FOR WRITE, THEN OK
	MOVX B,FC%WR		; Yes check for write access
	CALL ACCCHK
	 JRST CHFDB1		; NO WRITER ACCESS, CHECK OWNER
	JRST CHFDB2		; Ok, go ahead

CHFDB1:	UMOVE B,2		; GET MASK AGAIN
	MOVE D,CHFDBD		; [TCO 5.1081] GET BACK FDB INDEX
	ANDCM B,OWNER(D)
	JUMPN B,CHFDB4		; Requires mor than owner status
	MOVE A,CHFDBA		; GET THE FDB ADR AGAIN
	CALL NFACHK		; SEE IF THIS IS A NEW FILE
	 JRST CHFDB3		; NO, GO CHECK OWNER RIGHTS
	JRST CHFDB2		; YES, THEN GIVE OWNER RIGHTS TO CALLER
CHFDB3:	MOVX B,DC%CN
	CALL DIRCHK		;SEE IF USER CAN CONNECT (AND THUS BE LIKE
				; AN OWNER)
	 JRST CHFDB5
	JRST CHFDB2

CHFDB6:	MOVEI A,CFDBX2
CHFDB9:	CALL USTDIR		;UNLOCK DIRECTORY
CHFDX:	CALL UNLCKF		;UNLOCK JFN
	RETBAD ()
CHFDB4:	ANDCM B,WOPR(D)
	JUMPN B,CHFDB6		; Can't be done
CHFDB5:	MOVE B,CAPENB
	TRNN B,SC%WHL!SC%OPR
	IFNSK.			;FIGURE OUT WHICH ERROR TO GIVE
	 MOVE D,CHFDBD		;GET BACK FDB INDEX
	 MOVE B,WRTR(D)		;SEE IF WRITER
	 IOR B,OWNER(D)		;OR OWNER ACCESS WERE REQUIRED
	 XCTU [AND B,T2]	;ON USER SPECIFIED BITS
	 MOVEI T1,CFDBX3	;GIVE WRITE OR OWNER ACCESS REQUIRED
	 SKIPN B		;UNLESS NEITHER WERE REQUIRED
	 MOVEI T1,WHELX1	;IN WHICH CASE GIVE WHEEL/OPER REQUIRED
	 JRST CHFDB9		;TELL USER
	ENDIF.
CHFDB2:	MOVE A,CHFDBA		; GET THE FDB ADDRESS BACK
	ADD A,CHFDBD		; GET ADR OF DATA WORD IN FDB
	UMOVE C,3		; Data
	MOVE B,(A)		; Old data
	UMOVE D,2		; Mask
	AND C,D			; Retain masked bits of new data
	ANDCM B,D		; Flush bits to be replaced from old
	IOR B,C
	MOVE C,CHFDBD		; Get word index
	CAIN C,.FBCTL		; Flags word?
	 JRST CHFD10		; Yes, check things carefully
CHFDB8:	MOVEM B,(A)
	TQNN <OPNF>		;IS THE FILE OPEN?
	JRST CHFDB7		;NO, DONT SET UP THE NEW LENGTH
	HLRZ B,FILOFN(JFN)	;GET OFN
	TQNE <LONGF>		;LONG FILE?
	HRRZ B,FILOFN(JFN)	;YES, USE THIS ONE
	MOVE A,OFNLEN(B)	;[7.1059] Get OFNLEN for this OFN
	CAME A,[-1]		;[7.1059] Is it code for 34359738367(36)?
	IFSKP.			;[7.1059] Yes
	  MOVEI A,^D36		;[7.1059] Make 36 bit byte size
	  MOVX B,.INFIN		;[7.1059] Make 34359738367 byte count
	ELSE.			;[7.1059] 
	  LOAD A,OFNBSZ,(B)	;[7.1059] Get true file byte size
	  LOAD B,OFNBC,(B)	;[7.1059]  and file byte count
	ENDIF.			;[7.1059] 
	MOVE C,CHFDBD		;GET OFFSET
	CAIE C,.FBBYV		;BYTE SIZE WORD
	JRST CHFD12		;NO TRY BYTE COUNT
	TXNN D,FB%BSZ		;BYTE SIZE FIELD CHANGED?
	JRST CHFDB7		;NO DON'T UPDATE LENGTH
	MOVE D,CHFDBA		;GET FDB ADDR
	LOAD A,FBBSZ,(D)	;GET BYTE SIZE FROM FDB
	JRST CHFD11		;AND UPDATE LENGTH
CHFD12:	CAIE C,.FBSIZ		;LENGTH CHANGE?
	JRST CHFDB7		;NO DON'T UPDATE IT
	MOVE D,CHFDBA		;ADDR OF FDB
	LOAD B,FBSIZ,(D)	;GET LENGTH FROM FDB
CHFD11:	CALL UPDFLN		;UPDATE THE LENGTH
CHFDB7:	UMOVE T2,T1		;GET ARG
	TXNE T2,CF%NUD		;Update directory now?
	IFSKP.			;Yes
	  CALL UPDDIR		;()Update it
	  TQNN <OPNF>		;Is the file open?
	  ANSKP.		;Yes

;The directory has just been updated and the file is open.
;Since the EOF pointer could have changed, we must broadcast it
;to the other systems in the cluster.

	    HLRZ D,FILOFN(JFN)	;Get OFN
	    TQNE <LONGF>	;Long file?
	    HRRZ D,FILOFN(JFN)	;Yes, use this one
	    MOVE A,D         	;Copy OFN
	    MOVEI B,0		;Only need read permission
	    MOVEM D,CHFDBT	;Save OFN
	    CALL CFSAWT		;(T1,T2)Do it to get up-to-date EOF info
	    MOVE A,CHFDBT	;Get OFN back
	    CALL CFSBEF		;(T1)Broadcast the EOF we know about
	ENDIF.
	CALL USTDIR
	CALL UNLCKF
	RETSKP
CHFD10:	TXNN B,FB%DEL		; Changing state of deleted?
	 JRST CHFDB8		; No, proceed normally
	PUSH P,A		; SAVE FDB LOC
	PUSH P,B		; Save this
	MOVX B,FC%WR		; Write access necessary for delete
	CALL ARACCK		; Check archive/vir. disk requirements
	JUMPLE A,[POP P,B	; Recover mask
		POP P,A
		JRST CHFDB8]	; And proceed
	POP P,B			; Clean up stack
	POP P,A
	JRST CHFDB9		; Fail
;[9041]
;CHFSET/CHFCLR - Jacket routine to set things up for CHFDB% GETOK.
;
; Call with:
;	JFN/ Index into JFN block
;	CALL CHFSET to set FB%SEC
;	       or
;	CALL CHFCLR to clear FB%SEC
;
; Returns:
;	+1 - ACJ said no,
;	+2 - Success, allow setting of FB%SEC
;

CHFCLR:	TDZA T2,T2		;[9063] Flag that we are clearing it and skip
CHFSET:	MOVEI T2,1		;Say we are setting FB%SEC
	MOVEI T1,.GOCFD		;Say which ACJ function to do
	CALL ACJOFL		;(T1,T2,JFN/) Now get permission
	 RETBAD ()		;Can't do it
	RETSKP			;Success!
; Access tables for chfdb

;BITS WHICH CAN BE CHANGED IF PROGRAM HAS WRITE ACCESS TO FILE

WRTR:	0			;FBTYP ,, FBLEN
	FB%SEC+FB%NOD+FB%FCF+FB%FOR ;[9041] FBFLG
	0			;FBEXL
	0			;FBADR
	0			;FBPRT
	0			;FBCRE
	0			;FBAUT
	0			;FBGEN
	0			;FBACT
	007717000000		;FBGNR, FBBSZ, FBMOD ,, FBNPG
	777777777777		;FBSIZ
	777777,,777777		;FBCRV
	777777,,777777		;FBWRT
	777777,,777777		;FBREF
	0			;FBNWR ,, FBNRF
	0			;FBBK0
	0			;FBBK1
	0			;FBBK2
	0			;FBBBT
	0			;FBNET
	0			;FBUSW
	0			;FBGNL
	0			;FBNAM
	0			;FBEXT
	0			;FBLWR
	0			;FBTDT
	0			;FBFET
	0			;FBTP1
	0			;FBSS1
	0			;FBTP2
	0			;FBSS2
;BITS WHICH CAN BE CHANGED IF PROGRAM HAS OWNER ACCESS TO FILE

OWNER:	0			;FBTYP ,, FBLEN
	FB%SEC+FB%PRM+FB%TMP+FB%DEL+FB%NOD+FB%INV+FB%FCF+FB%FOR ;[9041] FBFLG
	0			;FBEXL
	0			;FBADR
	000000777777		;FBPRT
	0			;FBCRE
	0			;FBAUT
	0			;FBGEN
	0			;FBACT
	777717000000		;FBGNR, FBBSZ, FBMOD ,, FBNPG
	777777777777		;FBSIZ
	777777,,777777		;FBCRV
	777777,,777777		;FBWRT
	777777,,777777		;FBREF
	0			;FBNWR ,, FBNRF
	0			;FBBK0
	0			;FBBK1
	0			;FBBK2
	0			;FBBBT
	0			;FBNET
	777777777777		;FBUSW
	0			;FBGNL
	0			;FBNAM
	0			;FBEXT
	0			;FBLWR
	0			;FBTDT
	0			;FBFET
	0			;FBTP1
	0			;FBSS1
	0			;FBTP2
	0			;FBSS2
;BITS WHICH CAN BE CHANGED IF PROGRAM HAS WHEEL OR OPERATOR CAPABILITIES

WOPR:	0			;FBTYP ,, FBLEN
	FB%SEC+FB%PRM+FB%TMP+FB%DEL+FB%NOD+FB%INV+FB%FCF+FB%NDL+FB%WNC+FB%FOR ;[9041] FBFLG
	0			;FBEXL
	0			;FBADR
	000000777777		;FBPRT
	777777777777		;FBCRE
	0			;FBAUT
	0			;FBGEN
	0			;FBACT
	777777,,777777		;FBGNR, FBBSZ, FBMOD ,, FBNPG
	-1			;FBSIZ
	777777777777		;FBCRV
	777777777777		;FBWRT
	777777777777		;FBREF
	777777777777		;FBNWR ,, FBNRF
	777777777777		;FBBK0 DUMPER INCREMENTAL SAVE DATA
	-1			;FBBK1 DUMPER LAST BACKED UP ON TAPE DATA
	0			;FBBK2
	AR%1ST+AR%WRN		;FBBBT
	0			;FBNET
	777777777777		;FBUSW
	0			;FBGNL
	0			;FBNAM
	0			;FBEXT
	0			;FBLWR
	0			;FBTDT
	0			;FBFET
	0			;FBTP1
	0			;FBSS1
	0			;FBTP2
	0			;FBSS2
	SUBTTL CLOSF JSYS

; Close a file
; Call:	RH(1)	; Jfn
;	1(0)	; If 1 do not release jfn
;	CLOSF
; Returns
;	+1	; Cannot close
;	+2	; Ok

.CLOSF::MCENT
	CAMN 1,[-1]		; -1 means all
	JRST CLZALL
	HRRZ JFN,1
	CAIE JFN,.PRIIN		;PRIMARY DESIGNATOR?
	CAIN JFN,.PRIOU
	SMRETN			;YES, DO NOTHING BUT RETURN GOOD
	CALL CLZF
	 RETERR()		; Can't close, reason in a
	XCTU [SKIPL 1]		; Don't release jfn
	TQNE <OPNF>		; Or still open?
	SMRETN			; Yes. all done.
	CALL RELJFN		; No, release jfn.
	SMRETN

CLZALL:	MOVEI A,.FHSLF		;SAME AS CLZFF ON SELF
	CLZFF
	SMRETN
;CLOSF...

CLZF::	MOVEI A,CLSX2
	HRRZ B,PRIMRY
	HLRZ C,PRIMRY		;DONT CLOSE PRIMARY IN OR OUT
	CAME JFN,C
	CAMN JFN,B
	RET
	PUSH P,JFN		;SAVE THIS IN CASE OF BLOCK
	CALL CHKJFD
	 JRST [	POP P,(P)	; Garbage
		RET]
	 JFCL
	 JRST [	POP P,(P)	; Byte and tty always succeeds
		RETSKP]
	TQNN <OPNF>
	JRST [	POP P,(P)
		MOVEI A,CLSX1
		JRST UNLCKF]
	MOVSI B,1
	ANDCAB B,FILLFW(JFN)
	TLNN B,777777
	IFSKP.
	  CALL CLZMRC		;TRY TO REASSIGN MAP COUNT
	ANNSK.
	  CALL CLZMFE		;COULDN'T, MAKE FILE EXISTENT
	  POP P,0(P)		;CLEAR STACK
	  BLCAL. DSKOK,<DEV>	;DISK?
	  IFSKP. <CALL DEWNDW>	;YES. FREE UP WINDOW PAGE THEN
	  CALL UNLCKF		;UNLOCK THE JFN
	  RETBAD(CLSX3)		;SAY STILL MAPPED
	ENDIF.
	UMOVE A,A
	AND A,[CZ%ABT+CZ%NUD]	;ACCEPT ONLY THESE FLAGS
	MOVE B,0(P)		;PASS DOWN JFN
	CALL CLZDO		;DO DEVICE CLOSE AND DEASSIGN STUFF
	 JRST CLZFW		;DIDNT CLOSE, SEE IF BLOCKING
CLZF2:	POP P,(P)		;CLEAR OUT STACK
	CALL UNLCKF
	RETSKP

CLZFW:	TQZN <BLKF>		;DOES SERVICE ROUTINE WANT TO BLOCK?
	 JRST [POP P,(P)	;NO, CLEAR OUT STACK
		CALLRET UNLCKF]	;AND UNLOCK AND RETURN UNSUCCESSFULLY
	MOVSI B,1		;RESTORE MAP COUNT AGAIN SO THAT
	IORM B,FILLFW(JFN)	; FILES ARE NOT INADVERTANTLY CLOSED
	CALL UNLDIS		;YES, GO BLOCK
	POP P,JFN		;GET BACK THE JFN AGAIN FOR CHKJFN
	SE1ENT
	JRST CLZF		;TRY AGAIN
;TRY TO REASSIGN MAP COUNT FROM THIS JFN TO SOME OTHER JFN
;WITH THE SAME OFN
; JFN/ THE JFN INDEX
;	CALL JFNRMC
; RETURN +1: FAILED, COUNT STILL NON-0
; RETURN +2: OK, COUNT NOW 0

CLZMRC:	MOVEI A,0(JFN)		;GET JFN
	CALL DMOCHK		;SEE IF DISMOUNTED
	 RETSKP			;IT IS. SAY IT SUCCEEDED
	MOVX A,OPNF		;CLEAR OPNF SO OFNJFN WILL NOT FIND
	ANDCAM A,FILSTS(JFN)	;THIS JFN
	MOVEI A,0		;SAY PAGE 0
	CALL JFNOF1		;CONSTRUCT ID FOR PAGE 0 THIS FILE
	 JRST CLZMRX		;COULDN'T, FAIL
	CALL OFNJFL		;FIND A JFN FOR THIS OFN
	 JRST CLZMRX		;NOT FOUND
	HLLZ B,FILLFW(JFN)	;GET COUNT FROM ORIG JFN
	ADDM B,FILLFW(A)	;MOVE IT TO NEW JFN
	CALL LUNLKF		;UNLOCK JFN AND STRUCTURE
	OKINT			;AND UNDO THE NOINT
	HRRZS FILLFW(JFN)	;CLEAR IT FROM ORIG JFN
	MOVX A,OPNF
	IORM A,FILSTS(JFN)	;RESTORE OPNF
	RETSKP

CLZMRX:	MOVX A,OPNF		;RESTORE OPNF
	IORM A,FILSTS(JFN)
	RET

;MAKE FILE EXISTENT.  DONE WHEN FILE CANNOT BE CLOSED BECAUSE OF
;NON-0 MAP COUNT, BECAUSE LATER CLOSE MIGHT BE DONE BY CLZFF WITH
;CZ%ABT WHICH WOULD VANISH NON-EXISTENT FILE

CLZMFE:	CALL GETFDB		;GET THE FDB FOR THIS JFN
	 RET			;COULDN'T, ASSUME OK
	MOVX B,FB%NXF
	TDNE B,.FBCTL(A)	;DON'T CAUSE WRITE IF ALREADY CLEAR
	ANDCAM B,.FBCTL(A)	;CLEAR NONX
	CALLRET USTDIR		;RELEASE DIRECTORY AND RETURN
	SUBTTL CLZFF JSYS

;CLOSE FILES RELATIVE TO SPECIFIED FORK
; 1/	CZ%NIF (B0) - NO INFERIOR FORK FILES
;	CZ%NSF (B1) _ NOT AT SPECIFIED FORK
;	CZ%NFJ (B2) - NO RELEASE JFN'S
;	CZ%NCL (B3) - NO CLOSE FILES
;	CZ%UNR (B4) - UNRESTRICT FILES
;	CZ%ARJ (B5) - WAIT UNTIL MAP COUNT IS 0
;	CZ%ABT (B6) - ABORT, I.E. FLUSH NONX FILES AND NO WAIT FOR IO
;	CZ%NUD (B7) - NO UPDATE DIRECTORY
;	RH: FORK HANDLE
;	CLZFF
; RETURN +1: ALWAYS
; Traps if fork handle is bad

.CLZFF::MCENT
CLZFF0:	HRRZS A
	CALL FLOCK		;LOCK THE FORK STRUCTURE
	MOVX T2,<CALL CLZFF1>	;ROUTINE TO DO
	CALL MAPFKH		; Call routine to map over the fork hdl
	 JRST [	CALL FUNLK	;BLOCKING
		CALL UNLDIS	;WAIT FOR CONDITION TO BE SATISIFED
		UMOVE A,1	;GET BACK USER'S ARGS
		JRST CLZFF0]	;AND TRY AGAIN
	CALL FUNLK		;UNLOCK THE FORK STRUCTURE
	XCTU [HRRZ A,1]		;GET BACK USERS ARGUMENT
	MOVEI T2,NETN		;IS THIS AN ARPANET MONITOR?
	SKIPE T2		;DO NOT DO FOLLOWING IF WE ARE NON ARPANET
	RELIQ%			;RELEASE THE INTERNET QUEUE
	 ERJMP .+1		;IGNORE ERRORS
	JRST MRETN
;ROUTINE CALLED FOR EACH FORK SPECIFIED

CLZFF1:	TRVAR <FRKHDL>
	MOVEM T1,FRKHDL		;Save job relative fork hndl, setup by MAPFKH

	PUSH P,P6		;save this ac
	CALL ABTJCS		;abort all JCNs
	POP P,P6		;restore the ac
	MOVN JFN,MAXJFN
	HRLZS JFN

;LOOP OVER ALL JFNS

CLZFF2:	HLRZ B,PRIMRY
	CAIN B,(JFN)
	JRST CLZFF3		; Don't affect primary files
	HRRZ B,PRIMRY
	CAIN B,(JFN)
	JRST CLZFF3
	PUSH P,JFN
	PUSH P,1
	HRRZS A,JFN
	JUMPE A,CLZFF4		;ALWAYS SKIP 0
	IMULI A,MLJFN		; CONVERT TO INTERNAL INDEX
	SKIPL FILLCK(A)		;FILE LOCKED NOW?
	JRST CLZFF4		;YES, DON'T TRY TO CLOSE IT
	CALL CHKJFD		; See if this jfn is in use
	 JRST CLZFF8		; NO NAME, CHECK FOR ASGF
	 JRST CLZFF4		; Should not happen
	 JRST CLZFF4
	MOVSI B,777777
	TQNE <OPNF>		; If file is open
	TDNE B,FILLFW(JFN)	; And map count is zero
	SKIPA
	JRST CLZFF5		; Then it's ok to close it
	UMOVE C,1		;GET USER FLAGS
	HLRZ B,FILVER(JFN)
	MOVE A,(P)
	CAMN B,A		; Was this jfn created by this fork
	JRST [	TLNE C,(CZ%NSF)	; Are we to close files at the fork?
		JRST CLZFF7	; No, skip this jfn
		JRST CLZFF5]	; Yes, do it
	TXNE C,CZ%NIF		;CLOSE FILES OF INFERIOR FORKS?
	JRST CLZFF7		;NO, SKIP THIS JFN
	EXCH A,B
	CALL SKIIFA		; Skip if fork(a) < fork(b)
	JRST CLZFF7
	; ..
;CLZFF...

CLZFF5:	UMOVE C,1
	TLNE C,(CZ%UNR)		; Un restrict this file?
	TQZ <FRKF>		; Yes
	TQNE <OPNF>
	TLNE C,(CZ%NCL)
	JRST CLZFF6
	MOVSI B,1
	ANDCAB B,FILLFW(JFN)
	TLNN B,777777		;MAP COUNT NOW 0?
	JRST CLZFM1		;YES, CLOSE
	CALL CLZMRC		;NO, TRY TO REASSIGN COUNT
	 SKIPA			;COULDN'T
	JRST CLZFM1		;COUNT NOW 0, OK TO CLOSE
	UMOVE C,1		;GET FLAGS
	TXNN C,CZ%ABT		;FLUSH NONX FILES?
	CALL CLZMFE		;NO, MAKE SURE THIS ONE EXISTS
	UMOVE C,1
	TXNN C,CZ%ARJ		;WAIT FOR 0 MAP COUNT?
	JRST CLZFF7		;NO, DON'T CLOSE
;	SKIPN FORKN		;TOP FORK?
	CALL CKMMOD		;YES. FROM THE MONITOR THEN?
	 SKIPA			;NO. WAIT THEN
	JRST CLZFM1		;YES. CLOSE IT THEN
	MOVS A,TODCLK		;YES, GET TIME
	TXZ A,1B0		;ONLY USE 17 BITS
	ADD A,[^D1000,,0]	;WAIT FOR A SEC
	HRRI A,BLOCKW		;SHORT WAIT
	JRST CLZFW0		;AND WAIT A WHILE
CLZFM1:	UMOVE A,1		;GET FLAGS SET BY USER
	HRRZ B,-1(P)		;[8811] Get JFN number only
	CALL CLZDO		;DO THE WORK
	 JRST CLZFFW		;FAILED TO CLOSE, CHECK IF BLOCKING
CLZFF6:	UMOVE C,1
	SE1ENT
	TQNN <OPNF>
	TLNE C,(CZ%NRJ)
	JRST CLZFF7
	CALL UNLCKF		;[7460](JFN,STS/)FREE FILE AND STR LOCK
CLZFF9:	CALL RELJFN
	JRST CLZFF4

CLZFF7:	CALL UNLCKF
CLZFF4:	POP P,1
	POP P,JFN
CLZFF3:	AOBJN JFN,CLZFF2	;LOOP OVER ALL JFNS

; After doing all JFN's see if there are any CI connections that need to be
;cleaned up.
;
	MOVE T1,FRKHDL		;Get the job relative fork number again
	HRRZ T1,SYSFK(T1)	;Get the fork number of the target fork
	CALL SCSKIL		;Clean up after the SCS% JSYS...

	RET

	ENDTV.
;HERE ON +1 RETURN FROM CHKJFN, I.E. JFN DOESN'T EXIST OR IS RESTRICTED

CLZFF8:	CAIE A,DESX3		;[7384]ASSIGNED?
	JRST CLZFF4		;[7384]NO, SKIP IT
	MOVE B,FILST1(JFN)	;[7384]GET SECOND WORD OF STATUS BITS
	TQNE <ASGF>		;[7384]IS JFN BEING ASSIGNED?
	TXNN B,ASGF2		;[7384]MAKE SURE ASGF IS LIT, NOT BLKF
	JRST CLZFF4		;NO, SKIP IT
	HLRZ B,FILVER(JFN)	;GET FORK
	SKIPGE SYSFK(B)		;FORK STILL EXISTS?
	JRST CLZFF9		;NO, RELEASE JFN
	CAME B,FORKN		;THIS FORK?
	JRST CLZFF4		;NO, SKIP IT
	SKIPE PSIBIP		;AT INTERRUPT LEVEL?
	JRST CLZFF4		;YES, LEAVE IT ALONE
	JRST CLZFF9		;NO, RELEASE IT

;HERE IF CAN'T CLOSE BECAUSE SERVICE ROUTINE WANTS TO BLOCK

CLZFFW:	TQZN <BLKF>		;SERVICE ROUTINE WANT TO BLOCK?
	JRST CLZFF7		;NO, GO UNLOCK AND EXIT
	UMOVE B,1		;GET USER FLAGS AGAIN
	TXNE B,CZ%ABT	;WAS THE USER TRYING TO ABORT?
	BUG.(CHK,CLZABF,JSYSF,HARD,<CLZFFW - Service routine blocked on an abort close>,,<

Cause:	The device dependent service routine for a CLOSF% wants to block,
	but the user has specified an abort close.

Action:	The user will block anyway in an attempt to close the file.

>)
CLZFW0:	ADJSP P,-2		;CLEAN UP STACK
	SE1ENT			;GET TO PROPER SECTION
	RETSKP			;INDICATE WE WANT TO BLOCK
;COMMON DEVICE CLOSE FOR CLOSF AND CLZFF
;CALLED WITH CLZFF FLAGS IN A, ORIGINAL JFN I B
;RETURNS +1	NOT CLOSED OR ABOUT TO BLOCK IF BLKF IS 1
;	 +2	CLOSED OK

CLZDO:	STKVAR <CLZDOA,CLZDOJ,CLZDOX> ;[9122]
	MOVEM A,CLZDOA		; SAVE FLAGS
	MOVEM B,CLZDOJ		; SAVE JFN
	CALL CHKENQ		; CHECK IF CLOSING IS ALLOWED BY ENQ/DEQ
	 RET			; FILE IS LOCKED, DONT CLOSE IT
	MOVE A,CLZDOA		; GET FLAGS BACK
	TQZE <BLKF>		; SEE IF FLAG IS OFF
	BUG.(CHK,BLKF3,JSYSF,HARD,<CLZDO - BLKF set before call to service routine>,,<

Cause:	BLKF has been set before the call to the device dependent service
	routine which should be responsible for setting this bit.

Action:	If this BUGCHK persists, change it to a BUGHLT and find out where
	the bit is being set.
>)
	XMOVEI C,CLZDOB		;BLOCK CO-ROUTINE
	MOVE D,CLZDOJ		;PASS ALONG JFN
	CALL @CLOSD(P3)		; Call DEVice dependent stuff
	 RET
	TQZ <OPNF>
	MOVEI A,0(JFN)		;GET JFN IN A
	CALL DMOCHK		;CHECK IF DISMOUNTED
	 RETSKP			;IT IS .ALL DONE
	CALL FNDUNT		;GET DEV INDEX
	MOVX C,DV%OPN
	TDNN C,DEVCHR(A)	;ASSIGNED BECAUSE OF OPEN?
	RETSKP			;NO.
	HRRZM T1,CLZDOX		;[9122] Save index to device tables
;OPEN BIT IS STILL SET IN DEVICE TABLES. FOR TELETYPES, THIS WILL NOT
;BE TRUE BECAUSE THE DEVICE-DEPENDENT CODE BOTH DEASSIGNS THE
;DATA BLOCK AND CLEANS UP THE DEVICE TABLES.

	ANDCAB C,DEVCHR(A) 	;YES, CLEAR ASSIGNMENT
	MOVE B,DEVCH1(A)
	TXNE B,D1%ALC		;DEVICE ALLOCATED BY ALLOC JSYS?
	RETSKP			;YES. DON'T RELEASE IT
	TXNE C,DV%ASN		;ASSIGNED BY ASND?
	RETSKP			;YES. DON'T RELEASE IT
	MOVE B,A		;NO. B/ INDEX TO DEVICE TABLES
	CALL RELDEV		;GO CLEAR DEVICE TABLES
	 JRST CLZDO1		;FAILED. GO WAIT OR FAIL
	RETSKP

;RELDEV FAILED. THIS SHOULD NOT HAPPEN FOR NOW BECAUSE ONLY TELETYPE
;DEVICE DESIGNATOR CAN CAUSE THIS

CLZDO1:	TXZN T1,1B0		;HAVE TO WAIT?
	RETBAD			;NO. RETURN FAILURE
	TQO BLKF		;YES. INDICATE BLOCKING
	RETBAD
;ROUTINE TO SEE IF A FILE IS LOCKED UP BY ENQ/DEQ

;ASSUMES CHKJFN WAS CALLED
;	CALL CHKENQ
;RETURNS +1:	FILE IS LOCKED BY ENQ/DEQ AND CANNOT BE CLOSED
;	 +2:	FILE IS NOT LOCKED AND CAN BE CLOSED

CHKENQ:	MOVE A,ENQLST+1		;SEE IF ANY LOCKS ARE SET
	JUMPE A,RSKP		;IF 0, NO ENQ REQUESTS OUTSTANDING
	BLCAL. DSKOK,<<FILDEV(JFN)>> ;A DSK JFN?
	 RETSKP			;NOT A DISK, IGNORE THIS CLOSE
	SETZ A,			;GET OFN OF PAGE 0 OF FILE
	CALL JFNOF1		;GET OFN OF FILE PAGE 0
	 RETSKP			;ILLEGAL FOR THIS JFN, CLOSE CAN PROCEED
				; MAY FAIL BECAUSE STRUCTURE IS
				; DISMOUNTED
	HLRZS A			;GET THE OFN ONLY FOR ENQCLS
	HRRZ B,JFN		;GET JFN BLOCK OFFSET
	IDIVI B,MLJFN		;CONVERT TO JFN BEING CLOSED
	CALLRET ENQCLS		;SEE IF FILE CAN BE CLOSED NOW

;ROUTINE CALLED BY SERVICE ROUTINE TO BLOCK

CLZDOB:	STKVAR <SVDES>
	MOVEM DEV,SVDES		;SAVE DEVICE
	PUSH P,T2		;SAVE JFN
	CALL UNLDIS		;UNLOCK AND BLOCK
	POP P,JFN		;RESTORE JFN
	CALL CHKJFD
	 RETBAD ()
	 JFCL
	 RETBAD (DESX3)
	CAME DEV,SVDES 		;CHECK TO SEE IF DEVICE THE SAME
	RETBAD (DESX4)		;YOU CAN'T CHANGE DESCRIPTOR
	RETSKP			;CONTINUE
	SUBTTL CRDIR JSYS

;CRDIR -  CREATE FILE DIRECTORY OR MODIFY PARAMETERS.
;ACCEPTS:
;	A/ POINTER TO STRUCTURE:<DIRECTORY> STRING
;	B/ (FLAGS,,ADDRESS OF ARGUMENT BLOCK)
;	C/ POINTER TO PASSWORD STRING

;	CRDIR

; Returns +1: Error
;	  +2: Success
;		A/ (STRUCTURE UNIQUE CODE,,DIRECTORY number)

; In parameter block
;	.CDLEN=0	; (FLAGS,,LENGTH OF ARGUMENT BLOCK (LENGTH NOT USED))
;	.CDPSW=1	; Pointer to password string, 0 if none
;	.CDLIQ=2	; WORKING STORAGE (LOGGED-IN) QUOTA
;	.CDPRV=3	; PRIVILEGE BITS
;	.CDMOD=4	; MODE BITS
;		CD%DIR	;FILES-ONLY DIRECTORY
;		CD%ANA	;ALPHANUMERIC ACCOUNTS ALLOWED
;		CD%RLM	;REPEAT SYSTEM MESSAGES ON LOGIN
;		CD%SEC	;[9041] Secure directory
;	.CDLOQ=5	; PERMANENT STORAGE (LOGGED-OUT) QUOTA
;	.CDNUM=6	; DIR NUMBER
;	.CDFPT=7	; DEFAULT FILE PROTECTION
;	.CDDPT=10	; DIRECTORY PROTECTION
;	.CDRET=11	; DEFAULT # OF GENERATIONS TO KEEP
;	.CDLLD=12	; DATE OF LAST LOGIN
;	.CDUGP=13	; POINTER TO USER GROUPS
;	.CDDGP=14	; POINTER TO DIR GROUPS
;	.CDSDQ=15	; MAXIMUM NUMBER OF SUBDIRECTORIES
;	.CDCUG=16	; POINTER TO ALLOWED USER GROUPS FOR SUBDIR
;	.CDDAC=17	; Pointer to default account
;	.CDDNE=20	; Default online expiration
;	.CDDFE=21	; Default offline expiration
.CRDIR::MCENT
	CALL CKMMOD		;[9041] (/) Monitor mode?
	IFNSK.			;[9041] No, then gotta ask ACJ
	  CALL CRDGOK		;[9041] (/) Get a kiss from ACJ
	   ITERR ()		;[9041] Guess ACJ isn't in a suck-face mood
	  CALL PWDICT		;[9054] (/T1) See if password in dictionary
	   ITERR ()		;[9054] Password was illegal in some way
	ENDIF.			;[9041]
	UMOVE Q3,2		;GET FLAGS AND POINTER TO BLOCK
	UMOVE A,1		;GET STRING POINTER TO NAME
	MOVEI B,2*MAXLW+2	;39-DEV:<39-DIR> + 1 HEADER WORD
	CALL CPYUSR		;Copy directory name string
	 ITERR CRDIX3		;No room in jsb
	NOINT			;[8856] Be NOINT the entire time
	CALL CRDIR0		;GO DO THE WORK
	 ITERR (,OKINT)		;[8856] An error occured
	OKINT			;[8856] Housekeeping 
	JRST MRETN		;EXIT
;[9041]
;CRDGOK - Routine called before any CRDIR% work is done. This routine
;sets up a special argument block for the ACJ and asks permission from
;the ACJ for this user.
;
; Called with:
;	no arguments
;	CALL CRDGOK
;
; Returns:
;	+1 - Failure,
;	     T1/ Error code
;	+2 - Success, ACJ is allowing the CRDIR%

CRFSP==<.GOABK+.CDFPA+1>	;[9046] Number of words in free space block

CRDGOK:	SKIPN ACJFN		;Have an ACJ?
	RETSKP			;No, don't bother to ask
	SAVEQ			;Save the destroyed items
	STKVAR <CRDFRB,ERCOD,<LOGNM,MAXLW*2>> ;Temp storage
	SETZM LOGNM		;Clear first word
	NOINT			;No bothering me while I have freespace
	HRRZI T1,CRFSP		;Want this many words of freespace
	HRLI T1,.RESP3		;Lock down freespace if there ain't none
	MOVEI T2,.RESGP		;Get it from the general pool
	CALL ASGRES		;(T1,T2/T1) Get freespace block
	 RETBAD (MONX05,OKINT)	;Couldn't so don't let CRDIR% happen
	MOVEM T1,CRDFRB		;Stash freespace block address
	MOVEI T2,CRFSP		;Get block size
	MOVEM T2,.GOSIZ(T1)	;And save it here
	UMOVE T2,T2		;Get user flags
	MOVEM T2,.GOBLK(T1)	;Save user's flag
	UMOVE T2,T1		;Get user's byte pointer
	TLC T2,-1		;Does we have -1,,ADDR?
	TLCN T2,-1		;Well?
	HRLI T2,(POINT 7,)	;Yes we do, make it legal
	XCTBU [ILDB T3,T2]	;Get first character
	 ERJMP CRDGK0		;Bad user
	;..
	;..
	XMOVEI T1,.GOUSR(T1)	;Username string starts here
	TXO T1,<OWGP. 7>	;Make it a one word global byte pointer
	CAIE T3,.CHDI1		;Does string begin with a valid
	CAIN T3,.CHDI2		;  directory punctuation ?
	IFSKP.			;No, so check for logical name
	  MOVEI T4,LOGNM	;Put logical name here
	  HRLI T4,(POINT 7,)	;Make real byte pointer
	  IDPB T3,T4		;Save first character
	  DO.			;Scan all characters
	    XCTBU [ILDB T3,T2]	;Get another character
	     ERJMP CRDGK0	;Failed
	    CAIE T3,.CHDI1	;Get a directory starter?
	    CAIN T3,.CHDI2	;How about this kind?
	    JRST CRDGO0		;Yes, there is a directory here somewhere
	    IDPB T3,T4		;Save character in case of logical name
	    JUMPN T3,TOP.	;Null character? If not, get more
	  OD.
	  MOVE T3,T1		;Get destination location of logical name
	  HRROI T2,LOGNM	;Here's the logical name
	  MOVEI T1,.LNSJB	;Want job logical
	  LNMST%		;Try to translate logical name
	  IFJER.		;If can't
	    CAIE T1,LNSTX1	;No such job logical?
	    JRST CRDGK1		;Nope, something bad happened
	    MOVEI T1,.LNSSY	;Try system wide
	    LNMST%		;Do it
	     ERRJMP (RCDIX2,CRDGK1)
	  ENDIF.
	  JRST CRDGO1		;Logical name translated, so use it
	ELSE.			;Started with directory delimiter
	  MOVE T1,[POINT 7,[ASCIZ/DSK:/]] ;Default the device then
	  STDEV%		;Convert logical names to physical
	   ERJMP CRDGK0		;Something blew up
	  MOVE T1,CRDFRB	;Get freespace block back
	  XMOVEI T1,.GOUSR(T1)	;Username string starts here
	  TXO T1,<OWGP. 7>	;Make it a one word global byte pointer
	  DEVST%		;Put the physical name there
	   ERJMP CRDGK0		;Failed, cleanup the spill
	  MOVEI T2,":"		;End the string name with a colon
	  IDPB T2,T1		;Slam in ":"
	ENDIF.
	;...
;At this point, T1 has an updated byte pointer and we can now copy from user
;space.
	;...
CRDGO0:	MOVE Q1,T1		;Put byte pointer here
	UMOVE T2,T1		;Get user's byte pointer back
	TLC T2,-1		;Does we have -1,,ADDR?
	TLCN T2,-1		;Well?
	HRLI T2,(POINT 7,)	;Yes we do, make it legal
	MOVEI T3,<MAXLW+MAXLC+4> ;Get maximum character count
	DO.			;Loop over all characters
	  XCTBU [ILDB T4,T2]	;Get a byte from the user
	   ERJMP CRDGK0		;Something bad happened
	  JUMPE T4,CRDG05	;If null, don't check
	  CAIL T4,"A"+40	;Are we lowercase?
	  CAILE T4,"Z"+40	;Still in lowercase range?
	  SKIPA			;No, don't tickle the character
	  TRZ T4,40		;Raisin this character to new heights
	  CAIN T4,"V"-100	;Is it ^V?
	  ERRJMP (GJFX56,CRDGK1) ;Yes, this is not good
	  MOVE T1,T4		;Put character in good place first
	  CAIN T1,.CHDEV	;Device terminator?
	  JRST CRDG05		;Skip the quote check
	  CAIE T1,.CHDI1	;Get a directory starter?
	  CAIN T1,.CHDI2	;How about this kind?
	  JRST CRDG05		;Skip the quote check
	  CAIE T1,.CHDT1	;Directory terminator?
	  CAIN T1,.CHDT2	;Or goofy kind?
	  JRST CRDG05		;Skip the quote check
	  CAIN T1,"."		;How about a seperator?
	  JRST CRDG05		;Yes, don't check for quote
	  CALL QUOCHK		;(T1/) Need a ^V?
	   SKIPA		;No, so continue
	  ERRJMP (GJFX56,CRDGK1) ;Not a good directory spec
CRDG05:	  IDPB T4,Q1		;Save in monitor block
	  JUMPE T4,ENDLP.	;All done?
	  SOJG T3,TOP.		;Too many characters?
	  MOVEI T4,.CHNUL	;Yes, end with null now
	  IDPB T4,Q1		;Stash the null
	OD.
CRDGO1:	MOVEI T1,.CDFPA+1	;Make sure we get the whole block
	MOVE T3,CRDFRB		;Get back freespace block
	XMOVEI T3,.GOABK(T3)	;Want to stash user arg block here
	XCTU [HRRZ T2,2]	;Get address of argument block in user space
	CALL BLTUM1		;(T1-T3/T1-T3) Get user's argument block in freespace
	;..
	;..
;[9052]
;We will clear out the password byte pointer word, the user group word
;and the directory group word if these items are being set to nothing.
;This flags the ACJ so it can make wonderfully intelligent decisions.

	MOVE T1,CRDFRB		;Here's the freespace address
	UMOVE T2,T2		;[9052] Get user's argument block
	TXNN T2,CD%PSW		;[9052] User trying to set password?
	IFSKP.			;[9052] If so,
	  HRRZ T3,T2		;[9052] Get argument block address
	  XCTU [SKIPN T3,.CDPSW(T3)] ;[9052] Did we get a byte pointer?
	  IFSKP.		;[9052] If so,
	    TLC T3,-1		;[9052] did user get lazy with -1,,ADDR?
	    TLCN T3,-1		;[9052] Well?
	    HRLI T3,(POINT 7,)	;[9052] Yes we do, make it legal
	    XCTBU [ILDB T4,T3]	;[9052] Get a byte from user
	    SKIPN T4		;[9052] Is it a null?
	    SETZM <.GOABK+.CDPSW>(T1) ;[9052] Yes, say so for ACJ
	  ENDIF.		;[9052]
	ENDIF.			;[9052]
	TXNN T2,CD%UGP		;[9052] Trying to set user groups?
	IFSKP.			;[9052] If so,
	  HRRZ T3,T2		;[9052] Get the user's argument block
	  XCTU [SKIPN T3,.CDUGP(T3)] ;[9052] Pointer to user groups?
	  IFSKP.		;[9052] User has a block here
	    UMOVE T3,(T3)	;[9052] Get first word of argument block
	    SOSG T3		;[9052] Is it 1 or less? If so, then no groups
	  ENDIF.		;[9052]
	  SETZM <.GOABK+.CDUGP>(T1) ;[9052] No user groups, clear this
	ENDIF.			;[9052]
	TXNN T2,CD%DGP		;[9052] Setting directory groups?
	IFSKP.			;[9052] Looks like it
	  HRRZ T3,T2		;[9052] Get argument block
	  XCTU [SKIPE T3,.CDDGP(T3)] ;[9052] Any directory groups?
	  IFSKP.		;[9052] User has a block here
	    UMOVE T3,(T3)	;[9052] Get first word of argument block
	    SOSG T3		;[9052] Is it 1 or less? If so, then no groups
	  ENDIF.		;[9052]
	  SETZM <.GOABK+.CDDGP>(T1) ;[9052] Flag no directory groups
	ENDIF.			;[9052]
	GTOKM (.GOCRD,<T1>,CRDGK1) ;Get permission from ACJ
	CALL RELRES		;(T1/) Give back freespace block
	OKINT			;Interrupts are cool now
	RETSKP			;And return good because the ACJ said so
;Here on failures
CRDGK0:	MOVE T1,LSTERR		;Error will be here
CRDGK1:	MOVEM T1,ERCOD		;Save error code for a bit
	MOVE T1,CRDFRB		;Get freespace block back
	CALL RELRES		;(T1/) Give it back
	OKINT			;Interruptable now
	MOVE T1,ERCOD		;Retrieve error code
	RETBAD ()		;And back to caller

	ENDSV.			;End of CRDGOK's STKVAR scope
;[9054] PWDICT - routine to see if password is in password dictionary
;and checks length of supplied password.  Smashes T1-T4.
;	
;Returns +1 If illegal password (password found in dictionary or too short)
;	T1/ CRDI30 if password too short
;	T1/ CRDI33 if password in dictionary
;	T1/ ARGX01 if password too long
;Returns +2 If legal password (long enough password not found in dictionary)
;
;Note AC STS is P1, JFN is P2

	PWDBSZ==MAXLW*2		;Size of password dictionary buffer (80 chars)

;The following two tables are used to remember where each letter starts in the
;password dictionary.  These tables are built once and then used by anyone 
;searching the password dictionary.

NR PWDWRT,1			;Write date-time of the file
NR PWDXPT,<"Z"-"A">+1		;For each letter, byte count where it starts
NR PWDXPG,<"Z"-"A">+1		;For each letter, page count,,mapped page

;First determine if we have any work to do today.

PWDICT:	SAVEPQ			;Mind your Ps and Qs (STS is P1 and JFN is P2)
	TRVAR <PWDCNT,PWDPAG,PWDPGC,PWDPTR,<PWDSTR,MAXLW>,<PWDBUF,PWDBSZ>>
	UMOVE T2,2		;Load user's AC2
	TXNN T2,CD%PSW		;Setting password?
	RETSKP			;Nope, return OK
	TXNN T2,CD%LEN		;[9174] Does .CDLEN have flags in it?
	IFSKP.			;[9174] Yes, need to check encryption flag
	  TLZ T2,-1		;Get the address only
	  UMOVE T1,.CDLEN(T2)	;Load the user's flag words from block
	   ERJMP RSKP		;Skip return if this fails
	  TXNE T1,CD%PEN	;Password is encrypted already?
	  RETSKP		;Yes, skip return now
	ENDIF.			;[9174] Check the non-encrypted password
;[9054] User is setting a password, read in the password converting it to upper
;case and counting characters.

	UMOVE T1,.CDPSW(T2)	;Load pointer to password please
	TLC T1,-1		;Check for -1,,address
	TLCN T1,-1		; and if it is so
	HRLI T1,(POINT 7)	;  make it a real 7 bit byte pointer
	MOVEI T2,PWDSTR		;Point to place to build string
	HRLI T2,(POINT 7)	;Make that a byte pointer too
	MOVSI T4,-<MAXLW*5>	;[9078] Load -40,,0 for AOB pointer
	SETZM PWDSTR		;Clear first word for later check
	DO.			;Loop to convert lowercase to upper case
	  XCTBU [ILDB T3,T1]	;Get a character of password
	   ERJMP [RETBAD (ARGX01)] ;Return "Invalid Password"
	  CAIL T3,"a"		;Is it 
	  CAILE T3,"z"		; lowercase?
	  CAIA			;Nope, keep going
	  SUBI T3,"a"-"A"	;Convert to upper case
	  IDPB T3,T2		;Store in our special place
	  JUMPE T3,ENDLP.	;If that was the null, get out of the loop
	  AOBJN T4,TOP.		;Count char and loop if more room there
	  RETBAD (ARGX01)	;Password too long, return "Invalid password"
	OD.			;End of upper case conversion loop
	SKIPN PWDSTR		;Is there a non null password now?
	RETSKP			;Null password always is good

;The right half of T4 now contains the character count for this password.

	TLZ T4,-1		;Clear the left half (AOB count)
	CAMGE T4,MINPAS		;Is this password string long enough?
	RETBAD (CRDI30)		;No, return failure

;Continue only if password dictionary feature is enabled.

	SKIPN PWDFLG		;If this cell is nonzero then we continue
	RETSKP			;Skip return if dictionary not enabled
				;Fall through to consult password dictionary
;[9054] We have the password to check, try and get the password file opened.

	MOVX T1,GJ%SHT!GJ%OLD!GJ%PHY ;Please find an old file physical 
	HRROI T2,[ASCIZ/SYSTEM:PASSWORD.DICTIONARY/] ;This is the file
	GTJFN%			;Try and get a JFN on it
	 ERJMP RSKP		;Skip return if we can't get JFN on it
	MOVEM T1,JFN		;We got a JFN, save it
	MOVX T2,FLD(7,OF%BSZ)!OF%RD ;Reading 7 bit bytes today
	OPENF%			;Pry it open
	 IFJER.			;If error
	   MOVE T1,JFN		;Reload the JFN
	   RLJFN%		;Release it
	    ERJMP .+1		;Ignore errors
	   RETSKP		;Skip return to allow password
	 ENDIF.			;End of OPENF failure code

;File is open, get its size in pages for later.

	SIZEF%			;Get size of file
	 ERJMP PWDPOK 		;(JFN/) If error, punt file and skip return
	MOVEM T3,PWDPGC		;Save page count here right now
	MOVE Q3,PWDPGC		;Save the page counter (incase index built)

;Get the file's last write date and see if is the same one we just read.

	MOVX T2,<1,,.FBWRT>	;Getting one word, the last write date
	MOVX T3,T4		;Getting it into T4 this time
	GTFDB%			;Get that word from the file's FDB
	 ERJMP PWDPOK		;If error just get out of here
	CAMN T4,PWDWRT		;Does the last write data match?
	SKIPN PWDXPG		;Is there an index built for "A"?
	SKIPA T1,[PWDXPG,,PWDXPG+1] ;Nope, have to rebuild, load index
	JRST PWDPLP		;Yes, we have already read this file once
	SETZM PWDXPG		;Clear the first index entry
	BLT T1,PWDXPG+<"Z"-"A">	;Clear all entries in the table 
	MOVEM T4,PWDWRT		;Save this as the new last write date
	SETOM PWDPAG		;Indicate first page to map is page zero
	SETZM PWDCNT		;Indicate that buffer is empty now
;[9054] OK, we have decided to rebuild the index pointers to the password file.
;Set up PWDXPT+char/ character count in page to start at
;	PWDXPG+char/ pages left in file,,page currently mapped
;This is used by the code on the next page

PWDILP:	MOVE Q1,PWDCNT		;Copy the character counter before call
	MOVE Q2,PWDPAG		;Copy the page number in file
	HRL Q2,PWDPGC		; and the page counter for possible later use
	CALL PWDCHR		;(JFN/T1) Read first character of line
	 JRST PWDPLP		;End of file, we are done now
	CAIGE T1,"A"		;Is it A yet?
	IFSKP.			;Yes, it is a legal starting character
	  CAILE T1,"Z"		;Is it greater than Z?
	  MOVEI T1,"Z"		;Yes, use last index in table for this
	  SKIPE PWDXPG-"A"(T1)	;Do we know where this starts yet?
	  IFSKP.		;Nope, we have the beginning of it
	    MOVEM Q1,PWDXPT-"A"(T1) ; and save it there for later use
	    MOVEM Q2,PWDXPG-"A"(T1) ;  and save that for later use also please
	  ENDIF.		;Finished with this line
	  CAIN T1,"Z"		;Was that Z?
	  JRST PWDPLP		;Yes, we are now finished building index
	ENDIF.			;End of legal character check
	DO.			;Now we need a loop to eat until EOL
	  CALL PWDCHR		;(JFN/T1) Load the next character
	   JRST PWDPLP		;Give up if it is now the end of the file
	  CAIN T1,.CHLFD	;Is it a linefeed?
	  JRST PWDILP		;Yes, start of a new line
	  LOOP.			;Nope, keep looking for end of line
	OD.			;End of loop eating until end of line
;[9054] Here when the pointers to the beginning of each word are known, find
;the proper one for this file and set it up for reading.  From the stored index
;entries, we will extract a new PWDCNT, PWDPTR, PWDPGC, PWDPAG.  This code also
;sets P3/ first password character for later checking.

PWDPLP:	SETOM PWDPAG		;Assume that we are going to start 
	SETZM PWDCNT		; at the beginning of the file
	MOVEM Q3,PWDPGC		;  so reset these three things to reflect that
	MOVE P3,PWDSTR		;Load first word of password
	LSH P3,-^D<36-7>	;Shift over to proper position for an index
	CAIGE P3,"A"		;Less than the first index?
	JRST PWDLOP		;Yes, it was less than "A" start at beginning
	CAILE P3,"Z"		;Is the first character bigger than last index?
	MOVEI P3,"Z"		;Yes, start with last index instead

	SKIPN T2,PWDXPG-"A"(P3)	;Get count,,page number only if one set
	JRST PWDLOP		;Start at beginning of file if no index set
	HRREM T2,PWDPAG		;Save the page number to start at
	HLRZM T2,PWDPGC		; and the pages left to map in file
	MOVE T2,PWDXPT-"A"(P3)	;Load the character count in buffer to start
	MOVEM T2,PWDCNT		;Save the count of characters in buffer
	MOVEI T2,PGSIZ*5	;Load max characters that could be in buffer
	SUB T2,PWDCNT		;Compute what character we were on today
	ADJBP T2,[POINT 7,FPG0A] ;Get the file text pointer to that next char
	MOVEM T2,PWDPTR		; and save it for lower level routines
	SKIPL PWDPAG		;Do we need to map in the page?
	CALL PWDMAP		;(JFN/) Yes, map it in now please
				;Fall through to PWDLOP
;[9054] Loop through the password file reading a line at a time from it and
;checking the furnished password.  P3/ first character of password.

PWDLOP:	CALL PWDLIN		;(JFN/) Read a line from password file
	 JRST PWDPOK		;If end of file we are done
	MOVE T1,PWDBUF		;Load the first word of buffer
	LSH T1,-^D<36-7>	;Shift over to proper position for an index
	CAMLE T1,P3		;Are we to the next letter yet?  (watch ^Ls!)
	JRST PWDPOK		;Yes, password is not found in file

;Check this entry against the supplied password.

	CALL PWDMAT		;(/) Check password against line from dict
	 JRST PWDLOP		;Password was not found, check next one in file

;Entry was found in the dictionary, give the user an error code please.

	CALL PWDCLS		;(JFN/) Close the password file JFN
	RETBAD (CRDI33)		;Return invalid password error code

;Here if password is OK, close the file and return +2.

PWDPOK:	CALL PWDCLS		;(JFN/) Close password file
	RETSKP			;Skip return because password is OK

;Here to close password file, call with JFN/ file's open JFN
;Returns +1 always.

PWDCLS:	SETZ T1,		;Indicate no mapping desired
	MOVEI T2,FPG0A		;Load address (not page number)
	CALL SETMPG		;(T1,T2/) Unmap old page

	MOVE T1,JFN		;Load JFN of password file
	CLOSF%			;Close it
	 ERJMP .+1		;Ignore errors at this point
	RET			;Return +1 always
;[9054] Compare password against the string we read in.  Each entry specifies
;a base word.  If after the base word there is a comma, then suffixes are
;possible.  Each suffix is listed after the word.  If the suffix is preceeded
;by a backslash then the last base word letter is deleted before the suffix is
;checked.  If the suffix starts with quote, the last base word's letter is
;doubled.
;
;Examples:	ABACK = ABACK
;		ABBY, 'S = ABBY, ABBY'S
;		ABLE, \Y = ABLE, ABLY
;		ABUT, S, "ED, "ING = ABUT, ABUTS, ABUTTED, ABUTTING
;
;AC usage in this routine
;	T1/ last non matching character from password string
;	T2/ pointer to password string
;	T3/ last character from dictionary string
;	T4/ pointer to directory string entry
;	Q1/ copy of T1 at last match
;	Q2/ copy of T2 at last match
;Returns +1 if password didn't match
;Returns +2 if password matched

PWDMAT:	MOVEI T2,PWDSTR		;Point to place to build string
	HRLI T2,(POINT 7)	;Make that a byte pointer too
	MOVEI T4,PWDBUF		;Point to password buffer
	HRLI T4,(POINT 7)	;Make a byte pointer out of that
 	SETZ T1,		;Clear current character
	DO.			;Loop looking at the characters
	  DMOVE Q1,T1		;Save last password character and pointer match
	  ILDB T1,T2		;Load a byte from the source password
	  ILDB T3,T4		;Load a dictionary word pointer
	  CAIN T1,(T3)		;Does this character match?
	  JRST TOP.		;Yep keep looking
	OD.			;End of character compare loop

	CAIE T3,","		;Is it the end of a base word
	CAIN T3,.CHCRT		; or is it a return (end of word)?
	JUMPE T1,RSKP		;Yes, and if end of string, we match base word

	CAIN T3,.CHCRT		;Is it end of dictionary entry?
	RET			;Yes, word was not found
	SETZ STS,		;Assume match is at last base word character
	CAIN T3,","		;Is it a comma at end of base word?
	JRST PWDMA2		;Yes, try suffixes
	ILDB T3,T4		;No, check next character for backslash case
	CAIE T3,","		;Comma?
	RET			;Nope, mismatch before last char, try next word
	AOJA STS,PWDMA2		;Rememember to match \suffix only
;[9054] Here if password didn't match the dictionary word.  See if it matches
;any suffix of this base word.  Now the ACs are:
;	T1/ Last non matching character from password string
;	T2/ ILDB pointer to last non matching password string
;	T3/ Last character from dictionary string (comma)
;	T4/ ILDB pointer to dictionary string entry, last character was comma
;	Q1/ Last matched password character (character previous to one in T1)
;	Q2/ ILDB pointer to last match (copy of T2 that got character in Q1) 
;	Q3/ Copy of T4 that points to first real suffix character
;	STS/ Nonzero if backslash suffix should be only possible try
;	JFN/ still has the JFN of the password file
;	P3/ still has first character of attempted password string

PWDMA2:	ILDB T3,T4		;Load the character after the comma
	CAIE T3," "		;Is it a space?
	RET			;Nope, no match possible check next word
	MOVE Q3,T4		;Copy the current pointer
	ILDB T3,T4		;Get character after the space

	IFN. STS		;If backslash case
	  CAIE T3,"\"		;Is it a backslash?
	  JRST PWDMA5		;No, look for next suffix
	  DMOVE T1,Q1		;Reload last character matched and its pointer
	  JRST PWDMA3		; and look at this suffix to see if it matches
	ENDIF.			;Not a backslash

	CAIE T3,""""		;Is it a quote?
	IFSKP.			;Yes
	  DMOVE T1,Q1		;Copy the old pointer back
	  ILDB T1,T2		;Load the next character
	  CAIN T1,(Q1)		;Is the last matched equal the current char?
	  JRST PWDMA3		;Yes, continue checking the other characters
	  JRST PWDMA5		;Nope, look for next suffix
	ENDIF.			;End of quote case

	MOVE T4,Q3		;Not special char, copy pointer to the suffix
	DMOVE T1,Q1		;Reload last character matched and its pointer
				;Fall through to PWDMA3
;[9054] Keep checking the suffix and the base string.
;Now the ACs should be
;	T1/ last non-matched character from password string
;	T2/ ILDB pointer to last non-matching password character
;	T3/ last character from dictionary string 
;	T4/ ILDB pointer to dictionary suffix substring
;	Q1/ last matched password character
;	Q2/ ILDB pointer to last matched password character

;Now we are ready to see if this word matches the suffix.
;T2/ ILDB pointer to password string at time of last match
;T4/ ILDB pointer to directory suffix entry

PWDMA3:	DO.			;Loop for checking suffix
	  ILDB T1,T2		;Get next character of password string
	  ILDB T3,T4		;Get the next character of the suffix
	  CAIN T1,(T3)		;Does this match?
	  JRST TOP.		;Yes check the next character	  
	OD.
	CAIE T3,.CHCRT		;Is it a return or
	CAIN T3,","		; is it the end of the suffix
	JUMPE T1,RSKP		;  and end of password?  If so, password found

;Here to eat characters from the directory suffixes until a comma or return
;is seen.  If a comma, check next suffix.  If a return, return +2 (not found).

PWDMA5:	DO.			;No match, we have to eat until next suffix
	  CAIN T3,","		;End of suffix?
	  JRST PWDMA2		;Now try next suffix
	  CAIN T3,.CHCRT	;End of this line?
	  RET			;Yes, not found, read next line from file
	  ILDB T3,T4		;Get next character
	  JRST TOP.		; and check it next
	OD.			;End of suffix eat loop
;[9054] Routine to read a line from password dictionary.
;Call with JFN/ jfn of the file.
;Returns +1 if format error or EOF
;Returns +2 if line found, line returned in PWDBUF TRVAR.

PWDLIN:	MOVEI Q1,<PWDBSZ*5>-1	;Load max characters to store in buffer
	MOVEI Q2,PWDBUF		;Point to password buffer
	HRLI Q2,(POINT 7)	; rather get a byte pointer to it
	DO.			;Loop to pick out characters from file
	  CALL PWDCHR		;(JFN/T1) Read a character from the file
	   RET			;End of file, return +1
	  IDPB T1,Q2		;Store the non null character please
	  CAIE T1,.CHCRT	;Is it a return?
	  SOJGE Q1,TOP.		;Nope, keep going if there is room
	  JUMPL Q1,R		;Return +1 if line too long
	  CALL PWDCHR		;(JFN/T1) Get the next character please
	   RET			;End of file after return before line feed
	  CAIE T1,.CHLFD	;Is it a line feed?
	  RET			;Nope, return now if format error
	OD.			;Now we have a line stored in the buffer
	RETSKP			;Skip return to indicate a line was read
	
;[9054] Routine to read one non null character from password dictionary file.
;Call with JFN/ file's JFN
;Returns +1 if EOF or error
;Returns +2 with T1/ character

PWDCHR:	SOSGE PWDCNT		;Is there a character available?
	IFSKP.			;If so
	  ILDB T1,PWDPTR	;Get a character
	  JUMPN T1,RSKP		;Skip return for non null
	  JRST PWDCHR		;Get next character if null
	ENDIF.			;End of characters available code

;No characters left, we have to play like we are a PMAP JSYS and get more data.

	SOSGE PWDPGC		;Count down one page
	RET			;End of file
	AOS PWDPAG		;Get to next page number please
	CALL PWDMAP		;(JFN/) Map in the next page of the file
	MOVE T1,[POINT 7,FPG0A]	;Point to address we mapped file into
	MOVEM T1,PWDPTR		;Store the pointer to the data
	MOVEI T2,PGSIZ*5	;Load number of 7 bit bytes there
	MOVEM T2,PWDCNT		;Store as bytes available
	JRST PWDCHR		;OK, now get a byte

;[9054] Local routine to map in a page of the password dictionary file.
;Call with JFN/ the JFN of the file
;Returns +1 always

PWDMAP:	SETZ T1,		;Indicate no mapping desired
	MOVEI T2,FPG0A		;Load address (not page number)
	CALL SETMPG		;(T1,T2/) Unmap old page
	MOVE T1,PWDPAG		;Get page number to map
	MOVE T2,JFN		;Get JFN of the file
	IMULI T2,MLJFN		;Compute internal address of it
	HLL T1,FILOFN(T2)	;Get OFN,,pn
	MOVX T2,<PTRW!FPG0A>	;Get access and address of page to map
	CALL SETMPG		;(T1,T2/) Map that page in for us
	SKIP FPG0A		;Page fault it in
	 ERJMP R		;Return now if file damage
	RET			;Return to caller
	ENDTV.			;End of PWDICT's TRVAR
;CRDIR0 - ROUTINE TO DO CRDIR JSYS
;ACCEPTS IN A/	POINTER TO NAME STRING IN JSB
;	   Q3/	(FLAGS,,POINTER TO PARAMETER BLOCK IN USER SPACE) - USER'S AC2
;	CALL CRDIR0
;RETURNS +1:	ERROR OCCURRED, ERROR CODE IN A
;	 +2:	SUCCESSFUL

; LOCAL VARIABLE DEFINITIONS (STORED IN JSB FREE SPACE)
;CRDIRN		;HOLDS POINTER TO COPY OF USER'S STRING IN JSB
;CRDIRS		;POINTER TO GTJFN STRING OF COMPLETE DIRECTORY NAME
;CRDIRD		;DIRECTORY NUMBER
;CRDIRE		;TEMPORARILY HOLDS ERROR CODE
;CRDIRJ		;JFN OF DIRECTORY FILE
;CRDIRT		;HOLDS POINTER TO STRINGS ACROSS SUBROUTINE CALLS
;CRDIRF		;TEMPORARY ERROR FLAG
;CRDIRA		;INDEX BLOCK ADDRESS IN DIRECTORY DELETE ROUTINE
;CRDDNM		;ADR OF BLOCK HOLDING DIR NAME,,CRDSTX
;CRDSTX		;STRUCTURE NUMBER
;CRDIRB		;HOLDS EXPECTED TERMINATING BRACKET ON DIRECTORY STRING
;CRDLEN		;LENGTH OF NAME OF DIRECTORY FOR SETMSB
;CRDCPY		;-1 IF NEED TO CALL CPYBAK, 0 OTHERWISE
;CRDCAP		;CAPENB OF USER
;CRDTMP		;STARTING ADDRESS OF FDB
;CRDDEV		;DEVICE DESIGNATOR FOR CHKNUM
;CRDSTR		;STRUCTURE NUMBER IN CHKNUM
;CRDSUP		;FULLWORD DIR NUMBER OF SUPERIOR
;CRDWHL		;NONZERO IF THE USER IS LOGICALLY A WHEEL WRT THE DIR
		;BEING MANIPULATED BY CRDIR - EITHER OWNER ACCESS OR A
		;REAL WHOPER
;CRDDIQ		;DELTA IN SUPERIORS LIQ AS A RESULT OF THIS CRDIR
;CRDDOQ		;DELTA IN SUPERIORS LOQ AS A RESULT OF THIS CRDIR
;CRDDSQ		;DELTA IN SUPERIORS SDQ AS A RESULT OF THIS CRDIR
;CRDFLG		;FLAG WORD FOR INTERNAL USE
;CRDUFL		;WORD TO HOLD .CDLEN FROM USER ARGUMENT BLOCK

; * * * *
;THE HANDLING OF THE STRUCTURE LOCK IS INCORRECT HERE.  WHENEVER THE
;CORRESPONDENCE BETWEEN A UNIQUE CODE AND A STRUCTURE NUMBER IS IN
;USE, THE STRUCTURE MUST BE LOCKED.  ALL EXIT PATHS MUST CONTAIN A
;CALL TO ULKSTR IF CNVSTR HAS BEEN CALLED.
; * * * *
CRDNWH:	CD%LEN!CD%PSW!CD%FPT!CD%DPT!CD%RET!CD%DGP!CD%DAC

CDNWF==1B0			;BIT IN CRDFLG - NEW FILE BEING CREATED
CDDIR==1B1			;BIT IN CRDFLG - SUPERIOR IS FILES-ONLY
CDREC==1B2			;RECONSTRUCTING A DIRECTORY
CDERR==777777B35		;[8856] Error code that bombed new dir create

;Miscellaneous setup for CRDIR.

CRDIR0:: EA.ENT
	JSBVAR <CRDIRN,<CRDIRS,40>,CRDIRD,CRDIRE,CRDIRJ,CRDIRF,CRDIRA,CRDIRT,<CRDDNM,MAXLW+4>,CRDSTX,CRDIRB,CRDLEN,CRDCPY,CRDCAP,CRDTMP,CRDDEV,CRDSTR,CRDSUP,CRDWHL,CRDDIQ,CRDDOQ,CRDDSQ,CRDFLG,CRDUFL,CRDSFL,NAMPTR,<UGDRNM,2*MAXLW+1>>,[RETBAD (CRDIX3)] ;[7.1192]

	SETZM CRDFLG		;INITIALIZE FLAG WORD
	MOVE Q1,DIRORA		;GET BASE ADDRESS OF DIRECTORY
	HRRZ Q2,Q3		;GET ADDRESS OF USER'S BLOCK
	SETZ B,			;INITIALIZE USER .CDLEN WORD
	TXNE Q3,CD%LEN		;IS THE USER SPECIFIING A LENGTH
	UMOVE B,.CDLEN(Q2)	;YES, GET IT
	MOVE C,CAPENB		;GET ENABLED CAPABILITIES
	TXNN T3,SC%WHL!SC%OPR	;IS THE USER ENABLED?
	ANDX B,CD%RNA+CD%NCE+CD%NED+CD%FED+777777 ;NO, ONLY ALLOW THESE FLAGS
	MOVEM B,CRDUFL		;SAVE THE FLAGS
	HRLI A,(POINT 7,0,34)	;FORM BYTE POINTER TO NAME STRING
	;..
	;..

;MAKE CRDIRN POINT TO FREE SPACE HOLDING STR:<DIRECTORY> STRING
;AS INPUT BY USER

	MOVEM A,CRDIRN		;SAVE NAME STRING ADDRESS
	HRRZ B,A
	MOVE B,1(B)		;CHECK FOR NULL NAME
	TLNN B,774000
	RETBAD (CRDIX5,<CALL CRDIR6>)	;Null name illegal
	SETZM CRDIRD		;INITIALIZE DIR NUMBER
	SETZM CRDIRF		;ASSUME DIR NUMBER NEED NOT BE CHECKED LATER
	MOVE B,A		;COPY POINTER TO NAME
	MOVEM B,NAMPTR		;[7461] Save pointer
	HRROI A, UGDRNM		;[7461] Point to where to store string
	MOVEI C,<2*MAXLC+4>	;[7461][7.1192] Copy this much
	SETZM D			;[7.1192] Stop on null
	SOUT%			;[7461]
	 ERJMP [CALL CRDIR6	;[7461] 
		MOVE A,LSTERR	;[7461]
		RETBAD ()]	;[7461] 
	MOVE B,NAMPTR		;[7461] Restore name for RCDIR%
	MOVX A,RC%EMO		;STRING MUST MATCH EXACTLY
	RCDIR			;PARSE DIRECTORY NAME
	 ERJMP [CALL CRDIR6	;FAILED, CLEAN UP
		MOVE A,LSTERR	;RETURN ERROR FROM RCDIR
		RETBAD ()] ;RETURN ERROR CODE
	TXNN A,RC%NOM		;MATCH?
	IFSKP.			;[7103] No match!
	  TXNE Q3,CD%DEL	;[7103] User want to delete this new directory?
	  RETSKP		;[7103] Yes, nothing more to do then
	ELSE.			;[7103] There was a match
	  MOVEM C,CRDIRD	;[7103] Store directory number
	ENDIF.			;[7103]
	TXNN Q3,CD%NUM		;SPECIFYING A NUMBER?
	JRST CRDI0B		;NO
;USER HAS SPECIFIED A DIRECTORY NUMBER.  SEE IF IT IS THE NUMBER FOR
;THE DIRECTORY SPECIFIED IN THE STR:<DIRECTORY> STRING

	TXNE A,RC%NOM		;A REAL DIRECTORY ?
	JRST [	SETOM CRDIRF	;NO, MARK THAT DIR # SHOULD BE CHECKED LATER
		JRST CRDI0B ]	;GO SET UP GTJFN STRING FOR NEW DIRECTORY
	XCTU [SKIPG B,.CDNUM(Q2)] ;GET NUMBER FROM USER
	RETBAD (CRDIX8,<CALL CRDIR6>) ;ILLEGAL DIR NUMBER
	CAIN B,ROOTDN		;IS THIS THE ROOT DIR?
	JRST [	HLRZ A,C	;GET UNIQUE CODE
		CALL CNVSTR	;GET STRUCTURE NUMBER
		 RETBAD (,<CALL CRDIR6>)
		MOVE P3,STRTAB(A) ;GET ADDRESS OF SDB FOR THIS STRUCTURE
		CALL ULKSTR	;UNLOCK THE STRUCTURE (LOCKED BY CNVSTR)
		JN STCRD,(P3),CRDI0B ;DO NOT CHECK NAME IF CREATING ROOT-DIR
		JRST .+1]	;CONTINUE, NOT CREATING ROOT-DIRECTORY
	UMOVE B,.CDNUM(Q2)	;GET NUMBER FROM USER AGAIN
	HRRZ C,CRDIRD		;GET NUMBER OF DIRECTORY
	CAME B,C		;MATCH ?
	RETBAD (CRDIX8,<CALL CRDIR6>) ;NO, RETURN ERROR CODE
	;..
;HERE IN ALL CASES.  CRDIRF IS -1 IF RCDIR FAILED ON DIRECTORY STRING.
;IF USER SPECIFIED DIRECTORY NUMBER, AND CRDIRF IS 0, NUMBER MATCHED
;THAT OF DIRECTORY IN STRING
;	CRDIRD/ (STRUCTURE,,DIRECTORY) FOR DIRECTORY STRING
;	CRDIRN/ POINTER TO ORIGINAL STRING

;THIS CODE BUILDS A STRING FOR THE DIRECTORY FILE CORRESPONDING TO THE
;DESIRED DIRECTORY.  IT IS SET UP FOR A GTJFN.

	;..
CRDI0B:	MOVE B,CRDIRN		;GET POINTER TO INPUT STRING
	ILDB C,B		;GET FIRST CHARACTER IN STRING
	CAIE C,.CHDI1		;DOES STRING BEGIN WITH A VALID
	CAIN C,.CHDI2		;  DIRECTORY PUNCTUATION ?
	SKIPA A,[POINT 7,[ASCIZ/DSK:/]]	;YES, DEFAULT THE DEVICE THEN
	MOVE A,CRDIRN		;NO, GET POINTER TO SUPPLIED DEVICE
	STDEV			;CONVERT LOGICAL NAMES TO PHYSICAL
	 RETBAD (,<PUSH P,B	;SAVE THE ERROR CODE
		CALL CRDIR6	;RELEASE THE SPACE
		POP P,A>)	;GET BACK THE ERROR CODE
	MOVE A,[POINT 7,CRDIRS]	;GET POINTER TO DESTINATION AREA
	DEVST			;PUT THE PHYSICAL NAME THERE
	 RETBAD (,<PUSH P,A	;SAVE THE ERROR CODE
		CALL CRDIR6	;RELEASE ALL SPACE
		POP P,A>)	;GET BACK THE ERROR CODE
	MOVEI B,":"		;END THE STR NAME WITH A COLON
	BOUT
	MOVE B,CRDIRN		;NOW UPDATE THE BYTE POINTER
CDI0B1:	ILDB C,B		;SCAN FOR :
	JUMPE C,CRDI0D		;AT END OF STRING?
	CAIE C,.CHDI1		;NO, DOES STRING BEGIN WITH A VALID
	CAIN C,.CHDI2		;  DIRECTORY PUNCTUATION?
	JRST CRDI0D		;YES, GO PROCESS DIRECTORY STRING
	CAIE C,":"		;NO, FOUND A COLON?
	JRST CDI0B1		;NO, LOOP BACK
CDI0B2:	IBP B			;MOVE POINTER PAST OPENING DIRECTORY BRACKET
	;..
;DIRECTORY MAY OR MAY NOT EXIST HERE.  IF IT DOESN'T, AND USER GAVE
;DIRECTORY NUMBER, NUMBER IS AVAILABLE.

;	B/ POINTER TO ORIGINAL STRING; POINTS JUST AFTER COLON
;	A/ POINTER TO GTJFN STRING; POINTS JUST AFTER COLON

;DETERMINE TYPE OF CLOSING BRACKET EXPECTED

	;..
CRDI0D:	MOVEM A,CRDIRT		;SAVE DESTINATION POINTER FOR NEXT SOUT
	LDB C,B			;GET OPENING BRACKET
	JUMPN C,CRDI0C		;DIRECTORY NAME FOLLOWS?
	SKIPN B,CRDIRD		;GET DIR NUM
	RETBAD (CRDIX5,<CALL CRDIR6>)	;Null name illegal
	DIRST			;GET STRING WITH DIR NAME IN IT
	 JRST [	PUSH P,A	;SAVE ERROR
		CALL CRDIR6
		POP P,A
		RETBAD()]
	MOVE B,CRDIRT		;NOW WE HAVE STR:<DIR>, GET TO <DIR>
CRDI1A:	ILDB C,B		;GET NEXT CHAR
	CAIE C,":"		;FOUND COLON YET?
	JRST CRDI1A
	ILDB C,B		;GET DIR STARTING CHAR
CRDI0C:	MOVEI D,.CHDT1		;ASSUME TYPE 1 PUNCTUATION (ANGLE BRACKETS)
	CAIE C,.CHDI1		;TYPE 1 PUNCTUATION ?
	MOVEI D,.CHDT2		;NO, GET TYPE 2 CLOSING BRACKET (SQUARE BRACKET)
	MOVEM D,CRDIRB		;SAVE TERMINATING BRACKET
;COPY JUST THE DIRECTORY NAME INTO LOCAL STORAGE (CRDDNM) AND COMPUTE
;ITS LENGTH. MAKE IT END WITH NULL

	HRROI A,CRDDNM		;SET UP POINTER TO WHERE NAME WILL GO
	MOVEI C,MAXLC+1		;GET MAX # OF CHARS ALLOWED IN DIRECTORY NAMES
	MOVEI D,.CHNUL		;ALSO TERMINATE ON END OF STRING, I.E. ON NULLS
	SOUT			;ISOLATE DIRECTORY NAME
	MOVEI B,MAXLC		;GET MAX # OF CHARACTERS POSSIBLY MOVED
	LDB D,A			;SEE IF ENDED ON A NULL
	CAIE D,.CHNUL		;...
	AOS B			;YES, DONT COUNT THE CLOSE BRACKET
	SUB B,C			;COMPUTE # OF CHARACTERS ACTUALLY IN STRING
	IDIVI B,5		;COMPUTE # OF WORDS IN STRING + REMAINDER
	SKIPN C			;DOES B HAVE EXACT # OF WORDS IN THE STRING ?
	SUBI B,1		;YES, SETMSB REQUIRES ONE LESS WORD IN COUNT
	MOVEM B,CRDLEN		;SAVE # OF WORDS IN DIRECTORY NAME STRING
	LDB B,A			;GET ACTUAL TERMINATING CHARACTER
	CAIE B,.CHNUL		;DID STRING TERMINATE WITH A NULL ?
	JRST CRDI0E		;NO, GO CHECK TERMINATING BRACKET
	BKJFN			;YES, BACK UP TO TERMINATING BRACKET
	 JFCL
	LDB B,A			;PICK UP TERMINATING BRACKET
CRDI0E:	CAME B,CRDIRB		;IS IT EXPECTED TERMINATING BRACKET ?
	RETBAD (CRDI11,<CALL CRDIR6>) ;NO, RETURN ERROR TO USER
	MOVEI C,.CHNUL		;GET A NULL TO MAKE AN ASCIZ STRING
	DPB C,A			;OVERWRITE CLOSING BRACKET WITH A NULL
	SKIPN CRDIRF		;NEED TO SEE IF SPECIFIED DIR # EXISTS?
	JRST CRDI0M		;NO, GO ON
	;..
;RCDIR GAVE NO-MATCH AND USER SPECIFIED A DIRECTORY NUMBER.  SEE IF IT
;EXISTS ON THE GIVEN STRUCTURE

	;..
	CALL CHKNUM		;YES, GO CHECK DIRECTORY NUMBER SUPPLIED
	JRST [  CALL CRDIR6	;BAD DIRECTORY NUMBER
		MOVE A,CRDIRE	;RETURN ERROR
		RETBAD ()]

;ADD THE FILENAME AND EXTENSION TO THE GTJFN STRING.  IF THE DIRECTORY
;IS IN <ROOT-DIRECTORY>, COPY DIRNAME.DIRECTORY.  IF THE DIRECTORY IS
;IN ANY OTHER DIRECTORY, COPY <SUPERIOR>DIRNAME.DIRECTORY.

CRDI0M:	MOVEI A,CRDDNM		;CHECK IF THE NEW DIR IS A SUBDIR OF
	HRLI A,(<POINT 7,.-.>)	;OTHER THAN ROOT-DIRECTORY
	MOVEI P3,0		;P3 WILL POINT TO LAST DOT
CRDI0F:	ILDB B,A		;GET A CHAR
	CAIN B,"."		;A SEPARATOR?
	MOVE P3,A		;YES - COPY POINTER
	JUMPN B,CRDI0F		;LOOP
	JUMPE P3,CRDI0G		;ANY FOUND?
	MOVEI A,.CHDI1		;YES - BUILD DIR PREFIX
	IDPB A,CRDIRT		; ...
	MOVEI A,.CHDT1		;CHANGE LAST SEP TO CLOSING DIR BRACKET
	DPB A,P3		; ...
CRDI0G:	MOVE A,CRDIRT		;GET POINTER TO DESTINATION AGAIN
	HRROI B,CRDDNM		;FORM POINTER TO DIRECTORY NAME
	SOUT			;SAVE JUST THE NAME OF THE DIRECTORY
	MOVEI B,"."		;REPLACE SEP IF NEEDED
	SKIPE P3		; ...
	DPB B,P3		; ...
	HRROI B,[ASCIZ/.DIRECTORY;P020200/]
	SOUT			;ADD ON EXTENSION
	;..
;HAVE A FILESPEC OF THE FORM DEV:NAME.DIRECTORY;P000000 OR
;DEV:<SUPERIOR>DIRNAME.DIRECTORY;P020200.  DO GTJFN, ALLOWING
;NON-EXISTENT FILE

	;..
	CALL CRDSWH		;SET WHEEL CAPABILITY
	MOVEI A,CRDGJB		;GET POINTER TO GTJFN BLOCK
	HRROI B,CRDIRS		;GET POINTER TO "NAME.DIRECTORY" STRING
	GTJFN			;CREATE NEW NAME IF NONE OR GET OLD ONE
	 JRST [	MOVEM A,CRDIRE ;SAVE ERROR CODE
		CALL CRDCWH	;CLEAR WHEEL
		CALL CRDIR6	;RELEASE ASSIGNED STORAGE
		MOVE B,CRDIRE	;RESTORE ERROR CODE
		MOVEI A,CRDIX4	;ASSUME SUPERIOR DIRECTORY IS FULL
		CAIN B,GJFX16	;NO SUCH DEVICE ?
		MOVEI A,CRDI12	;YES. SAY STRUCTURE NOT MOUNTED
		CAIN B,STRX09	;"Prior structure mount required" error?
		MOVEI A,CRDI12	;yes, say structure not mounted
		CAIN B,GJFX17	;NO SUCH DIRECTORY?
		MOVEI A,CRDI23	;YES. SAY SUPERIOR DIRECTORY DOESN'T EXIST
		RETBAD () ]	;RETURN ERROR
	MOVEM A,CRDIRJ		;SAVE THE JFN OF THE DIRECTORY FILE
	CALL CRDCWH		;CLEAR WHEEL
;Get superior directory number and save for later.  If user can connect to
;superior directory without a password, he is a logical WHEEL for this
;directory.

	MOVE A,CRDIRJ		;GET THE JFN
	IMULI A,MLJFN		;CONVERT TO JFN BLOCK OFFSET
	HRRZ B,FILDDN(A)	;GET HW DIR NUMBER OF SUPERIOR
	LOAD A,FLUC,(A)	;GET UNIQUE CODE FOR FILE STRUCTURE
	HRL B,A			;BUILD FW DIR NUMBER
	MOVEM B,CRDSUP		;SAVE
	CALL CNVSTR		;CONVERT UNIQUE CODE TO STRUCTURE NUMBER
	 JRST CRDIR4		;FAILED, RETURN ERROR TO USER
	HRRM A,CRDSTX		;SAVE STRUCTURE NUMBER
	CALL ULKSTR		;UNLOCK THE STRUCTURE (LOCKED BY CNVSTR)
	MOVE A,CRDSUP		;CHECK ACCESS TO SUPERIOR DIR
	CALL SETDIR		;FIRST MAP DIR
	 JRST CRDIR4		;FAILED
	SETZM CRDWHL		;ASSUME NOT A LOGICAL WHEEL
	MOVX B,DC%CN		;CHECK IF CAN CONNECT TO SUPERIOR
	CALL DIRCHK		; ???
	 SKIPA			;NO - USER MUST PASS LATER CHECKS
	SETOM CRDWHL		;YES - USER IS A LOGICAL WHEEL
	MOVE B,DIRORA		;POINT TO START OF DIRECTORY
	LOAD B,DRMOD,(B)	;GET MODE BITS
	TXNN B,CD%DIR		;[8856] Is this a FILES-ONLY directory?
	IFSKP.			;[8856] Yes
	  MOVX B,CDDIR		;[8856] Load the local flag 
	  IORM B,CRDFLG		;[8856] Set it in the local flag word
	ENDIF.			;[8856] 
	CALL USTDIR		;UNLOCK DIR

;See if directory file exists, and remember dir number if it does exist.

	HRRZ A,CRDIRJ		;GET JFN OF DIRECTORY FILE
	MOVE B,[1,,.FBCTL]	;NOW SEE IF THE FILE EXISTS
	MOVEI C,D		;GET FLAGS INTO D
	GTFDB
	TXNN D,FB%DIR!FB%NXF	;IS THIS A DIR OR NON-EX FILE?
	ERRJMP (CRDIX9,CRDIR4)	;[8856] Internal format of dir is incorrect
	MOVE B,[1,,.FBDRN]	;GET DIR NUMBER
	MOVEI C,C
	GTFDB
	HRRZM C,CRDIRD		;SAVE DIR NUMBER IF FILE EXISTS
	SETZM CRDCPY		;ASSUME DON'T HAVE TO CALL CPYBAK
	TXNN D,FB%NXF		;FILE EXIST YET?
	JRST CRDIR1		;YES, NOT CREATING A NEW DIR
;HERE WHEN CREATING A NEW DIRECTORY
;	CRDSUP/DIRECTORY OF SUPERIOR
;	CRDSTX/ STRUCTURE NUMBER

	;..
	MOVX A,CDNWF		;INDICATE NEW FILE FOR CLEANING UP
	IORM A,CRDFLG
	SKIPN CRDWHL		;CAN THIS USER CREATE?
	JRST [	MOVEI A,CRDIX1	;NO. RETURN ERROR
		JRST CRDIR4]
	HRRZ C,CRDSUP		;GET SUPERIOR
	CAIN C,ROOTDN		;ROOT-DIRECTORY?
	JRST [	SETOM CRDCPY	;YES - HAVE TO CALL CPYBAK
		JRST CRDI0H]	;AND OMIT LIMIT CHECKS

;CHECK PRIVILEGES

	MOVE A,CAPENB		;GET ENABLED CAPABILITIES
	TXNN A,SC%WHL!SC%OPR	;WHEEL OR OPERATOR?
	TXNN Q3,CD%PRV		;WANT TO SET PRIVILEGES?
	JRST CRDI0N		;WHEEL OR OPER OR NOT SETTING PRIVILEGES
	UMOVE A,.CDPRV(Q2)	;YES. GET DESIRED PRIVILEGES
	ANDCM A,CAPENB		;WE HAVE TO HAVE THEM ENABLED
	JUMPN A, [ MOVEI A,CRDI20
		JRST CRDIR4]

;DIRECTORY IS NOT BEING CREATED IN <ROOT-DIRECTORY>. MAP ITS SUPERIOR
;TO CHECK THE SUBDIRECTORY'S PARAMETERS AGAINST THE SUPERIOR'S

CRDI0N:	MOVE A,CRDSUP		;MAP SUPERIOR FOR LIMIT
	CALL SETDIR		;CHECKS
	 JRST CRDIR4		;FAILED

;CHECK LIST OF CREATABLE USER GROUPS

	TXNE Q3,CD%CUG		;SETTING CREATABLE USER GROUPS?
	JRST [	UMOVE A,.CDCUG(Q2)	;GET USER CREATABLE GROUPS LIST
		LOAD B,DRCUG,(Q1) ;GET CREATABLE GROUPS LIST
		CALL CDCKCU	;VALIDATE LIST
		 ERRJMP(CRDI16,CRDI0I) ;FAILED
		JRST .+1]	;SUCCESS - GO ON

;CHECK LIST OF USER GROUPS

	TXNE Q3,CD%UGP		;SETTING USER GROUPS?
	JRST [	UMOVE A,.CDUGP(Q2) ;YES - GET USERS LIST
		LOAD B,DRCUG,(Q1) ;GET CREATABLE USER GROUPS LIST
		CALL CDCKCU	;VALIDATE LIST
		 ERRJMP(CRDI16,CRDI0I) ;FAILED
		JRST .+1]
	;..
;NEW DIRECTORY, NOT IN ROOT-DIRECTORY...
;CHECK PERMANENT (LOGGED-OUT) QUOTA

	;..
	MOVE A,CRDUFL		;GET FLAGS FROM USER
	TXNE A,CD%NSQ		;CHANGING THE SUPERIOR'S QUOTA
	JRST CRDI0L		;NO, SKIP THESE CHECKS
	MOVX B,.STDMX		;GET DEFAULT PERMANENT QUOTA
	TXNE Q3,CD%LOQ		;USER SETTING LOQ?
	UMOVE B,.CDLOQ(Q2)	;YES - GET THAT VALUE
	LOAD C,DRLOQ,(Q1)	;COMPARE AGAINST SUPERIOR
	CALL CKLOQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 JRST CRDI0P		;INFINITE. DON'T CHECK
	SKIPL B			; ...
	CAMLE B,C		; ...
	ERRJMP(CRDI14,CRDI0I)	;EXCEEDED SUPERIOR LOQ OR .LT. 0

;CHECK QUOTA OF SUBDIRECTORIES

CRDI0P:	MOVX B,.STDSD		;GET DEFAULT SUBDIR QUOTA
	TXNE Q3,CD%SDQ		;SETTING SUBDIR QUOTA?
	UMOVE B,.CDSDQ(Q2)	;YES - GET USERS VALUE
	TLNE B,-1		;RIGHT HALF ONLY?
	ERRJMP (CRDI24,CRDI0I)	;NO. WON'T FIT IN ALLOTTED SPACE
	LOAD C,DRSDM,(Q1)	;COMPARE AGAINST
	OPSTR <SUB C,>,DRSDC,(Q1) ;REMAINING SUBDIR QUOTA
	CAML B,C		;LESS ONE FOR DIR BEING CREATED
	ERRJMP(CRDI15,CRDI0I)	;EXCEEDED SUPERIOR SDQ

;CHECK WORKING (LOGGED-IN) QUOTA

	HRRZ A,CRDSUP		;GET SUPERIOR DIR NUM
	MOVE B,CRDSTX		;GET STRUCTURE NUMBER
	CALL GETCAL
	 JRST [	LOAD A,DRLIQ,(Q1) ;DIRECTORY VALUES
		OPSTR <SUB A,>,DRDCA,(Q1) ; ...
		JRST .+1]
	MOVE C,A		;COPY FREE SPACE
	MOVX B,.STDMX		;GET DEFAULT LIQ
	TXNE Q3,CD%LIQ		;SETTING LIQ?
	UMOVE B,.CDLIQ(Q2)	;YES - GET USERS VALUE
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 JUMPGE B,CRDI0L	;YES. DON'T CHECK LIMITS
	SKIPL B			;DON'T ALLOW NEGATIVE
	CAMLE B,C		;WILL IT FIT?
	ERRJMP(CRDI13,CRDI0I)	;NO - SUPERIOR LIQ EXCEEDED OR .LT. 0
;DON'T ALLOW CREATION OF LOGIN SUBDIRECTORY UNDER A FILES-ONLY SUPERIOR.
;NOTE THAT THIS CODE HAS BEEN SKIPPED IF SUPERIOR IS ROOT-DIRECTORY

CRDI0L:	MOVX B,CDDIR		;SEE IF THE SUPERIOR IS FILES-ONLY
	TDNN B,CRDFLG		;..
	JRST CRDIR9		;NO. DOESN'T MATTER WHAT THIS ONE IS TO BE
	TXNN Q3,CD%MOD		;SUPERIOR IS FILES ONLY. ARE WE SETTING THE MODE?
	ERRJMP(CRDI17,CRDI0I)	;NO. CAN'T TAKE THE DEFAULT
	UMOVE A,.CDMOD(Q2)	;YES. GET THE MODE WORD FROM USER
	TXNN A,CD%DIR		;SETTING FILES ONLY?
	ERRJMP(CRDI17,CRDI0I)	;NO. ILLEGAL IN FILES-ONLY SUPERIOR
CRDIR9:	CALL USTDIR		;UNLOCK THE SUPERIOR
	;..
;NEW DIRECTORY...
;HERE WHEN QUOTAS AND MODE HAVE BEEN CHECKED OR ROOT-DIRECTORY IS THE
;SUPERIOR. GET USER'S CHOICE FOR DIRECTORY NUMBER OR NEXT AVAILABLE ONE
;AND SAVE IN CRDIRD

	;..
CRDI0H:	TXNE Q3,CD%NUM		;SETTING THE DIR NUMBER SPECIFICALLY?
	JRST [	UMOVE A,.CDNUM(Q2) ;YES, GET THE DIR NUMBER
		JRST CRDI0A]	;GO CHECK IF LEGAL
	HRRZ A,CRDSTX		;GET STRUCTURE NUMBER
	CALL GETNDN		;NO, GET NEXT AVAILABLE DIR NUMBER ON THIS STR
	 JRST [	MOVEI A,CRDI10	;MAXIMUM DIR # EXCEEDED
		JRST CRDIR4]	;GO CLEAN UP AND BOMB
	JRST CRDI0A		;CONTINUE BELOW

;HERE WHEN A LIMIT CHECK HAS FAILED

CRDI0I:	MOVEM A,CRDIRE		;SAVE ERROR
	CALL USTDIR		;RELEASE SUPERIOR
	MOVE A,CRDIRE		;RESTORE ERROR
	JRST CRDIR4		;AND UNDO WORK SO FAR

CRDI0A:	SKIPL A			;NEGATIVE IS ILLEGAL
	CAML A,MXDIRN		;IS THIS A LEGAL DIRECTORY NUMBER?
	JRST [	MOVEI A,CRDIX8	;NO, ILLEGAL DIR # SPECIFIED
		JRST CRDIR4]	;GO RELEASE JFN AND BOMB
	MOVEM A,CRDIRD		;SAVE DIR NUMBER
	CAIN A,ROOTDN		;IS THIS THE ROOT DIR BEING CREATED
	JRST [	SETZ A,		;YES, NO DISK ADDRESS
		CALL CRDIDX	;HANDLE THIS SPECIALLY
		 BUG.(HLT,GTFDB6,JSYSF,SOFT,<CRDI0A - Cannot do GETFDB on ROOT-DIRECTORY >,,<

Cause:	There was an error in creating the Root-Directory.  Either the
	FDB could not be mapped or the index table could not be set up.

Action:	Use CHECKD to determine if the disk is OK. If you cannot repair
	the structure with CHECKD, then it may need to be rebuilt.
>)
		JRST CRDIR1]	;ROOT DIR NOW EXISTS, DONT REINITIALIZE

;THIS IS NOT ROOT-DIRECTORY.  DO RECONSTRUCTION IF REQUESTED

	CALL CHKREC		;SEE IF DOING RECONSTRUCTION
	 JRST CRDIAA		;NO
	CALL CRDIDX		;YES, GO SET UP IDXTAB AND FBADR
	 JRST CRDIAA		;FAILED, CREATE NEW DIR
	MOVX A,CDREC		;DONE, MARK THAT RECONSTRUCTION BEING DONE
	IORM A,CRDFLG		;  IN FLAG WORD
	JRST CRDIAB		;SKIP THE DIRECTORY INITIALIZATION
	;..
;NEW DIRECTORY...
;THIS IS NOT ROOT-DIRECTORY, AND WE AREN'T DOING RECONSTRUCTION.
;OPEN AND CLOSE DIRECTORY FILE, SET IDXTAB ENTRY AND INITIALIZE THE DIRECTORY

	;..
CRDIAA:	HRRZ A,CRDIRJ		;GET JFN
	MOVE B,[FLD (^D36,OF%BSZ)+OF%RD+OF%WR+OF%THW]
	OPENF			;OPEN THE FILE TO CREATE THE INDEX BLK
	 JRST CRDIR4		;ERROR ON OPENF, GO RELEASE JFN
	HRLI A,(1B0)		;NOW CLOSE THE FILE KEEPING THE JFN
	CLOSF			;THE FILE EXISTS NOW
	 JFCL
	SETZ A,			;NO ADDRESS OF INDEX BLOCK YET
	CALL CRDIDX		;GO INITIALIZE THE INDEX TABLE
	 JRST CRDIR4		;BOMBED!
	MOVE A,CRDIRD		;GET THE DIRECTORY NUMBER
	HRRZ B,CRDSTX		;GET STRUCTURE NUMBER
	CALL DIRIN1		;[7.1257] (A,B/) Initialize this directory
	 JRST CRDIR4		;COULD NOT INITIALIZE DIR

;DIRECTORY HAS BEEN INITIALIZED OR RECONSTRUCTED. UNLESS SUPERIOR IS
;ROOT-DIRECTORY, GET NEW DIRECTORY'S QUOTAS

CRDIAB:	HRRZ A,CRDSUP		;IS THE SUPERIOR ROOT-DIRECTORY?
	CAIN A,ROOTDN		; ???
	JRST CRDRD		;YES - NEVER DECREMENT QUOTAS
	HLL A,CRDSUP		;GET UNIQUE CODE
	HRR A,CRDIRD		;FORM NUMBER FOR DIRECTORY BEING CREATED
	CALL SETDIR		;MAP DIRECTORY BEING CREATED
	 JRST CRDIR4		;FAILED
	LOAD A,DRLIQ,(Q1)	;GET CURRENT QUOTA VALUES
	MOVEM A,CRDDIQ
	LOAD A,DRLOQ,(Q1)
	MOVEM A,CRDDOQ
	LOAD A,DRSDM,(Q1)
	MOVEM A,CRDDSQ
	CALL USTDIR		;UNLOCK THE DIRECTORY
;MAP THE SUPERIOR AND ADJUST ITS QUOTAS BY THE AMOUNT GIVEN TO
;THE NEW DIRECTORY

CRDRD:	MOVE A,CRDSUP		;DECREMENT QUOTAS BY DEFAULTS
	CALL SETDIR		;MAP SUPERIOR
	 JRST CRDIR4		;FAILED
	INCR DRSDC,(Q1)		;INCREMENT SUBDIRECTORY COUNT
	HRRZ A,CRDSUP		;IS SUPERIOR ROOT-DIRECTORY?
	CAIN A,ROOTDN		;?
	JRST CRDR1C		;YES
	MOVE A,CRDUFL		;GET USER FLAGS
	TXNE A,CD%NSQ		;UPDATING SUPERIOR QUOTA
	JRST CRDIAC		;NO, SKIP OVER THIS CODE
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 JRST CRDIAF		;YES. DON'T ADJUST IT
	LOAD A,DRLIQ,(Q1)	;DECREMENT WORKING
	SUB A,CRDDIQ		;...
	STOR A,DRLIQ,(Q1)	;STORE
	HRRZ A,CRDSUP		;A/ NUMBER OF SUPERIOR
	MOVE B,CRDSTX		;B/ STRUCTURE NUMBER
	MOVN C,CRDDIQ		;C/ AMOUNT TO ADD TO SUPERIOR'S ALLOCATION
	CALL ADJALC		;ADJUST SUPERIOR'S ALLOCATION BY SUBDIR'S QUOTA
CRDIAF:	CALL CKLOQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 JRST CRDIAD		;YES. DON'T ADJUST
	LOAD A,DRLOQ,(Q1)	 ;DECREMENT PERMANENT
	SUB A,CRDDOQ		;...
	STOR A,DRLOQ,(Q1)	;STORE
CRDIAD:	LOAD A,DRSDM,(Q1)	;DECREMENT SUBDIR QUOTA
	SUB A,CRDDSQ		;...
	STOR A,DRSDM,(Q1)	;STORE
CRDIAC:	CALL UPDDIR		;UPDATE DISK COPY
	CALL USTDIR		;RELEASE SUPERIOR

;SET FLAG IN SUPERIOR'S FDB TO INDICATE IT HAS INFERIORS

	HRRZ A,CRDSUP		;GET SUPERIOR DIR NUMBER
	CALL GETIDX		;GET SUPERIOR'S SUPERIOR AND FDB ADDR
	 JRST CRDR1B		;IF NOT SETUP, GO ON
	MOVEM A,CRDTMP		;SAVE FDB OF SUPERIOR
	MOVE A,C		;GET SUP SUP DIR NUMBER
	HLL A,CRDSUP		;GET SUC FOR FWDN
	CALL SETDIR		;MAP SUPERIOR'S SUPERIOR
	 JRST CRDR1B		;NOT FATAL - GO ON
	MOVE A,CRDTMP		;GET FDB
	ADD A,DIRORA		;AS AN ABSOLUTE ADDRESS
	SETONE FB%SDR,.FBCTL(A)	;SET SUBDIR FLAG IN SUPERIORS FDB
	CALL UPDDIR		;UPDATE DISK COPY
	CALL USTDIR		;RELEASE SUP SUP
	JRST CRDR1B		;SETUP USERS VALUES
	;..
	;..

;NOT CREATING A NEW DIRECTORY.  SEE IF PRIVILEGED TO CHANGE THINGS

CRDIR1:	SKIPE CRDWHL		;LOGICAL WHEEL OR OPERATOR?
	JRST CRDR1B		;YES. OK TO DO ANYTHING
	MOVE A,FACTSW		;NO. DOES SYSTEM ALLOW USER TO CHANGE THINGS?
	TXNN A,SF%CRD		;CAN USER CHANGE FIELDS
	ERRJMP (CRDIX1,CRDIR4)	;[8856] No
	HLLZ A,Q3		;GET REQUESTED FUNCTIONS
	ANDCM A,CRDNWH		;COMPARE AGAINST ALLOWED FUNCTIONS
	JUMPN A,[MOVEI A,CRDIX1	;WANT TO DO SOMETHING NOT ALLOWED
		JRST CRDIR4]	;REQUIRE WHEEL OR OPERATOR
	HLL A,CRDSUP		;GET UNIQUE CODE
	HRR A,CRDIRD		;A/(UNIQUE CODE,,DIRECTORY NUMBER)
	CALL SETDIR		;MAP THE DIRECTORY
	 JRST CRDIR4		;FAILED.
	MOVX B,DC%CN		;B/CHECK FOR ABILITY TO CONNECT
	CALL DIRCHK		;CAN USER ACCESS THIS DIRECTORY?
	 ERRJMP (CRDIX1,CRDIR7)	;[8856] No, wheel or operator required
	MOVE B,DIRORA		;GET ADDRESS OF MAPPED DIRECTORY
	LOAD B,DRPSW,(B)	;GET OFFSET OF PASSWORD BLOCK
	SKIPN B			;IF NONE, DIRECTORY HAS NO PASSWORD
	ERRJMP (CRDIX1,CRDIR7)	;[8856] Wheel or operator required
	ADD B,DIRORA		;GET ABSOLUTE ADDRESS OF PASSWORD BLOCK
	MOVE C,1(B)		;GET FIRST WORD AFTER HEADER
	TLNN C,774000		;IF FIRST CHARACTER IS NULL, NO PASSWORD
	ERRJMP (CRDIX1,CRDIR7)	;[8856] Wheel or operator required if no pswd
	UMOVE B,3		;GET POINTER TO PASSWORD AS INPUT BY USER
	CALL CHKPSX		;SEE IF USER GAVE CORRECT PASSWORD
	 JRST [	ULKDIR		;FAILED. UNLOCK THE DIRECTORY LOCKED BY SETDIR
		SKIPN A		;NEED TO SLEEP?
		CALL PASPEN
		OKINT		;NOW CAN GO OKINT FROM CALL TO SETDIR
		MOVEI A,CNDIX1	;ASSUME INCORRECT PASSWORD GIVEN
		XCTU [	SKIPN 3] ;DID USER GIVE A PASSWORD?
		MOVEI A,ACESX3	;NO. RETURN 'PASSWORD REQUIRED'
		JRST CRDIR4]	;TAKE ERROR RETURN
CRDR1C:	CALL USTDIR		;PASSWORD IS OK.  UNLOCK THE DIRECTORY
				;LOCKED BY SETDIR
	;..
;COMMON CODE FOR NEW AND OLD DIRECTORIES.  IF NEW, IT HAS BEEN
;INITIALIZED.  IF OLD, PRIVILEGE HAS BEEN CHECKED.

	;..
CRDR1B:	HRRZ A,CRDIRD		;GET DIR NUMBER
	TXNE Q3,CD%NUM		;IS USER SPECIFYING A DIR NUMBER
	UMOVE A,.CDNUM(Q2)	;YES, GET THE NUMBER
	CAME A,CRDIRD		;IS THIS A MATCH OF WHAT IS IN DIR FILE
	ERRJMP (CRDIX2,CRDIR4)	;[8856] No, dir number must match existing num
	TXNE Q3,CD%DEL		;DELETE WANTED?
	 JRST DELDIR		;Yes
	MOVE A,CRDIRJ		;GET THE JFN OF THE DIR FILE
	RLJFN			;RELEASE THE JFN
	 JFCL
	SETZM CRDIRJ		;MARK THAT THE JFN HAS BEEN RELEASED
	HLL A,CRDSUP		;GET STR UNIQUE CODE
	HRR A,CRDIRD		;ADD DIRECTORY NUMBER
	CALL SETDIR		;MAP IN THIS DIRECTORY
	 JRST [	BUG.(CHK,CRDSDF,JSYSF,HARD,<CRDIR1 - SETDIR failed on new directory>,,<

Cause:	SETDIR failed to map in a directory which has been newly created by
	CRDIR%. The CRDIR% call fails and the directory is not created.
>)
		JRST CRDIR4]

;PUT THE DIRECTORY'S NAME IN A NAME BLOCK POINTED TO BY THE DIRECTORY
;HEADER, AND RELEASE THE FREE SPACE CONTAINING THE NAME STRING

	MOVE A,DIRORA		;GET BASE ADR OF DIR AREA
	LOAD A,DRNAM,(A)	;GET POINTER TO NAME STRING
	JUMPN A,CRDR1A		;IF ALREADY SET, DONT SET IT AGAIN
	HRROI A,CRDDNM		;FORM POINTER TO NAME STRING
	MOVE B,CRDLEN		;GET LENGTH OF STRING
	CALL SETMSB		;SET UP MASK FOR LAST WORD
	CALL CPYDIR		;PUT THIS NAME IN THE DIR
	 ERRJMP (CRDIX4,CRDIR7)	;[8856] Failed to get room, return error
	MOVEI B,.TYNAM		;MARK THIS AS A NAME STRING
	STOR B,NMTYP,(A)	;...
	SUB A,DIRORA		;GET RELATIVE ADDRESS OF BLOCK
	STOR A,DRNAM,(Q1)	;PUT ADR IN DIR
CRDR1A:	CALL CRDIR6		;GO RELEASE JSB SPACE
	;..
	;..

;SET PASSWORD

	CALL CHKCHG		;CHECK IF CHANGE DESIRED
	 JRST CRDR3A		;NO, DO NOT CHANGE EXISTING PARAMETERS
CRDR1S:	TXNN Q3,CD%PSW		;WANT TO SET PASSWORD?
	JRST CRDIR3		;No password change
	MOVE T1,CRDSTX		;Get structure number
	MOVE T1,STRTAB(T1)	;Get address of SDB for this structure
	MOVE T1,SDBSTS(T1)	;[7.1063]Get the structure flags
	MOVEM T1,CRDSFL		;[7.1063]Save them in CRDSFL
	UMOVE T1,.CDPSW(Q2)	;Get pointer to password
	TLC T1,-1		;Check for -1,,ADR
	TLCN T1,-1		; and if so,
	HRLI T1,(<POINT 7,0>)	; make it into a real byte pointer
	XCTBU [	ILDB T1,T1]	;Get first character of password
	JUMPN T1,CRDR2A		;If non-null, OK
	SKIPN CRDWHL		;Must be WHOPER or have connect to superior
	ERRJMP (CRDIX1,CRDIR7)	;[8856] Nope, return error
GPVR1:	SETZM T2		;Null password always uses encryption version 0
	STOR T2,DRPEV,(Q1)	;...
	MOVE T1,DIRORA		;Null password has no block
	JRST CRDRP3		;Go store it

;Password is not null, copy to monitor space

CRDR2A:	UMOVE T1,.CDPSW(Q2)	;Get pointer to password
	CALL CPYFUS		;Copy to free storage
	 ERRJMP (CRDIX3,CRDIR7)	;[8856] JSB full
	HRLI T1,-7		;Make lookup pointer to JSB block
	MOVEM T1,CRDIRN		;Save pointer
	MOVE T3,CRDUFL		;Get user's flags
	TXNE T3,CD%PEN		;Already encrypted?
	JRST CRDRP1		;Yes
	;..
	;..
;Here when password is of proper length, check for encryption

CRDR2B:	SETZM T1		;[7.1290] Assume unencrypted structure
	STOR T1,DRPEV,(Q1)	;Store encryption version number
	MOVE T1,CRDSFL		;Get status flags for the structure
	TXNN T1,MS%CRY		;Want to encrypt it?
	JRST CRDRP2		;No, just store password as is
GPVR2:	MOVE T1,PSENVR		;Yes, use latest encryption
	STOR T1,DRPEV,(Q1)	;Store encryption version number
	CALL LGTAD		;Get system time and date
	STOR T1,DRPDT,(Q1)	;Save time password created
				;(If no date, store -1)
	LOAD T1,DRPEV,(Q1)	;Load the encryption version to use
	MOVE T2,CRDIRN		;Get JSB pointer
	CALL ENCPAS		;Encrypt password
	 ERRJMP (CRDI28,CRDIR7)	;[8856] Bad version number probably
	JRST CRDRP2		;[9041] Go store the password

;Here if encrypted password with version number was supplied

CRDRP1:	HRRZ T2,CRDUFL		;Get length of arguments
	CAIGE T2,.CDPDT		;Are they there? (version and date)
	ERRJMP (CRDI26,CRDIR7)	;[8856] Nope
	UMOVE T1,.CDPEV(Q2)	;Get user-supplied encryption version
	JUMPE T1,CRDP1A		;Bypass structure check if zero (unencrypted)
	MOVE T3,CRDSFL		;Get status flags for the structure
	TXNN T3,MS%CRY		;Is password encryption on for this structure?
	ERRJMP (CRDI27,CRDIR7)	;[8856] Nope

CRDP1A:	CALL CHKPEV		;Test validity of encryption version number
	 ERRJMP (CRDI28,CRDIR7)	;[8856] Bad version number
	STOR T1,DRPEV,(Q1)	; And remember it
	UMOVE T1,.CDPDT(Q2)	;Get user-supplied encryption date
	STOR T1,DRPDT,(Q1)	; And remember it
;Here with properly encrypted password to set in directory.

CRDRP2:	MOVE T1,CRDIRN		;Recover JSB address
	CALL SETMSK		;Store in directory
	CALL CPYDIR		;And copy string to directory
	 ERRJMP (CRDIX4,CRDIR7)	;[8856] Owie
	SKIPN P3,PASEXP		;[9041] Password expiration turned on?
	IFSKP.			;[9041] Yes,
	  PUSH P,T1		;[9041] Save name block address
	  CALL LGTAD		;[9041] (/T1) Get current time
	  HRLZS P3		;[9041] Get password expiration days in left
	  ADD T1,P3		;[9041] Add it to make new password expiration date and time
	  STOR T1,DRPED,(Q1)	;[9041] Stash it in directory
	  CALL UPDDIR		;[9041] (/) Update directory
	  POP P,T1		;[9041] Restore name block address
	ENDIF.			;[9041]
	MOVEI T2,.TYNAM		;MARK AS NAME BLOCK
	STOR T2,NMTYP,(T1)	;...
CRDRP3:	LOAD T2,DRPSW,(Q1)	;GET POINTER TO OLD PASSWORD STRING
	SUB T1,DIRORA		;GET RELATIVE ADR OF PASSWORD STRING
	STOR T1,DRPSW,(Q1)	;STORE NEW PASSWORD STRING POINTER
	JUMPE T2,CRDIR2
	CALL RELDFR		;Release storage if any
CRDIR2:	CALL CRDIR6		;RELEASE JSB STORAGE
;SET DEFAULT ACCOUNT STRING

CRDIR3:	TXNN Q3,CD%DAC		;WANT TO SET DEFAULT ACCOUNT?
	JRST CRDR3F		;NO, PROCEED
	UMOVE A,.CDDAC(Q2)	;GET POINTER TO ACCOUNT
	CALL CPYFUS		;DRAG IT IN
	 ERRJMP (CRDIX3,CRDIR7)	;[8856] JSB free space?
	MOVEM A,CRDIRN		;[9169] Save address of string
	CALL SETMSK		;STORE IN DIRECTORY
	CALL CPYDIR		;AND COPY STRING TO DIRECTORY
	 ERRJMP (CRDIX4,CRDIR7)	;[8856] Can't do it
	MOVEI B,.TYNAM		;MARK IT AS A NAME BLOCK
	STOR B,NMTYP,(A)	;
	LOAD B,DRACT,(Q1)	;GET POINTER TO OLD ACCOUNT
	SUB A,DIRORA		;RELATIVE ADDRESS OF ACCOUNT
	STOR A,DRACT,(Q1)	;STORE NEW ACCOUNT POINTER
	JUMPE B,CRDR3E		;WAS THERE AN OLD DEFAULT DIR ACCOUNT?
	CALL RELDFR		;YES, RELEASE SPACE FOR IT
CRDR3E:	CALL CRDIR6		;RELEASE JSB STORAGE
	;..
	;..
;SET PRIVILEGES

CRDR3F:	TXNN Q3,CD%PRV		;SETTING PRIVILEGES?
	JRST CRDR3G		;NO. SKIP THIS THEN
	UMOVE A,.CDPRV(Q2)	;Get privilege bits
	MOVE B,CAPENB		;LIMIT POSSIBLE PRIVS TO CURRENT USER
	TXNE B,SC%WHL!SC%OPR	;[8856] Privs enabled right now?
	IFSKP.			;[8856] Nope
	  MOVE B,A		;[8856] Copy requested priv word
	  ANDCM B,CAPENB	;[8856] Leave requested bits we don't have
	  IFN. B		;[8856] Are we granting a priv that we own?
	    MOVEI A,CRDI20	;[8856] Wheel, oper, or requested cap required
	    JRST CRDIR7		;[8856] Unlock directory and return error
	  ENDIF.		;[8856] Otherwise
	ENDIF.			;[8856]  it is OK to set the requested caps
	STOR A,DRPRV,(Q1)	;[8856] Set requested capabilities
	;..
;SET MODES

	;..
CRDR3G:	UMOVE A,.CDMOD(Q2)	;GET MODE BITS
	TXNN Q3,CD%MOD		;WANT TO SET MODE?
	JRST CRDI0K		;NO. SKIP
	MOVX B,CDNWF		;IF THIS IS A NEW DIRECTORY
	TDNE B,CRDFLG		; WE HAVE ALREADY CHECKED THE MODES
	JRST CRDI0J		;IT IS, SO SKIP THESE CHECKS
	MOVX B,CDDIR		;IF THE SUPERIOR IS FILES-ONLY
	TDNN B,CRDFLG		; HAVE TO CHECK FOR CREATING LOGIN DIR
	JRST CRDI0J		;NOT FILES-ONLY. OK TO CREATE USER IF DESIRED
	HRRZ B,CRDSUP		;IF SUPERIOR IS ROOT-DIRECTORY
	CAIN B,ROOTDN		; OK TO CREATE LOGIN DIRECTORY
	JRST CRDI0J
	TXNE A,CD%DIR		;TRYING TO MAKE THIS FILES ONLY?
	JRST CRDI0J		;YES. OK
	MOVEI A,CRDI17		;NO. CAN'T MAKE THIS A USER DIRECTORY
	JRST CRDIR7		;[8856] Unlock directory, return error
CRDI0J:	STOR A,DRMOD,(Q1)	;YES
;SET LOGIN DATE

CRDI0K:	UMOVE A,.CDLLD(Q2)	;GET LAST LOGIN DATE
	LOAD B,DRDAT,(Q1)	;GET PREVIOUS DATE
	CAMG A,B		;IS THE NEW DATE BEFORE CURRENT DATE?
	JRST CRDSNI		;[9041] Yes, don't let time go backwards
	TXNE Q3,CD%LLD		;WANT TO SET IT?
	STOR A,DRDAT,(Q1)	;YES

;[9041] Check for non-interactive set and password fail count
CRDSNI:	MOVE T1,CRDUFL		;Get user's flags
	TXNN T1,CD%SNI		;Wanna set non-interactive time?
	JRST CRDSFC		;No, go on to password fail count
	HRRZ T1,CRDUFL		;Get length of arguments
	CAIGE T1,.CDNLD		;Is it there?
	ERRJMP (CRDI26,CRDIR7)	;No
	MOVE T1,CAPENB		;Get privs
	TXNN T1,SC%WHL!SC%OPR	;Is user prived?
	ERRJMP (CRDIX1,CRDIR7)	;No, don't let him change this
	UMOVE T1,.CDNLD(Q2)	;Yes, get it
	STOR T1,DRNIL,(Q1)	;Store it - zero means there isn't one
;[9041]
;Here to set password failures
CRDSFC:	MOVE T1,CRDUFL		;Get user flags
	TXNN T1,CD%SFC		;Setting this?
	JRST CRDPUC		;No, go on
	HRRZ T1,CRDUFL		;Get length of arguments
	CAIGE T1,.CDFPA		;Is it there?
	ERRJMP (CRDI26,CRDIR7)	;No
	MOVE T1,CAPENB		;Get privs
	TXNN T1,SC%WHL!SC%OPR	;Is user prived?
	ERRJMP (CRDIX1,CRDIR7)	;No, don't let him change this
	UMOVE T1,.CDFPA(Q2)	;Yes, get it
	STOR T1,DRFPA,(Q1)	;Store it - zero means no failures
	;..
	;..
;Set password use count
CRDPUC:	MOVE T1,CRDUFL		;Get user's flags
	TXNN T1,CD%PMU		;Setting Password use data?
	JRST CRDPED		;
	HRRZ T1,CRDUFL		;Get length of arguments
	CAIGE T1,.CDPMU		;Is it there?
	ERRJMP (CRDI26,CRDIR7)	;[8856] No
	MOVE T1,CAPENB		;[7.1020] Get privs
	TXNN T1,SC%WHL!SC%OPR	;[7.1020] Is user prived?
	ERRJMP (CRDIX1,CRDIR7)	;[8856] No, don't let him change this
	UMOVE T1,.CDPMU(Q2)	;Yes, get it
	STOR T1,DRPUD,(Q1)	;Store it - zero means no use limit

CRDPED:	MOVE T1,CRDUFL		;Get user's flags
	TXNN T1,CD%PED		;Setting expiration date?
	JRST CDDIRQ		;No
	HRRZ T1,CRDUFL		;Get length of arguments
	CAIGE T1,.CDPED		;Is it there?
	ERRJMP (CRDI26,CRDIR7)	;[8856] No
	MOVE T1,CAPENB		;[7.1020] Get privs
	TXNN T1,SC%WHL!SC%OPR	;[7.1020] Is user prived?
	ERRJMP (CRDIX1,CRDIR7)	;[8856] No, don't let him change this
	UMOVE T2,.CDPED(Q2)	;[9050] Get projected expiration date and time
	SKIPN PASEXP		;[9050] Password expiration turned on?
	IFSKP.			;[9050] If so,
	  IFGE. T2		;[9060] If not expiring...
	    PUSH P,T2		;[9050] Save user argument
	    CALL LGTAD		;[9050] (/T1) Get current date and time
	    POP P,T2		;[9050] And get user argument back
	    HLRZS T1		;[9050] But we only want days
	    HLRZ T3,T2		;[9050] Get days only
	    SUB T3,T1		;[9050] See how many days into the future
	    CAMLE T3,PASEXP	;[9050] Is it too far?
	    ERRJMP (CRDI31,CRDIR7) ;[9050] Yes, don't let him do it
	  ENDIF.		;[9060]
	ENDIF.			;[9050]
	STOR T2,DRPED,(Q1)	;[9050] Store it - zero means no date

	;SKIP EVERYTHING FROM CRDR1S TO HERE IF USER SET CD%NCE
CRDR3A:	CALL UPDDIR		;UPDATE DISK WITH RESULTS SO FAR
;COMPUTE CHANGES IN LOGGED-IN QUOTA, LOGGED-OUT QUOTA, AND SUBDIRECTORY
;QUOTA. IF DIRECTORY IS NEW, IT CURRENTLY IS SET UP FOR THE DEFAULT
;VALUES

CDDIRQ:	LOAD A,DRLIQ,(Q1)	;GET CURRENT LIQ
	UMOVE B,.CDLIQ(Q2)	;GET USERS VALUE
	TXNN Q3,CD%LIQ		;BEING SET?
	MOVE B,A		;NO - NO CHANGE
	SUB A,B			;COMPUTE DELTA
	MOVEM A,CRDDIQ		;SAVE IT
	MOVX A,CDNWF		;IF THIS IS A NEW FILE, DON'T
	TDNE A,CRDFLG		; TO CHECK ITS ALLOCATION
	JRST CRD3AC
	HRRZ A,CRDIRD		;A/ THIS DIRECTORY'S NUMBER
	MOVE B,CRDSTX		;B/ STRUCTURE NUMBER
	CAIN A,ROOTDN		;IS THIS "ROOT-DIRECTORY"?
	JRST CRD3AC		;YES. ALLOW IT THEN.
	CALL GETCAL
	 JRST [	LOAD A,DRLIQ,(Q1) ;DIRECTORY VALUES
		OPSTR <SUB A,>,DRDCA,(Q1) ; ...
		JRST .+1]
	SUB A,CRDDIQ		;ADJUST BY AMOUNT OF CHANGE FROM OLD VALUE
	JUMPGE A,CRD3AC		;[8856] Enough quota today
	MOVEI A,CRDI21		;[8856] Not enough quota for existing files
	JRST CRDIR7		;[8856] Give error, unlock, return
CRD3AC:	LOAD A,DRLOQ,(Q1)	;GET CURRENT LOQ
	UMOVE B,.CDLOQ(Q2)	;GET USERS VALUE
	TXNN Q3,CD%LOQ		;SETTING LOQ?
	MOVE B,A		;NO - NO CHANGE
	SUB A,B			;COMPUTE DELTA
	MOVEM A,CRDDOQ		;SAVE IT
	SETZM CRDDSQ		;ASSUME NO CHANGE IN SUBDIRECTORY QUOTA
	TXNN Q3,CD%SDQ		;SETTING SDQ?
	JRST CRD3AE		;NO. DON'T CHECK IT
	UMOVE B,.CDSDQ(Q2)	;GET USERS VALUE
	TLNE B,-1		;RIGHT HALF ONLY?
	ERRJMP (CRDI24,CRDIR7)	;[8856] No. Won't fit in allotted space
	LOAD C,DRSDC,(Q1)	;GET NUMBER OF SUBDIRECTORIES EXISTING
	CAMLE C,B		;IS NEW VALUE LESS THAN THIS?
	ERRJMP (CRDI22,CRDIR7)	;[8856] Can't reduce quota this much
	LOAD A,DRSDM,(Q1)	;GET CURRENT SUBDIR QUOTA
	SUB A,B			;GET DELTA
	MOVEM A,CRDDSQ		;SAVE IT
CRD3AE:	CALL USTDIR		;RELEASE DIR
	;..
;IF NOT ROOT-DIRECTORY, VERIFY LIST OF GROUPS FOR SUBDIRECTORIES AND
;LIST OF USER GROUPS FOR THIS DIRECTORY

	;..
	HRRZ A,CRDSUP		;CHECK IF SUPERIOR IS
	CAIN A,ROOTDN		;ROOT-DIRECTORY
	JRST CRDR3B		;IT IS - DONT DECREMENT ANYTHING
	MOVE A,CRDSUP		;GET SUPERIOR DIR
	CALL SETDIR		;MAP IT
	 RETBAD (MONX03)	;ANOTHER IMPOSSIBLE ERROR
	TXNE Q3,CD%CUG		;SETTING CREATABLE USER GROUPS?
	JRST [	UMOVE A,.CDCUG(Q2)	;GET USER CREATABLE GROUPS LIST
		LOAD B,DRCUG,(Q1) ;GET CREATABLE GROUPS LIST
		CALL CDCKCU	;VALIDATE LIST
		 ERRJMP (CRDI16,CRDIR7) ;[8856] Failed
		JRST .+1]	;SUCCESS - GO ON
	TXNE Q3,CD%UGP		;SETTING USER GROUPS?
	JRST [	UMOVE A,.CDUGP(Q2) ;YES - GET USERS LIST
		LOAD B,DRCUG,(Q1) ;GET CREATABLE USER GROUPS LIST
		CALL CDCKCU	;VALIDATE LIST
		 ERRJMP (CRDI16,CRDIR7) ;[8856] Failed
		JRST .+1]
	MOVE A,CRDUFL		;SHOULD THE SUPERIOR BE DECREMENTED?
	TXNE A,CD%NSQ		;...
	JRST CRD3AA		;NO
;ADJUST SUPERIOR'S QUOTAS FOR LOGGED-IN QUOTA, LOGGED-OUT QUOTA, AND
;MAXIMUM SUBDIRECTORIES

	MOVX A,CDNWF		;IF THIS IS A NEW FILE, CHECKS HAVE ALREADY
	TDNE A,CRDFLG		; BEEN MADE
	JRST CRD3AD
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 JRST CRD3AB		;YES. DON'T CHECK
	TXNN Q3,CD%LIQ		;LIQ BEING SET?
	JRST CRD3AD		;NO, DON'T DO CHECKS
	HRRZ A,CRDSUP		;A/ SUPERIOR'S DIRECTORY NUMBER
	MOVE B,CRDSTX		;B/ STRUCTURE NUMBER
	CALL GETCAL
	 JRST [	LOAD A,DRLIQ,(Q1) ;DIRECTORY VALUES
		OPSTR <SUB A,>,DRDCA,(Q1) ; ...
		JRST .+1]
	ADD A,CRDDIQ		;ADJUST BY CHANGE IN SUBDIR
	JUMPGE A,CRD3AD		;[8856] Jump if it is OK
	MOVEI A,CRDI13		;[8856] Can't change superior
	JRST CRDIR7		;[8856] Give error, unlock, return
CRD3AD:	LOAD A,DRLIQ,(Q1)	;GET LIQ
	ADD A,CRDDIQ		;ADD DELTA
CRD3AB:	LOAD B,DRLOQ,(Q1)	;GET LOQ
	ADD B,CRDDOQ		;ADD DELTA
	CALL CKLOQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T CHECK
	JUMPL B,[MOVEI A,CRDI14 ;[8856] LOQ exhausted
		JRST CRDIR7]	;[8856] Return error and unlock dir
	LOAD C,DRSDM,(Q1)	;GET SDQ
	ADD C,CRDDSQ		;ADD DELTA
	MOVE D,C		;COPY IT
	OPSTR <SUB D,>,DRSDC,(Q1) ;SUBTRACT NUMBER OF SUBDIRS EXISTING
	JUMPL D,[MOVEI A,CRDI15 ;[8856] SDQ exhausted
		JRST CRDIR7]	;[8856] Unlock and return error
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T ADJUST LOGGED-IN QUOTA
	JRST [	STOR A,DRLIQ,(Q1) ;NO. ADJUST LOGGED-IN QUOTA
		JRST .+1]
	CALL CKLOQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T ADJUST LOGGED-OUT QUOTA
	JRST [	STOR B,DRLOQ,(Q1) ;NO. ADJUST LOGGED-OUT QUOTA
		JRST .+1]
	STOR C,DRSDM,(Q1)	; ...
	HRRZ A,CRDSUP		;A/ SUPERIOR'S DIRECTORY NUMBER
	MOVE B,CRDSTX		;B/ STRUCTURE NUMBER
	MOVE C,CRDDIQ		;C/ CHANGE IN QUOTA
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T ADJUST ALLOCATION ENTRY
	CALL ADJALC		;ADJUST SUPERIOR'S ALLOCATION ENTRY
CRD3AA:	CALL UPDDIR		;UPDATE DISK IMAGE
	CALL USTDIR		;NEW VALUES PASS LIMIT CHECKS
;SET USER GROUPS FOR SUBDIRECTORIES AND THIS DIRECTORY'S USER GROUPS

CRDR3B:	MOVE A,CRDIRD		;MAP OBJECT DIR AGAIN
	HLL A,CRDSUP		; ...
	CALL SETDIR		; ...
	 ERRJMP (MONX03,CRDIR4)	;[8856] Should be impossible
	CALL CHKCHG		;SHOULD PARAMETERS BE CHANGED
	 JRST CRDR3D		;NO
	UMOVE A,.CDCUG(Q2)	;GET CREATABLE USER GROUPS
	TXNN Q3,CD%CUG		;[7475] SETTING THEM?
	IFSKP.
          CALL CRDCUP		;YES - COPY TO DIR
	   JRST CRDIR7		;[8856] Failed, return 
	ENDIF.
	UMOVE A,.CDUGP(Q2)	;GET USER GROUPS
	TXNE Q3,CD%UGP		;WANT TO SET USER GROUPS?
	CALL CRDUGP		;YES, GO SET UP USER GROUPS

;Set remote node aliases

	MOVE T1,CRDUFL		;is remote node alias list
	TXNE T1,CD%RNA		; to be changed ?
	CALL CHKCHG		;yes. but SHOULD it be changed ?
	IFSKP.
	  CALL CRDRNA		;yes. do it
	   JRST CRDIR7		;[8856] Failed, unlock and return
	ENDIF.
	;..
;DO ALLOCATION, DEFAULT PROTECTION, DIRECTORY PROTECTION

	UMOVE A,.CDLOQ(Q2)	;GET LOGGED OUT QUOTA
	TXNE Q3,CD%LOQ		;SET IT?
	STOR A,DRLOQ,(Q1)	;YES
	UMOVE A,.CDLIQ(Q2)	;GET LOGGED IN QUOTA
	TXNE Q3,CD%LIQ		;SET LOGGED IN QUOTA?
	STOR A,DRLIQ,(Q1)	;YES
	HRRZ A,CRDIRD		;A/ DIRECTORY NUMBER
	MOVE B,CRDSTX		;B/ STRUCTURE NUMBER
	MOVN C,CRDDIQ		;C/ AMOUNT TO ADD TO QUOTA
	CAIE A,ROOTDN		;IS THIS "ROOT-DIRECTORY"?
	CALL ADJALC		;NO, ADJUST ALLOCATION ENTRY FOR THIS DIRECTORY
	UMOVE A,.CDSDQ(Q2)	;GET SUBDIR QUOTA
	TXNE Q3,CD%SDQ		;SETTING IT?
	STOR A,DRSDM,(Q1)	;YES.
	UMOVE A,.CDFPT(Q2)	;Default file protection
	ANDI A,777777
	TLO A,500000
	TXNE Q3,CD%FPT		;SET FILE PROTECTION?
	STOR A,DRDPW,(Q1)	;YES
	UMOVE A,.CDDPT(Q2)	;GET DIRECTORY PROTECTION
	ANDI A,777777
	TLO A,500000
	TXNE Q3,CD%DPT		;SET IT?
	STOR A,DRPRT,(Q1)	;YES
; Online & offline expiration defaults

	MOVE B,CRDUFL		; Get flags
	UMOVE A,.CDDNE(Q2)	; Get user's online exp choice
	TXNE B,CD%NED		; Want to change that?
	STOR A,DRDNE,(Q1)	; Yes, set it
	TXNN B,CD%FED		; Want to do offline?
	JRST CRD3BB		; No, skip over that
	UMOVE A,.CDDFE(Q2)	; Get what user wants
	MOVE B,CAPENB
	SKIPE TPRCYC		;If user is wheel or no system limit set,
	TXNE B,SC%WHL		;don't check range.
      IFSKP.
	  TLNN A,-1		; Is it an interval?
	IFSKP.
	  CALL LGTAD		;NO, A DATE. GET NOW
	  HLRZ D,A		;COMPUTE MAX ALLOWED END DAY
	  ADD D,TPRCYC
	  UMOVE A,.CDDFE(Q2)
	  HLRZ B,A		;GET USER SPECIFIED END DAY
	  CAMLE B,D		;LEGAL?
	  ERRJMP (ARGX27,CRDIR7) ;[8856] Out of reasonable range
	ELSE.
	  CAMLE A,TPRCYC	; Within range?
	  ERRJMP (ARGX27,CRDIR7) ;[8856] No
	ENDIF.
      ENDIF.
	STOR A,DRDFE,(Q1)	;Store user value
;SET PPN

CRD3BB:	UMOVE A,.CDPPN(Q2)	;GET PROJECT-PROGRAMMER NUMBER
	TXNN Q3,CD%PPN		;WANT TO SET IT?
	JRST CRD3BD		;NO
	SETZ B,			;YES - GET A ZERO FOR CLEARING
	JUMPE A,CRD3BC		;APPROVE PPN IF IT'S ZERO
	HLRZS A			;ELSE ISOLATE PROJECT NUMBER
	TRNN A,400000		;SIGN BIT ON IS AN ILLEGAL TOPS-10 PROJECT NUMBER
	CAIN A,PPNLH		;PREVENT CONFUSION BY NOT ALLOWING OLD STYLE
	ERRJMP (PPNX1,CRDIR7)	;[8856] Illegal project number
	UMOVE A,.CDPPN(Q2)	;GET PPN BACK AGAIN
	TRNN A,-1		;PROGRAMMER NUMBER OF ZERO IS ILLEGAL
	ERRJMP (PPNX1,CRDIR7)	;[8856] So flunk that out
;HERE TO CHECK PPN FOR UNIQUENESS
	LOAD C,DRPPN,(Q1)	;GET CURRENT PPN FOR THIS DIRECTORY
	CAMN A,C		;SAME AS SPECIFIED PPN?
	JRST CRD3BD		;YES, SO SKIP FURTHER PPN PROCESSING
	CALL FNDPPN		;MUST NOT MATCH AN EXISTING PPN
	 CAIA			;NO FOUND SO OK
	ERRJMP (PPNX1,CRDIR7)	;[8856] So flunk that out
CRD3BC:	UMOVE B,.CDPPN(Q2)	;GET BACK PPN NUMBER
	STOR B,DRPPN,(Q1)	;STORE IT IN THE DIRECTORY
	HRRZ A,CRDIRD		;GET DIRECTORY NUMBER
	CALL SETPPN		;ALSO, STORE IT IN IDXTAB EXTENSION
CRD3BD:
;DO RETENTION SPEC, DIRECTORY GROUPS

	UMOVE A,.CDRET(Q2)	;GET # OF GENERATIONS TO KEEP
	ANDI A,777777
	TLO A,500000
	TXNE Q3,CD%RET		;SET IT?
	STOR A,DRDBK,(Q1)	;YES
	UMOVE A,.CDDGP(Q2)	;GET DIRECTORY GROUPS
	TXNE Q3,CD%DGP		;SET DIR GROUPS?
	CALL CRDDGP		;YES, GO SET UP DIR GROUP LIST
CRDR3D:	CALL UPDDIR		;FIX DIR ON DISK
	CALL USTDIR		;[8856] (/) Unlock directory, go OKINT

;If creation of a top level directory, we need to call CPYBAK.

	SKIPN CRDCPY		;WANT TO CALL CPYBAK?
	JRST CRDR3C		;NO
	HRRZ A,CRDSTX		;GET STRUCTURE NUMBER
	CALL CPYBAK		;MAKE A COPY OF THE ROOT-DIRECTORY
	 JRST [	MOVEI B,ROOTDN	;FAILED, SEE IF WE ARE CREATING ROOT-DIR
		CAME B,CRDIRD ;BACKUP FILE NOT CREATED YET IF ROOT
		BUG.(CHK,CRDBAK,JSYSF,HARD,<CRDIR3 - Could not make backup copy of ROOT-DIRECTORY>,,<

Cause:	CPYBAK failed to create a backup copy of the root directory during
	a CRDIR% call. CPYBAK is called to re-create the backup copy of the
	root directory if the root directory is the superior of the
	directory being manipulated with CRDIR%.

Action:	The backup copy of the root directory is now corrupted. It must be
	fixed by hand.
>,,<DB%NND>)			;[7.1210] 
		JRST .+1]
	;..
;MAKE THE MESSAGE FILE IF DIRECTORY IS NOT FILES-ONLY

	;..
CRDR3C:	MOVX T1,CDNWF		;IF THIS IS A NEW DIRECTORY
	TDNN T1,CRDFLG		; THEN CONTINUE
	 JRST CRDIR5		;NOT CREATING DIRECTORY - LEAVE ALONE
	HLL B,CRDSUP		;GET STR UNIQUE CODE
	HRR B,CRDIRD		;GET THE DIRECTORY NUMBER
	HRROI A,CRDIRS		;RESTORE POINTER
	DIRST
	 JRST [	CALL CRBUG1	;REPORT TROUBLE
		JRST CRDIR5]	;CLEAN UP AND ABORT
	MOVEM A,CRDIRT		;SAVE CURRENT POINTER
	SETZ A,
	HRROI B,CRDIRS		;FORM POINTER TO START OF DIRECTORY SPEC
	RCDIR			;GET DIRECTORY FLAGS
	TXNE A,RC%DIR		;FILES ONLY DIRECTORY?
	 JRST CRDIR5		;YES, DON'T MAKE MESSAGE FILE
	MOVE A,CRDIRT		;GET POINTER TO LAST CHAR
	HRROI B,[ASCIZ /MAIL.TXT;P770404/]
	SETZ C,
	SOUT
	CALL CRDSWH		;SET WHEEL
	HRROI B,CRDIRS		;GET START OF NAME STRING
	MOVE A,[GJ%FOU!GJ%PHY!GJ%SHT+1] ;VERSION 1
	GTJFN
	 JRST [	CALL CRBUG1	;REPORT TROUBLE
		JRST CRDR8A]	;CLEAN UP AND ABORT
	MOVE D,A		;SAVE JFN
	MOVE B,[070000,,OF%RD+OF%WR+OF%PDT]
	OPENF			;MAKE THE FILE EXIST
	 MOVE A,D		;IGNOR ERROR
	MOVE B,[1,,.FBCTL]	;GET THE CONTROL BITS
	MOVEI C,C
	GTFDB
	TXNN C,FB%NXF		;SEE IF THE FILE EXISTED BEFORE
	JRST CRDIR8		;YES, DONT CHANGE ITS STATE
	HRLI A,.FBCTL
	MOVX B,FB%PRM+FB%DEL
	MOVX C,FB%PRM+FB%DEL	;MAKE IT PERMANENT AND DELETED
	CHFDB
CRDIR8:	HRRZS A
	CLOSF			;RELEASE THE JFN
	 JFCL
CRDR8A:	CALL CRDCWH		;CLEAR WHEEL
	;..
;HERE ON SUCCESSFUL COMPLETION.  RETURN DIRECTORY NUMBER TO USER

	;..
CRDIR5:
	HLL A,CRDSUP		;GET STR UNIQUE CODE
	HRR A,CRDIRD		;FORM 36-BIT DIRECTORY DESIGNATOR
	UMOVEM A,1		;RETURN IT IN USER AC 1
	RETSKP			;GIVE SUCCESSFUL RETURN
;Error Routines
;	Enter at CRDIR4 (directory not mapped)
;[8856] Enter at CRDIR7 (directory mapped by SETDIR)
;	with A/ error code to return to user

CRDIR7:	CALL USTDIR		;[8856] (/) Unlock directory, go OKINT
CRDIR4:	MOVEM A,CRDIRE		;SAVE ERROR CODE
	CALL CRDIR6		;RELEASE JSB SPACE
	HRRZ A,CRDIRJ		;GET JFN OF DIR FILE
	JUMPE A,CRDR02		;[8856] No JFN there, check if new dir failure
	MOVX B,CDNWF		;IS THIS A NEW FILE?
	TDNN B,CRDFLG		;??
	JRST CRDR01		;NO. DON'T EXPUNGE IT OR CLEAR IDXTAB
	HRLI A,(DF%EXP)		;EXPUNGE THE FILE
	DELF
	JFCL			;IGNORE ERRORS
	SKIPG A,CRDIRD		;GET DIR NUMBER
	CALL DELIDX		;GET RID OF INDEX TABLE ENTRY
CRDR01:	HRRZ A,CRDIRJ		;GET BACK THE JFN
	RLJFN			;RELEASE THE JFN
	JFCL
CRDR00:	MOVE A,CRDIRE		;GET BACK ERROR CODE
	RETBAD ()		;AND EXIT

CRDR02:	MOVX B,CDNWF		;[8856] Load new directory bit
	TDNN B,CRDFLG		;[8856] Is this a new directory build failure?
	JRST CRDR00		;[8856] Nope, just return now
	MOVEI A,CRDGJB		;[8856] Have to delete directory
	HRROI B,CRDIRS		;[8856] Get pointer to "NAME.DIRECTORY" string
	GTJFN			;[8856] Get JFN on the new directory
	 ERJMP CRDR00		;[8856] If an error here I give up
	HRRZM A,CRDIRJ		;[8856] Save JFN for DELDIR code
	MOVE A,CRDIRE		;[8856] Load error code that we bombed on
	HRRM A,CRDFLG		;[8856] Save it in place not known to DELDIR
	CALL DELDIR		;[8856] Delete this directory
	 JFCL			;[8856] Error?  Well I tried anyway
	HRRZ A,CRDFLG		;[8856] Reload the error
	RETBAD ()		;[8856] Pass error back up

;Small routine to releaser any JSB free space we are currently using.
;Returns +1 always.

CRDIR6:	MOVEI A,JSBFRE		;RELEASE NAME STRING SPACE
	HRRZ B,CRDIRN		;B/ ADDRESS OF JSB FREE SPACE
	JUMPE B,R		;DON'T RELEASE IF THERE ISN'T ANY
	CALL RELFRE		;RELEASE THE BLOCK FOR LOCAL VARIABLES
	SETZM CRDIRN		;INDICATE THERE IS NO SPACE ASSIGNED NOW
	RET
;ROUTINE TO CHECK IF EXISTING PARAMETERS SHOULD BE CHANGED
;	CALL CHKCHG
;RETURNS +1:	PARAMETERS SHOULD NOT BE CHANGED
;	 +2:	CHANGES ARE DESIRED

CHKCHG:	MOVE B,CRDUFL		;GET THE USER FLAGS
	MOVE A,CRDFLG		;GET LOCAL FLAGS
	TXNN B,CD%NCE		;NO CHANGES IF EXIST BIT ON?
	RETSKP			;NO, DO THE CHANGES ALWAYS
	TXNE A,CDNWF		;YES, IS THIS A NEW DIRECTORY?
	TXNE A,CDREC		;YES, IS THIS A RECONSTRUCTION?
	RET			;DO NOT DO THE CHANGES
	RETSKP			;NEW AND NO RECONSTRUCT, DO THE CHANGES


;ROUTINE TO CHECK IF RECONSTRUCTION IS NEEDED
;	CALL CHKREC
;RETURNS +1:	NO RECONSTRUCTION
;	 +2:	RECONSTRUCTION TO BE DONE
;		A/	DISK ADR OF INDEX BLOCK OF DIRECTORY FILE

CHKREC:	SAVEQ			;SAVE PERMANENT ACS
	MOVE A,CRDIRD		;GET DIR NUMBER
	CALL GETIDX		;SEE IF THE NUMBER WAS IN USE
	 RET			;NO
	TXNE D,IDX%IV		;IS THIS ENTRY INVALID?
	JRST CHKRC2		;YES, GO DELETE IT
	MOVE Q3,B		;SAVE THE ADR OF THE INDEX BLOCK
	MOVE A,CRDIRD		;GET THE DIR NUMBER AGAIN
	HRRZ B,CRDSTX		;GET STRUCTURE NUMBER
	MOVE B,STRTAB(B)	;GET UNIQUE CODE
	LOAD B,STRUC,(B)	;...
	HRL A,B			;BUILD A 36-BIT DIR NUMBER
	CALL SETDIR		;MAP IN THAT DIRECTORY
	 JRST CHKRC2		;DIR IS BAD, GO DELETE IT
	CALL CHKNAM		;SEE IF THE NAME STRINGS MATCH
	 JRST CHKRC1		;NO, NO RECONSTRUCTION
	CALL USTDIR		;THE NAMES MATCH, DO RECONSTRUCTION
	MOVE A,Q3		;RETURN ADR OF INDEX BLOCK
	RETSKP			;GO AND DO RECONSTRUCTION

CHKRC1:	CALL USTDIR		;GO UNLOCK THE DIR
CHKRC2:	MOVE A,CRDIRD		;GET DIR NUMBER
	CALL DELIDX		;DELETE THE ENTRY FROM THE IDXTAB
	RET			;AND GO CREATE THE DIR WITHOUT RECONSTRUCTION
;ROUTINE TO COMPARE THE NAME STRING IN A DIRECTORY WITH THE NAME
;	STRING GIVEN BY THE USER
;ASSUMES THE CORRECT DIRECTORY IS MAPPED, AND THAT THE NAME STRING
;	IS SET UP IN CRDDNM

;RETURNS +1:	NAMES DO NOT MATCH
;	 +2:	NAMES MATCH

CHKNAM:	SAVEQ
	MOVE Q1,DIRORA		;GET START OF DIR AREA
	LOAD Q1,DRNAM,(Q1)	;GET POINTER TO THE DIRECTORY NAME
	ADD Q1,DIRORA		;GET ABS ADR OF DIR NAME
	MOVSI Q2,(POINT 7,(Q1),35)
	MOVE C,[POINT 7,CRDDNM]	;GET POINTER TO THIS DIR NAME
CHKNA0:	ILDB A,Q2		;GET NEXT CHAR FROM DIRECTORY
	ILDB B,C		;GET NEXT CHAR FROM CRDIR DATA BASE
	CAME A,B		;MATCH?
	RET			;NO
	JUMPN A,CHKNA0		;YES, CHECK THROUGH THE NULL
	RETSKP			;NAMES MATCH

;ROUTINES TO SET UP A LIST OF GROUPS IN THE DIRECTORY
;ACCEPTS IN A/	36 BIT GROUP DESIGNATOR
;	CALL CRDUGP	OR	CALL CRDDGP
;RETURNS +1:	ALWAYS

CRDUGP:	PUSH P,A		;SAVE NEW VALUE
	LOAD B,DRUGP,(Q1)	;GET OLD SETTING
	SKIPE B
	CALL RELDFR		;RELEASE DIR SPACE OF OLD GROUP LIST
	POP P,A			;GET BACK NEW SETTING
	CALL CRGDGB		;GET DIR GROUP BLOCK SET UP
	 MOVEI A,0		;FAILED, DONT SET ANY GROUPS
	STOR A,DRUGP,(Q1)	;STORE USER GROUPS
	RET			;AND RETURN

CRDDGP:	PUSH P,A		;SAVE NEW SETTING
	LOAD B,DRDGP,(Q1)	;GET POINTER TO OLD LIST
	SKIPE B			;IF THERE IS ONE
	CALL RELDFR		;THEN RELEASE THE SPACE
	POP P,A			;GET BACK NEW VALUE
	CALL CRGDGB		;GET A NEW DIR GROUP BLOCK
	 MOVEI A,0		;FAILED, DONT SET ANY
	STOR A,DRDGP,(Q1)	;STOR POINTER INTO DIR
	RET			;AND RETURN
;ROUTINE TO SETUP THE CREATABLE USER GROUPS LIST
;A/ USER ADDRESS OF NEW GROUP LIST
;	CALL CRDCUP
;RETURNS:  +1 	NEW GROUP LIST SETUP
;	   +2   FAILS, GIVING ERROR MESSAGE

CRDCUP:	STKVAR <NEWLST>
        MOVEM T1,NEWLST		;[7461] Save pointer to new list
	LOAD T2,DRCUG,(Q1)	;[7461] Get pointer to old list
	SKIPN T2		;[7461] Was there any?
        JRST SETGPS		;[7461] No, just go set groups
	LOAD T3,DRSDC,(Q1)	;[7461] Yes, see if any subdirs to check
	SKIPN T3		;[7461] Any?
	JRST SETGPS		;[7461] No, just go set groups
	MOVE T1,CRDIRD		;[7461] Get directory number
	MOVE T2,NEWLST		;[7461] Get back pointer to new list
	CALL CHKSUB		;[7461] (T1,T2/)Check subdirs
	 RETBAD ( )             ;[7461]  Failure return
	LOAD T2,DRCUG,(Q1)	;[7461] Passed checks - point to old list
	CALL RELDFR		;[7461] (T2/)And release old space in dir
SETGPS:	MOVE T1, NEWLST		;[7461]  Get pointer to new list
	CALL CRGDGB		;[7461] (T1/)And set the new list
	   MOVEI A,0		;[7461] Failed, set up nil
	STOR A,DRCUG,(Q1)	;[7461] ...
	RETSKP			;[7461]  Success return 
	ENDSV.
;Subroutine to check user's proposed list of USER-GROUPS-TO-ALLOW for 
;subdirectories against the currently existing USER GROUP lists in the directory's 
;inferiors. If the existing list is a subset of the proposed list, then it is 
;all right to set the new list in the directory. If the existing list is NOT a 
;subset of the proposed list, then the user is attempting to remove a group 
;from the current list, and the inferior directories must be checked to make 
;sure that the group in question does not already exist in a subdirectory. The 
;first such ocurrence will cause failure return.
;
;			CALL CHKSUB
;		T1/ 36-bit directory number
;		T2/ Pointer to proposed new list in user space
;
;	Return +1: Failure, error code in T1
;
;	Return +2: Success, superior directory (the one we are creating) mapped
;
;

CHKSUB:	STKVAR <DIRNUM,NLIST>
	MOVEM T1,DIRNUM		;[7461] Save directory number
	MOVEM T2,NLIST		;[7461] Save pointer to user's list
	CALL WLDCRD		;[7461] () Asteriskize (whew!) the dir name
 	CALL USTDIR		;[7461] (T1/) Unmap this dir
	MOVE T2,[POINT 7,UGDRNM] ;[7461] Get pointer to complete dir name
CHKLUP:	MOVX T1,<RC%STP!RC%AWL> ;[7461] Step the dirs, allow wildcards
	HRR T3,DIRNUM		;[7461] Get the number of this dir
	HLL T3, CRDSUP		;[7461] Make it a 36-bit dir number
	RCDIR%			;[7461] 				
         ERJMP R
        TXNE T1,RC%NMD		;[7461] No more directories?
	IFNSK.
	  CALL MAPSUP		;[7461] () Guess not - Remap superior
	  RETSKP		;[7461]  Success return
	ENDIF.
	MOVEM T3,DIRNUM		;[7461] Save the dir number returned
	MOVE T1,T3		;[7461] Get dir number in AC1 for SETDIR
	CALL SETDIR		;[7461] (T1/) Map the next directory
          RETBAD ()		;[7461] Pass the error along
	MOVE T3,DIRORA		;[7461] Point to top of directory
	LOAD T1,DRUGP,(T3)	;[7461] Get current list
	MOVE T2,NLIST		;[7461] Get list we are requesting
	CALL CUCKCD		;[7461] (T1,T2/) Validate list
	IFSKP.
          CALL USTDIR		;[7461] (T1/) Unmap 
	  MOVE T2, [POINT 7,UGDRNM] ;[7461] Get pointer back
	  JRST CHKLUP		;[7461] Ok so far, move along the chain
	ENDIF.
	CALL USTDIR     	;[7461](T1/) Unmap
	RETBAD(CRDI29)		;[7461] Error return
	ENDSV.
;Add an asterisk to the directory name so RCDIR will step through the
;subdirectories for us
;
;		CALL WLDCRD
;		USES T3,T4
;

WLDCRD:	MOVE T3,[POINT 7,UGDRNM] ;[7461] Point to name
CRDLUP:	ILDB T4,T3		;[7461] Get a character
	CAIE T4, ">"		;[7461] Closing bracket?
	JRST CRDLUP		;[7461] No, keep looking
	SETO T4,		;[7461] Found it
	ADJBP T4,T3		;[7461] Back up
	MOVEI T3,"."		;[7461] Add a dot - we're looking for subdirectories
	IDPB T3,T4		;[7461] 
	MOVEI T3,"*"		;[7461] Now an asterisk
	IDPB T3,T4		;[7461]              
	MOVEI T3,">"		;[7461] And add 
	IDPB T3,T4		;[7461] A closing bracket
	MOVEI T3,0		;[7461] 
	IDPB T3,T4		;[7461] Finish off with a null
	RET

;Here to re-map the  superior again and leave things the way we found 'em
;

MAPSUP: HLL A,CRDSUP		;[7461]  Get unique code
	HRR A,CRDIRD		;[7461]  Form 36-bit number
	CALL SETDIR		;[7461]  (T1/) Map directory 
	 JRST CRDIR4		;[7461]  Failed
	RET
;Routine to check a list in a directory against a list in user address space 
;
;A/ RELATIVE DIRECTORY ADDRESS OF GROUP BLOCK
;B/ USER ADDRESS OF LIST
;	CALL CUCKCD
;RETURNS+1:
;	DIR LIST IS NOT A SUBSET OF USER LIST
;RETURNS+2:
;	DIR LIST IS A SUBSET OF USER LIST

CUCKCD:	JUMPE T1,RSKP		;[7461]  No list in dir header - OK, success
	JUMPE T2,R		;[7461]  No user list - bad news
	TRVAR <CDCKUP,CDCKUC,CDCKDP,CDCKDC> ;user ptr, user count, dir ptr
				;[7461]   dir count
	MOVEM T1,CDCKDP		;[7461] Save dir pointer
	MOVEM T2,CDCKUP		;[7461] Save user pointer
	ADD T1,DIRORA		;[7461]  
	LOAD T4,BLKLEN,(A)	;[7461] Get block length
	MOVEM T4,CDCKDC		;[7461] Save dir count
	UMOVE T2,(T2)		;[7461] Get count from user's list
	MOVEM T2,CDCKUC		;[7461] Save count
	JUMPLE T2,R		;[7461] Check for garbage count
	SOJE T2,R		;[7461] If null user list, error
	SUB T1,DIRORA		;[7461] Get absolute address
	HRLI T1,(POINT 18,.-.(Q1),35) ;[7461] and point to groups
CUCKD1:	SOSG CDCKDC		;[7461] Decrement dir count
	RETSKP			;[7461] End of list - success
	ILDB T2,T1       	;[7461] Get first group
	CALL CUCKD2		;[7461] (/T2)
	 RET			;[7461] Failure
	ILDB T2,T1       	;[7461] Next
	JUMPE T2,RSKP		;[7461] Done - success
	CALL CUCKD2		;(/T2)
	RET
	JRST CUCKD1		;[7461] keep going

;Here with element from user's list in AC2

CUCKD2: MOVE T3,CDCKUP		;[7461] Get pointer to user list
	MOVE T4,CDCKUC		;[7461] Get list size
CUCKD3: SOJLE T4,R		;[7461] Group not found in user list - fail
	AOS T3			;[7461] Next element from dir
	XCTU [CAMN T2,(T3)]	;[7461] Match?
	RETSKP			;[7461] Yes, success
	JRST CUCKD3		;[7461] Keep looking
	ENDTV.

;ROUTINE TO CHECK A LIST IN USER ADDRESS SPACE AGAINS A LIST IN
;A DIRECTORY

;A/ USER ADDRESS OF LIST
;B/ RELATIVE DIRECTORY ADDRESS OF GROUP BLOCK
;	CALL CDCKCU
;RETURNS+1:
;	USER LIST IS NOT A SUBSET OF DIR LIST
;RETURNS+2:
;	USER LIST IS A SUBSET OF DIR LIST

CDCKCU:	STKVAR <CDCKPT,CDCKCT,CDCKDP> ;KIUSER PTR, USER COUNT, DIR PTR
	MOVEM A,CDCKPT		;SAVE USER POINTER
	MOVEM B,CDCKDP		;SAVE DIR POINTER
	UMOVE A,(A)		;GET COUNT FROM USERS LIST
	MOVEM A,CDCKCT		;SAVE COUNT
	JUMPLE A,R		;CHECK FOR GARBAGE COUNT
	SOJE A,RSKP		;IF NULL LIST, ALL DONE
	JUMPE B,R		;IF NON-NULL USER LIST AND NO DIR LIST, NO MATCH
CDCKU1:	SOSG CDCKCT		;DECREMENT USER COUNT
	RETSKP			;END OF LIST - SUCCESS
	AOS A,CDCKPT		;STEP USER POINTER
	MOVE C,CDCKDP		;GET DIR POINTER
	ADD C,DIRORA		;AS ABSOLUTE ADDRESS
	LOAD D,BLKLEN,(C)	;GET BLOCK LENGTH
	SUB C,DIRORA		;AS RELATIVE ADDRESS
	HRLI C,(<POINT 18,.-.(Q1),35>) ;BUILD BYTE POINTER
CDCKU2:	SOJLE D,R		;EXHAUSTED DIR LIST - FAILURE
	ILDB B,C		;GET NEXT GROUP FROM DIR
	XCTU [CAMN B,(A)]	;COMPARE WITH USER LIST ELEMENT
	JRST CDCKU1		;EQUAL - GET NEXT USER ELEMENT
	ILDB B,C		;GET NEXT GROUP FROM DIR
	XCTU [CAMN B,(A)]	;COMPARE WITH USER ELEMENT
	JRST CDCKU1		;EQUAL - GET NEXT USER ELEMENT
	JRST CDCKU2		;NOT EQUAL - KEEP LOOKING
;ROUTINE TO GET SPACE IN DIR FOR GROUP LIST AND TO BUILD THE LIST
;ACCEPTS IN A/	ADDRESS OF LIST OF GROUP NUMBERS IN USER SPACE
;	CALL CRGDGB
;RETURNS +1:	FAILED
;	 +2:	RELATIVE ADR OF LIST IN AC A

CRGDGB:	STKVAR <CRGDGA,CRGDGC>
	TLNE A,-1		;GUARD AGAINST OLD FORMAT OF GROUPS
	JRST [	BUG.(CHK,CRDOLD,JSYSF,HARD,<CRGDGB - Old format CRDIR is illegal>,,<

Cause:	The old format of specifying user groups to CRDIR% has been
	attempted. This format is no longer supported.

Action:	Change the application to use the format specified in the current
	Monitor Calls Reference Manual.
>)
		RET]		;GIVE FAILURE RETURN
	MOVEM A,CRGDGA		;SAVE ADDRESS OF LIST IN USER SPACE
	JUMPE A,RSKP		;IF NO LIST, RETURN WITH A=0
	XCTU [HRRZ B,0(A)]	;GET LENGTH OF LIST
	SETZ A,			;SET UP FOR NULL LIST
	CAIG B,1		;LIST MUST HAVE MORE THAN HEADER
	RETSKP			;NULL LIST, RETURN WITH 0 IN A
	MOVEM B,CRGDGC		;SAVE LENGTH OF LIST
	ADDI B,2		;LEAVE ROOM FOR HEADER
	LSH B,-1		;WORDS ARE PACKED WHEN STORED IN DIR
	CALL ASGDFR		;GET SPACE FOR LIST
	 RETBAD (CRDIX4)	;FAILED TO GET SPACE
	MOVEI B,.TYGDB		;SET UP BLOCK TYPE
	STOR B,BLKTYP,(A)	;...
	MOVE B,CRGDGA		;GET POINTER TO USER LIST
	MOVEM A,CRGDGA		;SAVE ADR OF LIST IN DIR
	SOS C,CRGDGC		;GET COUNT OF ELEMENTS IN LIST
CRGDG1:	UMOVE D,1(B)		;GET NEXT GROUP NUMBER FROM USER SPACE
	HRLZM D,1(A)		;STORE IN DIR LIST
	AOS B			;STEP TO NEXT ELEMENT IN USER LIST
	SOJLE C,CRGDG2		;COUNT DOWN NUMBER OF GROUPS
	UMOVE D,1(B)		;GET NEXT GROUP FROM USER LIST
	HRRM D,1(A)		;STORE IT IN DIRECTORY
	AOS A			;STEP TO NEXT WORD IN DIR
	AOS B			;AND STEP USER LIST
	SOJG C,CRGDG1		;LOOP BACK FOR ALL GROUPS
CRGDG2:	MOVE A,CRGDGA		;GET ABS ADR OF LIST
	SUB A,DIRORA		;GET RELATIVE ADR
	RETSKP			;AND GIVE OK RETURN
;ROUTINE TO FIX UP ROOT DIR WHEN IT IS BEING CREATED DURING FILINI
;ACCEPTS IN A/ ADR OF FDB
;	    B/ STRUCTURE NUMBER
;	CALL RDFIX
;RETURNS +1:	ALWAYS

RDFIX:	MOVE B,STRTAB(B)	;GET ADDRESS OF SDB FOR THIS STRUCTURE
	LOAD B,STRRXB,(B)	;GET ADDRESS OF INDEX BLOCK FOR ROOT-DIRECTORY
	STOR B,FBADR,(A)	;MAKE FILE EXIST
	SETZRO FBNXF,(A)	;FILE NOW EXISTS
	SETONE FB%SDR,.FBCTL(A) ;SUBDIRS PRESENT
	MOVEI B,377777		;INITIALIZE SUBDIR LIMIT TO INF
	STOR B,DRSDM,(Q1)	; ...
	RET			;AND RETURN
;ROUTINE TO SET UP THE INDEX TABLE OF NEW DIRECTORIES
;ACCEPTS IN A/	ADR OF INDEX BLOCK IF ANY (0 IF NONE)
;	CALL CRDIDX
;RETURNS +1:	ERROR
;	 +2:	SUCCESSFUL - INDEX TABLE SET UP

CRDIDX:	STKVAR <CRDIDA>
	MOVEM A,CRDIDA		;SAVE DISK ADDRESS OF INDEX BLOCK
	HRRZ JFN,CRDIRJ		;GET JFN OF DIR FILE
	IMULI JFN,MLJFN		;GET INDEX INTO JFN TABLES
	MOVE STS,FILSTS(JFN)	;SET UP FOR CALL TO GETFDB
	HRRI DEV,DSKDTB
	HRL DEV,CRDSTX		;GET STRUCTURE NUMBER
	CALL GETFDB		;GET THE FDB MAPPED IN
	 RETBAD			;FAILED
	MOVEM A,CRDTMP		;SAVE ADDRESS OF FDB
	SETONE <FBNOD,FBDIR>,(A) ;MARK THAT THIS IS A DIR FILE
	MOVE C,CRDIRD		;GET DIRECTORY NUMBER
	STOR C,FBDRN,(A)	;STORE DIR # IN FDB OF DIR FILE
	MOVEM A,CRDIRT		;SAVE FDB ADDRESS
	LOAD B,STR,(JFN)	;GET STRUCTURE NUMBER
	CAIN C,ROOTDN		;IS THIS THE ROOT DIR BEING CREATED?
	CALL RDFIX		;YES, SET UP SPECIAL INFO
	LOAD D,DRNUM,(Q1)	;GET DIR NUMBER OF SUPERIOR
	MOVE B,CRDIRT		;GET ADR OF FDB
	SUB B,DIRORA		;MAKE IT RELATIVE ADDRESS
	MOVE A,CRDIRT		;GET ADR OF FDB AGAIN
	SKIPN C,CRDIDA		;IF AN ADDRESS WAS SPECIFIED, USE IT
	LOAD C,FBADR,(A)	;GET ADDRESS OF INDEX BLOCK OF FILE
	LOAD A,FBDRN,(A)	;GET DIR NUMBER
	CALL SETIDX		;SET UP THE INDEX TABLE
	 JRST CRDIDE		;FAILED
	SKIPN B,CRDIDA		;IS THERE A DISK ADDRESS?
	JRST CRDID1		;NO
	MOVE A,CRDTMP		;YES, DOING RECONSTRUCTION
	STOR B,FBADR,(A)	;STORE THIS ADDRESS IN THE FDB
	SETZRO FBNXF,(A)	;AND MAKE THIS FILE EXISTENT
CRDID1:	ULKDIR			;UNLOCK THE DIR
	MOVE A,CRDIRT		;GET BACK FDB ADDRESS
	RETSKP			;AND RETURN

CRDIDE:	MOVE B,CRDTMP		;GET ADDRESS OF FDB
	SETZRO FBDIR,(B)	;UNDO WHAT CRDIDX HAS ALREADY DONE
	SETZRO FBDRN,(B)
	ULKDIR			;NOW UNLOCK THE DIR
	RETBAD ()
;COMMON FAILURE CASE FOR ABOVE

CRBUG1:	BUG.(CHK,CRDNOM,JSYSF,HARD,<CRDIR - Failed to make MAIL.TXT file>,,<

Cause:	While creating a new directory that is not FILES-ONLY, CRDIR% could
	not create the MAIL.TXT.1 file.

Action:	Find out why the MAIL.TXT.1 file could not be created. It is
	most likely a problem with the disk.
>)
	RET
;change the remote alias list
;CALL CRDRNA
;Q1/ address of mapped directory
;Q2/ user address of CRDIR argument block
;directory mapped & locked.
;returns +1 on failure, with directory unlocked.
;returns +2 on success, with directory locked.
;uses T1-T4
;NOTE: when inserting a remote alias, the list in the directory is searched for
;      occurrences of remote aliases with that node name. Any such occurences
;      are deleted from the directory list.
CRDRNA:	TRVAR <UBLOCK,MBLOCK,JSBTMP,UFLAGS>
	SAVEAC <Q3>
;	UBLOCK - previous context address of remote alias block
;	MBLOCK - address of remote alias block being created
;	JSBTMP - address of temporary storage in JSB
;	UFLAGS - flags supplied by the user
;these TRVARs are used in CRDDUP, CRDCOP, CRDJSB

	UMOVE T2,.CDDRN(Q2)	;Get address of first alias block
	CAIN T2,0		;null list ?
	RETSKP			;yes. done.
	MOVEM T2,UBLOCK		;save address

;loop detect on user arguments

	MOVEI T1,CRDMAX   	;maximum # of aliases allowed
	DO.
       	  UMOVE T2,.CDNXT(T2)	;get next block
	  JUMPE T2,ENDLP.	;end of list, good.
	  SOJGE T1,TOP.  	;not end of list, continue
	  RETBAD (CRDI25,<ULKDIR>) ;failed.
	ENDDO.
	DO.			;for each block ...
	  MOVE T1,UBLOCK	;get &
	  UMOVE T2,.CDSIZ(T1)	; save
	  HLLZM T2,UFLAGS	;  flags
	  TXNN T2,<CD%NEW+CD%KIL> ;creating a new or deleting an old ?
	  IFSKP.
	    TXNN T2,CD%NEW	;yes. creating a new ?
	    IFSKP.
       	      MOVEI T2,RN.SIZ   ;yes. allocate an
	      CALL ASGDFR	;(T2/T1) alias block for directory [absolute]
	       RETBAD (NSPX01)	;Failed
	      MOVEM T1,MBLOCK	;save addr of new block
	    ELSE.
	      SETZM MBLOCK	;no. deleting, so no new block.
	    ENDIF.
	    MOVE T1,UBLOCK	;get user's
	    UMOVE T1,.CDNOD(T1)	; node name byte pointer
            CALL CRDDUP		;(T1) delete duplicates.
	     RETBAD ()		;failed
	    SKIPN MBLOCK	;is there a new block to be copied ?
	    IFSKP.
	      CALL CRDCOP	;() yes, copy it into directory.
 	       RETBAD ()	;failed.
	      MOVE T2,MBLOCK	;get addr of new block [absolute]
	      LOAD T1,DRRNA,(Q1) ;get addr of current list
	      STOR T1,RNNXT,(T2) ;insert new block into current list
	      SUB T2,DIRORA	;make address relative.
	      STOR T2,DRRNA,(Q1) ;the new "current list"
	    ENDIF.
	  ELSE.
	    UMOVE T1,.CDNOD(T1) ;no. altering existing entry. find alias
	    CALL CRDFND		;(T1/T1,T2) block in directory with that node
	     RETBAD ()		;allocation failure
	    SKIPN T2		;does it exist ?
	    IFSKP.
	      MOVE Q3,T2	;it exists. save addr of alias block [absolute]
	      MOVE T1,UFLAGS	;new
	      TXNN T1,CD%PAS	; password ?
	      IFSKP.
		XMOVEI T1,RN.PAS(Q3) ;yes. address of directory password entry.
		MOVE T2,UBLOCK	; byte pointer to
		UMOVE T2,.CDPAS(T2) ; user password entry
		CALL CRDCHG	;(T1,T2) do the work.
	         RETBAD ()	;failed
	      ENDIF.
	      MOVE T1,UFLAGS	;new
	      TXNN T1,CD%ACC	; password ?
	      IFSKP.
		XMOVEI T1,RN.ACC(Q3) ;yes. address of directory account entry.
		MOVE T2,UBLOCK	; byte pointer to
		UMOVE T2,.CDACC(T2) ; user account entry
		CALL CRDCHG	;(T1,T2) do the work.
	         RETBAD ()	;failed
	      ENDIF.
	    ENDIF.
	  ENDIF.
	  MOVE T1,UBLOCK	;get next user block
	  UMOVE T1,.CDNXT(T1)
	  SKIPN T1           	;was this the last one ?
	  RETSKP		;yes. success.
	  MOVEM T1,UBLOCK    	;no.
	  LOOP.      		; continue.
	ENDDO.
;search through the current remote alias list for an entry with a
;particular node name, and delete that entry
;CALL CRDDUP
; T1/ user byte pointer to node name to key on.
; Q1/ address of mapped directory
;returns +1 on failure (allocation failure) with directory unlocked.
;returns +2 on success with directory locked.
;uses the TRVAR JSBTMP
CRDDUP:	CALL CRDFND		;(T1/T1,T2) get address of the entry
	 RETBAD ()		;allocation failure
	JUMPE T2,RSKP		;not there.
	CALL CRDDEL		;(T1) delete it
	RETSKP
;find the remote alias entry with a particular node name associated with it.
;CALL CRDFND
; T1/ user byte pointer to node name
; Q1/ address of mapped directory
;returns +2 with
; T1/ address [absolute] of previous alias block or
;     0 if it is first in the list or
;     -1 if not found
; T2/ address [absolute] of matched alias block
;     0 if no match
;returns +1 on failure (allocation), with directory unlocked
CRDFND:	SAVEAC <Q2,Q3>
	CALL CPYFU0		;(T1/T1) copy user string to a JSB and trim.
	 RETBAD (CRDIX3,<ULKSTR>) ;failure
	MOVEM T1,JSBTMP		;save JSB string block address.
	SETZ Q3,		;initialize previous pointer
	LOAD Q2,DRRNA,(Q1)	;get start of current list.
	DO.			;for each entry in list...
 	  SKIPE Q2		;end of list ?
	  IFSKP.
	    SETO T1,		;yes. no match
	    SETZ T2,
	    RETSKP
          ENDIF.
	  ADD Q2,DIRORA		;make it absolute.
	  MOVE T1,JSBTMP	;address of key string block
	  LOAD T2,RNNOD,(Q2)	;address of node name string block
	  SKIPE T2		;null ?
	  ADD T2,DIRORA		;no. make it absolute.
	  CALL CRDCMP		;(T1,T2) compare. equal ?
	  IFSKP.
	    CALL CRDJSB		;yes. deallocate key string block
	    MOVE T1,Q3		;address of previous
	    MOVE T2,Q2 		;address of this one
	    RETSKP		;success
	  ENDIF.
	  MOVE Q3,Q2		;no. update previous.
	  MOVE Q2,.CDNXT(Q2)	;step to next
	  LOOP.			; and continue.
	ENDDO.
;change an entry in an existing remote alias block
;CALL CRDCHG
; T1/ address of entry to be changed [absolute]
; T2/ user byte pointer
;returns +2 on success,
;returns +1 on failure with directory unlocked.
CRDCHG:	SAVEAC <Q2,Q3>
	MOVE Q2,T1		;save address of old entry
	MOVE T1,T2		;get user byte pointer
	CALL CRDENT		;(T1/T1) copy the entry into the directory
	 RETBAD ()		;failed
	MOVEM T1,Q3  		;save pointer to new entry
	SKIPE T2,(Q2)		;any old entry ?
	CALL RELDFR		;(T2) yes, deallocate it.
	MOVEM Q3,(Q2)		;insert pointer to new entry
	RETSKP
;copy a block
;MBLOCK/ address of directory remote alias block to be filled
;UBLOCK/ address of user remote alias block to be used
;CALL CRDCOP
;returns +1 on failure with new list deallocated, and directory unlocked
;returns +2 on success with directory locked
;uses JSBTMP
CRDCOP:	ACVAR <W1,W2,W3>	;grab some ACs
	MOVE W1,MBLOCK
	MOVE W2,UBLOCK
	MOVEI T1,.TYRNA		;get remote alias block type
	STOR T1,RNTYP,(W1)	;store in directory block
	SETZRO RNNXT,(W1)	;zero the "next" field in directory block
	SETZRO RNNOD,(W1)	;zero the node field in directory block
	SETZRO RNUSR,(W1)	;zero the user field in directory block
	SETZRO RNPAS,(W1)	;zero the password field in directory block
	SETZRO RNACC,(W1)	;zero the account field in directory block
	XCTU [HRRZ W3,.CDSIZ(W2)] ;get length of user's block
	ADDI W1,RN.NOD		;point to first entry in directory
	ADDI W2,.CDNOD		;point to first entry in user
	SUBI W3,.CDNOD		;how many entries user has
	DO.
	  SOJL W3,RSKP  	;until done,
	  UMOVE T1,(W2)		;get pointer to next entry
	  SKIPE T1		;null ?
	  IFSKP.
	    AOS W1		;yes. step
	    AOJA W2,TOP.	; to next
	  ENDIF.
	  CALL CRDENT		;(T1/T1) copy entry into directory
	   RETBAD ()		;failed
	  MOVEM T1,(W1)		;place string block pointer in new entry
	  AOS W1		;step
	  AOJA W2,TOP.		; to next
	ENDDO.			;end loop
	ENDAV.			;END ACVAR
;copy entry from user into directory
;CALL CRDENT
; T1/ user byte pointer
;returns +2 on success with
; T1/ address of directory string block [relative]
;returns +1 on failure
CRDENT:	ACVAR <W1>
	CALL CPYFUS		;(T1/T1) put it in JSB
	 RETBAD (CRDIX3,<ULKSTR>) ;failed
	MOVEM T1,JSBTMP		;save its JSB address
	CALL SETMSK		;set up mask data
	CALL CPYDIR		;(/T1) and place it in dir. [absolute address]
	 RETBAD (NSPX01,<CALL CRDJSB
	      	   ULKSTR>) 	;failed, release JSB string & unlock dir.
	MOVEI T2,.TYNAM		;mark it as
	STOR T2,NMTYP,(T1)	; a name block
	SUB T1,DIRORA		;make it relative
	MOVE W1,T1		;save it
	CALL CRDJSB		;() release JSB string
	MOVE T1,W1  		;restore address
	RETSKP
	ENDAV.			;end ACVAR
;deallocate a JSB string pointed to by JSBTMP
;CALL CRDJSB
;returns +1 always
CRDJSB:	MOVE T2,JSBTMP		;deallocate JSB string
	MOVEI T1,JSBFRE		;JSB free space header addr
  	CALL RELFRE		;(T1,T2/) do it
	RET
	ENDTV.			;end TRVAR from CRDRNA
;compare two string blocks
;CALL CRDCMP
;T1/ addr of one
;T2/ addr of the other
;returns +1 if not equal
;returns +2 if equal
;uses T1-T4
;note addr = 0 means null string
CRDCMP::SKIPE T1		;first is null ?
	IFSKP.
	  JUMPE T2,RSKP		;yes. if second null, it is a match.
	  LOAD T3,NMLEN,(T2)	;get length of second.
	  CAIG T3,1		;is length = 1 ?
	  RETSKP		;yes. second is null. match.
	  CAIG T3,2		;is length more than 2 ?
	  RET			;yes. second isn't null. cannot match.
	  MOVE T3,1(T2)		;length is 2. get string.
	  JUMPE T3,RSKP		;if null, it is a match
	  RET			;not a match
	ENDIF.
	SKIPE T2		;second is null ?
	IFSKP.
	  LOAD T3,NMLEN,(T1)	;get length of second.
	  CAIG T3,1		;is length = 1 ?
	  RETSKP		;yes. second is null. match.
	  CAIG T3,2		;is length more than 2 ?
	  RET			;yes. second isn't null. cannot match.
	  MOVE T3,1(T1)		;length is 2. get string.
	  JUMPE T3,RSKP		;if null, it is a match
	  RET			;not a match
	ENDIF.
	LOAD T3,NMLEN,(T1)	;are the
	LOAD T4,NMLEN,(T2)	; lengths
	CAME T3,T4		;  equal ?
	RET			;no. strings are not equal.
	DO.			;yes. check further.
	  SOSG T3		;finished ?
	  RETSKP		;yes. they are equal.
	  AOS T1 		;no. step to
	  AOS T2		; next word.
	  MOVE T4,(T1)      	;get word.
	  CAME T4,(T2) 		;equal ?
	  RET			;no. strings not equal
	  LOOP.			;yes. strings might be equal. continue.
	ENDDO.
;delete a remote alias entry in directory
;CALL CRDDEL
;T1/ absolute address of the previous entry (0 if the first is to be deleted)
;directory mapped and locked
;returns +1 always
CRDDEL:	ACVAR <W1,W2,W3>
        SKIPE T1		;is the first entry in the list to be deleted ?
	IFSKP.
	  MOVE T1,DIRORA	;yes. get directory base address
	  LOAD W1,DRRNA,(T1)	;get address of entry to be deleted
	  ADD W1,DIRORA		;make it absolute.
	  LOAD T2,RNNXT,(W1)	;get next entry.
	  STOR T2,DRRNA,(T1)	;unlink entry to be deleted.
	ELSE.
	  LOAD W1,RNNXT,(T1)	;no. get address of entry to be deleted
	  ADD W1,DIRORA		;absolute.
	  LOAD T2,RNNXT,(W1)	;get next.
	  STOR T2,RNNXT,(T1)	;unlink old.
	ENDIF.
	LOAD W2,RNLEN,(W1)	;get size.
	SUBI W2,RN.NOD		;get number of string blocks in this entry
	MOVE W3,W1		;addr of first string
	ADDI W3,RN.NOD		; block entry in this block
	DO.
	  SOJL W2,ENDLP.	;until done,
	  MOVE T2,(W3)		;get addr of string block
	  SKIPE T2   		;is it null ?
	  CALL RELDFR		;(T2) no. deallocate it. [relative]
	  AOJA W3,TOP.		;continue
	ENDDO.
	MOVE T2,W1		;get addr of present block
	SUB T2,DIRORA		;make it relative
	CALL RELDFR		;(T2) deallocate it. [relative]
	RET
	ENDAV.			;END ACVAR
;DELDIR - DELETE THIS DIRECTORY

DELDIR:	SETZM CRDIRF		;INITIALIZE ERROR FLAG
	SETZM CRDIRE		;INITIALIZE ERROR CODE
	CALL CRDIR6		;RETURN ALL SPACE USED
	SETZM CRDDIQ		;CLEAR DELTAS IN CASE DIR IS BAD
	SETZM CRDDOQ		; ...
	SETZM CRDDSQ		; ...

; TCO 5.1082 CHECK FOR OTHER JOB USING THIS DIRECTORY

	HLL T1,CRDSUP		; GET THE STRUCTURE CODE
	HRR T1,CRDIRD		; GET THE DIR ID.
	CALL SETDIR		; MAP IN THE DIRECTORY
	 JRST [ SETOM CRDIRF	; ASSUME DIR IS BAD
		JRST DELDI2 ]	; AND KEEP GOING
	CALL GETIDX		; GO GET THE INDEX STUFF
	 JRST [ SETOM CRDIRF	; ASSUME BAD DIRECTORY
		JRST DELDI2 ]	; AND MOVE ON
	PUSH P,T1		; SAVE THE INDEX STUFF FOR LATER
	PUSH P,T2		;
	HRRZ T1,CRDIRD		; GET THE DIRECTORY NUMBER
	NOINT			; WE SHOULD NOT BE INTERRUPTED
	CALL INVDIR		;[7.1055](T1/) Make sure ALOC2 will not get us
	IFNSK.			;[7.1055] Can't delete this directory
	  POP P,T2		;[7.1055] Put the ACs back
	  POP P,T1		;[7.1055]
	  CALL USTDIR		;[7.1055](/) Unlock the directory
	  OKINT			;[7.1055] Undo the NOINT
	  MOVEI T4,CRDIX7	;[7.1055] Say we still have mapped files
	  JRST DELDI3		;[7.1055] And get out of here
	ENDIF.			;[7.1055]
	CALL INVIDX		; INVALIDATE THE INDEX WHILE WE LOOK AROUND
	MOVSI STS,-NJOBS	; SET UP AOBJN POINTER
	HLL DEV,CRDSUP		; GET THE UNIQUE CODE
	HRR DEV,CRDIRD		; UNIQUE CODE,,DIRECTORY
	LOAD P3,CURSTR		; GET THE STRUCTURE NUMBER
DDLOOP:	HRRZ T1,STS		; GET JOB NUMBER
	CAMN T1,JOBNO		; IS IT US?
	 JRST DDNXT		; YES, WE CHECK THAT LATER
	CALL MAPJSB		; MAP HIS JSB
	 JRST DDNXT		; NON-EXISTENT, GO DO NEXT
	CALL GTOJCD		; GET OTHER JOB'S CONNECTED DIRECTORY
	CAMN T1,DEV		; MATCH?
	 JRST DDBMB		; YES, GO BOMB OUT
	CALL CLRJSB		; UNMAP JSB
	CAME P3,LGSIDX		; [7.1112]Login Structure?
	JRST DDNXT		; NO, DON'T CHECK FOR LOGGED-IN
	HRRZ T1,JOBDIR(STS)	; GET LOGGED-IN DIR OF THIS JOB
	HRRZ T2,CRDIRD		; AND THE DIR # OF THE ONE TO DELETE
	CAMN T1,T2		; SAME?
	 JRST DDBMB		; YES, RETURN THE ERROR
DDNXT:	AOBJN STS,DDLOOP	; CHECK FOR MORE
	POP P,T3		; RETRIEVE THE IDXTAB STUFF
	POP P,T2
	CALL CRDONE		; RESET IT
;DON'T LET USER DELETE THIS DIRECTORY IF CONNECTED TO IT

	CALL GTCSCD		;GET CONNECTED STRUCTURE,,DIRECTORY
	HLL B,CRDSUP		;GET UNIQUE CODE
	HRR B,CRDIRD		;GET (STRUCTURE,,DIRECTORY) TO DELETE
	CAMN A,B		;TRYING TO DELETE CONNECTED DIRECTORY?
	JRST [	CALL USTDIR	;RELEASE THE DIRECTORY LOCK
		MOVEI D,CRDI19	;YES. DON'T ALLOW IT
		JRST DELDI3]	;GO CLEAN UP AND FAIL
	MOVE A,B		;A/(UNIQUE CODE,,DIRECTORY) TO DELETE

;DON'T ALLOW USER TO DELETE THIS DIRECTORY IF LOGGED-IN TO IT.

	MOVE A,JOBNO		;GET THIS JOB NUMBER
	HRRZ A,JOBDIR(A)	;GET ITS LOGGED-IN DIRECTORY NUMBER ON PS
	LOAD B,DRNUM,(Q1)	;GET NUMBER OF MAPPED DIRECTORY
	CAME A,B		;DO THEY MATCH?
	JRST DELDI6		;NO. OK TO DELETE IT
	LOAD B,CURSTR		;YES. GET STRUCTURE NUMBER FOR THIS DIRECTORY
	CAME B,LGSIDX		;[7.1112]Is it the Login Structure?
	JRST DELDI6		;YES. OK TO DELETE IT
	MOVEI D,CRDI18		;YES. CAN'T DELETE LOGGED-IN DIRECTORY
	CALL USTDIR		;UNLOCK THE DIRECTORY
	JRST DELDI3		;GO RETURN ERROR

; ROUTINE TO BOMB OUT OF SEARCH IN DDLOOP ABOVE

DDBMB:	POP P,T3		; GET BACK THE IDXTAB STUFF
	POP P,T2		;
	CALL CRDONE		; GO RESET WITH SETIDX
	CALL CLRJSB		; CLEAR OUT THE JSB WE MAPPED
	CALL USTDIR		; UNLOCK THE DIRECTORY
	OKINT			; MAKE US INTERRUPTIBLE
	MOVEI T4,CRDIX6		; SET ERROR TO "ALREADY MAPPED"
	JRST DELDI3		; AND GO TO IT

; ROUTINE TO RESET THE IDXTAB ENTRY FOR DDLOOP ABOVE

CRDONE:	HRRZ T1,CRDIRD		;
	LOAD T4,CURSTR		; GET THE STRUCTURE NUMBER
	HLRS T4			; SWAP IT
	HRR T4,CRDSUP		; DIRECTORY NUMBER OF SUPERIOR
	CALL SETIDX		; SET IT
	 RET			; SHOULDN'T HAPPEN
	RET			; OK
;SAVE THE QUOTAS (DISK AND SUBDIRECTORY) FOR THIS DIRECTORY SO THEY
;CAN BE GIVEN BACK TO ITS SUPERIOR

DELDI6:	LOAD A,DRLIQ,(Q1)	;GET LIQ
	MOVEM A,CRDDIQ		;SAVE AS DELTA LIQ FOR SUPERIOR
	LOAD A,DRLOQ,(Q1)	;GET LOQ
	MOVEM A,CRDDOQ		;SAVE AS DELTA
	LOAD A,DRSDM,(Q1)	;GET SUBDIR QUOTA
	MOVEM A,CRDDSQ		;SAVE
	CALL USTDIR		;RELEASE DIR

;SEE IF DIRECTORY FILE IS MAPPED. IF SO, THE DIRECTORY CAN'T BE DELETED
;IN THIS MANNER

	MOVE A,CRDIRJ		;1/JFN
	MOVE B,[1,,.FBADR]	;2/(COUNT,,OFFSET INTO FDB)
	MOVEI C,D		;3/DESTINATION FOR RESULT
	GTFDB			;GET ADDRESS OF INDEX BLOCK
	 ERJMP [SETOM CRDIRF	;DIRECTORY IS BAD. DON'T BOTHER TO CHECK
		JRST DELDI2]	;GO DELETE THE DIRECTORY ANYWAY
	MOVEM D,CRDIRA		;SAVE IT
	CALL UNMAPD		;UNMAP THE DIRECTORY TO BE DELETED
	MOVE A,CRDIRA		;A/ADDRESS OF INDEX BLOCK
	HRRZ B,CRDSTX		;B/STRUCTURE NUMBER
	CALL CHKOFN		;SEE IF THIS FILE IS OPEN (DIRECTORY IS MAPPED)
	 JRST [	MOVEI T4,CRDIX6	;YES. CAN'T DELETE THE FILE, THEN
		JRST DELDI3]	;RELEASE JFN AND RETURN

;DELETE AND EXPUNGE ALL THE FILES IN THIS DIRECTORY. THIS WILL FAIL IF THE
;DIRECTORY HAS SUBDIRECTORIES

	HRRZ A,CRDSTX		;GET STRUCTURE NUMBER
	CALL STRCNV		;GET UNIQUE CODE FOR THIS STRUCTURE
	 JRST [	MOVE D,A	;FAILED, GET ERROR CODE
		JRST DELDI3 ]	;GO RETURN ERROR
	HRL A,A			;POSITION UNIQUE CODE
	HRR A,CRDIRD		;Get directory number to delete
	MOVX F,1B17		;DELETE AND EXPUNGE ALL FILES FROM DIR
	CALL DELDEL
	 JRST [	MOVEM T1,CRDIRE ;FAILED. SAVE ERROR CODE
		JRST DELDI1]	;GO SEE WHY FAILED
;FILES MAY OR MAY NOT HAVE BEEN DELETED AT THIS POINT.  NOW CLEAR DIRECTORY
;AND PERMANENT BITS SO THAT DIRECTORY FILE CAN BE DELETED

DELDI2:	HRRZ JFN,CRDIRJ		;GET JFN
	IMULI JFN,MLJFN		;GET INTERNAL FORMAT
	MOVE STS,FILSTS(JFN)	;SET UP FOR GETFDB CALL
	HRRI DEV,DSKDTB		;...
	HRL DEV,CRDSTX		;GET STRUCTURE NUMBER
	CALL GETFDB		;MAP IN THE FDB OF THIS FILE
	 JRST [	MOVEI D,CRDIX9	;FAILED. RETURN ILLEGAL FORMAT ERROR CODE
		JRST DELDI3]	;CLEAN UP AND TAKE ERROR RETURN
	SETZRO <FBPRM,FBDIR>,(A) ;CLEAR BITS SO DELF WILL WORK

;INCREMENT SUPERIOR'S QUOTAS BY THE AMOUNT PREVIOUSLY ASSIGNED TO THIS
;DIRECTORY

	HRRZ A,CRDSUP		;GET SUPERIOR DIRNO
	CAIN A,ROOTDN		;ROOT-DIR?
	JRST DELDI5		;YES - DONT INCREMENT QUOTAS
	CALL CKLIQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T ADJUST
	JRST [	LOAD A,DRLIQ,(Q1) ;NO. GET SUPERIOR LIQ
		ADD A,CRDDIQ 	;INCREMENT BY DELTA LIQ
		STOR A,DRLIQ,(Q1); ADJUST SUPERIOR'S LOGGED-IN QUOTA
		HRRZ A,CRDSUP	;A/ DIRECTORY NUMBER FOR SUPERIOR
		MOVE B,CRDSTX	;B/ STRUCTURE NUMBER
		MOVE C,CRDDIQ	;C/ AMOUNT TO ADD TO SUPERIOR
		CALL ADJALC	;ADJUST SUPERIOR'S ALLOCATION ENTRY
		JRST .+1]
	CALL CKLOQ		;SEE IF SUPERIOR HAS INFINITE QUOTA
	 SKIPA			;YES. DON'T ADJUST
	JRST [	LOAD A,DRLOQ,(Q1) ;NO. GET SUPERIOR LOQ
		ADD A,CRDDOQ	;INCREMENT BY DELTA LOQ
		STOR A,DRLOQ,(Q1) ;ADJUST SUPERIOR'S LOGGED-OUT QUOTA
		JRST .+1]
	LOAD A,DRSDM,(Q1)	;GET SUPERIOR SDQ
	ADD A,CRDDSQ		;GET SUBDIR DELTA
	STOR A,DRSDM,(Q1)	;STORE
DELDI5:	LOAD A,DRSDC,(Q1)	;GET CURRENT SUBDIR COUNT
	SUBI A,1		;ONE FEWER SUBDIRS
	STOR A,DRSDC,(Q1)	; ...
	MOVEM A,CRDDSQ		;SAVE RESIDUAL COUNT
	ULKDIR			;UNLOCK DIR

;REMOVE ENTRY FOR THIS DIRECTORY FROM IDXTAB

	MOVE A,CRDIRD		;GET DIR NUMBER AGAIN
	CALL DELIDX		;DELETE THIS ENTRY FROM INDEX TABLE
;IF DELETING THE LAST SUBDIRECTORY FROM ITS SUPERIOR, INDICATE THAT
;SUPERIOR NO LONGER HAS SUBDIRECTORIES

	SKIPE CRDDSQ		;NEED TO CLEAR SUBDIR FLAG IN SUP FDB?
	JRST DELDI4		;NO.
	HRRZ A,CRDSUP		;GET SUPERIOR DIR NUMER
	CALL GETIDX		;GET INDEX INFORMATION
	 JRST DELDI4		;CANT
	MOVEM A,CRDTMP		;SAVE FDB ADDRESS
	MOVE A,C		;GET SUPERIORS SUPERIOR DIR NUMBER
	HLL A,CRDSUP		;INSERT SUC
	CALL SETDIR		;MAP DIRECTORY
	 JRST DELDI4		;OH WELL, WASN'T ALL THAT IMPORTANT
	MOVE A,CRDTMP		;GET FDB OF SUPERIOR
	ADD A,DIRORA		;AS AN ABSOLUTE ADDRESS
	SETZRO FB%SDR,.FBCTL(A) ;CLEAR SUBDIR FLAG
	CALL UPDDIR		;UPDATE DISK IMAGE
	CALL USTDIR		;RELEASE
;DELETE THE DIRECTORY FILE AND EXPUNGE ITS CONTENTS

DELDI4:	MOVE C,CRDIRD		;C/ DIRECTORY NUMBER
	MOVE D,CRDSTX		;D/ STRUCTURE NUMBER
	CALL REMSDR		;REMOVE FROM CACHE IF NECC.
	CALL CRDSWH		;SET WHEEL FOR DURATION OF DELETE
	MOVX A,DF%EXP		;EXPUNGE CONTENTS
	HRR A,CRDIRJ		;GET JFN OF DIR FILE
	DELF			;DELETE THE DIR FILE
	 JRST [	PUSH P,A	;SAVE ERROR CODE
		CALL CRDCWH	;CLEAR WHEEL
		POP P,D		;RESTORE ERROR CODE
		JRST DELDI3]	;GO CLEAN UP
	CALL CRDCWH		;CLEAR WHEEL
	SKIPE CRDIRF		;HAS DELDEL FAILED FOR A BAD DIRECTORY?
	JRST [ HRRZ A,CRDSTX	;GET STRUCTURE NUMBER
	       HRRZ A,STRTAB(A)	;GET LOCATION OF SDB
	       MOVE A,(A)	;GET SIXBIT STRUCTURE NAME
	       BUG.(INF,DELBDD,JSYSF,HARD,<DELDIR - Bad directory deleted>,<<A,STRNAM>>,<

Cause:	After a bad directory has been deleted, the attempt to delete and
	expunge it's contents has failed.  The bit table is now incorrect.

Action:	Use CHECKD to rebuild the structure's bit table.

Data:	STRNAM - sixbit structure name
>,,<DB%NND>)			;[7.1210] 
	       JRST .+1]	;CONTINUE
	HRRZ A,CRDIRJ		;GET JFN AGAIN
	RLJFN			;RELEASE THE JFN
	 JFCL
	HRRZ A,CRDSUP		;GET SUPERIOR DIRECTORY NUMBER
	CAIE A,ROOTDN		;IS IT ROOT-DIRECTORY?
	RETSKP			;NO. DON'T MAKE BACKUP
	HRRZ A,CRDSTX		;YES. GET STRUCTURE NUMBER
	CALL CPYBAK		;UPDATE BACKUP
	 JRST [	BUG.(CHK,CRDBK1,JSYSF,HARD,<CRDIR4 - Could not make backup copy of ROOT-DIRECTORY>,,<

Cause:	During an attempt to delete a directory directly inferior to the
	root directory, CPYBAK failed to update the backup copy of the root
	directory.

Action:	The backup copy of the root directory is now corrupt and must be
	repaired by hand.
>,,<DB%NND>)			;[7.1210] 
		RETSKP]
	RETSKP
;A FAILURE HAS OCCURRED. IF IT IS DUE TO A BAD DIRECTORY, FORCE IT TO
;BE DELETED ANYWAY.  IF NOT, ERROR IS PROBABLY OPEN FILE IN DIRECTORY, WHICH
;SHOULD FAIL

DELDI1:	SKIPE CRDIRF		;DID CONSISTENCY CHECK FAIL PREVIOUSLY?
	JRST [	MOVEI D,CRDIX9	;YES. RETURN BAD FORMAT FOR DIRECTORY
		JRST DELDI3]	;CLEAN UP AND TAKE ERROR RETURN
	MOVE A,CRDIRD		;NO. A/DIRECTORY NUMBER
	HLL A,CRDSUP		;GET STRUCTURE UNIQUE CODE IN LH
	MOVX F,DD%CHK		;CHECK CONSISTENCY OF DIRECTORY
	CALL DELDEL		; BUT DON'T FIX ANYTHING
	 JRST [ SETOM CRDIRF	;FAILED. INDICATE BAD DIRECTORY
		JRST DELDI2]	;GO DELETE THE DIRECTORY FILE
	SKIPN D,CRDIRE		;IF ERROR CODE SET, USE IT
	MOVEI D,CRDIX7		;IF NO CODE, ASSUME FILE IS OPEN
DELDI3:	HRRZ A,CRDIRJ		;GET JFN OF DIRECTORY FILE
	RLJFN			;RELEASE IT
	 JFCL
	MOVE A,D		;RESTORE ERROR CODE
	RETBAD ()		;GIVE ERROR RETURN
;CHKNUM - ROUTINE TO SEE IF DIR # SPECIFIED BY USER ALREADY EXISTS

CHKNUM:	SAVET			;PRESERVE TEMPORARY ACS
	HRROI A,CRDIRS		;GET POINTER TO DEVICE NAME
	STDEV			;GET DEVICE DESIGNATOR
	 JRST [ MOVEM B,CRDIRE	;RETURN ERROR NUMBER
		RETBAD ()]
	MOVEM B,CRDDEV		;SAVE DEVICE DESIGNATOR
	HRRZ A,B		;GET STRUCTURE UNIQUE CODE
	CALL CNVSTR		;CONVERT TO STR #
	 JRST [ MOVEM A,CRDIRE	;RETURN ERROR NUMBER
		RETBAD ()]
	MOVEM A,CRDSTR		;SAVE STRUCTURE #
	SKIPN C,STRTAB(A)	;GET SDB FOR THIS STRUCTURE
	 JRST [ MOVEI A,CRDI12	;INVALID STRUCTURE
		JRST CHKNM1]
	JN STCRD,(C),CHKNM2	;RETURN SUCCESS IF CREATING ROOT-DIRECTORY
	HRLZ A,CRDDEV		;GET STR UNIQUE CODE
	XCTU [HRR A,.CDNUM(Q2)]	;GET DIR NUMBER SPECIFIED BY USER
	CALL SETDIR		;SEE IF DIRECTORY WITH THIS NUMBER EXISTS
	 JRST CHKNM2		;NO SUCH DIRECTORY, SUCCESS
	CALL CHKNAM		;SEE IF THE NAME STRINGS MATCH
	 JRST CHKNM0		;NO, THIS IS ILLEGAL
	CALL USTDIR		;THEY MATCH, THIS MUST BE RECONSTRUCTION
	JRST CHKNM2

CHKNM0:	CALL USTDIR		;UNMAP THE DIRECTORY
	MOVEI A,CRDIX8		;DIRECTORY WITH SPECIFIED NUMBER ALREADY EXISTS

;CHKNUM ERROR RETURN

CHKNM1:	MOVEM A,CRDIRE		;SAVE ERROR NUMBER
	MOVE A,CRDSTR		;GET STR #
	CALL ULKSTR		;UNLOCK IT
	RETBAD ()

;CHKNUM SUCCESSFUL RETURN

CHKNM2:	MOVE A,CRDSTR		;GET STR #
	CALL ULKSTR		;UNLOCK IT
	RETSKP

;GTJFN BLOCK FOR CRDIR

CRDGJB:	GJ%DEL!GJ%PHY+1
	377777,,377777
	0			;DEVICE
	-1,,[ASCIZ/ROOT-DIRECTORY/]
	0			;NAME
	0			;EXT
	0			;PROTECTION
	0			;USE THE ACCOUNT OF THE CALLER
	0
;ROUTINE TO SET THE PROCESS INTO WHEEL STATE
;	CALL CRDSWH
;RETURNS +1:	USER IS NOINT AND WHEEL

CRDSWH:	NOINT
	MOVE A,CAPENB		;GET USER'S CAPABILITIES
	MOVEM A,CRDCAP		;SAVE THEM
	MOVX A,SC%WHL		;ADD WHEEL
	IORM A,CAPENB		; IN ORDER TO DO GTJFN
	RET			;AND RETURN


;ROUTINE TO CLEAR WHEEL AND PUT BACK THE PREVIOUS CAPABILITIES
;	CALL CRDCWH
;RETURNS +1:	OLD CAPABILITIES ARE RRESTORED, AND PROCESS IS OKINT

CRDCWH:	MOVE A,CRDCAP		;GET BACK ORIGINAL CAPABILITIES
	MOVEM A,CAPENB		;AND RESTORE TO USER
	OKINT
	RET			;AND RETURN


;CKLIQ AND CKLOQ - CHECK FOR INFINITE QUOTA

;ACCEPTS:
;	Q1/ CONTENTS OF DIRORA

;	CALL CKLIQ/CKLOQ

;RETURNS +1: QUOTA IS INFINITE
;	 +2: QUOTA IS NOT INFINITE

;CLOBBERS NO AC'S

CKLIQ:	SAVEAC <Q2>
	LOAD Q2,DRLIQ,(Q1)
	JRST CKLQ1

CKLOQ:	SAVEAC <Q2>
	LOAD Q2,DRLOQ,(Q1)
CKLQ1:	TXNN Q2,1B0
	TXNN Q2,1B1
	RETSKP
	RET
;ROUTINE TO INITIALIZE A DIRECTORY
;ACCEPTS IN T1/	DIRECTORY NUMBER
;	    T2/ STRUCTURE NUMBER
;	CALL DIRINI
;	    or
;	CALL DIRIN1 (from CRDIR%)
;RETURNS +1:	ERROR, ERROR CODE IN T1
;	 +2:	DIRECTORY IS INITIALIZED

DIRIN1:	TDZA T4,T4		;[7.1257] Make CRDIR% entry point
DIRINI::SETO T4,		;[7.1257] All other entries
	EA.ENT
	STKVAR <DIRINN,DIRINS,ENTPNT> ;[7.1257]
	MOVEM T4,ENTPNT		;[7.1257] Save entry point
	MOVEM T1,DIRINN		;SAVE DIRECTORY NUMBER
	MOVEM T2,DIRINS		;SAVE STRUCTURE NUMBER
	CALL MAPDIR		;MAP IN THE DIRECTORY
	 RETBAD (CRDIX8)	;ILLEGAL DIR NUMBER
	MOVE T1,DIRINN		;GET BACK DIR NUMBER
	MOVE T2,DIRINS		; AND STRUCTURE NUMBER
	CALL LCKDNM		;LOCK THE DIRECTORY
	HRRZ T1,DIRINS		;GET STRUCTURE NUMBER
	MOVE T1,STRTAB(T1)	;GET ADDRESS OF SDB
	INCR STRLK,(T1)		;LOCK THE STRUCTURE
	MOVE T4,DIRORA		;SET UP POINTER TO DIRORG
	SKIPN ENTPNT		;[7.1257] Only do this if CRDIR% code
	CALL CRDSWH		;[7440] (/T1) Bump privs to WHEEL and go NOINT
	SETZM 0(T4)		;ZERO THE FIRST WORD
	 ERJMP [SKIPN ENTPNT	;[7.1257] Do this if CRDIR% code
		CALL CRDCWH	;[7440] (/T1) Reset privs and go OKINT
		MOVE T1,DIRINN	;FAILED. GET DIR NUMBER
		MOVE T2,DIRINS	; AND STRUCTURE NUMBER
		CALL ULKDNM	;FREE LOCK
		HRRZ T1,DIRINS	;GET STRUCTURE # AGAIN
		MOVE T1,STRTAB(T1) ;GET SDB ADDRESS
		DECR STRLK,(T1) ;RELEASE STRUCTURE
		CALL UNMAPD	;UNMAP THE DIRECTORY
		MOVE T1,LSTERR	;GET PAGE FAULT HANDLER'S COMPLAINT
		RETBAD()]	;AND FAIL
	;..
	;..
	SKIPN ENTPNT		;[7.1257] Do this if CRDIR% code
	CALL CRDCWH		;[7440] (/T1) Reset privs and go OKINT
	MOVEI T1,777		;DO XBLT OF 1 PAGE
	MOVE T2,T4		;START OF PAGE
	MOVE T3,T4		;START OF PAGE
	AOS T3			;+1
	CALL XBLTA
	MOVE T1,DIRINN		;GET BACK DIR NUMBER
	STOR T1,DRNUM,(T4)	;PUT DIRECTORY NUMBER INTO DIR
	MOVEI T1,.TYDIR		;GET DIR BLOCK TYPE
	STOR T1,DRTYP,(T4)	;STORE TYPE # FOR CONSISTENCY CHECK
	SETZRO DRRPN,(T4)	;RELATIVE PAGE # IS 0
	MOVEI T1,.DIHL0		;GET LENGTH OF PAGE 0 HEADER
	STOR T1,DRHLN,(T4)	;REMEMBER LENGTH IN HEADER ITSELF
	SETZRO DRFFB,(T4)	;NO FREE AREA
	STOR T1,DRFTP,(T4)	;STORE END POINTER INTO DIR
	MOVEI T1,PGSIZ		;INITIAL DIR IS 1 PAGE LONG
	STOR T1,DRSTP,(T4)	;WITH SYMBOL TABLE ENDING AT 777
	MOVEI T1,PGSIZ-2	;EMPTY SYMBOL TABLE IS 2 WORDS LONG
	STOR T1,DRSBT,(T4)	;  TO HOLD JUST THE BLOCK TYPE
	ADD T1,DIRORA		;GET ACTUAL ADDRESS IN MON VIRT SPACE
	MOVE T2,DIRINN		;GET DIRECTORY NUMBER
	STOR T2,SYMDN,(T1)	;PUT IT IN SYMBOL TABLE HEADER BLOCK
	MOVEI T2,.TYSYM		;GET BLOCK TYPE OF SYMBOL TABLE
	STOR T2,SYMTY,(T1)	;STORE IT AT HEAD OF SYMBOL TABLE
	SETONE SYMVL,(T1)	;SET SECOND WORD TO -1
	MOVE T1,[5B2+.STDFP]	;GET STANDARD DEFAULT FILE PROTECTION
	STOR T1,DRDPW,(T4)	;SAVE DEFAULT FILE PROT
	MOVE T1,[5B2+.STDDP]	;NOW SET UP DIRECTORY PROTECTION
	STOR T1,DRPRT,(T4)	;...
	MOVE T1,[5B2+.STDBS]	;AND SET UP STD BACKUP SPECIFICATION
	STOR T1,DRDBK,(T4)	;...
	MOVEI T1,.STDMX		;INIT MAX ALLOCATION (LOGGED OUT QUOTA)
	STOR T1,DRLOQ,(T4)	;...
	STOR T1,DRLIQ,(T4)	; AND LOGGED IN QUOTA
	MOVX T1,.STDSD		;GET DEFAULT SUBDIR QUOTA
	STOR T1,DRSDM,(T4)	;STORE IN DIR
	MOVX T1,.STDNE		; Default online expiration
	STOR T1,DRDNE,(T4)	; Into directory
	SKIPG T1,TPRCYC		; Use Tape Recyle Period if set for
	MOVX T1,.STDFE		; Default offline expiration
	STOR T1,DRDFE,(T4)	; Into directory
	ULKDIR			;UNLOCK THE DIRECTORY
	RETSKP			;EXIT
	SUBTTL DELF JSYS

; Delete file
; Call:	1	; Jfn
;	DELF
; Return
;	+1	; Error, cannot delete
;	+2	; Success

; DF%NRJ (B0) - DON'T RELEASE JFN
; DF%EXP (B1) - EXPUNGE CONTENTS
; DF%FGT (B2) - FORGET FILE

.DELF::	MCENT			; Become slow
	HRRZ JFN,T1
	CALL CHKJFN		; Check it out
	 JRST GBGJFN
	 JFCL
	 ERUNLK DESX4		; Tty or byte illegal
	TQNE <ASTF>
	ERUNLK(DESX7)		; Output stars not allowed
	LOAD T2,FLDTB,(JFN)	;[9041] Get dispatch table
	CAIE T2,DSKDTB		;[9041] Is we on disk?
	IFSKP.			;[9041] If so,
	  MOVEI T1,.GODLF	;[9041] Say deleting file
	  SETZ T2,		;[9041] And not setting it secure
	  CALL ACJOFL		;[9041] (T1,T2,JFN/) And see if we can
	   ERUNLK()		;[9041] Can't
	ENDIF.			;[9041]
	CALL @DELD(P3)		; Call device dependent routine
	 ERUNLK()		; Couldn't delete
	UMOVE T1,T1
	TLNE T1,(DF%NRJ)	;IF B0, DON'T RELEASE JFN
	JRST DELF1
	TQNE <OPNF>
	IFSKP.
	  MOVEI A,0(JFN)	;GET THE JFN
	  CALL LUNLK0		;FREE THE STR LOCK
	  CALL RELJFN		;RELEASE THE JFN
	  SMRETN
	ENDIF.
DELF1:	CALL UNLCKF
	SMRETN
	SUBTTL DELNF JSYS

;DELETE ALL BUT N VERSIONS OF FILE

; 1/	FLAG BITS+JFN
; 2/	NUMBER OF VERSIONS TO KEEP
;
;RETURNS +1 - ERROR
;	+2 - SUCCESS, NUMBER OF VERSIONS DELETED IN 2

.DELNF:: MCENT
	XCTU [HRRZ JFN,1]	;Get JFN only from user's AC1
	CALL CHKJFN		;CHECK THE JFN
	 JRST GBGJFN
	 JFCL
	 ERUNLK DESX4		;TTY OF BYTE ILLEGAL
	TQNE <ASTF>		;PARSE-ONLY?
	ERUNLK(DESX7)		;YES, LOSE
	BLCAL. DSKOK,<P3>	;DISK?
	IFSKP.			;[9041] If so,
	  MOVEI T1,.GODLF	;[9041] Do we need ACJ's blessing?
	  SETZ T2,		;[9041] Say not setting secure
	  CALL ACJOFL		;[9041] (T1,T2,JFN/) Let's find out
	   ERUNLK ()		;[9041] ACJ said no
	ELSE.			;[9041] Not disk!
	  ERUNLK GFDBX1		;[9041] So no can do
	ENDIF.			;[9041]
	LOAD T1,STR,(JFN)	;[7.1063]Get structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is structure offline?
	 ERUNLK	()		;[7.1063]Return "Structure is offline"
	CALL GETFDB
	 ERUNLK DESX3
	UMOVE Q1,2		;NUMBER OF VERSIONS TO KEEP
DELNF2:	JN <FBNXF,FBDEL,FBNDL>,(A),DELNF1 ;[7253] Skip DELETED, NON-EX or NEVER-DELETE files
	UMOVE B,1		; Get flag
	TXNE B,DF%ARC		; Allowing deletes on archived ?
	 JRST DELNF5		; Yes, bypass check then
	PUSH P,A
	MOVX B,FC%WR		; Write access necessary for delete
	CALL ARACCK		; Check archive/vir. disk requirements
	JUMPG A,[POP P,A	; Not allowed--skip this file
		JRST DELNF1]
	POP P,A
DELNF5:	JN <FBTMP>,(A),DELNF3	;TEMPORARY FILES ARE SPECIAL
DELNF4:	SOJGE Q1,DELNF1		;SKIP IT IF STILL WITHIN KEEP COUNT
	PUSH P,A		;SAVE FDB ADR
	MOVX B,FC%WR		;MUST HAVE WRITE ACCESS TO DELETE
	CALL ACCCHK
	 JRST [	POP P,A		;NOT ENOUGH ACCESS RIGHTS
		ULKDIR
		ERUNLK (DELFX1)]
	POP P,A			;GET BACK FDB ADR
	SETONE FBDEL,(A)	;MARK IT AS DELETED
DELNF1:	LOAD A,FBGNL,(A)	;GET ADR OF FDB OF NEXT GENERATION
	JUMPE A,DELNFE		;DONE IF END OF LIST
	ADD A,DIRORA
	JRST DELNF2

DELNF3:	LOAD Q2,FBGEN,(A)	;GET GENERATION NUMBER
	SUBI Q2,^D100000	;OFFSET FOR TEMPORARY GENS
	JUMPL Q2,DELNF4		;[7107]  Not owned by a job, continue normally
	MOVE B,JOBNO		;Get local job number
	EXCH A,B		;Save A and position LJN correctly
	CALL LCL2GL		;(A/A) Convert to global job number
	 JFCL			;This should not fail!
	EXCH A,B		;Restore A; B now has global job number
	CAMN Q2,B    		;Belongs to current job?
	JRST DELNF4		;YES, DO NORMAL THING ON THIS FILE ONLY
	JRST DELNF1		;SKIP ALL TEMPORARY FILES NOT BELONGING TO THIS JOB

DELNFE:	SKIPLE Q1		;ANY FILES DELETED?
	MOVEI Q1,0		;NO, SET Q1=0
	XCTU [MOVNM Q1,2]	;STORE # OF FILES DELETED
	ULKDIR
	CALL UNLCKF
	SMRETN
	SUBTTL DSMNT JSYS
; Dismount device
; Call:	1	; Device designator
;	DSMNT
; Return
;	+1	; Error
;	+2	; Ok

.DSMNT:: MCENT
	UMOVE A,1
	CALL CHKDEV
	 RETERR()		; Illegal designator or not available
	HRRZ P3,DEV		; SET UP ADDRESS ONLY
	CALL DSM0		;DO THE WORK
	 RETERR DSMX1		;FAILED
	SMRETN

;LOCAL ROUTINE TO DO DISMOUNT

DSM0:	PUSH P,B		;SAVE DEV INDEX
	HRRZ P3,DEV
	CALL @DSMD(P3)		;CALL DEVICE DEPENDENT PART
	 JRST [	POP P,B		;FAILED
		RET]
	MOVSI A,(DV%MNT)
	POP P,B			;RECOVER DEV INDEX
	ANDCAM A,DEVCHR(B)	;CLEAR MOUNTED BIT
	RETSKP

;INTERNAL ROUTINE TO DISMOUNT DEVICE
; B/ DEV TABLE INDEX

DSMNT0::SAVEP
	PUSH P,1
	HRRZ A,DEVUNT(B)	;GET UNIT NUMBER
	ANDI A,DV%UNT		;MASK TO UNIT NUMBER
	CAIN A,DV%UNT		;CHECK FOR -1
	MOVEI A,-1		;YES SET -1
	HRRZ DEV,DEVDSP(B)	;BE SURE DEV SETUP AS USUAL
	HRLI DEV,0(A)
	CALL DSM0		;DO THE WORK
	 SOS -1(P)		;FAILED, PREVENT SKIP RETURN
DSMNT1:	POP P,1
	RETSKP
	SUBTTL DVCHR JSYS

; Get device characteristics
; Call:	1	; Device designator
;	DVCHR
; Return
;	+1	; Ok
;	2	; Device characteristics word
;	LH(3)	; Job to which device is assigned
;	RH(3)	; Unit number

.DVCHR::MCENT
	STKVAR <DEVJOB>		;Stash for Device's owning job
	HLRZ B,1
	TRZ B,777
	CAIL 1,.TTDES		; Is this a tty designator?
	CAIL 1,.TTDES+NLINES
	CAIN B,.DVDES		; Or a device designator
	JRST DVCHR1		; Yes, do directly
	UMOVE JFN,1		; No. translate first
	CALL CHKJFN
	 ITERR()
	 JFCL
	 JRST [	CAMN JFN,[0,,.NULIO]	;IS THIS NULL
		MOVE JFN,[600000+.DVNUL,,+777777]	;GIVE THE DEVICE DESIGNATOR
		UMOVEM JFN,1
		JRST DVCHR1]
	CALL LCKDVL		;LOCK DEVICE TABLE TO AVOID 'SECNX'
	CAIE P3,NFTDTB		;NFT device ?
	IFSKP.
	  CALL UNLCKF		;yes. unlock file.
	  UNLOKK DEVLKK		;unlock device table
	  MOVE A,[POINT 7,[ASCIZ\NFT\]] ;this is the device name
	  STDEV%		;get device designator
	   ITERR ()		;error
	  UMOVEM T2,T1		;return it to user.
	ELSE.
	  HLRZ A,FILDDN(JFN)	;no. Get pointer to device name block
	  HRLI A,(<POINT 7,0,35>)
	  CALL STDEVP		; Convert string to device designator
	   ITERR(<(A)>,<CALL UNLCKF
			UNLOKK DEVLKK>)
	  CALL UNLCKF
	  UNLOKK DEVLKK		;UNLOCK THE DEVICE TABLE
	  UMOVEM A,1		;return device designator to user
	ENDIF.
DVCHR1:	UMOVE A,1
	CALL CHKDEV
	 JRST [	CAIE A,DEVX2	; Was error due to unavailablity
		ITERR()		;NO, ABORT
		MOVE C,DEVCHR(B)
		TLZ C,(DV%AV)	;SAY NOT AVAILABLE
		JRST DVCHR4]
	TLO C,(DV%AV)
DVCHR4:	UMOVEM C,2
	BLCAL. DSKOK,<DEV>	;THIS A DSK?
	 SKIPA A,DEVUNT(B)	;NOT A DISK
	HLLO A,DEVUNT(B)	;A DISK, ALWAYS SAY -1 IN RH OF 3
	MOVEM A,DEVJOB		;Save it
	SKIPGE A		;Is device assigned to a job?
	IFSKP.			;Skip, Job index in LH(A)
	 HLRZ A,A		;Get job index only
	 CALL LCL2GL		;Convert it into a job number
	  SKIPA			;Not a real job number, so don't save it
	 HRLM A,DEVJOB		;Stuff job number where index was
	ENDIF.			;Resume main code
	MOVE A,DEVJOB		;Get the Job number,,unit number
	UMOVEM A,3
	HLRZ A,DEVUNT(B)	;YES, GET THE ASSIGNER
	TXNN C,DV%AV		;IS DEVICE UNAVAILABLE?
	CAIE A,-1		;YES, DO WE HAVE ASSIGNER?
	 MRETNG			;Available, or we have assigner
	HRRZ A,DEV		;FIND OUT WHAT DEVICE THIS IS
	CAIE A,TTYDTB		;IS THE UNAVAILABLE DEVICE A TTY?
	JRST DVCHR2		;NO
	HRRZ A,DEVUNT(B)	;NO ASSIGNER SO MUST BE UNAVAILABLE
	ANDI A,DV%UNT
	CAIN A,DV%UNT		;CHECK FOR -1
	MOVEI A,-1
	CALL TTYPTY		;ASSUME IT'S A PTY. GET PTY NUMBER
	HRLI A,<.DVDES+.DVPTY>	;MAKE IT A DEVICE DESIGNATOR
DVCHR3:	CALL CHKDES		;UNAVAILABLE.  GET INDEX FOR PTY
	 BUG.(CHK,DVCHRX,JSYSF,HARD,<DVCHR1 - Unexpected CHKDES failure within .DVCHR>,,<

Cause:	CHKDES failed to get the device code for a TTY or PTY after using
	either TTYPTY to convert a TTY number to a PTY number or PTYTTY to
	convert a PTY number to a TTY.

Action:	If this persists, use the DOB% facility to obtain a dump of this
	BUGCHK and submit an SPR.
>)
	MOVX A,DV%ASN		;COPY THIS BIT TO USER
	AND C,A			;ONLY THIS BIT
	XCTU [ANDCAM A,2]	;CLEAR FROM USER
	XCTU [IORM C,2]		;COPY
	MOVE A,DEVUNT(B)	;Get assigner of PTY.
	HLRZM A,DEVJOB		;Save it
	SKIPGE A		;See if it's a real job index
	IFSKP.			;Skipped, so there's a real job index
	 HLRZ A,A		;Move job index from LH to RH
	 CALL LCL2GL		;Convert Local job index into job number
	  SKIPA			;No such job, so don't save it
	 MOVEM A,DEVJOB		;Save the global job number
	ENDIF.			;Continue
	MOVE A,DEVJOB		;Get back the job number to return
	XCTU [HRLM A,C]		;RETURN IT TO USER.
	MRETNG
DVCHR2:	CAIE A,PTYDTB		;IS UNAVAILABLE DEVICE A PTY?
	JRST DVCHR5		;NO
	PUSH P,B		;YES. SAVE AC
	HRRZ B,DEVUNT(B)	;GET ITS UNIT #
	ANDI B,DV%UNT
	CAIN B,DV%UNT		;CHECK FOR -1
	MOVEI B,-1		;SET -1
	CALL PTYTTY		;CONVERT TERMINAL NUMBER
	MOVEI A,.TTDES(B)	;MAKE IT 400000+LINE NUMBER
	POP P,B			;RESTORE DEVICE TABLE POINTER
	JRST DVCHR3		;GET UNIT OF TTY TO RETURN TO USER

DVCHR5:	CAIE A,MTADTB		;IS THIS A MAGTAPE?
	 MRETNG			;No
	XCTU [HRRZS 3]		;YES, MAKE IT ASSIGNED TO JOB 0
	MRETNG
	SUBTTL ERSTR JSYS support

;ROUTINE TO OUTPUT A BYTE FROM ERSTR - COMPLETES QUIETLY IF
;ANY PROBLEMS

ERST9::	SKIPE C
	SOJLE C,CPOPJ
	CALL SAVAC
	UMOVE JFN,1
	CALL ERBOUT
	SOS -NSAC(P)
	TLNN JFN,-1		;BYTE POINTER?
	JRST ERST91		;NO
	UMOVEM JFN,1		;YES, RETURN UPDATED STRING POINTER
	MOVEI B,0		;AND APPEND A NULL
	XCTBU [IDPB B,JFN]
ERST91:	CALL RESAC
	RETSKP

ERBOUT:	TRVAR <SAVJFN,SAVBYT>	;RESERVE LOCS TO SAVE THINGS
ERBOU1:	MOVEM JFN,SAVJFN	;SAVE ORIGINAL JFN
	CALL CHKJFN
	RET
	JFCL
	 JFCL
	TQNE <ENDF>
	JRST UNLCKF
	TQNE <OPNF>
	TQNN <WRTF>
	JRST UNLCKF
	MOVEM B,SAVBYT		;SAVE THE BYTE
	CALL BYTOUA		;SEND OUT BYTE
	 JRST ERBOUW		;SERVICE ROUTINE WANTS TO BLOCK
	MOVE B,SAVBYT		;RESTORE BYTE
	CALL UNLCKF		;UNLOCK THE FILE
	RETSKP			;GIVE SUCCESSFUL RETURN

ERBOUW:	TQNE <ERRF>		;WAS IT AN ERROR?
	JRST [	MOVE B,SAVBYT	;YES. GET BACK BYTE
		CALLRET UNLCKF]	;AND DONE
	CALL UNLDIS		;UNLOCK AND BLOCK
	MOVE B,SAVBYT		;GET BACK BYTE
	JRST ERBOU1		;TRY AGAIN
	SUBTTL FFFFP JSYS

;FIND FIRST FREE FILE PAGE
; CALL:	A/PAGE #,, JFN
;	FFFFP
; Return
;	+1
;	A/JFN,,PAGE #
;		OR
;	A/-1 IF NO FREE PAGES

.FFFFP::MCENT
FFFF0:	HRRZ JFN,1		;MOVE JFN INT BASE REG
	CALL CHKJFN		;GO SEE IF IT'S A DISK FILE
	 RETERR()		;ERROR ("A" HAS THE CODE)
	 JFCL
	 RETERR(DESX4)		;TTY AND BYTE POINTER ARE NO GOOD
	TQNE <ASTF>		;PARSE ONLY?
	RETERR(DESX7)
	TQNN <OPNF>		;IS THE FILE OPEN?
	ERUNLK(FFUFX1)		;NOT OPEN
	BLCAL. DSKOK,<P3>	;DISK?
	 ERUNLK(FFUFX2)		;NO.
	TQNE <LONGF>		;IS IT A LONG FILE?
	JRST FFFFPL		;YES - SPECIAL HANDLING
	XCTU [	MOVS A,1]	;PUT INTO <JFN,,PAGE NUMBER>
	TRNE A,777000		;IS THIS A "LONG FILE" PAGE NUMBER
	JRST FFFFPX		;YES - THEN IT'S THE FIRST FREE PAGE
	HLL A,FILOFN(JFN)	;GET THE OFN. A1 NOW HAS OFN,,PAGE #
	CALL FFFFF		;FIND THE FIRST FREE PAGE
	 ERUNLK(MONX02)		;SYSTEM OUT OF JSB FREE SPACE
FFFFPX:	CAMN A,[-1]		;FREE PAGE NOT FOUND IN FILE
	HRRI A,1000		;YES - THEN PAGE IS IN "LONG FILE"
	XCTU [	HRL A,1]	;GET THE JFN INTO RIGHT HALF
FFFPX1:	UMOVEM A,1		;PUT FREE PAGE NUMBER IN USER AC
	CALL UNLCKF		;UNLOCK THE STRUCTURE
	JRST MRETN		;RETURN TO CALLER
;HERE TO SCAN A LONG FILE INDEX BLOCK.  THE BASIC PHILOSOPHY IS TO
;LOOK THROUGH THE SUPER INDEX BLOCK FOR VALID PAGE TABLE ENTRIES.  WHENEVER
;ONE IS FOUND SUBROUTINE FFFFF: IS CALLED TO  FIND A FREE PAGE IN
;THE PAGE TABLE. THE SEARCH CONTINUES TO FIRST FREE PAGE OR END OF FILE.

FFFFPL:	XCTU [	HLRZ Q1,1]	;GET PAGE NUMBER
FFFFP1:	MOVE Q3,Q1		; AND SAVE
	LSH Q3,-9		;GET THE PAGE TABLE NUMBER
	ADD Q3,FILLFW(JFN)	;INDEX INTO SUPER INDEX BLOCK
	HRRZS Q3		;ADDRESS ONLY
	MOVE A,Q1		;PUT PAGE NUMBER IN A FOR JUMP TO FFFFPX
	SKIPN (Q3)		;DOES PAGE TABLE EXIST
	JRST FFFFPX		;NO - THEN THIS IS THE PAGE
	CALL JFNOF3		;YES - GET <OFN,,PAGE NUMBER> INTO "A"
	 ERUNLK (MONX01)	;RETURN RESOURCES EXHAUSTED ERROR
	CALL FFFFF		;SCAN THE PAGE TABLE FOR A FREE ENTRY
	 ERUNLK (MONX02)	;NO JSB FREE SPACE
	CAMN A,[-1]		;WAS THE PAGE TABLE COMPLETELY FULL
	JRST FFFFP3		;YES - TRY NEXT PAGE TABLE
	ANDI Q1,777000		;ISOLATE SUPER INDEX BLOCK PAGE NUMBER
	ADD A,Q1		;ADD PAGE NUMBER OF FREE PAGE FOUND
	JRST FFFFPX		;AND REPORT TO USER

FFFFP3:	ADDI Q1,1000		;BUMP TO NEXT PAGE TABLE
	ANDCMI Q1,777		;ELIMINATE TEH REGULAR PAGE NUMBERS
	TLNN Q1,777777		;DID WE BUMP PAST END OF SUPER INDEX BLOCK
	JRST FFFFP1		;NO - KEEP LOOKING
	SETO A,			;;YES - NO FREE PAGES
	JRST FFFPX1		;JOIN COMMON EXIT
;ROUTINE TO MAP AND SCAN PAGE TABLE FOR FREE PAGE ENTRY - SUBROUTINE FOR .FFFFP

;ACCEPTS:	A/ <OFN,,PAGE NUMBER>

;RETURNS:	+1,NO FREE STORAGE
;		+2,	A/ -1 - NO FREE PAGE FOUND IN THIS PAGE TABLE
;			A/ <0,,PAGE NUMBER> IF FREE PAGE FOUND

;EXAMINE EACH ENTRY IN THE PAGE TABLE. IF THE ENTRY IS ZERO THEN THE PAGE IS
;FREE.  OTHERWISE CHECK FOR SHARED POINTER (THEY ALWAYS POINT TO EXISTING
;PAGES). IF SHARED GO TO NEXT  ENTRY.  IF IT'S INDIRECT CALL MRPACS: TO CHECK
;THE ENTRY OUT.  NOTE ENTRIES OF THE FORM 124001,,0 ARE ASSUMED TO POINT TO
;FREE PAGES.

FFFFF:	STKVAR <TEMPA,<TEMPB,2>>
	MOVEM A,TEMPA		;SAVE OFN,,PAGE NUMBER
	CALL ASGPAG		;GET A PAGE TO MAP THE PAGE TABLE INTO
	 RET			;NO MEMORY - RETURN AN ERROR
	MOVE B,A		;CREATE ENTRY FOR SETMPG
	HRLI B,100000		;WHERE WE WANT PAGE TO BE MAPPED
	HLRZ A,TEMPA		;JFN WHOSE TABLE WE WANT
	CALL SETMPG		;MAP THE PAGE TABLE
	HRRZ A,TEMPA		;GET STARTING PAGE NUMBER
	ADDI A,(B)		;LOCATION OF DISK ADDRESS
FFFFF0:	SKIPN (A)		;EMPTY?
	JRST FFFFF2		;YES, FOUND IT
	MOVE C,(A)		;GET THE PAGE POINTER
	CAMN C,[124001,,0]	;SPECIAL CASE INVALID PAGE POINTER?
	JRST FFFFF2		;YES - FOUND FREE PAGE
	LOAD C,PTRCOD,C		;GET THE POINTER TYPE CODE
	CAIE C,INDCOD		;IS IT AN INDIRECT POINTER?
	JRST FFFFF3		;NO - PAGE EXISTS - TRY NEXT PAGE
	DMOVEM A,TEMPB		;SAVE ACCROSS THE CALL
	MOVE A,TEMPA		;GET THE <OFN,,PAGE NUMBER>
	CALL MRPACS		;GET THE PAGE ACCESS BITS (LIKE RPACS JSYS)
	MOVE C,A		;MOVING "A" ALLOWS REGS TO BE RESTORED
	DMOVE A,TEMPB		;RESTORE THE REGS
	TXNN C,PA%PEX		;DOES THE PAGE EXIST
	JRST FFFFF2		;NO - THEN TELL CALLER
FFFFF3:	CAIGE A,777(B)		;WHOLE PAGE TABLE SCANNED?
	AOJA A,FFFFF0		;NO, TRY NEXT ONE.
	MOVEI A,0
	CALL SETMPG		;UNMAP THE PAGE TABLE
	HRRZ A,B
	CALL RELPAG		;RELEASE THE PAGE
	SETO A,			;INDICATE NO FREE PAGE FOUND IN PAGE TABLE
	RETSKP
FFFFF2:	MOVEM A,TEMPA		;SAVE
	MOVEI A,0
	CALL SETMPG		;UNMAP THE PAGE TABLE
	HRRZ A,B
	CALL RELPAG		;RELEASE THE PAGE
	MOVE A,TEMPA		;RESTORE A
	ANDI A,777		;KEEP ONLY THE PAGE NUMBER
	RETSKP
	SUBTTL FFUFP JSYS

; Find first used file page
; Call:	LH(1)	; Jfn
;	RH(1)	; Page number to start with
;	FFUFP
; Returns
;	+1	; Error
;	+2	; Success jfn.pn of first used page in 1

.FFUFP::MCENT
FFUF0:	HLRZ JFN,1
	CALL CHKJFN
	 RETERR()
	 JFCL
	 RETERR(DESX4)		; Tty and byte no good
	TQNE <ASTF>
	 RETERR(DESX7)
	TQNN <OPNF>
	ERUNLK(FFUFX1)		; Not open
	BLCAL. DSKOK,<P3>	;DISK?
	 ERUNLK(FFUFX2)		; Not disk
	TQNE <LONGF>
	JRST FFUFPL
	UMOVE A,1
	TRNE A,777000
	ERUNLK(FFUFX3)		; Page beyond 777 of short can't exist
	HLL A,FILOFN(JFN)
	CALL FFUFF
	 JRST [ CAIN A,MONX02	;[7196] Error, JSB full?
		ERUNLK(MONX02)	;[7196] Yes, return error code to caller
		ERUNLK(FFUFX3)]	;[7196] No pages in use error code
FFUFPX:	XCTU [HRRM A,1]
	CALL UNLCKF
	UMOVE A,A		;GET THE ARG BACK
	RPACS			;CHECK ACTUAL ACCESS
	 ERJMPR [RETERR ()]
	TLNE 2,(1B5)		;EXISTS?
	SMRETN			;YES, RETURN SUCCESS
	XCTU [AOS 1,1]		;NO, GO TO NEXT PAGE
	TRNE 1,777777		;OFF END OF WORLD?
	JRST FFUF0		;NO, TRY AGAIN
	RETERR(FFUFX3)
;FFUFP... EXTRA HAIR NEEDED FOR LONG FILE

FFUFPL:	UMOVE A,1
	HRRZS A
FFUFP1:	MOVE B,A
	LSH B,-9		; Get ptt number
	ADD B,FILLFW(JFN)
	HRRZS B			; ADDRESS ONLY
	SKIPE (B)		; Check for pt existence
	JRST FFUFP2		; Exists, scan it
FFUFP3:	ADDI A,1000
	ANDCMI A,777
	TLNN A,777777
	JRST FFUFP1
	ERUNLK(FFUFX3)

FFUFP2:	PUSH P,A
	CALL JFNOF1		; Get ofn.pn for this page
	 JRST [	POP P,A		;CLEAN UP THE STACK
		ERUNLK (MONX01)] ;RETURN RESOURCES EXHAUSTED ERROR
	CALL FFUFF		; Scan the pt for stuff
	 JRST [	MOVE B,A	;[7196] Something went wrong, save error
		POP P,A		;[7196] Fix the stack
		CAIN B,MONX02	;[7196] Was error jsb full?
		ERUNLK(MONX02)	;[7196] Yes
		JRST FFUFP3]
	POP P,B
	ANDI B,777000
	ADD A,B
	JRST FFUFPX		; Success
;ROUTINE TO MAP AND SCAN PT FOR NON-0 PAGE

FFUFF:	PUSH P,A
	CALL ASGPAG		; Get a page to map the pt
	 JRST [	POP P,A
		RETBAD (MONX02)] ;[7196] No JSB free space
	MOVE B,A
	HRLI B,100000
	HLRZ A,(P)
	CALL SETMPG		; Map the pt
	HRRZ A,(P)		; Get starting page number
	ADDI A,(B)		; Location of disc address
FFUFF0:	SKIPE (A)		; Empty?
	JRST FFUFF1		; No, found it
	CAIGE A,777(B)		; Whole pt scanned?
	AOJA A,FFUFF0		; No, try next one.
FFUFF2:	MOVEI A,0
	CALL SETMPG		; Unmap the pt
	HRRZ A,B
	CALL RELPAG		; Release the page
	POP P,A
	RET

FFUFF1:	ANDI A,777		; Get pn part
	MOVEM A,(P)
	AOS -1(P)		; Skip return
	JRST FFUFF2
	SUBTTL GACTF JSYS

; Get account of file
; Call:	1	; Jfn
;	2	; Core location to put string if any
;	GACTF
; Return
;	+1	; Error
;	+2
;	+3	; 5B2+number oR string pointer

.GACTF::MCENT
	UMOVE JFN,1		;GET JFN
	CALL DSKJFN		;GRNTEE DISK JFN
	 RETERR ()
	CALL GETFDB
	 ERUNLK(GACTX2)
	LOAD B,FBACT,(A)	;GET THE ACCOUNT
	JUMPG B,GACTF1		;IS THIS A STRING?
	UMOVEM B,2		;NO
	ULKDIR
	CALL UNLCKF
	AOS -1(P)		;DOUBLE SKIPPER
	SMRETN			;...

GACTF1:	ADD B,DIRORA		;GET ABS ADR OF STRING
	LOAD A,ACTYP,(B)	;CHECK THE CONSISTENCY OF DIR
	CAIE A,.TYACT		;IS THIS AN ACCOUNT STRING BLOCK
	ERUNLK(GACTX3,<ULKDIR>)	;NO, BAD BLOCK TYPE IN DIR
	CALL CPYXL		;COPY STRING TO USER SPACE
	SMRETN			;GOOD RETURN

;COPY ACCOUNT/USER NAME BLOCK TO USER
; T2/ POINTER TO BLOCK

CPYXL:	UMOVE T4,2		;USERS POINTER IN 2
	TLC T4,-1		;CHECK FOR SPECIAL PNTR
	TLCN T4,-1
	HRLI T4,(<POINT 7,0>)	;FORM BYTE PNTR
	MOVE T3,[POINT 7,2(2)]	;POINT TO TEXT IN BLOCK
CPYXL1:	ILDB T1,T3		;GET CHAR
	JUMPE T1,CPYXL2		;DONE IF ZERO
	XCTBU [IDPB T1,T4]	;DEPOSIT IN USER SPACE
	JRST CPYXL1		;LOOP BACK FOR NEXT
CPYXL2:	UMOVEM T4,2		;UPDATE USER POINTER
	XCTBU [IDPB T1,T4]	;DEPOSIT NULL
	ULKDIR			;UNLOCK DIRECTORY
	CALLRET UNLCKF		; AND JFN THEN RETURN
	SUBTTL GDSTS JSYS

; Get device status
; Call:	1	; Jfn
;	GDSTS
; Returns
;	+1	; Error
;	+2	; Ok

.GDSTS::MCENT
GDSTS1:	XCTU [HRRZ JFN,1]	;GET JFN
	CALL CHKJFN
	 ITERR()
	 SKIPA			;ALLOW TTY JFNS
	 ITERR(DESX4)
	MOVE A,STS
	ANDI A,17
	TQZE <BLKF>		;BLKF MUST BE ZERO BEFORE CALL
	BUG.(CHK,BLKF4,JSYSF,HARD,<.GDSTS - BLKF set before call to device routine>,,<

Cause:	The bit indicating that a device routine wishes to block has been
	set before the call to the device routine has been made. This bit
	must be set to zero before the call so we do not block needlessly
	(maybe never to wake up).

Action:	The bit is being cleared. If this problem persists, change the
	BUGCHK to a BUGHLT and find out where BLKF is being set.
>)
	TQNE <OPNF>		;DEVICE MUST BE OPENED TO GET STATUS
	CALL @GDSTD(P3)
	TQZE <BLKF>		;ROUTINE WANT TO BLOCK?
	JRST GDSTSW		;YES, GO WAIT
	UMOVEM A,2
	JRST UNL

GDSTSW:	CALL UNLDIS		;GO UNLOCK AND DISMIS
	JRST GDSTS1		;TRY AGAIN
	SUBTTL GFUST JSYS

; GET FILE USER STRING
;
; CALL:	1/ FUNCTION ,, JFN
;	2/ DESTINATION POINTER
;		GFUST
; RETURNS: +1 ALWAYS, DESTINATION POINTER UPDATED

.GFUST::MCENT			;MONITOR CONTEXT ENTRY
	STKVAR <GFUFDA,GFUBLK,GFUERR>

; CHECK FUNCTION CODE

	XCTU [HLRZ T3,1]	;GET FUNCTION CODE FROM USER
	CAIE T3,.GFAUT		;IS FUNCTION "GET AUTHOR" ?
	CAIN T3,.GFLWR		;  OR "GET LAST WRITER" ?
	SKIPA			;YES, EVERYTHING KOSHER
	ITERR (GFUSX1)		;NO, REFUSE TO PROVIDE FURTHER SERVICE

; GET DIRECTORY NUMBERS FROM FDB AND OBTAIN SPACE FOR STRING

	XCTU [HRRZ JFN,1]	;GET JFN FROM USER
	CALL DSKJFN		;GRNTEE JFN ON DISK
	 ITERR ()
	CALL GETFDB		;GET FDB ADRS
	 ITERR (GFUSX3,<CALL UNLCKF>)
	MOVEM T1,GFUFDA		;SAVE FOR LATER
	LOAD T2,FBVER,(T1)	;GET FDB VERSION
	CAIGE T2,1		;VER #1 OR LATER?
	JRST GFUS10		;VERSION #0 SPECIAL
	XCTU [HLRZ T3,1]	;GET FCN AGAIN
	LOAD T2,FBAUT,(T1)	;ASSUME AUTHOR
	CAIE T3,.GFAUT		;WAS IT
	LOAD T2,FBLWR,(T1)	;NO - GET LAST WRITE
	JUMPE T2,[MOVEI T2,[EXP 0,0,0] ;DUMMY BLOCK IF NONE
		  JRST GFUS05]	;RETURN USER A NULL
	ADD T2,DIRORA		;RELOCATE POINTER
	LOAD T1,UNTYP,(T2)	;GET TYPE FIELD
	CAIE T1,.TYUNS		;USER NAME STRING?
	ITERR (GFUSX4,<CALL USTDIR
			CALL UNLCKF>) ;SOMETHING WRONG
GFUS05:	CALL CPYXL		;COPY STRING TO USER SPACE
	JRST MRETN		;RETURN
GFUS10:	MOVEI T2,MAXLW+1	;GET LENGTH OF BLOCK REQUIRED
	CALL ASGJFR		;ASSIGN JSB FREE SPACE FOR STRING
	 ITERR (GFUSX2,<CALL UNLCKF
			CALL USTDIR>)	;NO ROOM IN JSB
	MOVEM T1,GFUBLK		;SAVE ADDRESS OF BLOCK ASSIGNED

; TRANSLATE REQUESTED DIRECTORY NUMBER TO STRING

	HRROI T1,1(T1)		;FORM POINTER TO WHERE STRING SHOULD GO
	SETZM (T1)		;FORM NULL STRING TO BE RETURNED IN THE CASE
				; THE AUTHOR/LAST-WRITER DOES NOT EXIST
	XCTU [HLRZ T3,1]	;GET FUNCTION CODE FROM USER AGAIN
	MOVE T4,GFUFDA		;GET FDB ADDRESS
	LOAD T2,FBAT0,(T4)	;ASSUME AUTHOR STRING DESIRED
	CAIE T3,.GFAUT		;WAS AUTHOR REQUESTED ?
	LOAD T2,FBLW0,(T4)	;NO - GET LAST-WRITER INSTEAD
	ULKDIR			;UNLOCK DIRECTORY
	CALL UNLCKF		;UNLOCK JFN
	JUMPE T2,GFUS20		;NO AUTHOR/LAST-WRITER EXISTS, RETURN A NULL
	HRLI T2,USRLH		;ASSUME THE PUBLIC STRUCTURE
	DIRST			;TRANSLATE TO STRING
	 JRST [	CAIE T1,STRX06	;NO SUCH USER #
		CAIN T1,DIRX1	; OR INVALID DIRECTORY NUMBER ?
		JRST GFUS20	;YES, RETURN A NULL
		MOVEM T1,GFUERR	;FAILED, SAVE ERROR CODE
		MOVEI T1,JSBFRE	;GET FREE HEADER
		MOVE T2,GFUBLK	;GET ADDRESS OF BLOCK
		CALL RELFRE	;RELEASE SPACE FOR STRING
		OKINT		;PERMIT INTERRUPTS AGAIN
		MOVE T1,GFUERR	;RETRIEVE ERROR CODE
		ITERR ()]	;GIVE ERROR NOTICE TO USER
GFUS20:	UMOVE T1,2		;GET DESTINATION POINTER
	MOVE T2,GFUBLK		;GET ADDRESS OF BLOCK CONTAINING STRING
	CALL CPYTUS		;RETURN STRING TO USER
	MOVEI T1,JSBFRE		;GET FREE HEADER
	MOVE T2,GFUBLK		;GET ADDRESS OF BLOCK
	CALL RELFRE		;RELEASE SPACE USED TO HOLD STRING
	OKINT			;PERMIT INTERRUPTS AGAIN
	JRST MRETN		;GIVE USER SUCCESS RETURN
	SUBTTL GTFDB JSYS

;GTFDB - RETURNS WORDS FROM A FILE'S FDB
;CALL:	1/	JFN
;	2/	LH: NUMBER OF WORDS TO READ, RH: OFFSET OF FIRST WORD
;	3/	LOCATION TO STORE WORDS
;
;RETURNS +1 IF SUCCESSFUL, ITRAPS ON ERRORS.
;IF THE FDB IS SHORTER THAN THE MAXIMUM SIZE OF AN FDB, ZERO WORDS
;ARE RETURNED FOR THE WORDS OFF THE END OF THE FDB.

.GTFDB::MCENT			;JSYS ENTRY
	STKVAR <GTFADR,GTFBEG,GTFEND,GTFZER>	;ALLOCATE VARIABLES
	MOVEM T3,GTFADR		;REMEMBER ADDRESS TO STORE DATA INTO
	HRRZM T2,GTFBEG		;SAVE BEGINNING OFFSET INTO FDB
	HLRZ T4,T2		;GET WORD COUNT BY ITSELF
	MOVE T1,GTFBEG		;GET BEGINNING OFFSET
	CAIL T1,.FBLEN		;MAKE SURE IT ISN'T TOO LARGE
	 ITERR(GFDBX1)		;YES, ERROR
	ADDI T1,-1(T4)		;COMPUTE LARGEST FDB ENTRY WANTED
	SKIPE T4		;MAKE SURE COUNT IS POSITIVE
	CAIL T1,.FBLEN		;AND OFFSET NOT TOO LARGE
	 ITERR(GFDBX2)		;NO, ERROR
	MOVEM T1,GTFEND		;SAVE ENDING OFFSET
	MOVE T1,GTFADR		;GET ADDRESS OF USER'S BLOCK
	XCTU [MOVES 0(T1)]	;MAKE SURE IT IS WRITABLE
	ADDI T1,-1(T4)		;GET ADDRESS OF END OF BLOCK
	XCTU [MOVES 0(T1)]	;MAKE SURE IT IS WRITABLE TOO
	UMOVE JFN,1		;GET JFN
	CALL CHKFIL		;MAKE SURE IT IS A FILE
	 ITERR()		;ILLEGAL
	TQNE <ASTF>		;SEE IF PARSE ONLY
	ITERR(DESX7,<CALL UNLCKF>)	;YES, ERROR
	BLCAL. DSKOK,<P3>	;DISK?
	 ITERR(GFDBX1,<CALL UNLCKF>)	;IF NOT, NOT LEGAL FOR THIS DEVICE
	LOAD A,STR,(JFN)	;[7.1063]Get structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is structure offline?
	 ITERR(,<CALL UNLCKF>)	;[7.1063]Return "Structure is offline"
	CALL GETFDB		;GET POINTER TO THE FDB
	 ITERR(DESX3,<CALL UNLCKF>)	;FAILED
	MOVE T2,T1		;PUT FDB ADDRESS IN RIGHT AC
	LOAD T1,FBLEN,(T1)	;GET FIRST ILLEGAL OFFSET FOR THIS FDB
	MOVEM T1,GTFZER		;REMEMBER WHERE WE HAVE TO ZERO LATER
	MOVE T1,GTFEND		;GET LAST WORD WANTED OF FDB
	CAML T1,GTFZER		;WANTS DATA OFF OF THE END OF THE FDB?
	SOS T1,GTFZER		;YES, LIMIT IT TO LAST LEGAL WORD
	SUB T1,GTFBEG		;COMPUTE DIFFERENCE BETWEEN START AND END
	AOJLE T1,GTFD2		;CREATE NUMBER OF WORDS AND SKIP IF NONE
	ADD T2,GTFBEG		;ADD OFFSET TO FDB ADDRESS
	MOVE T3,GTFADR		;GET ADDRESS TO BLT TO
	CALL BLTMU1		;COPY SOME OF THE FDB TO THE USER
GTFD2:	CALL USTDIR		;UNLOCK THE DIRECTORY
	CALL UNLCKF		;AND THE JFN
				; ..

;NOW ZERO WORDS WHICH THIS FDB WAS NOT LONG ENOUGH TO CONTAIN.

GTFDB3:	AOS T1,GTFZER		;ADVANCE TO NEXT WORD
	CAMLE T1,GTFEND		;WANTS ANOTHER WORD OFF END OF FDB?
	MRETNG			;NO, ALL DONE
	SUB T1,GTFBEG		;YES, COMPUTE OFFSET IN USERS BLOCK
	JUMPL T1,GTFDB3		;NOT UP TO BLOCK YET, GO ON
	ADD T1,GTFADR		;ADD ADDRESS OF BLOCK
	XCTU [SETZM 0(T1)]	;CLEAR THE WORD
	JRST GTFDB3		;CONTINUE
	SUBTTL GTSTS JSYS

; Get open file status
; Call:	1	; Jfn
;	GTSTS
; Return
;	+1
;	2	; Status word as in filsts

.GTSTS:: MCENT
	UMOVE JFN,1		;FETCH THE USER'S JFN
	CALL CHKJFD		;CHECK IT OUT, GET FILSTS TO STS
	 JRST GTSTS1		;ILLEGAL, RETURN ZERO
	 JFCL			;TTY, SAME AS
	 SETZM STS		;BYTE POINTER, RETURN ZERO
	CALL UNLCKF		;DON'T NEED THE FILE ANY MORE
	TXNN STS,NAMEF		;JFN ASSIGNED?
GTSTS1:	SETZM STS		; NO, BE SURE ALL OTHER BITS CLEAR TOO
	ANDX STS,DOCSTS		;KEEP JUST THE DOCUMENTED BITS
	UMOVEM STS,2		;RETURN THEM TO THE USER
	MRETNG			;AND DONE
	SUBTTL INIDR JSYS

; Initialize directory
; Call:	1	; Device designator
;	INIDR
; Return
;	+1	; Error
;	+2	; Ok

.INIDR::MCENT
	TLO A,(1B3)		;SAY MOUNT WITHOUT READING DIRECTORY
	MOUNT			;MAKE SURE FRESHLY MOUNTED
	 RETERR()		;COULDN'T MOUNT
	UMOVE A,1		;GET DEVICE DESIGNATOR
	CALL CHKDEV
	 RETERR()
	HRRZ P3,DEV		;SET UP ADDRESS ONLY
	TLNN C,(1B8)
	RETERR(DEVX3)		; Not mounted
	CALL @INDD(P3)
	 RETERR()		;FAILED
	SMRETN
	SUBTTL JFNS JSYS

; Convert JFN to string
; Call:	1	; Destination designator for ASCIZ filespec string
;	2	; Indexable file handle or pointer to string to return
;	3	; Format specification (see JSYS manual), default format if 0
;	4	; Pointer to attribute string (see JSYS manual)

;[9077] This edit makes a number of changes in the JFNS% JSYS.  Work was done
;in earlier edits (including [8820], [8829], and [9073]) to prevent various
;monitor crashes when multiple forks are diddling JFNs; in addition to that
;this edit continues to repair ugly bugs in code not used often, reduce
;maintenance worries (those strange PUSHes, POPs, and gark like ADD P,[5,,5] to
;get a STKVARish place to write a string), reduce the number of unlocks and
;relocks done by the old code, minimize the runtime when we have the locks and
;reduce JFNS% JSYS runtime for users.  All of these goals have been
;accomplished with this edit.  Here is the new JFNS flow:

;If JS%PTR is not set in user AC2, then T2 is a JFN.  JFNS goes NOINT, gets
;freespace, gets the FILLCK and checks the JFN, getting JFNLCK.  Getting all of
;these locks in this order prevents problems with other forks playing GNJFN or
;CLOSF games.  JFNS extracts all information about the JFN with these locks and
;copies a string to JSB free space.  If the JFN it turns out to be a disk JFN,
;JFNS calls GETFDB (which locks the directory and goes CSKED).  This is all
;done with local routines to copy strings and ASCIIfy numbers so that no deadly
;embrace can occur from BOUTA's use of BOUT (or anything which would require
;the JFNLCK and/or FILLCK).  After information is retrieved from the FDB, we
;unlock the directory and go ECSKED.  After all of the information is extracted
;from the JFN we release the JFNLCK and FILLCK.

;Then and only then the information is returned to the user with BOUTA (who may
;get FILLCK for a JFN with BOUT%).  This scheme prevents deadly embraces or
;page faults when holding the locks, insures complete and ungarbled data, and
;minimizes execution time with the locks on.

;After the string is sent to the user, we release the freespace and go OKINT.
;The file size and dates associated with a disk JFN are remembered in the TRVAR
;and returned after we go OKINT so that in the rare case that any of the JS%SIZ
;or JS%CDR or JS%LWR or JS%LRD bits are set ODTIM can be used OKINT at the end
;of the call (since it calls NOUTXX and BOUTA which we can't use with the locks
;on).

;If JS%PTR is set then T2 is a byte pointer and no locking of any type is done.
;No freespace is purchased either since we won't need it, and we want to run
;fast since the task is so simple.  Since only user supplied (in T2 and T4)
;strings are returned back to the user's destination pointer in T1, the monitor
;provides only punctuation along with a BOUT string copy loop.
;JFNS uses Q1 as a local flag register

MSKSTR JS%T1,Q1,1B0		;JFNS Local flag - punctuate null extension
MSKSTR JS%T2,Q1,1B1		;JFNS Local flag - multiple dir dev
MSKSTR JS%T3,Q1,1B2		;JFNS Local flag - suppressing leading tab

;The following is the default bits used it AC3/0 on a JFNS call.

JFSDEF==JS%NOD!FLD(.JSSSD,JS%DVN)!FLD(.JSSSD,JS%DIR)!FLD(.JSAOF,JS%NAM)!
FLD(.JSAOF,JS%TYP)!FLD(.JSSSD,JS%GEN)!JS%ATR!JS%PSD!JS%PAF ;[9077]

.JFNS::	MCENT
	TRVAR <JFSADR,JFSPTR,JFSCNT,JFSREF,JFSWRT,JFSCRV,JFSSIZ> ;[9081][9077]
	SETZM JFSADR		;[9077] We have no freespace yet
	SETZ Q1,		;[9077] Initialize tab flag

	XCTU [SKIPN Q3,3]	;[9077] Load format bits, skip if some are set
	MOVX Q3,JFSDEF		;[9077] Load default bits

	TXNE Q3,JS%PTR		;[9077] Is AC2 JFN or string pointer?
	JRST JFNX0		;[9077] String pointer, handle it

;Fall through if AC2 is supposed to have a real JFN and not a string pointer.
	SUBTTL JFNS JSYS -- JFN Supplied

;[9077] Here if a "real" JFNS, Check the JFN furnished in AC2.

	NOINT			;[9077] No interruptions please
	LOCK JFNLCK		;[9077] Get JFN lock

	XCTU [HRRZ JFN,2]	;[9077] Load user's JFN (leaving flags)
	CALL CHKJFD		;[9077] (JFN/DEV,P3,JFN,STS) Check the JFN
	 ITERR (,<CALL JFNSRJ>) ;[9077] (/) Unlock JFNLCK, OKINT, so forth
	 JFCL			;[9077] TTY furnished, this is illegal
	 ITERR (DESX4,<CALL JFNSRJ>) ;[9077] (/) String is illegal 
	DMOVE T1,FILSTS(JFN)	;[9077] Real JFN, get file status words
	TXNE T1,ASGF		;[9077] JFN being assigned?
	TXNN T2,ASGF2		;[9077] Make sure ASGF and not BLKF
	CAIA			;[9077] Must be BLKF or not assigning
	ITERR (DESX3,<CALL JFNSRF>) ;[9077] (/) Act like JFN not assigned
	XCTU [HLLZ F1,2]	;[9077] Load flags from user's JFN

;[9077] The following code (creation of copy on write) is no longer needed
;since we don't have the locks and we are OKINT when we send the string to the
;user.

REPEAT 0,<			;[9077] No longer needed 
	UMOVE A,1		;Retrieve user's destination designator
	TLNN A,777777		;See if in -1,,xxx form
	JRST JFNSZX		;Not byte pointer
	TLC A,777777		;It is a byte pointer,
	TLCN A,777777		;So make 7-bit byte pointer
	HRLI A,440700		;-1 in lh, fill in
	SETZ B,			;Load a null for later
	UMOVEM A,1		;Return byte pointer to user
	CSKED			;[8820] Be critical
	UNLOCK JFNLCK		;[8820] Give up JFNLCK briefly
	UNLOCK FILLCK(JFN)	;[8829] And file lock
	XCTBU [IDPB B,A]	;Deposit initial null in case
	ECSKED			;[8820] Not critical anymore
	LOCK JFNLCK		;[8820] Hopefully get this back without changes
	LOCK FILLCK(JFN)	;[8829] Get back the file lock
JFNSZX:>			;[9077] End of repeat 0

;[9077] Get some free space.
;	2+39:2+<39*2>2+39*2.2+39*2.2+6+2;T+2;A39+2;P6+2;OFFLINE+2+6;attr:value

JFNSF:	MOVEI T2,1+<MAXLW*9>	;[9077] Try and get this much, one for header
	CALL ASGJFR		;[9077] (T2/T1) Get space for our use
	 ITERR (MONX02,<CALL JFNSRF>) ;[9077] (/) Owie, return JSB full error

	MOVEM T1,JFSADR		;[9077] Save the address of the free space
	CALL JFNSNB		;[9077] (/) New buffer available now
	;..
	SUBTTL JFNS JSYS -- JFN Supplied -- Copy Filename

JFNSZ:	LOAD T1,FLNOD,(JFN)	;See if a node specified in this JFN
        IFN. T1			;If a node specified

;Do node and device field when node is present in file spec.

	  TQO <JS%T1,JS%T2>	;[9077] Puncuate null ext and multiple dir dev

	  LOAD T4,JS%NOD,Q3	;[9077] Load device control bit
	  IFN. T4		;[9077] If output desired
            CALL TAB4		;(T4,Q3/) Begin node field
            CALL JFNSSS		;[9077] (T1/) Print node name
            MOVEI T2,PNCNOD	;Load node punctuation
            CALL PUNCT		;(T2,Q3/) Print first one
	    CALL PUNCT		;(T2,Q3/)  and second one
	  ENDIF.		;End of node output code

	  LOAD T4,JS%DVN,Q3	;[9077] Load format bits for device (2 bits)
	  IFN. T4		;[9077] If nonzero print device name
	    CALL TAB4		;[9077] (T4,Q3/) Output tab if needed
            HLRZ T1,FILDDN(JFN)	;Get the device name string to print
            CALL JFNSSS		;(T1/) Output device name
            MOVEI T2,":"	;Load device punctuation
            CALL PUNCT		;(T2,Q3/) Send punctuation if needed
	  ENDIF.		;End of device output code
        ELSE.			;End of "this JFN had a node spec" code
	;...
;Do device field when no node is present in file spec.

          HLRZ T1,FILDDN(JFN)	;Get the
          MOVN T2,(T1)		; address-1 of the
          HRLI T1,-2(T2)	;  device name
          CALL DEVLUX		;(T1/T1,T2,T3) Lookup the device
           SETZ T1,		;Device not found
          MOVE T3,DEVUNT(T2)	;Get pseudo-device flag
          CAME T3,[-1]		;No units?
          TXNN T3,DV%PSD	;Pseudo-device always punctuates
          TXNE T1,DV%DIR	;[9086] Directory device?
          TQOA JS%T1		;Punctuate null extension
          TQZ JS%T1		;Do not punctuate null extension
          TQNE <ASTF>		;Parse-only?
          TQO JS%T1		;Yes, always punctuate extension
	  CAME T3,[-1]		;No units?
	  TXNN T3,DV%PSD	;Pseudo-device?
	  TXNE T1,DV%MDD	;Multiple directory device?
	  TQOA JS%T2		;Yes, multiple directory device
	  TQZ JS%T2		;No, not a multiple directory device
          CALL GTCSCD		;(/T1) Get the structure unique code
          HLRZ T3,T1		; of the current connected structure

	  LOAD T4,JS%DVN,Q3	;[9077] Get format control byte for device
          JUMPE T4,JFNS0	;[9077] Go on if no print wanted
          CALL TAB4		;[9077] (T4,Q3/) Tab if needed
          TQNE <STRSF>		;Wild device (file structure)?
          IFSKP.		;No
            LOAD T1,FLUC,(JFN)	;[9077] Get the unique code of the device
            CAIN T4,.JSSSD	;[9077] If it is suppress system default
            CAME T1,T3		;[9077]  and is the device the connected str?
            IFSKP. <JRST JFNS0>	;[9077] Yes, don't print it
            HLRZ T1,FILDDN(JFN)	;[9077] Get the device name string to print
            CALL JFNSSS		;[9077] (T1/) Output device name
          ELSE.			;It was a wild device
            MOVEI T1,[ASCIZ/DSK*/]-1 ;[9077] Point to wild name
            CALL JFNSST		;[9077] (T1/) Output wild device
          ENDIF.		;Device has been output
	  MOVEI T2,":"		;Load punctuation for device
	  CALL PUNCT		;(T2,Q3/) Print device punctuation if needed
        ENDIF.			;End of device output code
	; ..
;Do directory field

JFNS0:	LOAD T4,JS%DIR,Q3	;[9077] Load directory format control
	JUMPE T4,JFNS1		;[9077] Jump if no desired output
	TQNN <DIRSF>		;[9077] Wild directory?
	CAIE T4,.JSSSD		;[9077] Suppressing if default?
	JRST JFNS0A		;[9077] Wild or output always, do it
	LOAD T1,JSCDF		;Connected directory string valid flag
	SKIPN T1		;Skip if string exists in JSB
	CALL JFNSCD		;No, try to set one up
	JE JSCDF,,JFNS0A	;If no valid name string in JSB, print always
	LOAD T1,JSCDS		;Get adr of connected dir string
	HRLI T1,(POINT 7,0,35)	;Point to it
	LOAD T2,FLDIR,(JFN) 	;Get adr of dir name string
	JUMPE T2,JFNS1		;If no directory name, don't output anything
	HRLI T2,(POINT 7,0,35)	;Point to directory name
	CALL STRCMP		;(T1,T1/T1) Compare the strings
	 SKIPA			;The strings dont match, go output dir
	JRST JFNS1		;They match, do not output the directory name
	LOAD T4,JS%DIR,Q3	;[9077] Reload format bits smashed by STRCMP

;Here when it has been decided that a directory name has to be revealed.

JFNS0A:	CALL TAB4		;(T4,Q3/) Tab before field if desired
	LOAD T2,FLDIR,(JFN)	;Get pointer to directory string
	TQNN <DIRSF>		;If stars, return the wild string
	JUMPE T2,JFNS1		;If none, don't try to output it
	MOVEI T2,"<"		;Load left bracket
	CALL PUNCT		;(T2,Q3/) Print punctuation if desired
	TQNN <DIRSF>		;Directory wild?
	IFSKP.			;If so,
	  LOAD T1,FLDMS,(JFN)	;[9077] Get wild mask
	  CALL JFNSST		;[9077] (T1/) Go send it or a star
	ELSE.			;[9077] Not wild directory
	  LOAD T1,FLDIR,(JFN)	;Get pointer to directory string
	  CALL JFNSDS		;[9077] (T1/) Copy directory string
	ENDIF.			;[9077] Directory output done
	MOVEI T2,">"		;Load closing punctuation
	CALL PUNCT		;(T2,Q3/) and output it if desired
;Do file name field next, note that file name is output if JS%NAM non-zero.

JFNS1:	LOAD T4,JS%NAM,Q3	;[9077] Load output control for name
	JUMPE T4,JFNS2		;[9077] Jump if no print wanted
	CALL TAB4		;(T4,Q3/) Tab before field if required
	TQNN <NAMSF>		;Star in name field?
	IFSKP.			;Wild file name
	  LOAD T1,FLNMS,(JFN) 	;[9077] Get name wild mask
	  CALL JFNSST		;[9077] (T1/) Print it or a star
	ELSE.			;[9077] Name is not wild
	  HLRZ T1,FILNEN(JFN)	;[9077] Get location of file name block
	  CALL JFNSSS		;[9077] (T1/) Copy filename string
	ENDIF.			;[9077] End of name output

;Do extension field, dot is printed only if ext string exists or JS%T1 set.

JFNS2:	LOAD T4,JS%TYP,Q3	;[9077] Load output control
	JUMPE T4,JFNS3		;[7276] No print wanted
	CALL TAB4		;(T4,Q3/) Tab before field if required
	MOVEI T2,"."		;Load punctuation between file and type
	HRRZ T1,FILNEN(JFN)	;[9077] Get location of extension block
	MOVE T3,1(T1)		;See if there is an extension string
	TLNN T3,774000		;If non-null string, type out punctuation
	TQNE JS%T1		;If punctuation always desired, output it too
	CALL PUNCT		;(T2,Q3/) Output punctuation if desired
	TQNN <EXTSF>		;Extension wild?
	IFSKP.			;If so,
	  LOAD T1,FLEMS,(JFN) 	;[9077] Get extension wild mask
	  CALL JFNSST		;[9077] (T1/) Print it or a star
	ELSE.			;[9077] Not wild
	  HRRZ T1,FILNEN(JFN)	;[9077] Get location of extension block
	  CALL JFNSSS		;[9077] (T1/) Output extension
	ENDIF.			;[9077] End of extension output
;Do version, note special cases of 0, -1, -2, and *.

JFNS3:	LOAD T4,JS%GEN,Q3	;[9077] Load version number output control
	JUMPE T4,JFNS4		;[9077] Jump if no print wanted
	CALL TAB4		;(T4,Q3/) Tab before field if required
	HRRE T1,FILVER(JFN)	;[9081] Get version number
	TQNN <ASTF>		;Parse only?
	IFSKP.			;Yes
	  JUMPN T1,DOJF3	;Do version only if non-zero
	  TXNE F1,VERSF!RVERF!HVERF!LVERF ;Any special version flags?
	  JRST DOJF3		;Yes, do them
	ENDIF.			;Not parse only
	TQNN JS%T2		;Multiple directory device?
	JRST JFNS4		;Nope, no version output

DOJF3:	MOVEI T2,PNCVER		;Load punctuation for version
	CALL PUNCT		;(T2,Q3/) Output it
	MOVE T2,T1		;[9077] Copy version
	TQNN <VERSF>		;Is version wild?
	IFSKP.			;Yes
	  CALL JFNSTR		;(/) Output asterisk
	  CALL JFNSRS		;[9077] (/) Return the string we built
	  MRETNG		;All done, nothing more can be returned
	ENDIF.			;Version not wild
	TQNE <RVERF>		;Is version zero?
	MOVNI B,0		;Yes, load zero
	TQNE <HVERF>		;Is version -1 (highest)?
	MOVNI B,1		;Yes, load -1
	TQNE <LVERF>		;Is version -2 (lowest)?
	MOVNI B,2		;Yes, load -2
	CALL JFNSND		;[9077] (T2/) Output decimal generation number
	; ..
	SUBTTL JFNS JSYS -- JFN Supplied -- FDB Items of Disk JFN

;[9077] Filespec done, go to special routine if JFN is parse only.

JFNS4:	TQNE <ASTF>		;[9077] Parse only?
	JRST JFNSPO		;[9077] Yes, handle special

;[9081] Go off to handle non-disk JFNs too.

	BLCAL. DSKOK,<P3>	;[9081] Is this a disk JFN?
	 JRST JFNSNJ		;[9081] Not a disk JFN

;[9081] Try to get the FDB for this disk JFN, if none handle like non-disk JFN.
;If no further output is desired, we also handle this like a non-disk JFN.

	TXNE Q3,JS%PRO!JS%ACT!JS%TMP!JS%OFL!JS%SIZ!JS%CDR!JS%LWR!JS%LRD	;[9081]
	CALL GETFDB		;(/T2) Get a pointer to the FDB
	 JRST JFNSEJ		;[9081] No FDB, or simple case, get out now
	MOVE Q2,T1		;[9077] Copy pointer to FDB

;[9077] Do protection next (still with directory mapped and CSKED).

JFNS4P:	LOAD T4,JS%PRO,Q3	;[9077] Load format bits for protection
	JUMPE T4,JFNS5		;[9077] Jump if no output to do
	CALL TAB4		;[9077] (T4,Q3/) Perhaps a tab needed
	MOVE T1,.FBPRT(Q2)	;[9077] Load protection from the FDB
	CAIE T4,.JSSSD		;[9077] Output only if not default?
	IFSKP.			;[9077] Yes output only if not default
	  MOVE T3,DIRORA	;[9077] Load location of mapped directory
	  LOAD T3,DRDPW,(T3)	;[9077] Get default protection word
	  CAMN T1,T3		;[9077] Protection same as default one?
	  JRST JFNS5		;[9077] Do not output the protection
	ENDIF.			;[9077] End of protection output checks
	TXNE Q3,JS%PRO		;[9077] Output protection?
	CALL JFNSP		;[9077] (T1/) Yes, output protection
;[9077] Do ;Aaccount (still with directory mapped and CSKED).

JFNS5:	LOAD T4,JS%ACT,Q3	;[9077] Load output bits for account
	JUMPE T4,JFNS6		;[9077] Jump if no field to output
	CALL TAB4		;[9077] (T4,Q3/) Output tab if needed
	SKIPE T2,.FBACT(Q2)	;[9077] Load account
	CAIE T4,.JSSSD		;[9077] Suppress if default?
	IFSKP.			;[9077] Check account string for output
	  TXNE T2,7B2		;[9077] Is this a numeric account?
	  IFSKP.		;[9077] Nope
	    ADD T2,DIRORA	;[9077] Get address of string
	    XMOVEI T2,.ACVAL(T2) ;[9077] Get address of ASCIZ string
	    TXO T2,<OWGP. 7>	;[9077] Make it a one word gloal pointer
	    MOVE T1,[POINT 7,ACCTSR] ;[9077] Point to account string
	    CALL STRCMP		;[9077] (T1,T2/T1) See if strings equal
	     CAIA		;[9077] Nope, print it
	    JRST JFNS6		;[9077] Yes, do not print it
	  ENDIF.		;[9077] End of account string match check
	ENDIF.			;[9077] End of account string output check
	MOVEI T2,PNCATT		;[9077] Load punctuation for account
	CALL PUNCT		;[9077] (T2,Q3/) Send it
	MOVEI T2,"A"		;[9077] Load next character
	CALL PUNCT		;[9077] (T2,Q3/) Send it too
	SKIPN T2,.FBACT(Q2)	;[9077] Load account word
	IFSKP.			;[9077] Account set on this file
	  TXZN T2,7B2		;[9077] Is this a numeric account?
	  IFSKP.		;[9077] Yes, numeric!
	    CALL JFNSND		;[9077] (T2/) Output number
	  ELSE.			;[9077] Alphanumeric account
	    ADD T2,DIRORA	;[9077] Get address of string
	    XMOVEI T1,.ACVAL(T2) ;[9077] Get address of ASCIZ string
	    TXO T1,<OWGP. 7>	;[9077] Make it a one word gloal pointer
	    CALL JFNSGS		;[9077] (T1/) Output account string
	  ENDIF.		;[9077] End of 
	ENDIF.			;[9077]  account string output
;Do ";T" if needed (still with directory mapped and CSKED).

JFNS6:	TXNN Q3,JS%TMP		;[9077] Output this stuff?
	IFSKP.			;[9077] Maybe we should
	  MOVE T1,.FBCTL(Q2)	;[9077] Load the control word
	  TXNN T1,FB%TMP	;[9077] Is file a semiT?
	  IFSKP.		;[9077] Yes
	    MOVEI T2,PNCATT	;[9077] Load punctuation for it
	    CALL PUNCT		;[9077] (T2,Q3/) Do punctuation as needed
	    MOVEI T2,"T"	;[9077] Load flag for this file
	    CALL JFNSBO		;[9077] (T2,Q3/) Send that byte too
	  ENDIF.		;[9077] End of this is a temp file 
	ENDIF.			;[9077] End of output temp file if needed

;[9077] Do ;OFFLINE if needed (still with directory mapped and CSKED).

	TXNN Q3,JS%OFL		;[9077] Return offline stuff?
	IFSKP.			;[9077] Yes
	  MOVE T1,.FBCTL(Q2)	;[9077] Load the control word
	  TXNN T1,FB%OFF	;[9077] Is file offline?
	  IFSKP.		;[9077] Yes file is offline
	    MOVEI T2,PNCATT	;[9077] Load punctuation
	    CALL PUNCT		;[9077] (T2,Q3/) Send that if needed
	    MOVEI T1,[ASCIZ/OFFLINE/]-1	;[9077] Point to offline string
	    CALL JFNSSS		;[9077] (T1/) and send it
	  ENDIF.		;[9077] End of file is offline code
	ENDIF.			;[9077] End of offline desired code

;[9081] Before unlocking directory, get size and dates for possible output.

	MOVE T2,.FBREF(Q2)	;[9081] Get .FBREF
	MOVEM T2,JFSREF		;[9081] Save it
	MOVE T2,.FBWRT(Q2)	;[9081] Get .FBWRT
	MOVEM T2,JFSWRT		;[9081] Save it
	MOVE T2,.FBCRV(Q2)	;[9081] Get .FBCRV
	MOVEM T2,JFSCRV		;[9081] Save it
	LOAD T2,FBNPG,(Q2)	;[9081] Get number of pages in file
	MOVEM T2,JFSSIZ		;[9081] Save it
	CALL USTDIR		;[9081] Unlock directory and go ECSKED
;[9081] Now that directory is unlocked and we are ECSKED, output attributes.

	CALL JFNSAT		;[9077] (/) Output the attributes

;[9077] Do size in pages if desired.

	LOAD T4,JS%SIZ,Q3	;[9077] Load size bit
	IFN. T4			;[9077] If output size is desired
	  MOVEI T2,","		;[9077] Load a comma
	  TXNE Q3,JS%PSD	;[9077] Punctuate this?
	  CALL JFNSBO		;[9077] (T2/) Yes
	  CALL TAB4		;[9077] (T4,Q3/) Tab if needed
	  MOVE T2,JFSSIZ	;[9081] Load size in pages of file
	  CALL JFNSND		;[9077] (T2/) Copy size in decimal pages
	ENDIF.			;[9077] End of size output

;[9081] Release locks, return the string we built, release freespace, go OKINT.

	CALL JFNSRS		;[9077] (/) Return the string we built

;[9077] At this point all locks are off, the string has been returned to the
;user, the JSB freespace has been returned, and we are OKINT.
	SUBTTL JFNS JSYS -- JFN Supplied -- Dates for Disk JFN

;Now that the locks are off, we can do dates that we have saved.

JFNS8:	LOAD T4,JS%CDR,Q3	;[9077] Load bit to output creation date
	MOVE T2,JFSCRV		;[9077] Load .FBCRV of file
	CALL JFNSDA		;[9077] (T2,T4,Q3/) Output date if needed

	LOAD T4,JS%LWR,Q3	;[9077] Load last write date bit
	MOVE T2,JFSWRT		;[9077] Get .FBWRT of the file
	CALL JFNSDA		;[9077] (T2,T4,Q3/) Do that date if needed

	LOAD T4,JS%LRD,Q3	;[9077] Load last read bit
	MOVE T2,JFSREF		;[9077] Load last read date
	CALL JFNSDA		;[9077] (T2,T4,Q3/) Do that date if needed

	MRETNG			;[9077] Return good from JFNS%

;[9077] Local date printer for JFNS.
;Called only after JFNLCK and FILLCK unlocked.
;Call with T2/ date, T4/ 1 if output this field, Q3/ usual user bits
;Returns +1 always with string sent to user via BOUTA.

JFNSDA:	JUMPE T4,R		;[9077] Return now if no output
	STKVAR <JFNDAY,<JFNDAX,MAXLW>> ;[9077] Make place for ODTIM
	MOVEM T2,JFNDAY		;[9077] Save the date number
	MOVEI T2,.CHTAB		;[9077] Load a tab character
	TRNE Q3,JS%TBP		;[9077] Tab before fields with 1 or 2 value?
	CAIG T4,0		;[9077] Yes, skip if field should be output
	TRNE Q3,JS%TBR		;[9077] Tab just before returned fields?
	TQON JS%T3		;[9077] Skip if not first tab output
	CAIA			;[9077] No tab 
	CALL BOUTA		;[9077] (T2/) Send the tab if required
	MOVEI T2,","		;[9077] Next load a comma
	TRNE Q3,JS%PSD		;[9077] Punctuate size and date?
	CALL BOUTA		;[9077] (T2/) Send the comma then

	HRROI T1,JFNDAX		;[9077] Point to stack for ODTIM
	MOVE T2,JFNDAY		;[9077] Load the time we want to print
	SETZ T3,		;[9077] Default format please
	ODTIM			;[9077] Output Date and TIMe
	 ERJMP .+1		;[9077] Should never fail
	MOVEI T1,JFNDAX		;[9077] Point to the place where we wrote
	HRLI T1,(POINT 7)	;[9077] Make a byte pointer to it
	DO.			;[9077] Loop to transmit the string to user
	  ILDB T2,T1		;[9077] Load a byte
	  JUMPE T2,R		;[9077] Return if zero
	  CALL BOUTA		;[9077] (T2/) Send the byte
	  LOOP.			;[9077] Loop for all character
	OD.			;[9077] End of character transmission loop
	ENDSV.			;[9077] End of that STKVAR
	SUBTTL JFNS JSYS -- JFN Supplied -- Parse Only JFN

;[9077] Here if parse only JFN after filename has been output.

JFNSPO:	LOAD T4,JS%PRO,Q3	;[9077] Load output bits for protection
	IFN. T4			;[9077] If output is desired
	  CALL TAB4		;[9077] Output tab if needed
	  SKIPE T1,FILPRT(JFN)	;[9077] Any protection set?
	  CALL JFNSP		;[9077] (T1/) Output protection
	ENDIF.			;[9077] End of protection output code

	LOAD T4,JS%ACT,Q3	;[9077] Get format bits for account
	IFN. T4			;[9077] If output is desired
	  CALL TAB4		;[9077] Output tab if desired
	  MOVEI T2,PNCATT	;[9077] Load punctuation for account
	  CALL PUNCT		;[9077] (T2/) Send it
	  MOVEI T2,"A"		;[9077] Load next character
	  CALL PUNCT		;[9077] (T2/) Send it too
	  MOVE T1,FILACT(JFN)	;[9077] Point to string
	  CALL JFNSSS		;[9077] (T1/) Send account string
	ENDIF.			;[9077]  account string output

	CALLRET JFNSEJ		;[9081] That's all we need to output today
	SUBTTL JFNS JSYS -- JFN Supplied -- Non-Disk non-Parse Only JFN

;[9081] Here for real JFNs that aren't disk JFNs or for disk JFNs without FDBs.
;For magtape we output the protection.

JFNSNJ:	CAIE P3,MTDTB		;[9081] Is this a MT (labeled tape)?
	IFSKP.			;[9081] Yes it is a MT
	  LOAD T4,JS%PRO,Q3	;[9081] Load control bits for protection
	  IFN. T4		;[9081] If output desired
	    CALL TAB4		;[9081] (T4,Q3/) Do tab control
	    CALL MTGPRO		;[9081] (JFN/T1) Get protection
	    SKIPE T1		;[9081] Any protection to output?
	    CALL JFNSP		;[9081] (T1/) Output protection
	    ENDIF.		;[9081] End of protection output
	  ENDIF.		;[9081] End of magtape special case

;[9081] Here at end of device/JFN specific output.  Output any attributes,
;release locks, return string to user, release freespace, go OKINT and return.

JFNSEJ:	CALL JFNSAT		;[9081] (/) Type out attributes (if any)
	CALL JFNSRS		;[9081] (/) Return the string we built
	MRETNG			;[9081] Done
	SUBTTL JFNS JSYS -- JFN Supplied -- Attributes

;Local routine to do attributes, called with Q1, Q3, JFN, and so on.
;Returns +1 always.

JFNSAT:	STKVAR <JFNSAC,JFNSAA,JFNSAV>
	TXNE Q3,JS%ATR		;Want all attributes?
	JRST JFNAT1		;Yes
	TXNN Q3,JS%AT1		;Want one attribute?
	RET			;No, do nothing

;Now we need to output a single attribute, copy string to monitor space, then
;look for prefix in the prefix table.

	UMOVE T1,4		;Get the pointer to prefix
	CALL CPYFUS		;(T1-T3/T1-T3) Copy string to monitor space
	 ITERR (,<CALL JFNSRF>)	;[9077] (/) Failed, release things we own
	MOVEM T1,JFNSAA		;Save address of string block
	HRLI T1,(POINT 7,0,35)	;Set up a byte pointer to string
	MOVEI T2,PRFXTB		;Set up to look for prefix
	EXCH T1,T2		;Swap ACs for TBLUK
	TBLUK%			;Look up prefix
	 ERJMP JFN1AE		;Failed!
	TXNN T2,TL%ABR!TL%EXM	;Found a match?
	JRST JFN1AE		;No, error
	HRRZ T2,(T1)		;Get the prefix value
	ANDI T2,PFXMSK		;Get just the value
	LOAD T1,FLATL,(JFN)	;Get pointer to start of attribute list

;Look for desired prefix value in chain of attributes.

JFN1A1:	JUMPE T1,JFN1AE		;If none, give error return
	LOAD T3,PRFXV,(T1)	;Get prefix value of this entry
	CAMN T3,T2		;Found a match yet?
	JRST JFN1A2		;Yes, go return the value
	LOAD T1,PRFXL,(T1)	;Step to next entry on list
	JRST JFN1A1		;Loop back til desired entry found

;Copy desired attribute to user.

JFN1A2:	CALL JFNSSS		;[9077] (T1/) Go return the string to the user
	HRRZ T2,JFNSAA		;Get address of temp string
	CALLRET RELJFR		;[9077] (T2/) Free up storage and return

;Here if not found, return freespace and give appropriate error code.

JFN1AE:	HRRZ T2,JFNSAA		;Get address of temp string
	CALL RELJFR		;[9077] (T1,T2/) Free up storage
	ITERR (GJFX40,<CALL JFNSRF>) ;[9077] (/) Return error
;More JFNSAT

;Here when we want to return all attributes to the user.

JFNAT1:	SETZB T1,JFNSAC		;Initialize the count of attributes
JFNAT2:	CALL GTNPFX		;(T1/T1) Get the next prefix
	 RET			;No more, return
	MOVEM T1,JFNSAA		;Save the address of the block
	LOAD T2,PRFXV,(T1)	;Get the attribute prefix
	CAIN T2,.PFPWD		;Is this the password one?
	TQNE <ASTF>		;Yes, is this parse-only?
	TRNA			;Not password or parse-only - print it
	JRST JFNAT3		;Password and not parse only - do not print it
	MOVEI T2,PNCATT		;Get the starting punctuation
	CALL PUNCT		;(T2,Q3/) Put into caller's string if needed
	MOVE T1,JFNSAA		;Get back address of the attribute
	LOAD T1,PRFXV,(T1)	;Get the prefix value from block
	CALL GTPFXS		;(T1/T1,T2) Get address of prefix string
	 JRST JFNAT3		;[9077] Skip this one if we don't know it
	MOVEM T2,JFNSAV		;Save the attribute value
	CALL JFNSSS		;[9077] (T1/) Output attribute name
	MOVE T3,JFNSAV		;Get back the value of the prefix
	TRNE T3,NOATRF		;Is this a no value attribute?
	JRST JFNAT3		;Yes, do not add on a null value
	MOVEI T2,PNCPFX		;Get punctuation of prefix
	CALL PUNCT		;(T2,Q3/) Output the colon if needed
	HRRZ T1,JFNSAA		;Get the address of the attribute block
	CALL JFNSSS		;[9077] (T1/) Copy out the attribute string
JFNAT3:	AOS T1,JFNSAC		;Step to the next attribute
	JRST JFNAT2		;Loop back till all attributes seen
;More JFNSAT
;ROUTINE TO GET NEXT ATTRIBUTE ON CHAIN
;ACCEPTS IN A/	COUNT OF THE DESIRED BLOCK
;	CALL GTNPFX
;RETURNS +1:	NO MORE
;	 +2:	ADDRESS OF BLOCK IN AC A

GTNPFX:	MOVE D,A		;SAVE THE COUNT
	LOAD A,FLATL,(JFN)	;GET START OF ATTRIBUTE CHAIN
GTNPF1:	JUMPE A,R		;IF NO MORE, RETURN
	SOSGE D			;FOUND THE DESIRED ENTRY?
	RETSKP			;YES, RETURN WITH ADRRESS IN A
	LOAD A,PRFXL,(A)	;STEP TO NEXT ITEM ON THE CHAIN
	JRST GTNPF1		;LOOP BACK TILL DESIRED ENTRY IS FOUND

;ROUTINE TO GET ADDRESS OF PREFIX STRING (FOR JFNSS)
;ACCEPTS IN A/	VALUE OF THE DESIRED PREFIX
;	CALL GTPFXS
;RETURNS +1:	NOT FOUND
;	 +2:	A/	ADDRESS OF STRING BLOCK -1 (FOR JFNSS)

GTPFXS:	HLRZ D,PRFXTB		;GET NUMBER OF ENTRIES IN PREFIX TABLE
	MOVNS D			;BUILD AOBJN POINTER
	HRLZS D
	HRRI D,PRFXTB+1		;POINT TO FIRST ENTRY IN TABLE
GTPFX1:	HRRZ B,0(D)		;GET THE PREFIX VALUE
	ANDI B,PFXMSK		;GET JUST THE VALUE
	CAMN A,B		;FOUND IT YET?
	JRST GTPFX2		;YES
	AOBJN D,GTPFX1		;NO, LOOP BACK TIL FOUND
	RET			;NOT FOUND

GTPFX2:	HLRZ A,0(D)		;GET ADDRESS OF STRING
	HRRZ B,0(D)		;GET PREFIX VALUE AND FLAGS
	SOJA A,RSKP		;RETURN ADDRESS-1 FOR JFNSS

;LOCAL ROUTINE FOR JFNS TO TRY TO SET UP CONNECTED DIRECTORY STRING IN JSB WHEN
;ABSENT.  USES ACCES JSYS TO CONNECT TO CURRENTLY CONNECTED DIRECTORY....
;(PRESENT BECAUSE ACCES JSYS FOR ANOTHER JOB CAN'T WRITE THE STRING INTO
;ANOTHER JOB'S JSB FREE SPACE)

JFNSCD:	SAVEQ			;PRESERVE Q REGS
	MOVX T1,AC%CON+3	;CONNECT FUNCTION
	MOVEI T2,Q1		;ARGS IN Q1-Q3
	MOVE Q1,JSBSDN		;CURRENTLY CONNECTED DIRECTORY
	SETZM Q2		;GIVE NO PASSWORD
	SETOM Q3		;-1=THIS JOB
	ACCES			;AND DO IT
	 ERJMP .+1		;IGNORE ERRORS
	RET			;AND DONE
	SUBTTL JFNS JSYS -- JFN Supplied -- Display Routines

;Local routine to output protection for JFNS.
;Call with T1/ Protection
;Returns +1 always.

JFNSP:	MOVE T4,T1		;[9077] Save protection
	MOVEI T2,PNCATT		;Load punctuation
	CALL PUNCT		;(T2,Q3/) Do punctuation character
	MOVEI T2,"P"		;Get prefix for protection
	CALL PUNCT		;(T2,Q3/) Do it as well
	MOVE T2,T4		;[9077] Restore protection
	TXZ T2,5B2		;[9077] Clear obnoxious bits
	CALLRET JFNSNO		;[9077] (T1,T3/) Output protection in octal

;Local routine for JFNS to print punctuation if JS%PAF specified.
;Call with T2/ punctuation character, Q3/ JFNS format flags
;Returns +1 always

PUNCT:	TRNE Q3,JS%PAF		;Punctuate?
	CALLRET JFNSBO		;[9077] (T2/) Send character and return
	RET			;[9077] Do nothing and return

;Local routine for JFNS to print tab if needed.
;Call with T4/ format output control for field, Q3/ JFNS format flags
;Does not output tab on first call.
;Returns +1 always

TAB4:	MOVEI T2,.CHTAB		;Load a tab character
	TRNE Q3,JS%TBP		;Tab before all fields?
	CAIG T4,0		;Skip if field should be output
	TRNE Q3,JS%TBR		;Tab just before returned fields?
	TQON JS%T3		;Skip if not first tab output
	RET			;Do not output tab
	CALLRET JFNSBO		;[9077] (T2/) Send that and return
	SUBTTL JFNS JSYS -- JFN Supplied -- Store String

;[9077] Local routines to append ASCIZ string to the string returned by JFNS.
; CALL JFNSSS to precede all special characters with ctrl/V
;	with T1/ Address-1 of ASCIZ string
; CALL JFNSDS to precede all special characters but period with ctrl/V
;	with T1/ Address-1 of ASCIZ string
; CALL JFNSGS to precede all special characters with ctrl/V
;	with T1/ one word global byte pointer to the string to copy
;Returns +1: always

JFNSGS:	SETO T4,		;[9077] Indicate that dot gets ^V
	JRST JFNS1S		;[9077]  and then get cranking on that string
JFNSDS::TDZA T4,T4		;[9077] Indicate dot should not get ^V
JFNSSS::SETO T4,		;[9077] Indicate dot should get ^V
	JUMPE T1,R		;[9077] Return now if no string
	HRLI T1,(<POINT 7,0,35>) ;[9077] Construct pointer to source

;Loop through the characters in the string, if the character is not an upper
;case, digit, dollar sign, underscore, or hyphen it should be quoted.

JFNS1S:	DO.			;[9077] Top of loop to get characters
	  ILDB T2,T1		;[9077] Get next character
	  JUMPE T2,R		;[9077] Done when we see a null
	  CAIN T2,"."		;[9077] Is it a dot?
	  SKIPE T4		;[9077] Yes, skip if dot is exempt from check
	  CALL JFNSCC		;[9077] (T2/) Skip if a special character
	  IFSKP.		;[9077] If a special character
	    MOVEI T2,"V"-100	;[9077] Load a control-V
	    CALL JFNSBO		;[9077] (T2/) Send that control-V
	    LDB T2,T1		;[9077] Reload character
	  ENDIF.		;[9077] End of 
	  CALL JFNSBO		;[9077] (T2/) Output that character
	  LOOP.			;[9077] Loop until a null seen
	OD.			;[9077] End of loop
;[9077] Local routine called from above to skip is character in T2 is 
;a special character which must be quoted with control-V.
;Returns +1 if T2/ uppercase, digit, underscore, hyphen, or dollarsign.
;Returns +2 otherwise
;Coded this way since most characters presented to it will be uppercase.
	
JFNSCC:	CAIL T2,"A"		;[9077] Is it 
	CAILE T2,"Z"		;[9077]  upper case?
	CAIN T2,"$"		;[9077] No, is it a dollarsign?
	RET			;[9077] Uppercase or dollarsign, not special
	CAIL T2,"0"		;[9077] Is it zero
	CAILE T2,"9"		;[9077]  through nine?
	CAIN T2,"-"		;[9077] Nope, is it a hyphen?
	RET			;[9077] Digit or hyphen, not special character
	CAIN T2,"_"		;[9077] Underscore?
	RET			;[9077] Underscore not a special character
	RETSKP			;[9077] Special character, return +2

repeat 0,<			;[9077] An alternate expression of above
	  IDIVI T2,CCBPW	;Get the word number
	  LDB T3,CPTAB(T3)	;Get the code for the character
	  CAIE T3,UPPER		;Is it upper case, dollarsign, or underscore?
	  CAIN T3,MINUSC	; or minus sign?
	  IFSKP.		;If not one of those
	    CAIL T3,DIGITC	;Is it a 
	    CAILE T3,UPPERA	; digit, T, P, or A?
	    IFNSK.		;Not a digit, T, P, A, upper case, or minus
	      MOVEI T2,"V"-100	;Load a control V
	      CAIN T2,$DOT	;Is it a dot?
	      SKIPE T4		;Should we control-V it?
	      CALL JFNSBO	;(T2/) Send a control-V to the string
	    ENDIF.		;End of
	  ENDIF.		; character checks
>

;[9077] Local routine for JFNS to handle output of wildcard strings.
;Call JFNSTR to output an asterisk.
;Call JFNSST to output asterisk if T1 zero or string it T1 not zero.
;Returns +1 always.

JFNSST:	SKIPN T1		;[9077] Skip if string pointer in T1
JFNSTR:	MOVEI T1,[ASCIZ /*/]-1	;[9077] Use a star
	HRLI T1,(<POINT 7,0,35>) ;[9077] Make a pointer to address 
	DO.			;[9077] Loop through entire string
	  ILDB T2,T1		;[9077] Load a character from string
	  JUMPE T2,R		;[9077] Return if null seen
	  CALL JFNSBO		;[9077] (T2/) Send that character
	  LOOP.			;[9077]  and loop for more
	OD.			;[9077] End of per-character loop
	SUBTTL JFNS JSYS -- JFN Supplied -- Store Number

;[9077] Local routine to append a number to output string for JFNS.
;Call with T2/ number and T3/ radix
;Returns +1 always

JFNSND:	IFL. T2			;[9077] If negative number
	  MOVE T1,T2		;[9077] Save the number
	  MOVEI T2,"-"		;[9077] Load hyphen
	  CALL JFNSBO		;[9077] (T2/) Send minus sign along
	  MOVM T2,T1		;[9077] Get magnatude of number
	ENDIF.			;[9077] End of negative number check	
	SKIPA T1,[^D10]		;[9077] Load decimal radix and skip
JFNSNO:	MOVEI T1,10		;[9077] Load octal radix
JFNSN1:	IDIVI T2,(T1)		;[9077] Get a digit from the number
	ADDI T3,"0"		;[9077] Convert to ASCII
	PUSH P,T3		;[9077] Save it on the stack
	SKIPE T2		;[9077] End of number?
	CALL JFNSN1		;[9077] (T2/) No get next digit
	POP P,T2		;[9077] Restore digit to T2
;	CALLRET JFNSBO		;[9077] (T2/) Send a digit and return
				;Fall through to next page's JFNSBO
	SUBTTL JFNS JSYS -- JFN Supplied -- Store Character

;[9077] Local routine stores a character in the free space for JFNS.
;Call with T2/ character
;Returns +1 always, all ACs preserved

JFNSBO:	SOSGE JFSCNT		;[9077] Space to store?
	IFSKP.			;[9077] Yes
	  IDPB T2,JFSPTR	;[9077] Yes, store character
	  RET			;[9077] and return always
	ENDIF.			;[9077] Buffer full, this is VERY unusual
	CALL JFNSB1		;[9077] (/) What a pain in the BOUT
	JRST JFNSBO		;[9077] Try output again

;Here if the buffer is full, this is not expected to happen, but recover from
;it anyway by unlocking, emptying the buffer, and relocking.  Yeeccchh.

JFNSB1:	SAVET			;[9077] Save temps for now
	UNLOCK JFNLCK		;[9077] Unlock the JFN lock 
	UNLOCK FILLCK(JFN)	;[9077]  and unlock the file lock
	CALL JFNSCS		;[9077] (/T1) Copy the string
	 ITERR (,<CALL JFNSFR>)	;[9077] Error, return it
	LOCK FILLCK(JFN)	;[9077] No, make sure it is unlocked
	LOCK JFNLCK		;[9077] Release JFN lock
	RET			;[9077] Return from horrible routine

;[9077] Local routine called when new buffer for JFNS is available.
;Resets buffer pointer and count for JFNS.
;Returns +1 always.

JFNSNB:	SETZM 1(T1)		;[9077] Insure first word is zero
	HRLI T1,(POINT 7,0,35)	;[9077] Make pointer to the space
	MOVEM T1,JFSPTR		;[9077] Save pointer to that string
	MOVEI T2,<5*<MAXLW*9>>-1 ;[9077] Load characters we can store
	MOVEM T2,JFSCNT		;[9077] Save as count
	RET			;[9077] And return

	SUBTTL JFNS JSYS -- JFN Supplied -- Return User String

;[9077] Local routine to return the string to the user for JFNS.
;Unlocks everything, sends string, returns freespace, and goes OKINT.
;Returns +1 always.

JFNSRS:	CALL JFNSUL		;[9077] (/) Unlock file lock and JFN lock
	CALL JFNSCS		;[9077] (/T1) Copy the string
	 ITERR (,<CALL JFNSFR>)	;[9077] Error, return it
	CALLRET JFNSFR		;[9077] (/) Free space and unlock and return

;[9077] Local routine to return the string created by JFNS to the user.
;Returns +1 if error
;Returns +2 if OK

JFNSCS:	SETZ T3,		;[9077] Load a null
	IDPB T3,JFSPTR		;[9077]  and bind off the string to return
	MOVE T3,JFSADR		;[9077] Load the address of the free space
	HRLI T3,(POINT 7,0,35)	;[9077] Make pointer to the space

;[9077] Use a BOUT loop if the user's designator is not a string.

	UMOVE T1,1		;[9077] Load user's destination designator
	TLNE T1,-1		;[9077] Is it a string pointer or JFN?
	IFSKP.			;[9077] Its a real JFN
	  DO.			;[9077] Loop to read from
	    ILDB T2,T3		;[9077] Load a byte from space
	    JUMPE T2,RSKP	;[9077] (/) If a null get out we are done
	    BOUT		;[9077] Send byte to user
	     ERJMPR R		;[9077] If error return it in T1
	    LOOP.		;[9077] Loop for all of them
	  OD.			;[9077] End of character transmission loop
	ENDIF.			;[9077] Otherwise its a string pointer

;[9077] Copy characters to user if destination is a byte pointer

	TLC T1,777777		;[9077] Seems to be a byte pointer
	TLCN T1,777777		;[9077] Is it -1,,address?
	HRLI T1,(POINT 7)	;[9077] Yes, make it <POINT 7,address>
	DO.			;[9077] Loop for all characters
	  ILDB T2,T3		;[9077] Get a source character
	  JUMPE T2,ENDLP.	;[9077] Get out if null seen
	  XCTBU [IDPB T2,T1]	;[9077] Store character please
	  LOOP.			;[9077] Loop for all characters
	OD.			;[9077] Null seen
	UMOVEM T1,1		;[9077] Restore user's pointer
	XCTBU [IDPB T2,T1]	;[9077] Store null character next
	RETSKP			;[9077]  and return
	SUBTTL JFNS JSYS -- JFN Supplied -- Unlock and Free Space Return

;[9077] Local routine for JFNS to unlock locks.
;Call JFNSUL to perform the following functions:
;	Unlocks the file lock.
;	Unlocks the JFN lock.
;Returns +1 Always.

JFNSUL:	CALL UNLCKF		;[9077] (/) Unlock the FILLCK first
	UNLOCK JFNLCK		;[9077] Release JFN lock
	RET			;[9077] Return

;[9077] Local routine for JFNS to unlock and return nothing.
;Call JFNSRJ to perform the following functions:
;	Just JFNLCK lock is unlocked
;	Free space returned
;	Go OKINT

JFNSRJ:	UNLOCK JFNLCK		;[9077] Unlock just JFNLCK
	CALLRET JFNSFR		;[9077] (/) Return freespace and return

;[9077] Local routine for JFNS to unlock and return nothing.
;Call JFNSRF to perform the following functions:
;	All locks are unlocked
;	Free space returned
;	Go OKINT

JFNSRF:	CALL JFNSUL		;[9077] Unlock all locks
;	CALLRET JFNSFR		;[9077] (/) Return freespace and return

;[9077] Local routine to return freespace for JFNS.
;Call JFNSFR for the following functions:
;	Free space is returned.
;	Goes OKINT.
;Returns +1 always

JFNSFR:	SAVET			;[9077] Save temps

	HRRZ T2,JFSADR		;[9077] Get address of temp string
	SKIPE T2		;[9077] Don't ever release twice 
	CALL RELJFR		;[9077] (T2/) Free up storage
	SETZM JFSADR		;[9077] Insurance

	OKINT			;[9077] Interruptions are OK again
	RET			;[9077] Return now

	ENDTV.			;[9077] End of TRVAR for JFNS
	SUBTTL JFNS JSYS -- String Supplied

;[9077] Here if JS%PTR is set for JFNS (JFNX).  This code is a special string
;input handler to put correct punctuation around the string.  Punctuation used
;is that for the first non-zero field found scanning from left to right.
;Doesn't need JFNLCK or FILLCK to work, since AC2 contains string pointer.  As
;DML says, "this is just another case of user code in the monitor".

JFNX0:	UMOVE JFN,2		;[9077] Load user's JFN
	CALL CHKJFN		;(JFN/DEV,P3,JFN,STS) Check the JFN
	 ITERR ()		;Some kind of error
	 ITERR (DESX4)		;TTY is illegal
	 JRST JFNX0A		;String pointer is OK
	CALL UNLCKF		;(JFN/) A real JFN, release lock
	ITERR (DESX1)		; and return illegal designator error

;Check user's supplied pointer, fix up from -1,,addr, and insure a null stored.

JFNX0A:	UMOVE T1,1		;Load user's output pointer
	TLNN T1,777777		;Is it a byte pointer?
	JRST JFNX1		;No, not byte pointer
	TLC T1,777777		;Is it 
	TLCN T1,777777		; -1,,address?
	HRLI T1,440700		;Yes, make it POINT 7,address
	SETZ T2,		;Load a null up
	XCTBU [IDPB T2,T1]	;Deposit initial null in case

;Check for null JFN source, output tab if needed.

JFNX1:	CAIN JFN,.NULIO		;[9077] Null?
	MRETNG			;[9077] Return good now
	MOVEI T2,.CHTAB		;Load a tab
	TRNE Q3,JS%TBR!JS%TBP	;Either tab request?
	CALL BOUTA		;(T2/) Yes, output tab
	;..
;Dispatch to code based on first field to output.

	TXNE Q3,JS%DEV		;Device?  (Really should use JS%DVN?)
	JRST JFNXDA		;Yes
	TXNE Q3,JS%DIR		;Directory?
	JRST JFNXDB		;Yes
	TXNE Q3,JS%NAM		;Name?
	JRST JFNXN		;Yes
	TXNE Q3,JS%TYP		;Extension?
	JRST JFNXE		;Yes
	TXNE Q3,JS%GEN		;Version?
	JRST JFNXV		;Yes
	TXNE Q3,JS%PRO		;Protection?
	JRST JFNXP		;Yes
	TXNE Q3,JS%ACT		;Account?
	JRST JFNXA		;Yes
	TXNE Q3,JS%TMP		; ";T" ?
	JRST JFNXT		;Yes
	TXNE Q3,JS%ATR!JS%AT1	;Attributes?
	JRST JFNXAT		;Yes
	TXNE Q3,JS%SIZ!JS%CDR!JS%LWR!JS%LRD ;Size or any date?
	JRST JFNXSD		;Yes
	TXNE Q3,JS%OFL		;Offline?
	JRST JFNXOF		;Yes
	JRST JFNXN		;Uh, I guess we return the device then

;[9077] Local routine called from JFNX to do punctuation.
;Call with T2/ character and Q3/ user format bits.
;Returns +1 always.

JFNXPA:	MOVEI T2,PNCATT		;[9077] Load attirbute punctuation
JFNXPU:	TXNE Q3,JS%PAF		;[9077] Punctuate all fields?
	CALL BOUTA		;[9077] (T2/) Yes send punctuation
	RET			;[9077] Return to caller

;[9077] Local routine called from JFNX to copy string to user.
;Call with JFN/ string pointer in user space
;Returns +1 always

JFNXDO:	XCTBU [ILDB T2,JFN]	;Get byte from user
	JUMPE T2,R		;End on null
	UMOVEM JFN,2		;Update byte pointer
	CALL BOUTA		;(T2/) Copy that byte around and around
	JRST JFNXDO		;Loop for all bytes in supplied string
;Device

JFNXDA:	CALL JFNXDO		;(JFN/) Copy user string
	MOVEI T2,":"		;Load device punctuation
	JRST JFNXX1		;Store punctuation and exit

;Directory

JFNXDB:	MOVEI T2,"<"		;Load beginning of directory string
	CALL JFNXPU		;[9077] (T2/) Do punctuation if needed
	CALL JFNXDO		;(JFN/) Copy string to user
	MOVEI T2,">"		;Load closing punctuation
JFNXX1:	CALL JFNXPU		;[9077] (T2/) Do punctuation if needed
	MRETNG			;[9077]  and return

;Size or date

JFNXSD:	MOVEI T2,","		;Load usual punctuation for this field
	TRNE Q3,JS%PSD		;Punctuate size or date fields?
	CALL BOUTA		;(T2/) Yes do it then 
	JRST JFNXN		;Return user string and return

;Extension and version

JFNXV:	SKIPA T2,[PNCVER]	;Load punctuation for version
JFNXE:	MOVEI T2,"."		;Load punctuation for extension
JFNXE1:	CALL JFNXPU		;[9077] (T2/) Do punctuation if needed

;Name

JFNXN:	CALL JFNXDO		;(JFN/) Copy string to user
	MRETNG			;[9077] Return
;Account

JFNXA:	CALL JFNXPA		;[9077] (/) Do attribute punctuation
	MOVEI T2,"A"		;Load up account string specifier
	JRST JFNXE1		;Do punctuation and return string

;Protection

JFNXP:	CALL JFNXPA		;[9077] (/) Do attribute punctuation
	MOVEI T2,"P"		;Load next character for punctuation
	JRST JFNXE1		;Send punctuation and user string and return

;Offline

JFNXOF:	CALL JFNXPA		;[9077] (/) Do attribute punctuation
	MOVEI T1,[ASCIZ /OFFLINE/]-1 ;[9077] Point to string to return
	CALL JFNSS		;[9077] (T1/) Send that string to user
	MRETNG			;[9077] Return good

;Temporary

JFNXT:	CALL JFNXPA		;[9077] (/) Do attribute punctuation
	MOVEI T2,"T"		;[9077] Load temporary flag
	CALL BOUTA		;[9077] (T2/) Send the T always
	MRETNG			;[9077]  and return

;Attributes

JFNXAT:	CALL JFNXPA		;[9077] (/) Do attribute punctuation
	CALL JFNXDO		;(JFN/) Followed by the prefix string
	TXNN Q3,JS%AT1		;Does this have a value to return?
	MRETNG			;[9077] No, all done
	MOVEI T2,PNCPFX		;Yes, output the punctuation
	CALL JFNXPU		;[9077] (T2/) between fields
	UMOVE JFN,4		;Set up pointer to value string
	TLC JFN,-1		;See if -1 
	TLCN JFN,-1		; in left half
	HRLI JFN,(POINT 7,0)	;Yes, set up byte pointer
	CALL JFNXDO		;(JFN/) Output the string to the user
	MRETNG			;[9077] All done
	SUBTTL JFNS JSYS -- Global Subroutines

;JFNSS AND JFNSSD - WRITE ASCII STRING
;ACCEPTS:
;	A/ ADDRESS OF ASCII STRING, WHICH STARTS IN BYTE 0 OF THE WORD
;		AND ENDS WITH A NULL
;	CALL JFNSS TO PRECEDE ALL SPECIAL CHARACTERS WITH CTRL/V
;		OR
;	CALL JFNSSD TO PRECEDE ALL SPECIAL CHARACTERS BUT PERIOD WITH CTRL/V
;RETURNS +1: ALWAYS

;CALL BOUTA, WHICH USES USER MODE AC 1 TO DETERMINE DESTINATION OF
;STRING. TERMINATES ON NULL

JFNSSD::TDZA D,D		;INDICATE DOT SHOULD NOT GET CTRL/V
JFNSS::	SETOM D			;INDICATE DOT SHOULD GET CTRL/V
	ACVAR <W1>
	MOVE W1,D		;SAVE THE FLAG IN CASE BOUTA CLOBBERS IT
	MOVE C,A		;GET ADDRESS OF STRING
	HRLI C,(<POINT 7,0,35>)	;CONSTRUCT POINTER TO SOURCE

;LOOP THROUGH THE CHARACTERS IN THE STRING, PRINTING EACH ACCORDING
;TO ITS CHARACTER CLASS. CONTINUE UNTIL NULL IS FOUND.

JFNSS1:	ILDB B,C		;GET NEXT CHARACTER
	JUMPE B,R		;[8820] Done when we see a null
	PUSH P,C		;GET A WORK AC
	PUSH P,B		;SAVE THE CHARACTER

;DETERMINE THE CHARACTER CLASS FROM CHARACTER TABLES DEFINED IN GTJFN
;IF SPECIAL, PRINT CTRL/V BEFORE PRINTING THE CHARACTER

	;IDIVI B,^D36/CCSIZE
	MOVEI B,^D36		; Have to do it the hard way cause
	IDIVI B,CCSIZE		; Macro can't divide externals
	MOVE C,B
	MOVE B,0(P)		;GET THE CHARACTER
	IDIV B,C		; And finally the real divide
	LDB B,CPTAB(B+1)	;GET THE CHARACTER CLASS
	JUMPE B,NTSPC		;0 IS NORMAL ALPHAS (EXCLUDES SOME LETTERS)
	CAIN B,30		; Minus sign not special
	 JRST NTSPC
	CAIL B,21		; Digits t, p, a
	CAILE B,24
	 JRST [	CAIN B,14	;IS THIS A DOT?
		JUMPE W1,NTSPC	;YES. IF REQUESTED, DON'T INSERT CTRL/V
		MOVEI B,"V"-100	;OUTPUT CTRL/V
		CALL BOUTA	; ACCORDING TO USER'S DESIGNATOR
		JRST NTSPC]	;AND THEN GO DO THE CHARACTER
NTSPC:	POP P,B			;GET THE CHARACTER
	POP P,C
	CALL BOUTA		;OUTPUT ACCORDING TO USER'S DESIGNATOR
	JRST JFNSS1		;GO GET THE NEXT CHARACTER

	ENDAV.			;END ACVAR
;LOCAL NUMBER OUTPUT ROUTINE 
;[9077] No longer used by JFNS itself.
;Call with T2/ number, T3/ NOUT options
;Returns +1 always

NOUTXX::PUSH P,JFN
	PUSH P,DEV
	PUSH P,STS
	PUSH P,F1
	PUSH P,Q3
	PUSH P,D
	PUSH P,F
	PUSH P,C
	PUSH P,B
	CALL NOUTX
	 JFCL
	POP P,B
	POP P,C
	POP P,F
	POP P,D
	POP P,Q3
	POP P,F1
	POP P,STS
	POP P,DEV
	POP P,JFN
	RET
	SUBTTL MOUNT JSYS

; Mount device
; Call:	1	; Device designator
;	MOUNT
; Return
;	+1	; Error
;	+2	; Ok

.MOUNT::MCENT
	UMOVE A,1
	TLZN A,(1B3)		; Directory to be read?
	TDZA B,B		; Yes
	SETO B,			; No
	PUSH P,B
	CALL CHKDEV
	 RETERR()
	UMOVE 1,1
	TLZ 1,(1B3)
	TLNE C,(DV%MNT)		; Already mounted?
	 JRST [	DSMNT		; Attempt to dismount first
		 RETERR()	; Error if can't
		JRST .+1]
	EXCH B,(P)		; Save b, get directory read flag
	HRRZ P3,DEV		; GET ADDRESS ONLY
	CALL @MNTD(P3)		; Call P3ice mount routine
	 RETERR()		;MOUNT ERROR
	POP P,B
	MOVSI C,(DV%MNT)
	IORM C,DEVCHR(B)	; Mark device as mounted
	SMRETN			;NO, DONE NOW
	SUBTTL MTOPR JSYS

; Special file operation
; Call:	1	; Jfn
;	2	; Operation desired
;	MTOPR

.MTOPR::MCENT
MTOPR1:	UMOVE JFN,1
	CALL CHKJFN
	 ITERR()
	 JRST .+2
	 ITERR(DESX4)

	TQNE <OPNF>
	JRST MTOPR2		;OPENED PATH
	CALL FNDUNT		;FIND DEVICE TABLE INDEX
	MOVX B,D1%MTO		;Get "MTOPR allowed although not open" bit
	TDNE B,DEVCH1(A)	; and test it
	JRST MTOPR2		;Yes, bit set for this device - allow MTOPR.
	HLRZ C,DEVUNT(A)	;GET JOB #
	MOVX B,DV%ASN		;ASSIGNED BIT
	TDNE B,DEVCHR(A)	;DEVICE ASSIGNED?
	CAME C,JOBNO		;BY THIS JOB?
	ITERR(CLSX1,<CALL UNLCKF>)
MTOPR2:	TQZ <ERRF,EOFF>		;OK TO PROCEED
	UMOVE B,2
	TQZE <BLKF>		;BLKF MUST BE ZERO BEFORE CALL
	BUG.(CHK,BLKF5,JSYSF,HARD,<.MTOPR - BLKF set before call to device routine>,,<

Cause:	The bit indicating that a device routine wishes to block has been
	set before the call to the device routine has been made. This bit
	must be set to zero before the call so we do not block needlessly
	(maybe never to wake up).

Action:	The bit is being cleared. If this problem persists, change the
	BUGCHK to a BUGHLT and find out where BLKF is being set.
>)
	XMOVEI C,MTOPRB		;PASS DOWN BLOCKAGE ROUTINE
	CALL @MTPD(P3)
	 JRST [	TQZE <BLKF>	;ROUTINE WANT TO BLOCK?
		JRST MTOPRW	;YES, GO BLOCK
		CALL UNLCKF
		ITERR()]
	CALL UNLCKF
	JRST MRETN

MTOPRW:	CALL UNLDIS		;UNLOCK JFN AND DISMIS
	JRST MTOPR1		;LOOP BACK AND START AGAIN
;CO-ROUTINE USED TO PERFORM LOWER LEVEL BLOCK

MTOPRB:	STKVAR <DEVSAV>		;SAVE DEV OF THIS DEVICE
	MOVEM DEV,DEVSAV
	CALL UNLDIS		;UNLOCK JFN ETC.
	UMOVE JFN,1		;GET USER JFN AGAIN
	CALL CHKJFN		;VALIDATE IT
	 RETBAD ()		;RETURN ERRORS
	 JRST .+2		;TTY OK
	 RETBAD (DESX4)
	CAME DEV,DEVSAV		;CHECK TO SEE THAT THIS IS THE SAME DEVICE
	RETBAD (DESX4)		;NO SOMEONE CHANGED THINGS
	RETSKP			;GIVE GOOD RETURN

; ROUTINE TO LOAD/STORE A WORD IN MTOPR FUNCTION BLOCK
;
; CALL:	A/ OFFSET INTO FUNCTION BLOCK
;	B/ VALUE TO BE STORED (IF ANY)
;		CALL GETWRD/PUTWRD
; RETURNS: +1	 ARGUMENT BLOCK TOO SMALL
;	   +2	SUCCESS, ARGUMENT STORED OR RETURNED IN B

PUTWRD::TDZA D,D		;FLAG STORE INSTEAD OF LOAD
GETWRD::SETOM D			;INDICATE FETCH REQUESTED
	UMOVE C,3		;GET ADDRESS OF USER'S ARGUMENT BLOCK
	UMOVE C,(C)		;GET LENGTH OF ARGUMENT BLOCK
	 ERJMP R		;FAILED, NON-EXISTENT
	CAML A,C		;ARGUMENT BLOCK BIG ENOUGH ?
	RET			;NO, FAIL RETURN
	UMOVE C,3		;GET ADDRESS OF ARGUMENT BLOCK AGAIN
	ADD C,A			;COMPUTE ADDRESS OF DESIRED WORD IN BLOCK
	JUMPE D,PUTWD1		;IF STORING GO PUT VALUE IN ARGUMENT BLOCK
	UMOVE B,(C)		;FETCH WORD DESIRED
	 ERJMP R		;FAILED, NON-EXISTENT
	RETSKP			;RETURN WITH REQUESTED VALUE

PUTWD1:	UMOVEM B,(C)		;STORE VALUE IN ARGUMENT BLOCK
	 ERJMP R		;FAILED, NON-EXISTENT
	RETSKP			;RETURN
	SUBTTL OPENF JSYS

; Open a file
; Call:	1	; Job file number
;	2(0-5)	; Byte size
;	2(6-9)	; Data mode
;	RH(2)	; Access flags (see jsys manual)
;	OPENF
; Return
;	+1	; Cannot open file, error code in 1
;	+2	; Successful

.OPENF::MCENT			; Become slow, save ac's
	EA.ENT			;[9041] Be sure of section 1
	TRVAR <UNTIDX>		;SAVE UNIT INDEX HERE
OPENF0:	UMOVE JFN,1		; Get jfn
	CALL CHKJFN		; What kind of designator is this?
	 RETERR()		; Garbage designator
	 JRST OPENF1		;DON'T ALLOW 400000+TERMINAL NUMBER
	 JRST [	CAIE DEV,STRDTB	; IS THIS A STRING POINTER
		JRST OPENFZ	; NO, NUL DEVICE IS OK
		ERUNLK (OPNX26)] ; YES, STRING POINTER IS ILLEGAL
	UMOVE F1,2		; Get access bits
	TXNN F1,OF%RD+OF%WR+OF%EX+OF%APP
	ERUNLK OPNX13		;RETURN ERROR IF NO ACCESS REQUESTED
	TQNE <OPNF>
	ERUNLK OPNX1		; Already open
	TQNE <ASTF>
	 ERUNLK(DESX7)		; Output stars not allowed
	LDB A,[POINTR F1,OF%BSZ]	;GET BYTE SIZE
	SKIPN A			; ZERO SPECIFIED?
	MOVEI A,^D36		; YES, USE FULL WORD
	CAILE A,^D36
	ERUNLK SFBSX2
	DPB A,PBYTSZ		; Store as byte size of pointer
	CALL FNDUNT		;(JFN/T1) Get dev index for unit
	HRRZM T1,UNTIDX		;[9122] Save unit index here for later
	MOVE T3,DEVCHR(T1)	;[9122] Get device bits for this device
	TXNN T3,DV%AS		;[9122] Assignable device?
	IFSKP.			;[9122] Yes
	  HLRZ T2,DEVUNT(T1)	;[9122] Get current assignment
	  CAMN T2,JOBNO		;[9122] Assigned by this job?
	  IFSKP.		;[9122] Nope
	    HRR T3,DEVUNT(T1)	;[9122] Get UNIT
	    TLZ T3,777000	;[9122] Remove junk bits
	    TLO T3,.DVDES	;[9122] Add bits for designator
	    GTOKM (.GOOAD,<T3>,[ERUNLK ()],OPENB) ;[9122] Ask the ACJ
	    MOVE T2,UNTIDX	;[9122] Recover unit index
	    MOVE T3,DEVCHR(T2)	;[9122] Restore mode bits as well
	    UMOVE F1,2		;[9122] Recover access bits as well
	    CALL DEVAV		;[9122] (DEV,T2/) Device available?
	     ERUNLK(OPNX7)	;[9122] Device already assigned to another job
	  ENDIF.		;[9122] End of "not assigned to this job" code
	ENDIF.			;[9122] End of "assignable device" code

	LDB A,[POINTR F1,OF%MOD];GET MODE
	MOVN D,A
	ROT C,-1(D)
	JUMPGE C,[ERUNLK(OPNX14)] ; Illegal mode
	STOR (A,IOMODE)		;SAVE IO MODE
	;..
	;..
	ANDX STS,<NAMEF+NONXF+ASTF+FRKF+.RTJST(OF%MOD,OF%MOD)> ;KEEP ONLY THESE BITS
	TXNE F1,OF%HER		;MOVE CALLER BITS TO INTERNAL PLACE
	TXO STS,HLTF
	TXNE F1,OF%RD
	TXO STS,READF
	TXNE F1,OF%WR
	TXO STS,WRTF
	TXNE F1,OF%EX
	TXO STS,XCTF
	TXNE F1,OF%APP
	TXO STS,RNDF
	TXNN F1,OF%PLN		;USER WANT LINE NUMBERS?
	TXNE F1,OF%WR!OF%EX!OF%APP;WRITING OR EXECUTING?
	TQO <PASLSN>		;THEN THIS ISN'T A LINE #D FILE
	LDB A,[POINTR F1,OF%BSZ]
	CAIE A,7		;IF THE FILE ISN'T ASCII,
	TQO <PASLSN>		;THEN IT CAN'T HAVE LINE NUMBERS TO REMOVE
	BLCAL. DSKOK,<DEV>	;[9041] Disk file?
	IFSKP.			;[9041] If file is on disk
	  MOVEI A,.GOOPN	;[9041] Do this ACJ function
	  SETZ B,		;[9041] Say not setting FB%SEC
	  CALL ACJOFL		;[9041] (T1,T2,JFN/) Then go through the ACJ
	   ERUNLK ()		;[9041] ACJ said no
	ELSE.
	  CAIE A,MTADTB		;NO, MAGTAPE?
	  CAIN A,DTADTB		;  AND DECTAPE
	  ANSKP.
	    TQO <PASLSN>	;ALL OTHERS DON'T NEED EXAMINING
	ENDIF.
	MOVE T1,UNTIDX		;[9122] Recover unit index
	CALL CFSMTA		;[9122] (T1/) Get MTA token for device
	 ERUNLK (OPNX32)	;[9122] Device is in use by another system

	SETZM FILCNT(JFN)
	XMOVEI C,OPENB		;OPEN BLOCK ROUTINE
	CALL @OPEND(P3)		; Call the DEVIce dependent routine
				;N.B. BITS IN F1 USED BY DSK!!!
	 JRST OPENR		; Cannot open

	TQO <OPNF>		; Success
	MOVSI B,1
	HLLM B,FILLFW(JFN)

	MOVE T1,UNTIDX		;[9122] Load unit index for the JFN
	MOVE B,DEVCHR(A)	;GET DEVICE BITS
	TXNN B,DV%AS		;ASSIGNABLE DEVICE?
	JRST OPENFZ		;NO
	CALL CKJFTT		;IS THIS THE JFN  FOR 'TTY'?
	 JRST OPENFZ		;YES. DON'T CHANGE DEVICE TABLES
	MOVE B,JOBNO		;NO, ASSIGN IT TO THIS JOB
	HRLM B,DEVUNT(A)
	MOVX B,DV%OPN
	IORM B,DEVCHR(A)	;NOTE ASSIGNED BECAUSE OF OPEN
	MOVEI A,0(DEV)		;SEE WHAT THIS DEVICE IS
	CAIN A,PTYDTB		;IS IT A PTY?
	CALL PTYINI		;YES. GO INIT TTY PARAMETERS THEN
OPENFZ:	CALL UNLCKF
	SMRETN
;[9041]
;ACJOFL - Routine called by file operation to see if the file being used
;is secure and if so, have the ACJ bless the request. Lots of assumptions
;here. For one, assumes CHKJFN has been called. Also assumes DEV, STS, and
;JFN are setup (done by CHKJFN) so that the call to GETFDB won't rollover.
;Big watch it: make sure AC 2 is 0 unless you are coming from CHFDB%!!!
;
;To avoid deadly embraces with various locks, make sure that only CHKJFN
;is called when you being to tread through here. If the calling routine
;does bad things like lock the directory, then the ACJ may hang with a
;competing lock.
;
; Call with:
;	T1/ ACJ function
;	T2/ Used only for .GOCFD and must be 0 for all else!
;	JFN/ Index in JFN block
;	CALL ACJOFL
;
; Returns:
;	+1 - ACJ said no
;	+2 - ACJ said yes, file not secure, or ACJ not running

ACJOFL:	SKIPE JOBNO		;[9063] Job 0?
	SKIPN ACJFN		;Have an ACJ?
	RETSKP			;[9063] Job 0 or no ACJ, return success
	STKVAR <OPNNAM,ERR,FUNC,SET,NXF> ;[9049] Address for file name string
	;..
	;..

	SETZM NXF		;[9049] Say file exists for now
	MOVEM T1,FUNC		;Save ACJ function
	MOVEM T2,SET		;Used for .GOCFD
	CALL GETFDB		;(JFN/) Make sure FDB is there
	 RETSKP			;Directory is probably messed up
	MOVE T1,.FBCTL(T1)	;Get flags from FDB
	CALL USTDIR		;(/) Unlock directory to avoid deadly embrace
	TXNE T1,FB%NXF		;[9049] Does this file exist?
	SETOM NXF		;[9049] No, say it does not exist
	MOVE T2,FUNC		;[9063] Get function code back
	CAIN T2,.GOCFD		;[9063] Setting or clearing secure bit?
	IFSKP.			;[9063] Nope, we have to check for secure file
	  TXNN T1,FB%SEC	;[9063] Is this a secure file?
	  RETSKP		;[9063] No, don't ask ACJ and allow access
	ENDIF.			;[9063] End of secure file check
	SKIPN SET		;[9063] Setting secure?
	TXZA T1,FB%SEC		;[9063] No, clearing secure
	TXO T1,FB%SEC		;[9063] Yes, setting
	MOVEM T1,SET		;[9049] Now save .FBCTL word
ACJOFS:	NOINT			;No interrupts please
	HRRZI T1,GEFLSZ+1	;Get this many words
	HRLI T1,.RESP3		;Priority (grow if none available)
	MOVEI T2,.RESGP		;From this pool
	CALL ASGRES		;(T1,T2/T1) Gimme some space
	 RETBAD (MONX05,OKINT)	;If can't get none, then tell user
	MOVEM T1,OPNNAM		;Save block address here
	MOVEI T2,GEFLSZ+1	;Get freespace block size
	MOVEM T2,.GOSIZ(T1)	;And save it here
	XMOVEI T1,<.GEFIL+1>(T1) ;File string will start here
	TXO T1,<OWGP. 7>	;Make nice byte pointer
	CALL FILACJ		;(T1/) Slam file name into freespace block
	MOVE T1,OPNNAM		;Get freespace block
	MOVE T2,FUNC		;Get ACJ function back
	;..
	;..
	CAIE T2,.GOOPN		;Doing an OPEN?
	IFSKP.			;If so,
	  UMOVE T2,T2		;Get user's access bits
	  TXZ T2,OF%NXS		;[9049] Assume files exists
	  SKIPE NXF		;[9049] Now check to see if it really does
	  TXO T2,OF%NXS		;[9049] No, say it doesn't for the ACJ
	  MOVEM T2,<.GEOAC+1>(T1) ;Save in freespace block
	  GTOKM (.GOOPN,<T1>,ACJOF1) ;Ask ACJ if he can open secure file
	  JRST ACJOF0		;And return our library books
	ENDIF.
	CAIE T2,.GORNF		;How about a rename?
	IFSKP.			;If doing rename
	  GTOKM (.GORNF,<T1>,ACJOF1) ;Can we do it?
	  JRST ACJOF0		;Balance our freespace check book
	ENDIF.
	CAIE T2,.GOCFD		;Trying a CHFDB%?
	IFSKP.			;If so,
	  MOVE T2,SET		;[9049] Get .FBCTL word
	  MOVEM T2,<.GESFS+1>(T1) ;Save in freespace block
	  GTOKM (.GOCFD,<T1>,ACJOF1) ;Allowed?
	  JRST ACJOF0		;Yes, get rid of freespace
	ENDIF.
;At this point, the function has to be .GODLF as it is the only one
;left.
	UMOVE T2,T1		;Get user's selected bits
	MOVEM T2,<.GEDAC1>(T1)	;And stash in the freespace block
	GTOKM (.GODLF,<T1>,ACJOF1) ;What's the verdict?
	;..
	;..

ACJOF0:	CALL RELRES		;(T1/) Get rid of the freespace block
	OKINT			;Interrupts are OK now
	RETSKP			;And we are done

ACJOF1:	MOVEM T1,ERR		;Save error code for now
	MOVE T1,OPNNAM		;Get freespace block back
	CALL RELRES		;(T1/) And return it
	OKINT			;Interrupts are cool now
	MOVE T1,ERR		;Get error code back
	RETBAD ()		;And see ya

	ENDSV.
;Here if device dependant routine failed to open the device.

OPENR:	CAIN T1,OPNX9		;[9125] Invalid simultaneous access?
	IFSKP.			;[9125] Nope, some other error
	  EXCH T1,UNTIDX	;[9124] Save error code, recover unit index
	  CALL CFSMTR		;[9122] (T1/) Lose MTA token for device
	  EXCH T1,UNTIDX	;[9124] Restore error code
	ENDIF.			;[9125] 
	TQZE <BLKF>		;WANT TO BLOCK?
	JRST OPENFW		;YES - WAIT
	CAIN A,OPNX31		; Offline?
	 JRST RETFIL		; Yes, handle that case
	CAIE A,OPNX9		;BUSY?
	ERUNLK()		;NO, SOME OTHER ERROR
	UMOVE B,2		;GET USER'S BITS AGAIN
	TRNN B,OF%NWT		;"NEVER WAIT"?
	TRNN B,OF%AWT		;OR NO "ALWAYS WAIT"?
	ERUNLK()		;YES, ERROR OUT
	CALL UNLCKF		;"ALWAYS WAIT" AND NO "NEVER WAIT", THEREFORE WAIT
	SETZM INTDF
	XCT INTDFF
	MOVEI A,"["		;PRINT "[DEVICE BUSY-"
	PBOUT
	MOVEI A,101
	UMOVE B,1
	MOVEI C,0
	JFNS
	HRROI A,[ASCIZ / Busy-/]
	PSOUT
OPENR1:	MOVEI A,^D3000		;WAIT SHORT TIME THEN TRY AGAIN
	DISMS
	UMOVE A,A
	UMOVE 2,2
	TRO B,OF%NWT
	OPENF
	 JRST OPENR1
	UMOVEM 1,1		;SUCCESS NOW, PRINT "GO]"
	HRROI 1,[ASCIZ /Go]
/]
	PSOUT
	SMRETN
RETFIL:	UMOVE B,2		; Get user bits again
	SKIPN ARDFRT		; Job want to wait?
	TXNE B,OF%RAR		; Or this call?
	 CAIA			; Yes, or yes
	  ERUNLK()		; Neither, bomb
	TXNE B,OF%NWT		; Never wait?
	 ERUNLK()		; Right, fail now
	CALL UNLCKF
	SETZM INTDF
	XCT INTDFF
	HRROI T1,[ASCIZ/[Retrieving /]
	PSOUT
	MOVX A,.PRIOU
	UMOVE B,1
	MOVEI C,0
	JFNS
	HRROI A,[ASCIZ/ from tape - /]
	PSOUT
	UMOVE A,1		; Recover the JFN
	MOVX B,.ARRFR		; Retrieve the file pls
	MOVX C,AR%WAT		; I'm waiting on you
	ARCF
	 ERJMP RETFAI		; Couldn't????
	HRROI A,[ASCIZ/Retrieved]
/]
	PSOUT
	UMOVE A,1		; Get AC's again, OPENF assumes these
	UMOVE B,2
	JRST .OPENF		; Start over...

RETFAI:	MOVX A,.PRIOU
	MOVE B,LSTERR
	HRLI B,.FHSLF
	SETZ C,
	ERSTR
	 JFCL
	 JRST RETFFA		; ??? now what...
	HRROI A,[ASCIZ/]
/]
	PSOUT
RETFFA:	RETERR(OPNX31)		; Fail
;ROUTINE TO CHECK IF THE OPENF IS ALLOWED TO WIN IF THE DEV IS OFFLINE

;RETURNS +1:	NOT ALLOWED
;	 +2:	ALLOWED TO BE OPENED EVEN IF OFFLINE

CHKOFL::TXNN F1,OF%OFL		;CHECK THE OFF LINE BIT FROM AC2
	RET			;NOT ALLOWED
	RETSKP			;ALLOWED

;HERE WHEN CHKJFN RETURNED +2, INDICATING TERMINAL. IF USER SPECIFIED
;.PRIIN, .PRIOU, OR (0,,-1) RETURN SUCCESS WITHOUT ASSIGNING TERMINAL
;IN DEVICE TABLES.  IF USER GAVE 400000+TERMINAL NUMBER, FAIL

OPENF1:	UMOVE T1,1		;GET USER'S INPUT AGAIN
	CAIE T1,.PRIIN		;PRIMARY INPUT?
	CAIN T1,.PRIOU		;NO. PRIMARY OUTPUT?
	SMRETN			;ALLOW THEM TO SUCCEED
	CAIE T1,-1		;CONTROLLING TERMINAL?
	RETERR (DESX1)		;NO. INVALID DESIGNATOR
	SMRETN			;YES. ALLOW SUCCESS

;CKJFTT - CHECK FOR JFN FOR 'TTY'

;ACCEPTS:
;	JFN/ A VALID JFN

;	CALL CKJFTT

;RETURNS +1: JFN FOR 'TTY'
;	 +2: ANY OTHER JFN

;THIS ROUTINE IS CHECKING FOR A JFN ON THE STRING 'TTY:'.  SINCE THIS
;STRING IS TAKEN TO MEAN 'JOB'S CONTROLLING TERMINAL', THE CODE THAT
;OPENS A JFN (BOTH IN OPENF AND IN TTYOPN OF FILMSC) MUST NOT ASSIGN
;THE ASSOCIATED TERMINAL IN THE DEVICE TABLES OR ACTIVATE THE LINE.
;THIS IS BECAUSE, IF THE JOB DETACHES AND ATTACHES TO ANOTHER
;TERMINAL, DOING I/O ON THIS JFN WILL GET THE NEW CONTROLLING TERMINAL.
;IF DV%OPN HAD BEEN SET ON THE ORIGINAL TERMINAL, THE DETACH WOULD
;NOT DEASSIGN IT. WHEN A DETACHED JOB DOES AN OPENF ON TTY:, THE OPENF
;WILL SUCCEED WITHOUT ACTIVATING THE LINE.  WHEN THE JOB DOES I/O ON
;THE JFN, IT WILL BLOCK UNTIL THE JOB IS ATTACHED

CKJFTT::ACVAR <W1>		;GET WORK AC
	HLRZ W1,FILDDN(JFN)	;GET THE ORIGINAL STRING FROM THE GTJFN
	MOVE W1,1(W1)		;POINT BEYOND HEADER
	TRZ W1,377		;GET RID OF POSSIBLE GARBAGE
	CAMN W1,[ASCIZ/TTY/]	;IS THIS 'TTY'?
	RET			;YES. NONSKIP
	RETSKP			;SKIP

	ENDAV.			;END ACVAR
;NORMAL BLOCK ROUTINE

OPENFW:	CALL UNLDIS		;UNLOCK AND DISMIS
	JRST OPENF0		;RETRY

;OPENF BLOCK CO-ROUTINE

OPENB:	STKVAR <SAVDEV>
	MOVEM DEV,SAVDEV	;SAVE DEV
	CALL UNLDIS		;UNLOCK & DISMS
	UMOVE JFN,1		;FETCH JFN AGAIN
	CALL CHKJFN
	 RETBAD ()		;JUNK
	 JRST OPENB1		;400000+N
	 JRST [	CAIE DEV,STRDTB	;STRING PNTR?
		JRST .+1
		RETBAD (OPNX26)]
	CAME DEV,SAVDEV		;CHECK FOR SAME DEVICE
	RETBAD (DESX4)		;NO YOU CHANGED IT ON ME
	RETSKP			;GOOD RETURN

;HERE WHEN CHKJFN RETURNED +2, INDICATING TERMINAL. IF USER SPECIFIED
;.PRIIN, .PRIOU, OR (0,,-1) RETURN SUCCESS WITHOUT ASSIGNING TERMINAL
;IN DEVICE TABLES.  IF USER GAVE 400000+TERMINAL NUMBER, FAIL

OPENB1:	CAME DEV,SAVDEV		;CHECK FOR SAME DEVICE
	RETBAD (DESX4)		;NO IT WAS CHANGED
	UMOVE T1,1		;GET USER'S INPUT AGAIN
	CAIE T1,.PRIIN		;PRIMARY INPUT?
	CAIN T1,.PRIOU		;NO. PRIMARY OUTPUT?
	SMRETN			;ALLOW THEM TO SUCCEED
	CAIE T1,-1		;CONTROLLING TERMINAL?
	RETERR (DESX1)		;NO. INVALID DESIGNATOR
	SMRETN			;YES. ALLOW SUCCESS
	SUBTTL RCDIR JSYS

;RCDIR - RECOGNIZE DIRECTORY NAME
;
; CALL:		1/ FLAGS
;		2/ POINTER TO ASCIZ DIRECTORY NAME STRING
;		RCDIR
;		1/ FLAGS INDICATING RESULT:
;			RC%NOM - NO MATCH FOR STRING
;			RC%AMB - STRING WAS AMBIGUOUS
;		2/ UPDATED POINTER IF RECOGNITION WAS PERFORMED
;
; THE LEGAL FORMATS FOR A DIRECTORY STRING ARE:
;		STR:<DIRECTORY>
;		STR:[DIRECTORY]
;		STR:
;		<DIRECTORY>
;		[DIRECTORY]

; DEFINITIONS OF PUNCTUATION CHARACTERS --

	.CHDI1==:"<"		;TYPE 1 OPENING DIRECTORY BRACKET
	.CHDT1==:">"		;TYPE 1 CLOSING DIRECTORY BARCKET
	.CHDI2==:"["		;TYPE 2 OPENING DIRECTORY BRACKET
	.CHDT2==:"]"		;TYPE 2 CLOSING DIRECTORY BRACKET
	.CHDEV==:":"		;FILE STRUCTURE DELIMITER
	.CHWL1=="*"		;FIRST WILD CHARACTER
	.CHWL2=="%"		;SECOND WILD CHARACTER

; ACCUMULATOR USAGE --
;
; Q1/	RESULT REGISTER: CAN RETURN NOM,AMB,WLD,NMD
; Q2/	COPY OF USER'S FLAGS

; LOCAL VARIABLE USAGE --

; RCDBLK - LOOKUP POINTER TO BLOCK CONTAINING COPY OF USER STRING
; RCDDPT - BYTE POINTER TO BEGINNING OF DIRECTORY STRING IN RCCBLK
; RCDSTR - CONTAINS THE STRUCTURE NAME IN ASCIZ
; RCDBK2 - LOOKUP POINTER TO BLOCK HOLDING COPY OF DIRECTORY STRING
; RCDIDP - TERMINATING,,INITAL DIRECTORY PUNCTUATION CHARACTERS
; RCDTPT - POINTER TO TAIL OF DIRECTORY STRING SO RECOGNITION CAN BE DONE
; RCDNUM - DIRECTORY DESIGNATOR
; RCDUC - UNIQUE CODE OF STRUCTURE SPECIFIED
; RCDLND - LOOKUP POINTER TO DIRECTORY NAME IF FOUND IN LOGICAL NAME
; RCDUPT - USER'S BYTE POINTER TO STRUCTURE/DIRECTORY STRING
; RCDBPR - UPDATED BYTE POINTER TO STRUCTURE FIELD STRING
.RCDIR::MCENT			;MONITOR CONTEXT ENTRY
	CALL RCDIR0		;CALL INNER ROUTINE
	 ITERR ()		;ERROR RETURN
	JRST MRETN		;GOOD RETURN

;THIS LEVEL OF ROUTINE IS NEEDED BECAUSE MRETN DOESN'T CLEAN UP FROM
;JSBVAR.

RCDIR0:	JSBVAR <RCDBLK,RCDDPT,<RCDSTR,MAXLW+2>,RCDBK2,RCDIDP,RCDTPT,RCDNUM,RCDUC,RCDLND,RCDUPT,GETDT3>
	CALL RCDIR1		;GO DO THE WORK
	 JRST [	MOVEM T1,Q1	;FAILED. SAVE ERROR CODE
		CALL RCDCLN	;RELEASE FREE SPACE IF NEEDED
		MOVE T1,Q1	;RESTORE ERROR CODE
		RETBAD]		;RETURN FAILURE
	CALL RCDCLN		;RELEASE FREE SPACE IF NEEDED
	RETSKP			;RETURN SUCCESS (Q1 MAY HAVE ERROR)

;THIS LEVEL OF CODE IS NEEDED IN ORDER TO HANDLE ERROR RETURNS
;CONSISTENTLY

RCDIR1:	SETZM RCDBLK		;INITIALIZE POINTERS TO FREE SPACE
	SETZM RCDBK2		; IF THESE ARE NON-ZERO ON RETURN TO RCDIR0
	SETZM RCDLND		; THEY POINT TO JSB SPACE
	SETZ Q1,		;INITIALIZE TO INDICATE NO ERRORS
	UMOVE Q2,1		;GET FLAGS
	LOAD T1,JSUC		;GET UNIQUE CODE OF CONNECTED STR
	MOVEM T1,RCDUC		;SAVE IT IN CASE DEVICE WASN'T SPECIFIED
	;..
	;..
	UMOVE T1,2		;GET POINTER TO DIRECTORY STRING
				; OR DIRECTORY NUMBER...
	LOAD T2,NMFLG,T1	;LOOK AT BITS 0-2
	CAIN T2,NUMVAL		;IS IT A NUMBER?
	JRST [	TXNE Q2,RC%STP	;YES. STEPPING?
		RETBAD(DESX1)	;YES - NOT ALLOWED
		CALL RCNUM	;CONVERT USER NUMBER IF NECESSARY
		MOVEM T1,RCDNUM	;SAVE (UNIQUE CODE,,DIRECTORY NUMBER)
		JRST RCD550]	;GO SEE IF DIRECTORY IS OK
	HLRZ T2,T1		;NO. SEE IF LEFT HALF IS 0
	SKIPN T2		;IF ZERO, THIS IS A JFN
	JRST [	TXNE Q2,RC%STP	;STEPPING?
		RETBAD(DESX1)	;YES - NOT ALLOWED
		CALL RCJFN	;GET THE STRUCTURE,,DIRECTORY FOR THIS JFN
		 RETBAD		;INVALID. RETURN ERROR
		MOVEM T1,RCDNUM	;SAVE (STRUCTURE UNIQUE CODE,,DIRECTORY NUMBER)
		JRST RCD550]	;GO SEE IF DIRECTORY IS OK

;THIS IS A STRING POINTER. COPY THE STRING TO BE RECOGNIZED

	MOVEM T1,RCDUPT		;SAVE FOR COPYING BACK HERE LATER
	CALL PTRCHK		;CHECK THE BYTE POINTER FOR LEGALITY
	 RETBAD(DESX1)		;NOT LEGAL...INVALID DESIGNATOR ERROR
	MOVE T1,RCDUPT		;GET THE POINTER BACK
	MOVEI T2,2*MAXLW+1	;T2/ALLOW ROOM FOR LOGICAL NAME AND DIRECTORY PLUS
				; PUNCTUATION
	CALL CPYUSR		;COPY STRING FROM USER SPACE
	 RETBAD (RCDIX1)	;FAILED, RETURN "INSUFFICIENT RESOURCES" ERROR
	MOVEM T1,RCDBLK		;SAVE LOOKUP POINTER TO BLOCK CONTAINING STRING
	UMOVEM T3,2		;UPDATE THE USER'S BYTE POINTER

; DETERMINE IF A STRUCTURE NAME WAS INCLUDED IN THE STRING

	LDB T2,[POINT 7,1(T1),6] ;GET FIRST CHARACTER OF STRING
	HRLI T1,(POINT 7,0,35)	;FORM ILDB POINTER TO BEGINNING OF STRING
	MOVEM T1,RCDDPT		;ASSUME STRING STARTS WITH DIRECTORY
	CAIE T2,.CHDI1		;DOES THE STRING BEGIN WITH VALID
	CAIN T2,.CHDI2		;  DIRECTORY PUNCTUATION ?
	JRST RCD050		;YES, GO PROCESS DIRECTORY
	;..
	;..
; A DEVICE FIELD WAS SUPPLIED - COPY IT TO THE STACK
;STOP AT A NULL OR COLON OR WHEN THE MAXIMUM ALLOWED NUMBER OF
;CHARACTERS ARE DETECTED

	MOVEI T1,RCDSTR		;GET ADDRESS OF BLOCK ON STACK
	HRLI T1,(POINT 7,0,35)	;POINT BEYOND HEADER
	MOVE T2,RCDBLK		;GET ADDRESS OF BLOCK CONTAINING STRING
	HRLI T2,(POINT 7,0,35)	;FORM POINTER TO STRUCTURE NAME
	MOVEI T3,MAXLC+1	;COUNT IS MAX # OF CHARS IN NAME + ":"
RCD020:	ILDB T4,T2		;GET NEXT CHARACTER IN USER'S STRING
	IDPB T4,T1		;COPY IT TO THE STACK
	CAIE T4,.CHDEV		;WAS THIS A COLON?
	CAIN T4,.CHNUL		;NO. NULL?
	SKIPA			;COLON OR NULL
	SOJG T3,RCD020		;NEITHER. MAXIMUM CHARACTERS READ?

;DEVICE FIELD HAS BEEN COPIED. IF A COLON WAS NOT DETECTED, IT IS
;NOT A VALID DEVICE FIELD.

	CAIE T4,.CHDEV		;YES. ENDED WITH COLON?
	JRST [	TXNE Q2,RC%EMO	;NO. EXACT MATCH ONLY?
		RETBAD (RCDIX3)	;YES. INVALID STRUCTURE NAME
		MOVX Q1,RC%AMB	;NO. INDICATE AMBIGUOUS STRUCTURE NAME
		UMOVEM Q1,1	;TELL THE USER
		RETSKP]		;INDICATE SUCCESS
	SETZ T4,		;FOUND COLON. MAKE IT END WITH NULL
	DPB T4,T1		; FOR CHKLND
	MOVEM T2,RCDDPT		;SAVE POINTER TO BEGINNING OF DIRECTORY NAME
	;..
	;..

;DEVICE FIELD MAY CONTAIN LOGICAL NAME.  IF SO, GET THE DEVICE AND
;DIRECTORY SPECIFIED BY THE LOGICAL NAME.

	MOVEI T1,MAXLW+1	;SET UP LENGTH OF BLOCK CONTAINING DEVICE FIELD
	MOVEM T1,RCDSTR		;SAVE IT FOR CHKLND
	MOVEI T1,RCDSTR		;T1/LOCATION OF BLOCK WHERE DEVICE FIELD IS
	SETOM T2		;T2/WANT DIRECTORY STRING AS WELL AS DEVICE
	CALL CHKLND		;IF DEVICE FIELD IS LOGICAL NAME, CONVERT TO
				; DEVICE AND DIRECTORY
	MOVEM T2,RCDLND		;SAVE POINTER TO DIRECTORY NAME

;T2 POINTS TO LAST DEVICE FIELD IN CHAIN OF LOGICAL NAME DEFINITIONS
;SEE IF THIS IS REALLY A STRUCTURE AND GET ITS UNIQUE CODE

	CALL STDEVP		;SEE IF DEVICE FIELD IS A KNOWN DEVICE
	 JRST RCSNM		;STRUCTURE NOT UP
	HLRZ T2,T1		;GET LH OF DEVICE DESIGNATOR
	CAIE T2,.DVDES+.DVDSK	;IS IT A DISK?
	RETBAD (STRX01)		;NO. RETURN "STRUCTURE IS NOT MOUNTED"
	HRRZ T2,T1		;GET STRUCTURE UNIQUE CODE
	CAIN T2,-1		;IS THIS "DSK"?
	JRST [ LOAD T1,JSUC	;YES, GET CONNECTED STR UNIQUE CODE
	       JRST RCD040]
	LDB T2,[POINT STRNS,T1,35] ;GET STRUCTURE INDEX
	MOVE T2,STRTAB(T2)	;GET SDB ADDRESS
	LOAD T2,STRJB,(T2)	;GET FORK INIT'ING STRUCTURE
	SKIPE T2		;SKIP IF NOT BEING INIT'ED
	 JRST [	CAMN T2,FORKX	;Are we the fork doing it?
		JRST .+1	;Yes, so that's ok
		MOVEI T1,STDVX1	;No, say "No such device",
		JRST RCSNM]	;STRUCTURE NOT UP
RCD040:	HRRZM T1,RCDUC		;SAVE UNIQUE CODE FOR STRUCTURE
	;..
;HERE TO PROCESS DIRECTORY STRING.  IF NONE WAS INPUT, AND A LOGICAL NAME
;WAS INPUT, USE THE LOGICAL NAME DEFINITION. IF NOT, ASSUME CONNECTED
;DIRECTORY.
	;..

RCD050:	LDB T1,[POINT 6,RCDUC,35] ;[7.1063]Get the structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is the structure offline?
	 RETBAD	()		;[7.1063]Return  "Structure is offline"
	ILDB T1,RCDDPT		;GET FIRST CHARACTER OF DIRECTORY STRING
	JUMPE T1,RCD060		;IS THERE A STRING?

;A DIRECTORY STRING WAS INPUT BY THE USER

	CALL GETDIR		;YES. CONVERT TO DIRECTORY NUMBER
	 RETBAD			;FAILED. ERROR CODE IS IN T1
	JRST RCD500		;GO CLEAN UP

;STRUCTURE NOT MOUNTED.  SAY "NO MATCH", BUT GO ON, TO MAKE SURE
;SYNTAX OF DIRECTORY NAME IS CORRECT.

RCSNM:	TXO Q1,RC%NOM		;MARK THAT THERE'S NO MATCH
	JRST RCD050		;PROCEED AND CHECK DIRECTORY NAME SYNTAX

;NO STRING WAS INPUT.  SEE IF THERE IS A LOGICAL NAME DEFINITION

RCD060:	SKIPN T1,RCDLND		;NO. WAS ANYTHING FOUND?
	JRST RCD080		;NO.

;A LOGICAL NAME DEFINITION WAS FOUND.  CONVERT TO DIRECTORY NUMBER

	TQO <NREC>		;Directory was found in logical name. Indicate
				; recognition not allowed for DIRLUK
	HRRZ T3,RCDLND		;Get address of logical name string block
	AOS T3			;Make it start at beginning of text
	HRLI T3,440700		;Make it a byte pointer
	HRRZ T4,RCDDPT		;Get address of directory name block
	HRLI T4,440700		;Make it a byte pointer
	MOVEM T4,RCDDPT		;Save it
	MOVEI T1,.CHDI1		;Get opening bracket
	IDPB T1,T4		;Write it to first byte
RCD062:	ILDB T1,T3		;Get byte from logical name
	JUMPE T1,RCD064		;If end, clean up
	IDPB T1,T4		;Copy it to directory name
	JRST RCD062		;Go do next byte
RCD064:	MOVEI T1,.CHDT1		;End of logical name, get closing bracket
	IDPB T1,T4		;Append it to end
	MOVEI T1,.CHNUL		;Get a nul
	IDPB T1,T4		;Make sure we have an ASCIZ string
	JRST RCD050		;Go try again.
;NO DIRECTORY WAS SPECIFIED.  FIND OUT WHAT DIRECTORY THE USER IS
;CONNECTED TO AND USE ITS NAME

RCD080:	TXO Q2,RC%EMO		;DON'T ALLOW RECOGNITION SINCE DIRST WILL CREATE
				; THE STRING
	CALL GTCSCD		;GET CONNECTED STRUCTURE UNIQUE CODE,,DIRECTORY
	MOVE T2,T1		;T2/(STRUCTURE UNIQUE CODE,,DIRECTORY)
	HRRO T1,RCDBLK		;T1/POINTER TO WHERE STRING IS TO BE WRITTEN
	AOS T1			;POINT BEYOND HEADER
	DIRST			;GET STRUCTURE AND DIRECTORY
	 RETBAD (RCDIX2)	;RETURN "INVALID DIRECTORY SPECIFICATION"
	MOVE T2,RCDBLK		;POINT TO START OF STRING
	HRLI T2,(POINT 7,0,35)
RCD051:	ILDB T1,T2		;GET THE NEXT CHARACTER
	CAIE T1,.CHDEV		;IS IT A DEVICE TERMINATOR?
	JRST RCD051		;NO. KEEP LOOKING
	MOVEM T2,RCDDPT		;YES. SAVE POINTER TO THIS CHARACTER
	ILDB T1,RCDDPT		;GET OPENING BRACKET OF DIRECTORY STRING
	CALL GETDIR		;CONVERT DIRECTORY NAME TO NUMBER
	 RETBAD			;FAILED. ERROR CODE IS IN AC 1
	JRST RCD500		;GO CLEAN UP
;HERE WHEN ENTIRE STRING HAS BEEN PARSED. Q1 CONTAINS FLAGS INDICATING
;RESULTS. RCDUC HAS STRUCTURE NUMBER; RCNUM HAS DIRECTORY NUMBER

RCD500:
	JUMPN Q1,RCD550		;IF NO MATCH OF AMBIGUOUS, GO RETURN VALUES
	HRRZ T1,RCDUC		;GET STRUCTURE NUMBER
	HRLM T1,RCDNUM		;SAVE UNIQUE PART OF DIRECTORY DESIGNATOR

; RETURN VALUES TO THE USER

RCD550:	TXNE Q1,RC%NOM!RC%AMB!RC%NMD ;IF NO MATCH, AMBIG, OR NO MORE DIR
	JRST RCD600		;DONT ATTEMPT MAPPING DIR
	LDB T1,[POINT 6,RCDUC,35] ;[7.1063]Get the structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is the structure offline?
	 RETBAD ()		;[7.1063]Return "Structure is offline"
	TXNN Q2,RC%STP		;STEPPING??
	TXNE Q1,RC%WLD		;NO, WAS WILDCARD FOUND?
	JRST RCD555		;YES - DIR ALREADY MAPPED
	MOVE T1,RCDNUM		;GET DIRECTORY NUMBER
	CALL SETDIR		;MAP DIRECTORY
	 RETBAD ()		;FAILED, PASS ERROR UP
RCD555:	MOVE T4,DIRORA		;GET BASE ADDRESS OF DIRECTORY
	LOAD T1,DRMOD,(T4)	;GET MODE BITS
	TXZ T1,RC%NOM!RC%AMB!RC%NMD!RC%WLD	;DON'T SET THESE FROM T1
	TXO T1,MD%SA		;ALWAYS ALLOW STRING ACCOUNTS
	IOR Q1,T1		;ADD MODE BITS TO FLAG WORD
	CALL USTDIR		;UNLOCK DIRECTORY
RCD600:	UMOVEM Q1,1		;RETURN FLAGS GIVING RESULT OF LOOKUP
	MOVE T1,RCDNUM		;GET DIRECTORY NUMBER
	TXNN Q1,RC%NOM!RC%AMB	;NO MATCH OR AMBIGUOUS ?
	UMOVEM T1,3		;NO, SUCCESS, SO RETURN DIRECTORY NUMBER
	RETSKP			;RETURN TO USER
;RCDCLN - ROUTINE TO CLEAN UP AFTER RCDIR

;	CALL RCDCLN

;RETURNS +1: ALWAYS

RCDCLN:	SKIPN T2,RCDBLK		;DO WE HAVE A BLOCK FOR USER'S ORIGNAL STRING?
	JRST RCDCL1		;NO. NO NEED TO RELEASE IT
	MOVEI T1,JSBFRE		;YES. T1/ INDICATES JSB FREE SPACE
	CALL RELFRE		;RELEASE THE BLOCK
	OKINT

RCDCL1:	SKIPN T2,RCDBK2		;DO WE HAVE A BLOCK FOR DIRECTORY STRING?
	JRST RCDCL2		;NO. NO NEED TO RELEASE IT
	MOVEI T1,JSBFRE		;YES. T1/ INDICATES JSB FREE SPACE
	CALL RELFRE		;RELEASE THE BLOCK
	OKINT

RCDCL2:	SKIPN T2,RCDLND		;DID CHKLND RETURN A BLOCK FOR DIRECTORY STRING?
	RET			;NO. NO NEED TO RELEASE IT
	CAMN T2,[-1]		;DID CHKLND FIND A STAR?
	RET			;YES. NO BLOCK TO RELEASE
	MOVEI T1,JSBFRE		;YES. T1/ INDICATES JSB FREE SPACE
	CALL RELFRE		;RELEASE THE BLOCK
	OKINT
	RET
;GETDIR - GET THE DIRECTORY NUMBER

;ACCEPTS:
;	T1/FIRST CHARACTER IN DIRECTORY STRING
;	Q2/USER'S FLAGS

;	CALL GETDIR

;RETURNS +1: FAILURE
;		1/ERROR CODE
; 	 +2: SUCCESS
;		DIRECTORY NUMBER IN RCDNUM
;		RECOGNIZED STRING COPIED BACK TO USER

GETDIR:	CAIE T1,.CHDI1		;DOES THE DIRECTORY STRING BEGIN WITH
	CAIN T1,.CHDI2		;  VALID DIRECTORY PUNCTUATION ?
	SKIPA			;YES, SAVE INITIAL CHARACTER
	RETBAD (RCDIX2)	;NO, RETURN "INVALID DIRECTORY" SPEC"
	MOVEM T1,RCDIDP		;SAVE THE INITIAL DIRECTORY PUNCTUATION
	MOVEI T4,.CHDT1		;GET TYPE 1 TERMINATOR
	CAIE T1,.CHDI1		;WAS THIS A TYPE 1 OPENER?
	MOVEI T4,.CHDT2		;NO. GET TYPE 2 TERMINATOR
	HRLM T4,RCDIDP		;SAVE EXPECTED TERMINATOR

; ISOLATE THE DIRECTORY NAME STRING

	MOVEI T2,MAXLW+2	;GET NUMBER OF WORDS NEEDED FOR STRING
	NOINT			;NOINT WHILE JSB SPACE IS ASSIGNED
	CALL ASGJFR		;ASSIGN JSB FREE SPACE
	 RETBAD (RCDIX1,<OKINT>);RETURN "INSUFFICIENT RESOURCES"
	MOVEM T1,RCDBK2		;SAVE LOOKUP POINTER TO TEMPORARY BLOCK
	HRLI T1,(POINT 7,0,35)	;POINT BEYOND HEADER
	MOVE T2,RCDDPT		;GET POINTER TO DIRECTORY WITHIN USER STRING
	MOVEI T3,MAXLC+1	;MAX # OF CHARS IN DIRECTORY NAME + TERMINATOR
	;..
	;..
;COPY EACH CHARACTER STARTING WITH THE LEFT BRACKET UP TO INCLUDING
;EITHER A NULL OR MATCHING RIGHT BRACKET OR UNTIL THE MAXIMUM NUMBER
;OF CHARACTERS IS READ

GETD05:	ILDB T4,T2		;GET NEXT CHARACTER
	MOVEM T1,RCDTPT		;SAVE POINTER TO END OF STRING FOR DIRLUK
				; (LDB WOULD GET THE LAST CHARACTER COPIED)
	IDPB T4,T1		;COPY IT TO FREE SPACE
	CAIE T4,.CHWL1		;WILDCARD?
	CAIN T4,.CHWL2		; ???
	TXO Q1,RC%WLD		;YES - REMEMBER ONE SEEN
	MOVEM T3,GETDT3		;SAVE T3
	HRRZ T3,RCDIDP		;[7304] GET BACK OPENING BRACKET
	CAMN T4,T3		;[7304] IS THIS CHARACTER AN ADDITIONAL OPENER?
	RETBAD (RCDIX2)		;[7304] YES, GIVE ERROR NOW - INVALID DIRECTORY SPEC
	HLRZ T3,RCDIDP		;GET EXPECTED TERMINATING BRACKET
	CAMN T4,T3		;IS THE CURRENT CHARACTER A BRACKET?
	JRST [	TXO Q2,RC%EMO	;YES. DON'T ALLOW RECOGNITION
		JRST GETD07]	; AND DON'T LOOK AT MORE CHARACTERS
	CAIN T4,.CHNUL		;NO. IS IT A NULL?
	JRST GETD07		;BRACKET OR NULL. STOP COPYING
	MOVE T3,GETDT3		;RESTORE COUNTER
	SOJGE T3,GETD05		;END OF SPACE?
	;..
	;..

;END OF STRING. IF LAST CHARACTER WAS BRACKET, IT MUST BE FOLLOWED
;BY NULL. IF NOT, MUST BE DOING RECOGNITION. OTHERWISE ERROR.
;NOTE THAT IF THE STRING ENDS IN NULL, AND THE LAST NON-NULL IS
;THE WRONG KIND OF BRACKET, THE ENTIRE STRING INCLUDING THE BRACKET
;WILL BE PASSED TO DIRLUK, WHICH WILL RETURN NO-MATCH

GETD07:	TXNN Q1,RC%WLD		;WILDCARD FOUND?
	JRST GETD09		;NO
	TXO Q2,RC%EMO		;YES - ACT LIKE EXACT MATCH ONLY
	TXNN Q2,RC%AWL		;WILDCARD ALLOWED?
	RETBAD (RCDIX2)		;NO - ERROR
GETD09:	MOVE T3,RCDBK2		;GET POINTER TO STRING BLOCK
	SKIPN 1(T3)		;IS THE STRING NULL?
	JRST [	SETO T1,	;YES, THE STRING IS AMBIGUOUS
		JRST GETD21]
	HLRZ T3,RCDIDP		;GET EXPECTED TERMINATING BRACKET
	CAME T3,T4		;DIRECTORY TERMINATED BY EXPECTED BRACKET ?
	JRST [	TXNN Q2,RC%EMO	;NO. DOING RECOGNITION?
		JRST GETD10	;YES, CONTINUE
		RETBAD (RCDIX2)]	;NO. RETURN "INVALID DIRECTORY" ERROR
	ILDB T4,T2		;YES. GET THE NEXT CHARACTER
	CAIE T4,.CHNUL		;IS IT A NULL?
	RETBAD (RCDIX2)		;NO. MUST BE AN ASCIZ STRING
	DPB T4,T1		;REPLACE BRACKET BY NULL SO THAT
				; DIRLUK WILL SUCCEED
	;..
; FORM STANDARD LOOKUP POINTER AS EXPECTED BY DIRLUK: -<NWORDS-1>,,ADR-1

	;..
GETD10:	TXNE Q1,RC%NOM		;HAVE WE ALREADY DECIDED THERE'S "NO MATCH"?
	 RETSKP			;YES, SO DON'T BOTHER LOOKING UP DIRECTORY
	MOVE T2,RCDBK2		;POINT TO BLOCK CONTAINING STRING
	SUB T1,T2		;COMPUTE NUMBER OF WORDS WRITTEN
	SOS T1			;NUMBER -1
	MOVNS T1		;-<NWORDS-1>
	HRLM T1,RCDBK2		;FINISH THE LOOKUP POINTER

; SET UP FOR RECOGNITION AND SEE IF RECOGNITION WAS REQUESTED

	TQZ <NREC>		;ASSUME RECOGNITION WANTED
	TXNN Q2,RC%EMO		;EXACT MATCH OLY ?
	JRST GETD20		;NO, GO DO RECOGNITION
	TQO <NREC>		;YES, INDICATE NO RECOGNITION
	TXNN Q2,RC%STP		;STEPPING DIRECTORY?
	TXNE Q1,RC%WLD		;WILDCARD?
	JRST GETD25		;YES - GO PROCESS

; GET DIRECTORY NUMBER, RECOGNIZING IF NECESSARY

GETD20:	MOVE T1,RCDBK2		;GET ADDRESS OF BLOCK HOLDING DIRECTORY STRING
	HRRZ T2,RCDUC		;GET STRUCTURE UNIQUE NUMBER
	MOVE T3,RCDTPT		;GET POINTER TO TAIL OF STRING
	CALL DIRLUK		;LOOKUP DIRECTORY
GETD21:	 JRST [	MOVX Q1,RC%NOM	;FAILED, ASSUME NO MATCH AT ALL
		SKIPN T1	;NO MATCH OR AMBIGUOUS ?
		RETSKP		;NO MATCH. RETURN SUCCESS WITH Q1 SET
		MOVX Q1,RC%AMB	;AMBIGUOUS
		TXNN Q2,RC%PAR	;IS PARTIAL RECOGNITION ALLOWED?
		RETSKP		;NO. RETURN SUCCESS (Q1 INDICATES ERROR)
		JRST GETD30]	;YES. GO UPDATE USER'S STRING
	MOVEM T1,RCDNUM		;SAVE DIRECTORY NUMBER

; REASSEMBLE STRING IF RECOGNITION WAS DONE

GETD30:	TXNE Q2,RC%EMO		;EXACT MATCH ONLY DESIRED ?
	JRST GETD40		;YES. DON'T UPDATE THE STRING
	MOVE T1,RCDDPT		;GET POINTER TO DIRECTORY IN RCDBLK
	MOVE T2,RCDBK2		;GET ADDRESS OF TEMPORARY BLOCK
	HRROI T2,1(T2)		;FORM POINTER TO NAME AS FINISHED BY DIRLUK
	SETZM T3		;COPY UNTIL A NULL IS ENCOUNTERED
	SOUT			;APPEND DIRECTORY BACK TO USER'S STRING
	 ERJMP [RETBAD (RCDIX4)] ;ERROR, RETURN "INTERNAL ERROR"
	TXNN Q1,RC%AMB		;AMBIGUOUS?
	JRST [	HLRZ T4,RCDIDP	;NO. GET CLOSING BRACKET FOR DIRECTORY STRING
		IDPB T4,T1	;TERMINATE DIRECTORY
		JRST .+1]
	MOVEI T4,.CHNUL		;GET A NULL
	IDPB T4,T1		;FORM ASCIZ STRING
	JRST GETD40
;HERE IF A WILDCARD MASK WAS INPUT OR IF STEPPING

GETD25:	HRLZ T1,RCDUC		;GET STRUCTURE UNIQUE CODE
	TXNE Q2,RC%STP		;STEPPING?
	UMOVE T1,3		;YES - GET USERS DIR
	HLRZ T2,T1		;CHECK UNIQUE CODE
	CAME T2,RCDUC		;SAME?
	RETBAD (RCDIX2)		;NO. RETURN "INVALID DIRECTORY SPEC"
GETD26:	MOVEI F1,0		;CLEAR FLAGS
	TQO <STEPF,DIRSF>	;SET STEP FLAGS
	HRRZ T3,RCDBK2		;GET ADR OF WILD MASK BLOCK
	CALL MDDDIR		;STEP DIR
	 JRST GETD28		;ERROR
	MOVEM T1,RCDNUM		;SAVE DIRNUM
	MOVE T4,DIRORA		;GET DIR NAME STRING
	LOAD T4,DRNAM,(T4)	; ...
	ADD T4,DIRORA		;AS ABSOLUTE ADDRESS
	MOVSI T1,(<POINT 7,0(T4),35>)	;BUILD BYTE POINTER
	HRRZ T2,RCDBK2		;GET POINTER TO WILD MASK
	CALL CHKWLD		;CHECK FOR MATCH
	 SKIPA			;NO MATCH
	JRST GETD40		;MATCH - RETURN THIS DIR
	CALL USTDIR		;UNLOCK THIS DIR
	MOVE T1,RCDNUM		;NO MATCH - STEP THIS DIR
	JRST GETD26		; ...

GETD28:	CAIE T1,GJFX32		;NO MORE DIRS?
	RETBAD (RCDIX2)		;NO. RETURN "INVALID DIRECTORY SPEC"
	TXNN Q2,RC%STP		;YES, ARE WE STEPPING?
	TXOA Q1,RC%NOM		;NO, SET NO MATCH
	TXO Q1,RC%NMD		;YES, SET NO MORE DIRECTORIES IN GROUP
	SETZB T1,RCDNUM		;RETURN 0
	;..
	;..
; COPY COMPLETED STRING TO USER SPACE IF DOING RECOGNITION

GETD40:	TXNE Q2,RC%EMO		;EXACT MATCH ONLY?
	RETSKP			;YES. DON'T COPY BACK TO USER
	MOVE T1,RCDUPT		;GET ORIGINAL POINTER IN USER SPACE
	MOVE T2,RCDBLK		;GET LOOKUP POINTER TO BLOCK
	CALL CPYTUS		;COPY STRING BACK TO USER
	RETSKP
;RCNUM - GET STRUCTURE,,DIRECTORY NUMBER FROM DIRECTORY OR USER NUMBER

;ACCEPTS:
;	T1/(STRUCTURE UNIQUE CODE,,DIRECTORY NUMBER)
;		OR
;	   (USRLH,,DIRECTORY NUMBER)

;	CALL RCNUM

;RETURNS +1: ALWAYS,
;	T1/(STRUCTURE UNIQUE CODE,,DIRECTORY NUMBER)

;THIS ROUTINE DETECTS WHETHER THE INPUT IS A DIRECTORY NUMBER OR USER
;NUMBER.  IF A DIRECTORY NUMBER, IT RETURNS IT INTACT.  IF A USER NUMBER,
;IT RETURNS THE DIRECTORY NUMBER ON PS. RCDIR WILL CHECK THE VALIDITY OF THE
;DIRECTORY NUMBER LATER BY CALLING SETDIR

RCNUM:
	HLRZ T2,T1		;GET THE LEFT HALF
	CAIE T2,USRLH		;IS IT A USER NUMBER?
	RET			;NO. A DIRECTORY NUMBER
	MOVE T2,LGSIDX		;[7.1112]Get number of Login Structure
	MOVE T2,STRTAB(T2)	;POINT TO START OF SDB FOR PUBLIC STRUCTURE
	LOAD T2,STRUC,(T2)	;GET UNIQUE CODE FOR PUBLIC STRUCTURE
	HRL T1,T2		;USE IT IN THE DIRECTORY NUMBER
	RET
;RCJFN - GET (STRUCTURE UNIQUE CODE,,DIRECTORY NUMBER) FROM JFN

;ACCEPTS:
;	T1/JFN

;	CALL RCJFN

;RETURNS +1: FAILURE
;	 +2: SUCCESS,
;	T1/(STRUCTURE UNIQUE CODE,,DIRECTORY NUMBER)

RCJFN:
	MOVE JFN,T1		;JFN/THE JFN
	CALL DSKJFN		;SEE IF VALID JFN, LOCK JFN AND STRUCTURE
	 RETBAD			;INVALID
	LOAD T1,FLUC,(JFN)	;GET STRUCTURE UNIQUE CODE
	HRLZS T1		;PUT IN LH
	HRR T1,FILDDN(JFN)	;GET DIRECTORY NUMBER
	CALL UNLCKF		;UNLOCK THE JFN AND STRUCTURE
	RETSKP
	SUBTTL RCUSR JSYS

;RCUSR - RECOGNIZE USER NAME

;ACCEPTS:
;	T1/ FLAGS
;	T2/ POINTER TO USER NAME

;	RCUSR

;RETURNS +1: ALWAYS
;		T1/ FLAGS
;		T2/ UPDATED POINTER
;		T3/ USER NUMBER

;INPUT FLAGS:
;	RC%PAR (1B14) - PARTIAL RECOGNITION IS ALLOWED
;	RC%STP (1B15) - STEP TO THE NEXT USER NUMBER
;	RC%AWL (1B16) - ALLOW WILD CARDS
;	RC%EMO (1B17) - EXACT MATCH ONLY (NO RECOGNITION)

;OUTPUT FLAGS:
;	RC%ANA (1B1) - ALPHANUMERIC ACCOUNTS ALLOWED
;	RC%RLM (1B2) - REPEAT MESSAGE OF THE DAY
;	RC%NOM (1B3) - NO MATCH
;	RC%AMB (1B4) - AMBIGUOUS
;	RC%NMD (1B5) - NO MORE DIRECTORIES

;CAN ITRAP ON MONITOR ERROR

.RCUSR::MCENT			;MONITOR CONTEXT ENTRY
	TRVAR <RCUBLK,RCUNUM,RCUUPT,RCUTPT,RCUMOD>
	CALL RCUS0		;CALL ROUTINE TO DO THE WORK
	 JRST [	MOVEM T1,Q1	;FAILED. SAVE ERROR CODE
		CALL RCUCLN	;RELEASE FREE SPACE IF NECESSARY
		MOVE T1,Q1	;RESTORE ERROR CODE
		ITERR]
	CALL RCUCLN		;RELEASE FREE SPACE IF NECESSARY
	JRST MRETN		;SUCCEEDED. TAKE NON-SKIP RETURN
;RCUS0 - ROUTINE TO DO RCUSR'S WORK.  ARGUMENTS ARE THE SAME AS
;FOR RCUSR

RCUS0:	UMOVE Q2,1		;Q2/USER'S FLAGS
	SETZ Q1,		;INITIALIZE RETURN FLAGS
	SETZM RCUBLK		;INDICATE NO FREE SPACE YET

; COPY NAME STRING FROM USER SPACE, AND STORE IT IN JSB FREE SPACE

	UMOVE T1,2		;GET POINTER TO NAME STRING
	MOVEM T1,RCUUPT		;SAVE IT FOR COPYING TO LATER
	CALL CPYFUS		;GO NOINT AND COPY STRING FROM USER SPACE
	 RETBAD (RCUSX1)	;FAILED, INSUFFICIENT RESOURCES
	UMOVEM T3,2		;RETURN UPDATED POINTER TO USER
	MOVEM T1,RCUBLK		;SAVE LOOKUP POINTER TO BLOCK
	MOVEM T2,RCUTPT		;SAVE POINTER TO END OF STRING
	MOVEI T2,STKCD1		;CODE FOR STRINGS
	CALL JSBSTK		;SAVE ADDRESS OF STRING ON JSB STACK
	OKINT			;INTERRUPTS ALLOWED NOW
	MOVE T1,RCUBLK		;RESTORE AC'S
	MOVE T2,RCUTPT		;THAT WERE TRASHED

;PARSE THE STRING LOOKING FOR WILD CARD CHARACTERS

	HRLI T1,(POINT 7,0,35)	;POINT BEYOND HEADER WORD
	MOVEI T3,MAXLC		;MAXIMUM ALLOWED CHARACTERS
RCU030:	ILDB T2,T1		;GET NEXT CHARACTER
	CAIE T2,.CHWL1		;WILD CARD?
	CAIN T2,.CHWL2
	TXO Q1,RC%WLD		;YES. INDICATE WILD CARD FOUND
	CAIN T2,.CHNUL		;NULL?
	JRST RCU050		;YES. END OF STRING
	SOJGE T3,RCU030		;GO GET NEXT CHARACTER UNLESS REACHED MAX

;HERE WHEN STRING HAS BEEN PARSED.  Q1 HAS RC%WLD SET IF A WILD
;CARD WAS FOUND

RCU050:	TXNN Q1,RC%WLD		;WILD CARD FOUND?
	IFNSK.			;No
	  TXNN Q2,RC%STP	;Was stepping specified by user?
	  JRST RCU070		;No, continue
	  MOVX Q1,RC%NMD	;Yes, return error
	  JRST RCU210
	ENDIF.
	TXO Q2,RC%EMO		;YES. FORCE EXACT MATCH
	TXNN Q2,RC%AWL		;ARE WILD CARDS ALLOWED?
	RETBAD (STRX08)		;RETURN ERROR
;USER NAME IS A DIRECTORY ON PS.  GET DIRECTORY NUMBER ON THAT STRUCTURE

RCU070:	MOVE T1,LGSIDX		;[7.1112]Get STRTAB offset for Login Structure
	CALL STRCNV		;CONVERT TO UNIQUE CODE
	 RETBAD (RCDIX4)	;RETURN 'INTERNAL ERROR'
	TXNN Q2,RC%EMO		;EXACT MATCH?
	TQZA <NREC>		;NO. ALLOW RECOGNITION
	JRST [	TXNN Q2,RC%STP	;YES. STEPPING TO NEXT USER?
		TXNE Q1,RC%WLD	; OR FOUND A WILD CARD?
		JRST RCU110	;YES. GO PROCESS IT
		TQO <NREC>	;NO. INDICATE NO RECOGNITION
		JRST .+1]

;NO WILD CARD WAS FOUND. CALL DIRLUK TO FIND DIRECTORY CORRESPONDING
;TO GIVEN USER NAME

	MOVE T2,T1		;2/UNIQUE CODE FOR PS:
	MOVE T1,RCUBLK		;1/POINTER TO USER NAME
	MOVE T3,RCUTPT		;3/POINTER TO END OF STRING
	CALL DIRLUK		;CONVERT DIRECTORY NAME TO NUMBER ON PS
	 JRST [	MOVX Q1,RC%NOM	;INITIALLY ASSUME NO MATCH
		SKIPN T1	;AMBIGUOUS?
		JRST RCU210	;NO. RETURN NO MATCH
		MOVX Q1,RC%AMB	;YES. RETURN THAT BIT INSTEAD
		TXNN Q2,RC%PAR	;IS USER ALLOWING PARTIAL RECOGNITION
		JRST RCU210	;NO. DON'T COPY THE STRING
		JRST RCU090]	;YES. GO COPY THE STRING
	HRLI T1,USRLH		;PUT THE REQUIRED CODE IN THE LH FOR A USER NAME
	MOVEM T1,RCUNUM		;SAVE IT FOR LATER

;IF USER WANTED RECOGNITION, COPY COMPLETED STRING BACK TO USER

RCU090:	TXNE Q2,RC%EMO		;EXACT MATCH ONLY?
	JRST RCU170		;YES. DON'T COPY THE STRING BACK TO THE USER
	MOVE T1,RCUUPT		;T1/USER'S ORIGINAL BYTE POINTER
	MOVE T2,RCUBLK		;T2/LOOKUP POINTER TO STRING
	CALL CPYTUS		;COPY BACK THE STRING AS UPDATED BY DIRLUK
				; AND UPDATE USER'S BYTE POINTER
	JRST RCU170		;GO FINISH
;A WILD CARD WAS FOUND OR STEPPING USER NAME.
;GET STARTING DIRECTORY NUMBER FROM USER.
;CALL MDDDIR TO GET NEXT DIRECTORY, CHKWLD TO SEE IF USER'S STRING
;MATCHES THE DIRECTORY.  IF NOT, CALL MDDDIR AGAIN.  CONTINUE UNTIL
;EITHER A MATCH OCCURS OR MDDDIR RETURNS FAILURE.

RCU110:	HRLZS T1		;IF NOT STEPPING, T1/(PS UNIQUE CODE,,0)
	TXNE Q2,RC%STP		;STEPPING?
	JRST [	UMOVE T1,3	;YES. GET STARTING USER NUMBER
		HLRZ T2,T1	;GET LEFT HALF
		CAIE T2,USRLH	;IS IT A VALID USER NUMBER?
		RETBAD (STRX07)	;NO. RETURN ERROR
		CALL CNVDIR	;CONVERT TO DIRECTORY NUMBER
		JRST .+1]

;GET THE NEXT DIRECTORY AND SEE IF IT MATCHES

RCU130:	MOVEI F1,0		;INITIALIZE FLAGS FOR MDDDIR
	TQO <STEPF,DIRSF>	;INDICATE STEPPING, STEPPING DIRECTORY
	MOVEI T2,.RCUSR		;T2/ TELL WHERE WE'RE CALLING FROM
	HRRZ T3,RCUBLK		;T3/ ADDRESS OF BLOCK CONTAINING NAME
	CALL MDDDIR		;GET THE NEXT DIRECTORY
	 JRST RCU150
	MOVEM T1,RCUNUM		;SAVE DIRECTORY NUMBER
	MOVE T4,DIRORA		;SET UP BYTE POINTER TO NAME STRING
	LOAD T4,DRNAM,(T4)	; IN THE DIRECTORY THAT MDDDIR RETURNED
	ADD T4,DIRORA		; MAPPED
	MOVSI T1,(<POINT 7,0(T4),35>)	;T1/ BYTE POINTER TO NAME STRING
	HRRZ T2,RCUBLK		;T2/ ADDRESS OF USER'S STRING
	CALL CHKWLD		;DOES IT MATCH?
	 SKIPA			;NO
	JRST [	MOVE T2,DIRORA	;YES. THIS IS A USER NAME ONLY
		LOAD T2,DRMOD,(T2) ; IF THE DIRECTORY IS NOT FILES-ONLY
		TXNE T2,MD%FO	;IS IT?
		JRST .+1	;FILES-ONLY. GO GET ANOTHER DIRECTORY
		MOVE T1,RCUNUM	;GET THE DIRECTORY NUMBER
		HRLI T1,USRLH	;CONVERT IT TO A USER NUMBER
		MOVEM T1,RCUNUM	; TO RETURN TO THE USER
		JRST RCU170]
	CALL USTDIR		;UNMAP THIS DIRECTORY
	MOVE T1,RCUNUM		;RESTORE DIRECTORY NUMBER FOR MDDDIR
	JRST RCU130
;HERE WHEN MDDDIR FAILS. IF NO MORE DIRECTORIES, RETURN SUCCESS
;SETTING RC%NMD.  IF NOT, RETURN FAILURE.

RCU150:	CAIE T1,GJFX32		;NO MORE DIRECTORIES?
	RETBAD (RCDIX2)		;NO. TAKE ITERR RETURN
	TXNN Q2,RC%STP		;YES, ARE WE STEPPING?
	TXOA Q1,RC%NOM		;NO, SET NO MATCH
	TXO Q1,RC%NMD		;YES, SET NO MORE USERS IN GROUP
	SETZM RCUNUM		;INDICATE NO DIRECTORY TO RETURN

;MAP DIRECTORY AND GET MODE BITS

RCU170:	TXNE Q1,RC%NOM!RC%AMB!RC%NMD ;ANY ERRORS?
	JRST RCU210		;YES. DON'T MAP DIRECTORY
	TXNE Q1,RC%WLD		;WILD CARD FOUND?
	JRST RCU190		;YES. DIRECTORY ALREADY MAPPED
	MOVE T1,RCUNUM		;T1/USER NUMBER
	CALL CNVDIR		;CONVERT TO DIRECTORY NUMBER ON PS
	CALL SETDIR		;MAP THE USER'S DIRECTORY FROM PS AND GO NOINT
	 JRST RCU210		;FAILED. DON'T LOOK AT MODE BITS

;DIRECTORY IS MAPPED. GET MODE BITS

RCU190:	MOVE T4,DIRORA		;GET START OF DIRECTORY
	LOAD T1,DRMOD,(T4)	;GET MODE BITS
	TXZ T1,RC%NOM!RC%AMB!RC%NMD!RC%WLD	;DON'T SET THESE FROM T1
	TXO T1,MD%SA		;ALWAYS ALLOW STRING ACCOUNTS
	IOR Q1,T1		;ADD IT TO BITS
	TXNE T1,MD%FO		;IS IT FILES-ONLY?
	MOVX Q1,RC%NOM		;YES. INDICATE NO MATCH
	CALL USTDIR		;UNLOCK THE DIRECTORY AND GO OKINT

RCU210:	UMOVEM Q1,1		;RETURN FLAGS
	MOVE T1,RCUNUM		;GET USER NUMBER
	TXNN Q1,RC%NOM!RC%AMB!RC%NMD  ;Error?
	UMOVEM T1,3		;NO. RETURN DIRECTORY NUMBER
	RETSKP			;TAKE SUCCESS RETURN
;RCUCLN - CLEAN UP FROM RCUSR

;	CALL RCUCLN

;RETURNS +1: ALWAYS

;RELEASES JSB FREE SPACE IF ANY IS ASSIGNED

RCUCLN:	SKIPN T2,RCUBLK		;GET ADDRESS OF BLOCK OBTAINED BY CPYFUS
	RET			;WASN'T ANY, DONE
	SETZM RCUBLK		;CLEAR IT
	MOVEI T1,JSBFRE		;SPACE WAS IN JSB FREE SPACE
	NOINT			;DISALLOW INTERRUPTS
	CALL RELFRS		;RETURN SPACE AND REMOVE JSB STACK ENTRY
	OKINT			;INTERRUPTS ALLOWED AGAIN
	RET			;DONE
	SUBTTL RDDIR JSYS

; Read directory

.RDDIR::MCENT
	CALL CHKDEV
	 RETERR()
	MOVEI B,(DEV)
	CAIE B,DTADTB
	RETERR(RDDIX1)
	HLRZ A,DEV
	CALL DTAMCK		;CHECK FOR DIRECTORY IN CORE
	 RETERR(RDDIX1)		;FAILED, DRIVE PROBABLY OFF LINE
	HLRZ A,DEV
	HRRZ B,DTASTS(A)	;GET MONITOR BUFFER ADDRESS
	XMOVEI B,(B)		;MAKE IT CURRENT SECTION FOR BLT
	MOVEI T1,200		;200 WORDS TO MOVE
	UMOVE C,B		;GET USER ADDRESS
	CALL BLTMU1		;DO BLT
	SMRETN			;RETURN
	SUBTTL RFBSZ JSYS

; Read file byte size
; Call:	1	; Jfn
;	RFBSZ

.RFBSZ::MCENT
	MOVE JFN,1
	CALL CHKJFD
	 RETERR()
	 JFCL
	 RETERR(DESX4)
	TQNN <OPNF>
	RETERR(DESX5,<CALL UNLCKF>)
	LDB A,PBYTSZ
	UMOVEM A,2
	CALL UNLCKF
	SMRETN
	SUBTTL RFPTR JSYS

; Read file byte number
; Call:	1	; Jfn
;	RFPTR
; Return
;	+1	; Error
; 	+2	; Success
;	2	; File byte number

.RFPTR::MCENT
	MOVE JFN,1
	CALL CHKJFD
	 RETERR()
	 JFCL
	 RETERR(DESX4)
	TQNN <OPNF>
	ERUNLK(DESX5)
	MOVE A,FILBYN(JFN)
	UMOVEM A,2
	CALL UNLCKF
	SMRETN
	SUBTTL RFTAD JSYS

; READ FILE TIME AND DATE
; CALL:	1	;JFN
;	2	;ADDR
;	3	;COUNT
;	RFTAD
; RETURNS
;	+1	; ERROR, CODE IN 1
;	+2	; SUCCESS
; WITH:	1	; UNCHANGED
;	2	; UNCHANGED
; ADDR +0	;TIME AND DATE OF CREATION
; ADDR +1	;TIME AND DATE OF LAST WRITE
; ADDR +2	;TIME AND DATE OF LAST READ
; ADDR +3	;MONITOR LAST WRITE TIME AND DATE (PRIVILEGED)
;	FIRST "COUNT" LOCATIONS OF "ADDR" FILLED WITH DATES
;	ANY WORDS OF "ADDR" FOR WHICH NO DATE EXISTS ARE FILLED WITH -1

.RFTAD::MCENT
	MOVE JFN,1
	CALL CHKJFN
	 ITERR()
	 JFCL
	 JFCL
	UMOVE A,3		;GET COUNT
	JUMPE A,RFTAD1		;RETURN NOW IF 0 COUNT
	UMOVE Q3,2		;GET ADDR
	XCTU [SETOM (Q3)]	;INITIALIZE TABLE TO -1
	MOVE Q1,A		;[7.1044] Put count in Q1 for CALL @RFTADD
	CAIN Q1,1		;[7.1044] Done if only 1 word buffer
	IFSKP.			;[7.1044]
	  SOS A			;[7.1181] Make sure count of words to init is correct
	  MOVE B,Q3		;[7.1044] Get source of BLT
	  MOVE C,B		;[7.1044] Get destination of BLT...
	  ADDI C,1		;[7.1044] ...by adding 1 to source
	  CALL BLTUU		;[7.1044] (A,B,C/) Now set all of arg block to -1
	ENDIF.			;[7.1044]
	CALL @RFTADD(P3)	;CALL DEVICE DEPENDENT ROUTINE
	 ITERR(,<CALL UNLCKF>)	;ERROR
RFTAD1:	CALL UNLCKF
	MRETNG

;GLOBAL ROUTINE FOR NO DATES AVAILABLE
RFTADN::RETSKP
	SUBTTL RLJFN JSYS

; Release jfn
; Call:	1	; Jfn
;	RLJFN
; Returns
;	+1	; Error
;	+2	; Success
; Cannot release jfn if being assigned unless this same process as
; Assigner, and not at interrupt level

.RLJFN::MCENT
	CAMN 1,[-1]		; Release all
	JRST RLALL		;YES
	HRRZ JFN,1
	CALL RLJF
	 RETERR()
	SMRETN

RLALL:	MOVX A,CZ%NCL!.FHSLF	;DON'T CLOSE, SELF AND INFERIORS
	CLZFF
	 ERJMPR [RETERR()]	;GIVE USER LAST ERROR
	SMRETN

RLJF:	PUSH P,JFN
	HRRZS JFN
	CALL CHKJFD
	 JRST RLJF1		; Garbage jfn
	 JFCL
	 JRST [	MOVEI A,DESX4	; Tty or byte illegal
		JRST RLJF3]
	TQNE <OPNF>
	JRST [	MOVEI A,OPNX1	; File is open
		JRST RLJF4]
RLJF2:	MOVEI A,0(JFN)		;GET JFN
	CALL LUNLK0		;FREE THE STR LOCK
RLJF5:	CALL RELJFN		; Finally we can release it
	AOSA -1(P)
RLJF4:	CALL UNLCKF
RLJF3:	POP P,JFN
	RET
RLJF1:	CAMG JFN,MAXJFN		;IS IT A CURRENTLY ASSIGNED JFN?
	CAIE A,DESX3		;YES,  Is no name attached to this jfn?
	JRST RLJF3		; Some other error
	HLRZ B,FILVER(JFN)	; Get fork number of originator
	SKIPGE SYSFK(B)		; Fork still exists?
	JRST RLJF5		; No, ok to release
	CAME B,FORKN		; Is it me?
	JRST RLJF3		; No
	SKIPE PSIBIP		; Test if pi in progress
	JRST RLJF3		; Yes
	JRST RLJF5		; No pi in progress, ok to release
	SUBTTL RNAMF JSYS

; Rename file
; Call:	1	; Jfn 1
;	2	; Jfn 2
;	RNAMF
; Return
;	+1	; Error
;	+2	; Ok

.RNAMF::MCENT
	CAMN T1,T2		;BE SURE NOT SAME JFN
	SMRETN
	MOVE JFN,T1
	CALL CHKJFN
	 RETERR()
	 JFCL
	 RETERR(DESX4)		; Cannot rename tty or byte
	TQNE <ASTF>
	ERUNLK(DESX7)
	TQNE <OPNF>
	ERUNLK(OPNX1)		; File must not be open
	PUSH P,JFN
	PUSH P,DEV
	UMOVE JFN,T2
	CALL CHKJFN		; Check the second jfn
	 ERUNLK(,<POP P,DEV
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	 JFCL
	 ERUNLK(DESX4,<POP P,DEV
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	TQNE <ASTF>
	ERUNLK(DESX7,<CALL UNLCKF
		POP P,DEV
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	TQNE <OPNF>
	ERUNLK(OPNX1,<CALL UNLCKF
		POP P,DEV
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	;..
	;..

	POP P,A
	CAME A,DEV		; Can only rename on the same device
	ERUNLK(RNAMX1,<PUSH P,A
		CALL UNLCKF	;FREE THIS ONE
		POP P,DEV	;DEV FOR THE SOURCE
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	MOVE A,(P)
	PUSH P,JFN
	LOAD B,FLDTB,(JFN)	;[9041] Get device type of new file name
	CAIE B,DSKDTB		;[9041] File on disk?
	IFSKP.			;[9041] If so, both of them must be
	  PUSH P,A		;[9041] Save old JFN
	  MOVEI A,.GORNF	;[9041] Say doing a rename
	  SETZ B,		;[9041] And not doing FB%SEC change
	  CALL ACJOFL		;[9041] (T1,T2,JFN/) Can we do the rename?
	   ERUNLK (,<MOVEM A,LSTERR ;[9041] Save error code for a bit
		     POP P,A	;[9041] No, begin painful cleanup
		     POP P,JFN	;[9041] Retrieve appropriate JFN
		     MOVE STS,FILSTS(JFN) ;[9041] Get FILSTS
		     CALL UNLCKF ;[9041] (JFN/) Unlock file lock
		     POP P,JFN	;[9041] Get back other JFN
		     MOVE A,LSTERR ;[9041] Retrieve error code
		     MOVE STS,FILSTS(JFN)>) ;[9041] Get status then do unlock
	  EXCH JFN,-2(P)	;[9041] Now check other JFN
	  MOVEI A,.GORNF	;[9041] Say which function
	  SETZ B,		;[9041] And not doing FB%SEC change
	  CALL ACJOFL		;[9041] (T1,T2,JFN/) Is old JFN secure?
	   ERUNLK (,<MOVEM A,LSTERR ;[9041] Hang to this for a bit
		     EXCH JFN,-2(P) ;[9041] No, begin painful cleanup
	 	     POP P,A	;[9041] Restore original JFN
		     POP P,JFN	;[9041] Retrieve appropriate JFN
		     MOVE STS,FILSTS(JFN) ;[9041] Get FILSTS
		     CALL UNLCKF ;[9041] (JFN/) Unlock file lock
		     POP P,JFN	;[9041] Get back other JFN
		     MOVE A,LSTERR ;[9041] And get back error code
		     MOVE STS,FILSTS(JFN)>) ;[9041] Get status then do unlock
	  EXCH JFN,-2(P)	;[9041] Set this back to what it should be
	  POP P,A		;[9041] And retrieve source JFN
	ENDIF.			;[9041] Now do the rename!
	;..
	;..

	CALL @REND(P3)
	 ERUNLK(,<POP P,JFN
		MOVE STS,FILSTS(JFN)
		CALL UNLCKF
		POP P,JFN
		MOVE STS,FILSTS(JFN)>)
	POP P,JFN
	MOVE STS,FILSTS(JFN)
	CALL UNLCKF
	POP P,JFN
	MOVE STS,FILSTS(JFN)
	MOVEI A,0(JFN)
	CALL LUNLK0		;FREE UP THE STR LOCK
	CALL RELJFN
	SMRETN
	SUBTTL SACTF JSYS

; Set account for file
; Call:	1	; JFN
;	2	; String pointer or 5B2+account number
;	SACTF
; Returns:
;	+1	; Error, code in 1
;	+2	; Ok

.SACTF::MCENT			;MONITOR CONTEXT ENTRY
	STKVAR <SACNUM,SACPTR>	;ACCOUNT NUMBER, FREE SPACE POINTER
	MOVE JFN,T1		;FETCH THE USER'S JFN
	CALL CHKFIL		;CHECK ITS VALIDITY, WE WANT A FILE
	 RETERR()		;INVALID
	TQNE <ASTF>		;PARSE-ONLY JFN?
	 ERUNLK(DESX7)		;YES, PARSE-ONLY IS AN ERROR
	BLCAL. DSKOK,<P3>	;A DSK?
	 ERUNLK(SACTX1)		;NO, ERROR
	CALL GETFDB		;YES, GET A POINTER TO THE FDB
	 ERUNLK(SACTX4)		;FAILED
	MOVX T2,DC%CN		;CODE TO CONNECT TO DIRECTORY
	CALL DIRCHK		;SEE IF USER CAN DO IT
	 ERUNLK(SACTX4,<ULKDIR>);NOT ENOUGH PRIVS
	ULKDIR			;UNLOCK THE DIRECTORY
	UMOVE T1,2		;GET USER'S POINTER OR ACCOUNT
	TLC T1,-1		;DO POINTER ADJUSTMENT
	TLCN T1,-1		;-1 ,, ADR?
	HRLI T1,(<POINT 7,0>)	;YES, SET UP BYTE POINTER INSTEAD
	CAMG T1,[6B2-1]		;SEE IF BYTEPOINTER OR NUMERIC ACCOUNT
	CAMGE T1,[5B2]		;[1817]
	 JRST SACTFS		;BYTE POINTER, GO DO STRING ACCOUNT
;HERE FOR A NUMERIC ACCOUNT - CONVERT TO STRING

	MOVEM T1,SACNUM		;SAVE NEW NUMERIC ACCOUNT IN SACNUM
	MOVEI T2,4		;NUMERIC ACCOUNT, CONVERT TO STRING
	CALL ASGJFR		;GET A SMALL BLOCK OF JSB FREE SPACE
	 ERUNLK(SACTX2)		;COULDN'T DO IT
	MOVEM T1,SACPTR		;SAVE LOCATION OF THE BLOCK
	HRROI T1,1(T1)		;PUT -1 IN LH, AND START IN SECOND WORD
	MOVE T2,SACNUM		;GET THE ACCOUNT NUMBER BACK
	TLZ T2,700000		;ISOLATE THE VALUE PORTION
	MOVEI T3,^D10		;ACCOUNT NUMBERS ARE DECIMAL
	NOUT			;DO THE CONVERSION TO A STRING
	 ERUNLK(,<MOVE T1,T3>)	;MOVE ERROR CODE TO T1 AND ERROR OUT
	IBP T1			;STEP PAST NULL SO COUNT IS RIGHT
	HRRZ T2,T1		;LAST LOCATION USED IN BLOCK
	MOVE T1,SACPTR		;ORIGIN OF THE BLOCK
	MOVE T3,T2		;COPY LAST
	SUB T3,T1		;FULL WORDS IN BLOCK - 1
	MOVNS T3		;NEGATE IT
	HRLM T3,SACPTR		;FUDGED LOOKUP POINTER TO ACCOUNT
	CALL TRMBLK		;TRIM THE BLOCK
	MOVE T2,SACPTR		;CALL INSACT WITH LOOKUP POINTER IN T2
	CALL INSACT		;INSERT NUMERIC ACCOUNT AS STRING
	 JRST SACTER		;INSACT FAILED, CLEANUP AND ERROR OUT
	JRST SACTFE		;CLEANUP AND EXIT
;HERE FOR STRING ACCOUNT

SACTFS:
	MOVE T2,T1		;SAVE POINTER FOR A WHILE
	CALL PTRCHK		;CHECK THE POINTER FOR OWGBP'S
	 ERUNLK(SACTX2)		;BAD POINTER SO CAN NOT COPY IT
	MOVE T1,T2		;PUT POINTER WHERE IT CAN BE FOUND
	CALL CPYFUS		;COPY FROM THE USER
	 ERUNLK(SACTX2)		;CANNOT COPY IT
	UMOVEM T3,2		;RETURN UPDATED POINTER TO USER
	MOVE T2,T1		;STRING LOOKUP POINTER TO T2 FOR INSACT
	HRRZM T1,SACPTR		;SAVE ACCOUNT STRING POINTER
	CALL INSACT		;SET THE ACCOUNT IN THE DIRECTORY
	 JRST SACTER		;INSACT FAILED, CLEANUP AND ERROR OUT

SACTFE:	MOVE T2,SACPTR		;GET OLD FILACT
	MOVEI T1,JSBFRE		;JSB SPACE TO FREE
	CALL RELFRE		;RELEASE FREE SPACE FOR OLD FILACT
	CALL UNLCKF		;RELEASE THE SPACE
	SMRETN			;AND SKIP RETURN TO USER

;HERE FOR AN ERROR FROM INSACT

SACTER:	MOVEM T1,LSTERR 	;FAILED, SAVE ERROR CODE
	MOVEI T1,JSBFRE		;AREA IS JSB FREE SPACE
	HRRZ T2,SACPTR		;GET FREE POINTER
	CALL RELFRE		;RELEASE THE STRING SPACE
	MOVE T1,LSTERR		;GET OLD ERROR CODE BACK
	ERUNLK()		;RETURN
	SUBTTL SDSTS JSYS

; Set device status
; Call:	1	; Jfn
;	SDSTS
; Returns
;	+1	; Always unless traps

.SDSTS::MCENT
SDSTS1:	UMOVE JFN,1
	CALL CHKJFN
	 ITERR()
	 JFCL
	 ITERR(DESX4)
	UMOVE A,2
	TQZE <BLKF>		;BLKF MUST BE ZERO BEFORE CALL
	BUG.(CHK,BLKF6,JSYSF,HARD,<.SDSTS - BLKF set before call to device routine>,,<

Cause:	The bit indicating that a device routine wishes to block has been
	set before the call to the device routine has been made. This bit
	must be set to zero before the call so we do not block needlessly
	(maybe never to wake up).

Action:	The bit is being cleared. If this problem persists, change the
	BUGCHK to a BUGHLT and find out where BLKF is being set.
>)
	TQNE <OPNF>
	CALL @SDSTD(P3)
	TQZN <BLKF>		;ROUTINE WANT TO WAIT?
	JRST UNL		;NO, JUST EXIT
	CALL UNLDIS		;YES, GO DISMIS
	JRST SDSTS1		;LOOP BACK AND TRY AGAIN
	SUBTTL SFBSZ JSYS

; Set file byte size jsys
; Call:	1	; Job file number
;	2	; Byte size (1 to 36)
;	SFBSZ
; Return
;	+1	; Error number in a
;	+2	; Success

.SFBSZ::MCENT
	MOVE JFN,1
	CALL DSKJFN
	 RETERR()
	TQNN <OPNF>
	RETERR(CLSX1,<CALL UNLCKF>)
	XCTU [SKIPLE B,2]
	CAILE B,^D36
	RETERR(SFBSX2,<CALL UNLCKF>) ; Illegal byte size
	TQNE <SIZF>
	RETERR(SFBSX1,<CALL UNLCKF>) ; Illegal to change byte size
	LDB A,PBYTSZ		; Get previous byte size
	CALL NFBSZ
	TQNE <NONXF>		;[9123] Is this a new file?
	TQNN <WRTF>		;[9123] And do we have it open for write?
	IFSKP.			;[9123] Yes, we may have to adjust byte size
	  SKIPE FILLEN(JFN)	;[9123] Is the file empty?
	  IFSKP.		;[9123] Yes, adjust OFNBSZ in OFNLEN
	    LOAD D,FLPTN,(JFN)	;[9123] Get OFN for this JFN
	    LDB C,PBYTSZ	;[9123] Get the byte size
	    STOR C,OFNBSZ,(D)	;[9123] Store as new byte size for OFN
	  ENDIF.		;[9123] 
        ENDIF.			;[9123] 
	SETZM FILCNT(JFN)	;FORCE NEW WINDOW NEXT OPERATION
	CALL UNLCKF		; Unlock file
	SMRETN
	SUBTTL SFPTR JSYS

; Set file byte number
; Call:	1	; LSN flag,,Job file number
;	2	; Byte number
;	SFPTR
; Return
;	+1	; Error
;	+2	; Successful

.SFPTR::MCENT			; Become slow etc.
	TRVAR <SAVJFN>		;[7321]This TRVAR <SAVJFN> must be the same as
				;[7321] the TRVAR in routine SIN., BYTIN, etc.
				;[7321] SAVJFN must be the first argument in
				;[7321] TRVAR.  Before using any TRVARs within
				;[7321] the flow of this routine, make sure
				;[7321] that SAVJFN contains the original JFN
				;[7321] when BYTINX is called in routine TSTLSN
	STKVAR <LSNFLG>		;[7321]
	MOVE B,1		;[7321]Get LSN flag,,JFN 
	HLLM B,LSNFLG		;[7321]Save the LSN flag bit
	HRRZ JFN,B		;[7321] and JFN
	MOVEM JFN,SAVJFN	;[7321]Save JFN for later
	CALL DSKJFN		;[7321](JFN/)Check and lock JFN
	 RETERR()
	TQNN <OPNF>		;[7321]Is it open?
	ERUNLK(CLSX1)		;[7321]No, give the error
	UMOVE A,2		;[7321]Get byte count
	SKIPG A			;[7321]Possibly EOF or invalid byte count?
	JRST SFPT1		;[7321]Yes, skip LSN checking
	MOVE B,LSNFLG		;[7321]Get user LSN flag
	TXNN B,SF%LSN		;[7321]Include LSN in calculation?
	IFSKP.
	 CALL TSTLSN		;[7321](A/A)Yes, go calculate byte count
	 ERUNLK()		;[7321]Error
	ENDIF.
SFPT1:	CALL SFBNR		;[7321](A/)Set the byte number
	 ERUNLK()
	CALL UNLCKF
	SMRETN
	ENDSV.			;[7321]End STKVR for this region
	ENDTV.			;[7321]End TRVAR for this region
;TSTLSN - accepts a byte count in AC1 and returns the correct byte count based
; on whether the file has LSNs.  Called only if SF%LSN is on.
;
; Call:	A	; Byte number
;	TSTLSN
; Return
;	+1	;Error while read bytes
;	+2	;Byte count based on LSN in A

TSTLSN:	STKVAR <BYTCNT,BYTACC> 	;[7321]Byte count, byte count accumulator
	MOVEM A,BYTCNT		;[7321]Save it now
	SETZM BYTACC		;[7321]Clear byte accumulator
	SETZM FILBYN(JFN)	;[7321]Start at beginning
	TQZ <EOFF>		;[7321]Not EOF
	SETZM FILCNT(JFN)	;[7321]Force new window
	CALL @JFNID(P3)		;[7321]Init JFN for input
TSTL1:	CALL BYTINX		;[7321](/B)Get a byte
				;[7321]BYTINX expects the original JFN in
				;[7321] SAVJFN (Stored in a TRVAR <SAVJFN>).
	 JRST TSTEND		;[7321]Error or EOF 
	JUMPN B,TSTL2		;[7321]Including LSN's means including nulls
	MOVE A,FILBYN(JFN)	;[7321]Are we at beginning of file?
	SOJE A,TSTNLS		;[7321]Yes, file can't have line numbers
	AOS BYTACC		;[7321]Add the null to the total count
	JRST TSTL1		;[7321]Get the next byte
TSTL2:	LDB A,[POINT 12,FILBYT(JFN),11];[7321]Get byte position and size fields
	MOVE C,FILCNT(JFN)	;[7321]Get remaining bytes in buffer
	CAIE A,<POINT 7,0,6>_-^D24;[7321]First byte of a word?
	IFSKP.			;[7321]
	  CAIL C,4		;[7321]Yes, enuf for a line #?
	  IFSKP.		;[7321]
	    MOVE A,FILBYN(JFN)	;[7321]No, are we at beginning of file?
	    SOJE A,TSTNLS	;[7321]Yes, file can't have line numbers
	  ELSE.			;[7321]
	    HRRZ A,FILBYT(JFN)	;[7321]Get the word we got the character from
	    MOVE A,0(A)		;[7321]Do indirect
	    TXNE A,1B35		;[7321]Bit 35 on? If so, call it a line #
	    IFSKP.		;[7321]
	      MOVE A,FILBYN(JFN);[7321]No, are we at beginning of file?
	      SOJE A,TSTNLS	;[7321]Yes, file can't have line numbers
	    ELSE.		;[7321]We have a line number
	      MOVNI A,4		;[7321]Skip the rest of the line number quickly
	      ADDM A,FILCNT(JFN);[7321]Update remaining byte count in buffer
	      MOVEI A,4		;[7321]Just read in four bytes
	      ADDM A,FILBYN(JFN);[7321]Update FILBYN
	      MOVX A,77B5	;[7321]Now point to last byte in word
	      ANDCAM A,FILBYT(JFN);[7321]To "read" those 4
	      CALL BYTINX	;[7321](/B)Skip the tab after the LSN
				;[7321]BYTINX expects the original JFN in
				;[7321] SAVJFN, (Stored in a TRVAR <SAVJFN>.)
	      JRST TSTEND	;[7321]Error or EOF
	      MOVEI B,6		;[7321]Just skipped 5 characters and TAB
	      ADDM B,BYTACC	;[7321]Add it to the new byte count
	      JRST TSTL1	;[7321]And get a real one
	    ENDIF.		;[7321]
	  ENDIF.
	ENDIF.

TSTL5:	AOS BYTACC		;[7321]Increment new byte count
	SOSE BYTCNT		;[7321]Decrement original byte count
	JRST TSTL1		;[7321]If not done get another byte
	MOVE A,BYTACC		;[7321]Else store new byte count in A
	RETSKP			;[7321] and return good.

TSTNLS:	MOVE A,BYTCNT		;[7321]No, LSNs
	RETSKP			;[7321]just return

TSTEND:	CAIE A,IOX4		;[7321]EOF?
	RET			;[7321]No, error return
	MOVE A,BYTACC		;[7321]Yes, return byte count as the last byte 
	RETSKP			;[7321]Good return
	ENDSV.			;[7321]End STKVR for this region
	SUBTTL SFTAD JSYS

; SET FILE TIME AND DATE
; CALL:	1	;JFN
;	2	;ADDR
;	3	;COUNT
; ADDR +0	;TIME AND DATE OF CREATION
; ADDR +1	;TIME AND DATE OF LAST WRITE
; ADDR +2	;TIME AND DATE OF LAST READ
; ADDR +3	;MONITOR LAST WRITE TIME AND DATE (PRIVILEGED)
;		; TIME AND DATE = -1 FOR NO CHANGE
;	SFTAD
; RETURNS
;	+1	; ERROR, CODE IN 1
;	+2	; SUCCESS

.SFTAD::MCENT
	MOVE JFN,1
	CALL CHKJFN
	 ITERR()
	 JFCL
	 JFCL
	UMOVE Q1,3		;GET COUNT FOR SUBRS
	JUMPLE Q1,SFTAD1        ;JUST RETURN IF COUNT = 0
	UMOVE Q3,2		;GET ADDR
	TLNE Q3,-1		;DONT ALLOW BIG ADDRESSES
	 ITERR(ILLX01,<CALL UNLCKF>) ;GENERATE ERROR
	MOVE T1,CAPENB		;CHECK DATES?
	TRNE T1,SC%WHL!SC%OPR	;WHEEL OR OPERATOR?
	JRST SFTAD2		;CAN SET ANYTHING
	CALL LGTAD		;GET TIME AND DATE IN STANDARD FORMAT
	JUMPL A,[ITERR(DATEX6,<CALL UNLCKF>)] ;LOSE IF NOT SET
	MOVN B,Q1		;GET - LENGTH
	HRLZ B,B
	HRR B,Q3		;AND TABLE ADDR
SFTAD3:	XCTU [MOVE C,(B)]	;GET ENTRY
	CAME C,[-1]		;NOT CHANGING,
	CAMG C,A		;OR LEGAL TIME AND DATE?
	AOBJN B,SFTAD3		;YES, GET NEXT
	JUMPGE B,SFTAD2		;  Checked all entries
	HRRZ D,B		; Get offset
	SUB D,Q3		;MAKE AN INDEX
	CAIE D,.RSNET		; In range where an interval is legal?
	CAIN D,.RSFET
	CAIA
	ITERR(DATEX5,<CALL UNLCKF>) ;ILLEGAL TIME AND DATE?
	AOBJN B,SFTAD3		; Do all entries
SFTAD2:	CALL @SFTADD(P3)	;CALL DEVICE DEPENDENT ROUTINE
	 ITERR(,<CALL UNLCKF>)	;ERROR
SFTAD1:	CALL UNLCKF
	MRETNG

;GLOBAL ROUTINE FOR NO DATES AVAILABLE
SFTADN::RETSKP
	SUBTTL SFUST JSYS

; SET FILE USER STRING
;
; CALL: (ARGUMENTS IN USER SPACE)
; ACCEPTS IN T1/ FUNCTION,,JFN
;	     T2/ POINTER TO NAME STRING
;		SFUST
; RETURNS: +1 ALWAYS

.SFUST::MCENT			;MONITOR CONTEXT ENTRY
	TRVAR <SFUBLK,SFUFDA,SFUDIR,SFUERR,SFSPTR> ;ALLOCATE LOCAL STORAGE

; VALIDATE THE FUNCTION REQUESTED

	XCTU [ HLRZ T3,1 ]	;GET FUNCTION CODE FROM USER
	CAIE T3,.SFAUT		;IS FUNCTION "SET AUTHOR STRING" ?
	CAIN T3,.SFLWR		;  OR "SET LAST WRITER" ?
	SKIPA			;YES, PROCEED
	ITERR (SFUSX1)		;NO, RETURN "INVALID FUNCTION" ERROR

; COPY NAME STRING FROM USER AND TRANSLATE TO DIRECTORY NUMBER

	UMOVE T1,2		;GET POINTER TO NAME STRING IN USER SPACE
	CALL CPYFU0		;COPY STRING FROM USER SPACE
	 ITERR (SFUSX2)		;FAILED, RETURN "INSUFFICIENT RESOURCES" ERROR
	MOVEM T1,SFUBLK		;SAVE ADDRESS OF BLOCK ASSIGNED
	MOVEM T3,SFSPTR		;SAVE THE UPDATED BYTE PTR
	XCTU [HRRZ JFN,1]	;GET JFN
	CALL DSKJFN		;VALIDATE FOR FILE ONLY
	 ITERR (,<MOVEM T1,SFUERR	;SAVE THE ERROR CODE
		CALL SFUX2
		MOVE T1,SFUERR>)
	CALL GETFDB		;GET FDB MAPPED
	 ITERR (SFUSX4,<CALL SFUX1>)
	MOVEM T1,SFUFDA		;SAVE FDB ADDRESS
	XCTU [HLRZ T3,1]	;GET FCN CODE AGAIN
	MOVE T2,CAPENB		;CHECK IF ENABLED
	TXNE T2,SC%WHL!SC%OPR
	JRST SFUSOK		;OK TO PROCEED
	CAIN T3,.SFLWR		;WANT TO SET LAST-WRITER?
	ITERR (CAPX1,<CALL SFUXIT>) ;NEED TO BE WHOPER
	MOVX T2,DC%CN		;ELSE OWNER PRIVS FOR AUTHOR
	CALL DIRCHK		; STRING SETTING
	 ITERR (SFUSX5,<CALL SFUXIT>)
	;..
	;..
SFUSOK:	MOVE T1,SFUFDA		;GET FDB ADDRS AGAIN
	LOAD T2,FBVER,(T1)	;LOOK AT FDB VERSION #
	CAIGE T2,1		;VERSION 1 OR LATER?
	JRST SFUS10		;OLD FDB - DIFFERENT CODE
	XCTU [HLRZ T2,1]	;GET FCN AGAIN
	MOVEI T3,.FBAUT		;ASSUME AUTHOR
	CAIE T2,.SFAUT		;IS IT?
	MOVEI T3,.FBLWR		;NO - SET LAST-WRITER
	MOVE T2,SFUBLK		;POINTER TO STRING BLOCK
	CALL INSUNS		;INSERT STRING INTO DIRECTORY
	CALL SFUXIT		;UNLOCK THINGS
	MOVE T2,SFSPTR		;RESTORE THE BYTE PTR
	UMOVEM T2,2		
	JRST MRETN		;RETURN
;COMMON EXIT (CLEANUP) ROUTINES

SFUXIT:	CALL USTDIR		;UNLOCK DIRECTORY
SFUX1:	CALL UNLCKF		;UNLOCK JFN
SFUX2:	MOVEI T1,JSBFRE		;FREE UP JSB FREE SPACE
	MOVE T2,SFUBLK		;...
	CALL RELFRE
	OKINT			;ALLOW INTS AGAIN
	RET			;RETURN

;HANDLE OLD STYLE FDB (CONVERT STRING TO USER # FIRST)

SFUS10:	CALL USTDIR		;FIRST UNLOCK DIRECTORY
	MOVE T1,LGSIDX		;[7.1112]Look on Login Structure
	CALL STRCNV		;GET UNIQUE CODE
	 ITERR (SFUSX6,<CALL SFUX1>)
	MOVE T2,T1		;COPY FOR DIRLUK
	MOVE T1,SFUBLK		;POINT TO STRING
	MOVEI T3,0		;DON'T NEED THIS IF NO RECOG.
	TQO <NREC>		;SAY DON'T RECOGNIZE
	CALL DIRLUK		;SEE IF VALID USER NAME ON PS
	 ITERR (SFUSX6,<CALL SFUX1>) ; NO SUCH USER
	MOVEM T1,SFUDIR		;SAVE DIRECTORY NUMBER
	CALL GETFDB		;GET FDB AGAIN
	 ITERR (SFUSX4,<CALL SFUX1>) ;FILE DISAPPEARED
	XCTU [HLRZ T3,1]	;GET USER FCN AGAIN
	HRRZ T2,SFUDIR		;GET DIRECTORY NUMBER
	CAIE T3,.SFAUT		;SETTING AUTHOR?
	JRST [STOR T2,FBLW0,(T1) ;NO - ASSUME LAST WRITER THEN
		JRST SFUS20]
	STOR T2,FBAT0,(T1)	;YES - STASH DIR #
SFUS20:	CALL SFUXIT		;UNLOCK EVERYTHING
	MOVE T2,SFSPTR		;RESTORE UPDATED BYTE PTR
	UMOVEM T2,2
	JRST MRETN		;AND RETURN
	SUBTTL SIBE JSYS

;SIBE - Skip if input buffer empty
;ACCEPTS:
;	T1/ DEVICE DESIGNATOR
;	SIBE
;RETURNS +1: INPUT BUFFER NOT EMPTY
;		T2/ NUMBER OF BYTES IN BUFFER
;	 +2: INPUT BUFFER EMPTY OR ERROR
;		T2/ 0 IF EMPTY OR NOT OPEN FOR READ
;			OR
;		    ERROR CODE IF ERROR

.SIBE::	MCENT
	STKVAR <SIBEBS>
	CALL CHKTTR
	 JRST SIBE1
	MOVEM C,SIBEBS		;SAVE BYTE SIZE

;DEVICE IS A TERMINAL

	CALL LCKTTY		;POINT TO DYNAMIC DATA, PREVENT DEALLOCATION
	 JRST [	CALL ULKTTY	;NOT ACTIVE. ALLOW DEALLOCATION
		MOVEI A,TTYX01	;INDICATE LINE IS NOT ACTIVE
		UMOVEM A,B	;RETURN ERROR CODE IN 2
		MOVEM T1,LSTERR	; AND IN LSTERR
		SMRETN]		;RETURN +2
	MOVE C,SIBEBS		;GET BYTE SIZE FOR TTSIBE
	CALL TTSIBE		;GO CHECK INPUT BUFFER
	JRST [	UMOVEM A,B	;NOT EMPTY. RETURN COUNT
		CALL ULKTTY	;ALLOW DEALLOCATION
		JRST EMRET1]	;RETURN +1
	CALL ULKTTY		;EMPTY. ALLOW DEALLOCATION
	UMOVEM A,B		;RETURN COUNT OF 0
	SMRETN			;RETURN +2

SIBE1:	CAIE A,DESX6		;LEGAL, NON-TTY DESIGNATOR?
	 JRST [	MOVEM T1,LSTERR	;RETURN ERROR CODE IN LSTERR
		UMOVEM T1,2	; AND USER AC2
		SMRETN]		;THEN TAKE SKIP RETURN
	TQNE <OPNF>
	TQNN <READF>
	 JRST [	SETZ A,
		JRST SIBE2]
	CALL @JFNID(P3)		;GO INIT JFN FOR INPUT
	SKIPLE A,FILCNT(JFN)
	 JRST [	UMOVEM A,B
		JRST EMRET1]
SIBE2:	UMOVEM A,B		;RETURN ERROR CODE OR 0
	SMRETN			;+2 RETURN
	SUBTTL SIZEF JSYS

; Get size of file
; Call:	1	; Jfn
;	SIZEF
; Return
;	+1	; Error, cannot get size of file
;	+2	; Success
;	1	; Size in bytes
;	2	; Size in pages

.SIZEF::MCENT
	STKVAR <SIZFT,SIZFB>
	MOVE JFN,1
	CALL CHKJFN
	 JRST GBGJFN
	 JFCL
	 ERUNLK DESX4
	TQNE <ASTF>
	ERUNLK(DESX7)
	MOVEI A,DESX8
	BLCAL. DSKOK,<DEV>	;DSK?
	 ERUNLK()
	LOAD A,STR,(JFN)	;[7.1063]Get the structure number
	CALL CKSTOF		;[7.1063](T1/T1)Is the structure offline?
	 ERUNLK ()		;[7.1063]Return "Structure is offline"
	CALL GETFDB		; Get pointer to fdb
	 ERUNLK OPNX2
	LOAD B,FBNPG,(A)	; GET NUMBER OF PAGES
	TQNN <OPNF>		;FILE OPENED?
	JRST [	MOVE A,.FBSIZ(A) ; NO - USE LENGTH IN FDB
		JRST SIZEF1]
	HLRZ D,FILOFN(JFN)	;GET OFN
	TQNE <LONGF>
	HRRZ D,FILOFN(JFN)	;USE THIS IF LONG FILE
	MOVEM D,SIZFT		;Save the OFN
	MOVEM B,SIZFB		;Save the number of pages
	MOVE A,D		;Copy the OFN
	MOVEI B,0		;Only need read access in order ...
	CALL CFSAWT		;(T1,T2) ... to get up-to-date EOF info
	MOVE D,SIZFT		;Get OFN back
	MOVE B,SIZFB		;Get the number of pages back
	MOVE A,OFNLEN(D)	;[7.1059] Get OFNLEN
	CAMN A,[-1]		;[7.1059] Is it code for 34359738367(36)?
	SKIPA A,[.INFIN]	;[7.1059] Make 34359738367 byte count
	LOAD A,OFNBC,(D)	;[7.1059] Get true file length
	;..
	;..

SIZEF1:	UMOVEM A,2
	UMOVEM B,3
	CALL USTDIR
	CALL UNLCKF
	SMRETN

GBGJFN:	RETERR ()
	ENDSV.			;End of CHFDB STKVAR region
	SUBTTL SMAP JSYS support

;FILE PORTION OF SMAP JSYS. GOTTEN HERE IF MAPPING TO A FILE.

;ACCEPTS:
;	T1/ SOURCE I.D. (JFN,,SECTION NUMBER)
;	Q1/ STARTING SECTION IN SOURCE
;	Q2/ DESTINATION (SPT INDEX OF PSB,,SECTION NUMBER)
;	Q3/ ACCESS,,COUNT

;	CALL SMFILE

;RETURNS:	+1	FAILURE. T1/ERROR CODE
;		+2	SUCCESS

SMFILE::MOVEI T2,-1(Q3)		;GET COUNT
	ADD T2,Q1		;COMPUTE LAST SECTION IN SOURCE
	CAILE T2,777		;LEGAL SECTION?
	RETBAD (ARGX23)		;NO. ILLEGAL SECTION
	HLRZ JFN,T1		;GET THE JFN
	CALL DSKJFN		;VERIFY, LOCK
	 RETBAD ()		;NOT VALID
	TQNN <OPNF>		;OPENED?
	RETBAD (DESX5,<CALL UNLCKF>) ;NO. ERROR THEN
	TQNN <READF>		;READ OK?
	RETBAD (OPNX3,<CALL UNLCKF>) ;NO - CAN'T MAP XCT-ONLY FILE.
	TQNN <WRTF>		;OPEN FOR WRITE?
	TXZ Q3,PM%WT		;NO. CAN'T HAVE WRITE ACCESS THEN
	LSH Q1,PGSFT		;CONVERT SECTION # TO PAGE
	;..
	;..

;MAP A SECTION AT A TIME. GET THE OFN FOR EACH 1000-PAGE SECTION
;OF THE FILE AND MAP IT TO THE NEXT SECTION IN THE DESTINATION

;Q1/ PAGE NUMBER (SECTION NO. * 1000)

SMFIL1:	MOVE T1,Q1		;GET PAGE NUMBER OF SECTION
	TXNN Q3,PM%WT		;WANT WRITE?
	SKIPA T2,[JFNOF3]
	MOVEI T2,JFNOF1
	CALL 0(T2)		;GET OFN,,PN
	 JRST [	MOVE Q1,T1	;SAVE ERROR
		CALL UNLCKF	;UNLOCK FILE
		MOVE T1,Q1	;RESTORE ERROR
		RETBAD ()]	;DONE
	HLRZS T1		;GET OFN
;SECMAP WILL DO THIS
;	CALL UPSHR		;MAKE SURE IT DOESN'T DISAPPEAR
	DMOVE T2,Q2		;GET OTHER ARGS
	HLLZS T3		;ISOLATE FLAGS
	CALL SECMAP		;MAP IT
	 RETBAD ()		;LOSE, ERROR CODE IN T1
	ADDI Q1,PGSIZ		;NEXT SECTION
	ADDI Q2,1		;NEXT PROCESS SECTION
	SUBI Q3,1		;ONE LESS TO DO
	MOVX T1,2B17		;INCREMENTER
	ADDM T1,FILLFW(JFN)	;REMEMBER MAP
	TRNE Q3,-1		;MORE TO DO?
	JRST SMFIL1		;YES
	CALL UNLCKF		;NO. UNLOCK JFN
	RETSKP			;SUCCESS
	SUBTTL STDIR JSYS

; String to directory
; Call:	1	; Positive for no recognition
;	2	; Source designatoR
;	STDIR
; Return
;	+1	; No match
;	+2	; Ambiguous
;	+3	; Unique match

.STDIR::MCENT
	ITERR(STDIX1)		;STDIR WAS REPLACED BY RCUSR AND RCDIR
	SUBTTL STPPN JSYS

;JSYS TO CONVERT A STRING TO A PPN (TOPS10 STYLE)
;ACCEPTS IN T1/ 36-BIT DIRECTORY #
;		JFN
;		STRING-PNTR TO STR/DIRECTORY NAME
;RETURNS +1 ALWAYS T2/ PPN

.STPPN::MCENT
	UMOVE T1,1		;GET USER ARG
	TLNN T1,-1		;POSIBLE JFN?
	JRST STPPJ		;YES - TRY IT
STPPNX:	CALL CNVSTD		;STRING OR 36 BIT DIR # - TRY TO GET DIR #
	 ITERR ()		;RETURN LOSAGE INFO
	CALL SETDIR		;DIR # - MAP IT
	 ITERR ()		;RETURN LOSAGE INFO
	CALL USTDIR		;VALID # - UNLOCK DIR
	MOVE T2,DIRORA		;DIRECTORY ORGIN
	LOAD T2,DRPPN,(T2)	;GET PPN FROM DIR
	SKIPE T2		;IF PPN FROM THE DIRECTORY IS NON-ZERO
	SKIPA T1,T2		;USE PPN FROM DIRECTORY
	HRLI T1,PPNLH		;ELSE, RETURN OLD STYLE
	UMOVEM T1,2		;RETURN TO USER AC2
	JRST MRETN		;RETURN

STPPJ:	MOVE JFN,T1		;PUT JFN IN AC(JFN)
	CALL DSKJFN		;CHECK IF A DISK
	 ITERR ()		;NOPE - RETURN ERROR
	LOAD T1,FLUC,(JFN)	;YES - GET STR #
	HRLZS T1		;TO THE LEFT HALF
	HRR T1,FILDDN(JFN)	;GET DIR #
	CALL UNLCKF		;UNLOCK JFN
	JRST STPPNX		;COMMON EXIT
	SUBTTL STSTS JSYS

; Set status
; Call:	1	; Jfn
;	2	; New status
;	STSTS
; Returns
;	+1	; Erro2
;	+2	; Ok (only errf, hltf, and frkf can be changed)

.STSTS::MCENT
	MOVE JFN,1
	CALL CHKJFN
	 RETERR()		; Bad jfn
	 JFCL
	 RETERR(DESX4)		; Tty and byte bad
	UMOVE A,2		; Get new status
	ANDCA A,[ERRF!HLTF!FRKF]
	TDZ STS,A
	CALL UNLCKF
	SMRETN
	SUBTTL SWJFN JSYS

; Swap jfn's
; Call:	1	; Jfn 1
;	2	; Jfn 2
;	SWJFN

.SWJFN::MCENT
	MOVE JFN,1
	CAMN 1,2		;SWAPPING SAME JFN?
	ITERR(SWJFX1)		;ILLEGAL, TELL USER
	CALL CHKFIL
	 ITERR()
	CALL CHKATS		;IS THIS AN ATS JFN?
	JRST [	MOVE A,JFN	;YES. SET UP JFN FOR LUNLKF
		CALL LUNLKF	;UNLOCK THE JFN
		ITERR (SWJFX2)]	;RETURN 'ILLEGAL TO SWAP ATS JFN'
	PUSH P,JFN		;NO. SAVE THE FIRST JFN
	UMOVE JFN,2		;GET THE SECOND JFN
	CALL CHKFIL
	 ITERR(,<POP P,JFN
		MOVE DEV,FILDEV(JFN)
		MOVE STS,FILSTS(JFN)	;RESTORE STS CLOBBERED BY CHKJFN
		CALL UNLCKF>)
	CALL CHKATS		;IS THIS AN ATS JFN?
	JRST [	MOVE A,JFN	;YES. SET UP FOR LUNLKF
		CALL LUNLKF	;UNLOCK THE SECOND JFN
		POP P,A		;SET UP THE FIRST JFN FOR LUNLKF
		CALL LUNLKF	;UNLOCK THE FIRST JFN
		ITERR (SWJFX2)]	;RETURN 'ILLEGAL TO SWAP ATS JFN'
	POP P,A			;NO. GET THE FIRST JFN
	MOVE B,[XWD -MLJFN,JFN0] ;Get AOBJN word over all JFN cells
	HRLI A,B+(IFIW)		;Make first JFN an indexed local ifiw
	HRLI JFN,B+(IFIW)	;Same with second
SWJFNL:				;Exchange all JFN cells between the two JFN's
	MOVE C,@JFN
	EXCH C,@A
	MOVEM C,@JFN
	AOBJN B,SWJFNL
	MOVEI A,0(A)		;Get JFN only
	CALL SCSWJF		;Do DECNET-dependent part of SWJFN% for 1st JFN
	CALL LUNLKF		;RELEASE LOCK ON THIS JFN
	MOVEI A,0(JFN)		;GET OTHER
	CALL SCSWJF		;Do DECNET-dependent part of SWJFN% for 2nd JFN
	CALL LUNLKF		;AND RELEASE THIS ONE ALSO
	JRST MRETN
	SUBTTL UFPGS JSYS

;UPDATE FILE PAGES
; A/ IDENT OF FIRST PAGE (JFN,,PN)
; B/ COUNT OF SEQUENTIAL PAGES TO UPDATE
;	UFPGS
; RETURN +1: FAILURE
; RETURN +2: SUCCESS, ALL MODIFIED PAGES WRITTEN TO DSK.  FDB UPDATED
;	IF NECESSARY.  BLOCKS UNTIL ALL WRITES COMPLETE

.UFPGS::MCENT
	MOVE Q1,A		;SAVE ID
	HRRZ Q2,B		;SAVE COUNT
	HLRZ JFN,Q1
	CALL DSKJFN		;ENSURE JFN ON DSK
	 RETERR()
	TQNE <OPNF>		;[7451] Is file open?
	TQNN <WRTF>		;OPEN FOR WRITE?
	ERUNLK UFPGX1		;NO, WRONG.
	TQNE <LONGF>		;IS THE FILE LONG?
	JRST UFPG1		;YES
	CAILE Q2,PGSIZ		;FILE IS SHORT...IS COUNT EXCESSIVE?
	MOVEI Q2,PGSIZ		;YES...ADJUST IT
	;..
	;..
UFPG1:	HRRZ A,Q1		;GET CURRENT IDENT
	CALL JFNOF3		;GET OFN.PN
	 JRST [	CAIE A,LNGFX1	;TRIED TO CREATE A PT?
		JRST ERUNLD	;NO. GIVE THE ERROR THEN
		HRRO A,Q1	;GET PN IN RH AND -1 IN LH
		TRZ A,777000	;GET CURRENT PT OFFSET ONLY
		JRST .+1]	;GO IN-LINE
	MOVEM A,Q3
	MOVEI B,PGSIZ		;COMPUTE NUMBER WORDS LEFT IN PT
	SUBI B,0(A)
	CAML B,Q2		;GREATER THAN REMAINING COUNT?
	HRRZ B,Q2		;NO, USE COUNT
	ADD Q1,B		;UPDATE IDENT
	SUB Q2,B		;UPDATE COUNT
	SKIPGE Q3		;DOES THIS PT EXIST
	JRST UFPG2		;NO. SKIP OFN UPDATING THEN
	XCTU [HLL B,2]		;COPY FLAGS
	CALL UPDPGS		;DO THE WORK
	HLRZ A,Q3
	CALL UPDOFN		;UPDATE OFN ALSO
UFPG2:	JUMPG Q2,UFPG1		;LOOP OF COUNT NON-0
	CALL GETFDB		;CHECK FDB ALSO
	 JRST UFPG4		;COULDN'T, ASSUME OK (SHOULDN'T HAPPED)
	MOVX B,FILNB
	MOVX C,FB%NXF
	TDNN B,.FBADR(A)	;NEW FILE?
	TDNE C,.FBCTL(A)	;OR NONX?
	JRST [	ANDCAM B,.FBADR(A) ;YES, NORMALIZE
		ANDCAM C,.FBCTL(A)
		CALL UPDDIR	;AND UPDATE DIRECTORY
		JRST .+1]	;FILE NOW GUARANTEED ON DISK
	CALL USTDIR		;RELEASE DIRECTORY
UFPG4:	CALL UNLCKF		;UNLOCK JFN
	SMRETN
	SUBTTL WILD% JSYS

;WILD% JSYS.  USED TO COMPARE TWO STRINGS TO SEE IF THEY MATCH, OR
;TWO JFNS TO SEE IF THEY MATCH.  THE FIRST STRING OR JFN CAN CONTAIN
;WILDCARD CHARACTERS.

.WILD::	MCENT			;ENTER JSYS
	HLLZ F,T1		;PUT FLAGS IN A SAFE PLACE
	ANDI T1,-1		;ISOLATE FUNCTION CODE
	CAILE T1,WLDMXF		;LEGAL?
	 ITERR (ARGX02)		;NO
	SETZ Q2,		;INITIALIZE FLAGS TO BE RETURNED
	CALL @WLDDSP(T1)	;DO THE WORK
	UMOVEM Q2,1		;GIVE USER THE RESULT
	MRETNG			;DONE



WLDDSP:	IFIW	WLDSTR		;(0) COMPARE STRINGS
	IFIW	WLDJFN		;(1) COMPARE JFNS

	WLDMXF==.-WLDDSP-1	;MAXIMUM LEGAL FUNCTION
;STRING COMPARE FUNCTION.  AC2 CONTAINS BYTE POINTER TO WILD STRING,
;AC3 CONTAINS BYTE POINTER TO NON-WILD STRING.



WLDSTR:	TLNE F,-1-<(WL%LCD)>	;SPECIFYING ILLEGAL BITS?
	 ITERR (ARGX22)		;YES
	UMOVE T1,3		;SET UP NON-WILD POINTER
	UMOVE T2,2		;AND WILD POINTER
	TLC T1,-1		;GET SET TO DEFAULT LEFT HALFS
	TLC T2,-1
	TLCN T1,-1		;WAS LEFT HALF -1?
	HRLI T1,(POINT 7,)	;YES, USE DEFAULT
	TLCN T2,-1		;HOW ABOUT OTHER POINTER?
	HRLI T2,(POINT 7,)	;YES, FILL IN
; Check both pointers for reasonableness
	LDB T3,[POINT 6,T1,5]	;[7162] Get postion if local or P&S if global
	CAILE T3,44		;[7162] If .le. to 44 then we have
	IFSKP.			;[7162]  a local byte pointer
	  LDB T3,[POINT 6,T1,11] ;[7162] Get the byte size
	  CAIGE T3,7		;[7162] It must be at least 7
	  ITERR (ARGX09)	;[7162] An error if not
	ELSE.			;[7162] Probably a OWGBP
	  CAIL T3,54		;[7162] Is it at least 7 bits wide?
	  CAIL T3,77		;[7162] A P&S of 77 is illegal
	  ITERR (ARGX09)	;[7162] No, then no good
	ENDIF.

	LDB T3,[POINT 6,T2,5]	;[7162] Get postion if local or P&S if global
	CAILE T3,44		;[7162] If .le. to 44 then we have
	IFSKP.			;[7162]  a local byte pointer
	  LDB T3,[POINT 6,T2,11] ;[7162] Get the byte size
	  CAIGE T3,7		;[7162] It must be at least 7
	  ITERR (ARGX09)	;[7162] An error if not
	ELSE.			;[7162] Probably a OWGBP
	  CAIL T3,54		;[7162] Is it at least 7 bits wide?
	  CAIL T3,77		;[7162] A P&S of 77 is illegal
	  ITERR (ARGX09)	;[7162] No, then no good
	ENDIF.

	MOVEI T3,[PUSHJ P,WLDCH1 ;POINT AT INSTRUCTIONS
		  PUSHJ P,WLDCH2] ;WHICH WILL OBTAIN USER CHARS
	CALL CHKWLS		;SEE IF STRINGS MATCH
	TXOA Q2,WL%NOM		;NO, SET FLAG BIT
	RET			;YES, ALL DONE
	SKIPE T1		;IS IT AN ABBREVIATION?
	TXO Q2,WL%ABR		;YES, SET THAT
	RET			;DONE
;ROUTINES TO READ THE CHARACTERS FROM THE USER'S CORE.
;CHARACTERS HAVE TO BE RETURNED IN AC Q1 FOR CHKWLS TO USE.


WLDCH1:	XCTBU [ILDB Q1,T2]	;READ CHARACTER OF WILD STRING
	 ERJMPR [ITERR()]	;IN CASE REFERENCE FAILS
	JRST WLDCHC		;GO CHECK LOWER CASE

WLDCH2:	XCTBU [ILDB Q1,T1]	;READ CHARACTER OF NON-WILD STRING
	 ERJMPR [ITERR()]	;IN CASE REFERENCE FAILS

WLDCHC:	CAIL Q1,"A"+40		;IS CHARACTER LOWER CASE?
	CAILE Q1,"Z"+40		;WELL?
	RET			;NO
	TXNN F,WL%LCD		;SHOULD WE CONVERT TO UPPER CASE?
	SUBI Q1,40		;YES, DO SO
	RET			;DONE
;JFN COMPARE FUNCTION.  AC2 CONTAINS A WILD JFN, AND AC3 CONTAINS
;A NON-WILD JFN.

WLDJFN:	TLNE F,-1		;SUPPLYING ANY FLAGS?
	 ITERR (ARGX22)		;YES, GIVE ERROR
	UMOVE JFN,3		;GET JFN OF TEST FILE
	TLNE JFN,-1		;SPECIFYING ANY WILD FLAGS?
	 ITERR (WILDX1)		;YES, THAT IS ILLEGAL
	MOVE Q3,JFN		;SAVE FOR LATER
	CALL CHKFIL		;CHECK VALIDITY OF FILE JFN
	 ITERR ()		;ERROR IF BAD
	MOVE Q1,JFN		;REMEMBER JFN OFFSET OF TEST FILE
	UMOVE JFN,2		;GET JFN OF WILD FILE
	XOR Q3,JFN		;REMEMBER FLAG BITS AND COMPARE JFNS
	TRNN Q3,-1		;WERE THE WILD AND TEST JFNS THE SAME?
	JRST WLJFN2		;YES, A FILE MATCHES ITSELF!
	TLZ JFN,-1		;CLEAR FLAGS
	CALL CHKFIL		;VALIDATE THIS JFN TOO
	 ITERR (,<CALL WLERR>)	;BAD, UNLOCK FIRST JFN AND QUIT
	TXNN Q3,GJ%DEV!GJ%UNT	;DOES USER WANT WILD DEVICE OR UNIT?
	JRST WLDEV		;NO, GO COMPARE EXPLICIT DEVICES
	MOVE T1,FILSTS(Q1)	;GET FILE STATUS OF TEST JFN
	TXNE T1,ASTF		;IS IT PARSE ONLY?
	JRST WLJFD		;YES, THEN IT MATCHES
	BLCAL. DSKOK,<<FILDEV(Q1)>> ;A DSK?
	 TXO Q2,WL%DEV		;NO, SET DEVICES DIFFER FLAG
	JRST WLJFD		;GO ON TO DIRECTORIES

WLDEV:	HLRZ T1,FILDDN(JFN)	;GET DEVICE STRING OF WILD FILE
	HLRZ T2,FILDDN(Q1)	;AND OF TEST FILE
	CALL FLDCMP		;COMPARE THEM
	TXO Q2,WL%DEV		;NO MATCH, SET DEVICES DIFFER FLAG
WLJFD:	LOAD T2,FLDIR,(JFN)	;GET DIRECTORY STRING OF WILD FILE
	TXNN Q3,GJ%DIR		;WANT TO USE WILDCARDS INSTEAD?
	JRST WLJFD1		;NO, USE THIS STRING
	LOAD T2,FLDMS,(JFN)	;GET WILD STRING
	JUMPE T2,WLJFF		;IF NONE, ASSUME "*" AND MATCH
WLJFD1:	LOAD T1,FLDIR,(Q1)	;GET DIRECTORY STRING OF TEST FILE
	CALL FLDCMP		;DO THE COMPARISON
	TXO Q2,WL%DIR		;NO MATCH, SET DIRECTORIES DIFFER FLAG

WLJFF:	HLRZ T2,FILNEN(JFN)	;GET FILENAME STRING
	TXNN Q3,GJ%NAM		;WILDCARDING DESIRED?
	JRST WLJFF1		;NO, SO USE THIS STRING
	LOAD T2,FLNMS,(JFN)	;GET WILD STRING IF ANY
	JUMPE T2,WLJFE		;IF NONE, ASSUME "*" AND MATCH
WLJFF1:	HLRZ T1,FILNEN(Q1)	;GET FILENAME STRING OF TEST FILE
	CALL FLDCMP		;DO THE COMPARISON
	TXO Q2,WL%NAM		;NO MATCH, SET FILENAMES DIFFER FLAG


WLJFE:	HRRZ T2,FILNEN(JFN)	;GET EXTENSION STRING
	TXNN Q3,GJ%EXT		;SHOULD WE DO WILDCARDING?
	JRST WLJFE1		;NO, USE THIS STRING
	LOAD T2,FLEMS,(JFN)	;GET WILD MASK
	JUMPE T2,WLJFG		;IF NONE, MATCH THIS FIELD
WLJFE1:	HRRZ T1,FILNEN(Q1)	;GET EXTENSION STRING FOR TEST FILE
	CALL FLDCMP		;DO THE COMPARISON
	TXO Q2,WL%EXT		;NO MATCH, SET EXTENSIONS DIFFER FLAG


WLJFG:	TXNE Q3,GJ%VER		;WILD GENERATIONS DESIRED?
	JRST WLJFIN		;YES, THEN THEY MATCH
	HRRZ T1,FILVER(JFN)	;GET GENERATION OF WILD FILE
	HRRZ T2,FILVER(Q1)	;AND GENERATION OF TEST FILE
	CAME T1,T2		;ARE THEY THE SAME?
	TXO Q2,WL%GEN		;NO, SET GENERATIONS DIFFER FLAG


WLJFIN:	MOVE T1,JFN		;GET JFN OF WILD FILE
	CALL LUNLKF		;UNLOCK IT
WLJFN2:	MOVE T1,Q1		;GET JFN OF TEST FILE
	CALLRET LUNLKF		;UNLOCK IT TOO AND RETURN
;ROUTINE TO COMPARE STRINGS POINTED TO BY POINTERS IN T1 AND T2.
;IF NO POINTER EXISTS, THE STRING WILL BE DEFAULTED TO NULL.  SKIP
;RETURN IF STRINGS MATCH.

FLDCMP:	SKIPN T1		;ADDRESS OF TEST STRING MISSING?
	MOVEI T1,[EXP 0,0]	;YES, POINT TO A NULL STRING
	SKIPN T2		;ADDRESS OF WILD STRING MISSING?
	MOVEI T2,[EXP 0,0]	;YES, ALSO POINT TO NULL STRING
	HRLI T1,(POINT 7,0,35)	;FINISH BYTE POINTER
	CALLRET CHKWLD		;GO DO THE ACTUAL COMPARISON



;SUBROUTINE CALLED IF THE SECOND JFN IS BAD, TO UNLOCK THE FIRST
;JFN BEFORE GIVING THE ITRAP.


WLERR:	MOVE JFN,Q1		;GET FIRST JFN
	MOVE DEV,FILDEV(JFN)	;RESTORE STATUS ACS
	MOVE STS,FILSTS(JFN)	;THAT UNLCKF WANTS SET UP
	CALLRET UNLCKF		;GO UNLOCK THE JFN
	SUBTTL End of JSYSF

	TNXEND
	END