1		% (c) 2009-2019 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, record_has_multiple_field_names/2,
9		check_field_name_compatibility/2
10		]).
11
12
13		:- use_module(self_check).
14		:- use_module(debug).
15		:- use_module(tools).
16		:- use_module(typechecker).
17		:- use_module(error_manager).
18
19		:- use_module(module_information,[module_info/2]).
20		:- module_info(group,kernel).
21		:- module_info(description,'This module contains predicates that operate on the record type.').
22
23		:- assert_must_succeed(( kernel_records:normalise_record_type(
24		record([field(name,global('ID')),field(balance,integer)]),X),
25		X= record([field(balance,integer),field(name,global('ID'))]) )).
26		:- assert_must_succeed(( kernel_records:normalise_record_type(
27		record([field(balance,integer),field(name,global('ID'))]),X),
28		X= record([field(balance,integer),field(name,global('ID'))]) )).
29		:- assert_must_succeed(( kernel_records:normalise_record_type(
30		record([field(b,d),field(a,c)]),X),
31		X= record([field(a,c),field(b,d)]) )).
32
33		normalise_record_type(record(Fields),record(SortedFields)) :-
34		check_known_field_names(Fields),
35		sort(Fields,SortedFields).
36
37
38		:- use_module(kernel_waitflags).
39		:- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF),
40		kernel_records:is_a_record_wf(rec([field(balance,int(1)),field(name,fd(2,'Name'))]),
41		rec([field(balance,global_set('NAT')),field(name,global_set('Name'))]),WF),
42		kernel_waitflags:ground_wait_flags(WF))).
43		:- assert_must_fail(( kernel_waitflags:init_wait_flags(WF),
44		kernel_records:is_a_record_wf(rec([field(a,int(0)),field(b,fd(2,'Name'))]),
45		rec([field(a,global_set('NAT1')),field(b,global_set('Name'))]),WF),
46		kernel_waitflags:ground_wait_flags(WF))).
47		:- assert_must_fail(( kernel_waitflags:init_wait_flags(WF),
48		kernel_records:is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(0))]),
49		rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF),
50		kernel_waitflags:ground_wait_flags(WF))).
51
52
53		is_a_record_wf(rec(Fields),rec(FieldSets),WF) :- %print_message(check_is_a_record(Record,FieldSets)),
54		check_field_values(Fields,FieldSets,WF).
55
56
57		:-use_module(kernel_objects,[check_element_of_wf/3, membership_test_wf/4]).
58
59		:- block check_field_values(-,-,?).
60		check_field_values([],[],_WF).
61		check_field_values([field(Name,V)|ValueRest],[field(Name,VT)|TypeRest],WF) :-
62		check_element_of_wf(V,VT,WF),
63		check_field_values(ValueRest,TypeRest,WF).
64
65
66
67		:- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF),
68		kernel_records:not_is_a_record_wf(rec([field(balance,int(0)),field(name,fd(2,'Name'))]),
69		rec([field(balance,global_set('NAT1')),field(name,global_set('Name'))]),WF),
70		kernel_waitflags:ground_wait_flags(WF))).
71		:- assert_must_succeed(( kernel_waitflags:init_wait_flags(WF),
72		kernel_records:not_is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(0))]),
73		rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF),
74		kernel_waitflags:ground_wait_flags(WF))).
75		:- assert_must_fail(( kernel_waitflags:init_wait_flags(WF),
76		kernel_records:not_is_a_record_wf(rec([field(a,int(1)),field(b,fd(2,'Name')),field(c,int(1))]),
77		rec([field(a,global_set('NAT1')),field(b,global_set('Name')),field(c,global_set('NAT1'))]),WF),
78		kernel_waitflags:ground_wait_flags(WF))).
79
80		not_is_a_record_wf(rec(Fields),rec(FieldSets),WF) :-
81		not_check_field_values(Fields,FieldSets,WF).
82		%print_message(not_is_a_record(Record,FieldSets,WF)).
83
84
85		:- block not_check_field_values(-,-,?).
86		not_check_field_values([field(Name,V)|ValueRest],[field(Name,VT)|TypeRest],WF) :-
87		membership_test_wf(VT,V,MemRes,WF),
88		not_check_field_values2(MemRes,ValueRest,TypeRest,WF).
89
90		:- block not_check_field_values2(-,?,?,?).
91		not_check_field_values2(pred_false,_,_,_).
92		not_check_field_values2(pred_true,ValueRest,TypeRest,WF) :-
93		not_check_field_values(ValueRest,TypeRest,WF).
94
95
96
97
98
99		:- assert_must_fail(( X = [field(b,int(33)),field(a,int(2))], kernel_records:construct_record_wf(X,rec(X),_WF) )).
100		:- assert_must_succeed(( kernel_records:construct_record_wf(X,rec([field(a,int(2)),field(b,int(3))]),_WF),
101		X = [field(b,int(3)),field(a,int(2))] )).
102		:- assert_must_succeed(( kernel_records:construct_record_wf(X,rec([field(a,int(2)),field(b,int(3))]),_WF),
103		X = [field(a,int(2)),field(b,int(3))] )).
104		:- assert_must_succeed(( kernel_records:construct_record_wf(X,Y,_WF),
105		X = [field(b,int(4)),field(a,int(2))], Y = rec([field(a,int(2)),field(b,int(4))]) )).
106		:- 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))] )).
107
108		:- block construct_record_wf(-,?,?).
109		construct_record_wf(Fields,Res,WF) :-
110		check_known_field_names(Fields),
111		sort(Fields,SortedFields),
112		kernel_objects:equal_object_wf(Res,rec(SortedFields),WF).
113
114		check_known_field_names(Var) :- var(Var), !,
115		add_internal_error('Illegal var fields: ',check_known_field_names(Var)).
116		check_known_field_names([]).
117		check_known_field_names([field(Name,_)|T]) :-
118		(var(Name) -> add_internal_error('Illegal var fields: ',check_known_field_names([field(Name,_)|T]))
119		; true),
120		check_known_field_names(T).
121
122
123
124		%instantiate output argument when all field names known + indicate whether sorted or not
125		%:- block known_field_names(-,?).
126		%known_field_names([],sorted).
127		%known_field_names([field(Name,_)|T],Known) :- known_field_names4(T,Name,sorted,Known).
128		%
129		%:- block known_field_names4(-,?,?,?),known_field_names4(?,-,?,?).
130		%known_field_names4([],_,K,K).
131		%known_field_names4([field(Name,_)|T],PrevName,SortedSoFar,Known) :-
132		% (PrevName @< Name -> S2=SortedSoFar ; S2=not_sorted),
133		% known_field_names4(T,Name,S2,Known).
134
135
136
137		% check if a sorted records has multiple field names
138		record_has_multiple_field_names([field(N,_)|T],Res) :- multiple_fields_aux(T,N,Res).
139		multiple_fields_aux([field(N,_)|T],N1,Res) :-
140		(N1=N -> Res=N ; multiple_fields_aux(T,N,Res)).
141
142		:- use_module(library(lists)).
143
144		%%:- assert_must_fail(( kernel_records:access_record(rec([]),a,_) )). %% actually: must generate error; not just fail
145		:- assert_must_fail(( kernel_records:access_record(rec([field(a,int(2))]),a,int(3)) )).
146		:- assert_must_succeed(( kernel_records:access_record(rec(X),a,int(2)), X=[field(b,_),field(a,int(2))|_] )).
147		:- assert_must_succeed(( kernel_records:access_record(rec(X),b,int(2)), X=[field(b,_),field(a,int(3))|_] )).
148
149		access_record(Rec,Field,V) :- access_record_wf(Rec,Field,V,no_wf_available).
150
151		%access_record(X,Y,Z) :- print_message(access_record(X,Y,Z)),fail.
152		:- block access_record_wf(?,-,?,?). % when we add access_record_wf(-,?,?,?) we do not instantiate to rec(_), but PROB-356 runs slower.
153		access_record_wf(rec(Fields),FieldName,Value,WF) :-
154		% access_record2(Fields,FieldName,Value).
155		%:- block access_record2(?,-,?).
156		%access_record2(Fields,FieldName,Value) :-
157		get_field(Fields,FieldName,Value,Fields,WF).
158
159		:- block get_field(-,?,?,?,?).
160		get_field([],FieldName,_Value,OrigFields,_WF) :-
161		add_internal_error('Could not get field: ', FieldName:OrigFields),fail.
162		get_field([field(SFieldName,SValue)|T], FieldName,Value,OrigFields,WF) :-
163		get_field2(SFieldName,SValue,T, FieldName,Value,OrigFields,WF).
164
165		:- block get_field2(-,?,?, ?,?,?,?).
166		get_field2(SFieldName,SValue,T, FieldName,Value,OrigFields,WF) :-
167		(SFieldName=FieldName
168		-> kernel_objects:equal_object_wf(Value,SValue,get_field2,WF)
169		; get_field(T,FieldName,Value,OrigFields,WF)
170		).
171
172
173
174		:- assert_must_succeed(( kernel_records:check_field_name_compatibility(a,a))).
175		check_field_name_compatibility(Name1,Name2) :-
176		nonvar(Name1), nonvar(Name2), Name1 \= Name2, !,
177		add_internal_error('Incompatible fields: ',check_field_name_compatibility(Name1,Name2)),
178		fail.
179		check_field_name_compatibility(Name,Name).