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)  2019-2025, VU University Amsterdam
    7                              CWI, Amsterdam
    8                              SWI-Prolog Solutions b.v.
    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(machine,
   38          [ gc_heap/0,
   39            trimcore/0,
   40
   41            abolish_table_info/0,
   42            close_open_tables/1,          % ?
   43
   44            get_attr/3,
   45            put_attr/3,
   46            del_attr/2,
   47            attv_unify/2,                       % AttVar, Value
   48            install_verify_attribute_handler/4, % +Mod, −AttrValue,
   49                                                % −Target, :Handler)
   50            install_attribute_portray_hook/3,   % +Mod, −AttrValue, :Handler
   51
   52            str_cat/3,
   53
   54            parsort/4,                    % +List, +Spec, +Dupl, -Sorted
   55
   56            term_type/2,
   57
   58            xsb_expand_file_name/2,       % +File, -Expanded
   59            expand_filename_no_prepend/2, % FileName, -ExpandedName
   60            parse_filename/4,             % +FileName, -Dir, -Base, -Extension
   61
   62            conset/2,                     % +Term, +Value
   63            conget/2,                     % +Term, -Value
   64
   65            slash/1,                      % -OSDirSlash
   66
   67            xsb_backtrace/1,              % -Backtrace
   68            xwam_state/2                  % +Id, -Value
   69            ]).   70:- use_module(library(debug)).   71:- use_module(library(error)).   72:- use_module(library(prolog_stack)).   73
   74:- meta_predicate
   75    install_verify_attribute_handler(+, -, -, 0).   76:- multifile
   77    system:term_expansion/2.   78
   79%!  gc_heap
   80%
   81%   Explicitly invoke heap garbage collection.
   82
   83gc_heap :-
   84    garbage_collect.
   85
   86%!  trimcore
   87%
   88%   Trim the stacks.
   89
   90trimcore :-
   91    trim_stacks.
   92
   93%!  abolish_table_info
   94%
   95%   Undocumented in the XSB manual.
   96
   97abolish_table_info.
   98
   99%!  close_open_tables(?Arg)
  100%
  101%   Undocumented in the XSB manual. Tables are always closed on
  102%   exceptions, so it is unclear what this should do?
  103
  104close_open_tables(_).
  105
  106                /*******************************
  107                *     ATTRIBUTED VARIABLES     *
  108                *******************************/
  109
  110%!  attv_unify(?AttVar, ?Value) is semidet.
  111%
  112%   Unify AttVar with Value without causing a   wakeup. If AttVar is not
  113%   an attributed variable, this is a normal unification.
  114
  115attv_unify(AttVar, Value) :-
  116    '$attv_unify'(AttVar, Value).
  117
  118%!  install_verify_attribute_handler(+Mod, −AttrValue, −Target,
  119%!                                   :Handler) is det.
  120%!  install_attribute_portray_hook(+Mod, −AttrValue, :Handler) is det.
  121%
  122%   Install attributed variable hooks for Mod.
  123
  124install_verify_attribute_handler(Mod, AttrValue, Target, Handler) :-
  125    retractall(Mod:attr_unify_hook(_,_)),
  126    asserta(Mod:(attr_unify_hook(AttrValue, Target) :- Handler)).
  127install_attribute_portray_hook(Mod, AttrValue, Handler) :-
  128    retractall(Mod:attr_portray_hook(_,_)),
  129    asserta(Mod:(attr_portray_hook(AttrValue, _Var) :- Handler)).
  130
  131system:term_expansion((:-install_verify_attribute_handler(Mod, AttrValue, Target, Handler)),
  132                      (Mod:attr_unify_hook(AttrValue, Target) :- Handler)).
  133system:term_expansion((:-install_attribute_portray_hook(Mod, AttrValue, Handler)),
  134                      (Mod:attr_portray_hook(AttrValue, _Var) :- Handler)).
  135
  136                /*******************************
  137                *             MISC             *
  138                *******************************/
  139
  140%!  str_cat(+Atom1, +Atom2, -Atom3)
  141
  142str_cat(A, B, AB) :-
  143    must_be(atom, A),
  144    must_be(atom, B),
  145    atom_concat(A, B, AB).
  146
  147%!  parsort(+List, +Order, +Dupl, -Sorted) is det.
  148%
  149%   parsort/4 is a very general sorting routine.
  150
  151parsort(_List, Spec, _Dupl, _Sorted) :-
  152    var(Spec),
  153    !,
  154    uninstantiation_error(Spec).
  155parsort(_List, _Spec, Dupl, _Sorted) :-
  156    var(Dupl),
  157    !,
  158    uninstantiation_error(Dupl).
  159parsort(List, asc,  0, Sorted) :- !, sort(0, @=<, List, Sorted).
  160parsort(List, asc,  _, Sorted) :- !, sort(0, @<,  List, Sorted).
  161parsort(List, [],   0, Sorted) :- !, sort(0, @=<, List, Sorted).
  162parsort(List, [],   _, Sorted) :- !, sort(0, @<,  List, Sorted).
  163parsort(List, desc, 0, Sorted) :- !, sort(0, @>=, List, Sorted).
  164parsort(List, desc, _, Sorted) :- !, sort(0, @>,  List, Sorted).
  165parsort(List, SortSpec, Dupl, Sorted) :-
  166    must_be(list, SortSpec),
  167    reverse(SortSpec, Rev),
  168    parsort_(Rev, Dupl, List, Sorted).
  169
  170parsort_([], _, List, List).
  171parsort_([H|T], Dupl, List0, List) :-
  172    parsort_1(H, Dupl, List0, List1),
  173    parsort_(T, Dupl, List1, List).
  174
  175parsort_1(asc(I),  0, List, Sorted) :- !, sort(I, @=<, List, Sorted).
  176parsort_1(asc(I),  _, List, Sorted) :- !, sort(I, @<,  List, Sorted).
  177parsort_1(desc(I), 0, List, Sorted) :- !, sort(I, @>=, List, Sorted).
  178parsort_1(desc(I), _, List, Sorted) :- !, sort(I, @>,  List, Sorted).
  179parsort_1(Spec,  _, _, _) :-
  180    domain_error(parsort_spec, Spec).
  181
  182%!  term_type(+Term, -Type:integer)
  183%
  184%   Emulation of internal XSB predicate
  185
  186term_type(Term, Type) :-
  187    (   atom(Term)
  188    ->  Type = 5
  189    ;   compound(Term)
  190    ->  (   Term = [_|_]
  191        ->  Type = 3
  192        ;   Type = 1
  193        )
  194    ;   integer(Term)
  195    ->  Type = 2
  196    ;   float(Term)
  197    ->  Type = 6
  198    ;   var(Term)
  199    ->  Type = 0
  200    ;   assertion(fail)
  201    ).
  202
  203		 /*******************************
  204		 *              FILES		*
  205		 *******************************/
  206
  207%!  xsb_expand_file_name(+File, -Expanded)
  208%
  209%
  210
  211xsb_expand_file_name(File, Expanded) :-
  212    absolute_file_name(File, Expanded, [expand(true)]).
  213
  214%!  expand_filename_no_prepend(+FileName, -ExpandedName)
  215%
  216%
  217
  218expand_filename_no_prepend(File, Expanded) :-
  219    expand_file_name(File, Absolute),
  220    working_directory(Dir0, Dir0),
  221    ensure_slash(Dir0, Dir),
  222    (   atom_concat(Dir, Ex0, Absolute)
  223    ->  Expanded = Ex0
  224    ;   Expanded = Absolute
  225    ).
  226
  227%!  parse_filename(+FileName, -Dir, -Base, -Extension)
  228%
  229%
  230
  231parse_filename(FileName, Dir, Base, Extension) :-
  232    sub_atom(FileName, 0, _, _, '~'),
  233    !,
  234    expand_file_name(FileName, Absolute),
  235    parse_filename_2(Absolute, Dir, Base, Extension).
  236parse_filename(FileName, Dir, Base, Extension) :-
  237    parse_filename_2(FileName, Dir, Base, Extension).
  238
  239parse_filename_2(FileName, Dir, Base, Extension) :-
  240    file_directory_name(FileName, Dir0),
  241    (   Dir0 == '.'
  242    ->  Dir = ''
  243    ;   ensure_slash(Dir0, Dir)
  244    ),
  245    file_base_name(FileName, File),
  246    file_name_extension(Base, Extension, File).
  247
  248ensure_slash(Dir, DirS) :-
  249    sub_atom(Dir, _, _, 0, '/'),
  250    !,
  251    DirS = Dir.
  252ensure_slash(Dir, DirS) :-
  253    atom_concat(Dir, '/', DirS).
  254
  255
  256%!  conset(+Term, +Value) is det.
  257%!  conget(+Term, -Value) is det.
  258%
  259%   Cheap set/get integer value associated with an atom. Seems this is a
  260%   subset of what SWI-Prolog flags can do.
  261
  262conset(Name, Value) :-
  263    set_flag(Name, Value).
  264
  265conget(Name, Value) :-
  266    get_flag(Name, Value).
  267
  268%!  slash(-Slash)
  269%
  270%   Return the directory separator for the platform
  271
  272slash(Slash) :-
  273    current_prolog_flag(dir_sep, Slash).
  274
  275%!  xsb_backtrace(-Backtrace)
  276%
  277%   Upon success Backtrace is  bound  to   a  structure  indicating  the
  278%   forward continuations for  a  point   of  execution.  This structure
  279%   should be treated as opaque.
  280
  281xsb_backtrace(Backtrace) :-
  282    get_prolog_backtrace(25, Backtrace).
  283
  284%!  xwam_state(+Id, -Value)
  285%
  286%   Low-level query.  Used by the XSB test suite.
  287
  288xwam_state(2, DelayReg) :-
  289    !,
  290    (   '$tbl_delay_list'([_|_])
  291    ->  DelayReg = 1
  292    ;   DelayReg = 0
  293    ).
  294xwam_state(Id, _Value) :-
  295    domain_error(xwam_state, Id)