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