34
35:- module((record),
36 [ (record)/1, 37 current_record/2, 38 current_record_predicate/2, 39 op(1150, fx, record)
40 ]). 41:- use_module(library(error)). 42
64
65:- multifile
66 error:has_type/2,
67 prolog:generated_predicate/1. 68
69error:has_type(record(M:Name), X) :-
70 is_record(Name, M, X).
71
72is_record(Name, M, X) :-
73 current_record(Name, M, _, X, IsX),
74 !,
75 call(M:IsX).
76
101
102record(Record) :-
103 Record == '<compiled>',
104 !.
105record(Record) :-
106 throw(error(context_error(nodirective, record(Record)), _)).
107
108
112
113compile_records(Spec,
114 [ (:- record('<compiled>')) 115 | Clauses 116 ]) :-
117 phrase(compile_records(Spec), Clauses).
119
120compile_records(Var) -->
121 { var(Var),
122 !,
123 instantiation_error(Var)
124 }.
125compile_records((A,B)) -->
126 compile_record(A),
127 compile_records(B).
128compile_records(A) -->
129 compile_record(A).
130
134
135compile_record(RecordDef) -->
136 { RecordDef =.. [Constructor|Args],
137 defaults(Args, Defs, TypedArgs),
138 types(TypedArgs, Names, Types),
139 atom_concat(default_, Constructor, DefName),
140 atom_concat(Constructor, '_data', DataName),
141 DefRecord =.. [Constructor|Defs],
142 DefClause =.. [DefName,DefRecord],
143 length(Names, Arity)
144 },
145 [ DefClause ],
146 access_predicates(Names, 1, Arity, Constructor),
147 data_predicate(Names, 1, Arity, Constructor, DataName),
148 set_predicates(Names, 1, Arity, Types, Constructor),
149 set_field_predicates(Names, 1, Arity, Types, Constructor),
150 make_predicate(Constructor),
151 is_predicate(Constructor, Types),
152 current_clause(RecordDef).
153
154:- meta_predicate
155 current_record(?, :),
156 current_record_predicate(?, :). 157:- multifile
158 current_record/5. 159
165
166current_record(Name, M:Term) :-
167 current_record(Name, M, Term, _, _).
168
169current_clause(RecordDef) -->
170 { prolog_load_context(module, M),
171 functor(RecordDef, Name, _),
172 atom_concat(is_, Name, IsName),
173 IsX =.. [IsName, X]
174 },
175 [ (record):current_record(Name, M, RecordDef, X, IsX)
176 ].
177
178
184
185current_record_predicate(Record, M:PI) :-
186 ( ground(PI)
187 -> Det = true
188 ; Det = false
189 ),
190 current_record(Record, M:RecordDef),
191 ( general_record_pred(Record, M:PI)
192 ; RecordDef =.. [_|Args],
193 defaults(Args, _Defs, TypedArgs),
194 types(TypedArgs, Names, _Types),
195 member(Field, Names),
196 field_record_pred(Record, Field, M:PI)
197 ),
198 ( Det == true
199 -> !
200 ; true
201 ).
202
203general_record_pred(Record, _:Name/1) :-
204 atom_concat(is_, Record, Name).
205general_record_pred(Record, _:Name/1) :-
206 atom_concat(default_, Record, Name).
207general_record_pred(Record, _:Name/A) :-
208 member(A, [2,3]),
209 atom_concat(make_, Record, Name).
210general_record_pred(Record, _:Name/3) :-
211 atom_concat(Record, '_data', Name).
212general_record_pred(Record, _:Name/A) :-
213 member(A, [3,4]),
214 atomic_list_concat([set_, Record, '_fields'], Name).
215general_record_pred(Record, _:Name/3) :-
216 atomic_list_concat([set_, Record, '_field'], Name).
217
218field_record_pred(Record, Field, _:Name/2) :-
219 atomic_list_concat([Record, '_', Field], Name).
220field_record_pred(Record, Field, _:Name/A) :-
221 member(A, [2,3]),
222 atomic_list_concat([set_, Field, '_of_', Record], Name).
223field_record_pred(Record, Field, _:Name/2) :-
224 atomic_list_concat([nb_set_, Field, '_of_', Record], Name).
225
226prolog:generated_predicate(P) :-
227 current_record_predicate(_, P).
228
256
257make_predicate(Constructor) -->
258 { atomic_list_concat([make_, Constructor], MakePredName),
259 atomic_list_concat([default_, Constructor], DefPredName),
260 atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName),
261 atomic_list_concat([set_, Constructor, '_field'], SetFieldName),
262 MakeHead3 =.. [MakePredName, Fields, Record],
263 MakeHead4 =.. [MakePredName, Fields, Record, []],
264 MakeClause3 = (MakeHead3 :- MakeHead4),
265 MakeHead =.. [MakePredName, Fields, Record, RestFields],
266 DefGoal =.. [DefPredName, Record0],
267 SetGoal =.. [SetFieldsName, Fields, Record0, Record, RestFields],
268 MakeClause = (MakeHead :- DefGoal, SetGoal),
269 SetHead3 =.. [SetFieldsName, Fields, R0, R],
270 SetHead4 =.. [SetFieldsName, Fields, R0, R, []],
271 SetClause0 = (SetHead3 :- SetHead4),
272 SetClause1 =.. [SetFieldsName, [], R, R, []],
273 SetHead2 =.. [SetFieldsName, [H|T], R0, R, RF],
274 SetGoal2a =.. [SetFieldName, H, R0, R1],
275 SetGoal2b =.. [SetFieldsName, T, R1, R, RF],
276 SetGoal2c =.. [SetFieldsName, T, R0, R, RF1],
277 SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c))
278 },
279 [ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ].
280
284
285is_predicate(Constructor, Types) -->
286 { type_checks(Types, Vars, Body0),
287 clean_body(Body0, Body),
288 Term =.. [Constructor|Vars],
289 atom_concat(is_, Constructor, Name),
290 Head1 =.. [Name,Var],
291 Head2 =.. [Name,Term]
292 },
293 [ (Head1 :- var(Var), !, fail) ],
294 ( { Body == true }
295 -> [ Head2 ]
296 ; [ (Head2 :- Body) ]
297 ).
298
299type_checks([], [], true).
300type_checks([any|T], [_|Vars], Body) :-
301 type_checks(T, Vars, Body).
302type_checks([Type|T], [V|Vars], (Goal, Body)) :-
303 type_goal(Type, V, Goal),
304 type_checks(T, Vars, Body).
305
309
310type_goal(Type, Var, Body) :-
311 current_type(Type, Var, Body),
312 !.
313type_goal(record(Record), Var, Body) :-
314 !,
315 atom_concat(is_, Record, Pred),
316 Body =.. [Pred,Var].
317type_goal(Record, Var, Body) :-
318 atom(Record),
319 !,
320 atom_concat(is_, Record, Pred),
321 Body =.. [Pred,Var].
322type_goal(Type, _, _) :-
323 domain_error(type, Type).
324
325
326clean_body(Var, G) :-
327 var(Var),
328 !,
329 G = Var.
330clean_body(M:C0, G) :-
331 nonvar(C0),
332 control(C0),
333 !,
334 C0 =.. [Name|Args0],
335 clean_args(Args0, M, Args),
336 G =.. [Name|Args].
337clean_body((A0,true), A) :-
338 !,
339 clean_body(A0, A).
340clean_body((true,A0), A) :-
341 !,
342 clean_body(A0, A).
343clean_body(C0, G) :-
344 control(C0),
345 !,
346 C0 =.. [Name|Args0],
347 clean_args(Args0, Args),
348 G =.. [Name|Args].
349clean_body(_:A, A) :-
350 predicate_property(system:A, built_in),
351 \+ predicate_property(system:A, meta_predicate(_)),
352 !.
353clean_body(A, A).
354
355clean_args([], []).
356clean_args([H0|T0], [H|T]) :-
357 clean_body(H0, H),
358 clean_args(T0, T).
359
360clean_args([], _, []).
361clean_args([H0|T0], M, [H|T]) :-
362 clean_body(M:H0, H),
363 clean_args(T0, M, T).
364
365control((_,_)).
366control((_;_)).
367control((_->_)).
368control((_*->_)).
369control(\+(_)).
370
371
375
376access_predicates([], _, _, _) -->
377 [].
378access_predicates([Name|NT], I, Arity, Constructor) -->
379 { atomic_list_concat([Constructor, '_', Name], PredName),
380 functor(Record, Constructor, Arity),
381 arg(I, Record, Value),
382 Clause =.. [PredName, Record, Value],
383 I2 is I + 1
384 },
385 [Clause],
386 access_predicates(NT, I2, Arity, Constructor).
387
388
392
393data_predicate([], _, _, _, _) -->
394 [].
395data_predicate([Name|NT], I, Arity, Constructor, DataName) -->
396 { functor(Record, Constructor, Arity),
397 arg(I, Record, Value),
398 Clause =.. [DataName, Name, Record, Value],
399 I2 is I + 1
400 },
401 [Clause],
402 data_predicate(NT, I2, Arity, Constructor, DataName).
403
404
411
412set_predicates([], _, _, _, _) -->
413 [].
414set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
415 { atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
416 atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
417 length(Args, Arity),
418 replace_nth(I, Args, Value, NewArgs),
419 Old =.. [Constructor|Args],
420 New =.. [Constructor|NewArgs],
421 Head =.. [PredName, Value, Old, New],
422 SetHead =.. [PredName, Value, Term],
423 NBSetHead =.. [NBPredName, Value, Term],
424 ( Type == any
425 -> Clause = Head,
426 SetClause = (SetHead :- setarg(I, Term, Value)),
427 NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
428 ; type_check(Type, Value, MustBe),
429 Clause = (Head :- MustBe),
430 SetClause = (SetHead :- MustBe,
431 setarg(I, Term, Value)),
432 NBSetClause = (NBSetHead :- MustBe,
433 nb_setarg(I, Term, Value))
434 ),
435 I2 is I + 1
436 },
437 [ Clause, SetClause, NBSetClause ],
438 set_predicates(NT, I2, Arity, TT, Constructor).
439
440type_check(Type, Value, must_be(Type, Value)) :-
441 current_type(Type, Value, _),
442 !.
443type_check(record(Spec), Value, must_be(record(M:Name), Value)) :-
444 !,
445 prolog_load_context(module, C),
446 strip_module(C:Spec, M, Name).
447type_check(Atom, Value, Check) :-
448 atom(Atom),
449 !,
450 type_check(record(Atom), Value, Check).
451
452
458
459set_field_predicates([], _, _, _, _) -->
460 [].
461set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
462 { atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
463 length(Args, Arity),
464 replace_nth(I, Args, Value, NewArgs),
465 Old =.. [Constructor|Args],
466 New =.. [Constructor|NewArgs],
467 NameTerm =.. [Name, Value],
468 SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
469 ( Type == any
470 -> SetField = SetFieldHead
471 ; type_check(Type, Value, MustBe),
472 SetField = (SetFieldHead :- MustBe)
473 ),
474 I2 is I + 1
475 },
476 [ SetField ],
477 set_field_predicates(NT, I2, Arity, TT, Constructor).
478
479
483
484replace_nth(1, [_|T], V, [V|T]) :- !.
485replace_nth(I, [H|T0], V, [H|T]) :-
486 I2 is I - 1,
487 replace_nth(I2, T0, V, T).
488
489
493
494defaults([], [], []).
495defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :-
496 !,
497 defaults(T0, TD, TA).
498defaults([Arg|T0], [_|TD], [Arg|TA]) :-
499 defaults(T0, TD, TA).
500
501
505
506types([], [], []).
507types([Name:Type|T0], [Name|TN], [Type|TT]) :-
508 !,
509 must_be(atom, Name),
510 types(T0, TN, TT).
511types([Name|T0], [Name|TN], [any|TT]) :-
512 must_be(atom, Name),
513 types(T0, TN, TT).
514
515
516 519
520:- multifile
521 system:term_expansion/2,
522 sandbox:safe_primitive/1. 523:- dynamic
524 system:term_expansion/2. 525
526system:term_expansion((:- record(Record)), Clauses) :-
527 compile_records(Record, Clauses).
528
529sandbox:safe_primitive((record):is_record(_,_,_))