Google
 

Trailing-Edge - PDP-10 Archives - bb-m780d-sm - monitor-sources/jsysf.mac
There are 53 other files named jsysf.mac in the archive. Click here to see a list.
; UPD ID= 8715, RIP:<7.MONITOR>JSYSF.MAC.18,  19-May-88 16:10:38 by GSCOTT
;TCO 7.1290 - Don't enforce minimum password length if CRDIR called from
; monitor mode (like from FILCRD when building directories on a new structure).
; 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, 1988.
;	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()
; 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

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
; 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
;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

;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
; 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 blk ptr>,,<

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,T3		; 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

; 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>)
	SKIPN ASNPAS		;FIRST PASS?
	JRST [	HLRZ T4,DEVUNT(T2) ;GET OWNING JOB
		CAMN T4,JOBNO	;THIS JOB?
		JRST .+1	;YES. DON'T BOTHER WITH ACJ THEN
		UNLOKK DEVLKK	;YES
		OKINT		;ALLOW INTS NOW
		MOVE T1,ASNUAR	;GET USER'S ARG
		GTOKM (.GOASD,T1,[RETERR ()])		;DO GETOK AND RETURN IF ERROR
		MOVE T1,ASNUAR	;GET BACK ARG
		AOS ASNPAS	;ON SECOND PASS NOW
		JRST ASND0]	;AND CONTINUE
	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
; 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
; 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"
	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

; Access tables for chfdb

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

WRTR:	0			;FBTYP ,, FBLEN
	FB%NOD+FB%FCF+FB%FOR	;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%PRM+FB%TMP+FB%DEL+FB%NOD+FB%INV+FB%FCF+FB%FOR ;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%PRM+FB%TMP+FB%DEL+FB%NOD+FB%INV+FB%FCF+FB%NDL+FB%WNC+FB%FOR ;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
; 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
;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
	MOVE B,-1(P)		;PASS DOWN JFN
	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>
	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.

;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
;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
;	.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
	GTOKM (.GOCRD,)		;GETOK CREDIR
	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
	CALL CRDIR0		;GO DO THE WORK
	 ITERR ()		;AN ERROR OCCURED
	JRST MRETN		;EXIT
;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

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]
	;..								       
     
;MISCELLANEOUS SETUP FOR CRDIR

	;..
	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
	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
	TXNE B,CD%DIR		;IS THIS A FILES-ONLY DIRECTORY?
	JRST [	MOVX B,CDDIR	;YES. INDICATE IT IN THE LOCAL FLAG WORD
		IORM B,CRDFLG	;..
		JRST .+1]
	CALL USTDIR		;UNLOCK DIR
	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?
	JRST [	MOVEI A,CRDIX9	;NO, ILLEGAL FORMAT DIRECTORY FILE
		JRST CRDIR4]	;GO CLEAN UP AND BOMB OUT
	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.
>)
		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
	JRST [	MOVEI A,CRDIX1	;NO
		JRST CRDIR4]
	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?
	 JRST [	CALL USTDIR	;NO. UNLOCK THE DIRECTORY LOCKED BY SETDIR
		MOVEI A,CRDIX1	;WHEEL OR OPERATOR REQUIRED
		JRST CRDIR4]	;TAKE ERROR RETURN
	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
	 JRST [	CALL USTDIR	;UNLOCK THE DIRECTORY LOCKED BY SETDIR
		MOVEI A,CRDIX1	;WHEEL OR OPERATOR REQUIRED
		JRST CRDIR4]	;TAKE ERROR RETURN
	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
	 JRST [	CALL USTDIR	;UNLOCK THE DIRECTORY LOCKED BY SETDIR
		MOVEI A,CRDIX1	;WHEEL OR OPERATOR REQUIRED
		JRST CRDIR4]	;TAKE ERROR RETURN
	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
	RETBAD (CRDIX2)		;NO, DIR NUMBER MUST MATCH EXISTING #
	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 will fail and the directory will not be
	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
	 RETBAD(CRDIX4,<ULKDIR	;FAILED TO GET ROOM IN DIR
			JRST CRDIR4>)
	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
	RETBAD (CRDIX1,<ULKDIR>) ; in order to change password to null
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
CRDR2A:	UMOVE T1,.CDPSW(Q2)	;Get pointer to password
	CALL CPYFUS		;Copy to free storage
	 RETBAD (CRDIX3,<ULKDIR>) ;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
	CALL CKMMOD		;[7.1290] Check if previous context monitor
	 CAIA			;[7.1290] Nope, check password length
	JRST CRDR2B		;[7.1290] Yes, probably it is MSTR
	CALL CHPLEN		;[7.1231] (/) Check password length
	 RETBAD (CRDI30,<CALL CRDIR6
			 ULKDIR>) ;[7.1231] Password not long enough
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
         RETBAD(CRDI28,<CALL CRDIR6
			ULKDIR>) ;Bad version number
SKPENC:	JRST CRDRP2		;Go store the password

	;Here if password encryption version number was supplied
CRDRP1:	HRRZ T2,CRDUFL		;Get length of arguments
	CAIGE T2,.CDPDT		;Are they there? (version and date)
	 RETBAD(CRDI26,<CALL CRDIR6
			ULKDIR>)
	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?
	 RETBAD(CRDI27,<CALL CRDIR6
			ULKDIR>)

CRDP1A:	CALL CHKPEV		;Test validity of encryption version number
	 RETBAD(CRDI28,<CALL CRDIR6
			ULKDIR>) ;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
