View source with formatted comments or as raw
    1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        jan@swi.psy.uva.nl
    5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    6    Copyright (c)  1995-2013, University of Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(pce_expansion,
   36        [ pce_term_expansion/2,         % +In, -Out
   37          pce_compiling/1,              % -ClassName
   38          pce_compiling/2,              % -ClassName, -Path
   39          pce_begin_recording/1,        % +- source|documentation
   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,                    % -ClassName
   65    attribute/3,                    % ClassName, Attribute, Value
   66    verbose/0,
   67    recording/2.                    % items recorded
   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                 /*******************************
   77                 *           OPERATORS          *
   78                 *******************************/
   79
   80%       push_compile_operators.
   81%
   82%       Push operator definitions  that  are   specific  to  XPCE  class
   83%       definitions.
   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, ::)     % above \+
   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
  108%verbose.
  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), _) :-    % check for :- instead of :-> or :<-
  145    pce_compiling,
  146    (   Body = ::(Doc, _Body),      % TBD
  147        is_string(Doc)
  148    ;   typed_head(Head)
  149    ),
  150    pce_error(context_error((Head :- Body), nomethod, clause)),
  151    fail.
  152
  153
  154%!  is_string(@Doc) is semidet.
  155%
  156%   See whether Doc may have originated from "..."
  157
  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).
  181
  182%!  pce_pre_expand(+In, -Out)
  183%
  184%   First step of the XPCE class compiler, calling the supported
  185%   hook pce_pre_expansion_hook/2.
  186
  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).
  229
  230
  231%!  pce_post_expand(In, Out)
  232
  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).
  244
  245
  246%!  pce_expandable(+Term)
  247%   Quick test whether we can expand this.
  248
  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)).
  266
  267
  268%!  do_expand(In, Out)
  269%
  270%   The XPCE kernel expansion.
  271
  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)   % force a reload (TBD: move to realise)
  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)   % force a reload
  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
  434/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  435gen_method_id(+SendGet, +Class, +Selector, -Identifier)
  436
  437Generate a unique identifier for the method,  used as the first argument
  438of send_implementation/3 or get_implementation/4.  The identifier should
  439be an atom or integer. The  value  is   not  relevant,  as long as it is
  440unique.
  441
  442This  suggests  simple  counting:  always    unique   and  integers  are
  443considerably cheaper than atoms. Unfortunately, there  is a problem with
  444this. If methods appear in pre-compiled files, they cannot be joined. It
  445is hard to see a good and workable  solution to this problem. Grant each
  446file a domain? How do we associate a unique domain to each file?
  447- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  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
  456%gen_method_id(_, _, _, Id) :-
  457%%      flag(pce_method_id, Id, Id+1).
  458
  459                 /*******************************
  460                 *       TEMPLATE SUPPORT       *
  461                 *******************************/
  462
  463/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  464When compiling a template, calls to   send_class/3 and get_class/4 refer
  465to the template  classes.  This  is   not  correct.  Therefore,  we will
  466translate  the  method  implementation   into    a   parameterized  real
  467implementation and a normal implementation  that calls the parameterized
  468one. On method instantiation, we create additional clauses for the class
  469to which we attach the method.
  470
  471Importing the template (pce_use_class_template/1):
  472
  473        + Put binding in bind_lazy by searching the templates.
  474        + Expand the directive itself into the wrapper-implementations.
  475- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  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(','(:, :)).                        % TBD: synchronise with boot/init.pl
  537meta(;(:, :)).
  538meta(->(:, :)).
  539meta(*->(:, :)).
  540meta(\+(:)).
  541meta(not(:)).
  542meta(call(:)).
  543meta(once(:)).
  544meta(ignore(:)).
  545meta(forall(:, :)).
  546meta(findall(-, :, -)).
  547meta(bagof(-, :, -)).
  548meta(setof(-, :, -)).
  549meta(^(-,:)).
  550
  551%!  use_template_class_attributes(+Template)
  552%
  553%   Insert variables, class-variables and directives as if they appeared
  554%   in the current class definition.
  555
  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), % TBD: pce_extend_class/1
  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), % TBD: pce_extend_class/1
  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).
  621
  622%!  used_class_template(+Template)
  623%
  624%   Succeeds if any of my (Prolog-defined) super classes
  625%   has imported the named template.
  626
  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),       % Prolog class being loaded
  637    !,
  638    isa_prolog_class(Super0, Super).
  639isa_prolog_class(Class, Super) :-               % Loaded Prolog class
  640    pce_class(Class, _, Super0, _, _, _),
  641    !,
  642    isa_prolog_class(Super0, Super).
  643
  644
  645                 /*******************************
  646                 *            CHECKING          *
  647                 *******************************/
  648
  649%!  can_define_class(+Name, +Super)
  650%
  651%   Check whether we can define Name as   a  subclass of Super. This
  652%   cannot be done of Name  is  a   builtin  class  or it is already
  653%   defined at another location.
  654
  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,                      % SWI: we are running consult
  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                 /*******************************
  675                 *   PUSH/POP CLASS STRUCTURE   *
  676                 *******************************/
  677
  678%!  push_class(+ClassName)
  679%   Start compiling the argument class.
  680
  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
  702%       pop_class
  703%       End class compilation.
  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                 /*******************************
  719                 *           ATTRIBUTES         *
  720                 *******************************/
  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                 /*******************************
  731                 *        CONTEXT VALUES        *
  732                 *******************************/
  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                 /*******************************
  756                 *           RECORDING          *
  757                 *******************************/
  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(_).                       % default recording all
  773
  774
  775                 /*******************************
  776                 *        SUMMARY HANDLING      *
  777                 *******************************/
  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                 /*******************************
  804                 *       TERM DESCRIPTION       *
  805                 *******************************/
  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                 /*******************************
  826                 *             ACCESS           *
  827                 *******************************/
  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                 /*******************************
  839                 *             TYPES            *
  840                 *******************************/
  841
  842%!  pce_type(+Spec, -PceTypeName)
  843%   Convert type specification into legal PCE type-name
  844
  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                 /*******************************
  907                 *        METHOD SUPPORT        *
  908                 *******************************/
  909
  910extract_documentation(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                 /*******************************
  991                 *        PUBLIC METHODS        *
  992                 *******************************/
  993
  994%!  pce_compiling(-ClassName)
  995%   External function to get the current classname
  996
  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                 /*******************************
 1014                 *            CLEANUP           *
 1015                 *******************************/
 1016
 1017%       cleanup
 1018%
 1019%       Cleanup the compilation data. We should  probably give a warning
 1020%       when not under xref and there is data left.
 1021
 1022cleanup :-
 1023    source_location(Path, _),
 1024    forall(retract(compiling(Class, Path)),
 1025           retractall(attribute(Class, _, _))).
 1026
 1027
 1028                 /*******************************
 1029                 *            CHECKS            *
 1030                 *******************************/
 1031
 1032%       If we are expanding on behalf of cross-referencing tool, never
 1033%       send messages anywhere!
 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                /********************************
 1044                *           UTILITIES           *
 1045                ********************************/
 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).
 1062
 1063%!  feedback(+Term)
 1064%   Only print if verbose is asserted (basically debugging).
 1065
 1066feedback(Term) :-
 1067    (   verbose
 1068    ->  pce_info(Term)
 1069    ;   true
 1070    ).
 1071
 1072
 1073                /********************************
 1074                *         TERM EXPANSION        *
 1075                ********************************/
 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.