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