CRDRP2:	MOVE T1,CRDIRN		;Recover JSB address
	CALL SETMSK		;Store in directory
	CALL CPYDIR		;And copy string to directory
	 RETBAD(CRDIX4,<CALL CRDIR6
			ULKDIR>)
	MOVEI B,.TYNAM		;MARK AS NAME BLOCK
	STOR B,NMTYP,(A)	;...
CRDRP3:	LOAD B,DRPSW,(Q1)	;GET POINTER TO OLD PASSWORD STRING
	SUB A,DIRORA		;GET RELATIVE ADR OF PASSWORD STRING
	STOR A,DRPSW,(Q1)	;STORE NEW PASSWORD STRING POINTER
	JUMPE B,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
	 RETBAD (CRDIX3,<ULKDIR>)
	MOVEM A,CRDIRN		;SAVE ADDRESS OF STRING
	CALL SETMSK		;STORE IN DIRECTORY
	CALL CPYDIR		;AND COPY STRING TO DIRECTORY
	 RETBAD (CRDIX4,<CALL CRDIR6
			 ULKDIR>)
	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
	TXNN B,SC%WHL!SC%OPR	;UNLESS WHOPER
	JRST [	MOVE B,A
		ANDCM B,CAPENB
		JUMPE B,.+1
		MOVEI A,CRDI20
		CALL USTDIR
		JRST CRDIR4]
	STOR A,DRPRV,(Q1)	;YES
	;..
;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
	CALL USTDIR		;UNLOCK THE DIRECTORY
	JRST CRDIR4		;TAKE ERROR ROUTE
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 CRDPUC		;YES, DONT LET TIME GO BACKWARDS
	TXNE Q3,CD%LLD		;WANT TO SET IT?
	STOR A,DRDAT,(Q1)	;YES
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?
	 RETBAD(CRDI26,<ULKDIR>) ;No
	MOVE T1,CAPENB		;[7.1020] Get privs
	TXNN T1,SC%WHL!SC%OPR	;[7.1020] Is user prived?
	RETBAD (CRDIX1,<ULKDIR>);[7.1020] 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?
	 RETBAD(CRDI26,<ULKDIR>) ;No
	MOVE T1,CAPENB		;[7.1020] Get privs
	TXNN T1,SC%WHL!SC%OPR	;[7.1020] Is user prived?
	RETBAD (CRDIX1,<ULKDIR>);[7.1020] No, don't let him change this
	UMOVE T1,.CDPED(Q2)	;Yes, get it
	STOR T1,DRPED,(Q1)	;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
	JUMPL A,[ RETBAD (CRDI21,<CALL USTDIR>)] ;NOT ENOUGH QUOTA FOR EXISTING FILES
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?
	RETBAD (CRDI24,<CALL USTDIR>) ;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?
	RETBAD (CRDI22,<CALL USTDIR>) ;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
		 RETBAD(CRDI16,<CALL USTDIR>) ;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
		 RETBAD(CRDI16,<CALL USTDIR>) ;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
	JUMPL A,[ RETBAD (CRDI13,<CALL USTDIR>)] ;CAN'T CHANGE SUPERIOR
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,[ RETBAD(CRDI14,<CALL USTDIR>)] ;LOQ EXHAUSTED
	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,[ RETBAD(CRDI15,<CALL USTDIR>)] ;SDQ EXHAUSTED
	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		; ...
	 RETBAD(MONX03)		;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
          RETBAD ()             ;[7461] Failed - pass error along
	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
	   RETBAD ()		;failure. pass error up.
	ENDIF.
	;..
;DO ALLOCATION, DEFAULT PROTECTION, DIRECTORY PROTECTION
; Online & offline expiration defaults

	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
	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?
	  RETBAD(ARGX27,<ULKDIR>) ;  Out of reasonable range
	ELSE.
	  CAMLE A,TPRCYC	; Within range?
	  RETBAD(ARGX27,<ULKDIR>) ; No
	ENDIF.
      ENDIF.
	STOR A,DRDFE,(Q1)	;Store user value
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
	RETBAD (PPNX1,<ULKDIR>)	;ILLEGAL PROJECT NUMBER
	UMOVE A,.CDPPN(Q2)	;GET PPN BACK AGAIN
	TRNN A,-1		;PROGRAMMER NUMBER OF ZERO IS ILLEGAL
	RETBAD (PPNX1,<ULKDIR>)	;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
	RETBAD (PPNX1,<ULKDIR>)	;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
	ULKDIR
	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
;[7.1231]
;CHPLEN - Routine to check and see if a minimum password length
;is required. If so, then the supplied password must be long enough.
;
; Called with:
;	password string in JSB free space
;	CALL CHPLEN
;
; Returns:
;	+1 - Password not long enough
;	+2 - Password long enough or no minimum length required
;
;Preserves things

CHPLEN:	SAVET			;Don't mangle
	SKIPN MINPAS		;Do we want a minimum password length?
	RETSKP			;No, so this is done

;Note - Because this is a lookup pointer, the string actually starts
;at the (CRDIRN)+1 and not (CRDIRN)+0

	MOVE T1,CRDIRN		;Get pointer to password string block
	AOS T1			;Go past length word
	HRLI T1,(POINT 7,)	;Make a nice byte pointer
	SETZ T4,		;This is our counter
	DO.			;Now count the number of characters
	  ILDB T2,T1		;Get a character
	  JUMPE T2,ENDLP.	;If it is a null, then we are done
	  AOJA T4,TOP.		;Bump the count and get next character
	OD.			;No more characters, count is in T4
	CAMGE T4,MINPAS		;Is it big enough?
	RET			;No, return failure
	RETSKP			;Yes it is, this is a good one to use
