<mdl.int>/chkdcl.mud.2

   1
   2
   3 <SETG DECL-RESTED 1>
   4
   5 <SETG DECL-ELEMENT 2>
   6
   7 <SETG DECL-ITEM-COUNT 3>
   8
   9 <SETG DECL-IN-REST 4>
  10
  11 <SETG DECL-IN-COUNT-VEC 5>
  12
  13 <SETG DECL-REST-VEC 6>
  14
  15 <MANIFEST DECL-RESTED
  16           DECL-ELEMENT
  17           DECL-ITEM-COUNT
  18           DECL-IN-REST
  19           DECL-IN-COUNT-VEC
  20           DECL-REST-VEC>
  21
  22 <SETG HIGHBOUND 2>
  23
  24 <SETG LOWBOUND 1>
  25
  26 <MANIFEST HIGHBOUND LOWBOUND>
  27
  28 <SETG ALLWORDS '<PRIMTYPE WORD>>
  29
  30 <DEFINE TASTEFUL-DECL (D "AUX" TEM)
  31         <COND (<OR <NOT .D> <==? .D NO-RETURN>> ANY)
  32               (<AND <TYPE? .D ATOM> <VALID-TYPE? .D>> .D)
  33               (<AND <OR <TYPE? <SET TEM .D> ATOM> <SET TEM <ISTYPE? .D>>>
  34                     <GET .TEM DECL>>
  35                .TEM)
  36               (<TYPE? .D FORM SEGMENT>
  37                <COND (<LENGTH? .D 1>
  38                       <OR <AND <EMPTY? .D> ANY> <TASTEFUL-DECL <1 .D>>>)
  39                      (<==? <1 .D> FIX> FIX)
  40                      (<AND <==? <LENGTH .D> 2> <==? <1 .D> NOT>> ANY)
  41                      (<TYPE? .D SEGMENT>
  42                       <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> SEGMENT>)
  43                      (ELSE <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> FORM>)>)
  44               (<TYPE? .D VECTOR>
  45                [<COND (<==? <1 .D> OPT> OPTIONAL) (ELSE <1 .D>)>
  46                 !<MAPF ,LIST ,TASTEFUL-DECL <REST .D>>])
  47               (ELSE .D)>>
  48
  49 <DEFINE TMERGE (P1 P2)
  50         <COND (<OR <AND <TYPE? .P1 FORM SEGMENT>
  51                         <==? <LENGTH .P1> 2>
  52                         <TYPE? <2 .P1> LIST>>
  53                    <AND <TYPE? .P2 FORM SEGMENT>
  54                         <==? <LENGTH .P2> 2>
  55                         <TYPE? <2 .P2> LIST>>
  56                    <CTMATCH .P1 .P2 <> <> T>>
  57                <CTMATCH .P1 .P2 T T <>>)
  58               (<=? .P1 '<NOT ANY>> .P2)
  59               (<=? .P2 '<NOT ANY>> .P1)
  60               (ELSE <CHTYPE (OR !<PUT-IN <PUT-IN () .P1> .P2>) FORM>)>>
  61
  62 <DEFINE TYPE-AND (P1 P2) <CTMATCH .P1 .P2 T <> <>>>
  63
  64 <DEFINE TMATCH (P1 P2) <CTMATCH .P1 .P2 <> <> <>>>
  65
  66 <DEFINE CTMATCH (P1 P2 ANDF ORF MAYBEF)
  67         #DECL ((ANDF ORF MAYBEF) <SPECIAL <OR FALSE ATOM>>)
  68         <DTMATCH .P1 .P2>>
  69
  70 <DEFINE DTMATCH (PAT1 PAT2)
  71         <OR .PAT1 <SET PAT1 ANY>>
  72         <OR .PAT2 <SET PAT2 ANY>>
  73         <COND (<=? .PAT1 .PAT2> .PAT1)
  74               (<TYPE? <SET PAT1 <VTS .PAT1>> ATOM> <TYPMAT .PAT1 <VTS .PAT2>>)
  75               (<TYPE? <SET PAT2 <VTS .PAT2>> ATOM> <TYPMAT .PAT2 .PAT1>)
  76               (<AND <TYPE? .PAT1 FORM SEGMENT> <TYPE? .PAT2 FORM SEGMENT>>
  77                <TEXP1 .PAT1 .PAT2>)
  78               (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
  79
  80 <DEFINE VTS (X)
  81         <OR <AND <TYPE? .X ATOM>
  82                  <OR <VALID-TYPE? .X>
  83                      <MEMQ .X '![STRUCTURED LOCATIVE APPLICABLE ANY!]>>
  84                  .X>
  85             <AND <TYPE? .X ATOM> <GET .X DECL>>
  86             .X>>
  87
  88 <DEFINE 2-ELEM (OBJ)
  89         #DECL ((OBJ) <PRIMTYPE LIST>)
  90         <AND <NOT <EMPTY? .OBJ>> <NOT <EMPTY? <REST .OBJ>>>>>
  91
  92 <DEFINE TYPMAT (TYP PAT "AUX" TEM)
  93         #DECL ((TYP) ATOM)
  94         <OR <SET TEM
  95                  <COND (<TYPE? .PAT ATOM>
  96                         <OR <AND <==? .PAT ANY> <COND (.ORF ANY) (ELSE .TYP)>>
  97                             <AND <==? .TYP ANY> <COND (.ORF ANY) (ELSE .PAT)>>
  98                             <AND <=? .PAT .TYP> .TYP>
  99                             <STRUC .TYP .PAT T>
 100                             <STRUC .PAT .TYP <>>>)
 101                        (<TYPE? .PAT FORM SEGMENT> <TEXP1 .PAT .TYP>)
 102                        (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
 103             <AND <EMPTY? .TEM>
 104                  <OR <AND <N==? <SET TEM <VTS .TYP>> .TYP> <DTMATCH .TEM .PAT>>
 105                      <AND <N==? <SET TEM <VTS .PAT>> .PAT>
 106                           <TYPMAT .TYP .TEM>>>>>>
 107
 108 "\f"
 109
 110 <DEFINE TEXP1 (FORT PAT)
 111         #DECL ((FORT) <OR FORM SEGMENT>)
 112         <COND (<EMPTY? .FORT> #FALSE (EMPTY-TYPE-FORM!-ERRORS))
 113               (<MEMQ <1 .FORT> '![OR AND NOT PRIMTYPE!]> <ACTORT .FORT .PAT>)
 114               (<AND <==? <1 .FORT> QUOTE> <2-ELEM .FORT>>
 115                <DTMATCH <GEN-DECL <2 .FORT>> .PAT>)
 116               (ELSE <FORMATCH .FORT .PAT>)>>
 117
 118 <DEFINE ACTORT (FORT PAT "AUX" (ACTOR <1 .FORT>) TEM1)
 119    #DECL ((FORT) <PRIMTYPE LIST>)
 120    <COND
 121     (<==? .ACTOR OR>
 122      <COND
 123       (<EMPTY? <SET FORT <REST .FORT>>>
 124        #FALSE (EMPTY-OR-MATCH!-ERRORS))
 125       (ELSE
 126        <REPEAT (TEM (AL ()))
 127          #DECL ((AL) LIST)
 128          <COND
 129           (<OR <AND <TYPE? <SET TEM <1 .FORT>> ATOM>
 130                     <PROG ()
 131                         <COND (<VALID-TYPE? .TEM>)
 132                               (<SET TEM1 <GET .TEM DECL>>
 133                                <SET TEM .TEM1>
 134                                <AND <TYPE? .TEM ATOM> <AGAIN>>)
 135                               (ELSE T)>>
 136                     <SET TEM <TYPMAT .TEM .PAT>>>
 137                <AND <TYPE? .TEM FORM SEGMENT> <SET TEM <TEXP1 .TEM .PAT>>>>
 138            <COND (<==? .ACTOR OR>
 139                   <COND (.ANDF
 140                          <COND (.TEM
 141                                 <COND (<==? .TEM ANY> <RETURN ANY>)>
 142                                 <COND (.ORF <SET AL <PUT-IN .AL .TEM>>)
 143                                       (ELSE
 144                                        <OR <MEMBER .TEM .AL>
 145                                            <SET AL (.TEM !.AL)>>)>)>)
 146                         (ELSE <RETURN T>)>)>)
 147           (<NOT <EMPTY? .TEM>> <RETURN .TEM>)>
 148          <COND (<EMPTY? <SET FORT <REST .FORT>>>
 149                 <RETURN <AND <NOT <EMPTY? .AL>>
 150                              <COND (<EMPTY? <REST .AL>> <1 .AL>)
 151                                    (ELSE
 152                                     <ORSORT <CHTYPE (.ACTOR !.AL)
 153                                                     FORM>>)>>>)>>)>)
 154     (<==? .ACTOR NOT> <NOT-IT .FORT .PAT>)
 155     (ELSE <PTACT .FORT .PAT>)>>
 156
 157 <DEFINE PTACT (FORTYP PAT)
 158         <COND (<TYPE? .FORTYP FORM SEGMENT>
 159                <COND (<AND <2-ELEM .FORTYP> <==? <1 .FORTYP> PRIMTYPE>>
 160                       <PRIMATCH .FORTYP .PAT>)
 161                      (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 162               (<TYPE? .FORTYP ATOM> <TYPMAT .FORTYP .PAT>)
 163               (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
 164
 165 "\f"
 166
 167 <DEFINE STRUC (WRD TYP ACTAND)
 168         #DECL ((TYP) ATOM)
 169         <PROG ()
 170               <COND (<COND (<==? .WRD STRUCTURED>
 171                             <COND (<==? .TYP LOCATIVE> <>)
 172                                   (<==? .TYP APPLICABLE>
 173                                    <RETURN <COND (.ORF '<OR APPLICABLE STRUCTURED>)
 174                                                  (ELSE
 175                                                   '<OR RSUBR RSUBR-ENTRY FUNCTION CLOSURE MACRO>)>>)
 176                                   (<AND <VALID-TYPE? .TYP>
 177                                         <MEMQ <TYPEPRIM .TYP>
 178                                          '![LIST VECTOR UVECTOR TEMPLATE STRING TUPLE
 179                                             STORAGE BYTES!]>>)>)
 180                            (<==? .WRD LOCATIVE>
 181                             <MEMQ .TYP '![LOCL LOCAS LOCD LOCV LOCU LOCS LOCA!]>)
 182                            (<==? .WRD APPLICABLE>
 183                             <COND (<==? .TYP LOCATIVE> <RETURN <>>)
 184                                   (<==? .TYP STRUCTURED>
 185                                    <RETURN <STRUC .TYP .WRD .ACTAND>>)
 186                                   (<MEMQ .TYP
 187                                          '![RSUBR SUBR FIX FSUBR FUNCTION
 188                                             RSUBR-ENTRY MACRO CLOSURE
 189                                             OFFSET!]>)>)>
 190                      <COND (.ORF .WRD) (ELSE .TYP)>)
 191                     (ELSE
 192                      <COND (<AND .ORF <NOT .ACTAND>> <ORSORT <FORM OR .WRD .TYP>>)
 193                            (ELSE <>)>)>>>
 194
 195 <DEFINE PRIMATCH (PTYP PAT "AUX" PAT1 ACTOR TEM)
 196         #DECL ((PAT1) <PRIMTYPE LIST>
 197                (PTYP) <OR <FORM ANY ANY> <SEGMENT ANY ANY>>)
 198         <COND (<AND <TYPE? .PAT FORM SEGMENT>
 199                     <SET PAT1 .PAT>
 200                     <==? <LENGTH .PAT1> 2>
 201                     <==? <1 .PAT1> PRIMTYPE>>
 202                <COND (<==? <2 .PAT1> <2 .PTYP>> .PAT1)
 203                      (ELSE <COND (.ORF <ORSORT <FORM OR .PAT1 .PTYP>>)>)>)
 204               (<TYPE? .PAT ATOM>
 205                <COND (<==? .PAT ANY> <COND (.ORF ANY) (.ANDF .PTYP) (ELSE T)>)
 206                      (<MEMQ .PAT '![STRUCTURED LOCATIVE APPLICABLE!]>
 207                       <COND (<STRUC .PAT <2 .PTYP> T>
 208                              <COND (.ORF .PAT) (ELSE .PTYP)>)
 209                             (ELSE <COND (.ORF <ORSORT <FORM OR .PAT .PTYP>>)>)>)
 210                      (<AND <VALID-TYPE? .PAT>
 211                            <==? <TYPEPRIM .PAT> <2 .PTYP>>
 212                            <COND (.ORF .PTYP) (ELSE .PAT)>>)
 213                      (ELSE <COND (.ORF <ORSORT <FORM OR .PTYP .PAT>>)>)>)
 214               (<AND <TYPE? .PAT FORM SEGMENT>
 215                     <SET PAT1 .PAT>
 216                     <NOT <EMPTY? .PAT1>>>
 217                <COND (<==? <SET ACTOR <1 .PAT1>> OR> <ACTORT .PAT .PTYP>)
 218                      (<==? .ACTOR NOT>
 219                       <COND (.ORF <NOT-IT .PAT .PTYP>)
 220                             (ELSE
 221                              <SET TEM <PRIMATCH .PTYP <2 .PAT1>>>
 222                              <COND (<AND <NOT .TEM> <EMPTY? .TEM>> .PTYP)
 223                                    (<NOT .TEM> .TEM)
 224                                    (<N=? .TEM .PTYP> ANY)>)>)
 225                      (<SET TEM <PRIMATCH .PTYP <1 .PAT1>>>
 226                       <COND (.ORF .TEM)
 227                             (.ANDF <COND (<TYPE? .PAT FORM>
 228                                           <FORM .TEM !<REST .PAT1>>)
 229                                          (ELSE
 230                                           <CHTYPE (.TEM !<REST .PAT1>) SEGMENT>)>)
 231                             (ELSE T)>)>)>>
 232
 233 "\f"
 234
 235 <DEFINE NOT-IT (NF PAT "AUX" T1)
 236         #DECL ((NF) <OR FORM SEGMENT>)
 237         <COND (<AND <TYPE? .PAT FORM SEGMENT>
 238                     <NOT <EMPTY? .PAT>>
 239                     <OR <==? <1 .PAT> OR> <==? <1 .PAT> AND>>>
 240                <ACTORT .PAT .NF>)
 241               (ELSE
 242                <COND (<==? <LENGTH .NF> 2>
 243                       <COND (<NOT <SET T1 <TYPE-AND <2 .NF> .PAT>>>
 244                              <COND (.ORF .NF) (.ANDF .PAT) (ELSE T)>)
 245                             (<==? <2 .NF> ANY> <COND (.ORF .PAT)>)
 246                             (<AND <N==? .T1 .PAT>
 247                                   <N=? .T1 .PAT>
 248                                   <N=? <CANONICAL-DECL .PAT>
 249                                        <CANONICAL-DECL .T1>>>
 250                              <COND (<OR .ANDF .ORF> ANY) (ELSE T)>)
 251                             (.ORF ANY)>)
 252                      (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
 253
 254 <DEFINE NOTIFY (D)
 255         <COND (<AND <TYPE? .D FORM SEGMENT>
 256                     <==? <LENGTH .D> 2>
 257                     <==? <1 .D> NOT>>
 258                <2 .D>)
 259               (ELSE <FORM NOT .D>)>>
 260 "\f"
 261
 262 <DEFINE FORMATCH (FRM RPAT "AUX" TEM (PAT .RPAT) EX)
 263    #DECL ((FRM) <OR <FORM ANY> <SEGMENT ANY>>
 264           (RPAT) <OR ATOM FORM LIST SEGMENT VECTOR FIX>)
 265    <COND
 266     (<AND <TYPE? .RPAT ATOM> <TYPE? <1 .FRM> ATOM> <==? <1 .FRM> .RPAT>>
 267      <COND (.ORF .RPAT) (ELSE .FRM)>)
 268     (ELSE
 269      <COND (<TYPE? .RPAT ATOM> <SET PAT <SET EX <GET .RPAT DECL '.RPAT>>>)
 270            (ELSE <SET RPAT <1 .PAT>>)>
 271      <COND
 272       (<TYPE? .PAT ATOM>
 273        <SET TEM
 274             <COND (<AND .ORF <NOT <CTMATCH .PAT <1 .FRM> <> <> T>>>
 275                    <ORSORT <FORM OR .RPAT .FRM>>)
 276                   (ELSE
 277                    <COND (<TYPE? <1 .FRM> ATOM> <TYPMAT <1 .FRM> .PAT>)
 278                          (<TYPE? <1 .FRM> FORM> <ACTORT <1 .FRM> .PAT>)>)>>
 279        <COND (<AND .ANDF <NOT .ORF> .TEM>
 280               <COND (<TYPE? .FRM FORM> <CHTYPE (.TEM !<REST .FRM>) FORM>)
 281                     (ELSE <CHTYPE (.TEM !<REST .FRM>) SEGMENT>)>)
 282              (ELSE .TEM)>)
 283       (<TYPE? .PAT FORM SEGMENT>
 284        <COND (<MEMQ <1 .PAT> '![OR AND NOT PRIMTYPE!]> <ACTORT .PAT .FRM>)
 285              (ELSE
 286               <COND (<AND <==? <LENGTH .PAT> 2> <TYPE? <2 .PAT> LIST>>
 287                      <WRDFX .PAT .FRM .RPAT>)
 288                     (<AND <G=? <LENGTH .PAT> 2> <TYPE? <2 .PAT> FIX>>
 289                      <BYTES-HACK .PAT .FRM .RPAT>)
 290                     (<AND <G=? <LENGTH .FRM> 2> <TYPE? <2 .FRM> FIX>>
 291                      <BYTES-HACK .FRM .PAT <1 .FRM>>)
 292                     (<AND .ORF
 293                           <ASSIGNED? EX>
 294                           <NOT <CTMATCH .RPAT .FRM <> <> T>>>
 295                      <ORSORT <FORM OR .RPAT .FRM>>)
 296                     (<AND .ORF <NOT <CTMATCH .PAT .FRM <> <> T>>>
 297                      <ORSORT <FORM OR .PAT .FRM>>)
 298                     (ELSE
 299                      <SET TEM <ELETYPE .PAT .FRM .RPAT>>
 300                      <AND <ASSIGNED? EX>
 301                           <TYPE? .TEM FORM SEGMENT>
 302                           <G? <LENGTH .TEM> 1>
 303                           <==? <1 .TEM> OR>
 304                           <MAPR <>
 305                                 <FUNCTION (EL)
 306                                         <AND <=? <1 .EL> .EX>
 307                                              <PUT .EL 1 .RPAT>
 308                                              <MAPLEAVE>>>
 309                                 <REST .TEM>>>
 310                      .TEM)>)>)>)>>
 311
 312 "\f"
 313
 314 <DEFINE BYTES-HACK (F1 F2 RPAT "AUX" FST TL TEM SEGF MLF1 MLF2)
 315    #DECL ((F1 F2) <OR FORM SEGMENT> (MLF1 MLF2) FIX)
 316    <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
 317    <COND (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
 318    <SET FST
 319         <COND (<TYPE? .RPAT ATOM>
 320                <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
 321                      (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
 322                      (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 323               (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
 324               (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
 325    <COND
 326     (<NOT .FST> .FST)
 327     (ELSE
 328      <COND
 329       (<CTMATCH .RPAT '<PRIMTYPE BYTES> <> <> <>>
 330        <SET MLF1 <MINL .F1>>
 331        <SET MLF2 <MINL .F2>>
 332        <COND (<AND <G=? <LENGTH .F2> 2> <TYPE? <2 .F2> FIX>>
 333               <COND (<CTMATCH <1 .F2> '<PRIMTYPE BYTES> <> <> <>>
 334                      <COND (.ORF
 335                             <COND (<==? <2 .F2> <2 .F1>>
 336                                    <FOSE .SEGF .FST <2 .F1> <MIN .MLF1 .MLF2>>)
 337                                   (ELSE <ORSORT <FORM OR .F1 .F2>>)>)
 338                            (<AND <==? <2 .F2> <2 .F1>>
 339                                  <NOT <AND <TYPE? .F1 SEGMENT>
 340                                            <TYPE? .F2 SEGMENT>
 341                                            <N==? <2 .F1> <2 .F2>>>>>
 342                             <FOSE .SEGF .FST <2 .F1> <MAX .MLF1 .MLF2>>)>)
 343                     (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 344              (<TMATCH .F2 '<PRIMTYPE BYTES>>
 345               <COND (.ORF
 346                      <COND (<TMATCH .F2
 347                                     <SET TEM
 348                                          <COND (<0? .MLF1>
 349                                                 <FOSE .SEGF
 350                                                       <1 .F1>
 351                                                       '[REST FIX]>)
 352                                                (ELSE
 353                                                 <FOSE .SEGF
 354                                                       <1 .F1>
 355                                                       [.MLF1 FIX]
 356                                                       '[REST FIX]>)>>>
 357                             <TYPE-MERGE .TEM .F2>)
 358                            (ELSE <ORSORT <FORM .F1 .F2>>)>)
 359                     (<TMATCH .F2
 360                              <COND (<0? .MLF1>
 361                                     <FOSE .SEGF STRUCTURED '[REST FIX]>)
 362                                    (ELSE
 363                                     <FOSE .SEGF
 364                                           STRUCTURED
 365                                           [.MLF1 FIX]
 366                                           '[REST FIX]>)>>
 367                      <FOSE .SEGF .FST <2 .F1> <MAX .MLF2 .MLF1>>)>)
 368              (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
 369       (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
 370
 371 <DEFINE FOSE ("TUPLE" TUP "AUX" (FLG <1 .TUP>))
 372         <COND (.FLG <CHTYPE (!<REST .TUP>) SEGMENT>)
 373               (ELSE <CHTYPE (!<REST .TUP>) FORM>)>>
 374
 375 <DEFINE SEGANDOR (F1 F2 ORF)
 376         <COND (.ORF <AND <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)
 377               (ELSE <OR <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)>>
 378
 379 <DEFINE WRDFX (F1 F2 RPAT "AUX" FST TL)
 380    #DECL ((F1 F2) <OR FORM SEGMENT>)
 381    <COND (<OR <EMPTY? <SET F1 <CHTYPE .F1 FORM>>>
 382               <EMPTY? <SET F2 <CHTYPE .F2 FORM>>>>
 383           #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
 384    <SET FST
 385         <COND (<TYPE? .RPAT ATOM>
 386                <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
 387                      (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
 388                      (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 389               (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
 390               (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
 391    <COND
 392     (<NOT .FST> .FST)
 393     (ELSE
 394      <COND (<CTMATCH .RPAT ,ALLWORDS <> <> <>>
 395             <COND (<AND <LENGTH? .F2 2> <TYPE? <2 .F2> LIST>>
 396                    <COND (<CTMATCH <1 .F2> ,ALLWORDS <> <><>>
 397                           <COND (.ORF
 398                                  <SET TL <MAP-MERGE !<2 .F1> !<2 .F2>>>
 399                                  <COND (<EMPTY? .TL> .FST)
 400                                        (ELSE <FORM .FST .TL>)>)
 401                                 (<SET TL <AND-MERGE <2 .F1> <2 .F2>>>
 402                                  <FORM .FST .TL>)>)
 403                          (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 404                   (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
 405            (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
 406
 407 <DEFINE MAP-MERGE ("TUPLE" PAIRS "AUX" (HIGH <2 .PAIRS>) (LOW <1 .PAIRS>))
 408         #DECL ((PAIRS) <TUPLE [REST FIX]> (HIGH LOW) FIX)
 409         <REPEAT ()
 410                 <COND (<EMPTY? <SET PAIRS <REST .PAIRS 2>>> <RETURN>)>
 411                 <SET HIGH <MAX .HIGH <2 .PAIRS>>>
 412                 <SET LOW <MIN .LOW <1 .PAIRS>>>>
 413         <COND (<AND <==? .HIGH <CHTYPE <MIN> FIX>>
 414                     <==? .LOW <CHTYPE <MAX> FIX>>>
 415                ())
 416               (ELSE (.LOW .HIGH))>>
 417
 418
 419 <DEFINE AND-MERGE (L1 L2 "AUX" (FLG <>) HIGH LOW TEM (L (0)) (LL .L))
 420         #DECL ((L LL L1 L2) <LIST [REST FIX]> (HIGH LOW) FIX)
 421         <COND (<G? <LENGTH .L1> <LENGTH .L2>>
 422                <SET TEM .L1>
 423                <SET L1 .L2>
 424                <SET L2 .TEM>)>
 425         <REPEAT ()
 426                 <SET LOW <1 .L2>>
 427                 <SET HIGH <2 .L2>>
 428                 <REPEAT ((L1 .L1) LO HI)
 429                         #DECL ((L1) <LIST [REST FIX]> (LO HI) FIX)
 430                         <COND (<EMPTY? .L1> <RETURN>)>
 431                         <SET HI <2 .L1>>
 432                         <COND (<OR <AND <G=? <SET LO <1 .L1>> .LOW>
 433                                         <L=? .LO .HIGH>>
 434                                    <AND <L=? .HI .HIGH> <G=? .HI .LOW>>
 435                                    <AND <G=? .LOW .LO> <L=? .LOW .HI>>
 436                                    <AND <L=? .HIGH .HI> <G=? .HIGH .LO>>>
 437                                <SET LOW <MAX .LOW .LO>>
 438                                <SET HIGH <MIN .HIGH .HI>>
 439                                <SET L <REST <PUTREST .L (.LOW .HIGH)> 2>>
 440                                <SET FLG T>
 441                                <RETURN>)>
 442                         <SET L1 <REST .L1 2>>>
 443                 <COND (<EMPTY? <SET L2 <REST .L2 2>>>
 444                        <RETURN <COND (.FLG <REST .LL>) (ELSE <>)>>)>>>
 445
 446 "\f"
 447
 448 <DEFINE GET-RANGE (L1 "AUX" TT)
 449         <COND (<AND <TYPE? .L1 FORM>
 450                     <TMATCH .L1 ,ALLWORDS>
 451                     <TYPE? <2 .L1> LIST>>
 452                <COND (<NOT <EMPTY? <SET TT <MAP-MERGE !<2 .L1>>>>> .TT)>)>>
 453
 454 "\f"
 455
 456 <DEFINE ELETYPE (F1 F2 RTYP
 457                  "AUX" (S1 <VECTOR .F1 <> 0 <> <> '[]>) (FAIL <>) (INOPT <>)
 458                        (S2 <VECTOR .F2 <> 0 <> <> '[]>) (FL ()) (FP '<>) FSTL
 459                        SEGF RTEM)
 460    #DECL ((S1 S2) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY>
 461           (F1 F2) <PRIMTYPE LIST> (FP) <OR FORM SEGMENT> (FL) LIST)
 462    <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
 463    <COND
 464     (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))
 465     (<AND .ANDF .ORF <NOT <TMATCH <1 .F2> .RTYP>>> <ORSORT <FORM OR .F1 .F2>>)
 466     (ELSE
 467      <COND
 468       (<SET FSTL
 469             <COND (<TYPE? .RTYP ATOM>
 470                    <COND (<TYPE? <1 .F2> ATOM> <TYPMAT .RTYP <1 .F2>>)
 471                          (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RTYP>)
 472                          (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
 473                   (<TYPE? .RTYP FORM> <ACTORT .RTYP <1 .F2>>)
 474                   (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
 475        <COND (.ANDF
 476               <SET FL
 477                    <CHTYPE <SET FP
 478                                 <COND (.SEGF <CHTYPE (.FSTL) SEGMENT>)
 479                                       (ELSE <FORM .FSTL>)>>
 480                            LIST>>)>
 481        <PUT .S1 ,DECL-RESTED <REST .F1>>
 482        <PUT .S2 ,DECL-RESTED <REST .F2>>
 483        <REPEAT ((TEM1 <>) (TEM2 <>) T1 T2 TEM TT)
 484          #DECL ((TT) <VECTOR FIX ANY>)
 485          <SET T1 <SET T2 <>>>
 486          <COND
 487           (<AND <OR <AND <SET TEM1 <NEXTP .S1>> <SET T1 <DECL-ELEMENT .S1>>>
 488                     <AND <EMPTY? .TEM1> <SET T1 ANY>>>
 489                 <OR <AND <SET TEM2 <NEXTP .S2>> <SET T2 <DECL-ELEMENT .S2>>>
 490                     <AND .TEM1 <EMPTY? .TEM2> <SET T2 ANY>>>>
 491            <COND (<AND .ORF <OR <NOT .TEM1> <NOT .TEM2>>>
 492                   <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)>
 493            <OR <SET RTEM
 494                     <SET TEM
 495                          <COND (<NOT .TEM1>
 496                                 <COND (<OR <TYPE? .F1 FORM> <DECL-IN-REST .S2>>
 497                                        .T2)
 498                                       (ELSE <SET FAIL T> <>)>)
 499                                (<NOT .TEM2>
 500                                 <COND (<OR <TYPE? .F2 FORM> <DECL-IN-REST .S1>>
 501                                        .T1)
 502                                       (ELSE <SET FAIL T> <>)>)
 503                                (ELSE <DTMATCH .T1 .T2>)>>>
 504                <COND (.ORF <SET TEM <ORSORT <FORM OR .T1 .T2>>>)
 505                      (.MAYBEF <COND (.FAIL <RETURN <>>) (ELSE <SET FAIL T>)>)
 506                      (ELSE <RETURN <>>)>>
 507            <COND (<AND <NOT .INOPT>
 508                        <OR <AND .ORF
 509                                 <OR <DECL-IN-COUNT-VEC .S1>
 510                                     <DECL-IN-COUNT-VEC .S2>>>
 511                            <AND .ANDF
 512                                 <NOT .ORF>
 513                                 <DECL-IN-COUNT-VEC .S1>
 514                                 <DECL-IN-COUNT-VEC .S2>>>>
 515                   <SET INOPT <COND (.ANDF (OPTIONAL .TEM)) (ELSE ())>>)
 516                  (<AND .INOPT .ANDF>
 517                   <PUTREST <REST .INOPT <- <LENGTH .INOPT> 1>> (.TEM)>)>
 518            <COND (<AND .INOPT
 519                        <OR <AND .ORF
 520                                 <OR <0? <DECL-ITEM-COUNT .S1>>
 521                                     <0? <DECL-ITEM-COUNT .S2>>>>
 522                            <AND .ANDF
 523                                 <0? <DECL-ITEM-COUNT .S1>>
 524                                 <0? <DECL-ITEM-COUNT .S2>>>>>
 525                   <AND .ANDF <SET TEM [!.INOPT]>>
 526                   <SET INOPT <>>)>
 527            <COND
 528             (<OR <AND .ORF
 529                       <OR <AND <DECL-IN-REST .S1> <EMPTY? <DECL-RESTED .S2>>>
 530                           <AND <DECL-IN-REST .S2> <EMPTY? <DECL-RESTED .S1>>>>>
 531                  <AND <OR <DECL-IN-REST .S1>
 532                           <AND .ANDF <OR <NOT .TEM1> <DECL-IN-COUNT-VEC .S1>>>>
 533                       <OR <DECL-IN-REST .S2>
 534                           <AND .ANDF
 535                                <OR <NOT .TEM2> <DECL-IN-COUNT-VEC .S2>>>>>>
 536              <COND
 537               (<OR .ORF .ANDF>
 538                <COND (<N==? 0
 539                             <SET T1
 540                                  <RESTER? .S1
 541                                           .S2
 542                                           .FL
 543                                           .RTEM
 544                                           <TYPE? .F2 SEGMENT>>>>
 545                       <COND (<==? .T1 T>
 546                              <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
 547                                            (ELSE .FP)>>)
 548                             (ELSE
 549                              <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
 550                                                  <LENGTH? .FP 1>>
 551                                             <1 .T1>)
 552                                            (ELSE .T1)>>)>)
 553                      (<N==? 0
 554                             <SET T1
 555                                  <RESTER? .S2
 556                                           .S1
 557                                           .FL
 558                                           .RTEM
 559                                           <TYPE? .F1 SEGMENT>>>>
 560                       <COND (<==? .T1 T>
 561                              <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
 562                                            (ELSE .FP)>>)
 563                             (ELSE
 564                              <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
 565                                                  <LENGTH? .FP 1>>
 566                                             <1 .T1>)
 567                                            (ELSE .T1)>>)>)>)
 568               (ELSE <RETURN T>)>)
 569             (<AND <NOT .ANDF>
 570                   <OR <DECL-IN-REST .S1> <NOT .TEM1>>
 571                   <OR <DECL-IN-REST .S2> <NOT .TEM2>>>
 572              <RETURN T>)>
 573            <COND (<AND <NOT .INOPT>
 574                        .ANDF
 575                        <OR <NOT .ORF>
 576                            <NOT <OR <DECL-IN-REST .S1> <DECL-IN-REST .S2>>>>>
 577                   <COND (<AND <TYPE? <1 .FL> VECTOR>
 578                               <=? <2 <SET TT <1 .FL>>> .TEM>>
 579                          <PUT .TT 1 <+ <1 .TT> 1>>)
 580                         (<AND <N==? <CHTYPE .FP LIST> .FL> <=? .TEM <1 .FL>>>
 581                          <PUT .FL 1 [2 .TEM]>)
 582                         (ELSE <SET FL <REST <PUTREST .FL (.TEM)>>>)>)>)
 583           (ELSE
 584            <COND (<AND <EMPTY? .TEM1> <EMPTY? <SET TEM1 .TEM2>>>
 585                   <COND (.ANDF
 586                          <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)
 587                         (ELSE <RETURN T>)>)
 588                  (ELSE <RETURN .TEM1>)>)>>)>)>>
 589
 590 "\f"
 591
 592 <DEFINE RESTER? (S1 S2 FL FST SEGF
 593                  "AUX" (TT <DECL-REST-VEC .S1>) (TEM1 T) (TEM2 T) (OPTIT <>))
 594    #DECL ((S1 S2) <VECTOR ANY ANY ANY ANY ANY VECTOR> (FL) <LIST ANY>
 595           (TT) VECTOR)
 596    <COND (<AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
 597                 <EMPTY? <DECL-RESTED .S2>> <NOT <DECL-IN-REST .S2>>>
 598           <SET OPTIT T>)>
 599    <COND
 600     (<AND .SEGF <NOT .ORF> <OR <NOT <DECL-IN-REST .S1>>
 601                                <NOT <DECL-IN-REST .S2>>>> T)
 602     (<AND <NOT <EMPTY? .TT>>
 603           <OR <NOT <DECL-IN-REST .S2>> <G=? <LENGTH .TT>
 604               <LENGTH <REST <TOP <DECL-REST-VEC .S2>>>>>>>
 605      <SET TT <REST <TOP .TT>>>
 606      <MAPR <>
 607            <FUNCTION (SO "AUX" T1)
 608                    #DECL ((SO) <VECTOR ANY>)
 609                    <SET T1
 610                         <OR <AND <SET TEM1 <NEXTP .S2>> <DECL-ELEMENT .S2>>
 611                             <AND <EMPTY? .TEM1>
 612                                  <COND (.ORF <MAPLEAVE>) (ELSE ANY)>>>>
 613                    <AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
 614                         <EMPTY? <DECL-RESTED .S2>>
 615                         <NOT <DECL-IN-REST .S2>>
 616                         <SET OPTIT T>>
 617                    <COND (<NOT .TEM1> <AND <EMPTY? .TEM1> <SET TEM1 T>>)>
 618                    <COND (.T1
 619                           <PUT .SO
 620                                1
 621                                <SET TEM2
 622                                     <DTMATCH <AND <NEXTP .S1>
 623                                                   <DECL-ELEMENT .S1>> .T1>>>)>
 624                    <AND <OR <NOT .T1> <NOT .TEM2>> <MAPLEAVE>>>
 625            <REST <SET TT [REST .FST !<REST .TT>]> 2>>
 626      <COND (.OPTIT <PUT .TT 1 OPTIONAL>)
 627            (ELSE <SET TT <UNIQUE-VECTOR-CHECK .TT>>)>
 628      <COND (<AND .TEM1 .TEM2> <PUTREST .FL (.TT)> T)
 629            (<AND <NOT .TEM1> <NOT <EMPTY? .TEM1>>> .TEM1)
 630            (ELSE .TEM2)>)
 631     (ELSE 0)>>
 632
 633 <DEFINE UNIQUE-VECTOR-CHECK (V "AUX" (FRST <2 .V>))
 634         #DECL ((V) <VECTOR [2 ANY]>)
 635         <COND (<MAPF <>
 636                      <FUNCTION (X) <COND (<N=? .X .FRST> <MAPLEAVE .V>)>>
 637                      <REST .V 2>>)
 638               (ELSE [REST .FRST])>>
 639
 640
 641 <DEFINE NEXTP (S "AUX" TEM TT N)
 642         #DECL ((S) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY> (N) FIX
 643                (TT) VECTOR)
 644         <COND (<0? <DECL-ITEM-COUNT .S>> <PUT .S ,DECL-IN-COUNT-VEC <>>)>
 645         <COND (<DECL-IN-REST .S> <NTHREST .S>)
 646               (<NOT <0? <DECL-ITEM-COUNT .S>>>
 647                <PUT .S ,DECL-ITEM-COUNT <- <DECL-ITEM-COUNT .S> 1>>
 648                <NTHREST .S>)
 649               (<EMPTY? <SET TEM <DECL-RESTED .S>>> <>)
 650               (<TYPE? <1 .TEM> ATOM FORM SEGMENT>
 651                <SET TEM <1 .TEM>>
 652                <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
 653                <PUT .S ,DECL-ELEMENT .TEM>)
 654               (<TYPE? <1 .TEM> VECTOR>
 655                <SET TT <1 .TEM>>
 656                <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
 657                <PUT .S ,DECL-REST-VEC <REST .TT>>
 658                <COND (<G? <LENGTH .TT> 1>
 659                       <COND (<==? <1 .TT> REST>
 660                              <COND (<AND <==? <LENGTH .TT> 2>
 661                                          <==? <2 .TT> ANY>>
 662                                     <>)
 663                                    (ELSE
 664                                     <PUT .S ,DECL-IN-REST T>
 665                                     <PUT .S
 666                                          ,DECL-ELEMENT
 667                                          <DECL-ELEMENT .TT>>)>)
 668                             (<OR <AND <TYPE? <1 .TT> FIX> <SET N <1 .TT>>>
 669                                  <AND <MEMQ <1 .TT> '![OPT OPTIONAL!]>
 670                                       <SET N 1>>>
 671                              <OR <TYPE? <1 .TT> FIX>
 672                                  <PUT .S ,DECL-IN-COUNT-VEC T>>
 673                              <PUT .S
 674                                   ,DECL-ITEM-COUNT
 675                                   <- <* .N <- <LENGTH .TT> 1>> 1>>
 676                              <PUT .S ,DECL-ELEMENT <2 .TT>>
 677                              <COND (<L=? .N 0> <>) (ELSE .S)>)
 678                             (#FALSE (BAD-VECTOR-SYNTAX!-ERRORS))>)
 679                      (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>)
 680               (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>>
 681
 682 "\f"
 683
 684 <DEFINE NTHREST (S "AUX" (TEM <REST <DECL-REST-VEC .S>>))
 685         #DECL ((S) <VECTOR ANY ANY ANY ANY ANY VECTOR> (TEM) VECTOR)
 686         <COND (<EMPTY? .TEM> <SET TEM <REST <TOP .TEM>>>)>
 687         <PUT .S ,DECL-REST-VEC .TEM>
 688         <PUT .S ,DECL-ELEMENT <1 .TEM>>>
 689 "\f"
 690
 691 <DEFINE GET-ELE-TYPE (DCL2 NN
 692                       "OPTIONAL" (RST <>) (PT <>)
 693                       "AUX" (LN 0) (CNT 0) ITYP DC SDC DCL (N 0) DC1 (QOK <>)
 694                             (FMOK <>) STRU (GD '<>) (GP ()) (K 0) (DCL1 .DCL2)
 695                             (SEGF <>) TEM)
 696    #DECL ((LN CNT K N) FIX (DCL) <PRIMTYPE LIST> (SDC DC) VECTOR
 697           (GD) <OR FORM SEGMENT> (GP) LIST)
 698    <PROG ()
 699      <COND (<AND .PT <SET TEM <ISTYPE? .DCL1>>>
 700             <SET PT <TYPE-AND <GET-ELE-TYPE .TEM .NN> .PT>>)>
 701      <AND <TYPE? .DCL1 ATOM> <SET DCL1 <GET .DCL1 DECL '.DCL1>>>
 702      <COND (<TYPE? .DCL1 SEGMENT> <SET SEGF T>)>
 703      <COND (<==? <STRUCTYP .DCL2> BYTES>
 704             <RETURN <GET-ELE-BYTE .DCL2 .NN .RST .PT>>)>
 705      <COND (.RST <SET STRU <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>>)
 706            (.PT
 707             <SET STRU
 708                  <COND (<ISTYPE? .DCL2>)
 709                        (<SET STRU <STRUCTYP .DCL1>> <FORM PRIMTYPE .STRU>)
 710                        (ELSE STRUCTURED)>>)>
 711      <COND
 712       (<AND <TYPE? .DCL1 FORM SEGMENT>
 713             <SET DCL .DCL1>
 714             <G? <SET LN <LENGTH .DCL>> 1>
 715             <NOT <SET FMOK <MEMQ <1 .DCL> '![OR AND NOT!]>>>
 716             <NOT <SET QOK <==? <1 .DCL> QUOTE>>>
 717             <NOT <==? <1 .DCL> PRIMTYPE>>>
 718        <COND
 719         (<==? .NN ALL>
 720          <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
 721          <OR
 722           <AND <TYPE? <SET DC1 <2 .DCL>> VECTOR>
 723                <SET DC .DC1>
 724                <G=? <LENGTH .DC> 2>
 725                <==? <1 .DC> REST>
 726                <COND (<==? <LENGTH .DC> 2>
 727                       <COND (.RST <FORM .STRU [REST <2 .DC>]>)
 728                             (.PT <FORM .STRU [REST <TYPE-MERGE <2 .DC> .PT>]>)
 729                             (ELSE <2 .DC>)>)
 730                      (.RST <FORM .STRU [REST <TYPE-MERGE !<REST .DC>>]>)
 731                      (.PT
 732                       <FORM .STRU
 733                             [REST
 734                              <MAPF ,TYPE-MERGE
 735                                    <FUNCTION (D) <TYPE-MERGE .D .PT>>
 736                                    <REST .DC>>]>)
 737                      (ELSE <TYPE-MERGE !<REST .DC>>)>>
 738           <REPEAT (TT (CK <DCX <SET TT <2 .DCL>>>) (D .DCL) TEM)
 739                   #DECL ((D) <PRIMTYPE LIST>)
 740                   <COND (<EMPTY? <SET D <REST .D>>>
 741                          <SET TEM
 742                               <OR .SEGF
 743                                   <AND <TYPE? .TT VECTOR> <==? <1 .TT> REST>>>>
 744                          <RETURN <COND (.TEM
 745                                         <COND (.RST <FORM .STRU [REST .CK]>)
 746                                               (.PT .GD)
 747                                               (ELSE .CK)>)
 748                                        (.PT .GD)
 749                                        (.RST .STRU)
 750                                        (ELSE ANY)>>)>
 751                   <SET CK <TYPE-MERGE .CK <DCX <SET TT <1 .D>>>>>
 752                   <AND .PT
 753                        <SET GP
 754                             <REST
 755                              <PUTREST .GP
 756                                       (<COND (<TYPE? .TT VECTOR>
 757                                               [<1 .TT>
 758                                                !<MAPF ,LIST
 759                                                  <FUNCTION (X)
 760                                                          <TYPE-MERGE .X .PT>>
 761                                                  <REST .TT>>])
 762                                              (ELSE
 763                                               <TYPE-MERGE .PT .TT>)>)>>>>>>)
 764         (ELSE
 765          <SET N .NN>
 766          <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
 767          <AND .RST <SET N <+ .N 1>>>
 768          <COND (<EMPTY? <SET DCL <REST .DCL>>>
 769                 <RETURN <COND (.RST .STRU)
 770                               (.PT <FOSE .SEGF .STRU !<ANY-PAT <- .N 1>> .PT>)
 771                               (ELSE ANY)>>)>
 772          <REPEAT ()
 773            <COND
 774             (<NOT <0? .CNT>>
 775              <COND
 776               (<EMPTY? <SET SDC <REST .SDC>>>
 777                <SET SDC <REST .DC>>
 778                <AND
 779                 <0? <SET CNT <- .CNT 1>>>
 780                 <COND (<EMPTY? <SET DCL <REST .DCL>>>
 781                        <RETURN <COND (.RST .STRU)
 782                                      (.PT
 783                                       <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
 784                                       .GD)
 785                                      (ELSE ANY)>>)
 786                       (ELSE <AGAIN>)>>)>
 787              <SET ITYP <1 .SDC>>)
 788             (<TYPE? <1 .DCL> ATOM FORM SEGMENT>
 789              <SET ITYP <1 .DCL>>
 790              <SET DCL <REST .DCL>>)
 791             (<TYPE? <SET DC1 <1 .DCL>> VECTOR>
 792              <SET DC .DC1>
 793              <COND
 794               (<==? <1 .DC> REST>
 795                <AND <OR <AND .RST <NOT <1? .N>>> .PT>
 796                     <==? 2 <LENGTH .DC>>
 797                     <=? <2 .DC> '<NOT ANY>>
 798                     <RETURN <>>>
 799                <SET K <MOD <- .N 1> <- <LENGTH .DC> 1>>>
 800                <SET N </ <- .N 1> <- <LENGTH .DC> 1>>>
 801                <RETURN
 802                 <COND
 803                  (.RST
 804                   <FOSE .SEGF
 805                         .STRU
 806                         <COND (<0? .K> .DC)
 807                               (ELSE [REST <TYPE-MERGE !<REST .DC>>])>>)
 808                  (.PT
 809                   <PUTREST
 810                    .GP
 811                    (!<COND (<L=? .N 0> ())
 812                            (<1? .N> (!<REST .DC>))
 813                            (ELSE ([.N !<REST .DC>]))>
 814                     !<MAPF ,LIST
 815                            <FUNCTION (O)
 816                                    <COND (<==? <SET K <- .K 1>> -1> .PT)
 817                                          (ELSE .O)>>
 818                            <REST .DC>>
 819                     .DC)>
 820                   .GD)
 821                  (ELSE <NTH .DC <+ .K 2>>)>>)
 822               (<OR <TYPE? <1 .DC> FIX> <==? <1 .DC> OPT> <==? <1 .DC> OPTIONAL>>
 823                <SET CNT <COND (<TYPE? <1 .DC> FIX> <1 .DC>) (ELSE 1)>>
 824                <SET SDC .DC>
 825                <AGAIN>)>)>
 826            <AND
 827             <0? <SET N <- .N 1>>>
 828             <RETURN
 829              <COND
 830               (.RST
 831                <COND (<AND <EMPTY? .DCL> <0? .CNT>> .STRU)
 832                      (<FOSE .SEGF
 833                             .STRU
 834                             !<COND (<0? .CNT> (.ITYP !.DCL))
 835                                    (<N==? .SDC <REST .DC>>
 836                                     <COND (<0? <SET CNT <- .CNT 1>>>
 837                                            (!.SDC !<REST .DCL>))
 838                                           (ELSE
 839                                            (!.SDC
 840                                             [.CNT !<REST .DC>]
 841                                             !<REST .DCL>))>)
 842                                    (ELSE ([.CNT !.SDC] !<REST .DCL>))>>)>)
 843               (.PT
 844                <SET GP <REST <PUTREST .GP (.PT)>>>
 845                <AND <ASSIGNED? SDC> <SET SDC <REST .SDC>>>
 846                <COND (<AND <EMPTY? .DCL> <0? .CNT>> .GD)
 847                      (<PUTREST .GP
 848                                <COND (<OR <0? .CNT>
 849                                           <AND <1? .CNT> <==? .SDC <REST .DC>>>>
 850                                       .DCL)
 851                                      (<==? .SDC <REST .DC>>
 852                                       ([.CNT !<REST .DC>] !<REST .DCL>))
 853                                      (<L=? <SET CNT <- .CNT 1>> 0>
 854                                       (!.SDC !<REST .DCL>))
 855                                      (ELSE
 856                                       (!.SDC
 857                                        [.CNT !<REST .DC>]
 858                                        !<REST .DCL>))>>
 859                       .GD)>)
 860               (ELSE .ITYP)>>>
 861            <AND <OR .PT .RST> <=? .ITYP '<NOT ANY>> <RETURN <>>>
 862            <AND .PT <SET GP <REST <PUTREST .GP (.ITYP)>>>>
 863            <COND (<EMPTY? .DCL>
 864                   <RETURN <COND (.RST .STRU)
 865                                 (.PT
 866                                  <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
 867                                  .GD)
 868                                 (ELSE ANY)>>)>>)>)
 869       (.QOK <SET DCL1 <GEN-DECL <2 .DCL>>> <AGAIN>)
 870       (<AND .FMOK <==? <1 .FMOK> OR>>
 871        <MAPF ,TYPE-MERGE
 872              <FUNCTION (D "AUX" IT)
 873                      <COND (<SET IT <GET-ELE-TYPE .D .NN .RST .PT>>
 874                             <AND <==? .IT ANY> <MAPLEAVE ANY>>
 875                             .IT)
 876                            (ELSE <MAPRET>)>>
 877              <REST .DCL>>)
 878       (<AND .FMOK <==? <1 .FMOK> AND>>
 879        <SET ITYP ANY>
 880        <MAPF <>
 881              <FUNCTION (D)
 882                      <SET ITYP <TYPE-OK? .ITYP <GET-ELE-TYPE .D .NN .RST>>>>
 883              <REST .DCL>>
 884        .ITYP)
 885       (.RST <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>)
 886       (.PT
 887        <COND (<==? .NN ALL> .DCL1)
 888              (ELSE <FOSE .SEGF .DCL1 !<ANY-PAT <- .NN 1>> .PT>)>)
 889       (ELSE ANY)>>>
 890
 891 "\f"
 892
 893 <DEFINE GET-ELE-BYTE (DCL N RST PT "AUX" SIZ)
 894         #DECL ((N) <OR ATOM FIX>)
 895         <COND (.PT
 896                <COND (<==? .N ALL> .DCL)
 897                      (<TYPE-AND .DCL <FORM STRUCTURED [.N FIX] [REST FIX]>>)>)
 898               (.RST
 899                <COND (<==? .N ALL> <SET N <MINL .DCL>>)
 900                      (<G? .N <MINL .DCL>> <SET N 0>)
 901                      (ELSE <SET N <- <MINL .DCL> .N>>)>
 902                <COND (<SET SIZ <GETBSYZ .DCL>> <FORM BYTES .SIZ .N>)
 903                      (ELSE BYTES)>)
 904               (ELSE FIX)>>
 905
 906 <DEFINE GETBSYZ (DCL "AUX" TEM)
 907         <COND (<==? <SET TEM <STRUCTYP .DCL>> STRING> 7)
 908               (<AND <==? .TEM BYTES> <TYPE? .DCL FORM SEGMENT> <G=? <LENGTH .DCL> 2>
 909                <TYPE? <SET TEM <2 .DCL>> FIX>>
 910                .TEM)>>
 911
 912 <DEFINE MINL (DCL "AUX" (N 0) DD D DC (LN 0) (QOK <>) (ANDOK <>) TT (OROK <>))
 913    #DECL ((N VALUE LN) FIX (DC) <PRIMTYPE LIST> (D) VECTOR)
 914    <AND <TYPE? .DCL ATOM> <SET DCL <GET .DCL DECL '.DCL>>>
 915    <COND
 916     (<AND <TYPE? .DCL FORM SEGMENT>
 917           <SET DC .DCL>
 918           <G? <LENGTH .DC> 1>
 919           <N==? <SET TT <1 .DC>> PRIMTYPE>
 920           <NOT <SET OROK <==? .TT OR>>>
 921           <NOT <SET QOK <==? .TT QUOTE>>>
 922           <NOT <SET ANDOK <==? .TT AND>>>
 923           <N==? .TT NOT>>
 924      <SET DC <REST .DC>>
 925      <COND (<AND <NOT <EMPTY? .DC>> <TYPE? <1 .DC> FIX>>
 926             <OR <TMATCH .TT '<PRIMTYPE BYTES>>
 927                 <MESSAGE ERROR "BAD-DECL-SYNTAX" .DCL>>
 928             <COND (<AND <==? <LENGTH .DC> 2> <TYPE? <2 .DC> FIX>>
 929                    <2 .DC>)
 930                   (ELSE 0)>)
 931            (ELSE
 932             <REPEAT ()
 933                     #DECL ((VALUE) FIX)
 934                     <COND (<AND <TYPE? <SET DD <1 .DC>> VECTOR>
 935                                 <SET D .DD>
 936                                 <G? <LENGTH .D> 1>>
 937                            <COND (<MEMQ <1 .D> '[REST OPT OPTIONAL]> <RETURN .N>)
 938                                  (<TYPE? <1 .D> FIX>
 939                                   <SET LN <1 .D>>
 940                                   <SET N <+ .N <* .LN <- <LENGTH .D> 1>>>>)
 941                                  (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>)
 942                           (<TYPE? .DD ATOM FORM SEGMENT> <SET N <+ .N 1>>)
 943                           (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>
 944                     <AND <EMPTY? <SET DC <REST .DC>>> <RETURN .N>>>)>)
 945     (<OR .OROK .ANDOK> <CHTYPE <MAPF <COND (.OROK ,MIN) (ELSE ,MAX)> ,MINL <REST .DC>>
 946                                 FIX>)
 947     (.QOK <COND (<STRUCTURED? <2 .DC>> <LENGTH <2 .DC>>) (ELSE 0)>)
 948     (<TYPE? .DCL ATOM FALSE FORM SEGMENT> 0)
 949     (ELSE <MESSAGE "BAD DECL " .DCL>)>>
 950
 951 <DEFINE STRUCTYP (DCL)
 952         <SET DCL <TYPE-AND .DCL STRUCTURED>>
 953         <COND (<TYPE? .DCL ATOM>
 954                <AND <VALID-TYPE? .DCL> <TYPEPRIM .DCL>>)
 955               (<TYPE? .DCL FORM SEGMENT>
 956                <COND (<PRIMHK .DCL T>)
 957                      (<TYPE? <1 .DCL> FORM> <PRIMHK <1 .DCL> <>>)>)>>
 958
 959 <DEFINE PRIMHK (FRM FLG "AUX" TEM (LN <LENGTH .FRM>))
 960         #DECL ((FRM) <OR FORM SEGMENT> (LN) FIX)
 961         <COND (<AND <==? .LN 2>
 962                     <COND (<==? <SET TEM <1 .FRM>> PRIMTYPE>
 963                            <AND <TYPE? <SET TEM <2 .FRM>> ATOM>
 964                                 <VALID-TYPE? .TEM>
 965                                 <STRUCTYP <2 .FRM>>>)
 966                           (<==? .TEM QUOTE> <PRIMTYPE <2 .FRM>>)
 967                           (<==? .TEM NOT> <>)>>)
 968               (<NOT <0? .LN>>
 969                <COND (<==? <SET TEM <1 .FRM>> OR>
 970                       <SET TEM NO-RETURN>
 971                       <MAPF <>
 972                             <FUNCTION (D)
 973                                 <SET TEM <TYPE-MERGE <STRUCTYP .D> .TEM>>> <REST .FRM>>
 974                       <COND (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>> .TEM)>)
 975                      (<==? .TEM AND>
 976                       <MAPF <>
 977                             <FUNCTION (D)
 978                                     <COND (<SET TEM <STRUCTYP .D>> <MAPLEAVE>)>>
 979                             <REST .FRM>>
 980                       .TEM)
 981                      (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>>
 982                       <TYPEPRIM .TEM>)>)>>
 983
 984 "\f"
 985
 986 <DEFINE TYPESAME (T1 T2)
 987         <AND <SET T1 <ISTYPE? .T1>>
 988              <==? .T1 <ISTYPE? .T2>>>>
 989
 990 <DEFINE ISTYPE-GOOD? (TYP "OPTIONAL" (STRICT <>))
 991         <AND <SET TYP <ISTYPE? .TYP .STRICT>>
 992              <NOT <MEMQ <TYPEPRIM .TYP> '![BYTES STRING LOCD TUPLE FRAME!]>>
 993              .TYP>>
 994
 995 <DEFINE TOP-TYPE (TYP "AUX" TT)
 996         <COND (<AND <TYPE? .TYP ATOM> <NOT <VALID-TYPE? .TYP>>
 997                     <NOT <MEMQ .TYP '![STRUCTURED APPLICABLE ANY LOCATIVE]>>>
 998                <SET TYP <GET .TYP DECL '.TYP>>)>
 999         <COND (<TYPE? .TYP ATOM> .TYP)
1000               (<AND <TYPE? .TYP FORM SEGMENT> <NOT <LENGTH? .TYP 1>>>
1001                <COND (<==? <SET TT <1 .TYP>> OR>
1002                       <MAPF ,TYPE-MERGE ,TOP-TYPE <REST .TYP>>)
1003                      (<==? .TT NOT> ANY)
1004                      (<==? .TT QUOTE> <TYPE <2 .TYP>>)
1005                      (<==? .TT PRIMTYPE> .TYP)
1006                      (ELSE .TT)>)>>
1007
1008 <DEFINE ISTYPE? (TYP "OPTIONAL" (STRICT <>) "AUX" TY)
1009    <PROG ()
1010          <OR .STRICT <TYPE? .TYP ATOM> <SET TYP <TYPE-AND .TYP '<NOT
1011                                                                  UNBOUND>>>>
1012          <COND
1013           (<TYPE? .TYP FORM SEGMENT>
1014            <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
1015                   <SET TYP <TYPE <2 .TYP>>>)
1016                  (<==? <1 .TYP> OR>
1017                   <SET TYP <ISTYPE? <2 <SET TY .TYP>>>>
1018                   <MAPF <>
1019                         <FUNCTION (Z)
1020                                 <COND (<N==? .TYP <ISTYPE? .Z>>
1021                                        <MAPLEAVE <SET TYP <>>>)>>
1022                         <REST .TY 2>>)
1023                  (ELSE <SET TYP <1 .TYP>>)>)>
1024          <AND <TYPE? .TYP ATOM>
1025               <COND (<VALID-TYPE? .TYP> .TYP)
1026                     (<SET TYP <GET .TYP DECL>> <AGAIN>)>>>>
1027
1028
1029 <DEFINE DCX (IT "AUX" TT LN)
1030         #DECL ((TT) VECTOR (LN) FIX)
1031         <COND (<AND <TYPE? .IT VECTOR>
1032                     <G=? <SET LN <LENGTH <SET TT .IT>>> 2>
1033                     <COND (<==? .LN 2> <2 .TT>)
1034                           (ELSE <TYPE-MERGE !<REST .TT>>)>>)
1035               (ELSE .IT)>>
1036
1037 "DETERMINE IF A TYPE PATTERN REQUIRES DEFERMENT 0=> NO 1=> YES 2=> DONT KNOW "
1038
1039 "\f"
1040
1041 <DEFINE DEFERN (PAT "AUX" STATE TEM)
1042    #DECL ((STATE) FIX)
1043    <PROG ()
1044          <COND
1045           (<TYPE? .PAT ATOM>
1046            <COND (<VALID-TYPE? .PAT>
1047                   <COND (<MEMQ <SET PAT <TYPEPRIM .PAT>>
1048                                '![STRING TUPLE LOCD FRAME BYTES!]>
1049                          1)
1050                         (ELSE 0)>)
1051                  (<SET PAT <GET .PAT DECL>> <AGAIN>)
1052                  (ELSE 2)>)
1053           (<AND <TYPE? .PAT FORM SEGMENT> <NOT <EMPTY? .PAT>>>
1054            <COND (<==? <SET TEM <1 .PAT>> QUOTE> <DEFERN <TYPE <2 .PAT>>>)
1055                  (<==? .TEM PRIMTYPE> <DEFERN <2 .PAT>>)
1056                  (<AND <==? .TEM OR> <NOT <EMPTY? <REST .PAT>>>>
1057                   <SET STATE <DEFERN <2 .PAT>>>
1058                   <MAPF <>
1059                         <FUNCTION (P)
1060                                 <OR <==? <DEFERN .P> .STATE> <SET STATE 2>>>
1061                         <REST .PAT 2>>
1062                   .STATE)
1063                  (<==? .TEM NOT> 2)
1064                  (<==? .TEM AND>
1065                   <SET STATE 2>
1066                   <MAPF <>
1067                         <FUNCTION (P)
1068                                 <COND (<L? <SET STATE <DEFERN .P>> 2>
1069                                        <MAPLEAVE>)>>
1070                         <REST .PAT>>
1071                   .STATE)
1072                  (ELSE <DEFERN <1 .PAT>>)>)
1073           (ELSE 2)>>>
1074
1075 " Define a decl for a given quoted object for maximum winnage."
1076
1077 "\f"
1078
1079 <DEFINE GEN-DECL (OBJ)
1080    <COND
1081     (<OR <MONAD? .OBJ> <APPLICABLE? .OBJ> <TYPE? .OBJ STRING>> <TYPE .OBJ>)
1082     (<==? <PRIMTYPE .OBJ> BYTES>
1083      <CHTYPE (<TYPE .OBJ> <BYTE-SIZE .OBJ> <LENGTH .OBJ>) SEGMENT>)
1084     (ELSE
1085      <REPEAT ((DC <GEN-DECL <1 .OBJ>>) (CNT 1)
1086               (FRM <CHTYPE (<TYPE .OBJ>) SEGMENT>) (FRME .FRM) TT T1)
1087              #DECL ((CNT) FIX (FRME) <<PRIMTYPE LIST> ANY>)
1088              <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
1089                     <COND (<G? .CNT 1>
1090                            <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
1091                           (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
1092                     <RETURN .FRM>)
1093                    (<AND <=? <SET TT <GEN-DECL <1 .OBJ>>> .DC> .DC>
1094                     <SET CNT <+ .CNT 1>>)
1095                    (ELSE
1096                     <COND (<G? .CNT 1>
1097                            <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
1098                           (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
1099                     <SET DC .TT>
1100                     <SET CNT 1>)>>)>>
1101
1102 "\f"
1103
1104 <DEFINE REST-DECL (DC N "AUX" TT TEM)
1105    #DECL ((N) FIX)
1106    <COND
1107     (<TYPE? .DC FORM SEGMENT>
1108      <COND
1109       (<OR <==? <SET TT <1 .DC>> OR> <==? .TT AND>>
1110        <SET TT
1111         <CHTYPE (.TT
1112                  !<MAPF ,LIST
1113                         <FUNCTION (D "AUX" (IT <REST-DECL .D .N>))
1114                                 <COND (<==? .IT ANY>
1115                                        <COND (<==? .TT OR> <MAPLEAVE (ANY)>)
1116                                              (ELSE <MAPRET>)>)
1117                                       (ELSE .IT)>>
1118                         <REST .DC>>)
1119                 FORM>>
1120        <COND (<EMPTY? <REST .TT>> ANY)
1121              (<EMPTY? <REST .TT 2>> <2 .TT>)
1122              (ELSE .TT)>)
1123       (<==? .TT NOT> ANY)
1124       (<==? <STRUCTYP .DC> BYTES>
1125        <COND (<==? .TT PRIMTYPE>
1126               .DC)
1127              (<==? <LENGTH .DC> 2>
1128               <CHTYPE (!.DC .N) FORM>)
1129              (<FORM .TT <2 .DC> <+ <CHTYPE <3 .DC> FIX> .N>>)>)
1130       (<==? .TT PRIMTYPE>
1131        <COND (<0? .N> .DC)
1132              (ELSE <CHTYPE (.DC !<ANY-PAT .N>) FORM>)>)
1133       (ELSE
1134        <FOSE <TYPE? .DC SEGMENT> <COND (<SET TEM <STRUCTYP .TT>> <FORM PRIMTYPE .TEM>)
1135                                        (ELSE STRUCTURED)>
1136                 !<ANY-PAT .N>
1137                 !<REST .DC>>)>)
1138     (<SET TEM <STRUCTYP .DC>>
1139      <COND (<OR <0? .N>
1140                 <==? .TEM BYTES>> <FORM PRIMTYPE .TEM>)
1141            (ELSE <CHTYPE (<FORM PRIMTYPE .TEM> !<ANY-PAT .N>) FORM>)>)
1142     (ELSE
1143      <COND (<0? .N> STRUCTURED)
1144            (ELSE <CHTYPE (STRUCTURED !<ANY-PAT .N>) FORM>)>)>>
1145
1146 <DEFINE ANY-PAT (N)
1147         #DECL ((N) FIX)
1148         <COND (<L=? .N 0> ()) (<1? .N> (ANY)) (ELSE ([.N ANY]))>>
1149
1150 " TYPE-OK? are two type patterns compatible.  If the patterns
1151   don't parse, send user a message."
1152
1153 <DEFINE TYPE-OK? (P1 P2 "AUX" TEM)
1154         <COND (<OR <==? .P1 NO-RETURN> <==? .P2 NO-RETURN>> NO-RETURN)
1155               (<SET TEM <TYPE-AND .P1 .P2>> .TEM)
1156               (<EMPTY? .TEM> .TEM)
1157               (ELSE <MESSAGE ERROR " " <1 .TEM> " " .P1 " " .P2>)>>
1158
1159 " TYPE-ATOM-OK? does an atom's initial value agree with its DECL?"
1160
1161 <DEFINE TYPE-ATOM-OK? (P1 P2 ATM)
1162         #DECL ((ATM) ATOM)
1163         <OR <TYPE-OK? .P1 .P2>
1164                 <MESSAGE ERROR "TYPE MISUSE " .ATM>>>
1165
1166 " Merge a group of type specs into an OR."
1167
1168 "\f"
1169
1170 <DEFINE TYPE-MERGE ("TUPLE" TYPS)
1171         #DECL ((TYPS) TUPLE (FTYP) FORM (LN) FIX)
1172         <COND (<EMPTY? .TYPS> <>)
1173               (ELSE
1174                <REPEAT ((ORS <1 .TYPS>))
1175                        <COND (<EMPTY? <SET TYPS <REST .TYPS>>> <RETURN .ORS>)>
1176                        <SET ORS
1177                             <COND (<==? <1 .TYPS> NO-RETURN> .ORS)
1178                                   (<==? .ORS NO-RETURN> <1 .TYPS>)
1179                                   (ELSE <TMERGE .ORS <1 .TYPS>>)>>>)>>
1180
1181 <DEFINE PUT-IN (LST ELE)
1182    #DECL ((LST) <PRIMTYPE LIST> (VALUE) LIST)
1183    <COND (<AND <TYPE? .ELE FORM SEGMENT>
1184                <NOT <EMPTY? .ELE>>
1185                <==? <1 .ELE> OR>>
1186           <SET ELE <LIST !<REST .ELE>>>)
1187          (ELSE <SET ELE (.ELE)>)>
1188    <SET LST
1189     <MAPF ,LIST
1190      <FUNCTION (L1 "AUX" TT)
1191              <COND (<EMPTY? .ELE> .L1)
1192                    (<REPEAT ((A .ELE) B)
1193                             #DECL ((A B) LIST)
1194                             <COND (<TMATCH <1 .A> .L1>
1195                                    <SET TT <TMERGE <1 .A> .L1>>
1196                                    <COND (<==? .A .ELE> <SET ELE <REST .ELE>>)
1197                                          (ELSE <PUTREST .B <REST .A>>)>
1198                                    <RETURN T>)>
1199                             <AND <EMPTY? <SET A <REST <SET B .A>>>>
1200                                  <RETURN <>>>>
1201                     .TT)
1202                    (ELSE .L1)>>
1203      .LST>>
1204    <LSORT <COND (<EMPTY? .ELE> .LST)
1205                 (ELSE <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> .LST> .ELE)>>>
1206
1207 <DEFINE ORSORT (F) #DECL ((F) <FORM ANY ANY>) <PUTREST .F <LSORT <REST .F>>>>
1208
1209 <DEFINE LSORT (L "AUX" (M ()) (B ()) (TMP ()) (IT ()) (N 0) A1 A2)
1210         #DECL ((L M B TMP IT VALUE) LIST (N) FIX (CMPRSN) <OR FALSE APPLICABLE>)
1211         <PROG ()
1212               <COND (<L? <SET N <LENGTH .L>> 2> <RETURN .L>)>
1213               <SET B <REST <SET TMP <REST .L <- </ .N 2> 1>>>>>
1214               <PUTREST .TMP ()>
1215               <SET L <LSORT .L>>
1216               <SET B <LSORT .B>>
1217               <SET TMP ()>
1218               <REPEAT ()
1219                       <COND (<EMPTY? .L>
1220                              <COND (<EMPTY? .TMP> <RETURN .B>)
1221                                    (ELSE <PUTREST .TMP .B> <RETURN .M>)>)
1222                             (<EMPTY? .B>
1223                              <COND (<EMPTY? .TMP> <RETURN .L>)
1224                                    (ELSE <PUTREST .TMP .L> <RETURN .M>)>)
1225                             (ELSE
1226                              <SET A1 <1 .L>>
1227                              <SET A2 <1 .B>>
1228                              <COND (<COND (<AND <TYPE? .A1 ATOM> <TYPE? .A2 ATOM>>
1229                                            <L? <STRCOMP .A1 .A2> 0>)
1230                                           (<TYPE? .A1 ATOM> T)
1231                                           (<TYPE? .A2 ATOM> <>)
1232                                           (ELSE <FCOMPARE .A1 .A2>)>
1233                                     <SET L <REST <SET IT .L>>>)
1234                                    (ELSE <SET B <REST <SET IT .B>>>)>
1235                              <PUTREST .IT ()>
1236                              <COND (<EMPTY? .M> <SET M <SET TMP .IT>>)
1237                                    (ELSE <SET TMP <REST <PUTREST .TMP .IT>>>)>)>>>>
1238 "\f"
1239
1240 <DEFINE FCOMPARE (F1 F2 "AUX" (L1 <LENGTH .F1>) (L2 <LENGTH .F2>))
1241         #DECL ((F1 F2) <PRIMTYPE LIST> (L1 L2) FIX)
1242         <COND (<==? .L1 .L2>
1243                <L? <STRCOMP <UNPARSE .F1> <UNPARSE .F2>> 0>)
1244               (<L? .L1 .L2>)>>
1245
1246
1247 <DEFINE CANONICAL-DECL (D)
1248         <SET D <VTS .D>>
1249         <COND (<AND <TYPE? .D FORM SEGMENT> <NOT <EMPTY? .D>>>
1250                <COND (<==? <1 .D> OR>
1251                       <ORSORT <FORM OR !<CAN-ELE <REST .D>>>>)
1252                      (<==? <1 .D> QUOTE> <CANONICAL-DECL <GEN-DECL <2 .D>>>)
1253                      (ELSE <CAN-ELE .D>)>)
1254               (ELSE .D)>>
1255
1256
1257 <DEFINE CAN-ELE (L "AUX" (SAME <>) SAMCNT TT TEM)
1258    #DECL ((L) <PRIMTYPE LIST> (SAMCNT) FIX)
1259    <CHTYPE
1260     (<CANONICAL-DECL <1 .L>>
1261      !<MAPR ,LIST
1262        <FUNCTION (EL "AUX" (ELE <1 .EL>) (LAST <EMPTY? <REST .EL>>))
1263           <COND
1264            (<TYPE? .ELE VECTOR>
1265             <COND
1266              (<AND <==? <LENGTH .ELE> 2> <TYPE? <1 .ELE> FIX>>
1267               <SET TT <CANONICAL-DECL <2 .ELE>>>
1268               <COND (<AND .SAME <=? .SAME .TT>>
1269                      <SET SAMCNT <+ .SAMCNT <1 .ELE>>>
1270                      <COND (.LAST [.SAMCNT .TT]) (ELSE <MAPRET>)>)
1271                     (ELSE
1272                      <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1273                            (ELSE <SET TEM <>>)>
1274                      <SET SAME .TT>
1275                      <SET SAMCNT <1 .ELE>>
1276                      <COND (.LAST
1277                             <COND (.TEM <MAPRET .TEM <GR-RET .TT .SAMCNT>>)
1278                                   (ELSE <GR-RET .TT .SAMCNT>)>)
1279                            (.TEM)
1280                            (ELSE <MAPRET>)>)>)
1281              (<AND <==? <1 .ELE> REST>
1282                    <==? <LENGTH .ELE> 2>
1283                    <==? <2 .ELE> ANY>>
1284               <COND (.SAME
1285                      <SET TEM <GR-RET .SAME .SAMCNT>>
1286                      <SET SAME <>>
1287                      <MAPRET .TEM>)
1288                     (ELSE <MAPRET>)>)
1289              (ELSE
1290               <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1291                     (ELSE <SET TEM <>>)>
1292               <SET TT <IVECTOR <LENGTH .ELE>>>
1293               <PUT .TT 1 <COND (<==? <1 .ELE> OPT> OPTIONAL) (ELSE <1 .ELE>)>>
1294               <MAPR <>
1295                     <FUNCTION (X Y) <PUT .X 1 <CANONICAL-DECL <1 .Y>>>>
1296                     <REST .TT>
1297                     <REST .ELE>>
1298               <SET SAME <>>
1299               <COND (.TEM <MAPRET .TEM .TT>) (ELSE .TT)>)>)
1300            (ELSE
1301             <SET ELE <CANONICAL-DECL .ELE>>
1302             <COND (<AND .SAME <=? .SAME .ELE>>
1303                    <SET SAMCNT <+ .SAMCNT 1>>
1304                    <COND (.LAST <GR-RET .ELE .SAMCNT>) (ELSE <MAPRET>)>)
1305                   (ELSE
1306                    <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1307                          (ELSE <SET TEM <>>)>
1308                    <SET SAME .ELE>
1309                    <SET SAMCNT 1>
1310                    <COND (.LAST <COND (.TEM <MAPRET .TEM .ELE>) (ELSE .ELE)>)
1311                          (.TEM)
1312                          (ELSE <MAPRET>)>)>)>>
1313        <REST .L>>)
1314     FORM>>
1315
1316 <DEFINE GR-RET (X N) #DECL ((N) FIX)
1317         <COND (<1? .N> .X)(ELSE [.N .X])>>
1318
1319