share/macro/defstm.mac

   1 /*-*-Macsyma-*-*/
   2 /*    (c) Copyright 1984 the Regents of the University of California.
   3           All Rights Reserved.
   4           This work was produced under the sponsorship of the
   5           U.S. Department of Energy.  The Government retains
   6           certain rights therein.                                     */
   7
   8 eval_when([translate,batch,demo],
   9           load_package(sharem,"autolo"))$
  10
  11 herald_package(defstm)$
  12
  13 eval_when([batch,demo,loadfile],matchfix("{","}"))$
  14
  15 assess_mode(x):=
  16    if not(symbolp(x)) then
  17       if part(x,0)='mode and length(x)=2 and
  18          symbolp(part(x,1)) and symbolp(part(x,2))
  19         then part(x,2)
  20       else error("if slot name identifier is not a symbol, it must be of the following form:
  21 mode(type,slot_name)[= default value] , not",x)$
  22
  23 name_of_slot_id(x):=if symbolp(x) then x else part(x,1)$
  24
  25 mode_declare(function(equal_op),boolean)$
  26
  27 equal_op(x):=if not(atom(x)) and part(x,0)="=" then true$
  28
  29 slot_type(types,index):=if listp(types) then types[index] else types$
  30
  31 obtain_default_value_for_mode(mode):=
  32    caseq(mode,
  33          [fixnum,rational],0,
  34          [boolean],false,
  35          [float,number],0.0,
  36          [list],[],
  37          otherwise,buildq([],'%undefined%))$
  38
  39 %aux_alterant%(alt,extend_name,slot_names,quan,mode_type,obj,args):=
  40   (mode_declare([slot_names,args],list,quan,fixnum),
  41    block([result:[]],
  42       mode_declare(result,list),
  43       for ele in args do
  44          block([nom],
  45             cond(not equal_op(ele),
  46                  error("alterant argument must specify a value:",ele),
  47
  48                  not(member(nom:lhs(ele),slot_names)),
  49                  error("incorrect slot specifier to",alt,":",nom),
  50
  51                  true,
  52                  for i thru quan do
  53                     if slot_names[i]=nom then
  54                        return(result:endcons(buildq([i,val:rhs(ele),
  55                                                      type:slot_type(mode_type,i)],
  56                                                 extend_set(temp,i,mode_identity(type,val))),
  57                                              result)))),
  58       if length(result)=0 then false
  59       else
  60          buildq([result,obj,alt,extend_name],
  61             block([temp:obj],
  62                alter_extend_check(temp,'alt,'extend_name),
  63                splice(result),
  64                mode_identity(extend_name,temp)))))$
  65
  66 %aux_constructor%(construct,slot_names,defaults,quan,mode_type,name,args):=
  67   (mode_declare([slot_names,defaults,args],list,quan,fixnum),
  68    block([inits:?copy\-tree(defaults)],
  69       mode_declare(inits,list),
  70       for ele in args do
  71          block([nom],
  72             cond(not equal_op(ele),
  73                  error("constructor argument must specify a value:",ele),
  74
  75                  not(member(nom:lhs(ele),slot_names)),
  76                  error("incorrect slot specifier to",construct,":",nom),
  77
  78                  true,
  79                  for i thru quan do
  80                     if slot_names[i]=nom then
  81                        return(inits[i]:buildq([val:rhs(ele),
  82                                                type:slot_type(mode_type,i)],
  83                                           mode_identity(type,val))))),
  84       buildq([inits,name],
  85           mode_identity(name,make_extend('name,splice(inits))))))$
  86
  87 define_variable(%%existing_structures%%,[],list,
  88     "hack to allow the properties of only those structures in a file being
  89      translated to appear in the runtime portion of the translated output.")$
  90
  91 def_structure(name,options,[slots])::=
  92  (mode_declare([options,slots],list),
  93   block([construct:concat('make_,name),alt:concat('alter_,name),mode_type:'any,
  94          conc:false,include:false,included_values:false,first:false,quan,
  95          slot_num:1,default_value:buildq([],'%undefined%),inc_modes],
  96      mode_declare([quan,slot_num],fixnum),
  97      if not(symbolp(name)) then
  98          error("first argument to def_structure must be a name",name),
  99      quan:length(slots),
 100      for option in options do
 101         if not(atom(option)) and lhs(option)='mode then
 102            block([value:rhs(option)],
 103               mode_type:value,
 104               default_value:obtain_default_value_for_mode(mode_type)),
 105      for option in options do
 106        if atom(option) then
 107           caseq(option,
 108                 [but_first,include,mode],error("the",option,"option to def_structure must have a value"),
 109                 [conc_name],conc:concat(name,"_"),
 110                 [constructor,alterant],'done,
 111                 otherwise,error("unknown option to def_structure",option))
 112        else
 113           block([value:rhs(option)],
 114            block([multiple_valuesp:listp(value),selector:lhs(option)],
 115               mode_declare(multiple_valuesp,boolean),
 116               if member(selector,'[constructor,alterant,conc_name,but_first,mode]) then
 117                  if multiple_valuesp then
 118                     error("only the include option to def_structure can have a list as its rhs:",option)
 119                  else
 120                     if not(symbolp(value)) then
 121                        error("rhs of option",selector,"must be a name"),
 122               caseq(selector,
 123                     [constructor],construct:value,
 124                     [alterant],alt:value,
 125                     [conc_name],conc:value,
 126                     [but_first],first:value,
 127                     [include],
 128                     block([],
 129                       include:if multiple_valuesp then first(value) else value,
 130                       if not(symbolp(include)) then
 131                          error("first element of rhs list for include option to def_structure must be a name",include),
 132                       inc_modes:get(include,'mode_types),
 133                       if multiple_valuesp then
 134                          block([n_slots:length(value)-1],
 135                             mode_declare(n_slots,fixnum),
 136                             if get(include,'n_args)#n_slots then
 137                               error("incorrect number of slot initializations given to include option of def_structure"),
 138                             included_values:
 139                               block([defaults:makelist(default_value,m,1,n_slots),
 140                                      specs:rest(value),names:get(include,'slot_names)],
 141                                  slot_num:slot_num+n_slots,
 142                                  for i thru n_slots do
 143                                     block([arg:specs[i]],
 144                                        block([eqp:equal_op(arg)],
 145                                           mode_declare(eqp,boolean),
 146                                           block([name_spec:if eqp then lhs(arg) else arg],
 147                                              block([typ:assess_mode(name_spec),
 148                                                     t:name_of_slot_id(name_spec)],
 149                                                 if not(member(t,names)) then
 150                                                    error(arg,"is a bad slot name for",include)
 151                                                 else
 152                                                    catch(for m thru n_slots do
 153                                                             if t=names[m] then
 154                                                               block([dm:slot_type(inc_modes,m)],
 155                                                                  if typ and typ#dm then
 156                                                                    error("mode spec for included slot disagrees with slot from original structure"),
 157                                                                  throw(if eqp then
 158                                                                           (defaults[m]:buildq([val:rhs(arg)],val),
 159                                                                            apply('mode_identity,[dm,rhs(arg)]))))))))),
 160                                  defaults))),
 161                     [mode],'done,
 162                     otherwise,error("unknown option to def_structure",selector)))),
 163      block([defaults:makelist(default_value,m,1,quan),
 164             slot_names:[],ret_macros:[],accessors:[]],
 165         for i thru quan do
 166           block([slot:slots[i]],
 167              block([eqp:equal_op(slot)],
 168                 mode_declare(eqp,boolean),
 169                 block([nom_spec:if eqp then lhs(slot) else slot],
 170                    block([type:assess_mode(nom_spec),typed],
 171                       mode_declare(typed,boolean),
 172                       if typed:is(type#false) then
 173                          (if atom(mode_type) and type#mode_type then
 174                              mode_type:makelist(mode_type,m,1,quan),
 175                           if listp(mode_type) then
 176                             (mode_type[i]:type,
 177                              defaults[i]:obtain_default_value_for_mode(type))),
 178                       slot_names:endcons(name_of_slot_id(nom_spec),slot_names),
 179                       if eqp then
 180                          (defaults[i]:buildq([val:rhs(slot)],val),
 181                           apply('mode_identity,
 182                                 [if typed then type else slot_type(mode_type,i),
 183                                  defaults[i]])))))),
 184         accessors:if conc=false then slot_names
 185                   else makelist(concat(conc,slot_names[k]),k,1,quan),
 186         block([arg:if first=false then '%x_%
 187                    else buildq([funct:first],funct(%x_%))],
 188           for j thru quan do
 189             (ret_macros:endcons(buildq([slot_num,element:accessors[j],arg,
 190                                         name,lamode:slot_type(mode_type,j)],
 191                                    element(%x_%)::=
 192                                       buildq([%x_%],
 193                                         mode_identity(lamode,reference_an_extend(arg,'element,'name,slot_num)))),
 194                                 ret_macros),
 195              slot_num:slot_num+1)),
 196        if include#false then
 197           (accessors:append(get(include,'accessors),accessors),
 198            slot_names:append(get(include,'slot_names),slot_names),
 199            mode_type:cond(listp(mode_type),
 200                           append(if listp(inc_modes) then inc_modes
 201                                  else makelist(inc_modes,m,1,get(include,'n_args)),
 202                                  mode_type),
 203
 204                           listp(inc_modes),
 205                           append(inc_modes,makelist(mode_type,m,1,quan)),
 206
 207                           mode_type#inc_modes,
 208                           append(makelist(inc_modes,m,1,get(include,'n_args)),
 209                                  makelist(mode_type,m,1,quan))),
 210            defaults:append(if included_values=false then get(include,'defaults)
 211                            else included_values,
 212                            defaults),
 213            quan:length(defaults)),
 214        push(name,%%existing_structures%%),
 215        put(name,quan,'n_args),
 216        put(name,defaults,'defaults),
 217        put(name,accessors,'accessors),
 218        put(name,slot_names,'slot_names),
 219        put(name,mode_type,'mode_types),
 220        if alt#false then
 221          ret_macros:cons(buildq([alt,slot_names,quan,mode_type,name],
 222                             alt(%obj_%,[%args_%])::=
 223                                 %aux_alterant%('alt,'name,'slot_names,quan,
 224                                                'mode_type,%obj_%,%args_%)),
 225                          ret_macros),
 226        if construct#false then
 227          ret_macros:cons(buildq([construct,slot_names,defaults,quan,mode_type,name],
 228                             construct([%args_%])::=
 229                                  %aux_constructor%('construct,'slot_names,'defaults,
 230                                                    quan,'mode_type,'name,%args_%)),
 231                          ret_macros),
 232        buildq([name,ret_macros],(splice(ret_macros),'name)))))$
 233
 234 initialize_structure_list():=%%existing_structures%%:[]$
 235
 236 save_runtime_structure_info(file):=
 237  block([path:?merge\-pathname\-defaults('?"=.lsp",?stripdollar(file))],
 238     block([nfile:?intern(?namestring(path)),
 239            name:concat(?intern(?pathname\-name(path))),
 240            version_no:?pathname\-version(path)],
 241        put(name,if version_no=false then '%unknown% else version_no,'version),
 242        apply('save,append([nfile,name,'"{"],%%existing_structures%%)),
 243        %%existing_structures%%:[],
 244        compile_lisp_file(nfile)))$