mim/development/mim/vax/disk.mud

   1 <DEFINE X$DISK-OPEN DO (STYPE:ATOM OPR NAME:STRING MODS:STRING
   2                         "OPTIONAL" (BYTES:STRING "ASCII")
   3                      (BUF?:<OR ATOM FALSE> T) (THAWED? <>) (NO-REF? <>)
   4                      "AUX" (NEW?:<OR ATOM FALSE> <>) (APP?:<OR ATOM FALSE> <>)
   5                            MODE:FIX JFN:<OR FIX FALSE> BINARY?:<OR ATOM FALSE>
   6                            (BYTE?:<OR ATOM FALSE> <>) NNAME:STRING PTR:FIX
   7                            (STOR:<PRIMTYPE VECTOR> <ITUPLE 5 <>>)
   8                            (STATUS 0) BUF)
   9   ; "THAWED? and NO-REF? are no-ops, due to the lossages of unix"
  10   <COND (<=? .MODS "READ">
  11          <SET MODE ,O-RDONLY>
  12          <SET STATUS <ORB .STATUS ,STATUS-READ>>)
  13         (<=? .MODS "CREATE">
  14          <SET NEW? T>
  15          <SET STATUS <ORB ,STATUS-NEW ,STATUS-WRITE ,STATUS-RACC>>
  16          <SET MODE <+ ,O-RDWR ,O-CREAT ,O-EXCL>>)
  17         (<=? .MODS "MODIFY">
  18          <SET STATUS <ORB ,STATUS-WRITE ,STATUS-RACC>>
  19          <SET MODE ,O-RDWR>)
  20         (<=? .MODS "APPEND">
  21          <SET APP? T>
  22          <SET STATUS ,STATUS-WRITE>
  23          <SET MODE <+ ,O-RDWR ,O-APPEND>>)
  24         (T
  25          <ERROR %<P-E "ILLEGAL-MODE"> .MODS X$DISK-OPEN>)>
  26   <COND (<=? .BYTES "ASCII">
  27          <SET BINARY? <>>
  28          <SET STATUS <PUTLHW .STATUS ,BS-ASCII>>)
  29         (<=? .BYTES "8BIT">
  30          <SET BINARY? <>>
  31          <SET BYTE? T>
  32          <SET STATUS <PUTLHW .STATUS ,BS-8BIT>>)
  33         (<=? .BYTES "BINARY">
  34          <SET STATUS <PUTLHW .STATUS ,BS-BINARY>>
  35          <SET BINARY? T>)
  36         (T
  37          <ERROR %<P-E "ILLEGAL-BYTE-SIZE"> .BYTES X$DISK-OPEN>)>
  38   <SET NAME <T$PARSE-FILE-NAME .NAME <> T .STOR>>
  39   <SET JFN <>>
  40   <COND (.NEW?
  41          <COND (<NOT <SET JFN
  42                           <CALL SYSCALL OPEN .NAME .MODE
  43                                 %<ORB ,FM-OWN-READ ,FM-OWN-WRITE
  44                                   ,FM-GRP-READ ,FM-GRP-WRITE
  45                                   ,FM-OTHER-READ ,FM-OTHER-WRITE>>>>
  46                 ; "Try to make shiny new file; come here if failed"
  47                 <COND (<==? <1 .JFN> ,EEXIST>
  48                        ; "Failed because file already exists"
  49                        <SET NNAME <I$MAKE-BACKUP-NAME .NAME>>
  50                        <CALL SYSCALL RENAME .NAME .NNAME>
  51                        <SET STATUS <ORB .STATUS ,STATUS-RENAME>>
  52                        <SET JFN <CALL SYSCALL OPEN .NAME
  53                                              .MODE
  54                                              %<ORB ,FM-OWN-READ ,FM-OWN-WRITE
  55                                                ,FM-OWN-XCT ,FM-GRP-READ
  56                                                ,FM-GRP-WRITE ,FM-GRP-XCT
  57                                                ,FM-OTHER-READ ,FM-OTHER-WRITE
  58                                                ,FM-OTHER-XCT>>>)>)>
  59          <COND (<NOT .JFN>
  60                 <RETURN .JFN .DO>)>)>
  61   <COND (<OR .JFN
  62              <SET JFN <CALL SYSCALL OPEN .NAME .MODE 0>>>
  63          <CHTYPE [.JFN
  64                   !.STOR
  65                   .STATUS
  66                   .MODE
  67                   .BINARY?
  68                   <COND (.APP?
  69                          <SET PTR <CALL SYSCALL LSEEK .JFN 0 ,WHENCE-EOF>>
  70                          <COND (.BINARY?
  71                                 ; "If appending in binary mode, maybe fill
  72                                    last word of file out with 0's."
  73                                 <COND (<NOT <0? <MOD .PTR ,BYTES/WORD>>>
  74                                        <CALL SYSCALL WRITE .JFN
  75                                              %<ISTRING ,BYTES/WORD <ASCII 0>>
  76                                              <- ,BYTES/WORD
  77                                                 <MOD .PTR ,BYTES/WORD>>>)>
  78                                 <SET PTR </ <+ .PTR <- ,BYTES/WORD 1>>
  79                                              ,BYTES/WORD>>)>
  80                          .PTR)
  81                         (<SET PTR 0>)>
  82                   .PTR
  83                   <SET BUF
  84                    <COND (.BUF?
  85                           <T$REQUEST-BUFFER <> <COND (.BINARY? UVECTOR)
  86                                                      (.BYTE? BYTES)
  87                                                      (T STRING)>
  88                                             <>>)>>
  89                   .BUF
  90                   0
  91                   0
  92                   <>]
  93                  I$DISK-CHANNEL>)>>
  94
  95 <DEFINE I$MAKE-BACKUP-NAME (NAME:STRING "AUX" NNAME:STRING TN:STRING NLEN:FIX)
  96   <SET TN <OR <REST <I$BMEMQ !\/ .NAME>> .NAME>>
  97   <SET NLEN <MIN %<+ ,MAXNAMLEN 1> <+ <LENGTH .TN> %<LENGTH ".bak">>>>
  98   <SET NNAME <ISTRING <+ <- <LENGTH .NAME> <LENGTH .TN>> .NLEN>>>
  99   <SUBSTRUC .NAME 0 <LENGTH .NAME> .NNAME>
 100   <SET TN <REST .NNAME <- <LENGTH .NNAME> %<+ <LENGTH ".bak"> 1>>>>
 101   <SUBSTRUC ".bak" 0 4 .TN>
 102   <PUT .NNAME <LENGTH .NNAME> <ASCII 0>>>
 103
 104 <DEFINE X$DISK-FILE-HANDLE (CHANNEL:T$CHANNEL OPR
 105                             "AUX" (DATA:I$DISK-CHANNEL
 106                                    <T$CHANNEL-DATA .CHANNEL>))
 107   <NS-JFN .DATA>>
 108
 109 <DEFINE X$DISK-QUERY (CHANNEL OPR BIT "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>))
 110   #DECL ((CHANNEL) T$CHANNEL (BIT) FIX (DATA) I$DISK-CHANNEL)
 111   <COND (<==? .BIT ,T$BIT-ACCESS>
 112          T)>>
 113
 114 <DEFINE X$DISK-CLOSE (CHANNEL OPER "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>))
 115         #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL)
 116         <I$FLUSH-BUFFER .DATA>
 117         <COND (<NS-BUF .DATA>
 118                <T$RELEASE-BUFFER <NS-BUF .DATA>>)>
 119         <CALL SYSCALL CLOSE <NS-JFN .DATA>>
 120         <NS-JFN .DATA -1>>
 121
 122 <DEFINE X$DISK-READ-BYTE (CHANNEL OPER
 123                        "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>)
 124                        (BUF <NS-BUF .DATA>) (PT <ANDB <CALL TYPE .BUF> ,M$$TYSAT>)
 125                        BYTE BC)
 126         #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL
 127                (BUF) <OR BYTES STRING FALSE UVECTOR> (BC) FIX)
 128         <COND (<NOT .BUF>
 129                <COND (<AND <SET BC
 130                             <X$DISK-READ-BUFFER .CHANNEL .OPER
 131                                                 <SET BUF
 132                                                  <COND (<NS-BINARY? .DATA>
 133                                                         ,I$UBUF1)
 134                                                        (,I$SBUF1)>>>>
 135                            <NOT <0? .BC>>>
 136                       <1 .BUF>)>)
 137               (T
 138                <PROG ((ONCE? <>))
 139                      #DECL ((ONCE?) <OR ATOM FALSE>)
 140                      <COND (<NOT <0? <SET BC <NS-BC .DATA>>>>
 141                             <SET BYTE <1 .BUF>>
 142                             <NS-PTR .DATA <+ <NS-PTR .DATA> 1>>
 143                             <NS-BUF .DATA <CASE ,==? .PT
 144                                                 (,M$$T-STR
 145                                                  <REST <CHTYPE .BUF STRING>>)
 146                                                 (,M$$T-UVC
 147                                                  <REST <CHTYPE .BUF UVECTOR>>)
 148                                                 (,M$$T-BYT
 149                                                  <REST <CHTYPE .BUF BYTES>>)>>
 150                             <NS-BC .DATA <- .BC 1>>
 151                             .BYTE)
 152                            (.ONCE? <>)
 153                            (<I$READ-BUFFER .DATA>
 154                             <SET BUF <NS-BUF .DATA>>
 155                             <SET ONCE? T>
 156                             <AGAIN>)>>)>>
 157
 158 <DEFINE I$READ-BUFFER (DATA
 159                      "AUX" (JFN <NS-JFN .DATA>) CT (OB <NS-BUF .DATA>)
 160                            (BUF <NS-TBUF .DATA>)
 161                            STS)
 162         #DECL ((DATA) I$DISK-CHANNEL (STS CT) <OR FIX FALSE> (JFN) FIX
 163                (OB BUF) <OR BYTES UVECTOR STRING>)
 164         <COND (<NS-WRITE-BUF? .DATA> <I$FLUSH-BUFFER .DATA>)>
 165         <COND (<NOT <SET CT <CALL SYSCALL READ .JFN .BUF
 166                                   <COND (<TYPE? .BUF STRING><LENGTH .BUF>)
 167                                         (<TYPE? .BUF BYTES> <LENGTH .BUF>)
 168                                         (<* ,BYTES/WORD <LENGTH .BUF>>)>>>>
 169                <ERROR %<P-E "ERROR-ON-READ"> .CT I$READ-BUFFER>)>
 170         <COND (<NS-BINARY? .DATA>
 171                <SET CT </ <+ .CT <- ,BYTES/WORD 1>> ,BYTES/WORD>>)>
 172         <NS-BUF .DATA .BUF>
 173         <NS-SPTR .DATA <+ <NS-SPTR .DATA> .CT>>
 174         <NS-BC .DATA .CT>
 175         <NS-OBC .DATA .CT>>
 176
 177 <DEFINE X$DISK-READ-BUFFER (CHANNEL OPER BUFFER
 178                          "OPTIONAL" CT
 179                          (CONT 0)
 180                          "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>)
 181                                (IBUF <NS-BUF .DATA>) (TIBUF <NS-TBUF .DATA>)
 182                                (TRANS 0) BC RD RTRANS
 183                                (PT <ANDB <CALL TYPE .BUFFER> ,M$$TYSAT>))
 184         #DECL ((CHANNEL) T$CHANNEL (BUFFER) <OR <PRIMTYPE BYTES>
 185                                                 <PRIMTYPE STRING>
 186                                                 <PRIMTYPE UVECTOR>>
 187                (CT CONT) FIX
 188                (DATA) I$DISK-CHANNEL (IBUF) <OR BYTES STRING UVECTOR FALSE>
 189                (BC) FIX (RD TRANS) <OR FIX FALSE>)
 190         <COND (<AND .IBUF <N==? <ANDB <CALL TYPE .IBUF> ,M$$TYSAT> .PT>>
 191                ; "Can't use buffer, since wrong type"
 192                <SET IBUF <>>
 193                <I$FLUSH-BUFFER .DATA>)>
 194         <COND (<NOT <ASSIGNED? CT>>
 195                <SET CT <CASE ,==? .PT
 196                              (,M$$T-STR <LENGTH <CHTYPE .BUFFER STRING>>)
 197                              (,M$$T-UVC <LENGTH <CHTYPE .BUFFER UVECTOR>>)
 198                              (,M$$T-BYT <LENGTH <CHTYPE .BUFFER BYTES>>)>>)>
 199         <REPEAT ((RD 0))
 200                 #DECL ((RD) FIX)
 201                 <COND
 202                  (<AND .IBUF <NOT <0? <SET BC <NS-BC .DATA>>>>>
 203                   <SET TRANS <MIN .BC .CT>>
 204                   <CASE ,==? .PT
 205                    (,M$$T-STR
 206                     <SUBSTRUC .IBUF:<PRIMTYPE STRING>
 207                               0 .TRANS .BUFFER:<PRIMTYPE STRING>>
 208                     <NS-BUF .DATA <REST .IBUF:<PRIMTYPE STRING> .TRANS>>
 209                     <SET BUFFER <REST .BUFFER:<PRIMTYPE STRING> .TRANS>>)
 210                    (,M$$T-BYT
 211                     <SUBSTRUC .IBUF:<PRIMTYPE BYTES>
 212                               0 .TRANS .BUFFER:<PRIMTYPE BYTES>>
 213                     <NS-BUF .DATA <REST .IBUF:<PRIMTYPE BYTES> .TRANS>>
 214                     <SET BUFFER <REST .BUFFER:<PRIMTYPE BYTES> .TRANS>>)
 215                    (,M$$T-UVC
 216                     <SUBSTRUC .IBUF:<PRIMTYPE UVECTOR>
 217                               0 .TRANS .BUFFER:<PRIMTYPE UVECTOR>>
 218                     <NS-BUF .DATA <REST .IBUF:<PRIMTYPE UVECTOR> .TRANS>>
 219                     <SET BUFFER <REST .BUFFER:<PRIMTYPE UVECTOR> .TRANS>>)>)>
 220                 <SET RD <+ .RD .TRANS>>
 221                 <SET CT <- .CT .TRANS>>
 222                 <NS-BC .DATA <- .BC .TRANS>>
 223                 <NS-PTR .DATA <+ <NS-PTR .DATA> .TRANS>>
 224                 <COND (<NOT <0? .CT>>
 225                      ;"Only use the buffer here if it might save a system call"
 226                        <COND (<AND .IBUF
 227                                    <L? .CT <CASE ,==? .PT
 228                                                  (,M$$T-STR
 229                                                   <LENGTH <CHTYPE .TIBUF
 230                                                                   STRING>>)
 231                                                  (,M$$T-BYT
 232                                                   <LENGTH <CHTYPE .TIBUF
 233                                                                   BYTES>>)
 234                                                  (,M$$T-UVC
 235                                                   <LENGTH <CHTYPE .TIBUF
 236                                                                   UVECTOR>>)>>>
 237                               <I$READ-BUFFER .DATA>
 238                               <COND (<0? <NS-BC .DATA>>
 239                                      <RETURN .RD>)>
 240                               <SET IBUF <NS-BUF .DATA>>)
 241                              (<SET TRANS
 242                                    <CALL SYSCALL READ
 243                                          <NS-JFN .DATA>
 244                                          .BUFFER
 245                                          <COND (<==? .PT 6>
 246                                                 <* .CT ,BYTES/WORD>)
 247                                                (.CT)>>>
 248                               <SET RTRANS .TRANS>
 249                               <COND (<==? .PT 6>
 250                                      <SET TRANS </ <+ .TRANS <- ,BYTES/WORD 1>>
 251                                                    ,BYTES/WORD>>
 252                                      <COND (<NS-BINARY? .DATA>
 253                                             <SET RTRANS .TRANS>)>)>
 254                               <NS-PTR .DATA <+ <NS-PTR .DATA> .RTRANS>>
 255                               <NS-SPTR .DATA <+ <NS-SPTR .DATA> .RTRANS>>
 256                               ; "Don't get ACCESS confused--make sure he
 257                                  knows there's nothing in the channel buffer
 258                                  in this case."
 259                               <NS-OBC .DATA 0>
 260                               <COND (.IBUF <NS-BUF .DATA .TIBUF>)>
 261                               <RETURN <+ .TRANS .RD>>)
 262                              (<RETURN .TRANS>)>)
 263                       (<RETURN .RD>)>>>
 264
 265 <DEFINE X$DISK-WRITE-BYTE (CHANNEL OPER BYTE
 266                         "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>)
 267                               (BUF <NS-BUF .DATA>) (PT <ANDB <CALL TYPE .BUF>
 268                                                              ,M$$TYSAT>)
 269                               (TBUF <NS-TBUF .DATA>))
 270         #DECL ((CHANNEL) T$CHANNEL (BYTE) <OR FIX CHARACTER>
 271                (DATA) I$DISK-CHANNEL
 272                (BUF) <OR FALSE BYTES STRING UVECTOR>)
 273         <COND (<0? <ANDB <NS-MODE .DATA> ,O-RDWR>>
 274                <ERROR %<P-E "CHANNEL-NOT-OPEN-FOR-WRITING">
 275                       .CHANNEL X$DISK-WRITE-BYTE>)>
 276         <COND (<NOT .BUF>
 277                <COND (<NS-BINARY? .DATA>
 278                       <SET BUF ,I$UBUF1>
 279                       <1 .BUF .BYTE>)
 280                      (T
 281                       <SET BUF ,I$SBUF1>
 282                       <1 .BUF .BYTE>)>
 283                <CALL SYSCALL WRITE <NS-JFN .DATA> .BUF
 284                      <COND (<TYPE? .BUF UVECTOR>
 285                             ,BYTES/WORD)
 286                            (1)>>
 287                <NS-PTR .DATA <+ <NS-PTR .DATA> 1>>
 288                <NS-SPTR .DATA <+ <NS-SPTR .DATA> 1>>
 289                .BYTE)
 290               (T
 291                <COND (<CASE ,==? .PT
 292                             (,M$$T-STR <EMPTY? .BUF:<PRIMTYPE STRING>>)
 293                             (,M$$T-BYT <EMPTY? .BUF:<PRIMTYPE BYTES>>)
 294                             (,M$$T-UVC <EMPTY? .BUF:<PRIMTYPE UVECTOR>>)>
 295                       <I$FLUSH-BUFFER .DATA>
 296                       <SET BUF <NS-BUF .DATA>>)>
 297                <CASE ,==? .PT
 298                      (,M$$T-STR
 299                       <1 .BUF:<PRIMTYPE STRING> .BYTE>
 300                       <NS-BUF .DATA <SET BUF <REST .BUF:<PRIMTYPE STRING>>>>
 301                       <NS-OBC .DATA
 302                               <MAX <NS-OBC .DATA>
 303                                    <- <LENGTH
 304                                        .TBUF:<PRIMTYPE STRING>>
 305                                       <LENGTH .BUF:<PRIMTYPE STRING>>>>>)
 306                      (,M$$T-BYT
 307                       <1 .BUF:<PRIMTYPE BYTES> .BYTE>
 308                       <NS-BUF .DATA <SET BUF <REST .BUF:<PRIMTYPE BYTES>>>>
 309                       <NS-OBC .DATA
 310                               <MAX <NS-OBC .DATA>
 311                                    <- <LENGTH
 312                                        .TBUF:<PRIMTYPE BYTES>>
 313                                       <LENGTH .BUF:<PRIMTYPE BYTES>>>>>)
 314                      (,M$$T-UVC
 315                       <1 .BUF:<PRIMTYPE UVECTOR> .BYTE>
 316                       <NS-BUF .DATA <SET BUF <REST .BUF:<PRIMTYPE UVECTOR>>>>
 317                       <NS-OBC .DATA
 318                               <MAX <NS-OBC .DATA>
 319                                    <- <LENGTH
 320                                        .TBUF:<PRIMTYPE UVECTOR>>
 321                                       <LENGTH .BUF:<PRIMTYPE UVECTOR>>>>>)>
 322                <NS-PTR .DATA <+ <NS-PTR .DATA> 1>>
 323                <NS-WRITE-BUF? .DATA T>
 324                <NS-BC .DATA <MAX 0 <- <NS-BC .DATA> 1>>>
 325                .BYTE)>>
 326
 327 <DEFINE I$FLUSH-BUFFER (DATA
 328                       "AUX" (BUF <NS-BUF .DATA>) LEN SP (JFN <NS-JFN .DATA>)
 329                             (PT <ANDB <CALL TYPE .BUF> ,M$$TYSAT>) TB)
 330         #DECL ((DATA) I$DISK-CHANNEL (BUF) <OR BYTES UVECTOR STRING FALSE>
 331                (JFN SP LEN) FIX)
 332         <COND (<NS-WRITE-BUF? .DATA>
 333                <NS-WRITE-BUF? .DATA <>>
 334                <COND (.BUF
 335                       <SET SP <- <NS-PTR .DATA>
 336                                  <CASE ,==? .PT
 337                                   (,M$$T-STR <- <LENGTH
 338                                                  <SET TB
 339                                                       <NS-TBUF .DATA>:STRING>>
 340                                                 <LENGTH
 341                                                  .BUF:<PRIMTYPE STRING>>>)
 342                                   (,M$$T-BYT
 343                                    <- <LENGTH
 344                                        <SET TB
 345                                             <NS-TBUF .DATA>:BYTES>>
 346                                       <LENGTH .BUF:<PRIMTYPE BYTES>>>)
 347                                   (,M$$T-UVC
 348                                    <- <LENGTH
 349                                        <SET TB
 350                                             <NS-TBUF .DATA>:UVECTOR>>
 351                                       <LENGTH .BUF:<PRIMTYPE UVECTOR>>>)>>>
 352                       <COND (<N==? <NS-SPTR .DATA> .SP>
 353                              <COND (<NS-BINARY? .DATA>
 354                                     <CALL SYSCALL LSEEK .JFN
 355                                           <* .SP ,BYTES/WORD>
 356                                           ,WHENCE-ABS>)
 357                                    (<CALL SYSCALL LSEEK .JFN
 358                                           .SP ,WHENCE-ABS>)>
 359                              <NS-SPTR .DATA .SP>)>
 360                       <SET LEN <NS-OBC .DATA>>
 361                       <COND (<N==? .PT ,M$$T-UVC>
 362                              <CALL SYSCALL WRITE .JFN .TB .LEN>)
 363                             (<CALL SYSCALL WRITE .JFN .TB
 364                                    <* .LEN ,BYTES/WORD>>)>
 365                       <SET SP <+ .LEN <NS-SPTR .DATA>>>
 366                       <COND (<N==? .SP <NS-PTR .DATA>>
 367                              <SET SP <NS-PTR .DATA>>
 368                              <NS-SPTR .DATA .SP>
 369                              <CALL SYSCALL LSEEK .JFN
 370                                    <COND (<NS-BINARY? .DATA>
 371                                           <* ,BYTES/WORD .SP>)
 372                                          (.SP)> ,WHENCE-ABS>)
 373                             (<NS-SPTR .DATA .SP>)>
 374                       <NS-BUF .DATA .TB>
 375                       <NS-BC .DATA 0>
 376                       <NS-OBC .DATA 0>)>)
 377               (T
 378                <COND (<N==? <NS-PTR .DATA> <NS-SPTR .DATA>>
 379                       <CALL SYSCALL LSEEK .JFN
 380                             <COND (<NS-BINARY? .DATA>
 381                                    <* ,BYTES/WORD <NS-PTR .DATA>>)
 382                                   (<NS-PTR .DATA>)>
 383                             ,WHENCE-ABS>)>
 384                <NS-SPTR .DATA <NS-PTR .DATA>>
 385                <NS-BC .DATA 0>
 386                <NS-OBC .DATA 0>
 387                <COND (.BUF <NS-BUF .DATA <NS-TBUF .DATA>>)>)>>
 388
 389 <DEFINE X$DISK-WRITE-BUFFER (CHANNEL OPER BUFFER
 390                           "OPTIONAL" LEN
 391                           "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>) RVAL
 392                                 (IBUF <NS-BUF .DATA>) (JFN <NS-JFN .DATA>)
 393                                 VAL TIB (PT <ANDB <CALL TYPE .BUFFER> ,M$$TYSAT>))
 394    #DECL ((CHANNEL) T$CHANNEL (BUFFER) <OR <PRIMTYPE UVECTOR> <PRIMTYPE STRING>
 395                                            <PRIMTYPE BYTES>>
 396           (JFN LEN) FIX
 397           (DATA) I$DISK-CHANNEL (IBUF) <OR BYTES UVECTOR STRING FALSE>
 398           (VAL) <OR FALSE FIX> (TIB) FIX)
 399    <COND (<0? <ANDB <NS-MODE .DATA> ,O-RDWR>>
 400           <ERROR %<P-E "CHANNEL-NOT-OPEN-FOR-WRITING">
 401                  .CHANNEL X$DISK-WRITE-BYTE>)>
 402    <COND (<NOT <ASSIGNED? LEN>>
 403           <SET LEN
 404                <CASE ,==? .PT
 405                      (,M$$T-STR
 406                       <LENGTH .BUFFER:<PRIMTYPE STRING>>)
 407                      (,M$$T-BYT
 408                       <LENGTH .BUFFER:<PRIMTYPE BYTES>>)
 409                      (,M$$T-UVC
 410                       <LENGTH .BUFFER:<PRIMTYPE UVECTOR>>)>>)>
 411    <COND (<OR <NOT .IBUF>
 412               <N==? .PT <ANDB <CALL TYPE .IBUF> ,M$$TYSAT>>>
 413           <COND (.IBUF
 414                  <I$FLUSH-BUFFER .DATA>)>
 415           <COND (<SET VAL <CALL SYSCALL WRITE .JFN .BUFFER
 416                                 <COND (<==? .PT 6> <* ,BYTES/WORD .LEN>)
 417                                       (.LEN)>>>
 418                  <SET RVAL .VAL>
 419                  <COND (<==? .PT 6>
 420                         ; "If we wrote out a uvector, get length right"
 421                         <SET VAL </ .VAL ,BYTES/WORD>>
 422                         <COND (<NS-BINARY? .DATA>
 423                                ; "but if not a binary channel, pointer
 424                                   will still be in characters instead
 425                                   of words"
 426                                <SET RVAL .VAL>)>)>
 427                  <NS-PTR .DATA <+ <NS-PTR .DATA> .RVAL>>
 428                  <NS-SPTR .DATA <+ <NS-SPTR .DATA> .RVAL>>)>)
 429          (T
 430           <CASE ,==? .PT
 431                 (,M$$T-STR
 432                  <SET TIB <LENGTH <NS-TBUF .DATA>:STRING>>)
 433                 (,M$$T-BYT
 434                  <SET TIB <LENGTH <NS-TBUF .DATA>:BYTES>>)
 435                 (,M$$T-UVC
 436                  <SET TIB <LENGTH <NS-TBUF .DATA>:UVECTOR>>)>
 437           <REPEAT ((RD 0) TRANS (IBUF .IBUF) IL)
 438                   #DECL ((RD TRANS) FIX (IBUF) <OR BYTES STRING UVECTOR>)
 439                   <SET IL <CALL LENU .IBUF>>
 440                   <COND (<AND <NOT <AND <==? .IL .TIB>
 441                                         <G=? .LEN .IL>>>
 442                               ; "If buffer is empty, and long transfer,
 443                                  don't put any of it in buffer"
 444                               <NOT <CASE ,==? .PT
 445                                     (,M$$T-STR
 446                                      <EMPTY? .IBUF:<PRIMTYPE STRING>>)
 447                                     (,M$$T-BYT
 448                                      <EMPTY? .IBUF:<PRIMTYPE BYTES>>)
 449                                     (,M$$T-UVC
 450                                      <EMPTY? .IBUF:<PRIMTYPE UVECTOR>>)>>>
 451                          <CASE ,==? .PT
 452                                (,M$$T-STR
 453                                 <SET TRANS <MIN .LEN .IL>>
 454                                 <SUBSTRUC .BUFFER:<PRIMTYPE STRING> 0
 455                                           .TRANS .IBUF:<PRIMTYPE STRING>>
 456                                 <SET BUFFER
 457                                      <REST .BUFFER:<PRIMTYPE STRING> .TRANS>>
 458                                 <SET IL <LENGTH
 459                                          <SET IBUF <REST
 460                                                     .IBUF:<PRIMTYPE STRING>
 461                                                     .TRANS>>>>)
 462                                (,M$$T-BYT
 463                                 <SET TRANS <MIN .LEN .IL>>
 464                                 <SUBSTRUC .BUFFER:<PRIMTYPE BYTES> 0 .TRANS
 465                                           .IBUF:<PRIMTYPE BYTES>>
 466                                 <SET BUFFER <REST .BUFFER:<PRIMTYPE BYTES>
 467                                                   .TRANS>>
 468                                 <SET IL <LENGTH
 469                                          <SET IBUF <REST .IBUF:<PRIMTYPE BYTES>
 470                                                          .TRANS>>>>)
 471                                (,M$$T-UVC
 472                                 <SET TRANS <MIN .LEN .IL>>
 473                                 <SUBSTRUC .BUFFER:<PRIMTYPE UVECTOR> 0 .TRANS
 474                                           .IBUF:<PRIMTYPE UVECTOR>>
 475                                 <SET BUFFER <REST .BUFFER:<PRIMTYPE UVECTOR>
 476                                                   .TRANS>>
 477                                 <SET IL <LENGTH
 478                                          <SET IBUF <REST
 479                                                     .IBUF:<PRIMTYPE UVECTOR>
 480                                                     .TRANS>>>>)>
 481                          <SET RD <+ .RD .TRANS>>
 482                          <SET LEN <- .LEN .TRANS>>
 483                          <NS-WRITE-BUF? .DATA T>
 484                          <NS-BUF .DATA .IBUF>
 485                          <NS-PTR .DATA <+ <NS-PTR .DATA> .TRANS>>
 486                          <NS-BC .DATA <MAX 0 <- <NS-BC .DATA> .TRANS>>>
 487                          <NS-OBC .DATA
 488                                  <MAX <NS-OBC .DATA>
 489                                       <- .TIB .IL>>>)>
 490                   <COND (<NOT <0? .LEN>>
 491                          <COND (<N==? .IL .TIB> <I$FLUSH-BUFFER .DATA>)>
 492                          <COND (<G=? .LEN .TIB>
 493                                 <SET TRANS
 494                                      <CALL SYSCALL WRITE .JFN .BUFFER
 495                                            <COND (<NS-BINARY? .DATA>
 496                                                   <* ,BYTES/WORD .LEN>)
 497                                                  (.LEN)>>>
 498                                 <COND (<NS-BINARY? .DATA>
 499                                        <SET TRANS </ .TRANS ,BYTES/WORD>>)>
 500                                 <NS-SPTR .DATA <+ <NS-SPTR .DATA> .TRANS>>
 501                                 <NS-PTR .DATA <+ <NS-PTR .DATA> .TRANS>>
 502                                 <RETURN <+ .TRANS .RD>>)
 503                                (<SET IBUF <NS-BUF .DATA>>)>)
 504                         (<RETURN .RD>)>>)>>
 505
 506 <DEFINE X$DISK-ACCESS (CHANNEL OPER "OPTIONAL" PTR
 507                     "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>) (JFN <NS-JFN .DATA>)
 508                           (OPTR <NS-PTR .DATA>) (BUF <NS-BUF .DATA>) INC TL L
 509                           (PT <ANDB <CALL TYPE .BUF> ,M$$TYSAT>) TB)
 510         #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL
 511                (TL L OPTR JFN INC) FIX (PTR) <OR FIX FALSE>)
 512         <COND (.BUF
 513                <CASE ,==? .PT
 514                      (,M$$T-STR
 515                       <SET L <LENGTH <CHTYPE .BUF STRING>>>
 516                       <SET TL <LENGTH <SET TB <CHTYPE <NS-TBUF .DATA>
 517                                                       STRING>>>>)
 518                      (,M$$T-BYT
 519                       <SET L <LENGTH <CHTYPE .BUF BYTES>>>
 520                       <SET TL <LENGTH <SET TB <CHTYPE <NS-TBUF .DATA>
 521                                                       BYTES>>>>)
 522                      (,M$$T-UVC
 523                       <SET L <LENGTH <CHTYPE .BUF UVECTOR>>>
 524                       <SET TL <LENGTH
 525                                <SET TB <CHTYPE <NS-TBUF .DATA> UVECTOR>>>>)>)>
 526         <COND (<OR <NOT <ASSIGNED? PTR>>
 527                    <NOT .PTR>>
 528                <SET PTR .OPTR>)
 529               (<==? .PTR .OPTR>)
 530               (<AND .BUF
 531                     <G=? .PTR <- .OPTR <- .TL .L>>>
 532                     <L=? .PTR <+ .OPTR <NS-BC .DATA>>>>
 533                <COND (<G? .PTR .OPTR>
 534                       <NS-BC .DATA <- <NS-BC .DATA> <SET INC <- .PTR .OPTR>>>>
 535                       <CASE ,==? .PT
 536                             (,M$$T-STR
 537                              <NS-BUF .DATA <REST <CHTYPE .BUF STRING> .INC>>)
 538                             (,M$$T-BYT
 539                              <NS-BUF .DATA <REST <CHTYPE .BUF BYTES> .INC>>)
 540                             (,M$$T-UVC
 541                              <NS-BUF .DATA
 542                                      <REST <CHTYPE .BUF UVECTOR> .INC>>)>)
 543                      (T
 544                       <NS-BUF .DATA <CALL BACKU .BUF <SET INC <- .OPTR .PTR>>>>
 545                       <NS-BC .DATA <+ <NS-BC .DATA> .INC>>)>
 546                <NS-PTR .DATA .PTR>)
 547               (T
 548                <I$FLUSH-BUFFER .DATA>
 549                <SET PTR
 550                     <COND (<==? .PTR -1>
 551                            <CALL SYSCALL LSEEK .JFN 0 ,WHENCE-EOF>)
 552                           (<CALL SYSCALL LSEEK
 553                                  .JFN <COND (<NS-BINARY? .DATA>
 554                                              <* ,BYTES/WORD .PTR>)
 555                                             (.PTR)>
 556                                  ,WHENCE-ABS>)>>
 557                <COND (<NS-BINARY? .DATA>
 558                       <SET PTR </ .PTR ,BYTES/WORD>>)>
 559                <NS-PTR .DATA .PTR>
 560                <NS-SPTR .DATA .PTR>)>
 561         .PTR>
 562
 563 <DEFINE X$DISK-BUFOUT (CHANNEL OPER "OPTIONAL" (FORCE? T)
 564                        "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>))
 565         #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL
 566                (FORCE?) <OR ATOM FALSE>)
 567         <COND (<NS-WRITE-BUF? .DATA>
 568                <I$FLUSH-BUFFER .DATA>
 569                <CALL SYSCALL FSYNC <NS-JFN .DATA>>)>>
 570
 571 <DEFINE X$DISK-FILE-LENGTH (CHANNEL OPER
 572                             "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>))
 573         #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL)
 574         <T$GET-BYTE-COUNT <NS-JFN .DATA> <NS-BINARY? .DATA>>>
 575
 576 <DEFINE X$DISK-PRINT-DATA (CHANNEL OPER OUTCHAN
 577                           "AUX" (DATA <T$CHANNEL-DATA .CHANNEL>) BUF)
 578   #DECL ((CHANNEL) T$CHANNEL (DATA) I$DISK-CHANNEL)
 579   <PRINC "#DISK-CHANNEL [">
 580   <PRINC "JFN:">
 581   <PRIN1 <NS-JFN .DATA>>
 582   <PRINC " MODE:">
 583   <PRIN1 <NS-MODE .DATA>>
 584   <PRINC " BIN?:">
 585   <PRIN1 <NS-BINARY? .DATA>>
 586   <PRINC " PTR:">
 587   <PRIN1 <NS-PTR .DATA>>
 588   <PRINC " SPTR:">
 589   <PRIN1 <NS-SPTR .DATA>>
 590   <PRINC " BUF:">
 591   <COND (<SET BUF <NS-BUF .DATA>>
 592          <PRIN1 <NS-BC .DATA>>
 593          <PRINC !\/>
 594          <COND (<TYPE? .BUF STRING>
 595                 <PRIN1 <- <LENGTH <NS-TBUF .DATA>>
 596                           <LENGTH <NS-BUF .DATA>>>>
 597                 <PRINC !\/>
 598                 <PRIN1 <LENGTH <NS-BUF .DATA>>>)
 599                (<PRIN1 <- <LENGTH <NS-TBUF .DATA>>
 600                           <LENGTH <NS-BUF .DATA>>>>
 601                 <PRINC !\/>
 602                 <PRIN1 <LENGTH <NS-BUF .DATA>>>)>)
 603         (T
 604          <PRINC "<>">)>
 605   <PRINC !\]>
 606   T>
 607
 608 <DEFINE X$DISK-FLUSH (CHN OPER "AUX" (DAT <T$CHANNEL-DATA .CHN>)
 609                      (JFN <NS-JFN .DAT>) (STATUS <NS-STATUS .DAT>)
 610                      ONM BCKNM)
 611   #DECL ((CHN) T$CHANNEL (DAT) I$DISK-CHANNEL)
 612   <COND (<NS-BUF .DAT>
 613          <T$RELEASE-BUFFER <NS-BUF .DAT>>)>
 614   <COND (<0? <ANDB .STATUS ,STATUS-NO-FLUSH>>
 615          <COND (<CALL SYSCALL CLOSE .JFN>
 616                 <COND (<NOT <0? <ANDB .STATUS ,STATUS-NEW>>>
 617                        <SET ONM <T$STANDARD-NAME <I$DEF-NAME .CHN .OPER>>>
 618                        <CALL SYSCALL UNLINK .ONM>
 619                        <COND (<NOT <0? <ANDB .STATUS ,STATUS-RENAME>>>
 620                               <SET BCKNM <I$MAKE-BACKUP-NAME .ONM>>
 621                               <CALL SYSCALL LINK .BCKNM .ONM>
 622                               <CALL SYSCALL UNLINK .BCKNM>)
 623                              (.CHN)>)
 624                       (.CHN)>)>)>>