1 | % (c) 2009-2023 Lehrstuhl fuer Softwaretechnik und Programmiersprachen, | |
2 | % Heinrich Heine Universitaet Duesseldorf | |
3 | % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html) | |
4 | ||
5 | :- module(kernel_records,[is_a_record_wf/3, not_is_a_record_wf/3, | |
6 | construct_record_wf/3, | |
7 | access_record_wf/4, | |
8 | normalise_record_type/2, normalise_record_types/4, | |
9 | record_has_multiple_field_names/2, | |
10 | check_field_name_compatibility/3, | |
11 | overwrite_record_wf/5 | |
12 | ]). | |
13 | ||
14 | ||
15 | :- use_module(self_check). | |
16 | :- use_module(debug). | |
17 | :- use_module(tools). | |
18 | :- use_module(typechecker). | |
19 | :- use_module(error_manager). | |
20 | :- use_module(library(samsort),[samsort/2]). | |
21 | ||
22 | :- use_module(module_information,[module_info/2]). | |
23 | :- module_info(group,kernel). | |
24 | :- module_info(description,'This module contains predicates that operate on the record type.'). | |
25 | ||
26 | :- assert_must_succeed(( kernel_records:normalise_record_type( | |
27 | record([field(name,global('ID')),field(balance,integer)]),X), | |
28 | X == record([field(balance,integer),field(name,global('ID'))]) )). | |
29 | :- assert_must_succeed(( kernel_records:normalise_record_type( | |
30 | record([field(balance,integer),field(name,global('ID'))]),X), | |
31 | X == record([field(balance,integer),field(name,global('ID'))]) )). | |
32 | :- assert_must_succeed(( kernel_records:normalise_record_type( | |
33 | record([field(b,d),field(a,c)]),X), | |
34 | X == record([field(a,c),field(b,d)]) )). | |
35 | ||
36 | % just normalise a top-level record type | |
37 | normalise_record_type(record(Fields),record(SortedFields)) :- | |
38 | check_known_field_names(Fields), | |
39 | samsort(Fields,SortedFields). % Note: this will not remove duplicates with same type ! | |
40 | ||
41 | ||
42 | :- assert_must_succeed(( kernel_records:normalise_record_types( | |
43 | record([field(name,global('ID')),field(balance,integer)]),[],X,HR), HR==true, | |
44 | X == record([field(balance,integer),field(name,global('ID'))]) )). | |
45 | :- assert_must_succeed(( kernel_records:normalise_record_types( | |
46 | set(record([field(name,global('ID')),field(balance,integer)])),[],X, HR), HR==true, | |
47 | X == set(record([field(balance,integer),field(name,global('ID'))])) )). | |
48 | ||
49 | :- use_module(probsrc(tools),[exact_member/2]). | |
50 | ||
51 | % normalise all record types within a type and instantiate HasRecords if a record is encountered | |
52 | % allows variables | |
53 | normalise_record_types(Var,NonGroundExceptions,R,_) :- var(Var), !, | |
54 | (NonGroundExceptions=do_not_ground_types -> true % TODO: check if Var in NonGroundExceptions | |
55 | ; exact_member(Var,NonGroundExceptions) -> true | |
56 | ; add_internal_error('Variable type:',normalise_record_types(Var,NonGroundExceptions,R,_))), | |
57 | R=Var. | |
58 | normalise_record_types(couple(TA,TB),NonGroundExceptions,couple(NTA,NTB),HasRecords) :- !, | |
59 | normalise_record_types(TA,NonGroundExceptions,NTA,HasRecords), | |
60 | normalise_record_types(TB,NonGroundExceptions,NTB,HasRecords). | |
61 | normalise_record_types(seq(T),NonGroundExceptions,seq(NT),HasRecords) :- !, | |
62 | normalise_record_types(T,NonGroundExceptions,NT,HasRecords). | |
63 | normalise_record_types(set(T),NonGroundExceptions,set(NT),HasRecords) :- !, | |
64 | normalise_record_types(T,NonGroundExceptions,NT,HasRecords). | |
65 | normalise_record_types(record(Fields),NonGroundExceptions,record(SortedFields),HasRecords) :- !, HasRecords=true, | |
66 | normalise_fields(Fields,NonGroundExceptions,NFields,HasVar), | |
67 | (HasVar==true | |
68 | -> SortedFields=NFields, | |
69 | debug_format(9,'Record type with partially known fields: ~w~n',[Fields]) | |
70 | % grounding_open_ended_record | |
71 | ; samsort(NFields,SortedFields)). % Note: this will not remove duplicates with same type ! | |
72 | normalise_record_types(AtomicType,_,AtomicType,_). | |
73 | ||
74 | normalise_fields(Var,NonGroundExceptions,Res,HasVar) :- var(Var), !, | |
75 | (NonGroundExceptions=do_not_ground_types -> true | |
76 | ; add_internal_error('Variable fields:',normalise_fields(Var,NonGroundExceptions,Res,HasVar))), | |
77 | HasVar=true, Res=Var. | |
78 | normalise_fields([],_,[],_). | |
79 | normalise_fields([field(Name,FieldType)|T],NonGroundExceptions,[field(Name,NFieldType)|NT],HasVar) :- | |
80 | (var(Name) | |
81 | -> add_internal_error('Illegal var fields: ',normalise_fields([field(Name,_)|T])), | |
82 | HasVar=true | |
83 | ; true), | |
84 | normalise_record_types(FieldType,NonGroundExceptions,NFieldType,HasVar), | |
85 | normalise_fields(T,NonGroundExceptions,NT,HasVar). | |
86 | ||
87 | :- use_module(kernel_waitflags). | |
88 | :- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF), | |
89 | kernel_records:is_a_record_wf(rec([field(balance,int(1)),field(name,fd(2,'Name'))]), | |
90 | rec([field(balance,global_set('NAT')),field(name,global_set('Name'))]),WF), | |
91 | kernel_waitflags:ground_wait_flags(WF))). | |
92 | :- assert_must_fail(( kernel_waitflags:init_wait_flags(WF), | |
93 | kernel_records:is_a_record_wf(rec([field(a,int(0)),field(b,fd(2,'Name'))]), | |
94 | rec([field(a,global_set('NAT1')),field(b,global_set('Name'))]),WF), | |
95 | kernel_waitflags:ground_wait_flags(WF))). | |
96 | :- assert_must_fail(( kernel_waitflags:init_wait_flags(WF), | |
97 | kernel_records:is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(0))]), | |
98 | rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF), | |
99 | kernel_waitflags:ground_wait_flags(WF))). | |
100 | ||
101 | ||
102 | is_a_record_wf(rec(Fields),rec(FieldSets),WF) :- | |
103 | check_field_values(Fields,FieldSets,WF). | |
104 | ||
105 | ||
106 | :-use_module(kernel_objects,[check_element_of_wf/3, membership_test_wf/4]). | |
107 | ||
108 | :- block check_field_values(-,-,?). | |
109 | check_field_values([],[],_WF). | |
110 | check_field_values([field(Name1,V)|ValueRest],[field(Name2,VT)|TypeRest],WF) :- | |
111 | check_field_name_compatibility(Name1,Name2,check_field_values), | |
112 | check_element_of_wf(V,VT,WF), | |
113 | check_field_values(ValueRest,TypeRest,WF). | |
114 | ||
115 | ||
116 | :- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF), | |
117 | kernel_records:not_is_a_record_wf(rec([field(balance,int(0)),field(name,fd(2,'Name'))]), | |
118 | rec([field(balance,global_set('NAT1')),field(name,global_set('Name'))]),WF), | |
119 | kernel_waitflags:ground_wait_flags(WF))). | |
120 | :- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF), | |
121 | kernel_records:not_is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(0))]), | |
122 | rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF), | |
123 | kernel_waitflags:ground_wait_flags(WF))). | |
124 | :- assert_must_fail(( kernel_waitflags:init_wait_flags(WF), | |
125 | kernel_records:not_is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(1))]), | |
126 | rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF), | |
127 | kernel_waitflags:ground_wait_flags(WF))). | |
128 | ||
129 | not_is_a_record_wf(rec(Fields),rec(FieldSets),WF) :- | |
130 | not_check_field_values(Fields,FieldSets,WF). | |
131 | ||
132 | ||
133 | :- block not_check_field_values(-,-,?). | |
134 | not_check_field_values([field(Name1,V)|ValueRest],[field(Name2,VT)|TypeRest],WF) :- | |
135 | check_field_name_compatibility(Name1,Name2,not_check_field_values), | |
136 | membership_test_wf(VT,V,MemRes,WF), | |
137 | not_check_field_values2(MemRes,ValueRest,TypeRest,WF). | |
138 | ||
139 | :- block not_check_field_values2(-,?,?,?). | |
140 | not_check_field_values2(pred_false,_,_,_). | |
141 | not_check_field_values2(pred_true,ValueRest,TypeRest,WF) :- | |
142 | not_check_field_values(ValueRest,TypeRest,WF). | |
143 | ||
144 | ||
145 | ||
146 | ||
147 | ||
148 | :- assert_must_fail(( X = [field(b,int(33)),field(a,int(2))], X2 = [field(a,int(33)),field(b,int(2))], kernel_records:construct_record_wf(X,rec(X2),_WF) )). | |
149 | :- assert_must_succeed(( kernel_records:construct_record_wf(X,rec([field(a,int(2)),field(b,int(3))]),_WF), | |
150 | X = [field(b,int(3)),field(a,int(2))] )). | |
151 | :- assert_must_succeed(( kernel_records:construct_record_wf(X,rec([field(a,int(2)),field(b,int(3))]),_WF), | |
152 | X = [field(a,int(2)),field(b,int(3))] )). | |
153 | :- assert_must_succeed(( kernel_records:construct_record_wf(X,Y,_WF), | |
154 | X = [field(b,int(4)),field(a,int(2))], Y = rec([field(a,int(2)),field(b,int(4))]) )). | |
155 | :- assert_must_succeed(( kernel_records:construct_record_wf(X,rec([field(a,[int(2),int(3)]),field(b,int(3))]),_WF), X = [field(a,[int(3),int(2)]),field(b,int(3))] )). | |
156 | ||
157 | :- block construct_record_wf(-,?,?). | |
158 | construct_record_wf(Fields,Res,WF) :- | |
159 | check_known_field_names(Fields), | |
160 | sort(Fields,SortedFields), | |
161 | kernel_objects:equal_object_wf(Res,rec(SortedFields),WF). | |
162 | ||
163 | check_known_field_names(Var) :- var(Var), !, | |
164 | add_internal_error('Illegal var fields: ',check_known_field_names(Var)). | |
165 | check_known_field_names([]). | |
166 | check_known_field_names([field(Name,_)|T]) :- | |
167 | (var(Name) -> add_internal_error('Illegal var fields: ',check_known_field_names([field(Name,_)|T])) | |
168 | ; true), | |
169 | check_known_field_names(T). | |
170 | ||
171 | ||
172 | ||
173 | %instantiate output argument when all field names known + indicate whether sorted or not | |
174 | %:- block known_field_names(-,?). | |
175 | %known_field_names([],sorted). | |
176 | %known_field_names([field(Name,_)|T],Known) :- known_field_names4(T,Name,sorted,Known). | |
177 | % | |
178 | %:- block known_field_names4(-,?,?,?),known_field_names4(?,-,?,?). | |
179 | %known_field_names4([],_,K,K). | |
180 | %known_field_names4([field(Name,_)|T],PrevName,SortedSoFar,Known) :- | |
181 | % (PrevName @< Name -> S2=SortedSoFar ; S2=not_sorted), | |
182 | % known_field_names4(T,Name,S2,Known). | |
183 | ||
184 | ||
185 | ||
186 | % check if a sorted records has multiple field names | |
187 | record_has_multiple_field_names([field(N,_)|T],Res) :- multiple_fields_aux(T,N,Res). | |
188 | multiple_fields_aux([field(N,_)|T],N1,Res) :- | |
189 | (N1=N -> Res=N ; multiple_fields_aux(T,N,Res)). | |
190 | ||
191 | :- use_module(library(lists)). | |
192 | ||
193 | %%:- assert_must_fail(( kernel_records:access_record(rec([]),a,_) )). %% actually: must generate error; not just fail | |
194 | :- assert_must_fail(( kernel_records:access_record(rec([field(a,int(2))]),a,int(3)) )). | |
195 | :- assert_must_succeed(( kernel_records:access_record(rec(X),a,int(2)), X=[field(b,_),field(a,int(2))|_] )). | |
196 | :- assert_must_succeed(( kernel_records:access_record(rec(X),b,int(2)), X=[field(b,_),field(a,int(3))|_] )). | |
197 | ||
198 | access_record(Rec,Field,V) :- access_record_wf(Rec,Field,V,no_wf_available). | |
199 | ||
200 | %access_record(X,Y,Z) :- print_message(access_record(X,Y,Z)),fail. | |
201 | :- block access_record_wf(?,-,?,?). % when we add access_record_wf(-,?,?,?) we do not instantiate to rec(_), but PROB-356 runs slower. | |
202 | access_record_wf(rec(Fields),FieldName,Value,WF) :- | |
203 | % access_record2(Fields,FieldName,Value). | |
204 | %:- block access_record2(?,-,?). | |
205 | %access_record2(Fields,FieldName,Value) :- | |
206 | get_field(Fields,FieldName,Value,Fields,WF). | |
207 | ||
208 | :- block get_field(-,?,?,?,?). % note: FieldName is already known | |
209 | get_field([],FieldName,_Value,OrigFields,_WF) :- | |
210 | add_internal_error('Could not get field: ', FieldName:OrigFields),fail. | |
211 | get_field([field(SFieldName,SValue)|T], FieldName,Value,OrigFields,WF) :- | |
212 | get_field2(SFieldName,SValue,T, FieldName,Value,OrigFields,WF). | |
213 | ||
214 | :- block get_field2(-,?,?, ?,?,?,?). | |
215 | get_field2(SFieldName,SValue,T, FieldName,Value,OrigFields,WF) :- | |
216 | (SFieldName=FieldName | |
217 | -> kernel_objects:equal_object_wf(Value,SValue,get_field2,WF) | |
218 | ; get_field(T,FieldName,Value,OrigFields,WF) | |
219 | ). | |
220 | ||
221 | ||
222 | ||
223 | % try and unify field names and throw error if unification fails | |
224 | % indicates an incorrectly sorted field | |
225 | :- assert_must_succeed(( kernel_records:check_field_name_compatibility(a,a,test))). | |
226 | check_field_name_compatibility(Name1,Name2,Origin) :- | |
227 | nonvar(Name1), nonvar(Name2), Name1 \= Name2, !, | |
228 | add_internal_error('Incompatible fields: ',check_field_name_compatibility(Name1,Name2,Origin)), | |
229 | fail. | |
230 | check_field_name_compatibility(Name,Name,_). | |
231 | ||
232 | ||
233 | :- assert_must_succeed(( kernel_records:overwrite_record_wf(rec(X),c,int(22),Y,no_wf_available), | |
234 | X=[field(b,int(33)),field(c,int(4))], | |
235 | Y==rec([field(b,int(33)),field(c,int(22))]) )). | |
236 | ||
237 | % overwrite one field of a record, used for assignment x'field := RHS | |
238 | :- block overwrite_record_wf(?,-,?,?,?). | |
239 | overwrite_record_wf(rec(Fields),FieldToChange,ChangedVal,rec(NewFields),WF) :- | |
240 | overwrite_field(Fields,FieldToChange,ChangedVal,NewFields,WF). | |
241 | ||
242 | :- block overwrite_field(-,?,?,?,?). | |
243 | overwrite_field([],FieldToChange,ChangedVal,T,WF) :- | |
244 | add_internal_error('Could not find field to overwrite:',overwrite_field([],FieldToChange,ChangedVal,T,WF)), | |
245 | T=[]. | |
246 | overwrite_field([field(FN,V)|T],FieldToChange,ChangedVal,[field(FN,NewVal)|TN],WF) :- | |
247 | overwrite_field_aux(FN,V,T,FieldToChange,ChangedVal,NewVal,TN,WF). | |
248 | ||
249 | :- block overwrite_field_aux(-,?,?,?,?,?,?,?). | |
250 | overwrite_field_aux(FN,OldVal,T,FieldToChange,ChangedVal,NewVal,TN,WF) :- | |
251 | (FN=FieldToChange | |
252 | -> kernel_objects:equal_object_wf(NewVal,ChangedVal,overwrite_field_aux,WF), | |
253 | kernel_objects:equal_object_wf(rec(T),rec(TN),overwrite_field_aux,WF) | |
254 | ; kernel_objects:equal_object_wf(NewVal,OldVal,overwrite_field_aux,WF), | |
255 | overwrite_field(T,FieldToChange,ChangedVal,TN,WF) | |
256 | ). |