View source with raw comments or as raw
    1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        J.Wielemaker@cs.nu.nl
    5    WWW:           http://www.swi-prolog.nl/projects/xpce/
    6    Copyright (c)  1985-2019, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module(pce_principal,
   38          [ new/2, free/1,
   39
   40            send/2, send/3, send/4, send/5, send/6, send/7,
   41            send/8,
   42
   43            get/3, get/4, get/5, get/6, get/7, get/8,
   44
   45            send_class/3,
   46            get_class/4,
   47
   48            object/1, object/2,
   49
   50            pce_class/6,
   51            pce_lazy_send_method/3,
   52            pce_lazy_get_method/3,
   53            pce_uses_template/2,
   54
   55            pce_method_implementation/2,
   56
   57            pce_open/3,                 % +Object, +Mode, -Stream
   58            in_pce_thread/1,            % :Goal
   59            set_pce_thread/0,
   60            pce_dispatch/0,
   61
   62            pce_postscript_stream/1,    % -Stream
   63
   64            op(200, fy,  @),
   65            op(250, yfx, ?),
   66            op(800, xfx, :=)
   67          ]).   68:- use_module(library(apply)).   69:- use_module(library(lists)).   70
   71
   72:- meta_predicate
   73    send_class(+, +, :),
   74    send(+, :),
   75    send(+, :, +),
   76    send(+, :, +, +),
   77    send(+, :, +, +, +),
   78    send(+, :, +, +, +, +),
   79    send(+, :, +, +, +, +, +),
   80
   81    get_class(+, +, :, -),
   82    get(+, :, -),
   83    get(+, :, +, -),
   84    get(+, :, +, +, -),
   85    get(+, :, +, +, +, -),
   86    get(+, :, +, +, +, +, -),
   87    get(+, :, +, +, +, +, +, -),
   88
   89    new(?, :).   90
   91                /********************************
   92                *             HOME              *
   93                ********************************/
 pce_home(-Home) is det
True when Home is the home directory of XPCE.
   99pce_home(PceHome) :-
  100    absolute_file_name(pce('.'), PceHome,
  101                       [ file_type(directory),
  102                         file_errors(fail)
  103                       ]),
  104    exists_directory(PceHome),
  105    !.
  106pce_home(PceHome) :-
  107    getenv('XPCEHOME', PceHome),
  108    exists_directory(PceHome),
  109    !.
  110pce_home(PceHome) :-
  111    (   current_prolog_flag(xpce_version, Version),
  112        atom_concat('/xpce-', Version, Suffix)
  113    ;   Suffix = '/xpce'
  114    ),
  115    absolute_file_name(swi(Suffix), PceHome,
  116                       [ file_type(directory),
  117                         file_errors(fail)
  118                       ]),
  119    exists_directory(PceHome),
  120    !.
  121pce_home(PceHome) :-
  122    current_prolog_flag(saved_program, true),
  123    !,
  124    (   current_prolog_flag(home, PceHome)
  125    ->  true
  126    ;   current_prolog_flag(executable, Exe)
  127    ->  file_directory_name(Exe, PceHome)
  128    ;   PceHome = '.'
  129    ).
  130pce_home(_) :-
  131    throw(error(pce_error(no_home), _)).
 xpce_application_dir(-Dir)
Set the directory for storing user XPCE configuration and data.
  137xpce_application_dir(Dir) :-
  138    create_config_directory(user_app_config(xpce), Dir),
  139    !.
  140xpce_application_dir(Dir) :-
  141    expand_file_name('~/.xpce', [Dir]).
 create_config_directory(+Alias, -Dir) is semidet
