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-2012, 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_realise,
   36          [ pce_register_class/1,       % +ClassName
   37            pce_extended_class/1,       % +ClassName
   38            pce_realise_class/1,        % +ClassName
   39            pce_begin_class_definition/4,% +ClassName, +Meta, +Super, +Summary
   40            pce_prolog_class/1,         % ?ClassName
   41            pce_prolog_class/2          % ?ClassName, ?SuperName
   42          ]).   43
   44:- use_module(pce_boot(pce_principal)).   45:- use_module(pce_boot(pce_global)).   46:- require([ ignore/1
   47           , pce_error/1
   48           , call/3
   49           , last/2
   50           ]).   51
   52:- pce_global(@class, new(var(class, class, @nil))).
   53
   54                 /*******************************
   55                 *            REGISTER          *
   56                 *******************************/
   57
   58pce_register_class(ClassName) :-
   59    check_loaded_class(ClassName).
   60
   61
   62                 /*******************************
   63                 *       EXTENDING CLASSES      *
   64                 *******************************/
   65
   66pce_extended_class(ClassName) :-
   67    get(@classes, member, ClassName, Class),
   68    !,
   69    attach_class_attributes(ClassName),
   70    send(Class, clear_cache),
   71    resolve_method_message(Msg),
   72    send(Class, resolve_method_message, Msg).
   73pce_extended_class(_).

 pce_begin_class_definition(+ClassName, +Meta, +Super, +Summary)

Dummy to allow cross-referencing and other tools to locate class-definitions after term-expansion.

   81pce_begin_class_definition(_,_,_,_).
   82
   83
   84                 /*******************************
   85                 *            RELOAD            *
   86                 *******************************/

 check_loaded_class(+ClassName)

If the class is already defined, we are dealing with redefinition and have to take action immediately.

   93check_loaded_class(ClassName) :-
   94    get(@classes, member, ClassName, _),
   95    !,
   96    pce_realise_class(ClassName).
   97check_loaded_class(_).
   98
   99
  100                 /*******************************
  101                 *        REALISE-CLASS         *
  102                 *******************************/

 pce_realise_class(+ClassName)

Creates `ClassName' from the compiled representation.

  107pce_realise_class(ClassName) :-
  108    pce_class(ClassName, MetaClassName, SuperName, _, _, _),
  109    MetaClassName \== (-),
  110    create_class(ClassName, MetaClassName, SuperName, Class),
  111    !,
  112    resolve_method_message(Msg),
  113    send(Class, resolve_method_message, Msg),
  114    attach_class_attributes(ClassName),
  115    (   cache_table(TableName),
  116        get(Class, slot, TableName, Table),
  117        get(Table, size, Size),
  118        Size > 0
  119    ->  delete_prolog_methods(Class)
  120    ;   true
  121    ),
  122    ignore(get(Class, send_method, in_event_area, _)). % HACK!
  123
  124cache_table(send_table).
  125cache_table(get_table).
  126cache_table(send_methods).
  127cache_table(get_methods).
  128
  129attach_class_attributes(ClassName) :-
  130    get(@classes, member, ClassName, Class),
  131    pce_class(ClassName, _, _,
  132              Variables,
  133              ClassVariables,
  134              Directives),
  135    attach_variables(Variables, Class),
  136    attach_class_variables(ClassVariables, Class),
  137    run_directives(Directives, Class),
  138    fail ; true.

 pce_prolog_class(?ClassName:atom) is nondet

 pce_prolog_class(?ClassName:atom, ?SuperName:atom) is nondet

Is true if ClassName refers to a class defined in Prolog with the given superclass.

  147pce_prolog_class(ClassName) :-
  148    pce_prolog_class(ClassName, _SuperName).
  149pce_prolog_class(ClassName, SuperName) :-
  150    pce_class(ClassName, _MetaClassName, SuperName,
  151              _Variables,
  152              _ClassVariables,
  153              _Directives),
  154    SuperName \== '-'.              % extended class

 create_class(+ClassName, +MetaClassName, +SuperName, -Class)

Creates class `ClassName' below `SuperName'. Succeeds (for redefinition) if the class already existed with the same super-class.

  163create_class(ClassName, MetaClassName, Super, Class) :-
  164    get(@classes, member, ClassName, Class),
  165    send(Class, instance_of, class),
  166    !,
  167    get(Class, super_class, SuperClass),
  168    (   (   Super == @nil,
  169            SuperClass == @nil
  170        ;   SuperClass \== @nil,
  171            get(SuperClass, name, Super)
  172        )
  173    ->  true
  174    ;   pce_error(superclass_not_changed(ClassName))
  175    ),
  176    (   (   MetaClassName == @default
  177        ;   get(Class, class, MetaClass),
  178            get(MetaClass, name, MetaClassName)
  179        )
  180    ->  true
  181    ;   pce_error(metaclass_not_changed(ClassName))
  182    ),
  183    send(Class, clear_cache).
  184create_class(ClassName, MetaClassName, SuperName, Class) :-
  185    (   get(@pce, convert, SuperName, class, Super)
  186    ->  true
  187    ;   pce_error(superclass_not_exist(SuperName, ClassName))
  188    ),
  189    (   MetaClassName == @default
  190    ->  get(Super, sub_class, ClassName, Class)
  191    ;   Term =.. [MetaClassName, ClassName, Super],
  192        new(Class, Term)
  193    ).

 attach_variables(+VariableList, +Class)

