mim/development/mim/20/io-utils.mud

   1 <DEFINE T$HANG ("OPTIONAL" (PRED <>))
   2   <REPEAT (VAL)
   3     <COND (<SET VAL <T$EVAL .PRED>>
   4            <RETURN .VAL>)>
   5     <ISYSOP WAIT>>>
   6
   7 <DEFINE T$JNAME ("OPT" NEW:STRING "AUX" WD:FIX (TS <STACK <ISTRING 6>>) CT)
   8   <COND (<NOT <ASSIGNED? NEW>>
   9          <SET WD <CALL SYSOP GETNM '(RETURN 1)>>
  10          <REPEAT (CHR)
  11            <COND (<0? .WD> <RETURN>)>
  12            <SET WD <ROT .WD 6>>
  13            <SET CHR <ASCII <+ <ANDB .WD 63> 32>>>
  14            <SET WD <ANDB .WD -64>>
  15            <1 .TS .CHR>
  16            <SET TS <REST .TS>>>
  17          <SUBSTRUC <TOP .TS> 0 <- 6 <LENGTH .TS>>>)
  18         (T
  19          <SET WD 0>
  20          <SET CT 0>
  21          <MAPF <>
  22            <FUNCTION (CHR)
  23              <SET WD <ORB <LSH .WD 6> <ANDB <- <ASCII .CHR> 32> 63>>>
  24              <COND (<G=? <SET CT <+ .CT 1>> 6>
  25                     <MAPLEAVE>)>>
  26            .NEW>
  27          <CALL SYSOP SETNM .WD>
  28          .NEW)>>
  29
  30 <DEFINE T$SLEEP (TM "OPTIONAL" (PRED <>) "AUX" RTM)
  31   #DECL ((TM) <OR FIX FLOAT> (RTM) FIX)
  32   <COND (<TYPE? .TM FLOAT>
  33          <SET RTM <FIX <* .TM 1000.0>>>)
  34         (<SET RTM <* .TM 1000>>)>
  35   <REPEAT (VAL STIME)
  36     #DECL ((STIME) FIX)
  37     <COND (<SET VAL <T$EVAL .PRED>>
  38            <RETURN .VAL>)>
  39     <SET STIME <CALL SYSOP TIME-JSYS '(RETURN 1)>>
  40     <ISYSOP DISMS .RTM>
  41     <COND (<L=? <SET RTM <- .RTM
  42                             <- <CHTYPE <CALL SYSOP TIME-JSYS '(RETURN 1)> FIX>
  43                                .STIME>>>
  44                 0>
  45            <RETURN T>)>>>
  46
  47 <DEFINE X$INIT-ENV ()
  48   ; "System initialization--none needed for 20x"
  49   <COND (<NOT <GASSIGNED? T$HOME-STRUC>><SETG T$HOME-STRUC "MIM">)>
  50   T>
  51
  52 <DEFINE T$SYS-ERR (NAME ERR "OPTIONAL" (NAME? T))
  53   #DECL ((NAME) STRING (ERR) <FALSE FIX> (NAME?) <OR ATOM FALSE>)
  54   <I$STD-ERROR .NAME .ERR .NAME?>>
  55
  56 <DEFINE T$TRANSLATE-ERROR (ERR:<FALSE FIX> "AUX" CT ES (NS:STRING ,I$NAMSTR))
  57   <SET CT <CALL SYSOP ERSTR
  58                 .NS
  59                 <PUTLHW <1 .ERR> ,/FHSLF>
  60                 <PUTLHW 0 <- <LENGTH .NS>>>>>
  61   <SET ES <ISTRING .CT>>
  62   <SUBSTRUC .NS 0 .CT .ES>>
  63
  64 <DEFINE I$STD-ERROR (NAME ERR "OPTIONAL" (NAME? T) "AUX"
  65                      (NS <STACK <ISTRING 500>>) CT ES)
  66   #DECL ((ES NS NAME) STRING (ERR) <FALSE FIX>)
  67   <SET ES <T$TRANSLATE-ERROR .ERR>>
  68   <COND (.NAME?
  69          <PROG (JFN (NM1 <X$VALUE? NM1>) (NM2 <X$VALUE? NM2>)
  70                 (DEV <X$VALUE? DEV>) (SNM <X$VALUE? SNM>) FNL)
  71            #DECL ((JFN) <OR FIX FALSE> (NM1 NM2 DEV SNM) <OR FIX STRING>)
  72            <COND (<SET JFN <CALL SYSOP GTJFN-L
  73                                  .NAME
  74                                  ,GJ-OFG
  75                                  %<CHTYPE <ORB ,/NULIO <LSH ,/NULIO 18>> FIX>
  76                                  .DEV
  77                                  .SNM
  78                                  .NM1
  79                                  .NM2
  80                                  0
  81                                  0
  82                                  0>>
  83                   <SET FNL <CALL SYSOP JFNS .NS .JFN 0 0>>
  84                   <CALL SYSOP RLJFN .JFN>
  85                   <SET NAME <SUBSTRUC .NS 0 .FNL>>)>>)>
  86   <CHTYPE (.ES .NAME !.ERR) FALSE>>
  87
  88 <DEFINE T$GET-JFN (NAME MODE BSZ NEW? "AUX" JFN ERR)
  89   #DECL ((NAME) STRING (MODE BSZ) FIX (NEW?) <OR ATOM FALSE>
  90          (JFN ERR) <OR FIX FALSE>)
  91   <COND (.NEW?
  92          <SET JFN <CALL SYSOP GTJFN-S-S
  93                         %<CHTYPE <ORB ,GJ-FOU ,GJ-SHT> FIX>
  94                         .NAME>>)
  95         (T
  96          <SET JFN <CALL SYSOP GTJFN-S-S
  97                         %<CHTYPE <ORB ,GJ-OLD ,GJ-SHT> FIX>
  98                         .NAME>>)>
  99   <COND (.JFN
 100          <COND (<SET ERR <CALL SYSOP OPENF
 101                                .JFN
 102                                <ORB <LSH .BSZ 30>
 103                                     .MODE>>>
 104                 .JFN)
 105                (T
 106                 <CALL SYSOP RLJFN .JFN>
 107                 .ERR)>)>>
 108
 109 <DEFINE T$GET-BYTE-COUNT (JFN BSZ "AUX" OBC OBS FC)
 110   #DECL ((FC JFN BSZ OBC OBS) FIX)
 111   <SET OBC <CALL SYSOP SIZEF .JFN '(RETURN 2)>>
 112   <SET OBS <LSH <ANDB <CALL SYSOP GTFDB
 113                             .JFN
 114                             %<CHTYPE <ORB ,/FBBYV <LSH 1 18>>
 115                                      FIX> 5 '(RETURN 5)>
 116                       ,FB-BSZ>
 117                 -24>>
 118   <COND (<0? .OBS> <SET OBS 36>)>
 119   <COND (<==? .OBS .BSZ> .OBC)
 120         (T
 121          <* </ <+ .OBC <- <SET FC </ 36 .OBS>> 1>> .FC>
 122             </ 36 .BSZ>>)>>
 123
 124 <DEFINE T$CLOSE-OPEN (JFN MODE BSZ)
 125   #DECL ((JFN MODE BSZ) FIX)
 126   <AND <CALL SYSOP CLOSF <ORB ,CO-NRJ .JFN>>
 127        <CALL SYSOP OPENF .JFN
 128              <ORB <LSH .BSZ 30>
 129                   .MODE>>>>
 130
 131 <DEFINE T$GET-DEVICE-TYPE (JFN "AUX" VAL)
 132   #DECL ((JFN) FIX)
 133   <COND (<SET VAL <CALL SYSOP DVCHR .JFN '(RETURN 2)>>
 134          <ANDB <LSH .VAL -18> *777*>)>>
 135
 136 \f
 137 <DEFINE X$IO-INIT ()
 138   <SETG T$MUDDLE-SYSTEM "T">
 139   <SETG CRLF-STRING <STRING <ASCII 13> <ASCII 10>>>
 140   <SETG CRLF-LENGTH 2>
 141   <SETG TABSTR <ISTRING 10 <ASCII 9>>>
 142   <SETG SPACESTR <ISTRING 7 <ASCII 32>>>
 143   <SETG I$RDBLEN <* 5 256>>
 144   <SETG %<P-R "NM2"> "MUD">
 145   <SETG %<P-R "DEVVEC"> [,/DVDSK %<P-R "DISK">
 146                     ,/DVMTA %<P-R "TWAY">
 147                     ,/DVLPT %<P-R "TWAY">
 148                     ,/DVCDR %<P-R "TWAY">
 149                     ,/DVFE %<P-R "TWAY">
 150                     ,/DVTTY [%<P-R "TTY"> T T]
 151                     ,/DVPTY [%<P-R "TTY"> T T]
 152                     ,/DVNUL [%<P-R "TWAY"> <> <>]
 153                     ,/DVNET [%<P-R "TWAY"> T T]]>
 154   <SETG I$NAMSTR <T$ISTRING 100>>
 155   <SETG I$CHANNEL-TYPES ()>
 156   <T$NEW-CHANNEL-TYPE %<P-R "DEFAULT"> <>
 157                  %<P-R "NAME"> X$DEF-NAME
 158                  %<P-R "NM1"> X$DEF-NM1
 159                  %<P-R "NM2"> X$DEF-NM2
 160                  %<P-R "DEV"> X$DEF-DEV
 161                  %<P-R "SNM"> X$DEF-SNM
 162                  %<P-R "SHORT-NAME"> X$DEF-SHORT-NAME
 163                  %<P-R "FLUSH"> X$DEF-FLUSH
 164                  %<P-R "READ-DATE"> X$DEF-HACK-DATE
 165                  %<P-R "WRITE-DATE"> X$DEF-HACK-DATE
 166                  %<P-R "GET-MODE"> X$DEF-GET-MODE
 167                  %<P-R "GET-BYTE-SIZE"> X$DEF-GET-BYTE-SIZE>
 168   <T$NEW-CHANNEL-TYPE %<P-R "DISK"> %<P-R "DEFAULT">
 169                  %<P-R "FILE-HANDLE"> X$DISK-FILE-HANDLE
 170                  %<P-R "QUERY"> X$DISK-QUERY
 171                  %<P-R "OPEN"> X$DISK-OPEN
 172                  %<P-R "CLOSE"> X$DISK-CLOSE
 173                  %<P-R "FLUSH"> X$DISK-FLUSH
 174                  %<P-R "READ-BYTE"> X$DISK-READ-BYTE
 175                  %<P-R "WRITE-BYTE"> X$DISK-WRITE-BYTE
 176                  %<P-R "READ-BUFFER"> X$DISK-READ-BUFFER
 177                  %<P-R "WRITE-BUFFER"> X$DISK-WRITE-BUFFER
 178                  %<P-R "ACCESS"> X$DISK-ACCESS
 179                  %<P-R "BUFOUT"> X$DISK-BUFOUT
 180                  %<P-R "FILE-LENGTH"> X$DISK-FILE-LENGTH
 181                  %<P-R "PRINT-DATA"> X$DISK-PRINT-DATA>
 182   <T$NEW-CHANNEL-TYPE I$UNPARSE <>
 183                  %<P-R "WRITE-BUFFER"> X$UP-WRITE-BUF
 184                  %<P-R "WRITE-BYTE"> X$UP-WRITE-BYTE
 185                  %<P-R "READ-BYTE"> X$UP-READ-BYTE>>
 186
 187 <DEFINE X$IO-LOAD (BOOTYP)
 188   #DECL ((BOOTYP) FIX)
 189   <SETG M$$FLATCHAN
 190                 <X$RESET <CHTYPE [I$FLATSIZE <> <> T 0 <>] T$CHANNEL>>>
 191   <SETG M$$INTCHAN <X$RESET <CHTYPE [I$UNPARSE <> <> T "" <>] T$CHANNEL>>>
 192   <COND (<AND <G=? .BOOTYP 0>
 193               <T$FILE-EXISTS? "<MIM.20>CHANNEL-OPERATION.MBIN">>
 194          <T$FLOAD "<MIM.20>CHANNEL-OPERATION.MBIN">)
 195         (<T$FLOAD "<MIM.20>CHANNEL-OPERATION.MSUBR">)>
 196   <COND (<AND <G=? .BOOTYP 0>
 197               <T$FILE-EXISTS? "<MIM.20>TWAY.MBIN">>
 198          <T$FLOAD "<MIM.20>TWAY.MBIN">)
 199         (<T$FLOAD "<MIM.20>TWAY.MSUBR">)>
 200   <COND (<AND <G=? .BOOTYP 0>
 201               <T$FILE-EXISTS? "<MIM.20>TTY.MBIN">>
 202          <T$FLOAD "<MIM.20>TTY.MBIN">)
 203         (<T$FLOAD "<MIM.20>TTY.MSUBR">)>>
 204
 205 <DEFINE T$RENAME (OLD NEW "AUX" (NM1 <X$VALUE? T$NM1>) (NM2 <X$VALUE? T$NM2>)
 206                   (DEV <X$VALUE? T$DEV>) (SNM <X$VALUE? T$SNM>) (FOLD <>)
 207                   (FNEW <>) VAL FNL (NS <STACK <ISTRING 500>>))
 208   #DECL ((OLD NEW) STRING (NM1 NM2 DEV SNM) <OR STRING FIX>
 209          (FOLD FNEW) <OR FIX FALSE> (FNL) FIX (NS) STRING)
 210   <COND (<SET VAL
 211               <AND <SET FOLD <I$DO-OPEN ,GJ-OLD .OLD .DEV .SNM .NM1 .NM2>>
 212                    <SET FNEW <I$DO-OPEN ,GJ-FOU .NEW .DEV .SNM .NM1 .NM2>>>>
 213          <COND (<SET VAL <CALL SYSOP RNAMF .FOLD .FNEW>>
 214                 <SET FNL <CALL SYSOP JFNS .NS .FNEW 0 0>>
 215                 <CALL SYSOP RLJFN .FNEW>
 216                 <SET NEW <SUBSTRUC .NS 0 .FNL>>
 217                 <SET VAL .NEW>)>)>
 218   <COND (<NOT .VAL>
 219          <COND (.FOLD
 220                 <CALL SYSOP RLJFN .FOLD>)>
 221          <COND (.FNEW
 222                 <CALL SYSOP RLJFN .FNEW>)>
 223          <I$STD-ERROR .OLD .VAL>)
 224         (.VAL)>>
 225
 226 <DEFINE T$DELFILE (NM "OPTIONAL" (NM1 <X$VALUE? T$NM1>) (NM2 <X$VALUE? T$NM2>)
 227                    (DEV <X$VALUE? T$DEV>) (SNM <X$VALUE? T$SNM>) "AUX" FID VAL)
 228   #DECL ((NM) STRING (NM1 NM2 DEV SNM) <OR STRING FIX> (FID) <OR FIX FALSE>)
 229   <SET VAL
 230        <COND (<SET FID <I$DO-OPEN ,GJ-OLD .NM .DEV .SNM .NM1 .NM2>>
 231               <CALL SYSOP DELF .FID>)>>
 232   <COND (<NOT .VAL>
 233          <COND (.FID <CALL SYSOP RLJFN .FID>)>
 234          <I$STD-ERROR .NM .VAL>)
 235         (.NM)>>
 236
 237 <DEFINE T$FILE-EXISTS? (NAME "OPTIONAL" (NM1 <X$VALUE? T$NM1>)
 238                         (NM2 <X$VALUE? T$NM2>)(DEV <X$VALUE? T$DEV>)
 239                         (SNM <X$VALUE? T$SNM>) "AUX" FID)
 240   #DECL ((NAME) STRING (NM1 NM2 DEV SNM) <OR STRING FIX>
 241          (FID) <OR FIX FALSE>)
 242   <COND (<SET FID <I$DO-OPEN ,GJ-OLD .NAME .DEV .SNM .NM1 .NM2>>
 243          <CALL SYSOP RLJFN .FID>
 244          T)
 245         (<I$STD-ERROR .NAME .FID>)>>
 246
 247 <DEFINE I$DO-OPEN (MODE NAME DEV SNM NM1 NM2)
 248   #DECL ((MODE) FIX (NAME) STRING (DEV SNM NM1 NM2) <OR STRING FIX>)
 249   <CALL SYSOP GTJFN-L
 250         .NAME
 251         .MODE
 252         %<CHTYPE <ORB ,/NULIO <LSH ,/NULIO 18>> FIX>
 253         .DEV    ; "Default device"
 254         .SNM    ; "Default directory"
 255         .NM1    ; "Default first name"
 256         .NM2    ; "Default second name"
 257         0       ; "Protection"
 258         0       ; "Account"
 259         0       ; "JFN to use">>
 260
 261 <DEFINE T$GEN-OPEN GO (NAME "OPTIONAL" (MODE "READ")
 262                (BSZ "ASCII") (DEVNAM <>) "AUX" (NEW? <>) JFN DEVTYP VEC
 263                (DEV <X$VALUE? DEV>) (SNM <X$VALUE? SNM>)
 264                (NM1 <X$VALUE? NM1>) (NM2 <X$VALUE? NM2>)
 265                (NS <STACK <ISTRING 500>>) NNS FNL VAL)
 266   #DECL ((NNS NS NAME MODE BSZ) STRING (JFN) <OR FALSE FIX> (FNL DEVTYP) FIX
 267          (DEV SNM NM1 NM2) <OR STRING FIX> (DEVNAM) <OR ATOM FALSE VECTOR>)
 268   <COND (<=? .MODE "CREATE"> <SET NEW? T>)>
 269   <COND (<SET JFN <I$DO-OPEN <COND (.NEW? ,GJ-FOU)
 270                                    (T ,GJ-OLD)>
 271                              .NAME .DEV .SNM .NM1 .NM2>>
 272          <SET FNL <CALL SYSOP JFNS .NS .JFN 0 0>>
 273          <SET NNS <SUBSTRUC .NS 0 .FNL>>
 274          <COND (<NOT .DEVNAM>
 275                 <SET DEVTYP <T$GET-DEVICE-TYPE .JFN>>
 276                 <COND (<SET VEC <MEMQ .DEVTYP ,T$DEVVEC>>
 277                        <SET DEVNAM <2 .VEC>>)
 278                       (<SET DEVNAM %<P-R "TWAY">>)>)>
 279          <CALL SYSOP RLJFN .JFN>
 280          <COND (<NOT
 281                  <SET VAL
 282                   <COND (<TYPE? .DEVNAM ATOM>
 283                          <T$CHANNEL-OPEN .DEVNAM .NNS .MODE .BSZ>)
 284                         (<TYPE? .DEVNAM VECTOR>
 285                          <T$CHANNEL-OPEN <1 .DEVNAM>
 286                                          .NNS .MODE .BSZ !<REST .DEVNAM>>)>>>
 287                 <I$STD-ERROR .NAME .VAL>)
 288                (.VAL)>)
 289         (<I$STD-ERROR .NAME .JFN>)>>
 290
 291 <DEFINE X$VALUE? (ATM "AUX" TS)
 292   #DECL ((ATM) ATOM (TS) <OR FALSE FIX STRING>)
 293   <SET TS <COND (<ASSIGNED? .ATM>
 294                  ..ATM)
 295                 (<GASSIGNED? .ATM>
 296                  ,.ATM)>>
 297   <COND (<OR <NOT .TS> <TYPE? .TS FIX> <EMPTY? .TS>> 0)
 298         (.TS)>>
 299
 300 <DEFINE T$UNAME ("AUX" UNUM (ST ,I$NAMSTR))
 301   #DECL ((UNUM) FIX (ST) STRING)
 302   <SET UNUM <CALL SYSOP GJINF '(RETURN 1)>>
 303   <CALL SYSOP DIRST .ST .UNUM>
 304   <I$GET-STRING ,I$NAMSTR>>
 305
 306 <DEFINE T$GET-CONNECTED-DIR GCD ("AUX" DIRNUM (ST ,I$NAMSTR) NST DIRST DEVST)
 307   #DECL ((DIRNUM) FIX (DIRST DEVST ST NST) STRING)
 308   <SET DIRNUM <CALL SYSOP GJINF '(RETURN 2)>>
 309   <CALL SYSOP DIRST .ST .DIRNUM>
 310   <SET ST <I$GET-STRING ,I$NAMSTR>>
 311   <SET NST <MEMQ !\: .ST>>
 312   <PUT .ST <LENGTH .ST> <ASCII 0>>
 313   <SET DIRST <I$GET-STRING <REST .NST 2>>>
 314   <PUT .NST 1 <ASCII 0>>
 315   <SET DEVST <I$GET-STRING .ST>>
 316   <MULTI-RETURN .GCD .DIRST .DEVST>>
 317
 318 <DEFINE I$GET-STRING (ST "AUX" NST RST)
 319   #DECL ((ST RST) STRING (NST) <OR STRING FALSE>)
 320   <COND (<SET NST <MEMQ <ASCII 0> .ST>>
 321          <SUBSTRUC .ST 0 <- <LENGTH .ST> <LENGTH .NST>>>)
 322         (<STRING .ST>)>>