Try to find an existing config directory or create a writeable config directory below a directory owned by this process. If there are multiple possibilities, create the one that requires the least number of new directories.
  151create_config_directory(Alias, Dir) :-
  152    member(Access, [write, read]),
  153    absolute_file_name(Alias, Dir0,
  154                       [ file_type(directory),
  155                         access(Access),
  156                         file_errors(fail)
  157                       ]),
  158    !,
  159    Dir = Dir0.
  160create_config_directory(Alias, Dir) :-
  161    findall(Candidate,
  162            absolute_file_name(Alias, Candidate,
  163                               [ solutions(all),
  164                                 file_errors(fail)
  165                               ]),
  166            Candidates),
  167    convlist(missing, Candidates, Paths),
  168    member(_-Create, Paths),
  169    catch(maplist(make_directory, Create), _, fail),
  170    !,
  171    last(Create, Dir).
  172
  173missing(Dir, Len-Create) :-
  174    missing_(Dir, Create0),
  175    reverse(Create0, Create),
  176    length(Create, Len).
  177
  178missing_(Dir, []) :-
  179    exists_directory(Dir),
  180    access_file(Dir, write),
  181    '$my_file'(Dir),
  182    !.
  183missing_(Dir, [Dir|T]) :-
  184    file_directory_name(Dir, Parent),
  185    Parent \== Dir,
  186    missing_(Parent, T).
  187
  188
  189                /********************************
  190                *           LOAD C-PART         *
  191                ********************************/
  192
  193init_pce :-
  194    catch(load_foreign_library(foreign(pl2xpce)),
  195          error(Error, _Context),           % suppress stack trace
  196          (   print_message(error, error(Error, _)),
  197              fail
  198          )),
  199    pce_home(Home),
  200    xpce_application_dir(AppDir),
  201    pce_init(Home, AppDir),
  202    !,
  203    create_prolog_flag(xpce, true, []),
  204    thread_self(Me),
  205    assert(pce:pce_thread(Me)).
  206init_pce :-
  207    print_message(error, error(pce_error(init_failed), _)),
  208    halt(1).
  209
  210:- initialization(init_pce, now).  211
  212:- noprofile((send_implementation/3,
  213              get_implementation/4,
  214              send_class/3,
  215              get_class/4,
  216              new/2,
  217              send/2,
  218              get/3)).  219
  220
  221                /********************************
  222                *          PROLOG LAYER         *
  223                ********************************/
 free(+Ref) is det
Delete object if it exists.
  230free(Ref) :-
  231    object(Ref),
  232    !,
  233    send(Ref, free).
  234free(_).
 send(+Object, +Selector, +Arg...) is semidet
Succeeds if sending a message to Object with Selector and the given Arguments succeeds. Normally, goal_expansion/2 expands all these goals into send(Receiver, Method(Args...)).
  243send(Receiver, M:Selector, A1) :-
  244    functor(Message, Selector, 1),
  245    arg(1, Message, A1),
  246    send(Receiver, M:Message).
  247
  248send(Receiver, M:Selector, A1, A2) :-
  249    functor(Message, Selector, 2),
  250    arg(1, Message, A1),
  251    arg(2, Message, A2),
  252    send(Receiver, M:Message).
  253
  254send(Receiver, M:Selector, A1, A2, A3) :-
  255    functor(Message, Selector, 3),
  256    arg(1, Message, A1),
  257    arg(2, Message, A2),
  258    arg(3, Message, A3),
  259    send(Receiver, M:Message).
  260
  261send(Receiver, M:Selector, A1, A2, A3, A4) :-
  262    functor(Message, Selector, 4),
  263    arg(1, Message, A1),
  264    arg(2, Message, A2),
  265    arg(3, Message, A3),
  266    arg(4, Message, A4),
  267    send(Receiver, M:Message).
  268
  269send(Receiver, M:Selector, A1, A2, A3, A4, A5) :-
  270    functor(Message, Selector, 5),
  271    arg(1, Message, A1),
  272    arg(2, Message, A2),
  273    arg(3, Message, A3),
  274    arg(4, Message, A4),
  275    arg(5, Message, A5),
  276    send(Receiver, M:Message).
  277
  278send(Receiver, M:Selector, A1, A2, A3, A4, A5, A6) :-
  279    functor(Message, Selector, 6),
  280    arg(1, Message, A1),
  281    arg(2, Message, A2),
  282    arg(3, Message, A3),
  283    arg(4, Message, A4),
  284    arg(5, Message, A5),
  285    arg(6, Message, A6),
  286    send(Receiver, M:Message).
 get(+Object, :Selector, +Arg..., ?Rval) is semidet