Attach the instance variables. Error checking is done by the XPCE kernel.

  201attach_variables([], _).
  202attach_variables([V|T], Class) :-
  203    catch(send(Class, instance_variable, V), E,
  204          pce_error(E)),
  205    attach_variables(T, Class).

 attach_class_variables(+ClassVarList, +Class)

Attach the class variables

  211attach_class_variables([], _).
  212attach_class_variables([R|T], Class) :-
  213    attach_class_variable(Class, R),
  214    attach_class_variables(T, Class).
  215
  216attach_class_variable(Class, M:class_variable(Name, Def, Type, Summary)) :-
  217    !,
  218    classvar_default(Def, PceDef),
  219    new(_, M:class_variable(Class, Name, PceDef, Type, Summary)).
  220attach_class_variable(Class, ClassVar) :-
  221    attach_class_variable(Class, user:ClassVar).

 classvar_default(+DefaultSpec, -Default) is det

Allow environment specific defaults. If DefaultSpec is a list, it may hold terms windows(WindowsDefault), 'X'(X11Default) or apple(AppleDefault). The system is considered apple if @pce has window_system X and <-operating_system matches the substring darwin. If apple(AppleDefault) is not found, 'X'(X11Default) is tried.

  232classvar_default(List, Default) :-
  233    is_list(List),
  234    !,
  235    (   get(@pce, window_system, 'X'),
  236        get(@pce, operating_system, OS),
  237        sub_atom(OS, _, _, _, darwin),
  238        memberchk(apple(AppleDefault), List)
  239    ->  Default = AppleDefault
  240    ;   get(@pce, window_system, WS),
  241        Term =.. [WS,Default],
  242        memberchk(Term, List)
  243    ->  true
  244    ;   List = [H|_],
  245        compound(H),
  246        H =.. [_, Default]
  247    ->  true
  248    ;   throw(error(type_error(class_variable_default, List), _))
  249    ).
  250classvar_default(Default, Default).
  251
  252
  253run_directives([], _).
  254run_directives(Directives, Class) :-
  255    send(@class, assign, Class),
  256    run_directives(Directives).
  257
  258run_directives([]).
  259run_directives([H|T]) :-
  260    H,
  261    run_directives(T).
  262
  263delete_prolog_methods(Class) :-
  264    get(Class, name, ClassName),
  265    (   pce_lazy_send_method(Selector, ClassName, _Binder1),
  266        send(Class, delete_send_method, Selector),
  267        fail
  268    ;   pce_lazy_get_method(Selector, ClassName, _Binder2),
  269        send(Class, delete_get_method, Selector),
  270        fail
  271    ;   true
  272    ).
  273
  274
  275                 /*******************************
  276                 *    LAZY METHOD RESOLUTION    *
  277                 *******************************/

 resolve_method_message(-Message)

