mim/development/mim/vax/mimlib/dfl.mud

   1
   2 <PACKAGE "DFL">
   3
   4 "Fast FLOADer for people who use TECO to debug MUDDLE"
   5
   6 <ENTRY DFL RDFL FLO DFL-RETRY UN-DFL>
   7
   8 <USE "PP">
   9
  10 <INCLUDE-WHEN <COMPILING? "DFL"> "DFLDEFS">
  11
  12 <SETG DFL-BUFLEN 600>
  13 <SETG SLEN 6>
  14 <MANIFEST DFL-BUFLEN SLEN>
  15
  16 <SETG 6STRING <ISTRING 6>>
  17
  18 <SETG TV <IVECTOR ,SLEN>>
  19
  20 <SETG DFL-BUF <REST <SETG TDFL-BUF <ISTRING <+ ,DFL-BUFLEN 50> !\ >> 50>>
  21
  22 <SETG DFL-ZERO-STR <REST <SETG DFL-FILNAM <ISTRING 40 !\ >> 40>>
  23
  24 <SETG DFL-STRUC <REST <SETG DFL-NAM-SCRATCH <IVECTOR 10 "">> 9>>
  25
  26 <DEFINE DFL ("OPTIONAL" (FUNC-NAME ,DFL-FUNC-NAM) (FILNAM ,DFL-FILNAM))
  27         #DECL ((FUNC-NAME) <OR STRUCTURED ATOM> (FILNAM) <OR ATOM STRING>)
  28         <FDFL .FUNC-NAME .FILNAM '["<DEF" ["INE " "MAC "]] <>>>
  29
  30 <DEFINE RDFL ("OPTIONAL" (FUNC-NAME ,DFL-FUNC-NAM) (FILNAM ,DFL-FILNAM)
  31                          (READ2? T))
  32         #DECL ((FUNC-NAME) <OR STRUCTURED ATOM> (FILNAM) <OR ATOM STRING>
  33                (READ2?) <OR ATOM FALSE>)
  34         <FDFL .FUNC-NAME .FILNAM "<SETG " .READ2?>>
  35
  36 <DEFINE FDFL (FUNC-NAME FILNAM STR READ2?)
  37         #DECL ((FUNC-NAME) <OR STRUCTURED ATOM> (FILNAM) <OR ATOM STRING>)
  38         <COND (<TYPE? .FILNAM ATOM> <SET FILNAM <SPNAME .FILNAM>>)>
  39         <SETG DFL-FUNC-NAM .FUNC-NAME>
  40         <SETG DFL-FILNAM .FILNAM>
  41         <DO-DFL <DFL-SETUP .FUNC-NAME .READ2?> .FILNAM .STR .READ2?>>
  42
  43 <DEFINE DFL-SETUP (FUNC-NAME "OPT" (READ2? <>)
  44                    "AUX" (DFL-STRUC ,DFL-STRUC) (DFL-SCRATCH ,DFL-NAM-SCRATCH)
  45                          (TL <LENGTH .DFL-SCRATCH>))
  46    #DECL ((FUNC-NAME) <OR ATOM STRUCTURED> (TL) FIX
  47           (DFL-SCRATCH DFL-STRUC) VECTOR)
  48    <COND
  49     (<TYPE? .FUNC-NAME ATOM> <PUT .DFL-STRUC 1
  50                                   <COND (.READ2? <STRING <ASCII 26>
  51                                                          <LC <SPNAME .FUNC-NAME>>
  52                                                          "-IMSUBR">)
  53                                         (T <SPNAME .FUNC-NAME>)>>)
  54     (<TYPE? .FUNC-NAME STRING> <PUT .DFL-STRUC 1
  55                                     <COND (.READ2? <STRING <ASCII 26>
  56                                                            <LC .FUNC-NAME>
  57                                                            "-IMSUBR">)
  58                                           (T .FUNC-NAME)>>)
  59     (T
  60      <COND (<G? <LENGTH .FUNC-NAME> .TL>
  61             <SET DFL-SCRATCH
  62                  <SETG DFL-NAM-SCRATCH
  63                        <IVECTOR <SET TL <+ <LENGTH .FUNC-NAME> 5>> "">>>
  64             <SETG DFL-STRUC <REST .DFL-SCRATCH <- .TL 1>>>)>
  65      <SET DFL-SCRATCH <REST .DFL-SCRATCH <- .TL <LENGTH .FUNC-NAME>>>>
  66      <MAPR <>
  67            <FUNCTION (X Y "AUX" (FOO <1 .Y>))
  68                    #DECL ((X) VECTOR (Y) <STRUCTURED [REST <OR ATOM STRING>]>
  69                           (FOO) <OR ATOM STRING>)
  70                    <COND (<TYPE? .FOO ATOM> <SET FOO <SPNAME .FOO>>)>
  71                    <1 .X <COND (.READ2? <STRING <ASCII 26> <LC .FOO> "-IMSUBR">)
  72                                (T .FOO)>>>
  73            .DFL-SCRATCH
  74            .FUNC-NAME>
  75      .DFL-SCRATCH)>>
  76
  77 <DEFINE LC (STR)
  78    #DECL ((STR) STRING)
  79    <MAPF ,STRING
  80          <FUNCTION (C)
  81             <COND (<AND <G=? <ASCII .C> <ASCII !\A>>
  82                         <L=? <ASCII .C> <ASCII !\Z>>>
  83                    <ASCII <+ <ASCII .C> <- <ASCII !\a> <ASCII !\A>>>>)
  84                   (T .C)>>
  85          .STR>>
  86
  87 <DEFINE DO-DFL (FUNC-NAME FILNAM MEMSTR READ2?
  88                 "AUX" (CHN <OPEN "READ" .FILNAM>) FUNC-NAMLEN
  89                       TSTR STR (PACKAGE-FLAG <>) FNV
  90                       (DFL-BUF ,DFL-BUF) (6STR ,6STRING) ATM FORM RFILNAM
  91                       BEGACC ACC P Q (DEBUGGING? T))
  92    #DECL ((FUNC-NAME) <VECTOR [REST <OR FALSE STRING>]> (6STR FILNAM) STRING
  93           (CHN) <OR <CHANNEL 'DISK> FALSE> (FNV) <OR VECTOR FALSE>
  94           (TSTR) STRING
  95           (FUNC-NAMLEN) FIX (MEMSTR) <OR STRING VECTOR>
  96           (PACKAGE-FLAG) <OR FALSE STRING FIX> (STR) <OR FALSE STRING>
  97           (DFL-BUF) STRING (ATM) ATOM (FORM) FORM (DEBUGGING?) <SPECIAL ATOM>
  98           (READ2?) <OR ATOM FALSE> (RFILNAM) <VECTOR [4 STRING]>
  99           (BEGACC ACC) FIX)
 100    <UNWIND
 101     <AND
 102      .CHN
 103      <SET RFILNAM
 104           <VECTOR <CHANNEL-OP .CHN NM1>
 105                   <CHANNEL-OP .CHN NM2>
 106                   <CHANNEL-OP .CHN DEV>
 107                   <CHANNEL-OP .CHN SNM>>>
 108      <REPEAT REPNAM ((ANS ()) (ANS1 ()) CHARS-READ (FOUND? <>))
 109        #DECL ((ANS ANS1) <LIST [REST ATOM]> (CHARS-READ) FIX
 110               (FOUND?) <OR ATOM FALSE>)
 111        <COND (.FOUND?
 112               <SET TSTR .DFL-BUF>
 113               <SET FOUND? <>>)
 114              (<SET TSTR ,TDFL-BUF>
 115               <SUBSTRUC <REST .DFL-BUF <- ,DFL-BUFLEN 50>> 0 50 .TSTR>)>
 116        <SET CHARS-READ <CHANNEL-OP .CHN READ-BUFFER .DFL-BUF>>
 117        <COND
 118         (<NOT .PACKAGE-FLAG>
 119          <COND
 120           (<AND <SET PACKAGE-FLAG <MEMBER "PACKA" .TSTR>>
 121                 <SET PACKAGE-FLAG <BACK .PACKAGE-FLAG>>
 122                 <COND (<==? <1 .PACKAGE-FLAG> !\R>
 123                        <SET PACKAGE-FLAG <BACK .PACKAGE-FLAG>>)
 124                       (T)>
 125                 <COND (<N==? <1 .PACKAGE-FLAG> !\<> <SET PACKAGE-FLAG <>>) (T)>
 126                 <NOT <MEMQ <1 <BACK .PACKAGE-FLAG>> ";'">>>
 127            <CHANNEL-OP .CHN ACCESS <- ,DFL-BUFLEN <LENGTH .PACKAGE-FLAG>>>
 128            <SET P <READ .CHN>>
 129            <CHAN-CLEAR .CHN>
 130            <COND (<AND <TYPE? .P FORM>
 131                        <NOT <LENGTH? .P 1>>
 132                        <SET Q <LOOKUP <2 .P> <MOBLIST PACKAGE>>>
 133                        <GASSIGNED? .Q>
 134                        <TYPE? <SET Q ,.Q> LIST>>
 135                   <SET P <EVAL .P>>
 136                   <SETG .P <SET OBLIST .Q>>
 137                   <PUTPROP .Q IN-COLLECTION .P>
 138                   <SET CHARS-READ <CHANNEL-OP .CHN READ-BUFFER .DFL-BUF>>)
 139                  (ELSE
 140                   <EVAL .P>
 141                   <PROG ()
 142                         <SET CHARS-READ <CHANNEL-OP .CHN READ-BUFFER .DFL-BUF>>
 143                         <COND (<SET PACKAGE-FLAG <MEMBER "ENTRY" .DFL-BUF>>
 144                                <SET PACKAGE-FLAG <BACK .PACKAGE-FLAG>>
 145                                <COND (<==? <1 .PACKAGE-FLAG> !\R>
 146                                       <SET PACKAGE-FLAG <BACK .PACKAGE-FLAG>>)>
 147                                <COND (<OR <N==? <1 .PACKAGE-FLAG> !\<>
 148                                           <MEMQ <1 .PACKAGE-FLAG> ";'">>
 149                                       <RETURN>)>
 150                                <CHANNEL-OP .CHN ACCESS
 151                                        <+ <- <SET ACC <CHANNEL-OP .CHN ACCESS>>
 152                                              .CHARS-READ>
 153                                           <- ,DFL-BUFLEN <LENGTH .PACKAGE-FLAG>>>>
 154                                <EVAL <READ .CHN>>
 155                                <CHAN-CLEAR .CHN>
 156                                <AGAIN>)>>
 157                   <PROG ()
 158                         <COND (<OR <AND <SET PACKAGE-FLAG <MEMBER "<USE"
 159                                                                   .DFL-BUF>>
 160                                         <OR <==? <5 .PACKAGE-FLAG> !\ >
 161                                             <MEMBER
 162                                              <SUBSTRUC .PACKAGE-FLAG 4 6 .6STR>
 163                                              '["-DEBUG" "-TOTAL" "-DEFER"]>
 164                                             <=?
 165                                              <SUBSTRUC .PACKAGE-FLAG 4 5
 166                                                        <REST .6STR>>
 167                                              "-WHEN">>>
 168                                    <AND <SET PACKAGE-FLAG <MEMBER "<INCLUDE"
 169                                                                   .DFL-BUF>>
 170                                         <OR <==? <9 .PACKAGE-FLAG> !\ >
 171                                             <=? <SUBSTRUC .PACKAGE-FLAG
 172                                                           10 6 .6STR>
 173                                                 "-DEBUG">
 174                                             <=? <SUBSTRUC .PACKAGE-FLAG
 175                                                           10 5 <REST .6STR>>
 176                                                 "-WHEN">>>>
 177                                <CHANNEL-OP .CHN ACCESS
 178                                            <+ <- <SET ACC <CHANNEL-OP .CHN
 179                                                                       ACCESS>>
 180                                                  .CHARS-READ>
 181                                           <- ,DFL-BUFLEN
 182                                              <LENGTH .PACKAGE-FLAG>>>>
 183                                <EVAL <READ .CHN>>
 184                                <CHAN-CLEAR .CHN>
 185                                <SET CHARS-READ
 186                                     <CHANNEL-OP .CHN READ-BUFFER .DFL-BUF>>
 187                                <AGAIN>)>
 188                         <SET PACKAGE-FLAG "">>)>)
 189           (<OR <MEMBER "<SET" .TSTR> <MEMBER "<DEF" .TSTR>>
 190            <SET PACKAGE-FLAG 0>)>)>
 191        <PROG ()
 192          <AND
 193           <COND (<OR <AND <NOT <SET STR <SUBSTRING-SEARCH .MEMSTR .TSTR>>>
 194                           <L? .CHARS-READ ,DFL-BUFLEN>>
 195                      <AND .STR <L? <LENGTH .STR> <- ,DFL-BUFLEN .CHARS-READ>>>>
 196                  <PROG ()
 197                        <CLOSE .CHN>
 198                        <AND <TYPE? .PACKAGE-FLAG STRING> <ENDPACKAGE>>
 199                        <RETURN <CHTYPE (EOF-FOUND-BEFORE-THESE
 200                                         !<MAPF ,LIST
 201                                                <FUNCTION (X) <OR .X <MAPRET>>>
 202                                                .FUNC-NAME>)
 203                                        FALSE>
 204                                .REPNAM>>)
 205                 (T)>
 206           .STR
 207           <NOT <LENGTH? .STR 40>>
 208           <SET FUNC-NAMLEN
 209                <- <LENGTH .STR>
 210                   <REPEAT ((S .STR))
 211                           <COND (<MEMQ <1 .S> "         \r\0">
 212                                  <RETURN <LENGTH .S>>)>
 213                           <COND (<EMPTY? <SET S <REST .S>>> <RETURN 0>)>>>>
 214           <COND
 215            (<AND <SET FNV
 216                       <MEMBER <SUBSTRUC .STR
 217                                         0
 218                                         .FUNC-NAMLEN
 219                                         <BACK ,DFL-ZERO-STR .FUNC-NAMLEN>>
 220                               .FUNC-NAME>>
 221                  <NOT <MEMQ <1 <BACK .STR 9>> ";'">>>
 222             <CHANNEL-OP .CHN ACCESS
 223                     <SET BEGACC
 224                          <+ <- <SET ACC <CHANNEL-OP .CHN ACCESS>> .CHARS-READ>
 225                             <- ,DFL-BUFLEN <LENGTH .STR> 8>>>>
 226             <SET FOUND? T>
 227             <SET ATM <2 <SET FORM <READ .CHN>>>>
 228             <CHAN-CLEAR .CHN>
 229             <SET ANS (.ATM !.ANS)>
 230             <EVAL .FORM>
 231             <PUTPROP .ATM
 232                      DFL
 233                      <VECTOR .BEGACC
 234                              <SET ACC <CHANNEL-OP .CHN ACCESS>>
 235                              .RFILNAM
 236                              .OBLIST>>
 237             <PUT .FNV 1 <>>
 238             <COND (<AND .READ2? <TYPE? ,.ATM IMSUBR>> <EVAL <READ .CHN>>
 239                    <CHAN-CLEAR .CHN>)>
 240             <COND (<OR? !.FUNC-NAME>
 241                    <AGAIN .REPNAM>)
 242                   (T
 243                    <AND <TYPE? .PACKAGE-FLAG STRING> <ENDPACKAGE>>
 244                    <CLOSE .CHN>
 245                    <COND (<NOT <EMPTY? .ANS1>>
 246                           <PUTREST <REST .ANS1 <- <LENGTH .ANS1> 1>> .ANS>
 247                           <SET ANS .ANS1>)>
 248                    <RETURN .ANS .REPNAM>)>)
 249            (<SET TSTR .STR> <AGAIN>)>>>>>
 250     <CLOSE .CHN>>>
 251
 252 <DEFINE CHAN-CLEAR (CHN:<CHANNEL 'DISK>)
 253    <COND (<M-NCHR .CHN>
 254           <M-NCHR .CHN <>>
 255           <CHANNEL-OP .CHN ACCESS <- <CHANNEL-OP .CHN ACCESS>:FIX 1>>)>>
 256
 257 <DEFINE SUBSTRING-SEARCH SS (MEMSTR STR "AUX" TSTR TARG)
 258    #DECL ((TSTR) <OR FALSE STRING> (TARG) STRING (STR) STRING
 259           (MEMSTR) <OR STRING <VECTOR STRING VECTOR>>)
 260    <COND
 261     (<TYPE? .MEMSTR STRING>
 262      <COND (<SET TSTR <MEMBER .MEMSTR .STR>> <REST .TSTR <LENGTH .MEMSTR>>)>)
 263     (T
 264      <PROG OA ()
 265         <COND
 266          (<SET TSTR <MEMBER <SET TARG <1 .MEMSTR>> .STR>>
 267           <COND (<OR <L? <LENGTH .TSTR> <LENGTH .TARG>>
 268                      <EMPTY? <SET TSTR <REST .TSTR <LENGTH .TARG>>>>>
 269                  <RETURN <>>)>
 270           <MAPF <>
 271                 <FUNCTION (SECOND "AUX" TEMP (RT .TSTR))
 272                    #DECL ((RT SECOND) STRING)
 273                    <REPEAT ()
 274                       <COND (<EMPTY? .RT> <RETURN>)
 275                             (<==? <1 .SECOND> <1 .RT>>
 276                              <SET RT <REST .RT>>
 277                              <COND (<EMPTY? <SET SECOND <REST .SECOND>>>
 278                                     <RETURN .RT .SS>)>)
 279                             (T
 280                              <SET STR <REST .STR>>
 281                              <AGAIN .OA>)>>>
 282                 <2 .MEMSTR>>
 283           <>)>>)>>
 284
 285
 286 <DEFINE UN-DFL UNACT (ATMS:<OR ATOM <LIST [REST ATOM]>>
 287                       "OPT" (FILNAM:<OR FALSE STRING <VECTOR [REST STRING]>> <>)
 288                       (FORCE:<OR ATOM FALSE> <>)
 289                       "AUX" (FOOTOP:<PRIMTYPE VECTOR>
 290                              <ITUPLE <COND (<TYPE? .ATMS ATOM> ,SLEN)
 291                                            (T <* <LENGTH .ATMS> ,SLEN>)>>)
 292                             (FOOBOT:<PRIMTYPE VECTOR>
 293                              <REST .FOOTOP <LENGTH .FOOTOP>>)
 294                             FOO:UNTUPLE FOOSAV:UNTUPLE TEMP
 295                             ACC:FIX FILP:<VECTOR [4 STRING]>
 296                             OCH:<OR FALSE <CHANNEL 'DISK>>
 297                             ICH:<OR FALSE <CHANNEL 'DISK>>
 298                             NEWFIL:<VECTOR [4 STRING]>
 299                             (LOSERS:<LIST [REST ATOM]> ())
 300                             NM1:<SPECIAL STRING>
 301                             NM2:<SPECIAL STRING>
 302                             SNM:<SPECIAL STRING>
 303                             DEV:<SPECIAL STRING>
 304                             CDATE1:<OR FIX FALSE> NAME1)
 305    <COND (<TYPE? .ATMS ATOM>
 306           <COND (<SET TEMP <UNSET .ATMS .FOOBOT>>
 307                  <SET FOOBOT .TEMP>
 308                  <SET FOO .FOOBOT>)
 309                 (<RETURN <CHTYPE ("Not DFLed?" .ATMS) FALSE> .UNACT>)>)
 310          (T
 311           <MAPF <>
 312                 <FUNCTION (X "AUX" TEMP)
 313                         #DECL ((X) ATOM (TEMP) <OR FALSE UNTUPLE>)
 314                         <COND (<SET TEMP <UNSET .X .FOOBOT>> <SET FOO .TEMP>)
 315                               (T <SET LOSERS (.X !.LOSERS)>)>>
 316                 .ATMS>
 317           <COND (<G? <LENGTH .ATMS> 1> <DO-SORT .FOO>)>)>
 318    <SET FOOSAV .FOO>
 319    <SET FILP <FILPTR .FOO>>
 320    <SET SNM <4 .FILP>>
 321    <SET DEV <3 .FILP>>
 322    <SET NM1 <1 .FILP>>
 323    <SET NM2 <2 .FILP>>
 324    <OR .FILNAM <SET FILNAM .FILP>>
 325    <COND (<TYPE? .FILNAM STRING>
 326           <COND (<SET OCH <OPEN "READ" .FILNAM>>
 327                  <SET DEV <CHANNEL-OP .OCH DEV>>
 328                  <SET SNM <CHANNEL-OP .OCH SNM>>)>)
 329          (T
 330           <SET OCH <OPEN "READ" "" <1 .FILNAM> "MUD" <3 .FILNAM> <4 .FILNAM>>>)>
 331    <COND (.OCH
 332           <SET CDATE1 <CHANNEL-OP .OCH WRITE-DATE>>
 333           <SET NAME1 <CHANNEL-OP .OCH NAME *36*>>
 334           <CLOSE .OCH>)>
 335    <COND (<SET ICH <OPEN "READ" "" !<FILPTR .FOO>>>
 336           <COND (<OR .FORCE
 337                      <NOT .OCH>
 338                      <N=? <CHANNEL-OP .ICH NAME *36*> .NAME1>
 339                      <L=? .CDATE1:FIX <CHANNEL-OP .ICH WRITE-DATE>:FIX>>)
 340                 (<RETURN <CHTYPE ("Would destroy later version!"
 341                                   <CHANNEL-OP .ICH NAME>
 342                                   .NAME1)
 343                                  FALSE>
 344                          .UNACT>)>
 345           <COND (<TYPE? .FILNAM STRING>
 346                  <SET OCH <OPEN "PRINT" .FILNAM>>)
 347                 (T
 348                  <SET OCH <OPEN "PRINT"
 349                                 "" <1 .FILNAM> "MUD" <3 .FILNAM> <4 .FILNAM>>>)>
 350           <REPEAT (NEWBEG ATM VAL (OUTCHAN .OCH) OBLIST)
 351                   #DECL ((OUTCHAN) <SPECIAL CHANNEL> (OBLIST) <SPECIAL ANY>)
 352                   <COND (<EMPTY? .FOO>
 353                          <COPY-TO-CHR .ICH .OCH <FILE-LENGTH .ICH>>
 354                          <CLOSE .ICH>
 355                          <SET NEWFIL
 356                               <VECTOR <CHANNEL-OP .OCH NM1>
 357                                       <CHANNEL-OP .OCH NM2>
 358                                       <CHANNEL-OP .OCH DEV>
 359                                       <CHANNEL-OP .OCH SNM>>>
 360                          <CLOSE .OCH>
 361                          <RETURN>)>
 362                   <SET OBLIST <OBLPTR .FOO>>
 363                   <COPY-TO-CHR .ICH .OCH <BEGPTR .FOO>>
 364                   <SET NEWBEG <CHANNEL-OP .OCH ACCESS>>
 365                   <EPRIN1 <COND (<TYPE? <SET VAL ,<SET ATM <NAMPTR .FOO>>>
 366                                         FUNCTION>
 367                                  <CHTYPE (DEFINE .ATM !.VAL) FORM>)
 368                                 (<FORM SETG .ATM .VAL>)>>
 369                   <CRLF .OCH>
 370                   <CRLF .OCH>
 371                   <CHANNEL-OP .ICH ACCESS <ENDPTR .FOO>>
 372                   <FILPTR-SAVE-BEG <ASSOCI .FOO> .NEWBEG>
 373                   <FILPTR-SAVE-END <ASSOCI .FOO>
 374                                    <SET ACC <CHANNEL-OP .OCH ACCESS>>>
 375                   <SET FOO <REST .FOO ,SLEN>>>
 376           <REPEAT ((FOO .FOOSAV))
 377                   #DECL ((FOO) UNTUPLE)
 378                   <COND (<EMPTY? .FOO> <RETURN>)
 379                         (<FILNAM-SAVE <ASSOCI .FOO> .NEWFIL>
 380                          <SET FOO <REST .FOO ,SLEN>>)>>
 381           <COND (<NOT <EMPTY? .LOSERS>> <CHTYPE ("Not DFLed?" !.LOSERS) FALSE>)
 382                 (.ATMS)>)>>
 383
 384 <DEFINE UNSET (ATM:ATOM TUP:<PRIMTYPE VECTOR>
 385                "AUX" (AS:<OR FALSE <VECTOR FIX FIX VECTOR>> <GETPROP .ATM DFL>)
 386                "VALUE" <OR FALSE <PRIMTYPE VECTOR>>)
 387         <COND (.AS
 388                <NAMPTR <SET TUP <BACK .TUP ,SLEN>>:<PRIMTYPE VECTOR> .ATM>
 389                <ASSOCI .TUP .AS>
 390                <BEGPTR .TUP
 391                        <FILPTR-SAVE-BEG .AS>>
 392                <ENDPTR .TUP
 393                        <FILPTR-SAVE-END .AS>>
 394                <FILPTR .TUP <FILNAM-SAVE .AS>>
 395                <OBLPTR .TUP <OBLIST-SAVE .AS>>)>>
 396
 397 <DEFINE COPY-TO-CHR (ICH OCH CT
 398                      "AUX" (BUF ,DFL-BUF) (ACC <CHANNEL-OP .ICH ACCESS>)
 399                      (INC <- .CT .ACC>) TINC)
 400         #DECL ((ICH OCH) <CHANNEL 'DISK> (TINC INC CT ACC) FIX (BUF) STRING)
 401         <REPEAT ()
 402                 <SET TINC <CHANNEL-OP .ICH READ-BUFFER
 403                                       .BUF <MIN .INC ,DFL-BUFLEN>>>
 404                 <CHANNEL-OP .OCH WRITE-BUFFER .BUF .TINC>
 405                 <COND (<L=? <SET INC <- .INC ,DFL-BUFLEN>> 0> <RETURN>)>>>
 406
 407 <DEFINE DO-SORT (TUP:UNTUPLE "AUX" (TV ,TV))
 408         <REPEAT ((X:UNTUPLE .TUP) (Y:UNTUPLE <REST .TUP ,SLEN>) (NEWL <>))
 409                 <COND (<G? <BEGPTR .X> <BEGPTR .Y>>
 410                        <SUBSTRUC .X 0 ,SLEN .TV>
 411                        <SUBSTRUC .Y 0 ,SLEN .X>
 412                        <SUBSTRUC .TV 0 ,SLEN .Y>
 413                        <SET NEWL T>)>
 414                 <COND (<EMPTY? <SET Y <REST .Y ,SLEN>>>
 415                        <COND (.NEWL
 416                               <SET X .TUP>
 417                               <SET Y <REST .TUP ,SLEN>>
 418                               <SET NEWL <>>)
 419                              (<RETURN>)>)
 420                       (T <SET X <REST .X ,SLEN>>)>>>
 421
 422 <ENDPACKAGE>
 423