; ERROR ROUTINES

CRDIR4:	MOVEM A,CRDIRE		;SAVE ERROR CODE
	CALL CRDIR6		;RELEASE JSB SPACE
	HRRZ A,CRDIRJ		;GET JFN OF DIR FILE
	JUMPE A,CRDR00		;DON'T RELEASE IT IF ALREADY RELEASED
	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

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.
>)
	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,<ULKDIR>) ;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
; 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,1
	CALL CHKJFN		; Check it out
	 JRST GBGJFN
	 JFCL
	 ERUNLK DESX4		; Tty or byte illegal
	TQNE <ASTF>
	 ERUNLK(DESX7)		; Output stars not allowed
	CALL @DELD(P3)		; Call device dependent routine
	 ERUNLK()		; Couldn't delete
	UMOVE A,1
	TLNE A,(DF%NRJ)		;IF B0, DON'T RELEASE JFN
	JRST DELF1
	TQNN <OPNF>
	JRST [	MOVEI A,0(JFN)	;GET THE JFN
		CALL LUNLK0	;FREE THE STR LOCK
		CALL RELJFN	;RELEASE THE JFN
		SMRETN]
DELF1:	CALL UNLCKF
	SMRETN
;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?
	 ERUNLK GFDBX1		;NO, CAN'T DO
	LOAD A,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
; 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
; 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.
>)
	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
;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
;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
; 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
; 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
; 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
; 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
;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
; 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
; 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
; Convert jfn to string
; Call:	1	; Jfn
;	2	; String pointer
;	3	; Format specification (see jsys manual)

MSKSTR JS%T1,Q1,1B0		;LOCAL FLAG - PUNCTUATE NULL EXTENSION
MSKSTR JS%T2,Q1,1B1		;LOCAL FLAG - MULTIPLE DIR DEV
MSKSTR JS%T3,Q1,1B2		;LOCAL FLAG - SUPPRESSING LEADING TAB

.JFNS::	MCENT
	UMOVE A,3		;GET BITS
	TRNE A,1B26		;IS AC2 JFN OR STRING POINTER?
	JRST JFNX0		;STRING
	HRRZ JFN,2
	CALL CHKJFD
	 ITERR()
	 JFCL
	 ITERR(DESX4)
	CALL UNLCKF
	UMOVE A,1
	TLNN A,777777
	 JRST JFNSZ		; Not byte pointer
	TLC A,777777
	TLCN A,777777
	 HRLI A,440700		; -1 in lh, fill in
	SETZ B,
	UMOVEM A,1		; Return to user
	XCTBU [IDPB B,A]	; Deposit initial null in case
JFNSZ:	XCTU [HLLZ F1,2]
	XCTU [SKIPN Q3,3]
	MOVE Q3,[6B2!2B5!1B8!1B11!2B14!JS%ATR!JS%PSD!JS%PAF]
	SETZ Q1,		; Initialize tab flag
	LOAD A,FLNOD,(JFN)	;SEE IF A NODE SPECIFIED IN THIS JFN
        IFN. A

;DO NODE AND DEVICE FIELD WHEN NODE IS PRESENT IN FILE SPEC

          LDB D,[POINT 1,Q3,0]	;YES, USE BIT FROM DEVICE FIELD CONTROL
	  CAIN D,0		;print node name ?
	  IFSKP.
            CALL TAB4		;Yes. begin node field
            CALL JFNSS		;PRINT NODE NAME
            MOVEI B,PNCNOD	;PRINT NODE PUNCTUATION
            CALL PUNCT
	    CALL PUNCT
	  ENDIF.
	  TQO <JS%T1,JS%T2>	;punc. null ext. & mult. dir device
          LDB D,[POINT 2,Q3,2]	;now do the device field (2 bits)
	  CALL TAB4		;BEGIN DEVICE FIELD
	  CAIN D,0		;print device name ?
	  IFSKP.
            HLRZ A,FILDDN(JFN)	;YES.  GET THE DEVICE NAME STRING TO PRINT
            CALL JFNSS		; Output the string in a
            MOVEI B,":"
            CALL PUNCT
	  ENDIF.
        ELSE.
	;...
;DO DEVICE FIELD WHEN NO NODE IS PRESENT IN FILE SPEC
	  TXZ Q3,JS%NOD		; null out node bit
          HLRZ A,FILDDN(JFN)	; Get pointer to device block
          MOVN B,(A)
          HRLI A,-2(B)
          CALL DEVLUX
           SETZ A,
          MOVE C,DEVUNT(B)	;GET PSEUDO-DEVICE FLAG
          CAME C,[-1]		;NO UNITS?
          TXNN C,DV%PSD		;PSEUDO-DEVICE?
          TLNE A,(DV%DIR)
          TQOA JS%T1
          TQZ JS%T1
          TQNE <ASTF>		;PARSE-ONLY?
          TQO JS%T1		;YES, ALWAYS PUNCTUATE EXTENSION
	  CAME C,[-1]		;NO UNITS?
	  TXNN C,DV%PSD		;PSEUDO-DEVICE?
	  TLNE A,(DV%MDD)
	  TQOA JS%T2
	  TQZ JS%T2
          CALL GTCSCD		; GET THE STRUCTURE UNIQUE CODE
          HLRZ C,A		; OF THE CURRENT CONNECTED STR
          LDB D,[POINT 3,Q3,2]	; Get format control byte for device
          CALL TAB4
          JUMPE D,JFNS0		;GO ON IF NO PRINT WANTED
          TQNE <STRSF>		;WILD DEVICE?
          IFSKP.
            LOAD A,FLUC,(JFN)	; GET THE UNIQUE CODE OF THE DEV
            CAIN D,2		; If it is suppress system default
            CAME A,C		; AND IS THE DEVICE THE CONNECTED STR?
            IFSKP. <JRST JFNS0>	;YES, DON'T PRINT
            HLRZ A,FILDDN(JFN)	; GET THE DEVICE NAME STRING TO PRINT
            CALL JFNSS		; Output the string in a
          ELSE.
            MOVEI B,[ASCIZ/DSK*/]-1 ;YES, POINT AT WILD STRING
            CALL JFSTA1		;OUTPUT IT
          ENDIF.
            MOVEI B,":"
            CALL PUNCT
        ENDIF.
	; ..