Create the @pce_resolve_method_message that is called by XPCE whenever there is a method to be resolved.

  284resolve_method_message(X) :-
  285    X = @pce_resolve_method_message,
  286    (   object(X)
  287    ->  true
  288    ;   new(X, message(@prolog, call, '_bind_lazy', @arg1, @arg2, @arg3))
  289    ).
  290
  291pce_ifhostproperty(prolog(swi),
  292                   (:- '$hide'('_bind_lazy'/3))).
  293
  294pce_ifhostproperty(prolog(swi),
  295('_bind_lazy'(Type, ClassName, Selector) :-
  296%       format('bind_lazy(~p, ~p, ~p)~n', [Type, ClassName, Selector]),
  297        notrace(do_bind_lazy(Type, ClassName, Selector))),
  298('_bind_lazy'(Type, ClassName, Selector) :-
  299        do_bind_lazy(Type, ClassName, Selector))).
  300
  301do_bind_lazy(send, ClassName, @default) :-
  302    !,
  303    get(@pce, convert, ClassName, class, Class),
  304    (   send_binder(Selector, ClassName, Binder),
  305        \+ send(Class, bound_send_method, Selector),
  306        call_binder(ClassName, Selector, Binder),
  307        fail ; true
  308    ).
  309do_bind_lazy(send, ClassName, Selector) :-
  310    send_binder(Selector, ClassName, Binder),
  311    call_binder(ClassName, Selector, Binder).
  312do_bind_lazy(get, ClassName, @default) :-
  313    !,
  314    get(@pce, convert, ClassName, class, Class),
  315    (   get_binder(Selector, ClassName, Binder),
  316        \+ send(Class, bound_get_method, Selector),
  317        call_binder(ClassName, Selector, Binder),
  318        fail ; true
  319    ).
  320do_bind_lazy(get, ClassName, Selector) :-
  321    get_binder(Selector, ClassName, Binder),
  322    call_binder(ClassName, Selector, Binder).
  323
  324/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  325This deals with possible redefined methods.  We distinguish two types of
  326`legal' method redefinition: using pce_extend_class/1  and redefining an
  327implementation inherited from a template.
  328
  329Other cases are reported by checkpce/0.
  330- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  331
  332send_binder(Sel, Class, Binder) :-
  333    bagof(B, pce_lazy_send_method(Sel, Class, B), Binders),
  334    last(Binders, Binder).
  335get_binder(Sel, Class, Binder) :-
  336    bagof(B, pce_lazy_get_method(Sel, Class, B), Binders),
  337    last(Binders, Binder).
  338
  339call_binder(ClassName, Selector, Binder) :-
  340    build_in_binder(Binder, ClassName, Selector),
  341    !.
  342call_binder(ClassName, Selector, Binder) :-
  343    call(Binder, ClassName, Selector).
  344
  345build_in_binder(bind_send(Id, T, D, L, G), C, S) :-
  346    !,
  347    pce_bind_send(Id, T, D, L, G, C, S).
  348build_in_binder(bind_send(Id, T, D, L), C, S) :-
  349    !,
  350    pce_bind_send(Id, T, D, L, @default, C, S).
  351build_in_binder(bind_send(Id, T, D), C, S) :-
  352    !,
  353    pce_bind_send(Id, T, D, @default, @default, C, S).
  354build_in_binder(bind_send(Id, T), C, S) :-
  355    !,
  356    pce_bind_send(Id, T, @default, @default, @default, C, S).
  357
  358build_in_binder(bind_get(Id, R, T, D, L, G), C, S) :-
  359    !,
  360    pce_bind_get(Id, R, T, D, L, G, C, S).
  361build_in_binder(bind_get(Id, R, T, D, L), C, S) :-
  362    !,
  363    pce_bind_get(Id, R, T, D, L, @default, C, S).
  364build_in_binder(bind_get(Id, R, T, D), C, S) :-
  365    !,
  366    pce_bind_get(Id, R, T, D, @default, @default, C, S).
  367build_in_binder(bind_get(Id, R, T), C, S) :-
  368    !,
  369    pce_bind_get(Id, R, T, @default, @default, @default, C, S).
  370
  371
  372pce_bind_send(Id, Types, Doc, Loc, Group, ClassName, Selector) :-
  373    get(@pce, convert, ClassName, class, Class),
  374    pce_method_implementation(Id, Message),
  375    send(Class, send_method,
  376         send_method(Selector, Types, Message, Doc, Loc, Group)).
  377
  378pce_bind_get(Id, RType, Types, Doc, Loc, Group, ClassName, Selector) :-
  379    get(@pce, convert, ClassName, class, Class),
  380    pce_method_implementation(Id, Message),
  381    send(Class, get_method,
  382         get_method(Selector, RType, Types, Message, Doc, Loc, Group))