34
35:- module(pce_expansion,
36 [ pce_term_expansion/2, 37 pce_compiling/1, 38 pce_compiling/2, 39 pce_begin_recording/1, 40 pce_end_recording/0
41 ]). 42:- use_module(pce_boot(pce_principal)). 43:- require([ pce_error/1
44 , pce_info/1
45 , pce_warn/1
46 , string/1
47 , atomic_list_concat/2
48 , expand_goal/2
49 , flatten/2
50 , forall/2
51 , reverse/2
52 , source_location/2
53 , string_codes/2
54 , append/3
55 , atom_concat/3
56 , between/3
57 , maplist/3
58 , sub_atom/5
59 , push_operators/1
60 , pop_operators/0
61 ]). 62
63:- dynamic
64 compiling/2, 65 attribute/3, 66 verbose/0,
67 recording/2. 68
69:- if(exists_source(library(quintus))). 70:- use_module(library(quintus), [genarg/3]). 71:- endif. 72
73 76
81
82:- module_transparent
83 push_compile_operators/0. 84
85push_compile_operators :-
86 context_module(M),
87 push_compile_operators(M).
88
89push_compile_operators(M) :-
90 push_operators(M:
91 [ op(1200, xfx, :->)
92 , op(1200, xfx, :<-)
93 , op(910, xfy, ::) 94 , op(100, xf, *)
95 , op(125, xf, ?)
96 , op(150, xf, ...)
97 , op(100, xfx, ..)
98 ]).
99
100pop_compile_operators :-
101 pop_operators.
102
103:- push_compile_operators. 104
106
107pce_term_expansion(In, Out) :-
108 pce_pre_expand(In, In0),
109 ( is_list(In0)
110 -> maplist(map_term_expand, In0, In1),
111 flatten(In1, Out0),
112 ( Out0 = [X]
113 -> Out = X
114 ; Out = Out0
115 )
116 ; do_term_expand(In0, Out)
117 ).
118
119map_term_expand(X, X) :-
120 var(X),
121 !.
122map_term_expand(X, Y) :-
123 do_term_expand(X, Y),
124 !.
125map_term_expand(X, X).
126
127
128do_term_expand(end_of_file, _) :-
129 cleanup, !, fail.
130do_term_expand(In0, Out) :-
131 pce_expandable(In0),
132 ( do_expand(In0, Out0)
133 -> ( pce_post_expand(Out0, Out)
134 -> true
135 ; Out = Out0
136 )
137 ; pce_error(expand_failed(In0)),
138 Out = []
139 ),
140 !.
141do_term_expand((Head :- Body), _) :- 142 pce_compiling,
143 ( Body = ::(Doc, _Body), 144 is_string(Doc)
145 ; typed_head(Head)
146 ),
147 pce_error(context_error((Head :- Body), nomethod, clause)),
148 fail.
155is_string(Doc) :-
156 string(Doc),
157 !.
158is_string(Doc) :-
159 is_list(Doc),
160 catch(string_codes(Doc, _), _, fail).
161
162typed_head(T) :-
163 functor(T, _, Arity),
164 Arity > 1,
165 forall(genarg(N, T, A), head_arg(N, A)).
166
167head_arg(1, A) :-
168 !,
169 var(A).
170head_arg(_, A) :-
171 nonvar(A),
172 ( A = (_:TP)
173 -> true
174 ; A = (_:Name=TP),
175 atom(Name)
176 ),
177 ground(TP).
184:- multifile user:pce_pre_expansion_hook/2. 185:- dynamic user:pce_pre_expansion_hook/2. 186:- multifile user:pce_post_expansion_hook/2. 187:- dynamic user:pce_post_expansion_hook/2. 188
189pce_pre_expand(X, Y) :-
190 user:pce_pre_expansion_hook(X, X1),
191 !,
192 ( is_list(X1)
193 -> maplist(do_pce_pre_expand, X1, Y)
194 ; do_pce_pre_expand(X1, Y)
195 ).
196pce_pre_expand(X, Y) :-
197 do_pce_pre_expand(X, Y).
198
199do_pce_pre_expand((:- pce_begin_class(Class, Super)),
200 (:- pce_begin_class(Class, Super, @default))).
201do_pce_pre_expand(variable(Name, Type, Access),
202 variable(Name, Type, Access, @default)) :-
203 pce_compiling.
204do_pce_pre_expand(class_variable(Name, Type, Default),
205 class_variable(Name, Type, Default, @default)) :-
206 pce_compiling.
207do_pce_pre_expand(handle(X, Y, Kind),
208 handle(X, Y, Kind, @default)) :-
209 pce_compiling.
210do_pce_pre_expand((:- ClassDirective), D) :-
211 functor(ClassDirective, send, _),
212 arg(1, ClassDirective, @class),
213 !,
214 D = (:- pce_class_directive(ClassDirective)).
215do_pce_pre_expand(pce_ifhostproperty(Prop, Clause), TheClause) :-
216 ( pce_host:property(Prop)
217 -> TheClause = Clause
218 ; TheClause = []
219 ).
220do_pce_pre_expand(pce_ifhostproperty(Prop, If, Else), Clause) :-
221 ( pce_host:property(Prop)
222 -> Clause = If
223 ; Clause = Else
224 ).
225do_pce_pre_expand(X, X).
230pce_post_expand([], []).
231pce_post_expand([H0|T0], [H|T]) :-
232 user:pce_post_expansion_hook(H0, H),
233 !,
234 pce_post_expand(T0, T).
235pce_post_expand([H|T0], [H|T]) :-
236 pce_post_expand(T0, T).
237pce_post_expand(T0, T) :-
238 user:pce_post_expansion_hook(T0, T),
239 !.
240pce_post_expand(T, T).
246pce_expandable((:- pce_begin_class(_Class, _Super, _Doc))).
247pce_expandable((:- pce_extend_class(_Class))).
248pce_expandable((:- pce_end_class)).
249pce_expandable((:- pce_end_class(_))).
250pce_expandable((:- use_class_template(_TemplateClass))).
251pce_expandable((:- pce_group(_))).
252pce_expandable((:- pce_class_directive(_))).
253pce_expandable(variable(_Name, _Type, _Access, _Doc)) :-
254 pce_compiling.
255pce_expandable(class_variable(_Name, _Type, _Default, _Doc)) :-
256 pce_compiling.
257pce_expandable(delegate_to(_VarName)) :-
258 pce_compiling.
259pce_expandable(handle(_X, _Y, _Kind, _Name)) :-
260 pce_compiling.
261pce_expandable(:->(_Head, _Body)).
262pce_expandable(:<-(_Head, _Body)).
269do_expand((:- pce_begin_class(Spec, Super, Doc)),
270 (:- pce_begin_class_definition(ClassName, MetaClass, Super, Doc))) :-
271 break_class_specification(Spec, ClassName, MetaClass, TermArgs),
272 can_define_class(ClassName, Super),
273 push_class(ClassName),
274 set_attribute(ClassName, super, Super),
275 set_attribute(ClassName, meta, MetaClass),
276 class_summary(ClassName, Doc),
277 class_source(ClassName),
278 term_names(ClassName, TermArgs).
279do_expand((:- pce_extend_class(ClassName)), []) :-
280 push_class(ClassName),
281 set_attribute(ClassName, extending, true).
282do_expand((:- pce_end_class(Class)), Expansion) :-
283 ( pce_compiling(ClassName),
284 ( Class == ClassName
285 -> do_expand((:- pce_end_class), Expansion)
286 ; pce_error(end_class_mismatch(Class, ClassName))
287 )
288 ; pce_error(no_class_to_end)
289 ).
290do_expand((:- pce_end_class),
291 [ pce_principal:pce_class(ClassName, MetaClass, Super,
292 Variables,
293 Resources,
294 Directs),
295 RegisterDecl
296 ]) :-
297 pce_compiling(ClassName),
298 !,
299 findall(V, retract(attribute(ClassName, variable, V)), Variables),
300 findall(R, retract(attribute(ClassName, classvar, R)), Resources),
301 findall(D, retract(attribute(ClassName, directive, D)), Directs),
302 ( attribute(ClassName, extending, true)
303 -> MetaClass = (-),
304 Super = (-),
305 expand_term((:- initialization(pce_extended_class(ClassName))),
306 RegisterDecl)
307 ; retract(attribute(ClassName, super, Super)),
308 retract(attribute(ClassName, meta, MetaClass)),
309 expand_term((:- initialization(pce_register_class(ClassName))),
310 RegisterDecl)
311 ),
312 pop_class.
313do_expand((:- pce_end_class), []) :-
314 pce_error(no_class_to_end).
315do_expand((:- use_class_template(_)), []) :-
316 current_prolog_flag(xref, true),
317 !.
318do_expand((:- use_class_template(Template)), []) :-
319 used_class_template(Template),
320 !.
321do_expand((:- use_class_template(Template)),
322 [ pce_principal:pce_uses_template(ClassName, Template)
323 | LinkClauses
324 ]) :-
325 pce_compiling(ClassName),
326 use_template_class_attributes(Template),
327 use_template_send_methods(Template, SendClauses),
328 use_template_get_methods(Template, GetClauses),
329 append(SendClauses, GetClauses, LinkClauses).
330do_expand((:- pce_group(Group)), []) :-
331 pce_compiling(ClassName),
332 set_attribute(ClassName, group, Group).
333do_expand(variable(Name, Type, Access, Doc), []) :-
334 pce_compiling(ClassName),
335 current_group(ClassName, Group),
336 pce_access(Access),
337 var_type(Type, PceType, Initial),
338 pce_summary(Doc, PceDoc),
339 strip_defaults([Initial, Group, PceDoc], Defs),
340 Var =.. [variable, Name, PceType, Access | Defs],
341 add_attribute(ClassName, variable, Var).
342do_expand(class_variable(Name, Type, Default, Doc), []) :-
343 pce_compiling(ClassName),
344 prolog_load_context(module, M),
345 pce_type(Type, PceType),
346 pce_summary(Doc, PceDoc),
347 add_attribute(ClassName, classvar,
348 M:class_variable(Name, Default, PceType, PceDoc)).
349do_expand(handle(X, Y, Kind, Name), []) :-
350 pce_compiling(ClassName),
351 add_attribute(ClassName, directive,
352 send(@class, handle, handle(X, Y, Kind, Name))).
353do_expand(delegate_to(Var), []) :-
354 pce_compiling(ClassName),
355 add_attribute(ClassName, directive,
356 send(@class, delegate, Var)).
357do_expand((:- pce_class_directive(Goal)),
358 (:- initialization((send(@class, assign, Class),
359 Goal)))) :-
360 pce_compiling(ClassName),
361 realised_class(ClassName),
362 attribute(ClassName, extending, true),
363 !,
364 get(@classes, member, ClassName, Class).
365do_expand((:- pce_class_directive(Goal)), (:- Goal)) :-
366 pce_compiling(ClassName),
367 realised_class(ClassName),
368 !.
369do_expand((:- pce_class_directive(Goal)), []) :-
370 pce_compiling(ClassName),
371 prolog_load_context(module, M),
372 add_attribute(ClassName, directive, M:Goal).
373do_expand(:->(Head, DocBody),
374 [ pce_principal:pce_lazy_send_method(Selector, ClassName, LSM)
375 | Clauses
376 ]) :-
377 extract_documentation(DocBody, Doc, Body),
378 source_location_term(Loc),
379 pce_compiling(ClassName),
380 current_group(ClassName, Group),
381 prolog_head(send, Id, Head, Selector, Types, PlHead),
382 strip_defaults([Group, Loc, Doc], NonDefArgs),
383 LSM =.. [bind_send, Id, Types | NonDefArgs],
384 Clause = (PlHead :- Body),
385 gen_method_id((->), ClassName, Selector, Id),
386 ( attribute(ClassName, super, template)
387 -> template_clause(Clause, Clauses)
388 ; Clauses = [Clause]
389 ),
390 ( realised_class(ClassName) 391 -> send(@class, delete_send_method, Selector)
392 ; true
393 ),
394 feedback(expand_send(ClassName, Selector)).
395do_expand(:<-(Head, DocBody),
396 [ pce_principal:pce_lazy_get_method(Selector, ClassName, LGM)
397 | Clauses
398 ]) :-
399 extract_documentation(DocBody, Doc, Body),
400 source_location_term(Loc),
401 pce_compiling(ClassName),
402 current_group(ClassName, Group),
403 return_type(Head, RType),
404 prolog_head(get, Id, Head, Selector, Types, PlHead),
405 strip_defaults([Group, Loc, Doc], NonDefArgs),
406 LGM =.. [bind_get, Id, RType, Types | NonDefArgs],
407 Clause = (PlHead :- Body),
408 gen_method_id((<-), ClassName, Selector, Id),
409 ( attribute(ClassName, super, template)
410 -> template_clause(Clause, Clauses)
411 ; Clauses = [Clause]
412 ),
413 ( realised_class(ClassName) 414 -> send(@class, delete_get_method, Selector)
415 ; true
416 ),
417 feedback(expand_get(ClassName, Selector)).
418
419strip_defaults([@default|T0], T) :-
420 !,
421 strip_defaults(T0, T).
422strip_defaults(L, LV) :-
423 reverse(L, LV).
424
425break_class_specification(Meta:Term, ClassName, Meta, TermArgs) :-
426 !,
427 Term =.. [ClassName|TermArgs].
428break_class_specification(Term, ClassName, @default, TermArgs) :-
429 Term =.. [ClassName|TermArgs].
430
445
446gen_method_id(SG, Class, Selector, Id) :-
447 attribute(Class, extending, true),
448 !,
449 atomic_list_concat([Class, '$+$', SG, Selector], Id).
450gen_method_id(SG, Class, Selector, Id) :-
451 atomic_list_concat([Class, SG, Selector], Id).
452
455
456 459
473
474template_clause((M:send_implementation(Id, Msg, R) :- Body),
475 [ (M:send_implementation(Tid, ClassMsg, R) :- ClassBody),
476 (M:(send_implementation(Id, Msg, R) :-
477 send_implementation(Tid, IClassMsg, R)))
478 ]) :-
479 !,
480 atom_concat('T-', Id, Tid),
481 Msg =.. Args,
482 append(Args, [Class], Args2),
483 ClassMsg =.. Args2,
484 append(Args, [template], Args3),
485 IClassMsg =.. Args3,
486 template_body(Body, template, Class, ClassBody).
487template_clause((M:get_implementation(Id, Msg, R, V) :- Body),
488 [ (M:get_implementation(Tid, ClassMsg, R, V) :- ClassBody),
489 (M:(get_implementation(Id, Msg, R, V) :-
490 get_implementation(Tid, IClassMsg, R, V)))
491 ]) :-
492 !,
493 atom_concat('T-', Id, Tid),
494 Msg =.. Args,
495 append(Args, [Class], Args2),
496 ClassMsg =.. Args2,
497 append(Args, [template], Args3),
498 IClassMsg =.. Args3,
499 template_body(Body, template, Class, ClassBody).
500template_clause(Clause, Clause).
501
502template_body(G0, T, C, G) :-
503 compound(G0),
504 functor(G0, Name, Arity),
505 functor(M, Name, Arity),
506 meta(M),
507 !,
508 functor(G, Name, Arity),
509 convert_meta(0, Arity, G0, M, T, C, G).
510template_body(G, T, C, send_class(R, C, Msg)) :-
511 expand_goal(G, send_class(R, T, Msg)),
512 !.
513template_body(G, T, C, get_class(R, C, Msg, V)) :-
514 expand_goal(G, get_class(R, T, Msg, V)),
515 !.
516template_body(G, _, _, G).
517
518convert_meta(A, A, _, _, _, _, _) :- !.
519convert_meta(I, Arity, G0, M, T, C, G) :-
520 A is I + 1,
521 arg(A, M, :),
522 !,
523 arg(A, G0, GA0),
524 arg(A, G, GA),
525 template_body(GA0, T, C, GA),
526 convert_meta(A, Arity, G0, M, T, C, G).
527convert_meta(I, Arity, G0, M, T, C, G) :-
528 A is I + 1,
529 arg(A, G0, GA),
530 arg(A, G, GA),
531 convert_meta(A, Arity, G0, M, T, C, G).
532
533meta(','(:, :)). 534meta(;(:, :)).
535meta(->(:, :)).
536meta(*->(:, :)).
537meta(\+(:)).
538meta(not(:)).
539meta(call(:)).
540meta(once(:)).
541meta(ignore(:)).
542meta(forall(:, :)).
543meta(findall(-, :, -)).
544meta(bagof(-, :, -)).
545meta(setof(-, :, -)).
546meta(^(-,:)).
553use_template_class_attributes(Template) :-
554 pce_class(Template, _, template, Variables, ClassVars, Directs),
555 assert_attributes(Variables, variable),
556 assert_attributes(ClassVars, classvar),
557 assert_attributes(Directs, directive).
558
559assert_attributes([], _).
560assert_attributes([H|T], Att) :-
561 pce_compiling(ClassName),
562 ( H = send(@class, source, _Source)
563 -> true
564 ; add_attribute(ClassName, Att, H)
565 ),
566 assert_attributes(T, Att).
567
568use_template_send_methods(Template, Clauses) :-
569 findall(C, use_template_send_method(Template, C), Clauses).
570
571use_template_send_method(Template, pce_principal:Clause) :-
572 pce_compiling(ClassName),
573 pce_lazy_send_method(Sel, Template, Binder),
574 Binder =.. [Functor, Id | RestBinder],
575 gen_method_id('$T$->', ClassName, Sel, NewId),
576 ( Clause = pce_lazy_send_method(Sel, ClassName, NewBinder),
577 NewBinder =.. [Functor, NewId | RestBinder]
578 ; Clause = (send_implementation(NewId, Msg, R) :-
579 send_implementation(Tid, IClassMsg, R)),
580 attribute(ClassName, super, SuperClass), 581 arg(2, Binder, Types),
582 type_arity(Types, Arity),
583 functor(Msg, Sel, Arity),
584 Msg =.. Args,
585 append(Args, [SuperClass], Args1),
586 IClassMsg =.. Args1,
587 atom_concat('T-', Id, Tid)
588 ).
589
590use_template_get_methods(Template, Clauses) :-
591 findall(C, use_template_get_method(Template, C), Clauses).
592
593use_template_get_method(Template, pce_principal:Clause) :-
594 pce_compiling(ClassName),
595 pce_lazy_get_method(Sel, Template, Binder),
596 Binder =.. [Functor, Id | RestBinder],
597 gen_method_id('$T$<-', ClassName, Sel, NewId),
598 ( Clause = pce_lazy_get_method(Sel, ClassName, NewBinder),
599 NewBinder =.. [Functor, NewId | RestBinder]
600 ; Clause = (get_implementation(NewId, Msg, R, V) :-
601 get_implementation(Tid, IClassMsg, R, V)),
602 attribute(ClassName, super, SuperClass), 603 arg(3, Binder, Types),
604 type_arity(Types, Arity),
605 functor(Msg, Sel, Arity),
606 Msg =.. Args,
607 append(Args, [SuperClass], Args1),
608 IClassMsg =.. Args1,
609 atom_concat('T-', Id, Tid)
610 ).
611
612type_arity(@default, 0) :- !.
613type_arity(Atom, 1) :-
614 atom(Atom),
615 !.
616type_arity(Vector, A) :-
617 functor(Vector, _, A).
624used_class_template(Template) :-
625 pce_compiling(Class),
626 isa_prolog_class(Class, Super),
627 Super \== Class,
628 pce_uses_template(Super, Template),
629 !.
630
631isa_prolog_class(Class, Class).
632isa_prolog_class(Class, Super) :-
633 attribute(Class, super, Super0), 634 !,
635 isa_prolog_class(Super0, Super).
636isa_prolog_class(Class, Super) :- 637 pce_class(Class, _, Super0, _, _, _),
638 !,
639 isa_prolog_class(Super0, Super).
640
641
642
652can_define_class(Name, _Super) :-
653 get(@classes, member, Name, Class),
654 get(Class, creator, built_in),
655 !,
656 throw(error(permission_error(modify, pce(built_in_class), Name), _)).
657can_define_class(Name, _Super) :-
658 flag('$compilation_level', Level, Level),
659 Level > 0, 660 pce_class(Name, _Meta, _OldSuper, _Vars, _ClassVars, _Dirs),
661 throw(error(permission_error(modify, pce(class), Name), _)).
662can_define_class(Name, _Super) :-
663 get(@types, member, Name, Type),
664 \+ get(Type, kind, class),
665 throw(error(permission_error(define, pce(class), Name),
666 context(pce_begin_class/3,
667 'Already defined as a type'))).
668can_define_class(_, _).
669
670
671
678push_class(ClassName) :-
679 compiling(ClassName, _),
680 !,
681 pce_error(recursive_loading_class(ClassName)),
682 fail.
683push_class(ClassName) :-
684 prolog_load_context(module, M),
685 push_compile_operators(M),
686 ( source_location(Path, _Line)
687 -> true
688 ; Path = []
689 ),
690 asserta(compiling(ClassName, Path)),
691 ( realised_class(ClassName)
692 -> get(@class, '_value', OldClassVal),
693 asserta(attribute(ClassName, old_class_val, OldClassVal)),
694 get(@classes, member, ClassName, Class),
695 send(@class, assign, Class, global)
696 ; true
697 ).
698
701
702pop_class :-
703 retract(compiling(ClassName, _)),
704 !,
705 ( attribute(ClassName, old_class_val, OldClassVal)
706 -> send(@class, assign, OldClassVal, global)
707 ; true
708 ),
709 retractall(attribute(ClassName, _, _)),
710 pop_compile_operators.
711pop_class :-
712 pce_error(no_class_to_end),
713 fail.
714
715 718
719set_attribute(Class, Name, Value) :-
720 retractall(attribute(Class, Name, _)),
721 asserta(attribute(Class, Name, Value)).
722
723add_attribute(Class, Name, Value) :-
724 assert(attribute(Class, Name, Value)).
725
726
727 730
731source_location_term(source_location(File, Line)) :-
732 pce_recording(source),
733 source_location(File, Line),
734 !.
735source_location_term(@default).
736
737current_group(Class, Group) :-
738 attribute(Class, group, Group),
739 !.
740current_group(_, @default).
741
742class_source(ClassName) :-
743 pce_recording(source),
744 source_location_term(Term),
745 Term \== @default,
746 !,
747 add_attribute(ClassName, directive,
748 send(@class, source, Term)).
749class_source(_).
750
751
752 755
756pce_begin_recording(+Topic) :-
757 asserta(recording(Topic, true)).
758pce_begin_recording(-Topic) :-
759 asserta(recording(Topic, fail)).
760
761pce_end_recording :-
762 retract(recording(_, _)),
763 !.
764
765pce_recording(Topic) :-
766 recording(Topic, X),
767 !,
768 X == true.
769pce_recording(_). 770
771
772 775
776class_summary(ClassName, Summary) :-
777 pce_summary(Summary, PceSummary),
778 ( PceSummary \== @default
779 -> add_attribute(ClassName, directive,
780 send(@class, summary, PceSummary))
781 ; true
782 ).
783
784
785pce_summary(@X, @X) :- !.
786pce_summary(_, @default) :-
787 \+ pce_recording(documentation),
788 !.
789pce_summary(Atomic, Atomic) :-
790 atomic(Atomic),
791 !.
792pce_ifhostproperty(string, [
793(pce_summary(String, String) :-
794 string(String), !),
795(pce_summary(List, String) :-
796 string_codes(String, List))]).
797pce_summary(List, string(List)).
798
799
800 803
804term_names(_, []) :- !.
805term_names(Class, Selectors) :-
806 check_term_selectors(Selectors),
807 VectorTerm =.. [vector|Selectors],
808 add_attribute(Class, directive,
809 send(@class, term_names, new(VectorTerm))).
810
811
812check_term_selectors([]).
813check_term_selectors([H|T]) :-
814 ( atom(H)
815 -> true
816 ; pce_error(bad_term_argument(H)),
817 fail
818 ),
819 check_term_selectors(T).
820
821
822 825
826pce_access(both) :- !.
827pce_access(get) :- !.
828pce_access(send) :- !.
829pce_access(none) :- !.
830pce_access(X) :-
831 pce_error(invalid_access(X)),
832 fail.
833
834
835
842pce_type(Prolog, Pce) :-
843 to_atom(Prolog, RawPce),
844 canonicalise_type(RawPce, Pce).
845
846canonicalise_type(T0, T0) :-
847 sub_atom(T0, _, _, 0, ' ...'),
848 !.
849canonicalise_type(T0, T) :-
850 atom_concat(T1, '...', T0),
851 !,
852 atom_concat(T1, ' ...', T).
853canonicalise_type(T, T).
854
855to_atom(Atom, Atom) :-
856 atom(Atom),
857 !.
858to_atom(Term, Atom) :-
859 ground(Term),
860 !,
861 phrase(pce_type_description(Term), Chars),
862 atom_chars(Atom, Chars).
863to_atom(Term, any) :-
864 pce_error(type_error(to_atom(Term, any), 1, ground, Term)).
865
866pce_type_description(Atom, Chars, Tail) :-
867 atomic(Atom),
868 !,
869 name(Atom, C0),
870 append(C0, Tail, Chars).
871pce_type_description([X]) -->
872 "[", pce_type_description(X), "]".
873pce_type_description([X|Y]) -->
874 "[", pce_type_description(X), "|", pce_type_description(Y), "]".
875pce_type_description({}(Words)) -->
876 "{", word_list(Words), "}".
877pce_type_description(=(Name, Type)) -->
878 pce_type_description(Name), "=", pce_type_description(Type).
879pce_type_description(*(T)) -->
880 pce_type_description(T), "*".
881pce_type_description(...(T)) -->
882 pce_type_description(T), " ...".
883
884word_list((A,B)) -->
885 !,
886 pce_type_description(A), ",", word_list(B).
887word_list(A) -->
888 pce_type_description(A).
889
890
891var_type(Type := new(Term), PceType, Initial) :-
892 !,
893 pce_type(Type, PceType),
894 Term =.. L,
895 Initial =.. [create|L].
896var_type(Type := Initial, PceType, Initial) :-
897 !,
898 pce_type(Type, PceType).
899var_type(Type, PceType, @default) :-
900 pce_type(Type, PceType).
901
902
903 906
(Body0, Summary, Body) :-
908 ex_documentation(Body0, Summary, Body),
909 !.
910extract_documentation(Body, @default, Body).
911
912ex_documentation(::(DocText, Body), Summary, Body) :-
913 !,
914 pce_summary(DocText, Summary).
915ex_documentation((::(DocText, A), B), Summary, (A,B)) :-
916 !,
917 pce_summary(DocText, Summary).
918ex_documentation((A0 ; B), Summary, (A;B)) :-
919 ex_documentation(A0, Summary, A),
920 !.
921ex_documentation((A0->B), Summary, (A->B)) :-
922 !,
923 ex_documentation(A0, Summary, A),
924 !.
925ex_documentation((A0*->B), Summary, (A*->B)) :-
926 !,
927 ex_documentation(A0, Summary, A),
928 !.
929
930return_type(Term, RType) :-
931 functor(Term, _, Arity),
932 arg(Arity, Term, Last),
933 ( nonvar(Last),
934 Last = _:Type
935 -> pce_type(Type, RType)
936 ; RType = @default
937 ).
938
939prolog_head(send, MethodId, Head, Selector,
940 TypeVector, pce_principal:PlHead) :-
941 !,
942 Head =.. [Selector, Receiver | Args],
943 prolog_send_arguments(Args, Types, PlArgs),
944 create_type_vector(Types, TypeVector),
945 CallArgs =.. [Selector | PlArgs],
946 PlHead =.. [send_implementation, MethodId, CallArgs, Receiver].
947prolog_head(get, MethodId, Head, Selector,
948 TypeVector, pce_principal:PlHead) :-
949 !,
950 Head =.. [Selector, Receiver | Args],
951 prolog_get_arguments(Args, Types, PlArgs, Rval),
952 create_type_vector(Types, TypeVector),
953 CallArgs =.. [Selector | PlArgs],
954 PlHead =.. [get_implementation, MethodId, CallArgs, Receiver, Rval].
955
956create_type_vector([], @default) :- !.
957create_type_vector(List, VectorTerm) :-
958 VectorTerm =.. [vector|List].
959
960prolog_send_arguments([], [], []) :- !.
961prolog_send_arguments([ArgAndType|RA], [T|RT], [Arg|TA]) :-
962 !,
963 head_arg(ArgAndType, Arg, Type),
964 pce_type(Type, T),
965 prolog_send_arguments(RA, RT, TA).
966
967prolog_get_arguments([Return], [], [], ReturnVar) :-
968 !,
969 ( var(Return)
970 -> ReturnVar = Return
971 ; Return = ReturnVar:_Type
972 ).
973prolog_get_arguments([ArgAndType|RA], [T|RT], [Arg|TA], ReturnVar) :-
974 !,
975 head_arg(ArgAndType, Arg, Type),
976 pce_type(Type, T),
977 prolog_get_arguments(RA, RT, TA, ReturnVar).
978
979
980head_arg(Var, Var, any) :-
981 var(Var),
982 !.
983head_arg(Arg:Type, Arg, Type).
984head_arg(Arg:Name=Type, Arg, Name=Type).
985
986
987
994pce_compiling(ClassName, Path) :-
995 compiling(X, Y),
996 !,
997 X = ClassName,
998 Y = Path.
999
1000pce_compiling(ClassName) :-
1001 compiling(X, _),
1002 !,
1003 X = ClassName.
1004
1005pce_compiling :-
1006 compiling(_, _),
1007 !.
1008
1009
1010 1013
1018
1019cleanup :-
1020 source_location(Path, _),
1021 forall(retract(compiling(Class, Path)),
1022 retractall(attribute(Class, _, _))).
1023
1024
1025 1028
1031
1032pce_ifhostproperty(qpc,
1033(realised_class(_ClassName) :- fail),
1034(realised_class(ClassName) :-
1035 \+ current_prolog_flag(xref, true),
1036 get(@classes, member, ClassName, Class),
1037 get(Class, realised, @on))).
1038
1039
1040 1043
1044term_member(El, Term) :-
1045 El == Term.
1046term_member(El, Term) :-
1047 functor(Term, _, Arity),
1048 term_member(Arity, El, Term).
1049
1050term_member(0, _, _) :-
1051 !,
1052 fail.
1053term_member(N, El, Term) :-
1054 arg(N, Term, Sub),
1055 term_member(El, Sub).
1056term_member(N, El, Term) :-
1057 NN is N - 1,
1058 term_member(NN, El, Term).
1063feedback(Term) :-
1064 ( verbose
1065 -> pce_info(Term)
1066 ; true
1067 ).
1068
1069
1070 1073
1074:- multifile
1075 system:term_expansion/2. 1076:- dynamic
1077 system:term_expansion/2. 1078
1079system:term_expansion(A, B) :-
1080 pce_term_expansion(A, B).
1081
1082:- pop_compile_operators.