See the comments with send/[3-12].
  293get(Receiver, M:Selector, A1, Answer) :-
  294    functor(Message, Selector, 1),
  295    arg(1, Message, A1),
  296    get(Receiver, M:Message, Answer).
  297
  298get(Receiver, M:Selector, A1, A2, Answer) :-
  299    functor(Message, Selector, 2),
  300    arg(1, Message, A1),
  301    arg(2, Message, A2),
  302    get(Receiver, M:Message, Answer).
  303
  304get(Receiver, M:Selector, A1, A2, A3, Answer) :-
  305    functor(Message, Selector, 3),
  306    arg(1, Message, A1),
  307    arg(2, Message, A2),
  308    arg(3, Message, A3),
  309    get(Receiver, M:Message, Answer).
  310
  311get(Receiver, M:Selector, A1, A2, A3, A4, Answer) :-
  312    functor(Message, Selector, 4),
  313    arg(1, Message, A1),
  314    arg(2, Message, A2),
  315    arg(3, Message, A3),
  316    arg(4, Message, A4),
  317    get(Receiver, M:Message, Answer).
  318
  319get(Receiver, M:Selector, A1, A2, A3, A4, A5, Answer) :-
  320    functor(Message, Selector, 5),
  321    arg(1, Message, A1),
  322    arg(2, Message, A2),
  323    arg(3, Message, A3),
  324    arg(4, Message, A4),
  325    arg(5, Message, A5),
  326    get(Receiver, M:Message, Answer).
  327
  328
  329                 /*******************************
  330                 *           NEW SEND           *
  331                 *******************************/
  332
  333:- multifile
  334    send_implementation/3,
  335    get_implementation/4.
 send_implementation(+Id, +Message, +Object)
Method-bodies are compiled into clauses for this predicate. Id is a unique identifier for the implementation, Message is a compound whose functor is the method name and whose arguments are the arguments to the method-call. Object is the receiving object.
  345send_implementation(true, _Args, _Obj).
  346send_implementation(fail, _Args, _Obj) :- fail.
  347send_implementation(once(Id), Args, Obj) :-
  348    send_implementation(Id, Args, Obj),
  349    !.
  350send_implementation(spy(Id), Args, Obj) :-
  351    (   current_prolog_flag(debug, true)
  352    ->  trace,
  353        send_implementation(Id, Args, Obj)
  354    ;   send_implementation(Id, Args, Obj)
  355    ).
  356send_implementation(trace(Id), Args, Obj) :-
  357    pce_info(pce_trace(enter, send_implementation(Id, Args, Obj))),
  358    (   send_implementation(Id, Args, Obj)
  359    ->  pce_info(pce_trace(exit, send_implementation(Id, Args, Obj)))
  360    ;   pce_info(pce_trace(fail, send_implementation(Id, Args, Obj)))
  361    ).
 get_implementation(+Id, +Message, +Object, -Return)
As send_implementation/3, but for get-methods.
  368get_implementation(true, _Args, _Obj, _Rval).
  369get_implementation(fail, _Args, _Obj, _Rval) :- fail.
  370get_implementation(once(Id), Args, Obj, Rval) :-
  371    get_implementation(Id, Args, Obj, Rval),
  372    !.
  373get_implementation(spy(Id), Args, Obj, Rval) :-
  374    (   current_prolog_flag(debug, true)
  375    ->  trace,
  376        get_implementation(Id, Args, Obj, Rval)
  377    ;   get_implementation(Id, Args, Obj, Rval)
  378    ).
  379get_implementation(trace(Id), Args, Obj, Rval) :-
  380    pce_info(pce_trace(enter, get_implementation(Id, Args, Obj, Rval))),
  381    (   get_implementation(Id, Args, Obj, Rval)
  382    ->  pce_info(pce_trace(exit, get_implementation(Id, Args, Obj, Rval)))
  383    ;   pce_info(pce_trace(fail, get_implementation(Id, Args, Obj, Rval))),
  384        fail
  385    ).
  386
  387%       SWI-Prolog: make this a normal user (debug-able) predicate.
  388
  389pce_ifhostproperty(prolog(swi), [
  390(:- unlock_predicate(send_implementation/3)),
  391(:- unlock_predicate(get_implementation/4)),
  392(:- '$set_predicate_attribute'(send_implementation(_,_,_),  hide_childs, false)),
  393(:- '$set_predicate_attribute'(get_implementation(_,_,_,_), hide_childs, false))
  394                   ]).
  395
  396
  397                 /*******************************
  398                 *          DECLARATIONS        *
  399                 *******************************/
  400
  401:- multifile
  402    pce_class/6,
  403    pce_lazy_send_method/3,
  404    pce_lazy_get_method/3,
  405    pce_uses_template/2.  406
  407
  408                 /*******************************
  409                 *            @PROLOG           *
  410                 *******************************/
  411
  412:- initialization
  413   (object(@prolog) -> true ; send(@host, name_reference, prolog)).