;DO DIRECTORY FIELD

JFNS0:	LOAD A,FLDNO,(JFN)	;GET DIRECTORY NUMBER
	LDB D,[POINT 3,Q3,5]	; And format control
	CALL TAB4		; Tab before field if desired
	TQNE <DIRSF>
	JRST JFNS0A
	CAIN D,2		; If suppressing default,
	JRST [	LOAD T1,JSCDF	;CONNECTED DIRECTORY STRING VALID FLAG
		SKIPN T1	; SKIP IF STRING EXISTS IN JSB
		CALL JFNSCD	; ELSE TRY TO SET ONE UP
		JE JSCDF,,JFNS0A ;IF NO VALID NAME STRING IN JSB, PRINT DIR
		LOAD A,JSCDS	;GET ADR OF CONNECTED DIR STRING
		HRLI A,(POINT 7,0,35)
		LOAD B,FLDIR,(JFN) ;GET ADR OF DIR NAME STRING
		JUMPE B,JFNS1	;IF NO DIR NAME, DONT OUTPUT IT
		HRLI B,(POINT 7,0,35)
		CALL STRCMP	;COMPARE THE STRINGS
		 JRST JFNS0A	;THE STRINGS DONT MATCH, GO OUTPUT DIR
		JRST JFNS1]	;THEY MATCH, DO NOT OUTPUT THE DIR NAME
JFNS0A:	LDB D,[POINT 3,Q3,5]	; GET format control
	CAIN D,0		; if no print is wanted
	JRST JFNS1		; Then don't print
	LOAD B,FLDIR,(JFN)	; GET POINTER TO DIRECTORY STRING
	TQNN <DIRSF>		; IF STARS, GO RETURN THE WILD STRING
	JUMPE B,JFNS1		; IF NONE, DONT TRY TO OUTPUT IT
	MOVEI B,"<"
	CALL PUNCT		; Print punctuation if desired
	TQNE <DIRSF>
	JRST [	LOAD B,FLDMS,(JFN) ;GET WILD MASK
		CALL JFSTA1	; GO DO IT OR A STAR
		JRST JFNS0B]
	LOAD A,FLDIR,(JFN)	; GET POINTER TO DIRECTORY STRING
	JUMPE A,JFNS0B		; IF NONE, DONT TRY TO OUTPUT IT
	CALL JFNSSD		; Copy string to output
JFNS0B:	MOVEI B,">"
	CALL PUNCT		; And output terminating punct

;DO NAME FIELD

JFNS1:	HLRZ A,FILNEN(JFN)	; Get location of file name block
	LDB D,[POINT 3,Q3,8]	; And output control
	JUMPE D,JFNS2		;[7276] No print wanted
	CALL TAB4		; Tab before field if required
	TQNE <NAMSF>
	JRST [	LOAD B,FLNMS,(JFN) ;GET NAME WILD MASK
		CALL JFSTA1	; PRINT IT OR A STAR
		JRST JFNS2]
	CALL JFNSS		; Copy string to output
	; ..
;DO EXTENSION FIELD

JFNS2:	HRRZ A,FILNEN(JFN)	; Get location of extension block
	LDB D,[POINT 3,Q3,11]	; And output control
	JUMPE D,JFNS3		;[7276] No print wanted
	CALL TAB4		; Tab before field if required
	MOVEI B,"."
	MOVE C,1(A)		; SEE IF THERE IS AN EXTENSION STRING
	TLNN C,774000		; IF NON-NUL STRING, TYPE OUT PUNCT.
	TQNE JS%T1
	CALL PUNCT		; Output punctuation if desired
	TQNE <EXTSF>
	JRST [	LOAD B,FLEMS,(JFN) ;GET EXTENSION WILD MASK
		CALL JFSTA1	; PRINT IT OR A STAR
		JRST JFNS3]
	CALL JFNSS		; Copy to output

;DO VERSION

JFNS3:	HRRE A,FILVER(JFN)	; Get version number
	LDB D,[POINT 3,Q3,14]	; And output control
	JUMPE D,JFNS4		;[7276] No print wanted
	CALL TAB4		; Tab before field if required
	TQNE <ASTF>		;HAD OUTPUT STARS?
	JRST [	JUMPN A,DOJF3	;YES. DO NON-ZERO VERSION
		TXNE F1,VERSF!RVERF!HVERF!LVERF ;ANY SPECIALS?
		JRST DOJF3	;YES. DO THEM
		JRST .+1]	;NO. DO LAST TEST
	TQNN JS%T2
	JRST JFNS4
