spcompat.pl

来自「SRI international 发布的OAA框架软件」· PL 代码 · 共 1,075 行 · 第 1/3 页

% spcompat.pl

% Extra code needed by Sicstus, for functionality from Quintus library
% not available in Sicstus one. This file is created by David Carter
% ([e-mail]); code is written by David Carter and (earlier)
% by Ralph Becket.

% This has been tested under Sicstus 3.7.1.

% A few modifications made by Chris Culy for increased compatibility. This has been tested under Sicstus 3.8.4

%%CC sicstus complained about memberchk/2 not existing
:- use_module(library(lists)).

%%% ======================================================================
%%% Implementations of predicates with no simple equivalents in SICStus 3#7.
%%% ======================================================================

% can_open_file exists in Quintus library(file). We implement just the
% behaviour for Mode=read, because that's all that's used by OAA, and 
% because the Quintus documentation points out the following:
%  "Under operating systems which do not support version numbers (as
%   UNIX does not), file_exists/2 could fail (because there is no
%   such FileName) and can_open_file/2 could succeed (because you are
%   allowed to create one).  Conversely, file_exists/2 could succeed
%   (because there is such a FileName) and can_open_file/2 fail
%   (because you have so many files open that you cannot open
%   another)."
% We assume the "too many open files" condition won't arise.

can_open_file(_FileName, Mode, _) :-
  \+(Mode==read),
  !,
  format(user_error,
"~N* WARNING: can_open_file called with Mode=~w (not implemented under Sicstus\n"),
  fail.
% Succeed if can open FileName in this Mode.
can_open_file(FileName, read, _) :-
  file_exists(FileName, read),
  !.
% No, fail after printing a warning if Quiet = warn.
can_open_file(FileName, read, warn) :-
  format(user_error,
         "~N* could not open ~w in mode read~n",
	 [FileName]),
  fail.

% ------------------------------------------------------------------------

% Emulation of Quintus library(ctr).

ctr_is(Ctr, Old) :-
  ctr(Ctr, Old1),
  !,
  Old=Old1.
ctr_is(_,0).

ctr_set(Ctr, N) :-
  retractall(ctr(Ctr, _)),
  assert(ctr(Ctr, N)).

ctr_inc(Ctr, N, Old) :-
  ctr(Ctr, Old),
  retractall(ctr(Ctr, _)),
  M is Old + N,
  assert(ctr(Ctr, M)).

ctr_inc(Ctr) :-
  ctr_inc(Ctr, 1, _Old).

ctr_inc(Ctr, N) :-
  ctr_inc(Ctr, N, _Old).

% ------------------------------------------------------------------------

% Partial emulation of library(tcp) ...

:- dynamic tcp_connectionid_stream/2.
:- dynamic ctr/2.
:- dynamic tcp_watch_user/0.
:- dynamic tcp_listener/1.
:- dynamic tcp_scheduled_wakeups/1.

% Just a stub to warn of non-existence:
tcp_trace(off, OnOff) :-
  OnOff == on,
  !,
  format(user_error,
	 "~NWarning: tcp_trace/2 has no equivalent in SICStus Prolog 3.7~n",
	 []).
tcp_trace(_,_).

% ctr 14 is used to generate socket #'s like what we get from the QP
% tcp lib.
% :- ctr_set(14, 1).
% Not sure if the above works, so do this:
ctr(14, 1).

% Connect to a server that is waiting at port Port on host Host. We return a
% socket #, ConnectionID. 

tcp_connect(Address, ConnectionID) :-
  tcp_connect(Address, ConnectionID, _).

% This predicate returns a Stream which we can read and write.

tcp_connect(address(Port, Host), ConnectionID, Stream) :-
  socket('AF_INET', Socket),
  socket_connect(Socket, 'AF_INET'(Host, Port), Stream),
  socket_buffering(Stream, read, _Old, unbuf),
  % Socket is an int, but since we don't know that it always will be,
  % let's play it safe and generate our own.
  ctr_inc(14, 1, ConnectionID),
  set_tcp_connection_name(ConnectionID, Stream).

set_tcp_connection_name(ConnectionID, Stream) :-
  retractall(tcp_connectionid_stream(ConnectionID, _)),
  assert(tcp_connectionid_stream(ConnectionID, Stream)).

% Succeed on the current connection name, or return such a name.

tcp_connected(ConnectionID) :-
  tcp_connectionid_stream(ConnectionID, _).

% Send a Term down the stream corresponding to the named connection.
% NB: in Sicstus, this is done with simple portray_clause, i.e. we can't
% emulate the Quintus term-compression trickery. This is why an OAA Sicstus
% process will post its language as 'sicstus', not as 'prolog', because
% the latter will attract compressed terms.
%
% This probably isn't called by any Sicstus code, and probably shouldn't be,
% because it doesn't escape single quotes the right way.
% Use com:com_SendData.  (DLM, 6/2000)

