MODIFIED: Turn SICStus splfr script into a SWI-Prolog _app_

Allows for ``swipl splfr [option..] input ...``

Patch also fixes typing in ``sicstus.h``, check the return of
PL_put_term() and adds SP_cons_functor().

app/splfr.pl

@@ -0,0 +1,177 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        [email protected]
+    WWW:           http://www.swi-prolog.org
+    Copyright (c)  2010-2024, VU University Amsterdam
+                              SWI-Prolog Solutions b.v.
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in
+       the documentation and/or other materials provided with the
+       distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+*/
+
+:- initialization(main, main).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+This  file  emulates  SICStus   the    splfr   program,  which  extracts
+declarations for foreign  resources  from  a   Prolog  file,  creates  a
+wrapper, compiles this and finally  generates   a  shared object that is
+automatically loaded into SWI-Prolog.
+
+Note that this implementation  is  only   partial.  It  was  written for
+running Alpino (www.let.rug.nl/vannoord/alp/Alpino/) and  only processes
+the commandline options needed for this.
+
+To use this facility, copy this file to   a  directory in your $PATH and
+edit the first line to reflect the location of SWI-Prolog.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+:- use_module(library(prolog_source)).
+:- use_module(library(qpforeign)).
+:- use_module(library(apply)).
+:- use_module(library(debug)).
+:- use_module(library(option)).
+:- use_module(library(dialect)).
+:- use_module(library(main)).
+
+:- debug(swipl_frl).
+
+main(Argv) :-
+    append(Opts, [Stop|Rest], Argv),
+    (   Stop == '--'
+    ->  Inputs = Rest
+    ;   \+ sub_atom(Stop, 0, _, _, '--')
+    ->  Inputs = [Stop|Rest]
+    ),
+    !,
+    argv_options(Opts, _, Options),
+    (   catch(swipl_frl(Inputs, Options), Error,
+              (     print_message(error, Error),
+                    halt(1)
+              ))
+    ->  halt
+    ;   print_message(error, goal_failed(swipl_frl(Argv))),
+        halt(1)
+    ).
+
+opt_type(cflag, cflag, atom).
+
+opt_help(help(header),
+	 "Emulator for SICStus splfr").
+opt_help(help(usage),
+	 " [option ...] inputs ...").
+opt_help(help(footer),
+	 "Very incomplete!").
+opt_help(cflag,
+	 "Flags to pass to the C compiler").
+
+swipl_frl(Positional, Options) :-
+    partition(plfile, Positional, PlFiles, Rest),
+    PlFiles = [PlFile],
+    !,
+    file_name_extension(Base, _Ext, PlFile),
+    create_glue(PlFile, GlueFile),
+    option(cflag(CFlags), Options, ''),
+    atomic_list_concat([GlueFile,CFlags|Rest], ' ', Cmd0),
+    format(atom(Cmd), 'swipl-ld -shared -o ~w ~w', [Base, Cmd0]),
+    debug(swipl_frl, '~w', [Cmd]),
+    shell(Cmd).
+swipl_frl(_Positional, _Options) :-
+    argv_usage(debug).
+
+plfile(Name) :-
+    \+ sub_atom(Name, 0, _, _, -),
+    file_name_extension(_, pl, Name).
+
+%!  create_glue(+PrologFile, -GlueFile) is det
+%
+%   Create the glue foreign resources  in   PrologFile.  The glue is
+%   written to GlueFile.
+
+create_glue(File, Glue) :-
+    file_name_extension(Base, _Ext, File),
+    atom_concat(Base, '_swi_glue', GlueBase),
+    file_name_extension(GlueBase, c, Glue),
+    load_resource_decls(File, Module),
+    create_module_glue(Module, Base, GlueBase).
+
+create_module_glue(Module, Base, GlueBase) :-
+    Module:foreign_resource(Resource, _),
+    make_foreign_resource_wrapper(Module:Resource, Base, GlueBase).
+
+
+%!  load_resource_decls(+Source, -Module)
+%
+%   Load SICSTus/Quintus resource declarations   from Source. Module
+%   is the module in which the resources are loaded.
+
+load_resource_decls(Source, Module) :-
+    expects_dialect(sicstus),
+    prolog_canonical_source(Source, Id),
+    setup_call_cleanup(prolog_open_source(Id, In),
+                       process(In, no_module, Module),
+                       prolog_close_source(In)).
+
+
+process(In, State0, Module) :-
+    prolog_read_source_term(In, _, Expanded, []),
+    process_terms(Expanded, State0, State1),
+    (   State1 = end_of_file(EndState)
+    ->  state_module(EndState, Module)
+    ;   process(In, State1, Module)
+    ).
+
+process_terms([], State, State) :- !.
+process_terms([H|T], State0, State) :-
+    !,
+    process_term(H, State0, State1),
+    (   State1 == end_of_file
+    ->  State = State1
+    ;   process_terms(T, State1, State)
+    ).
+process_terms(T, State0, State) :-
+    process_term(T, State0, State).
+
+process_term(end_of_file, State, end_of_file(State)) :- !.
+process_term((:- module(Name, _)), _, module(Name)) :-
+    !,
+    clean_resources(Name).
+process_term(Term, State, State) :-
+    foreign_term(Term, Assert),
+    !,
+    state_module(State, M),
+    assertz(M:Assert).
+process_term(_, State, State).
+
+foreign_term(foreign_resource(Name, Funcs), foreign_resource(Name, Funcs)).
+foreign_term(foreign(Func, Pred), foreign(Func, c, Pred)).
+foreign_term(foreign(Func, Lang, Pred), foreign(Func, Lang, Pred)).
+
+state_module(module(M), M).
+state_module(no_module, user).
+
+clean_resources(Module) :-
+    forall(foreign_term(_, T), Module:retractall(T)).

