mim/development/mim/mimc/chkdcl.mud

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