tcp_send(ConnectionID, Term) :-
  debug_format("~N% tcp_send(~q, ~q)~n", [ConnectionID, term(Term)]),
  tcp_connectionid_stream(ConnectionID, Stream),
  portray_clause(Stream, term(Term)),
  flush_output(Stream).

% Comment out the first clause to get debug_format/2 to behave like
% format/2.
debug_format(_,_) :-
  !.
debug_format(Template,Args) :-
  format(Template,Args),
  current_output(CO),
  flush_output(CO).

% These are simple under Sicstus. Just look up the stream (bidirectional)
% for the named connection.

tcp_input_stream(ConnectionID, Stream) :-
  tcp_connectionid_stream(ConnectionID, Stream).

tcp_output_stream(ConnectionID, Stream) :-
  tcp_connectionid_stream(ConnectionID, Stream).

flush_all_streams :-
  tcp_connectionid_stream(_ConnectionID, Stream),
  flush_output(Stream),
  fail.
flush_all_streams.

% This is Ralph Becket's Sicstus emulation of the Quintus
% tcp_select/[1,2], using the Sicstus socket_select/5 predicate in
% library(sockets). I've cleaned it up a bit (shortening predicate
% bodies, etc) and have also added an emulation of the Quintus
% "wakeup" code, whereby timers can be set with
% tcp_schedule_wakeup(When,Value) which will later cause tcp_select to
% return with wakeup(Value). The abbreviation "SW" in variable names
% here stands for "ScheduledWakeup". DMC.

% Default timeout is 0, which (under Quintus) means no timeout.
tcp_select(X) :-
  tcp_select(0, X).

tcp_select(QPTimeout, X) :-
%    flush_all_streams,
    debug_format("~N% Call: tcp_select(~q, ~q)...~n", [QPTimeout,X]),
  % Convert to Sicstus timeout representation.
  sicstus_timeout_structure(QPTimeout,SPTimeout),
  % If there's a wakeup due before our timeout, use the wakeup time instead.
  adjust_timeout_from_wakeup(SPTimeout,SWTimeval,SWTerm,
                             SPTimeoutToUse),
  % Find all the sockets we are listening on (as server)
  findall(Listener, tcp_listener(Listener), Listeners),
  % Find all the streams we are connected to (as client)
  find_all_connected_streams(Streams),
    debug_format("call: socket_select(~q, _, ~q, ~q, _)~n",
                 [Listeners, SPTimeout, Streams]),
  % See the Sicstus documentation for what socket_select does.
  socket_select(Listeners, NewStreams, SPTimeoutToUse, Streams, ReadStreams),
    debug_format("exit: socket_select(~q, ~q, ~q, ~q, ~q)~n",
                 [Listeners, NewStreams, SPTimeout, Streams, ReadStreams]),
  % Pick through what socket_select has given us and return X1 as an
  % initial return value.
  tcp_select_return_value(NewStreams,ReadStreams,SPTimeout,X1),
  % If X1 was a timeout, see if it's because we've been using an adjusted
  % timeout (for a wakeup). If so, return the wakeup term. Otherwise,
  % return X1.
  adjust_return_value_from_wakeup(X1,SWTimeval,SWTerm,X),
    debug_format("~N% Exit: tcp_select(~q, ~q)...~n", [QPTimeout, X]).

