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 8eval_when([translate,batch,demo], 9 load_package(sharem,"autolo"))$ 10 11herald_package(defstm)$ 12 13eval_when([batch,demo,loadfile],matchfix("{","}"))$ 14 15assess_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: 21mode(type,slot_name)[= default value] , not",x)$ 22 23name_of_slot_id(x):=if symbolp(x) then x else part(x,1)$ 24 25mode_declare(function(equal_op),boolean)$ 26 27equal_op(x):=if not(atom(x)) and part(x,0)="=" then true$ 28 29slot_type(types,index):=if listp(types) then types[index] else types$ 30 31obtain_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 87define_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 91def_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 234initialize_structure_list():=%%existing_structures%%:[]$ 235 236save_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)))$ 245