mim/development/mim/mimc/casefcn.mud

   1 <NEWTYPE ORQ LIST>
   2
   3 <USE "CHKDCL" "COMPDEC">
   4
   5 <DEFINE CASE-FCN (OBJ AP
   6                   "AUX" (OP .PARENT) (PARENT .PARENT) (FLG T) (WIN T) TYP
   7                         (DF <>) P TEM X)
   8    #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
   9    <COND
  10     (<AND
  11       <G? <LENGTH .OBJ> 3>
  12       <PROG ()
  13             <COND (<OR <AND <==? <TYPE <SET X <2 .OBJ>>> GVAL>
  14                             <==? <SET P <CHTYPE .X ATOM>> ==?>>
  15                        <AND <TYPE? <SET X <2 .OBJ>> FORM>
  16                             <==? <LENGTH .X> 2>
  17                             <==? <1 .X> GVAL>
  18                             <==? <SET P <2 .X>> ==?>
  19                             ;<MEMQ <SET P <2 .X>> '[==? TYPE? PRIMTYPE?]>>>)
  20                   (ELSE <SET WIN <>>)>
  21             1>
  22       <MAPF <>
  23        <FUNCTION (O)
  24           <COND
  25            (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
  26            (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
  27            (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
  28             <COND
  29              (<SET TEM <VAL-CHK <1 .O>>>
  30               <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
  31                     (ELSE <SET TYP <TYPE .TEM>>)>)
  32              (<AND <TYPE? <SET TEM <1 .O>> SEGMENT>
  33                    <==? <LENGTH .TEM> 2>
  34                    <==? <1 .TEM> QUOTE>
  35                    <NOT <MONAD? <SET TEM <2 .TEM>>>>>
  36               <MAPF <>
  37                     <FUNCTION (TY)
  38                             <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
  39                                   (ELSE
  40                                    <COND (<ASSIGNED? TYP>
  41                                           <OR <==? .TYP <TYPE .TY>>
  42                                               <SET WIN <>>>)
  43                                          (ELSE <SET TYP <TYPE .TY>>)>)>>
  44                     .TEM>)
  45              (ELSE <SET WIN <>>)>)
  46            (ELSE <MAPLEAVE <>>)>
  47           T>
  48        <REST .OBJ 3>>
  49       <NOT .DF>>
  50      <COND (<AND .WIN
  51                  <NOT <OR <AND <MEMQ <TYPEPRIM .TYP> '[WORD FIX]>
  52                                <==? .P ==?>>
  53                           <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
  54             <SET WIN <>>)>
  55      <COND
  56       (.WIN
  57        <SET PARENT <NODECOND ,CASE-CODE .OP <> CASE ()>>
  58        <PUT
  59         .PARENT
  60         ,KIDS
  61         (<PCOMP <2 .OBJ> .PARENT>
  62          <PCOMP <3 .OBJ> .PARENT>
  63          !<MAPF ,LIST
  64            <FUNCTION (CLA "AUX" TT)
  65                    #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
  66                    <COND (.DF <SET CLA (ELSE !.CLA)>)>
  67                    <COND
  68                     (<NOT <TYPE? .CLA ATOM>>
  69                      <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
  70                           ,PREDIC
  71                           <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
  72                                         <FORM QUOTE
  73                                               <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
  74                                        (<TYPE? .TEM ORQ>
  75                                         <FORM QUOTE
  76                                               <MAPF ,LIST ,VAL-CHK .TEM>>)
  77                                        (ELSE <VAL-CHK .TEM>)>
  78                                  .TT>>
  79                      <PUT .TT
  80                           ,CLAUSES
  81                           <MAPF ,LIST
  82                                 <FUNCTION (O) <PCOMP .O .TT>>
  83                                 <REST .CLA>>>
  84                      <SET DF <>>
  85                      .TT)
  86                     (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
  87            <REST .OBJ 3>>)>)
  88       (ELSE <PMACRO .OBJ .OP>)>)
  89     (ELSE <COMPILE-ERROR "CASE in incorrect format " .OBJ>)>>