mim/development/mim/vax/mimlib/mudcom.mud

   1 <USE "NEWSTRUC" "MISC-IO" "JCL">
   2
   3 <SETG VERBOSE? T>
   4
   5 <DEFINE SAVE-MUDCOM ("AUX" A)
   6         #DECL ((A) <OR FALSE VECTOR>)
   7         <COND (<=? <SAVE "MUDCOM.SAVE"> "RESTORED">
   8                <COND (<SET A <READARGS>>
   9                       <MUDCOM !.A>)
  10                      (ELSE
  11                       <PRINC "mudcom [oldfile] newfile
  12 ">)>
  13                <QUIT>)>>
  14
  15 <DEFINE MUDCOM (OLDFILE "OPT" NEWFILE
  16                 "AUX" NEWCHAN OLDCHAN OLDREST NEWSTART L OLD (NM2 "MIMA")
  17                 (OUTCHAN .OUTCHAN))
  18         #DECL ((NEWFILE OLDFILE NEWSTART OLDREST) STRING (OUTCHAN) CHANNEL
  19                (NEWCHAN OLDCHAN) <OR FALSE CHANNEL>
  20                (NM2) <SPECIAL STRING> (L) <OR LIST FALSE> (OLD) <OR FALSE STRING>)
  21         <IFSYS (UNIX
  22                 <COND (<AND <NOT <ASSIGNED? NEWFILE>>
  23                             <NOT <MEMBER ".BAK" .OLDFILE>>>
  24                        <COND (<NOT <MEMBER !\. .OLDFILE>>
  25                               <SET OLDFILE <STRING .OLDFILE ".MUD">>)>
  26                        <COND (<SET OLDCHAN
  27                                    <OPEN "READ" <STRING .OLDFILE ".BAK">>>)
  28                              (ELSE
  29                               <SET OLDREST .OLDFILE>
  30                               <REPEAT (TMP)
  31                                  <COND (<SET TMP <MEMQ !\/ .OLDFILE>>
  32                                         <SET OLDREST <REST .TMP>>)
  33                                        (ELSE <RETURN>)>>
  34                               <COND (<G? <LENGTH .OLDREST> 10>
  35                                      <SET OLDCHAN
  36                                           <OPEN "READ"
  37                                                 <STRING <SUBSTRUC .OLDFILE 0 10>
  38                                                         ".BAK">>>)>)>)
  39                       (ELSE <SET OLDCHAN <OPEN "READ" .OLDFILE>>)>)
  40                (TOPS-20
  41                 <SET OLDCHAN <OPEN "READ" .OLDFILE>>)>
  42         <COND (.OLDCHAN
  43                <COND (<NOT <ASSIGNED? NEWFILE>>
  44                       <SET NEWSTART
  45                            <CHANNEL-OP .OLDCHAN NAME %<+ 16 8 4>>>
  46                       <SET NEWFILE <STRING .NEWSTART ".MUD">>)>
  47                <SET NM2 "MUD">
  48                <COND (<SET NEWCHAN <OPEN "READ" .NEWFILE>>
  49                       <SET OLDFILE <CHANNEL-OP .OLDCHAN NAME>>
  50                       <IFSYS
  51                        (TOPS-20
  52                         <COND (<N=? <CHANNEL-OP .OLDCHAN NAME 2> ".MUD">
  53                                <COND (<SET OLD <FIND-OLD .OLDCHAN .NEWCHAN>>
  54                                       <CLOSE .OLDCHAN>
  55                                       <COND (<SET OLDCHAN <OPEN "READ" .OLD>>
  56                                              <SET OLDFILE
  57                                                   <CHANNEL-OP .OLDCHAN NAME>>)
  58                                             (ELSE
  59                                              <SET OLDFILE .OLD>)>)
  60                                      (ELSE
  61                                       <CLOSE .OLDCHAN>
  62                                       <SET OLDCHAN .OLD>)>)>)>
  63                       <PRINC "Comparing ">
  64                       <PRINC .OLDFILE>
  65                       <PRINC " with ">
  66                       <PRINC <CHANNEL-OP .NEWCHAN NAME>>
  67                       <CRLF>
  68                       <COND (.OLDCHAN
  69                              <SET L <FILE-COMPARE .NEWCHAN .OLDCHAN>>
  70                              <COND (,VERBOSE? <MUDCOM-PRINT .L> T)
  71                                    (ELSE .L)>)
  72                             (ELSE
  73                              <CLOSE .NEWCHAN>
  74                              .OLDCHAN)>)
  75                      (ELSE <OPEN-FAILED .NEWCHAN>)>)
  76               (ELSE
  77                <OPEN-FAILED .OLDCHAN>)>>
  78
  79 <DEFINE OPEN-FAILED (F "AUX" (OUTCHAN .OUTCHAN))
  80         #DECL ((F) FALSE (OUTCHAN) CHANNEL)
  81         <PRINC "Open of ">
  82         <PRINC <2 .F>>
  83         <PRINC " failed: ">
  84         <PRINC <1 .F>>
  85         <>>
  86
  87 <DEFINE FIND-OLD (OLDCHAN NEWCHAN
  88                   "AUX" (CMPDATE 0) (CMPFILE #FALSE ("No older file"))
  89                   (R T) C OLDDATE NEWDATE NEW)
  90         #DECL ((OLDCHAN NEWCHAN) <OR CHANNEL FALSE> (CMPDATE OLDDATE NEWDATE) FIX)
  91         <COND (<L? <SET OLDDATE <CHANNEL-OP .OLDCHAN WRITE-DATE>>
  92                    <SET NEWDATE <CHANNEL-OP .NEWCHAN WRITE-DATE>>>
  93                <SET NEW <STRING <CHANNEL-OP .NEWCHAN NAME %<+ 16 8 4 2>>
  94                                 ".*">>
  95                <SET C <CHANNEL-OPEN GNJFN .NEW .NEW>>
  96                <MAPF <>
  97                      <FUNCTION ()
  98                           <COND (<NOT .R>
  99                                  <CLOSE .C>
 100                                  <MAPLEAVE .CMPFILE>)
 101                                 (<AND <L? <SET NEWDATE <CHANNEL-OP .C WRITE-DATE>>
 102                                           .OLDDATE>
 103                                       <G? .NEWDATE .CMPDATE>>
 104                                  <SET CMPFILE <CHANNEL-OP .C NAME>>
 105                                  <SET CMPDATE .NEWDATE>)
 106                                 (ELSE
 107                                  <SET R <CHANNEL-OP .C NEXT-FILE>>)>>>)
 108               (ELSE .CMPFILE)>>
 109
 110 <DEFINE MUDCOM-PRINT (L "AUX" (OUTCHAN .OUTCHAN))
 111         #DECL ((L) <OR FALSE <LIST [REST <VECTOR STRING ATOM ANY>]>>
 112                (OUTCHAN) CHANNEL)
 113         <COND (<NOT .L>
 114                <PRINC <1 .L>>
 115                <PRINC !\ >
 116                <PRIN1 <2 .L>>)
 117               (<EMPTY? .L> <PRINC "No differences."> <CRLF>)
 118               (ELSE
 119                <MAPF <>
 120                      <FUNCTION (V)
 121                           #DECL ((V) <VECTOR STRING ATOM ANY>)
 122                           <PRINC <COND (<==? <3 .V> 'N==?> "Changed ")
 123                                        (<==? <3 .V> '+> "Added ")
 124                                        (<==? <3 .V> '-> "Removed ")>>
 125                           <PRINC <2 .V>>
 126                           <PRINC !\ >
 127                           <PRINC <1 .V>>
 128                           <CRLF>>
 129                      .L>)>>
 130
 131 <DEFINE FILE-COMPARE (NEWCHAN OLDCHAN
 132                       "AUX" NEW OLD (NEWNAME <CHANNEL-OP .NEWCHAN NAME>)
 133                       (OLDNAME <CHANNEL-OP .OLDCHAN NAME>))
 134         #DECL ((NEW OLD) <OR FALSE LIST> (NEWNAME OLDNAME) STRING)
 135         <COND (<AND <SET NEW <FILE-HASH .NEWCHAN>>
 136                     <SET OLD <FILE-HASH .OLDCHAN>>>
 137                <MAPF ,LIST
 138                      <FUNCTION ("AUX" N)
 139                           #DECL ((N) <OR <VECTOR STRING ATOM ANY> FALSE>)
 140                           <COND (<EMPTY? .NEW>
 141                                  <COND (<EMPTY? .OLD> <MAPSTOP>)
 142                                        (ELSE
 143                                         <SET N <1 .OLD>>
 144                                         <SET OLD <REST .OLD>>
 145                                         <COND (.N
 146                                                <PUT .N 3 '->
 147                                                <MAPRET .N>)
 148                                               (ELSE <MAPRET>)>)>)
 149                                 (ELSE
 150                                  <SET N <1 .NEW>>
 151                                  <SET NEW <REST .NEW>>
 152                                  <COND (<DIFF? .N .OLD>
 153                                         <MAPRET .N>)
 154                                        (ELSE <MAPRET>)>)>>>)
 155               (.NEW <CHTYPE (.OLDNAME .OLD) FALSE>)
 156               (ELSE <CHTYPE (.NEWNAME .NEW) FALSE>)>>
 157
 158 <DEFINE DIFF? (N OL)
 159         #DECL ((N) <VECTOR STRING ATOM ANY> (OL) LIST)
 160         <MAPR <>
 161               <FUNCTION (OL "AUX" (O <1 .OL>))
 162                    #DECL ((OL) LIST (O) <OR FALSE <VECTOR STRING ATOM ANY>>)
 163                    <COND (<AND .O <=? <1 .N> <1 .O>>>
 164                           <PUT .OL 1 <>>
 165                           <COND (<AND <==? <2 .N> <2 .O>>
 166                                       <==? <3 .N> <3 .O>>>
 167                                  <MAPLEAVE <>>)
 168                                 (ELSE
 169                                  <PUT .N 3 'N==?>
 170                                  <MAPLEAVE .N>)>)
 171                          (<EMPTY? <REST .OL>>
 172                           <PUT .N 3 '+>
 173                           <MAPLEAVE .N>)>>
 174               .OL>>
 175
 176 <SETG BUFFER <REST <SETG TOPBUFFER <ISTRING 1000>> 1000>>
 177 <SETG N 0>
 178 <SETG BLANKS "
 179 ">
 180 <SETG BRACKETS <ISTRING 100>>
 181 <GDECL (TOPBUFFER BUFFER BLANKS BRACKETS) STRING (N) FIX>
 182
 183 <MSETG ITEM-NAME 1>
 184 <MSETG ITEM-TYPE 2>
 185 <MSETG ITEM-CODE 3>
 186
 187 <DEFINE FILE-HASH (FIL "AUX" CHAN (ITEM-LIST ()) ITEM
 188                    (BLANKS ,BLANKS) (QUOTE? <>) (STR? <>) (BLANK? <>)
 189                    (WAS-BLANK? <>) (BRACKETS ,BRACKETS) LEFT
 190                    (BUFFER ,BUFFER) (LEVEL 0) (HASH? <>) CHR)
 191         #DECL ((BUFFER BLANKS BRACKETS) STRING (CHAN) <OR FALSE CHANNEL>
 192                (FIL) <OR STRING CHANNEL> (ITEM-LIST) LIST (LEFT) CHARACTER
 193                (ITEM) <OR FALSE VECTOR> (QUOTE? STR? BLANK?) <OR ATOM FALSE>
 194                (LEVEL) FIX (HASH?) <OR FALSE FIX> (CHR) <OR CHARACTER FALSE>)
 195         <COND (<SET CHAN
 196                     <COND (<TYPE? .FIL STRING> <OPEN "READ" .FIL>)
 197                           (ELSE .FIL)>>
 198                <SETG BUFFER <REST .BUFFER <LENGTH .BUFFER>>>
 199                <SETG N 0>
 200                <SETG CHAN .CHAN>
 201                <REPEAT ()
 202                        <PROG ((BUFFER ,BUFFER) (N ,N))
 203                              #DECL ((BUFFER) STRING (N) FIX)
 204                              <COND (<EMPTY? .BUFFER>
 205                                     <SET BUFFER <SETG BUFFER ,TOPBUFFER>>
 206                                     <COND (<G? <SET N
 207                                                     <CHANNEL-OP ,CHAN
 208                                                                 READ-BUFFER
 209                                                                 .BUFFER>>
 210                                                0>)
 211                                           (ELSE <RETURN <SET CHR <>>>)>)
 212                                    (<0? .N> <RETURN <SET CHR <>>>)>
 213                              <SET CHR <1 .BUFFER>>
 214                              <SETG BUFFER <REST .BUFFER>>
 215                              <SETG N <- .N 1>>>
 216                        <COND (<NOT .CHR>
 217                               <CLOSE .CHAN>
 218                               <RETURN
 219                                <COND (<N==? .BRACKETS ,BRACKETS>
 220                                       <CHTYPE ("EOF" <1 <BACK .BRACKETS>> .ITEM)
 221                                               FALSE>)
 222                                      (.STR?
 223                                       <CHTYPE ("UNTERMINATED STRING" <> .ITEM)
 224                                               FALSE>)
 225                                      (ELSE .ITEM-LIST)>>)>
 226                        <COND (<AND <NOT .STR?>
 227                                    <NOT .QUOTE?>
 228                                    <MEMQ .CHR .BLANKS>>
 229                               <COND (.BLANK? <AGAIN>)
 230                                     (ELSE
 231                                      <SET BLANK? T>
 232                                      <SET CHR !\ >)>)
 233                              (ELSE
 234                               <SET WAS-BLANK? .BLANK?>
 235                               <SET BLANK? <>>)>
 236                        <COND (.HASH?
 237                               <SET HASH? <XORB <ASCII .CHR> <ROT .HASH? 5>>>)>
 238                        <COND (.QUOTE? <SET QUOTE? <>>)
 239                              (<==? .CHR %<ASCII 92>> <SET QUOTE? T>)
 240                              (<==? .CHR !\"> <SET STR? <NOT .STR?>>)
 241                              (.STR?)
 242                              (<MEMQ .CHR "<[({">
 243                               <SET BRACKETS <REST <PUT .BRACKETS 1 .CHR>>>
 244                               <COND (<AND <==? .LEVEL 0> <==? .CHR !\<>>
 245                                      <COND (<SET ITEM <DO-TLF>>
 246                                             <SET HASH? 0>)>)
 247                                     (<AND .HASH? <NOT .WAS-BLANK?>>
 248                                      <SET HASH?
 249                                           <XORB <ASCII !\ > <ROT .HASH? 5>>>)>
 250                               <SET LEVEL <+ .LEVEL 1>>)
 251                              (<MEMQ .CHR ">])}">
 252                               <COND (<==? .BRACKETS ,BRACKETS>
 253                                      <CLOSE .CHAN>
 254                                      <RETURN <CHTYPE ("EXTRA" .CHR .ITEM) FALSE>>)
 255                                     (ELSE
 256                                      <SET LEFT
 257                                           <1 <SET BRACKETS
 258                                                   <CALL BACKU .BRACKETS 1>>>>)>
 259                               <COND (<OR <AND <==? .LEFT !\<>
 260                                               <==? .CHR !\>>>
 261                                          <AND <==? .LEFT !\[>
 262                                               <==? .CHR !\]>>
 263                                          <AND <==? .LEFT !\(>
 264                                               <==? .CHR !\)>>
 265                                          <AND <==? .LEFT !\{>
 266                                               <==? .CHR !\}>>>)
 267                                     (ELSE
 268                                      <CLOSE .CHAN>
 269                                      <RETURN <CHTYPE (.LEFT .CHR .ITEM) FALSE>>)>
 270                               <COND (<AND .HASH? <NOT .WAS-BLANK?>>
 271                                      <SET HASH?
 272                                           <XORB <ASCII !\ > <ROT .HASH? 5>>>)>
 273                               <COND (<==? <SET LEVEL <- .LEVEL 1>> 0>
 274                                      <COND (.ITEM
 275                                             <ITEM-CODE .ITEM .HASH?>
 276                                             <SET ITEM-LIST (.ITEM !.ITEM-LIST)>)>
 277                                      <SET HASH? <>>)>)>>)>>
 278
 279 <DEFINE DO-TLF ("AUX" (TYP <>) BUF NAM)
 280         #DECL ((TYP) <OR ATOM FALSE> (BUF) <OR FIX FALSE>
 281                (NAM) <OR STRING FALSE>)
 282         <COND (<SET BUF <CHECK-FOR "SET">>
 283                <SET TYP LVAL>)
 284               (<SET BUF <CHECK-FOR "SETG">>
 285                <SET TYP GVAL>)
 286               (<SET BUF <CHECK-FOR "MSETG">>
 287                <SET TYP MANIFEST>)
 288               (<SET BUF <CHECK-FOR "DEFINE">>
 289                <SET TYP FUNCTION>)
 290               (<SET BUF <CHECK-FOR "DEFMAC">>
 291                <SET TYP MACRO>)>
 292         <COND (<AND .TYP <SET NAM <NEXT-TOKEN .BUF>>>
 293                <VECTOR .NAM .TYP 0>)>>
 294
 295 <DEFINE CHECK-FOR (STR "AUX" BUF N (BUFFER ,BUFFER) (M ,N) BLANKS)
 296         #DECL ((STR BUFFER BLANKS BUF) STRING (N M) FIX)
 297         <PROG ()
 298               <COND (<L=? .M <LENGTH .STR>>
 299                      <SUBSTRUC .BUFFER 0 .M
 300                                <SETG BUFFER ,TOPBUFFER>>
 301                      <SET BUFFER ,BUFFER>
 302                      <SET BUF <REST .BUFFER .M>>
 303                      <COND (<G? <SET N <CHANNEL-OP ,CHAN READ-BUFFER .BUF>>
 304                                 0>
 305                             <SETG N <+ .N .M>>)
 306                            (ELSE <RETURN <>>)>)>
 307               <COND (<AND <FIRST? .STR .BUFFER>
 308                           <MEMQ <NTH .BUFFER <+ 1 <SET N <LENGTH .STR>>>>
 309                                 <SET BLANKS ,BLANKS>>>
 310                      .N)>>>
 311
 312 <DEFINE NEXT-TOKEN (O "AUX" N (START? <>) (M ,N) (BUFFER ,BUFFER)
 313                     BUF BLANKS)
 314         #DECL ((BUF BUFFER BLANKS) STRING
 315                (START?) <OR ATOM FALSE> (M O N) FIX)
 316         <PROG ()
 317               <COND (<L=? .M 100>
 318                      <SUBSTRUC .BUFFER
 319                                0 .M
 320                                <SETG BUFFER ,TOPBUFFER>>
 321                      <SET BUFFER ,BUFFER>
 322                      <SET BUF <REST .BUFFER .M>>
 323                      <COND (<G? <SET N <CHANNEL-OP ,CHAN READ-BUFFER .BUF>>
 324                                 0>
 325                             <SETG N <+ .N .M>>)>)
 326                     (ELSE <SET BUF ,BUFFER>)>
 327               <SET BUF <REST .BUFFER .O>>
 328               <MAPF ,STRING
 329                     <FUNCTION (CHR)
 330                          #DECL ((CHR) CHARACTER)
 331                          <COND (<NOT .START?>
 332                                 <COND (<MEMQ .CHR <SET BLANKS ,BLANKS>>
 333                                        <MAPRET>)
 334                                       (ELSE
 335                                        <SET START? T>
 336                                        <MAPRET .CHR>)>)
 337                                (<MEMQ .CHR <SET BLANKS ,BLANKS>>
 338                                 <MAPSTOP>)
 339                                (ELSE
 340                                 <MAPRET .CHR>)>>
 341                     .BUF>>>
 342
 343 <DEFINE FIRST? (STR BUF)
 344         #DECL ((STR BUF) STRING)
 345         <MAPF <>
 346               ,==?
 347               .STR
 348               .BUF>>