src/CMakeLists.txt

@@ -211,7 +211,7 @@ set(SWIPL_DATA_library_dialect_swi syspred_options.pl)
 set(SWIPL_DATA_library_dialect_eclipse test_util_iso.pl)
 set(SWIPL_DATA_library_dialect_hprolog format.pl)
 set(SWIPL_DATA_library_dialect_sicstus arrays.pl block.pl lists.pl ordsets.pl
-    README.TXT sockets.pl swipl-lfr.pl system.pl terms.pl timeout.pl)
+    README.TXT sockets.pl system.pl terms.pl timeout.pl)
 set(SWIPL_DATA_library_dialect_sicstus4 aggregate.pl between.pl clpfd.pl
     file_systems.pl lists.pl ordsets.pl samsort.pl sets.pl sockets.pl
     system.pl terms.pl timeout.pl types.pl)
@@ -229,7 +229,7 @@ endif()
 set(SWIPL_DATA_demo likes.pl README.md)
 set(SWIPL_DATA_cmake swipl.cmake)
 
-set(SWIPL_DATA_app pack.pl app.pl qlf.pl README.md)
+set(SWIPL_DATA_app pack.pl app.pl qlf.pl splfr.pl README.md)
 
 ################
 # Custom targets and commands

src/compat/sicstus.h

@@ -3,7 +3,8 @@
     Author:        Jan Wielemaker
     E-mail:        [email protected]
     WWW:           http://www.swi-prolog.org
-    Copyright (c)  2010-2011, VU University Amsterdam
+    Copyright (c)  2010-2024, VU University Amsterdam
+			      SWI-Prolog Solutions b.v.
     All rights reserved.
 
     Redistribution and use in source and binary forms, with or without
@@ -281,7 +282,9 @@ SP_cons_functor_array(SP_term_ref term, SP_atom name, int arity,
   { int i;
 
     for(i=0; i<arity; i++)
-      PL_put_term(argv+i, arg[i]);
+    { if ( !PL_put_term(argv+i, arg[i]) )
+	return false;
+    }
 
     return PL_cons_functor_v(term, f, argv);
   }
@@ -290,6 +293,33 @@ SP_cons_functor_array(SP_term_ref term, SP_atom name, int arity,
 }
 
 
+static __inline int
+SP_cons_functor(SP_term_ref term, SP_atom name, int arity, ...)
+{ functor_t f = PL_new_functor(name, arity);
+  term_t argv;
+
+  if ( (argv=PL_new_term_refs(arity)) )
+  { int i;
+    va_list args;
+    int rc = true;
+
+    va_start(args, arity);
+    for(i=0; i<arity; i++)
+    { SP_term_ref a = va_arg(args, SP_term_ref);
+      if ( !PL_put_term(argv+i, a) )
+      { rc = false;
+	break;
+      }
+    }
+    va_end(args);
+
+    return rc && PL_cons_functor_v(term, f, argv);
+  }
+
+  return false;
+}
+
+
 
 		 /*******************************
 		 * RETURN CODES AND EXCEPTIONS	*
@@ -316,7 +346,7 @@ SP_cons_functor_array(SP_term_ref term, SP_atom name, int arity,
 static __inline int
 SP_query(SP_pred_ref predicate, ...)
 { atom_t name;
-  int i, arity;
+  size_t i, arity;
   module_t module;
   fid_t fid;
   qid_t qid;
@@ -361,7 +391,7 @@ SP_query(SP_pred_ref predicate, ...)
 static __inline int
 SP_query_cut_fail(SP_pred_ref predicate, ...)
 { atom_t name;
-  int i, arity;
+  size_t i, arity;
   module_t module;
   fid_t fid;
   qid_t qid;