% If we got a timeout from socket_select, and SWTimeval did get set by
% adjust_timeout_from_wakeup (i.e. the timeout was really a wakeup, then
% return the wakeup value. Otherwise, pass back the value from 
% tcp_select_return_value unchanged.

adjust_return_value_from_wakeup(In,SWTimeval,SWTerm,wakeup(SWTerm)) :-
  In == timeout,
  nonvar(SWTimeval),
  !,
  tcp_cancel_wakeup(SWTimeval,SWTerm).
adjust_return_value_from_wakeup(Value,_,_,Value).

% Here's where the clever wakeup stuff is done. We look at the next scheduled
% wakeup, if any, and see if it's before the Timeout provided as arg1. If so,
% we return TimeoutToUse as a more imminent timeout value, and set timeval
% and term to return as args 2 and 3 as well. If we don't find a wakeup, or
% if we do but it's after the timeout, we just return the timeout as we got it.

adjust_timeout_from_wakeup(Timeout,SWTimeval,SWTerm,
                           TimeoutToUse) :-
  (tcp_scheduled_wakeup(SWTimeval,SWTerm) -> true;
   fail),
  tcp_now(Now),
  (Timeout=off; % any wakeup is more imminent that 'off'
   Timeout=Secs:Micros,
     TimeoutSecs is Secs+Micros/1000000,
     tcp_time_plus(Now,TimeoutSecs,TimeoutTimeval),
     TimeoutTimeval @> SWTimeval),
  !, % scheduled wakeup will happen earlier than Timeout we were given
  tcp_time_plus(Now,TimeoutToUse1,SWTimeval),
  sicstus_timeout_structure(TimeoutToUse1,TimeoutToUse).
adjust_timeout_from_wakeup(Timeout,_,_,Timeout).

% A Quintus timeout structure is just a number (of seconds to wait). Sicstus
% uses 'off' for no timeout, and a structure of the form Seconds:Microseconds
% for other amounts of time.

sicstus_timeout_structure(0,Timeout) :-
  !,
  Timeout=off.
sicstus_timeout_structure(Secs,Secs:0) :-
  integer(Secs),
  !.
sicstus_timeout_structure(Secs1,Secs:Micros) :-
  number(Secs1),
  !,
  Micros1 is Secs1*1000000,
  Secs is Micros1 // 1000000,
  Micros is integer(Micros1 - (Secs*1000000)).
% Assume already converted:
sicstus_timeout_structure(Timeout,Timeout).

find_all_connected_streams(Streams) :-
  findall(Stream, tcp_connectionid_stream(_, Stream), Streams0),
  (tcp_watch_user ->
     Streams = [user_input | Streams0];
   Streams = Streams0).

% We got a new stream. Register it and return the KS ID.
tcp_select_return_value(NewStreams,_ReadStreams,_Timeout,X) :-
  member(NewStream, NewStreams),
  tcp_register_new_stream(NewStream, KSID),
  !,
  X = connected(KSID).
% No read-streams: must be a timeout.
tcp_select_return_value(_,[],_,X) :-
  !,
  X = timeout.
% We have either a proper term to read, or some user input.
tcp_select_return_value(_,ReadStreams,_,X) :-
  member(ReadStream, ReadStreams),
  (  tcp_connectionid_stream(ConnectionID, ReadStream),
     debug_format("call: tcp_select(_); reading ~q stream ~q~n",
                  [ConnectionID, ReadStream]),
    % Character escapes (e.g., \n) are *not* employed in ICL expressions.
    % (icldataq, among other things, depends on this.)
     prolog_flag(character_escapes,CE,off),
     read(ReadStream, Input),
     prolog_flag(character_escapes,_,CE),
     ( Input == end_of_file -> 
	 tcp_shutdown(ConnectionID),
         debug_format("exit: tcp_select(~q)~n", [end_of_file(ConnectionID)]),
         X = end_of_file(ConnectionID)
     | Input = term(Event) ->
         debug_format("exit: tcp_select(~q)~n", [term(ConnectionID, Event)]),
         X = term(ConnectionID, Event)
       % Not sure if this case occurs (DLM):
     | otherwise ->
         debug_format("exit: tcp_select(~q)~n", [term(ConnectionID, Input)]),
         X = term(ConnectionID, Input)
     )
   ;
   % ReadStream = user_input,
   X = user_input).
% Otherwise, try again.
% Ralph says: "I *think* this is the correct semantics for
% tcp_select/2, but the Quintus manual isn't very explicit (i.e. can
% tcp_select/2 ever fail?  If not, what are the timeout semantics?)"
tcp_select_return_value(_,_,Timeout,X) :-
  tcp_select(Timeout, X).

tcp_register_new_stream(Stream, KSID) :-
  next_number(KSID),
  \+ tcp_connectionid_stream(KSID, _),
  !,
  socket_buffering(Stream, read, _Old, unbuf),
  assert(tcp_connectionid_stream(KSID, Stream)).

next_number(1).
next_number(N) :-
  next_number(M),
  N is M + 1.

% Start up as a server on the given port (and host, which should be our
% hostname). This both returns and asserts a Socket number; at the time of
% writing, the OAA code ignores the returned one and relies on the asserted
% one.

tcp_listen_at_port(Port,Host,Socket) :-
  socket('AF_INET', Socket),
  socket_bind(Socket, 'AF_INET'(Host, Port)),
  socket_listen(Socket, 5),	% Max no. of pending connection req's.
  assert(tcp_listener(Socket)).

% This should only ever be called on one Socket, so allow for the argument
% being variable:

tcp_destroy_listener(Socket) :-
  (var(Socket) -> tcp_listener(Socket); true),
  socket_close(Socket).

tcp_watch_user(Old, New) :-
  (tcp_watch_user -> Old = on; Old = off),
  retractall(tcp_watch_user),
  (New = on -> assert(tcp_watch_user); true).

% Shut down the specified connection(s).
tcp_shutdown(ConnectionID) :-
  retract(tcp_connectionid_stream(ConnectionID, Stream)),
  !,
  close(Stream).
% At least shout if no associated stream...
tcp_shutdown(ConnectionID) :-
  ground(ConnectionID),
  !,
  format('~NWARNING: tcp_shutdown/1: ~w has no associated stream.~n',[ConnectionID]).
tcp_shutdown(_).

% I hope this is sufficiently drastic...DMC
tcp_reset :-
  tcp_shutdown(_),
  retractall(tcp_listener(_)),
  tcp_cancel_wakeups.

% Simulate some of the timing predicates...these work with "timevals", which