--- /dev/null
+<DEFINE T$HANG ("OPTIONAL" (PRED <>))
+ <REPEAT (VAL)
+ <COND (<SET VAL <T$EVAL .PRED>>
+ <RETURN .VAL>)>
+ <ISYSOP WAIT>>>
+
+<DEFINE T$JNAME ("OPT" NEW:STRING "AUX" WD:FIX (TS <STACK <ISTRING 6>>) CT)
+ <COND (<NOT <ASSIGNED? NEW>>
+ <SET WD <CALL SYSOP GETNM '(RETURN 1)>>
+ <REPEAT (CHR)
+ <COND (<0? .WD> <RETURN>)>
+ <SET WD <ROT .WD 6>>
+ <SET CHR <ASCII <+ <ANDB .WD 63> 32>>>
+ <SET WD <ANDB .WD -64>>
+ <1 .TS .CHR>
+ <SET TS <REST .TS>>>
+ <SUBSTRUC <TOP .TS> 0 <- 6 <LENGTH .TS>>>)
+ (T
+ <SET WD 0>
+ <SET CT 0>
+ <MAPF <>
+ <FUNCTION (CHR)
+ <SET WD <ORB <LSH .WD 6> <ANDB <- <ASCII .CHR> 32> 63>>>
+ <COND (<G=? <SET CT <+ .CT 1>> 6>
+ <MAPLEAVE>)>>
+ .NEW>
+ <CALL SYSOP SETNM .WD>
+ .NEW)>>
+
+<DEFINE T$SLEEP (TM "OPTIONAL" (PRED <>) "AUX" RTM)
+ #DECL ((TM) <OR FIX FLOAT> (RTM) FIX)
+ <COND (<TYPE? .TM FLOAT>
+ <SET RTM <FIX <* .TM 1000.0>>>)
+ (<SET RTM <* .TM 1000>>)>
+ <REPEAT (VAL STIME)
+ #DECL ((STIME) FIX)
+ <COND (<SET VAL <T$EVAL .PRED>>
+ <RETURN .VAL>)>
+ <SET STIME <CALL SYSOP TIME-JSYS '(RETURN 1)>>
+ <ISYSOP DISMS .RTM>
+ <COND (<L=? <SET RTM <- .RTM
+ <- <CHTYPE <CALL SYSOP TIME-JSYS '(RETURN 1)> FIX>
+ .STIME>>>
+ 0>
+ <RETURN T>)>>>
+
+<DEFINE X$INIT-ENV ()
+ ; "System initialization--none needed for 20x"
+ <COND (<NOT <GASSIGNED? T$HOME-STRUC>><SETG T$HOME-STRUC "MIM">)>
+ T>
+
+<DEFINE T$SYS-ERR (NAME ERR "OPTIONAL" (NAME? T))
+ #DECL ((NAME) STRING (ERR) <FALSE FIX> (NAME?) <OR ATOM FALSE>)
+ <I$STD-ERROR .NAME .ERR .NAME?>>
+
+<DEFINE T$TRANSLATE-ERROR (ERR:<FALSE FIX> "AUX" CT ES (NS:STRING ,I$NAMSTR))
+ <SET CT <CALL SYSOP ERSTR
+ .NS
+ <PUTLHW <1 .ERR> ,/FHSLF>
+ <PUTLHW 0 <- <LENGTH .NS>>>>>
+ <SET ES <ISTRING .CT>>
+ <SUBSTRUC .NS 0 .CT .ES>>
+
+<DEFINE I$STD-ERROR (NAME ERR "OPTIONAL" (NAME? T) "AUX"
+ (NS <STACK <ISTRING 500>>) CT ES)
+ #DECL ((ES NS NAME) STRING (ERR) <FALSE FIX>)
+ <SET ES <T$TRANSLATE-ERROR .ERR>>
+ <COND (.NAME?
+ <PROG (JFN (NM1 <X$VALUE? NM1>) (NM2 <X$VALUE? NM2>)
+ (DEV <X$VALUE? DEV>) (SNM <X$VALUE? SNM>) FNL)
+ #DECL ((JFN) <OR FIX FALSE> (NM1 NM2 DEV SNM) <OR FIX STRING>)
+ <COND (<SET JFN <CALL SYSOP GTJFN-L
+ .NAME
+ ,GJ-OFG
+ %<CHTYPE <ORB ,/NULIO <LSH ,/NULIO 18>> FIX>
+ .DEV
+ .SNM
+ .NM1
+ .NM2
+ 0
+ 0
+ 0>>
+ <SET FNL <CALL SYSOP JFNS .NS .JFN 0 0>>
+ <CALL SYSOP RLJFN .JFN>
+ <SET NAME <SUBSTRUC .NS 0 .FNL>>)>>)>
+ <CHTYPE (.ES .NAME !.ERR) FALSE>>
+
+<DEFINE T$GET-JFN (NAME MODE BSZ NEW? "AUX" JFN ERR)
+ #DECL ((NAME) STRING (MODE BSZ) FIX (NEW?) <OR ATOM FALSE>
+ (JFN ERR) <OR FIX FALSE>)
+ <COND (.NEW?
+ <SET JFN <CALL SYSOP GTJFN-S-S
+ %<CHTYPE <ORB ,GJ-FOU ,GJ-SHT> FIX>
+ .NAME>>)
+ (T
+ <SET JFN <CALL SYSOP GTJFN-S-S
+ %<CHTYPE <ORB ,GJ-OLD ,GJ-SHT> FIX>
+ .NAME>>)>
+ <COND (.JFN
+ <COND (<SET ERR <CALL SYSOP OPENF
+ .JFN
+ <ORB <LSH .BSZ 30>
+ .MODE>>>
+ .JFN)
+ (T
+ <CALL SYSOP RLJFN .JFN>
+ .ERR)>)>>
+
+<DEFINE T$GET-BYTE-COUNT (JFN BSZ "AUX" OBC OBS FC)
+ #DECL ((FC JFN BSZ OBC OBS) FIX)
+ <SET OBC <CALL SYSOP SIZEF .JFN '(RETURN 2)>>
+ <SET OBS <LSH <ANDB <CALL SYSOP GTFDB
+ .JFN
+ %<CHTYPE <ORB ,/FBBYV <LSH 1 18>>
+ FIX> 5 '(RETURN 5)>
+ ,FB-BSZ>
+ -24>>
+ <COND (<0? .OBS> <SET OBS 36>)>
+ <COND (<==? .OBS .BSZ> .OBC)
+ (T
+ <* </ <+ .OBC <- <SET FC </ 36 .OBS>> 1>> .FC>
+ </ 36 .BSZ>>)>>
+
+<DEFINE T$CLOSE-OPEN (JFN MODE BSZ)
+ #DECL ((JFN MODE BSZ) FIX)
+ <AND <CALL SYSOP CLOSF <ORB ,CO-NRJ .JFN>>
+ <CALL SYSOP OPENF .JFN
+ <ORB <LSH .BSZ 30>
+ .MODE>>>>
+
+<DEFINE T$GET-DEVICE-TYPE (JFN "AUX" VAL)
+ #DECL ((JFN) FIX)
+ <COND (<SET VAL <CALL SYSOP DVCHR .JFN '(RETURN 2)>>
+ <ANDB <LSH .VAL -18> *777*>)>>
+
+\f
+<DEFINE X$IO-INIT ()
+ <SETG T$MUDDLE-SYSTEM "T">
+ <SETG CRLF-STRING <STRING <ASCII 13> <ASCII 10>>>
+ <SETG CRLF-LENGTH 2>
+ <SETG TABSTR <ISTRING 10 <ASCII 9>>>
+ <SETG SPACESTR <ISTRING 7 <ASCII 32>>>
+ <SETG I$RDBLEN <* 5 256>>
+ <SETG %<P-R "NM2"> "MUD">
+ <SETG %<P-R "DEVVEC"> [,/DVDSK %<P-R "DISK">
+ ,/DVMTA %<P-R "TWAY">
+ ,/DVLPT %<P-R "TWAY">
+ ,/DVCDR %<P-R "TWAY">
+ ,/DVFE %<P-R "TWAY">
+ ,/DVTTY [%<P-R "TTY"> T T]
+ ,/DVPTY [%<P-R "TTY"> T T]
+ ,/DVNUL [%<P-R "TWAY"> <> <>]
+ ,/DVNET [%<P-R "TWAY"> T T]]>
+ <SETG I$NAMSTR <T$ISTRING 100>>
+ <SETG I$CHANNEL-TYPES ()>
+ <T$NEW-CHANNEL-TYPE %<P-R "DEFAULT"> <>
+ %<P-R "NAME"> X$DEF-NAME
+ %<P-R "NM1"> X$DEF-NM1
+ %<P-R "NM2"> X$DEF-NM2
+ %<P-R "DEV"> X$DEF-DEV
+ %<P-R "SNM"> X$DEF-SNM
+ %<P-R "SHORT-NAME"> X$DEF-SHORT-NAME
+ %<P-R "FLUSH"> X$DEF-FLUSH
+ %<P-R "READ-DATE"> X$DEF-HACK-DATE
+ %<P-R "WRITE-DATE"> X$DEF-HACK-DATE
+ %<P-R "GET-MODE"> X$DEF-GET-MODE
+ %<P-R "GET-BYTE-SIZE"> X$DEF-GET-BYTE-SIZE>
+ <T$NEW-CHANNEL-TYPE %<P-R "DISK"> %<P-R "DEFAULT">
+ %<P-R "FILE-HANDLE"> X$DISK-FILE-HANDLE
+ %<P-R "QUERY"> X$DISK-QUERY
+ %<P-R "OPEN"> X$DISK-OPEN
+ %<P-R "CLOSE"> X$DISK-CLOSE
+ %<P-R "FLUSH"> X$DISK-FLUSH
+ %<P-R "READ-BYTE"> X$DISK-READ-BYTE
+ %<P-R "WRITE-BYTE"> X$DISK-WRITE-BYTE
+ %<P-R "READ-BUFFER"> X$DISK-READ-BUFFER
+ %<P-R "WRITE-BUFFER"> X$DISK-WRITE-BUFFER
+ %<P-R "ACCESS"> X$DISK-ACCESS
+ %<P-R "BUFOUT"> X$DISK-BUFOUT
+ %<P-R "FILE-LENGTH"> X$DISK-FILE-LENGTH
+ %<P-R "PRINT-DATA"> X$DISK-PRINT-DATA>
+ <T$NEW-CHANNEL-TYPE I$UNPARSE <>
+ %<P-R "WRITE-BUFFER"> X$UP-WRITE-BUF
+ %<P-R "WRITE-BYTE"> X$UP-WRITE-BYTE
+ %<P-R "READ-BYTE"> X$UP-READ-BYTE>>
+
+<DEFINE X$IO-LOAD (BOOTYP)
+ #DECL ((BOOTYP) FIX)
+ <SETG M$$FLATCHAN
+ <X$RESET <CHTYPE [I$FLATSIZE <> <> T 0 <>] T$CHANNEL>>>
+ <SETG M$$INTCHAN <X$RESET <CHTYPE [I$UNPARSE <> <> T "" <>] T$CHANNEL>>>
+ <COND (<AND <G=? .BOOTYP 0>
+ <T$FILE-EXISTS? "<MIM.20>CHANNEL-OPERATION.MBIN">>
+ <T$FLOAD "<MIM.20>CHANNEL-OPERATION.MBIN">)
+ (<T$FLOAD "<MIM.20>CHANNEL-OPERATION.MSUBR">)>
+ <COND (<AND <G=? .BOOTYP 0>
+ <T$FILE-EXISTS? "<MIM.20>TWAY.MBIN">>
+ <T$FLOAD "<MIM.20>TWAY.MBIN">)
+ (<T$FLOAD "<MIM.20>TWAY.MSUBR">)>
+ <COND (<AND <G=? .BOOTYP 0>
+ <T$FILE-EXISTS? "<MIM.20>TTY.MBIN">>
+ <T$FLOAD "<MIM.20>TTY.MBIN">)
+ (<T$FLOAD "<MIM.20>TTY.MSUBR">)>>
+
+<DEFINE T$RENAME (OLD NEW "AUX" (NM1 <X$VALUE? T$NM1>) (NM2 <X$VALUE? T$NM2>)
+ (DEV <X$VALUE? T$DEV>) (SNM <X$VALUE? T$SNM>) (FOLD <>)
+ (FNEW <>) VAL FNL (NS <STACK <ISTRING 500>>))
+ #DECL ((OLD NEW) STRING (NM1 NM2 DEV SNM) <OR STRING FIX>
+ (FOLD FNEW) <OR FIX FALSE> (FNL) FIX (NS) STRING)
+ <COND (<SET VAL
+ <AND <SET FOLD <I$DO-OPEN ,GJ-OLD .OLD .DEV .SNM .NM1 .NM2>>
+ <SET FNEW <I$DO-OPEN ,GJ-FOU .NEW .DEV .SNM .NM1 .NM2>>>>
+ <COND (<SET VAL <CALL SYSOP RNAMF .FOLD .FNEW>>
+ <SET FNL <CALL SYSOP JFNS .NS .FNEW 0 0>>
+ <CALL SYSOP RLJFN .FNEW>
+ <SET NEW <SUBSTRUC .NS 0 .FNL>>
+ <SET VAL .NEW>)>)>
+ <COND (<NOT .VAL>
+ <COND (.FOLD
+ <CALL SYSOP RLJFN .FOLD>)>
+ <COND (.FNEW
+ <CALL SYSOP RLJFN .FNEW>)>
+ <I$STD-ERROR .OLD .VAL>)
+ (.VAL)>>
+
+<DEFINE T$DELFILE (NM "OPTIONAL" (NM1 <X$VALUE? T$NM1>) (NM2 <X$VALUE? T$NM2>)
+ (DEV <X$VALUE? T$DEV>) (SNM <X$VALUE? T$SNM>) "AUX" FID VAL)
+ #DECL ((NM) STRING (NM1 NM2 DEV SNM) <OR STRING FIX> (FID) <OR FIX FALSE>)
+ <SET VAL
+ <COND (<SET FID <I$DO-OPEN ,GJ-OLD .NM .DEV .SNM .NM1 .NM2>>
+ <CALL SYSOP DELF .FID>)>>
+ <COND (<NOT .VAL>
+ <COND (.FID <CALL SYSOP RLJFN .FID>)>
+ <I$STD-ERROR .NM .VAL>)
+ (.NM)>>
+
+<DEFINE T$FILE-EXISTS? (NAME "OPTIONAL" (NM1 <X$VALUE? T$NM1>)
+ (NM2 <X$VALUE? T$NM2>)(DEV <X$VALUE? T$DEV>)
+ (SNM <X$VALUE? T$SNM>) "AUX" FID)
+ #DECL ((NAME) STRING (NM1 NM2 DEV SNM) <OR STRING FIX>
+ (FID) <OR FIX FALSE>)
+ <COND (<SET FID <I$DO-OPEN ,GJ-OLD .NAME .DEV .SNM .NM1 .NM2>>
+ <CALL SYSOP RLJFN .FID>
+ T)
+ (<I$STD-ERROR .NAME .FID>)>>
+
+<DEFINE I$DO-OPEN (MODE NAME DEV SNM NM1 NM2)
+ #DECL ((MODE) FIX (NAME) STRING (DEV SNM NM1 NM2) <OR STRING FIX>)
+ <CALL SYSOP GTJFN-L
+ .NAME
+ .MODE
+ %<CHTYPE <ORB ,/NULIO <LSH ,/NULIO 18>> FIX>
+ .DEV ; "Default device"
+ .SNM ; "Default directory"
+ .NM1 ; "Default first name"
+ .NM2 ; "Default second name"
+ 0 ; "Protection"
+ 0 ; "Account"
+ 0 ; "JFN to use">>
+
+<DEFINE T$GEN-OPEN GO (NAME "OPTIONAL" (MODE "READ")
+ (BSZ "ASCII") (DEVNAM <>) "AUX" (NEW? <>) JFN DEVTYP VEC
+ (DEV <X$VALUE? DEV>) (SNM <X$VALUE? SNM>)
+ (NM1 <X$VALUE? NM1>) (NM2 <X$VALUE? NM2>)
+ (NS <STACK <ISTRING 500>>) NNS FNL VAL)
+ #DECL ((NNS NS NAME MODE BSZ) STRING (JFN) <OR FALSE FIX> (FNL DEVTYP) FIX
+ (DEV SNM NM1 NM2) <OR STRING FIX> (DEVNAM) <OR ATOM FALSE VECTOR>)
+ <COND (<=? .MODE "CREATE"> <SET NEW? T>)>
+ <COND (<SET JFN <I$DO-OPEN <COND (.NEW? ,GJ-FOU)
+ (T ,GJ-OLD)>
+ .NAME .DEV .SNM .NM1 .NM2>>
+ <SET FNL <CALL SYSOP JFNS .NS .JFN 0 0>>
+ <SET NNS <SUBSTRUC .NS 0 .FNL>>
+ <COND (<NOT .DEVNAM>
+ <SET DEVTYP <T$GET-DEVICE-TYPE .JFN>>
+ <COND (<SET VEC <MEMQ .DEVTYP ,T$DEVVEC>>
+ <SET DEVNAM <2 .VEC>>)
+ (<SET DEVNAM %<P-R "TWAY">>)>)>
+ <CALL SYSOP RLJFN .JFN>
+ <COND (<NOT
+ <SET VAL
+ <COND (<TYPE? .DEVNAM ATOM>
+ <T$CHANNEL-OPEN .DEVNAM .NNS .MODE .BSZ>)
+ (<TYPE? .DEVNAM VECTOR>
+ <T$CHANNEL-OPEN <1 .DEVNAM>
+ .NNS .MODE .BSZ !<REST .DEVNAM>>)>>>
+ <I$STD-ERROR .NAME .VAL>)
+ (.VAL)>)
+ (<I$STD-ERROR .NAME .JFN>)>>
+
+<DEFINE X$VALUE? (ATM "AUX" TS)
+ #DECL ((ATM) ATOM (TS) <OR FALSE FIX STRING>)
+ <SET TS <COND (<ASSIGNED? .ATM>
+ ..ATM)
+ (<GASSIGNED? .ATM>
+ ,.ATM)>>
+ <COND (<OR <NOT .TS> <TYPE? .TS FIX> <EMPTY? .TS>> 0)
+ (.TS)>>
+
+<DEFINE T$UNAME ("AUX" UNUM (ST ,I$NAMSTR))
+ #DECL ((UNUM) FIX (ST) STRING)
+ <SET UNUM <CALL SYSOP GJINF '(RETURN 1)>>
+ <CALL SYSOP DIRST .ST .UNUM>
+ <I$GET-STRING ,I$NAMSTR>>
+
+<DEFINE T$GET-CONNECTED-DIR GCD ("AUX" DIRNUM (ST ,I$NAMSTR) NST DIRST DEVST)
+ #DECL ((DIRNUM) FIX (DIRST DEVST ST NST) STRING)
+ <SET DIRNUM <CALL SYSOP GJINF '(RETURN 2)>>
+ <CALL SYSOP DIRST .ST .DIRNUM>
+ <SET ST <I$GET-STRING ,I$NAMSTR>>
+ <SET NST <MEMQ !\: .ST>>
+ <PUT .ST <LENGTH .ST> <ASCII 0>>
+ <SET DIRST <I$GET-STRING <REST .NST 2>>>
+ <PUT .NST 1 <ASCII 0>>
+ <SET DEVST <I$GET-STRING .ST>>
+ <MULTI-RETURN .GCD .DIRST .DEVST>>
+
+<DEFINE I$GET-STRING (ST "AUX" NST RST)
+ #DECL ((ST RST) STRING (NST) <OR STRING FALSE>)
+ <COND (<SET NST <MEMQ <ASCII 0> .ST>>
+ <SUBSTRUC .ST 0 <- <LENGTH .ST> <LENGTH .NST>>>)
+ (<STRING .ST>)>>
projects / pdp10-muddle.git / blobdiff