home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / boot / init.pl < prev    next >
Text File  |  1993-02-17  |  27KB  |  1,021 lines
  1. /*  init.pl,v 1.7 1993/02/17 12:45:48 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: Get the Ball Rolling ...
  7. */
  8.  
  9. /*
  10. Consult, derivates and basic things.   This  module  is  loaded  by  the
  11. C-written  bootstrap  compiler.   For this reason the module is declared
  12. using low-level foreign predicates rather then the high level predicates
  13. use_module/[1,2].  Be careful: order of declarations is delicate in this
  14. module.
  15.  
  16. The $:- directive  is  executed  by  the  bootstrap  compiler,  but  not
  17. inserted  in  the  intermediate  code  file.   Used  to print diagnostic
  18. messages and start the Prolog defined compiler for  the  remaining  boot
  19. modules.
  20.  
  21. If you want  to  debug  this  module,  put  a  '$:-'  trace.   directive
  22. somewhere.   The  tracer will work properly under boot compilation as it
  23. will use the C defined write predicate  to  print  goals  and  does  not
  24. attempt to call the Prolog defined trace interceptor.
  25. */
  26.  
  27. '$:-' format('Loading boot file ...~n', []).
  28.  
  29.         /********************************
  30.         *    LOAD INTO MODULE SYSTEM    *
  31.         ********************************/
  32.  
  33. :- $set_source_module(_, system).
  34.  
  35.         /********************************
  36.         *          DIRECTIVES           *
  37.         *********************************/
  38.  
  39. op(_, _, []) :- !.
  40. op(Priority, Type, [Name|Rest]) :- !,
  41.     $op(Priority, Type, Name),
  42.     op(Priority, Type, Rest).
  43. op(Priority, Type, Name) :-
  44.     $op(Priority, Type, Name).
  45.  
  46. dynamic((Pred/Arity, More)) :- !,
  47.     functor(Term, Pred, Arity),
  48.     $predicate_attribute(Term, (dynamic), 1),
  49.     dynamic(More).
  50. dynamic(Pred/Arity) :-
  51.     functor(Term, Pred, Arity),
  52.     $predicate_attribute(Term, (dynamic), 1).
  53.  
  54. multifile((Pred/Arity, More)) :- !,
  55.     functor(Term, Pred, Arity),
  56.     $predicate_attribute(Term, (multifile), 1),
  57.     multifile(More).
  58. multifile(Pred/Arity) :-
  59.     functor(Term, Pred, Arity),
  60.     $predicate_attribute(Term, (multifile), 1).
  61.  
  62. module_transparent((Pred/Arity, More)) :- !,
  63.     functor(Term, Pred, Arity),
  64.     $predicate_attribute(Term, transparent, 1),
  65.     module_transparent(More).
  66. module_transparent(Pred/Arity) :-
  67.     functor(Term, Pred, Arity),
  68.     $predicate_attribute(Term, transparent, 1).
  69.  
  70. discontiguous((Pred/Arity, More)) :- !,
  71.     functor(Term, Pred, Arity),
  72.     $predicate_attribute(Term, (discontiguous), 1),
  73.     discontiguous(More).
  74. discontiguous(Pred/Arity) :-
  75.     functor(Term, Pred, Arity),
  76.     $predicate_attribute(Term, (discontiguous), 1).
  77.  
  78. :- module_transparent
  79.     (dynamic)/1,
  80.     (multifile)/1,
  81.     (module_transparent)/1,
  82.     (discontiguous)/1,
  83.     $hide/2,
  84.     $show_childs/2.
  85.  
  86.  
  87.         /********************************
  88.         *        TRACE BEHAVIOUR        *
  89.         *********************************/
  90.  
  91. %    $hide(+Name, +Arity)
  92. %    Predicates protected this way are never visible in the tracer.
  93.  
  94. $hide(Name, Arity) :-
  95.     functor(Head, Name, Arity),
  96.     $predicate_attribute(Head, trace, 0).
  97.  
  98. %    $show_childs(+Name, +Arity)
  99. %    Normally system predicates hide their childs frames if these are
  100. %    system predicates as well.  $show_childs suppresses this.
  101.  
  102. $show_childs(Name, Arity) :-  
  103.     functor(Head, Name, Arity),
  104.         $predicate_attribute(Head, hide_childs, 0).
  105.  
  106.         /********************************
  107.         *       CALLING, CONTROL        *
  108.         *********************************/
  109.  
  110. :- module_transparent
  111.     ';'/2,
  112.     '|'/2,
  113.     ','/2,
  114.     call/1,
  115.     (^)/2,
  116.     (not)/1,
  117.     (\+)/1,
  118.     (->)/2,
  119.     once/1,
  120.     ignore/1,
  121.     apply/2.
  122.  
  123. true.                    % this is easy!
  124.  
  125. %   ->/2, ;/2, |/2 and \+/1 are normally compiled. These predicate catch them
  126. %   in case they are called via the meta-call predicates.
  127.  
  128. (If -> Then) :- If, !, Then.
  129.  
  130. (If -> Then; _Else) :- If, !, Then.
  131. (_If -> _Then; Else) :- !, Else.
  132. ';'(Goal, _) :- Goal.
  133. ';'(_, Goal) :- Goal.
  134.  
  135. (If -> Then | _Else) :- If, !, Then.
  136. (_If -> _Then | Else) :- !, Else.
  137. '|'(Goal, _) :- Goal.
  138. '|'(_, Goal) :- Goal.
  139.  
  140. ','(Goal1, Goal2) :-            % Puzzle for beginners!
  141.     Goal1,
  142.     Goal2.
  143.  
  144. call(Goal) :-
  145.     Goal.
  146.  
  147. not(Goal) :-
  148.     Goal, !,
  149.     fail.
  150. not(_).
  151.  
  152. %    This version of not is compiled as well. For meta-calls only
  153.  
  154. \+ Goal :-
  155.     Goal, !,
  156.     fail.
  157. \+ _.
  158.  
  159. %    once/1 can normally be replaced by ->/2. For historical reasons
  160. %    only.
  161.  
  162. once(Goal) :-
  163.     Goal, !.
  164.  
  165. ignore(Goal) :-
  166.     Goal, !.
  167. ignore(_Goal).
  168.  
  169. apply(Pred, Arguments) :-
  170.     $apply(Pred, Arguments).        % handled by the compiler
  171.  
  172. _Var^Goal :-                    % setof/3, bagof/3
  173.     Goal.
  174.  
  175. :-
  176.     $hide((';'), 2),
  177.     $hide(('|'), 2),
  178.     $hide((','), 2),
  179.     $hide((->), 2),
  180.     $show_childs(^, 2),
  181.     $show_childs(call, 1),
  182.     $show_childs(not, 1),
  183.     $show_childs(\+, 1),
  184.     $show_childs(once, 1),
  185.     $show_childs(ignore, 1),     
  186.     $show_childs((','), 2),     
  187.     $show_childs((';'), 2),     
  188.     $show_childs(('|'), 2),
  189.     $show_childs((->), 2).
  190.  
  191.  
  192.         /********************************
  193.         *            MODULES            *
  194.         *********************************/
  195.  
  196. %    $prefix_module(+Module, +Context, +Term, -Prefixed)
  197. %    Tags `Term' with `Module:' if `Module' is not the context module.
  198.  
  199. $prefix_module(Module, Module, Head, Head) :- !.
  200. $prefix_module(Module, _, Head, Module:Head).
  201.  
  202.  
  203.         /********************************
  204.         *      TRACE AND EXCEPTIONS     *
  205.         *********************************/
  206.  
  207. :- user:dynamic((prolog_trace_interception/3, exception/3)).
  208. :- user:multifile((prolog_trace_interception/3,    exception/3)).
  209.  
  210. :- user:$hide($prolog_trace_interception, 2),
  211.    user:$hide(prolog_trace_interception, 3).    
  212.  
  213. $map_trace_action(continue,     0).
  214. $map_trace_action(retry,     1).
  215. $map_trace_action(fail,     2).
  216.  
  217. %    This function is called from C by the tracer. Allows the user
  218. %    to intercept the tracer. If this predicate fails, the C tracer
  219. %    takes over.
  220.  
  221. $prolog_trace_interception(Port, Frame) :-
  222.     user:prolog_trace_interception(Port, Frame, Action),
  223.     $map_trace_action(Action, Int), !,
  224.     $trace_continuation(Int).
  225.  
  226. %    This function is called from C on undefined predicates.  First
  227. %    allows the user to take care of it using exception/3. Else try
  228. %    to give a DWIM warning. Otherwise fail. C will print an error
  229. %    message.
  230.  
  231. :- flag($verbose_autoload, _, off).
  232. :- flag($enable_autoload, _, on).
  233. :- flag($autoloading, _, 0).
  234.  
  235. $undefined_procedure(Module, Name, Arity) :-
  236.     $prefix_module(Module, user, Name/Arity, Pred),
  237.     user:exception(undefined_predicate, Pred, Action),
  238.     $map_trace_action(Action, Int), !,
  239.     $trace_continuation(Int).
  240. $undefined_procedure(Module, Name, Arity) :-
  241.     flag($enable_autoload, on, on),
  242.     $find_library(Module, Name, Arity, LoadModule, Library),
  243.     flag($autoloading, Old, Old+1),
  244.     (   Module == LoadModule
  245.     ->  ignore(ensure_loaded(Library))
  246.     ;   ignore(Module:use_module(Library, [Name/Arity]))
  247.     ),
  248.     flag($autoloading, _, Old),
  249.     functor(Head, Name, Arity),
  250.     current_predicate(_, Module:Head), !,
  251.     $map_trace_action(retry, Int),
  252.     $trace_continuation(Int).
  253. $undefined_procedure(Module, Name, Arity) :-
  254.     $prefix_module(Module, user, Name, MName),
  255.     findall(Dwim, dwim_predicate(MName, Dwim), Dwims),
  256.     Dwims \== [],
  257.     functor(Goal, Name, Arity),
  258.     $prefix_module(Module, user, Goal, Pred),
  259.     $warn_undefined(Pred, Dwims),
  260.     trace,
  261.     $map_trace_action(fail, Int),
  262.     $trace_continuation(Int).
  263.  
  264.  
  265.         /********************************
  266.         *        SYSTEM MESSAGES        *
  267.         *********************************/
  268.  
  269. %    $ttyformat(+Format, [+ArgList])
  270. %    Format on the user stream.  Used to print system messages.
  271.  
  272. $ttyformat(Format) :-
  273.     $ttyformat(Format, []).
  274.  
  275. $ttyformat(Format, Args) :-
  276.     format(user_output, Format, Args).
  277.  
  278. %    $confirm(Format, Args)
  279. %
  280. %    Ask the user to confirm a question.
  281.  
  282. $confirm(Format, Args) :-
  283.     $ttyformat(Format, Args),
  284.     $ttyformat('? '),
  285.     between(0, 5, _),
  286.         (   get_single_char(Answer),
  287.         memberchk(Answer, [0'y, 0'Y, 0'j, 0'J, 0'n, 0'N, 0' ,10])
  288.         ->  !, $confirm_(Answer)
  289.         ;   $ttyformat('Please answer ''y'' or ''n''~n'),
  290.         fail
  291.         ).
  292.  
  293. $confirm_(Answer) :-
  294.     memberchk(Answer, [0'y, 0'Y, 0'j, 0'J, 0' ,10]), !,
  295.     (   $tty
  296.     ->  $ttyformat('yes~n')
  297.     ;   true
  298.     ).
  299. $confirm_(_) :-
  300.     $tty,
  301.     $ttyformat('no~n'),
  302.     fail.
  303.  
  304. %    $warning(+Format, [+ArgList])
  305. %    Format a standard warning to the user and start the tracer.
  306.  
  307. $warning(Format) :-
  308.     $warning(Format, []).
  309. $warning(Format, Args) :-
  310.     source_location(File, Line), !,
  311.     sformat(Msg, Format, Args),
  312.     (   user:exception(warning, warning(File, Line, Msg), _)
  313.     ->  true
  314.     ;   format(user_error, '[WARNING: (~w:~d)~n~t~8|~w]~n',
  315.            [File, Line, Msg])
  316.     ).
  317. $warning(Format, Args) :-
  318.     format(user_error, '[WARNING: ', []), 
  319.     format(user_error, Format, Args), 
  320.     format(user_error, ']~n', []).
  321.  
  322.  
  323. %    $warn_undefined(+Goal, +Dwims)
  324. %    Tell the user that the predicate implied by `Goal' does not exists,
  325. %    If there are alternatives (DWIM) tell the user about them.
  326.  
  327. :- module_transparent
  328.     $warn_undefined/2,
  329.     $write_alternatives/1,
  330.     $predicate_name/2.
  331.  
  332. $warn_undefined(Goal, Dwims) :-
  333.     $predicate_name(Goal, Name),
  334.     $ttyformat('[WARNING: Undefined predicate: `~w''', [Name]),
  335.     (   Dwims == []
  336.     ;   $ttyformat('~nHowever there are definitions for:'), 
  337.         $write_alternatives(Dwims)
  338.     ), !,
  339.     $ttyformat(']~n').
  340.  
  341. $write_alternatives([]) :- !.
  342. $write_alternatives([Dwim|Rest]) :-
  343.     $predicate_name(Dwim, Name), 
  344.     $ttyformat('~n~t~8|~w', [Name]), 
  345.     $write_alternatives(Rest).
  346.  
  347. %    $predicate_name(+Head, -String)
  348. %    Convert `Head' into a predicate name.
  349.  
  350. $predicate_name(Goal, String) :-
  351.     $strip_module(Goal, Module, Head), 
  352.     functor(Head, Name, Arity), 
  353.     (   memberchk(Module, [user, system])
  354.     ->  sformat(String, '~w/~w',    [Name, Arity])
  355.     ;   sformat(String, '~w:~w/~w',    [Module, Name, Arity])
  356.     ).
  357.  
  358.  
  359.         /********************************
  360.         *         FILE CHECKING         *
  361.         *********************************/
  362.  
  363. %    File is a specification of a Prolog source file. Return the full
  364. %    path of the file. Warns the user if no such file exists.
  365.  
  366. $check_file(0, _) :- !, fail.            % deal with variables
  367. $check_file(user, user) :- !.
  368. $check_file(File, Absolute) :-
  369.     $chk_file(File, Absolute, [''], ['.pl', '']), !.
  370. $check_file(File, _) :-
  371.     $warning('~w: No such file', [File]),
  372.     fail.
  373.  
  374. $chk_file(library(File), FullName, Prefixes, Ext) :- !,
  375.     $chk_lib_file(File, FullName, Prefixes, Ext).
  376. $chk_file(Term, FullName, Prefixes, Ext) :-    % allow a/b, a-b, etc.
  377.     \+ atomic(Term), !,
  378.     term_to_atom(Term, Raw),
  379.     name(Raw, S0),
  380.     delete(S0, 0' , S1),
  381.     name(Atom, S1),
  382.     $chk_file(Atom, FullName, Prefixes, Ext).
  383. $chk_file(File, FullName, _, Exts) :-
  384.     atomic(File),
  385.     member(Ext, Exts),
  386.     (   concat(_, Ext, File)
  387.     ->  PlFile = File
  388.     ;   concat(File, Ext, PlFile)
  389.     ),
  390.     absolute_file_name(PlFile, FullName),
  391.     exists_file(FullName), !.
  392.  
  393. $chk_lib_file(File, FullFile, Prefixes, Exts) :-
  394.     user:library_directory(Dir),
  395.     member(Prefix, Prefixes),
  396.     member(Ext, Exts),
  397.     concat_atom([Dir, '/', Prefix, '/', File, Ext], LibFile),
  398.     absolute_file_name(LibFile, FullFile),
  399.     exists_file(FullFile), !.
  400.     
  401.  
  402.         /********************************
  403.         *            CONSULT            *
  404.         *********************************/
  405.  
  406. :- user:(dynamic
  407.          library_directory/1,
  408.         $start_compilation/2,
  409.         $end_compilation/2).
  410. :- user:(multifile
  411.          library_directory/1,
  412.         $start_compilation/2,
  413.         $end_compilation/2).
  414.  
  415.  
  416. :-    flag($break_level,    _, 0),
  417.     flag($compiling,    _, database),
  418.     flag($preprocessor,    _, none),
  419.     prompt(_, '|: ').
  420.  
  421. %    compiling
  422. %    Is true if SWI-Prolog is generating an intermediate code file
  423.  
  424. compiling :-
  425.     flag($compiling, wic, wic).
  426.  
  427.  
  428.         /********************************
  429.         *         PREPROCESSOR          *
  430.         *********************************/
  431.  
  432. preprocessor(Old, New) :-
  433.     flag($preprocessor, Old, New).
  434.  
  435. $open_source(File, Goal) :-
  436.     preprocessor(none, none), !,
  437.     $file_dir_name(File, Dir),
  438.     seeing(Old),
  439.     absolute_file_name('', OldDir), chdir(Dir),
  440.     see(File),
  441.     $open_source_call(File, Goal, True),
  442.     seen,
  443.     chdir(OldDir), !,
  444.     see(Old),
  445.     True == yes.
  446. $open_source(File, Goal) :-
  447.     preprocessor(Pre, Pre),
  448.     $file_dir_name(File, Dir),
  449.     $file_base_name(File, Base),
  450.     seeing(Old),
  451.     absolute_file_name('', OldDir), chdir(Dir),
  452.     $substitute_atom('%f', Base, Pre, Command),
  453.     see(pipe(Command)),
  454.     $open_source_call(File, Goal, True),
  455.     seen, chdir(OldDir),
  456.     see(Old), !,
  457.     True == yes.
  458. $open_source(_, _) :-
  459.     preprocessor(Pre, Pre),
  460.     $warning('Illegal preprocessor specification: `~w''', [Pre]),
  461.     fail.
  462.  
  463.  
  464. $open_source_call(File, Goal, Status) :-
  465.     flag($compilation_level, Level, Level+1),
  466.     ignore(user:$start_compilation(File, Level)),
  467.     (   Goal
  468.     ->  Status = yes
  469.     ;   Status = no
  470.     ),
  471.     ignore(user:$end_compilation(File, Level)),
  472.     flag($compilation_level, _, Level).
  473.  
  474.  
  475. $substitute_atom(Old, New, Org, Result) :-
  476.     name(Old, OS),
  477.     name(New, NS),
  478.     name(Org, OrgS),
  479.     append(Before, Rest, OrgS),
  480.     append(OS, After, Rest), !,
  481.     append(Before, NS, R1),
  482.     append(R1, After, R2), !,
  483.     name(Result, R2).
  484.  
  485.  
  486.         /********************************
  487.         *       LOAD PREDICATES         *
  488.         *********************************/
  489.  
  490. :- module_transparent
  491.     ensure_loaded/1,
  492.     '.'/2,
  493.     consult/1,
  494.     use_module/1,
  495.     use_module/2,
  496.     $use_module/3,
  497.     $ensure_loaded/2,
  498.     $consult_file/2.
  499.  
  500. %    ensure_loaded(+File|+ListOfFiles)
  501. %    
  502. %    Load specified files, provided they where not loaded before. If the
  503. %    file is a module file import the public predicates into the context
  504. %    module.
  505.  
  506. ensure_loaded([]) :- !.
  507. ensure_loaded([Spec|Rest]) :- !,
  508.     ensure_loaded(Spec),
  509.     ensure_loaded(Rest).
  510. ensure_loaded(Spec) :-
  511.     $strip_module(Spec, _, File),
  512.     $check_file(File, FullFile),
  513.     $ensure_loaded(Spec, FullFile).
  514.  
  515. $ensure_loaded(_Spec, FullFile) :-
  516.     source_file(FullFile), !.
  517. $ensure_loaded(Spec, _) :-
  518.     $consult_file(Spec, [verbose]).
  519.  
  520. %    use_module(+File|+ListOfFiles)
  521. %    
  522. %    Very similar to ensure_loaded/1, but insists on the loaded file to
  523. %    be a module file. If the file is already imported, but the public
  524. %    predicates are not yet imported into the context module, then do
  525. %    so.
  526.  
  527. use_module([]) :- !.
  528. use_module([Spec|Rest]) :- !,
  529.     use_module(Spec),
  530.     use_module(Rest).
  531. use_module(Spec) :-
  532.     use_module(Spec, all).
  533.  
  534. %    use_module(+File, +ImportList)
  535. %    
  536. %    As use_module/1, but takes only one file argument and imports only
  537. %    the specified predicates rather than all public predicates.
  538.  
  539. use_module(File, ImportList) :-
  540.     $use_module(File, ImportList, [verbose]).
  541.  
  542. $use_module(Spec, Import, _) :-
  543.     $strip_module(Spec, _, File),
  544.     $check_file(File, FullFile),
  545.     $module_file(FullFile, Module),
  546.     context_module(Context),
  547.     $import_list(Context, Module, Import).    
  548. $use_module(Spec, Import, Options) :-
  549.     $consult_file(Spec, [import = Import, is_module | Options]).
  550.  
  551. [F|R] :-
  552.     consult([F|R]).
  553. [].
  554.  
  555. consult([]) :- !.
  556. consult([File|Rest]) :- !,
  557.     consult(File),
  558.     consult(Rest).
  559. consult(Spec) :-
  560.     $consult_file(Spec, [verbose]).
  561.  
  562. %    $consult_file(+File, +Options)
  563. %    
  564. %    Common entry for all the consult derivates.  File is the raw user
  565. %    specified file specification, possibly tagged with the module.
  566. %    
  567. %    `Options' is a list of additional options.  Defined values are
  568. %
  569. %        verbose        Print statistics on user channel
  570. %        is_module        File MUST be a module file
  571. %        import = List    List of predicates to import
  572. %
  573. %    Actual compilation is executed in a break environment to prevent
  574. %    warning() from starting the tracer and to clean up the used local
  575. %    and global stack.
  576.  
  577. $consult_file(Spec, Options) :-
  578.     statistics(heapused, OldHeap),
  579.     statistics(cputime, OldTime),
  580.  
  581.     (memberchk(import = Import, Options) -> true ; Import = all),
  582.     (memberchk(is_module, Options) -> IsModule = true ; IsModule = false),
  583.  
  584.     $strip_module(Spec, Module, File),
  585.     $check_file(File, Absolute),
  586.     $consult_file(Absolute, Module, Import, IsModule, LM),
  587.  
  588.     (   memberchk(verbose, Options),
  589.         (flag($autoloading, 0, 0) ; flag($verbose_autoload, on, on))
  590.     ->  statistics(heapused, Heap),
  591.         statistics(cputime, Time),
  592.         HeapUsed is Heap - OldHeap,
  593.         TimeUsed is Time - OldTime,
  594.         $confirm_file(File, Absolute, ConfirmFile),
  595.         $confirm_module(LM, ConfirmModule),
  596.  
  597.         $ttyformat('~N~w compiled~w, ~2f sec, ~D bytes.~n',
  598.                [ConfirmFile, ConfirmModule, TimeUsed, HeapUsed])
  599.     ;   true
  600.     ).
  601.  
  602. $confirm_file(library(_), Absolute, Absolute) :- !.
  603. $confirm_file(File, _, File).
  604.  
  605. $confirm_module(user, '') :- !.
  606. $confirm_module(Module, Message) :-
  607.     concat(' into ', Module, Message).
  608.  
  609. $read_clause(Clause) :-                % get the first non-syntax
  610.     repeat,                    % error
  611.         read_clause(Clause), !.
  612.  
  613. $consult_file(Absolute, Module, Import, IsModule, LM) :-
  614.     $set_source_module(OldModule, Module),    % Inform C we start loading
  615.     $start_consult(Absolute),
  616.     (   compiling
  617.     ->  $add_directive_wic($assert_load_context_module(Absolute, OldModule))
  618.     ;   true
  619.     ),
  620.     $assert_load_context_module(Absolute, OldModule),
  621.  
  622.     $style_check(OldStyle, OldStyle),    % Save style parameters
  623.     $open_source(Absolute, (        % Load the file
  624.         $read_clause(First),
  625.         $load_file(First, Absolute, Import, IsModule, LM))),
  626.  
  627.     $style_check(_, OldStyle),        % Restore old style
  628.     (   compiling
  629.     ->  $add_directive_wic($style_check(_, OldStyle))
  630.     ;   true
  631.     ),
  632.     $set_source_module(_, OldModule).    % Restore old module
  633.  
  634. %    $load_context_module(+File, -Module)
  635. %    Record the module a file was loaded from (see make/0)
  636.  
  637. $load_context_module(File, Module) :-
  638.     recorded($load_context_module, File/Module, _).
  639.  
  640. $assert_load_context_module(File, Module) :-
  641.     recorded($load_context_module, File/Module, _), !.
  642. $assert_load_context_module(File, Module) :-
  643.     recordz($load_context_module, File/Module, _).
  644.  
  645. %   $load_file(+FirstTerm, +Path, +Import, +IsModule, -Module)
  646. %
  647. %   $load_file5 does the actual loading. The first term has already been
  648. %   read as this may be the module declaraction.
  649.  
  650. $load_file((?- module(Module, Public)), File, all, _, Module) :- !,
  651.     $load_module(Module, Public, Public, File).
  652. $load_file((:- module(Module, Public)), File, all, _, Module) :- !,
  653.     $load_module(Module, Public, Public, File).
  654. $load_file((?- module(Module, Public)), File, Import, _, Module) :- !,
  655.     $load_module(Module, Public, Import, File).
  656. $load_file((:- module(Module, Public)), File, Import, _, Module) :- !,
  657.     $load_module(Module, Public, Import, File).
  658. $load_file(_, File, _, true, _) :- !,
  659.     $warning('use_module: ~w is not a module file', [File]),
  660.     fail.
  661. $load_file(end_of_file, _, _, _, Module) :- !,        % empty file
  662.     $set_source_module(Module, Module).
  663. $load_file(FirstClause, File, _, false, Module) :- !,
  664.     $set_source_module(Module, Module),
  665.     ignore($consult_clause(FirstClause, File)),
  666.     repeat,
  667.         read_clause(Clause),
  668.         $consult_clause(Clause, File), !.
  669.  
  670. :- dynamic
  671.     $module_file/3.
  672.  
  673. $module_file(File, Module) :-
  674.     $module_file(File, _Base, Module), !.
  675. $module_file(File, Module) :-
  676.     $file_base_name(File, Base),
  677.     $module_file(LoadedFile, Base, Module),
  678.     same_file(File, LoadedFile), !,
  679.     $assert_module_file(LoadedFile, Module).
  680.  
  681. $assert_module_file(File, Module) :-
  682.     $file_base_name(File, Base),
  683.     (   $module_file(File, Base, Module)
  684.     ->  true
  685.     ;   asserta($module_file(File, Base, Module))
  686.     ).
  687.  
  688. $load_module(Module, Public, Import, File) :-
  689.     $set_source_module(OldModule, OldModule),
  690.     (   compiling
  691.     ->  $start_module_wic(Module, File),
  692.         $add_directive_wic($assert_module_file(File, Module))
  693.     ;   true
  694.     ),
  695.     $declare_module(Module, File),
  696.     $export_list(Module, Public),
  697.     $assert_module_file(File, Module),
  698.     repeat,
  699.         read_clause(Clause),
  700.         $consult_clause(Clause, File), !,
  701.     Module:$check_export,
  702.     (   compiling
  703.     ->  $start_module_wic(OldModule, 0)
  704.     ;   true
  705.     ),
  706.     $import_list(OldModule, Module, Import).
  707.  
  708.  
  709. $import_list(_, _, []) :- !.
  710. $import_list(Module, Source, [Name/Arity|Rest]) :- !,
  711.     functor(Term, Name, Arity),
  712.     (   compiling
  713.     ->  $import_wic(Source, Name, Arity)
  714.     ;   true
  715.     ),
  716.     ignore(Module:import(Source:Term)),
  717.     $import_list(Module, Source, Rest).
  718. $import_list(Context, Module, all) :- !,
  719.     export_list(Module, Exports),
  720.     $import_all(Exports, Context, Module).
  721.  
  722.  
  723. $import_all([], _, _).
  724. $import_all([Head|Rest], Context, Source) :-
  725.     ignore(Context:import(Source:Head)),
  726.     (   compiling
  727.     ->  functor(Head, Name, Arity),
  728.         $import_wic(Source, Name, Arity)
  729.     ;   true
  730.     ),
  731.     $import_all(Rest, Context, Source).
  732.  
  733.  
  734. $export_list(_, []) :- !.
  735. $export_list(Module, [Name/Arity|Rest]) :- !,
  736.     (   compiling
  737.     ->  $export_wic(Name, Arity)
  738.     ;   true
  739.     ),
  740.     functor(Term, Name, Arity),
  741.     export(Module:Term),
  742.     $export_list(Module, Rest).
  743. $export_list(Module, [Term|Rest]) :-
  744.     $warning('Illegal predicate specification in public list: `~w''', [Term]),
  745.     $export_list(Module, Rest).
  746.  
  747. $consult_clause(end_of_file, _) :- !.
  748. $consult_clause(Clause, File) :-
  749.     expand_term(Clause, Expanded),
  750.     $store_clause(Expanded, File), !,
  751.     fail.
  752.  
  753. $execute_directive(Goal) :-
  754.     flag($compiling, wic, wic), !,
  755.     $add_directive_wic2(Goal),
  756.     $execute_directive2(Goal).
  757. $execute_directive(Goal) :-
  758.     $execute_directive2(Goal).
  759.  
  760. $execute_directive2(Goal) :-
  761.     $set_source_module(Module, Module),
  762.     Module:Goal, !.
  763. $execute_directive2(Goal) :-
  764.     $set_source_module(Module, Module),
  765.     (   Module == user
  766.     ->  $warning('Directive failed: ~w', [Goal])
  767.     ;   $warning('Directive failed: ~w:~w', [Module, Goal])
  768.         ),
  769.     fail.
  770.  
  771. %    Note that the list, consult and ensure_loaded directives are already
  772. %    handled at compile time and therefore should not go into the
  773. %    intermediate code file.
  774.  
  775. $add_directive_wic2(Goal) :-
  776.     $common_goal_type(Goal, Type), !,
  777.     (   Type == load
  778.     ->  true
  779.     ;   $set_source_module(Module, Module),
  780.         $add_directive_wic(Module:Goal)
  781.     ).
  782. $add_directive_wic2(Goal) :-
  783.     $warning('Cannot compile mixed loading/calling directives: ~w', Goal).
  784.     
  785. $common_goal_type((A,B), Type) :- !,
  786.     $common_goal_type(A, Type),
  787.     $common_goal_type(B, Type).
  788. $common_goal_type((A;B), Type) :- !,
  789.     $common_goal_type(A, Type),
  790.     $common_goal_type(B, Type).
  791. $common_goal_type((A->B), Type) :- !,
  792.     $common_goal_type(A, Type),
  793.     $common_goal_type(B, Type).
  794. $common_goal_type(Goal, Type) :-
  795.     $goal_type(Goal, Type).
  796.  
  797. $goal_type(Goal, Type) :-
  798.     (   $load_goal(Goal)
  799.     ->  Type = load
  800.     ;   Type = call
  801.     ).
  802.  
  803. $load_goal([_|_]).
  804. $load_goal(consult(_)).
  805. $load_goal(ensure_loaded(_)).
  806. $load_goal(use_module(_)).
  807. $load_goal(use_module(_, _)).
  808.  
  809.         /********************************
  810.         *        TERM EXPANSION         *
  811.         *********************************/
  812.  
  813. :- user:dynamic(term_expansion/2).
  814. :- user:multifile(term_expansion/2).
  815.  
  816. expand_term(Term, Expanded) :-
  817.     user:term_expansion(Term, Expanded), !.
  818. expand_term(Term, Expanded) :-
  819.     $translate_rule(Term, Expanded), !.
  820. expand_term(Term, Term).
  821.  
  822. $store_clause([], _) :- !.
  823. $store_clause([C|T], F) :- !,
  824.     $store_clause(C, F),
  825.     $store_clause(T, F).
  826. $store_clause((:- Goal), _) :- !,
  827.     $execute_directive(Goal).
  828. $store_clause((?- Goal), _) :- !,
  829.     $execute_directive(Goal).
  830. $store_clause((_, _), F) :- !,
  831.     current_input(Stream),
  832.     line_count(Stream, Line),
  833.     $file_base_name(F, Base),
  834.     $warning('Full stop in clause body (line ~w of ~w)', [Line, Base]).
  835. $store_clause(Term, File) :-
  836.     flag($compiling, database, database), !,
  837.     $record_clause(Term, File).
  838. $store_clause(Term, File) :-
  839.     $add_clause_wic(Term, File).
  840.  
  841.  
  842.         /********************************
  843.         *        GRAMMAR RULES          *
  844.         *********************************/
  845.  
  846. /*  Original version by Fernando Pereira, Edinburgh, 1984
  847.  
  848.  ** Thu Sep  1 15:57:59 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  849.  
  850. $translate_rule((LP-->List), H) :-
  851.     nonvar(List),
  852.     (  List = []
  853.     -> $t_head(LP, S, S, H)
  854.     ;  List = [X]
  855.     -> $t_head(LP, [X|S], S, H)
  856.     ;  List = [_|_]
  857.     -> append(List, SR, S),
  858.        $extend([S, SR], LP, H)
  859.     ).
  860. $translate_rule((LP-->RP), (H:-B)):-
  861. %    style_check(+dollar),
  862. %    trace,
  863.     $t_head(LP, S, SR, H),
  864.     $t_body(RP, S, SR, B1),
  865.     $t_tidy(B1, B).
  866.  
  867.  
  868. $t_head((LP, List), S, SR, H):- !,
  869.     append(List, SR, List2),
  870.     $extend([S, List2], LP, H).
  871. $t_head(LP, S, SR, H) :-
  872.     $extend([S, SR], LP, H).
  873.  
  874.  
  875. $t_body(Var, S, SR, $apply(Var, [S, SR])) :-
  876.     var(Var), !.
  877. $t_body(!, S, S, !) :- !.
  878. $t_body([], S, S1, S=S1) :- !.
  879. $t_body([X], S, SR, $char(S, X, SR)) :- !.
  880. $t_body([X|R], S, SR, ($char(S, X, SR1), RB)) :- !,
  881.     $t_body(R, SR1, SR, RB).
  882. $t_body({T}, S, S, T) :- !.
  883. $t_body((T, R), S, SR, (Tt, Rt)) :- !,
  884.     $t_body(T, S, SR1, Tt),
  885.     $t_body(R, SR1, SR, Rt).
  886. $t_body((T;R), S, SR, (Tt;Rt)) :- !,
  887.     $t_body(T, S, S1, T1), $t_fill(S, SR, S1, T1, Tt),
  888.     $t_body(R, S, S2, R1), $t_fill(S, SR, S2, R1, Rt).
  889. $t_body((T|R), S, SR, (Tt;Rt)) :- !,
  890.     $t_body(T, S, S1, T1), $t_fill(S, SR, S1, T1, Tt),
  891.     $t_body(R, S, S2, R1), $t_fill(S, SR, S2, R1, Rt).
  892. $t_body((C->T;E), S, SR, (Ct->Tt;Et)) :- !,
  893.     $t_body(C, S, S1, Ct),
  894.     $t_body(T, S1, S2, T1), $t_fill(S, SR, S2, T1, Tt),
  895.     $t_body(E, S1, S3, E1), $t_fill(S, SR, S3, E1, Et).
  896. $t_body((C->T|E), S, SR, (Ct->Tt;Et)) :- !,
  897.     $t_body(C, S, S1, Ct),
  898.     $t_body(T, S1, S2, T1), $t_fill(S, SR, S2, T1, Tt),
  899.     $t_body(E, S1, S3, E1), $t_fill(S, SR, S3, E1, Et).
  900. $t_body((C->T), S, SR, (Ct->Tt)) :- !,
  901.     $t_body(C, S, SR1, Ct),
  902.     $t_body(T, SR1, SR, Tt).
  903. $t_body(T, S, SR, Tt) :-
  904.     $extend([S, SR], T, Tt).
  905.  
  906.  
  907. $t_fill(S, SR, S1, T, (T, SR=S)) :-
  908.     S1 == S, !.
  909. $t_fill(_S, SR, SR, T, T).
  910.  
  911.  
  912. $extend(More, OldT, NewT) :-
  913.     OldT =.. OldL,
  914.     append(OldL, More, NewL),
  915.     NewT =.. NewL.
  916.  
  917. $t_tidy(Var, Var) :-
  918.      var(Var), !.
  919. $t_tidy((P1;P2), (Q1;Q2)) :- !,
  920.     $t_tidy(P1, Q1),
  921.     $t_tidy(P2, Q2).
  922. $t_tidy(((P1, P2), P3), Q) :-
  923.     $t_tidy((P1, (P2, P3)), Q).
  924. $t_tidy((P1, P2), (Q1, Q2)) :- !,
  925.     $t_tidy(P1, Q1),
  926.     $t_tidy(P2, Q2).
  927. $t_tidy(A, A).
  928.  
  929. $char([X|S], X, S).
  930.  
  931.  
  932.         /********************************
  933.         *     WIC CODE COMPILER         *
  934.         *********************************/
  935.  
  936. /*  This  entry  point  is  called  from  pl-main.c  if  the  -c  option
  937.     (intermediate  code  compilation) is given.  It's job is simple: get
  938.     the output file  and  input  files,  open  the  output  file,  setup
  939.     intermediate  code  compilation  flag  and  finally just compile the
  940.     input files.
  941. */
  942.  
  943. $compile_wic :-
  944.     $argv(Argv),            % gets main() argv as a list of atoms
  945.     $get_files_argv(Argv, Files),
  946.     $get_wic_argv(Argv, Wic),
  947.     $compile_wic(Files, Wic).
  948.  
  949. $compile_wic(FileList, Wic) :-
  950.     $open_wic(Wic),
  951.     flag($compiling, Old, wic),
  952.         $style_check(Style, Style),
  953.         $execute_directive($style_check(_, Style)),
  954.         user:consult(FileList),
  955.     flag($compiling, _, Old),
  956.     $close_wic.
  957.  
  958. $get_files_argv([], []) :- !.
  959. $get_files_argv(['-c'|Files], Files) :- !.
  960. $get_files_argv([_|Rest], Files) :-
  961.     $get_files_argv(Rest, Files).
  962.  
  963. $get_wic_argv([], 'a.out').
  964. $get_wic_argv(['-o', Wic|_], Wic) :- !.
  965. $get_wic_argv([_|Rest], Wic) :-
  966.     $get_wic_argv(Rest, Wic).
  967.  
  968.  
  969.         /********************************
  970.         *       LIST PROCESSING         *
  971.         *********************************/
  972.  
  973. member(X, [X|_]).
  974. member(X, [_|T]) :-
  975.     member(X, T).
  976.  
  977. append([], L, L).
  978. append([H|T], L, [H|R]) :-
  979.     append(T, L, R).
  980.  
  981.  
  982.         /********************************
  983.         *            EXPORTS            *
  984.         *********************************/
  985.  
  986. /*
  987. :- boot((
  988.     Public = [
  989.         op/3, (dynamic)/1, (multifile)/1, (module_transparent)/1,
  990.         ';'/2, '|'/2, ','/2, call/1, (not)/1, (\+)/1, (->)/2,
  991.         once/1, ignore/1, apply/2,
  992.         true,
  993.         library_directory/1,
  994.         compiling/0,
  995.         ensure_loaded/1, '.'/2, consult/1, use_module/1, use_module/2,
  996.         $system_feedback/1,
  997.         $check_file/2,
  998.         member/2, append/3
  999.     ],
  1000.     $export_list($init, Public),
  1001.     $import_list(user, $init, Public)
  1002.   )).
  1003. */
  1004.  
  1005.         /********************************
  1006.         *      LOAD OTHER MODULES       *
  1007.         *********************************/
  1008.  
  1009. '$:-'
  1010.     format('Loading Prolog startup files~n', []),
  1011.     $style_check(_, 2'1111),
  1012.     $argv(Argv),
  1013.     $get_files_argv(Argv, Files),
  1014.     flag($compiling, Old, wic),
  1015.     consult(Files),
  1016.     $execute_directive($set_source_module(_, user)),
  1017.     $execute_directive($style_check(_, 2'1011)),
  1018.     flag($compiling, _, Old),
  1019.     format('Boot compilation completed~n', []).
  1020.  
  1021.