1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  1995-2016, University of Amsterdam
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(qsave,
   37          [ qsave_program/1,                    % +File
   38            qsave_program/2                     % +File, +Options
   39          ]).   40:- use_module(library(lists)).   41:- use_module(library(option)).   42:- use_module(library(error)).   43
   44/** <module> Save current program as a state or executable
   45
   46This library provides qsave_program/1  and   qsave_program/2,  which are
   47also used by the commandline sequence below.
   48
   49  ==
   50  swipl -o exe -c file.pl ...
   51  ==
   52*/
   53
   54:- meta_predicate
   55    qsave_program(+, :).   56
   57:- predicate_options(qsave_program/2, 2,
   58                     [ local(integer),
   59                       global(integer),
   60                       trail(integer),
   61                       goal(callable),
   62                       toplevel(callable),
   63                       init_file(atom),
   64                       class(oneof([runtime,kernel,development])),
   65                       autoload(boolean),
   66                       map(atom),
   67                       op(oneof([save,standard])),
   68                       stand_alone(boolean),
   69                       foreign(oneof([save,no_save])),
   70                       emulator(atom)
   71                     ]).   72
   73:- set_prolog_flag(generate_debug_info, false).   74
   75:- dynamic verbose/1.   76:- volatile verbose/1.                  % contains a stream-handle
   77
   78%!  qsave_program(+File) is det.
   79%!  qsave_program(+File, :Options) is det.
   80%
   81%   Make a saved state in file `File'.
   82
   83qsave_program(File) :-
   84    qsave_program(File, []).
   85
   86qsave_program(FileBase, Options0) :-
   87    meta_options(is_meta, Options0, Options),
   88    check_options(Options),
   89    exe_file(FileBase, File),
   90    option(class(SaveClass),    Options, runtime),
   91    option(init_file(InitFile), Options, DefInit),
   92    default_init_file(SaveClass, DefInit),
   93    save_autoload(Options),
   94    open_map(Options),
   95    create_prolog_flag(saved_program, true, []),
   96    create_prolog_flag(saved_program_class, SaveClass, []),
   97    (   exists_file(File)
   98    ->  delete_file(File)
   99    ;   true
  100    ),
  101    '$rc_open_archive'(File, RC),
  102    make_header(RC, SaveClass, Options),
  103    save_options(RC, SaveClass,
  104                 [ init_file(InitFile)
  105                 | Options
  106                 ]),
  107    save_resources(RC, SaveClass),
  108    '$rc_open'(RC, '$state', '$prolog', write, StateFd),
  109    '$open_wic'(StateFd),
  110    setup_call_cleanup(
  111        ( current_prolog_flag(access_level, OldLevel),
  112          set_prolog_flag(access_level, system) % generate system modules
  113        ),
  114        ( save_modules(SaveClass),
  115          save_records,
  116          save_flags,
  117          save_prompt,
  118          save_imports,
  119          save_prolog_flags,
  120          save_operators(Options),
  121          save_format_predicates
  122        ),
  123        set_prolog_flag(access_level, OldLevel)),
  124    '$close_wic',
  125    close(StateFd),
  126    save_foreign_libraries(RC, Options),
  127    '$rc_close_archive'(RC),
  128    '$mark_executable'(File),
  129    close_map.
  130
  131is_meta(goal).
  132is_meta(toplevel).
  133
  134exe_file(Base, Exe) :-
  135    current_prolog_flag(windows, true),
  136    file_name_extension(_, '', Base),
  137    !,
  138    file_name_extension(Base, exe, Exe).
  139exe_file(Exe, Exe).
  140
  141default_init_file(runtime, none) :- !.
  142default_init_file(_,       InitFile) :-
  143    '$cmd_option_val'(init_file, InitFile).
  144
  145
  146                 /*******************************
  147                 *           HEADER             *
  148                 *******************************/
  149
  150make_header(RC, _, Options) :-
  151    option(emulator(OptVal), Options),
  152    !,
  153    absolute_file_name(OptVal, [access(read)], Emulator),
  154    '$rc_append_file'(RC, '$header', '$rc', none, Emulator).
  155make_header(RC, _, Options) :-
  156    (   current_prolog_flag(windows, true)
  157    ->  DefStandAlone = true
  158    ;   DefStandAlone = false
  159    ),
  160    option(stand_alone(true), Options, DefStandAlone),
  161    !,
  162    current_prolog_flag(executable, Executable),
  163    '$rc_append_file'(RC, '$header', '$rc', none, Executable).
  164make_header(RC, SaveClass, _Options) :-
  165    current_prolog_flag(unix, true),
  166    !,
  167    current_prolog_flag(executable, Executable),
  168    '$rc_open'(RC, '$header', '$rc', write, Fd),
  169    format(Fd, '#!/bin/sh~n', []),
  170    format(Fd, '# SWI-Prolog saved state~n', []),
  171    (   SaveClass == runtime
  172    ->  ArgSep = ' -- '
  173    ;   ArgSep = ' '
  174    ),
  175    format(Fd, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]),
  176    close(Fd).
  177make_header(_, _, _).
  178
  179
  180                 /*******************************
  181                 *           OPTIONS            *
  182                 *******************************/
  183
  184min_stack(local,    32).
  185min_stack(global,   16).
  186min_stack(trail,    16).
  187
  188convert_option(Stack, Val, NewVal, "~w") :-     % stack-sizes are in K-bytes
  189    min_stack(Stack, Min),
  190    !,
  191    (   Val == 0
  192    ->  NewVal = Val
  193    ;   NewVal is max(Min, Val*1024)
  194    ).
  195convert_option(toplevel, Callable, Callable, "~q") :- !.
  196convert_option(_, Value, Value, "~w").
  197
  198doption(Name) :- min_stack(Name, _).
  199doption(toplevel).
  200doption(init_file).
  201doption(system_init_file).
  202doption(class).
  203doption(home).
  204
  205%!  save_options(+ArchiveHandle, +SaveClass, +Options)
  206%
  207%   Save the options in the '$options'   resource. The home directory is
  208%   saved for development  states  to  make   it  keep  refering  to the
  209%   development home.
  210%
  211%   The script files (-s script) are not saved   at all. I think this is
  212%   fine to avoid a save-script loading itself.
  213
  214save_options(RC, SaveClass, Options) :-
  215    '$rc_open'(RC, '$options', '$prolog', write, Fd),
  216    (   doption(OptionName),
  217            '$cmd_option_val'(OptionName, OptionVal0),
  218            save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
  219            OptTerm =.. [OptionName,OptionVal2],
  220            (   option(OptTerm, Options)
  221            ->  convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
  222            ;   OptionVal = OptionVal1,
  223                FmtVal = "~w"
  224            ),
  225            atomics_to_string(["~w=", FmtVal, "~n"], Fmt),
  226            format(Fd, Fmt, [OptionName, OptionVal]),
  227        fail
  228    ;   true
  229    ),
  230    save_init_goals(Fd, Options),
  231    close(Fd).
  232
  233%!  save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)
  234
  235save_option_value(Class,   class, _,     Class) :- !.
  236save_option_value(runtime, home,  _,     _) :- !, fail.
  237save_option_value(_,       _,     Value, Value).
  238
  239%!  save_init_goals(+Stream, +Options)
  240%
  241%   Save initialization goals. If there  is   a  goal(Goal)  option, use
  242%   that, else save the goals from '$cmd_option_val'/2.
  243
  244save_init_goals(Out, Options) :-
  245    option(goal(Goal), Options),
  246    !,
  247    format(Out, 'goal=~q~n', [Goal]).
  248save_init_goals(Out, _) :-
  249    '$cmd_option_val'(goals, Goals),
  250    forall(member(Goal, Goals),
  251           format(Out, 'goal=~w~n', [Goal])).
  252
  253
  254                 /*******************************
  255                 *           RESOURCES          *
  256                 *******************************/
  257
  258save_resources(_RC, development) :- !.
  259save_resources(RC, _SaveClass) :-
  260    feedback('~nRESOURCES~n~n', []),
  261    copy_resources(RC),
  262    (   current_predicate(_, M:resource(_,_,_)),
  263        forall(M:resource(Name, Class, FileSpec),
  264               (   mkrcname(M, Name, RcName),
  265                   save_resource(RC, RcName, Class, FileSpec)
  266               )),
  267        fail
  268    ;   true
  269    ).
  270
  271mkrcname(user, Name, Name) :- !.
  272mkrcname(M, Name, RcName) :-
  273    atomic_list_concat([M, :, Name], RcName).
  274
  275save_resource(RC, Name, Class, FileSpec) :-
  276    absolute_file_name(FileSpec,
  277                       [ access(read),
  278                         file_errors(fail)
  279                       ], File),
  280    !,
  281    feedback('~t~8|~w~t~32|~w~t~48|~w~n',
  282             [Name, Class, File]),
  283    '$rc_append_file'(RC, Name, Class, none, File).
  284save_resource(RC, Name, Class, _) :-
  285    '$rc_handle'(SystemRC),
  286    copy_resource(SystemRC, RC, Name, Class),
  287    !.
  288save_resource(_, Name, Class, FileSpec) :-
  289    print_message(warning,
  290                  error(existence_error(resource,
  291                                        resource(Name, Class, FileSpec)),
  292                        _)).
  293
  294copy_resources(ToRC) :-
  295    '$rc_handle'(FromRC),
  296    '$rc_members'(FromRC, List),
  297    (   member(rc(Name, Class), List),
  298        \+ user:resource(Name, Class, _),
  299        \+ reserved_resource(Name, Class),
  300        copy_resource(FromRC, ToRC, Name, Class),
  301        fail
  302    ;   true
  303    ).
  304
  305reserved_resource('$header',    '$rc').
  306reserved_resource('$state',     '$prolog').
  307reserved_resource('$options',   '$prolog').
  308
  309copy_resource(FromRC, ToRC, Name, Class) :-
  310    setup_call_cleanup(
  311        '$rc_open'(FromRC, Name, Class, read,  FdIn),
  312        setup_call_cleanup(
  313            '$rc_open'(ToRC,   Name, Class, write, FdOut),
  314            ( feedback('~t~8|~w~t~24|~w~t~40|~w~n',
  315                       [Name, Class, '<Copied from running state>']),
  316              copy_stream_data(FdIn, FdOut)
  317            ),
  318            close(FdOut)),
  319        close(FdIn)).
  320
  321
  322                 /*******************************
  323                 *            MODULES           *
  324                 *******************************/
  325
  326save_modules(SaveClass) :-
  327    forall(special_module(X),
  328           save_module(X, SaveClass)),
  329    forall((current_module(X), \+ special_module(X)),
  330           save_module(X, SaveClass)).
  331
  332special_module(system).
  333special_module(user).
  334
  335define_predicate(Head) :-
  336    '$define_predicate'(Head),
  337    !.   % autoloader
  338define_predicate(Head) :-
  339    strip_module(Head, _, Term),
  340    functor(Term, Name, Arity),
  341    throw(error(existence_error(procedure, Name/Arity), _)).
  342
  343
  344                 /*******************************
  345                 *            AUTOLOAD          *
  346                 *******************************/
  347
  348define_init_goal(Options) :-
  349    option(goal(Goal), Options),
  350    !,
  351    define_predicate(Goal).
  352define_init_goal(_).
  353
  354define_toplevel_goal(Options) :-
  355    option(toplevel(Goal), Options),
  356    !,
  357    define_predicate(Goal).
  358define_toplevel_goal(_).
  359
  360save_autoload(Options) :-
  361    define_init_goal(Options),
  362    define_toplevel_goal(Options),
  363    option(autoload(true),  Options, true),
  364    !,
  365    autoload(Options).
  366save_autoload(_).
  367
  368
  369                 /*******************************
  370                 *             MODULES          *
  371                 *******************************/
  372
  373%!  save_module(+Module, +SaveClass)
  374%
  375%   Saves a module
  376
  377save_module(M, SaveClass) :-
  378    '$qlf_start_module'(M),
  379    feedback('~n~nMODULE ~w~n', [M]),
  380    save_unknown(M),
  381    (   P = (M:_H),
  382        current_predicate(_, P),
  383        \+ predicate_property(P, imported_from(_)),
  384        save_predicate(P, SaveClass),
  385        fail
  386    ;   '$qlf_end_part',
  387        feedback('~n', [])
  388    ).
  389
  390save_predicate(P, _SaveClass) :-
  391    predicate_property(P, foreign),
  392    !,
  393    P = (M:H),
  394    functor(H, Name, Arity),
  395    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
  396    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
  397save_predicate(P, SaveClass) :-
  398    P = (M:H),
  399    functor(H, F, A),
  400    feedback('~nsaving ~w/~d ', [F, A]),
  401    (   H = resource(_,_,_),
  402        SaveClass \== development
  403    ->  save_attribute(P, (dynamic)),
  404        (   M == user
  405        ->  save_attribute(P, (multifile))
  406        ),
  407        feedback('(Skipped clauses)', []),
  408        fail
  409    ;   true
  410    ),
  411    (   no_save(P)
  412    ->  true
  413    ;   save_attributes(P),
  414        \+ predicate_property(P, (volatile)),
  415        (   nth_clause(P, _, Ref),
  416            feedback('.', []),
  417            '$qlf_assert_clause'(Ref, SaveClass),
  418            fail
  419        ;   true
  420        )
  421    ).
  422
  423no_save(P) :-
  424    predicate_property(P, volatile),
  425    \+ predicate_property(P, dynamic),
  426    \+ predicate_property(P, multifile).
  427
  428pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
  429    !,
  430    strip_module(Head, M, _).
  431pred_attrib(Attrib, Head,
  432            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
  433    attrib_name(Attrib, AttName, Val),
  434    strip_module(Head, M, Term),
  435    functor(Term, Name, Arity).
  436
  437attrib_name(dynamic,                dynamic,                true).
  438attrib_name(volatile,               volatile,               true).
  439attrib_name(thread_local,           thread_local,           true).
  440attrib_name(multifile,              multifile,              true).
  441attrib_name(public,                 public,                 true).
  442attrib_name(transparent,            transparent,            true).
  443attrib_name(discontiguous,          discontiguous,          true).
  444attrib_name(notrace,                trace,                  false).
  445attrib_name(show_childs,            hide_childs,            false).
  446attrib_name(built_in,               system,                 true).
  447attrib_name(nodebug,                hide_childs,            true).
  448attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
  449attrib_name(iso,                    iso,                    true).
  450
  451
  452save_attribute(P, Attribute) :-
  453    pred_attrib(Attribute, P, D),
  454    (   Attribute == built_in       % no need if there are clauses
  455    ->  (   predicate_property(P, number_of_clauses(0))
  456        ->  true
  457        ;   predicate_property(P, volatile)
  458        )
  459    ;   Attribute == 'dynamic'      % no need if predicate is thread_local
  460    ->  \+ predicate_property(P, thread_local)
  461    ;   true
  462    ),
  463    '$add_directive_wic'(D),
  464    feedback('(~w) ', [Attribute]).
  465
  466save_attributes(P) :-
  467    (   predicate_property(P, Attribute),
  468        save_attribute(P, Attribute),
  469        fail
  470    ;   true
  471    ).
  472
  473%       Save status of the unknown flag
  474
  475save_unknown(M) :-
  476    current_prolog_flag(M:unknown, Unknown),
  477    (   Unknown == error
  478    ->  true
  479    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
  480    ).
  481
  482                 /*******************************
  483                 *            RECORDS           *
  484                 *******************************/
  485
  486save_records :-
  487    feedback('~nRECORDS~n', []),
  488    (   current_key(X),
  489        X \== '$topvar',                        % do not safe toplevel variables
  490        feedback('~n~t~8|~w ', [X, V]),
  491        recorded(X, V, _),
  492        feedback('.', []),
  493        '$add_directive_wic'(recordz(X, V, _)),
  494        fail
  495    ;   true
  496    ).
  497
  498
  499                 /*******************************
  500                 *            FLAGS             *
  501                 *******************************/
  502
  503save_flags :-
  504    feedback('~nFLAGS~n~n', []),
  505    (   current_flag(X),
  506        flag(X, V, V),
  507        feedback('~t~8|~w = ~w~n', [X, V]),
  508        '$add_directive_wic'(set_flag(X, V)),
  509        fail
  510    ;   true
  511    ).
  512
  513save_prompt :-
  514    feedback('~nPROMPT~n~n', []),
  515    prompt(Prompt, Prompt),
  516    '$add_directive_wic'(prompt(_, Prompt)).
  517
  518
  519                 /*******************************
  520                 *           IMPORTS            *
  521                 *******************************/
  522
  523%!  save_imports
  524%
  525%   Save  import  relations.  An  import  relation  is  saved  if  a
  526%   predicate is imported from a module that is not a default module
  527%   for the destination module. If  the   predicate  is  dynamic, we
  528%   always define the explicit import relation to make clear that an
  529%   assert must assert on the imported predicate.
  530
  531save_imports :-
  532    feedback('~nIMPORTS~n~n', []),
  533    (   predicate_property(M:H, imported_from(I)),
  534        \+ default_import(M, H, I),
  535        functor(H, F, A),
  536        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
  537        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
  538        fail
  539    ;   true
  540    ).
  541
  542default_import(To, Head, From) :-
  543    '$get_predicate_attribute'(To:Head, (dynamic), 1),
  544    predicate_property(From:Head, exported),
  545    !,
  546    fail.
  547default_import(Into, _, From) :-
  548    default_module(Into, From).
  549
  550%!  restore_import(+TargetModule, +SourceModule, +PI) is det.
  551%
  552%   Restore import relation. This notably   deals  with imports from
  553%   the module =user=, avoiding a message  that the predicate is not
  554%   exported.
  555
  556restore_import(To, user, PI) :-
  557    !,
  558    export(user:PI),
  559    To:import(user:PI).
  560restore_import(To, From, PI) :-
  561    To:import(From:PI).
  562
  563                 /*******************************
  564                 *         PROLOG FLAGS         *
  565                 *******************************/
  566
  567save_prolog_flags :-
  568    feedback('~nPROLOG FLAGS~n~n', []),
  569    '$current_prolog_flag'(Flag, Value, _Scope, write, Type),
  570    \+ no_save_flag(Flag),
  571    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
  572    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
  573    fail.
  574save_prolog_flags.
  575
  576no_save_flag(argv).
  577no_save_flag(os_argv).
  578no_save_flag(access_level).
  579no_save_flag(tty_control).
  580no_save_flag(readline).
  581no_save_flag(associated_file).
  582no_save_flag(cpu_count).
  583no_save_flag(hwnd).                     % should be read-only, but comes
  584                                        % from user-code
  585
  586%!  restore_prolog_flag(+Name, +Value, +Type)
  587%
  588%   Deal  with  possibly   protected    flags   (debug_on_error  and
  589%   report_error are protected flags for the runtime kernel).
  590
  591restore_prolog_flag(Flag, Value, _Type) :-
  592    current_prolog_flag(Flag, Value),
  593    !.
  594restore_prolog_flag(Flag, Value, _Type) :-
  595    current_prolog_flag(Flag, _),
  596    !,
  597    catch(set_prolog_flag(Flag, Value), _, true).
  598restore_prolog_flag(Flag, Value, Type) :-
  599    create_prolog_flag(Flag, Value, [type(Type)]).
  600
  601
  602                 /*******************************
  603                 *           OPERATORS          *
  604                 *******************************/
  605
  606%!  save_operators(+Options) is det.
  607%
  608%   Save operators for all modules.   Operators for =system= are
  609%   not saved because these are read-only anyway.
  610
  611save_operators(Options) :-
  612    !,
  613    option(op(save), Options, save),
  614    feedback('~nOPERATORS~n', []),
  615    forall(current_module(M), save_module_operators(M)),
  616    feedback('~n', []).
  617save_operators(_).
  618
  619save_module_operators(system) :- !.
  620save_module_operators(M) :-
  621    forall('$local_op'(P,T,M:N),
  622           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
  623               '$add_directive_wic'(op(P,T,M:N))
  624           )).
  625
  626
  627                 /*******************************
  628                 *       FORMAT PREDICATES      *
  629                 *******************************/
  630
  631save_format_predicates :-
  632    feedback('~nFORMAT PREDICATES~n', []),
  633    current_format_predicate(Code, Head),
  634    qualify_head(Head, QHead),
  635    D = format_predicate(Code, QHead),
  636    feedback('~n~t~8|~w ', [D]),
  637    '$add_directive_wic'(D),
  638    fail.
  639save_format_predicates.
  640
  641qualify_head(T, T) :-
  642    functor(T, :, 2),
  643    !.
  644qualify_head(T, user:T).
  645
  646
  647                 /*******************************
  648                 *       FOREIGN LIBRARIES      *
  649                 *******************************/
  650
  651%!  save_foreign_libraries(+Archive, +Options) is det.
  652%
  653%   Save current foreign libraries into the archive.
  654
  655save_foreign_libraries(RC, Options) :-
  656    option(foreign(save), Options),
  657    !,
  658    feedback('~nFOREIGN LIBRARIES~n', []),
  659    forall(current_foreign_library(FileSpec, _Predicates),
  660           ( find_foreign_library(FileSpec, File),
  661             term_to_atom(FileSpec, Name),
  662             '$rc_append_file'(RC, Name, shared, none, File)
  663           )).
  664save_foreign_libraries(_, _).
  665
  666%!  find_foreign_library(+FileSpec, -File) is det.
  667%
  668%   Find the shared object specified by   FileSpec.  If posible, the
  669%   shared object is stripped to reduce   its size. This is achieved
  670%   by calling strip -o <tmp> <shared-object>. Note that the file is
  671%   a Prolog tmp file and will be deleted on halt.
  672%
  673%   @bug    Should perform OS search on failure
  674
  675find_foreign_library(FileSpec, SharedObject) :-
  676    absolute_file_name(FileSpec,
  677                       [ file_type(executable),
  678                         access(read),
  679                         file_errors(fail)
  680                       ], File),
  681    !,
  682    (   absolute_file_name(path(strip), Strip,
  683                           [ access(execute),
  684                             file_errors(fail)
  685                           ]),
  686        tmp_file(shared, Stripped),
  687        format(atom(Cmd), '"~w" -o "~w" "~w"',
  688               [ Strip, Stripped, File ]),
  689        shell(Cmd)
  690    ->  SharedObject = Stripped
  691    ;   SharedObject = File
  692    ).
  693
  694
  695                 /*******************************
  696                 *             UTIL             *
  697                 *******************************/
  698
  699open_map(Options) :-
  700    option(map(Map), Options),
  701    !,
  702    open(Map, write, Fd),
  703    asserta(verbose(Fd)).
  704open_map(_) :-
  705    retractall(verbose(_)).
  706
  707close_map :-
  708    retract(verbose(Fd)),
  709    close(Fd),
  710    !.
  711close_map.
  712
  713feedback(Fmt, Args) :-
  714    verbose(Fd),
  715    !,
  716    format(Fd, Fmt, Args).
  717feedback(_, _).
  718
  719
  720/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  721Option checking and exception generation.  This should be in a library!
  722- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  723
  724option_type(Name,        integer) :- min_stack(Name, _MinValue).
  725option_type(class,       oneof([runtime,kernel,development])).
  726option_type(autoload,    boolean).
  727option_type(map,         atom).
  728option_type(op,          oneof([save, standard])).
  729option_type(stand_alone, boolean).
  730option_type(foreign,     oneof([save, no_save])).
  731option_type(goal,        callable).
  732option_type(toplevel,    callable).
  733option_type(init_file,   atom).
  734option_type(emulator,    ground).
  735
  736check_options([]) :- !.
  737check_options([Var|_]) :-
  738    var(Var),
  739    !,
  740    throw(error(domain_error(save_options, Var), _)).
  741check_options([Name=Value|T]) :-
  742    !,
  743    (   option_type(Name, Type)
  744    ->  (   must_be(Type, Value)
  745        ->  check_options(T)
  746        ;   throw(error(domain_error(Type, Value), _))
  747        )
  748    ;   throw(error(domain_error(save_option, Name), _))
  749    ).
  750check_options([Term|T]) :-
  751    Term =.. [Name,Arg],
  752    !,
  753    check_options([Name=Arg|T]).
  754check_options([Var|_]) :-
  755    throw(error(domain_error(save_options, Var), _)).
  756check_options(Opt) :-
  757    throw(error(domain_error(list, Opt), _)).
  758
  759
  760                 /*******************************
  761                 *            MESSAGES          *
  762                 *******************************/
  763
  764:- multifile prolog:message/3.  765
  766prolog:message(no_resource(Name, Class, File)) -->
  767    [ 'Could not find resource ~w/~w on ~w or system resources'-
  768      [Name, Class, File] ]