mim/development/mim/mimc/macros.mud

   1
   2 <RPACKAGE "MACROS">
   3
   4 <ENTRY DO CASE INC DEC CHOP IF IF-NOT PRIMTYPE?>
   5
   6 ;
   7 "Sample DO usage
   8 <DO ((X 1 10)
   9      \"UNTIL\" (<==? .Y STOP>
  10               <ERROR EARLY-STOP>
  11               #FALSE (\"NO-MORE\"))
  12      \"GEN\" (Z .FOO <REST .FOO .X> <EMPTY? .Z> <ERROR Z-RAN-OUT> T)
  13      \"EXTRA\" Y)
  14     <COND (<SET Y <NTH ,DATA .X>>
  15            <PRINT .Y>)>
  16     <PRIN1 <1 .Z>>>
  17 "
  18
  19 <DEFMAC DO ('ARGL
  20             "ARGS" BODY
  21             "AUX" (PRE-CODE ()) (POST-CODE ()) (PRE-TEST ()) (POST-TEST ())
  22                     (STATE ,COLON-FOR) (RETURNS ()))
  23         #DECL ((ARGL BODY) LIST (STATE) FIX (RETURNS) <SPECIAL LIST>
  24                (POST-CODE PRE-TEST POST-TEST) <SPECIAL <LIST [REST <LIST ANY>]>>
  25                (PRE-CODE) <SPECIAL LIST> (VALUE) FORM)
  26         <SET ARGL
  27              <MAPF ,LIST
  28                    <FUNCTION (NAM)
  29                            <COND (<TYPE? .NAM STRING>
  30                                   <COND (<=? .NAM "FOR"> <SET STATE ,COLON-FOR>)
  31                                         (<=? .NAM "GEN"> <SET STATE ,COLON-GEN>)
  32                                         (<=? .NAM "WHILE">
  33                                          <SET STATE ,COLON-WHILE>)
  34                                         (<=? .NAM "UNTIL">
  35                                          <SET STATE ,COLON-UNTIL>)
  36                                         (<=? .NAM "VALUE">
  37                                          <SET STATE ,COLON-VALUE>)
  38                                         (<OR <=? .NAM "AUX"> <=? .NAM "AUX">>
  39                                          <SET STATE ,COLON-NONE>)
  40                                         (ELSE <SET STATE ,COLON-NONE> <MAPRET .NAM>)>)
  41                                  (<==? .STATE ,COLON-NONE> <MAPRET .NAM>)
  42                                  (ELSE
  43                                   <COND (<NOT <TYPE? .NAM LIST>>
  44                                          <SET NAM (.NAM)>)>
  45                                   <CASE ,==? .STATE
  46                                              (,COLON-FOR <MAPRET <DO-FOR !.NAM>>)
  47                                              (,COLON-GEN <MAPRET <DO-GEN !.NAM>>)
  48                                              (,COLON-WHILE <DO-WHILE !.NAM>)
  49                                              (,COLON-UNTIL <DO-UNTIL !.NAM>)
  50                                              (,COLON-VALUE <DO-VALUE !.NAM>)>)>
  51                            <MAPRET>>
  52                    .ARGL>>
  53         <SET RETURNS <COND-BODY '(<RETURN T>) .RETURNS>>
  54         <FORM REPEAT
  55               .ARGL
  56               !<MAPF ,LIST <FUNCTION (L)
  57                                      #DECL ((L) <LIST ANY>)
  58                                      <MAKE-COND <1 .L> .RETURNS <REST .L>>>
  59                      .PRE-CODE>                                     ;"FOR tests"
  60               !<MAPF ,LIST <FUNCTION (L)
  61                                      #DECL ((L) <LIST ANY>)
  62                                      <MAKE-COND <1 .L> .RETURNS <REST .L>>>
  63                      .PRE-TEST>                                   ;"WHILE tests"
  64               !.BODY
  65               !<MAPF ,LIST <FUNCTION (L)
  66                                      #DECL ((L) <LIST ANY>)
  67                                      <MAKE-COND <1 .L> .RETURNS <REST .L>>>
  68                      .POST-TEST>                                  ;"UNTIL tests"
  69               !.POST-CODE                                       ;"FOR updates">>
  70
  71
  72 <AND? <SETG COLON-NONE 0>
  73       <SETG COLON-FOR 1>
  74       <SETG COLON-GEN 2>
  75       <SETG COLON-UNTIL 3>
  76       <SETG COLON-WHILE 4>
  77       <SETG COLON-VALUE 5>
  78       <MANIFEST COLON-NONE COLON-FOR COLON-GEN COLON-UNTIL COLON-WHILE COLON-VALUE>>
  79 \\f
  80
  81 ;"Generators for DO"
  82
  83 <DEFINE DO-FOR         ;"Make a variable declaration and a test for FOR looping"
  84         (VARIABLE "OPTIONAL" (INITIAL 1) FINAL (STEP 1) "TUPLE" VAL)
  85         #DECL ((VAL) TUPLE (PRE-CODE POST-CODE) LIST)
  86         <COND (<OR <NOT <ASSIGNED? FINAL>>
  87                    <==? .STEP 0>
  88                    <==? .STEP 0.0000000>>)
  89               (<AND <TYPE? .STEP FIX FLOAT> <G? .STEP 0>>       ;"Stepping up ?"
  90                <SET PRE-CODE
  91                     (!.PRE-CODE
  92                      (<FORM G? <FORM LVAL .VARIABLE> .FINAL> !.VAL))>)
  93               (<AND <TYPE? .STEP FIX FLOAT> <L? .STEP 0>>     ;"Stepping down ?"
  94                <SET PRE-CODE
  95                     (!.PRE-CODE
  96                      (<FORM L? <FORM LVAL .VARIABLE> .FINAL> !.VAL))>)
  97               (ELSE                         ;"Assume unknown stepping direction"
  98                <SET PRE-CODE
  99                     (!.PRE-CODE
 100                      (<FORM COND
 101                             (<FORM G? .STEP 0>
 102                              <FORM G? <FORM LVAL .VARIABLE> .FINAL>)
 103                             (<FORM L? .STEP 0>
 104                              <FORM L? <FORM LVAL .VARIABLE> .FINAL>)>
 105                       !.VAL))>)>
 106         <SET POST-CODE
 107              (!.POST-CODE
 108               <FORM SET .VARIABLE <FORM + <FORM LVAL .VARIABLE> .STEP>>)>
 109         (.VARIABLE .INITIAL)>
 110
 111 <DEFINE DO-GEN         ;"Make a variable declaration and a test for FOR looping"
 112         (VARIABLE "OPTIONAL" (INITIAL ()) STEP PRED "TUPLE" VAL)
 113         #DECL ((VARIABLE) ATOM (VAL) TUPLE (PRE-CODE POST-CODE) LIST)
 114         <COND (<ASSIGNED? PRED>
 115                <SET PRE-CODE
 116                     (!.PRE-CODE (.PRED !.VAL))>)>
 117         <COND (<ASSIGNED? STEP>
 118                <SET POST-CODE (!.POST-CODE <FORM SET .VARIABLE .STEP>)>)>
 119         (.VARIABLE .INITIAL)>
 120
 121 <DEFINE DO-WHILE (EXPR "TUPLE" VAL)           ;"Make a test to do looping WHILE"
 122         #DECL ((VAL) TUPLE (PRE-TEST) LIST)
 123         <SET PRE-TEST
 124              (!.PRE-TEST
 125               (<FORM NOT .EXPR> !.VAL))>>
 126
 127 <DEFINE DO-UNTIL (EXPR "TUPLE" VAL)           ;"Make a test to do looping UNTIL"
 128         #DECL ((VAL) TUPLE (POST-TEST) LIST)
 129         <SET POST-TEST
 130              (!.POST-TEST (.EXPR !.VAL))>>
 131
 132 <DEFINE DO-VALUE ("TUPLE" BODY)
 133         #DECL ((BODY) TUPLE (RETURNS) LIST)
 134         <COND (<NOT <EMPTY? .RETURNS>>
 135                <ERROR TOO-MANY!-ERRORS "VALUE" DO>)
 136               (ELSE <SET RETURNS (!.BODY)>)>>
 137
 138 <DEFINE MAKE-COND (PRED DEF BODY)
 139         #DECL ((VALUE) <FORM ATOM LIST> (DEF BODY) LIST)
 140         <FORM COND (.PRED !<COND-BODY .DEF .BODY>)>>
 141
 142 <DEFINE COND-BODY (DEF BODY)
 143         #DECL ((VALUE) LIST (DEF BODY) LIST)
 144         <COND (<EMPTY? .BODY> .DEF)
 145               (ELSE
 146                <SET DEF <REST .BODY <- <LENGTH .BODY> 1>>>
 147                <PUT .DEF 1 <FORM RETURN <1 .DEF>>>
 148                .BODY)>>
 149
 150 \\f
 151
 152 ;
 153 "Sample CASE usage
 154 <CASE ,TYPE? <GET .FOO DATA>
 155       (ATOM <PRINT IDENTIFIER> 0)
 156       (FIX <PRINT INTEGER> 1)
 157       (FLOAT <PRINT REAL> 2)
 158       DEFAULT
 159       (<PRINT OTHER> 3)
 160       (!'(LIST VECTOR UVECTOR ,XTRA) <PRINT STRUCTURE> 4)
 161       (STRING <PRINT STRING> 5)>
 162 "
 163
 164 <DEFMAC CASE ('PRED 'EXPR "ARGS" CASES "AUX" (DEFAULT-CASE <>))
 165    #DECL ((CASES) LIST (DEFAULT-CASE) <OR FALSE LIST> (VALUE) FORM)
 166    <COND (<AND <TYPE? .PRED FORM>
 167                <==? <LENGTH .PRED> 2>
 168                <==? <1 .PRED> GVAL>
 169                <TYPE? <2 .PRED> ATOM>>
 170           <SET PRED <2 .PRED>>)
 171          (<TYPE? .PRED GVAL> <SET PRED <CHTYPE .PRED ATOM>>)>
 172    <FORM
 173     BIND
 174     ((OB .EXPR))
 175     <FORM
 176      COND
 177      !<MAPF ,LIST
 178        <FUNCTION (PHRASE "AUX" EXPR)
 179                <COND (<==? .PHRASE DEFAULT>
 180                       <COND (.DEFAULT-CASE
 181                              <ERROR TOO-MANY-DEFAULTS!-ERRORS CASE>)
 182                             (ELSE <SET DEFAULT-CASE ()>)>
 183                       <MAPRET>)
 184                      (<OR <NOT <TYPE? .PHRASE LIST>> <EMPTY? .PHRASE>>
 185                       <ERROR BAD-CLAUSE!-ERRORS CASE>)
 186                      (<AND .DEFAULT-CASE <EMPTY? .DEFAULT-CASE>>
 187                       <SET DEFAULT-CASE ((DEFAULT !.PHRASE))>
 188                       <MAPRET>)
 189                      (<NOT <TYPE? <SET EXPR <1 .PHRASE>> SEGMENT>>
 190                       (<FORM .PRED '.OB .EXPR> !<REST .PHRASE>))
 191                      (<EMPTY? .EXPR> (<FORM .PRED '.OB> !<REST .PHRASE>))
 192                      (<==? <1 .EXPR> QUOTE>
 193                       <COND (<OR <EMPTY? <REST .EXPR>>
 194                                  <NOT <STRUCTURED? <2 .EXPR>>>>
 195                              <ERROR ILLEGAL-SEGMENT!-ERRORS CASE>)
 196                             (ELSE
 197                              (<DO-SEG .PRED (!<2 .EXPR>)> !<REST .PHRASE>))>)
 198                      (ELSE (<FORM .PRED '.OB .EXPR> !<REST .PHRASE>))>>
 199        .CASES>
 200      !.DEFAULT-CASE>>>
 201
 202 <DEFINE DO-SEG (PRED OPS)
 203         #DECL ((OPS) LIST (VALUE) FORM)
 204         <COND (<OR <==? .PRED TYPE?> <==? .PRED PRIMTYPE?> <EMPTY? .OPS>>
 205                <CHTYPE (.PRED '.OB !.OPS) FORM>)
 206               (ELSE
 207                <CHTYPE (OR
 208                         !<MAPF ,LIST
 209                                <FUNCTION (X) <FORM .PRED '.OB .X>>
 210                                .OPS>)
 211                        FORM>)>>
 212
 213 \\f
 214
 215 <DEFMAC INC ('ATM "OPTIONAL" ('AMT 1))
 216         <FORM SET .ATM <FORM + <FORM LVAL .ATM> .AMT>>>
 217
 218 <DEFMAC DEC ('ATM "OPTIONAL" ('AMT 1))
 219         <FORM SET .ATM <FORM - <FORM LVAL .ATM> .AMT>>>
 220
 221 <DEFMAC CHOP ('ATM "OPTIONAL" ('AMT 1))
 222         <FORM SET .ATM <FORM REST <FORM LVAL .ATM> .AMT>>>
 223
 224 <DEFMAC IF ("ARGS" BODY) <FORM COND .BODY>>
 225
 226 <DEFMAC IF-NOT ('PRED "ARGS" BODY) <FORM COND (<FORM NOT .PRED> !.BODY)>>
 227
 228 <DEFMAC PRIMTYPE? ('EXPR "ARGS" BODY)
 229         #DECL ((BODY) LIST)
 230         <COND (<EMPTY? .BODY>
 231                <ERROR TOO-FEW-ARGUMENTS-SUPPLIED!-ERRORS PRIMTYPE?>)
 232               (<EMPTY? <REST .BODY>>
 233                <FORM ==? <FORM PRIMTYPE .EXPR> <1 .BODY>>)
 234               (ELSE
 235                <FORM PROG
 236                      ((OB <FORM PRIMTYPE .EXPR>))
 237                      #DECL ((OB) ATOM (VALUE) <OR FALSE ATOM>)
 238                      <FORM COND
 239                            (<CHTYPE (OR
 240                                      !<MAPF ,LIST
 241                                             <FUNCTION (X) <FORM ==? '.OB .X>>
 242                                             .BODY>)
 243                                     FORM>
 244                             '.OB)>>)>>
 245
 246 <ENDPACKAGE>