DOJF3:	MOVEI B,PNCVER
	CALL PUNCT
	MOVE B,A
	MOVEI C,12
	TQNE <VERSF>
	JRST [	CALL JFSTAR
		JRST MRETN]
	TQNE <RVERF>
	MOVNI B,0
	TQNE <HVERF>
	MOVNI B,1
	TQNE <LVERF>
	MOVNI B,2
	CALL NOUTXX
	; ..
;SAVE INFORMATION FOR ;A, ;P, ;T

JFNS4:	TQNE <ASTF>		;STARS?
	JRST JFNS44		;YES. SKIP ALL DIRECTORY STUFF
	BLCAL. DSKOK,<P3>	;DISK?
	IFNSK.
	  CAIE P3,MTDTB	;AN MT?
	  IFSKP.
	    LDB D,[POINT 3,Q3,17] ;GET CTL BITS FOR PROTECTION
	    SKIPE D		;[7276]PRINT TAB?
	    CALL TAB4		;DO TAB CONTROL
	    CALL MTGPRO		;GET PROTECTION
	    ANDN. A		;IF NONE, DONE
	    ANDN. D		;IF NO TYPEOUT, DONE
	    TXO A,5B2		;MAKE SURE IT IS A NUMBER
	    CALL JFNSP		;AND DO IT
	  ENDIF.
	  CALL JFNSAT		;TYPE OUT ATTRIBUTES (IF ANY)
	  MRETNG		;DONE
	ENDIF.
	CALL GETFDB		; Get a pointer to the fdb
	 JRST [	CALL JFNSAT	;TYPE OUT ATTRIBUTES (IF ANY)
		MRETNG]		;DONE
	PUSH P,.FBREF(A)
	PUSH P,.FBWRT(A)
	PUSH P,.FBCRV(A)
	LOAD B,FBNPG,(A)
	PUSH P,B
	PUSH P,.FBCTL(A)
	MOVE B,.FBACT(A)	; Get account
	SETZ C,			; 0 words of string
	TLNN B,700000		; String account?
	 JRST [	ADD B,DIRORA	;GET ABSOLUTE ADR OF STRING
		EXCH A,D	;SAVE A
		LOAD A,ACLEN,(B) ;GET LENGTH OF STRING BLOCK
		SUBI A,.ACVAL	;SKIP HEADER AND SHARE COUNT
		HRL A,A		;TO BOTH HALVES
		XMOVEI C,1(P)	;WHERE TO PUT STRING ON STACK
		XMOVEI B,.ACVAL(B)	;WHERE TO GET STRING FOM
		ADD P,A
		PUSH P,A	;SAVE TO BEYOND STRING
		PUSH P,C	;SAVE STACK POINTER (POINTER TO STRING
		SOS 0(P)
		CALL XBLTA	;DO BLT
		EXCH D,A	;RESTORE
		JRST JFNS43]
	PUSH P,C		; Save size of string
	PUSH P,B		; And account or pointer
JFNS43:	MOVE D,DIRORA		; GET BASE ADR OF MAPPED DIR
	LOAD D,DRDPW,(D)	; GET DEFAULT PROTECTION WORD
	PUSH P,D		; PUT IT ON THE STACK
	PUSH P,.FBPRT(A)
	CALL USTDIR		; Unlock directory (done with it)
JFNS44:	LDB D,[POINT 3,Q3,17]
	SKIPE D			;[7276]PRINT TAB?
	CALL TAB4
	TQNE <ASTF>		;PARSE ONLY?
	JRST [	SKIPE D		;YES. WANT OUTPUT OF PROTECTION?
		SKIPN FILPRT(JFN) ;YES. HAVE ONE?
		JRST JFNS5	;NO. GIVE IT UP
		JRST JFNS45]	;GO DO IT
	MOVE B,0(P)
	CAIN D,2
	CAME B,-1(P)
	CAIN D,0
	JRST JFNS5
	; ..
;DO ;P

JFNS45:	MOVE A,0(P)		;GET PROTECTION
	TQNE <ASTF>		;PARSE ONLY?
	MOVE A,FILPRT(JFN)	;YES. GET IT FROM JFN THEN
	TXNE Q3,JS%PRO		;[7276]JS%PRO SET?
	CALL JFNSP		;AND DO IT

;DO ;A

JFNS5:	TQNN <ASTF>		; PARSE ONLY
	SUB P,[XWD 2,2]		; Flush protection and def prot
	LDB D,[POINT 3,Q3,20]
	JUMPE D,JFNS6		;[7276]PRINT FIELD?
	CALL TAB4
	CAIN D,2		; WANT DEFAULT?
	TQNE <ASTF>		; YES, AND NOT OUTPUT STARS?
	JRST JFNS5A		; NO, PRINT OUT THE ACCOUNT STRING
	MOVE A,[POINT 7,ACCTSR]	; GET A POINTER TO THE CURRENT ACCOUNT
	MOVE B,0(P)		; GET POINTER TO THIS ACCOUNT STRING
	JUMPL B,JFNS5A		; IF OLD STYLE NUMERIC ACCOUNT, GO PRINT IT
	HRLI B,(POINT 7,0,35)	; OTHERWISE SET UP A BYTE POINTER
	CALL STRCMP		; SEE IF THE STRINGS ARE EQUAL
	 SKIPA			; NO, GO OUTPUT IT
	JRST JFNS6		; THE ACCOUNT IS THE DEFAULT, DONT OUTPUT
JFNS5A:	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI B,"A"
	CALL PUNCT
	TQNE <ASTF>		; PARSE ONLY?
	SKIPA A,FILACT(JFN)	; YES. GET IT FROM JFN THEN
	MOVE A,(P)		; Get account or pointer
	MOVEI C,^D10
	SKIPE A			;IF ZERO, FORGET IT .
	CALL JFNSN

;DO ;T

JFNS6:	TQNN <ASTF>		;PARSE ONLY?
	 IFSKP.			;If JFN is parse only then
	  CALL JFNSAT		;  output any linked attributes
	  MRETNG		;  and exit since finished
	 ENDIF.
	ADJSP P,-1		; Flush account or pointer
	POP P,C			; Get size of saved string
	SUB P,C			; Flush string from stack
	LDB D,[POINT 1,Q3,21]
	POP P,B
	TXNE B,FB%TMP
	CAIN D,0
	JRST JFNS6A
	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI B,"T"
	CALL BOUTA

JFNS6A:	LDB D,[POINT 1,Q3,29]	; Offline output bit
	TXNE B,FB%OFF		; File offline?
	CAIN D,0		; And ;OFFLINE output requested?
	JRST JFNS7		; No
	MOVEI B,PNCATT		; Yes
	CALL PUNCT
	MOVEI A,[ASCIZ /OFFLINE/]-1  ; String for output by JFNSS
	CALL JFNSS
	; ..
;DO SIZE IN PAGES

JFNS7:	CALL JFNSAT		;OUTPUT THE ATTRIBUTES
	LDB D,[POINT 1,Q3,22]
	JUMPE D,JFNS8		;[7276]PRINT FIELD?
	CALL JFNCOM
	CALL TAB4
	MOVE B,0(P)		;GET SIZE
	MOVEI C,^D10
	CALL NOUTXX

;DO DATES

JFNS8:	ADJSP P,-1
	CALL TAB4		;[7276]TAB OVER TO NEXT STOP
	POP P,B			;GET .FBCRV
	TRNE Q3,JS%CDR		;[7276]PRINT CREATION DATE?
	CALL JFNDAT
	TXNE Q3,JS%CDR		;[7276]PRINT TAB FOR NEXT FIELD?
	CALL TAB4
	POP P,B			;GET .FBWRT
	TRNE Q3,JS%LWR		;[7276]PRINT LAST-WRITE DATE?
	CALL JFNDAT
	TXNE Q3,JS%LWR		;[7276]PRINT TAB FOR NEXT FIELD?
	CALL TAB4
	POP P,B			;GET .FBREF
	TRNE Q3,JS%LRD		;[7276]PRINT LAST-READ DATE?
	CALL JFNDAT
	 JFCL
	JRST MRETN

;LOCAL ROUTINE TO OUTPUT PROTECTION
;	A/ PROTECTION

JFNSP:	PUSH P,A		;SAVE PROTECTION
	MOVEI B,PNCATT
	CALL PUNCT		;DO PUNCT CHAR
	MOVEI B,"P"		;GET PREFIX
	CALL PUNCT		;DO IT AS WELL
	POP P,A			;GET BACK PROTECTION WORD
	MOVEI C,10		;IN OCTAL
	CALLRET JFNSN		;AND DO IT
;DO ATTRIBUTES

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
	UMOVE A,4		;YES, GET THE POINTER TO PREFIX
	CALL CPYFUS		;COPY STRING TO MONITOR SPACE
	 ITERR()		;FAILED
	MOVEM A,JFNSAA		;SAVE ADR OF STRING BLOCK
	HRLI A,(POINT 7,0,35)	;SET UP A BYTE POINTER TO STRING
	MOVEI B,PRFXTB		;SET UP TO LOOK FOR PREFIX
	EXCH A,B
	TBLUK			;LOOK UP PREFIX
	 ERJMP JFN1AE		;FAILED
	TXNN B,TL%ABR!TL%EXM	;FOUND A MATCH?
	JRST JFN1AE		;NO, ERROR
	HRRZ B,0(A)		;GET THE PREFIX VALUE
	ANDI B,PFXMSK		;GET JUST THE VALUE
	LOAD A,FLATL,(JFN)	;GET POINTER TO START OF ATTRIBUTE LIST
JFN1A1:	JUMPE A,JFN1AE		;IF NONE, GIVE ERROR RETURN
	LOAD C,PRFXV,(A)	;GET PREFIX VALUE OF THIS ENTRY
	CAMN C,B		;FOUND A MATCH YET?
	JRST JFN1A2		;YES, GO RETURN THE VALUE
	LOAD A,PRFXL,(A)	;STEP TO NEXT ENTRY ON LIST
	JRST JFN1A1		;LOOP BACK TIL DESIRED ENTRY FOUND

JFN1A2:	CALL JFNSS		;GO RETURN THE STRING TO THE USER
	HRRZ B,JFNSAA		;GET ADDRESS OF TEMP STRING
	MOVEI A,JSBFRE		;RETURN TEMP STRING
	CALLRET RELFRE		;AND EXIT

JFN1AE:	HRRZ B,JFNSAA		;RETURN THE TEMP STRING
	MOVEI A,JSBFRE		;TO THE FREE POOL
	CALL RELFRE
	ITERR (GJFX40)		;NO SUCH ATTRIBUTE ERROR


;RETURN ALL ATTRIBUTES TO THE CALLER

JFNAT1:	SETZB A,JFNSAC		;INITIALIZE THE COUNT OF ATTRIBUTES
JFNAT2:	CALL GTNPFX		;GET THE NEXT PREFIX
	 RET			;NO MORE, RETURN
	MOVEM A,JFNSAA		;SAVE THE ADDRESS OF THE BLOCK
	LOAD B,PRFXV,(A)	;GET THE ATTRIBUTE PREFIX
	CAIN B,.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 B,PNCATT		;GET THE STARTING PUNCTUATION
	CALL PUNCT		;PUT ";" INTO CALLER'S STRING
	MOVE A,JFNSAA		;GET BACK ADDRESS OF THE ATTRIBUTE
	LOAD A,PRFXV,(A)	;GET THE PREFIX VALUE FROM BLOCK
	CALL GTPFXS		;GET ADDRESS OF PREFIX STRING
	 RET			;COULD NOT FIND IT, JUST RETURN
	MOVEM B,JFNSAV		;SAVE THE VALUE
	CALL JFNSS		;OUTPUT THE PREFIX STRING
	MOVE C,JFNSAV		;GET BACK THE VALUE OF THE PREFIX
	TRNE C,NOATRF		;IS THIS A NO VALUE ATTRIBUTE?
	JRST JFNAT3		;YES, DO NOT ADD ON A NULL VALUE
	MOVEI B,PNCPFX		;GET PUNCTUATION OF PREFIX
	CALL PUNCT		;OUTPUT THE ":"
	HRRZ A,JFNSAA		;GET THE ADDRESS OF THE ATTRIBUTE BLOCK
	CALL JFNSS		;OUTPUT THE ATTRIBUTE VALUE
JFNAT3:	AOS A,JFNSAC		;STEP TO THE NEXT ATTRIBUTE
	JRST JFNAT2		;LOOP BACK TILL ALL ATTRIBUTES SEEN


;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
;JFNX
;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
JFNX0:	MOVE JFN,2
	CALL CHKJFN
	 ITERR()
	 ITERR(DESX4)
	 JRST JFNX0A
	CALL UNLCKF
	ITERR(DESX1)

JFNX0A:	UMOVE A,1
	TLNN A,777777
	 JRST JFNX1		; Not byte pointer
	TLC A,777777
	TLCN A,777777
	 HRLI A,440700		; -1 in lh, fill in
	SETZ B,
	XCTBU [IDPB B,A]	; Deposit initial null in case
JFNX1:	XCTU [HLLZ F1,2]
	XCTU [MOVE Q3,3]
	MOVEI B,11
	TRNE Q3,3B34		;EITHER TAB REQUEST?
	CALL BOUTA		;YES, OUTPUT TAB
	TXNE Q3,7B2		;DEVICE?
	JRST JFNXDA		;YES
	TXNE Q3,7B5		;DIRECTORY?
	JRST JFNXDB		;YES
	TXNE Q3,7B8		;NAME?
	JRST JFNXN		;YES
	TXNE Q3,7B11		;EXTENSION?
	JRST JFNXE		;YES
	TXNE Q3,7B14		;VERSION?
	JRST JFNXV		;YES
	TXNE Q3,7B17		;PROTECTION?
	JRST JFNXP		;YES
	TXNE Q3,7B20		;ACCOUNT?
	JRST JFNXA		;YES
	TXNE Q3,1B21		; ";T" ?
	JRST JFNXT		;YES
	TXNE Q3,JS%ATR!JS%AT1	;ATTRIBUTES?
	JRST JFNXAT		;YES
	TXNE Q3,17B25		;SIZE OR ANY DATE?
	JRST JFNXSD		;YES
	TXNE Q3,JS%OFL		;OFFLINE?
	JRST JFNXOF
;DEVICE
JFNXDA:	CALL JFNXDO		;COPY USER STRING
	MOVEI B,":"
	JRST JFNXX1		; STORE PUNCTUATION AND EXIT

;DIRECTORY
JFNXDB:	MOVEI B,"<"
	CALL PUNCT
	CALL JFNXDO
	MOVEI B,">"
	JRST JFNXX1

;SIZE OR DATE
JFNXSD:	MOVEI B,","
	TRNE Q3,1B32
	CALL BOUTA
;NAME
JFNXN:	CALL JFNXDO
	JRST JFNXX2

;EXTENSION
JFNXE:	MOVEI B,"."
JFNXE1:	CALL PUNCT
	JRST JFNXN

;VERSION
JFNXV:	MOVEI B,PNCVER
	JRST JFNXE1

;ACCOUNT
JFNXA:	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI B,"A"
	JRST JFNXE1

;PROTECTION
JFNXP:	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI B,"P"
	JRST JFNXE1

;OFFLINE
JFNXOF:	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI A,[ASCIZ /OFFLINE/]-1
	CALL JFNSS
	JRST JFNXX2

;TEMPORARY
JFNXT:	MOVEI B,PNCATT
	CALL PUNCT
	MOVEI B,"T"
;END ROUTINE
JFNXX1:	CALL PUNCT
JFNXX2:	JRST MRETN

JFNXDO:	CAIN JFN,377777		;NIL?
	RET			;YES, DONE
JFNXD1:	XCTBU [ILDB B,JFN]	;GET BYTE FROM USER
	JUMPE B,R		;END ON NULL
	UMOVEM JFN,2		;UPDATE BYTE POINTER
	CALL BOUTA		;OUTPUT BYTE
	JRST JFNXD1
;ROUTINE TO PUNCTUATE ATTRIBUTES

JFNXAT:	MOVEI B,PNCATT		;ATTRIBUTE STARTING PUNCTUATION
	CALL PUNCT		;OUTPUT THE ";"
	CALL JFNXDO		;FOLLOWED BY THE PREFIX STRING
	TXNN Q3,JS%AT1		;DOES THIS HAVE A VALUE
	JRST JFNXX2		;NO, ALL DONE
	MOVEI B,PNCPFX		;YES, OUTPUT THE PUNCTUATION
	CALL PUNCT		;  BETWEEN FIELDS
	UMOVE JFN,4		;SET UP POINTER TO VALUE STRING
	TLC JFN,-1		;SEE IF -1 IN LH
	TLCN JFN,-1		;...
	HRLI JFN,(POINT 7,0)	;YES, SET UP BYTE POINTER
	CALL JFNXDO		;OUTPUT THE STRING
	JRST JFNXX2		;ALL DONE
;LOCAL NUMBER OUTPUT ROUTINE FOR JFNS
;NOUTXX ALWAYS PRINTS NUMBER
;JFNSN TAKES A AS STRING POINTER IF POSITIVE, NUMBER (AFTER FLUSHING
; BITS 0-2) IF NEGATIVE

JFNSN:	JUMPG A,JFNSS		; Copy to output
	MOVE B,A
	TLZ B,700000
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



;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
;LOCAL DATE PRINTER FOR JFNS

JFNDAT:	PUSH P,B
	MOVEI D,1
	CALL JFNCOM
	POP P,B
	PUSH P,A
	SETZ C,
	HRROI A,1(P)
	ADD P,[XWD 5,5]		;[7355]
	ODTIM
	MOVEI C,-4(P)		;[7355]
	HRLI C,(<POINT 7,0>)
JFNDA1:	ILDB B,C
	JUMPE B,[SUB P,[XWD 5,5] ;[7355]
		 POP P,A
		 RET]
	CALL BOUTA
	JRST JFNDA1

;PRINT COMMA IF D=TRUE AND Q3/B32=1

JFNCOM:	MOVEI B,","
	CAIE D,0
	TRNN Q3,1B32
	RET
	CALLRET BOUTA

;PRINT MASK ADDRESSED BY B OR A STAR IF B IS ZERO

JFSTAR:	SKIPA			; ALWAYS DO A STAR IF ENTERED HERE
JFSTA1:	SKIPN B			; HAVE A MASK INSTEAD?
	MOVEI B,[ASCIZ /*/]-1	; NO. USE A STAR
	HRLI B,(<POINT 7,0,35>)	; MAKE A STRING POINTER
	STKVAR (MSKSAV)		; SAVE STRING PTR IN TEMP STORAGE
	MOVEM B,MSKSAV		; SAVE B FOR NOW
JFLOP:	ILDB B,MSKSAV		; TOP OF PRINT LOOP
	JUMPE B,R		; IF AT THE END, RETURN
	CALL BOUTA		; OUTPUT THE BYTE
	JRST JFLOP		; DO ALL OF STRING

;PRINT PUNCTUATION IF Q3/B35=1

PUNCT:	TRNE Q3,1B35
	CALLRET BOUTA
	RET

;PRINT TAB PER Q3/B33-34 IF D=TRUE

TAB4:	MOVEI B,11		;TAB
	TRNE Q3,JS%TBP
	CAIG D,0
	TRNE Q3,JS%TBR
	TQON JS%T3		; Tab usage flag in Q1
	RET
	CALLRET BOUTA
;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,CPOPJ		;NULL INDICATES END OF STRING
	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
; 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
; 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
; 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
	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		;GET DEV INDEX FOR UNIT
	MOVE C,DEVCHR(A)	;GET DEVICE BITS
	TXNE C,DV%AS		;ASSIGNABLE DEVICE?
	JRST [	HLRZ B,DEVUNT(A) ;GET CURRENT ASSIGNMENT
		CAMN B,JOBNO	;ASSIGNED BY THIS JOB?
		JRST .+1	;YES. PROCEED
		HRRZM A,UNTIDX	;SAVE UNIT INDEX HERE
		HRR C,DEVUNT(A) ;GET UNIT
		TLZ C,777000 ;REMOVE JUNK BITS
		TLO C,.DVDES ;ADD BITS FOR DESIGNATOR
		GTOKM (.GOOAD,<C>,[ERUNLK ()],OPENB)
		MOVE B,UNTIDX	;RECOVER UNIT INDEX
		MOVE C,DEVCHR(B) ;RESTORE MODE BITS AS WELL
		UMOVE F1,2	;RECOVER ACCESS BITS AS WELL
		CALL DEVAV	;DEVICE AVAILABLE?
		ERUNLK(OPNX7)	;NO
		JRST .+1]	;YES
	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>
	IFNSK.
	  CAIE A,MTADTB		;NO, MAGTAPE?
	  CAIN A,DTADTB		;  AND DECTAPE
	ANSKP.
	  TQO <PASLSN>		;ALL OTHERS DON'T NEED EXAMINING
	ENDIF.
	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)
	CALL FNDUNT		;GET DEV INDEX
	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
;HERE IF GTOKM INDICATED BLOCK
;
OPENR:	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
;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
;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
; 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
; 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
; 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
; 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
; 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
; Rename file
; Call:	1	; Jfn 1
;	2	; Jfn 2
;	RNAMF
; Return
;	+1	; Error
;	+2	; Ok

.RNAMF::MCENT
	CAMN 1,2		;BE SURE NOT SAME JFN
	SMRETN
	MOVE JFN,1
	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,2
	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
	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
; 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
; 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

; 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
	SETZM FILCNT(JFN)	;FORCE NEW WINDOW NEXT OPERATION
	CALL UNLCKF		; Unlock file
	SMRETN
; 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
; 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
; 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
;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
; 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
;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
; 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
;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
; 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
; 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
;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
;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


	TNXEND
	END