<mdl.comp>/chkdcl.mud.44

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