mim/development/mim/vax/mimlib/newstruc.mud

   1 <PACKAGE "NEWSTRUC">
   2
   3 <RENTRY MSETG NEWSTRUC>
   4
   5 "Does SETG and MANIFEST"
   6 <DEFINE MSETG ("TUPLE" DEFS:<<PRIMTYPE VECTOR> [REST ATOM ANY]>)
   7    <COND (<NOT <0? <MOD <LENGTH .DEFS> 2>>>
   8           <ERROR BAD-ARGUMENT-LIST!-ERRORS MSETG>)
   9          (T
  10           <REPEAT ((EXPSPLICE <AND <ASSIGNED? EXPSPLICE> .EXPSPLICE>)
  11                    (REDEFINE <AND <ASSIGNED? REDEFINE> .REDEFINE>)
  12                    (HEAD:LIST (T)) (TAIL:LIST .HEAD) DEF:ATOM VAL:ANY)
  13              <SET VAL <2 .DEFS>>
  14              <COND (<GASSIGNED? <SET DEF <1 .DEFS>>>
  15                     <COND (<OR .REDEFINE <=? .VAL ,.DEF>
  16                                <ERROR MSETG .DEF ALREADY-GASSIGNED ,.DEF>>
  17                            <GUNASSIGN .DEF>
  18                            <UNMANIFEST .DEF>
  19                            <AGAIN>)>)
  20                    (.EXPSPLICE
  21                     <PUTREST .TAIL
  22                              (<FORM SETG .DEF .VAL> <FORM MANIFEST .DEF>)>
  23                     <SET TAIL <REST .TAIL 2>>)
  24                    (T
  25                     <SETG .DEF .VAL>
  26                     <MANIFEST .DEF>)>
  27              <COND (<EMPTY? <SET DEFS <REST .DEFS 2>>>
  28                     <COND (.EXPSPLICE
  29                            <MAPF <> ,EVAL <REST .HEAD>>
  30                            <RETURN <CHTYPE <REST .HEAD> SPLICE>>)
  31                           (<RETURN>)>)>>)>>
  32
  33 "Set up structure definitions.  Takes name, primtype, pairs (sort of)
  34  of name & type for slots in structure"
  35 <DEFINE NEWSTRUC (NAM:<OR ATOM <LIST ATOM>> PRIM:<OR ATOM <LIST ATOM>>
  36                   "ARGS" ELEM:<PRIMTYPE LIST>
  37                   "AUX" (RPRIM:ATOM <COND (<TYPE? .PRIM LIST> <1 .PRIM>)
  38                                           (.PRIM)>)
  39                         (LL:<PRIMTYPE LIST> <FORM <FORM PRIMTYPE .RPRIM>>)
  40                         (L:<PRIMTYPE LIST> .LL) OFFS DEC
  41                         R:<PRIMTYPE LIST> RR:<PRIMTYPE LIST> (CNT:FIX 1)
  42                         (EXPSPLICE <AND <ASSIGNED? EXPSPLICE> .EXPSPLICE>))
  43    <REPEAT ((HEAD:LIST (T)) (TAIL:LIST .HEAD))
  44       <COND
  45        (<EMPTY? .ELEM>
  46         <COND (<ASSIGNED? RR> <PUTREST .R (<VECTOR !.RR>)>)>
  47         <COND
  48          (<TYPE? .NAM ATOM>
  49           <COND (<TYPE? .PRIM LIST>
  50                  <COND (.EXPSPLICE
  51                         <SET TAIL
  52                              <REST <PUTREST .TAIL
  53                                             (<FORM PUT-DECL .NAM
  54                                                    <FORM QUOTE .LL>>)>>>)>
  55                  <PUT-DECL .NAM .LL>)
  56                 (T
  57                  <COND (.EXPSPLICE
  58                         <SET TAIL
  59                              <REST <PUTREST .TAIL
  60                                             (<FORM NEWTYPE .NAM .RPRIM
  61                                                    <FORM QUOTE .LL>>)>>>
  62                         <NEWTYPE .NAM .RPRIM .LL>)
  63                        (T
  64                         <NEWTYPE .NAM .RPRIM .LL>)>)>)
  65          (T
  66           <1  .LL .RPRIM>
  67           <EVAL <FORM GDECL .NAM .LL>>
  68           <SET NAM <1 .NAM>>)>
  69         <COND (.EXPSPLICE
  70                <RETURN <CHTYPE <REST .HEAD> SPLICE>>)
  71               (<RETURN .NAM>)>)
  72        (<LENGTH? .ELEM 1> <ERROR NEWSTRUC>)>
  73       <SET OFFS <1 .ELEM>>
  74       <SET DEC <2 .ELEM>>
  75       <COND (<OR <NOT .OFFS> <TYPE? .OFFS FORM>>
  76              <SET CNT <+ .CNT 1>>
  77              <SET ELEM <REST .ELEM>>
  78              <AGAIN>)>
  79       <COND (<AND <TYPE? .OFFS STRING> <=? .OFFS "REST">>
  80              <AND <ASSIGNED? RR> <ERROR NEWSTRUC TWO-RESTS>>
  81              <SET R .L>
  82              <SET RR <SET L <LIST REST>>>
  83              <SET ELEM <REST .ELEM>>
  84              <AGAIN>)
  85             (<TYPE? .OFFS ATOM>
  86              <SETG .OFFS <OFFSET .CNT .NAM .DEC>>
  87              <MANIFEST .OFFS>
  88              <COND (.EXPSPLICE
  89                     <PUTREST .TAIL
  90                              (<FORM SETG .OFFS ,.OFFS>
  91                               <FORM MANIFEST .OFFS>)>
  92                     <SET TAIL <REST .TAIL 2>>)>)
  93             (<TYPE? .OFFS LIST>
  94              <MAPF <>
  95                    <FUNCTION (A)
  96                       <SETG .A <OFFSET .CNT .NAM .DEC>>
  97                       <MANIFEST .A>
  98                       <COND (.EXPSPLICE
  99                              <PUTREST .TAIL
 100                                       (<FORM SETG .A ,.A>
 101                                        <FORM MANIFEST .OFFS>)>
 102                              <SET TAIL <REST .TAIL 2>>)>>
 103                    .OFFS>)
 104             (T <ERROR NEWSTRUC>)>
 105       <SET CNT <+ .CNT 1>>
 106       <SET L <REST <PUTREST .L (.DEC)>>>
 107       <SET ELEM <REST .ELEM 2>>>>
 108
 109 <ENDPACKAGE>