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