1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% Contributor(s): IC-Parc, Imperal College London 22% 23% END LICENSE BLOCK 24% 25% System: ECLiPSe Constraint Logic Programming System 26% Version: $Id: sicstus.pl,v 1.3 2012/02/06 13:24:43 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * IDENTIFICATION: sicstus.pl 35 * 36 * DESCRIPTION: SICStus Prolog compatibility package 37 * 38 * 39 * CONTENTS: 40 * 41 */ 42 43:- module(sicstus). 44 45:- comment(categories, ["Compatibility"]). 46:- comment(summary, 'SICStus Prolog Compatibility Package'). 47:- comment(author, 'Micha Meier, ECRC Munich'). 48:- comment(copyright, 'Cisco Systems, Inc'). 49:- comment(date, '$Date: 2012/02/06 13:24:43 $'). 50:- comment(desc, html(' 51 ECLiPSe includes a SICStus Prolog compatibility package to ease 52 the task of porting SICStus Prolog applications to ECLiPSe Prolog. 53 This package includes the C-Prolog compatibility package (lib(cprolog)) 54 and the Quintus-Prolog compatibility package (lib(quintus)). 55 <P> 56 Please note that this appendix does not detail the functionality 57 of SICStus Prolog, refer to the SICStus Prolog documentation for 58 this information. 59 <P> 60 The effect of the compatibility library is local to the module where 61 it is loaded. For maximum compatibility, a Sicstus program should 62 be wrapped in a separate module starting with a directive like 63 <PRE> 64 :- module(mymodule, [], sicstus). 65 </PRE> 66 In this case, Eclipse-specific language constructs will not be available. 67 <P> 68 If the compatibility package is loaded into a standard module, e.g. like 69 <PRE> 70 :- module(mymixedmdule). 71 :- use_module(library(sicstus)). 72 </PRE> 73 then Sicstus and Eclipse language features can be used together. 74 However, ambiguities must be resolved explicitly and confusion may 75 arise from the different meaning of quotes in Eclipse vs Sicstus-Prolog. 76 <P> 77 A sockets library is provided for compatibility with the sockets 78 manipulation predicates of SICStus. To use these predicates, the 79 sockets library has to be loaded: 80 <PRE> 81 :- use_module(library(sockets)). 82 </PRE> 83 For SICStus 3.0, the sockets predicates are also in a sockets library, 84 so no changes are needed to load the library. However, for older 85 versions of SICStus, the predicates are available as built-ins, and no 86 library has to be loaded. So if the code is written for older 87 versions of SICStus, then the above line has to be added. 88 <P> 89 The sockets library can be used independently of the sicstus library. 90 Note also that ECLiPSe also provides its own socket manipulation 91 predicates that provides similar functionalities to the sockets library. 92 <P> 93 Since the SICStus package contains the Quintus one, the syntax 94 differences are the same. 95 ')). 96:- comment(see_also, [library(cio),library(cprolog),library(quintus), 97 library(sockets),library(swi)]). 98 99:- comment(call_residue/2, [template:'call_residue(+Goal,-Residue)', 100 summary:'This is only approximate, the variables in the second argument are dummies' 101 ]). 102 103% suppress deprecation warnings for reexported builtins 104:- pragma(deprecated_warnings(not_reexports)). 105 106:- reexport quintus except 107 load/1. 108 109:- export 110 op(1150, fx, block). 111 112:- export 113 (block)/1, 114 call_residue/2, 115 dif/2, 116 freeze/2, 117 frozen/2, 118 (if)/3, 119 load/1, 120 on_exception/3, 121 raise_exception/1, 122 when/2. 123 124:- export 125 chtab(0'\,escape). % character escapes are on by default in SICStus 126 127:- local 128 op(1100, xfy, (do)), 129 op(650, xfx, (@)). 130 131:- system. % compiler directive to add the SYSTEM flag 132 133%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 134 135:- import 136 (*->)/2, 137 compiled_stream/1, 138 suspend_body/4, 139 erase_macro_/2, 140 import_body/2, 141 read_/3, 142 subcall/3, 143 untraced_call/2 144 from sepia_kernel. 145 146%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 147 148 149:- tool(freeze/2, freeze_body/3). 150:- inline(freeze/2, tr_freeze/2). 151 152tr_freeze(freeze(Var, Goal), 153 ( var(Var) -> suspend(Goal, 2, (Var->suspend:1)) ; Goal )). 154 155:- system_debug. 156freeze_body(X, Goal, Module) :- 157 var(X), !, 158 suspend_body(Goal, 2, (X->suspend:1), Module). 159freeze_body(_, Goal, Module) :- 160 untraced_call(Goal, Module). 161 162:- system. 163frozen(Var, Goals) :- 164 var(Var), 165 delayed_goals(Var, List), 166 list_to_comma(List, Goals). 167 168list_to_comma([], true) :- !. 169list_to_comma([G], G) :- !. 170list_to_comma([H|T], (H,Rest)) :- 171 list_to_comma(T, Rest). 172 173dif(A, B) :- 174 A ~= B. 175 176 177%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 178% Sicstus's block-directives are translated as follows: 179% :- block p(-,?). 180% p(a,b). 181% into 182% p(A,B) :- var(A), !, make_suspension(p(A,B),0,S), insert_suspension([A],S,1,suspend). 183% p(A,B) :- 'p unblocked'(A,B). 184% 'p unblocked'(a,b). 185% i.e. new clauses are generated to implement the delay conditions, and 186% the original predicate is renamed with the help of a clause macro. 187 188:- tool((block)/1, block_body/2). 189block_body(List, M) :- 190 block_to_clauses(List, Clauses, [(Head:-Call)], Name/Arity), 191 !, 192 functor(Head, Name, Arity), 193 rename_functor(Head, Call), 194 compile_term(Clauses)@M, 195 local(macro(Name/Arity,sicstus:rename_head/2,[clause]))@M. 196block_body(List, M) :- 197 printf(error, '*** Error in block-declaration %w%n', [block(List)])@M, 198 fail. 199 200:- export rename_head/2. 201rename_head((OldHead:-Body), Renamed) ?- !, 202 Renamed = (NewHead:-Body), 203 rename_functor(OldHead, NewHead). 204rename_head(OldHead, NewHead) :- 205 rename_functor(OldHead, NewHead). 206 207 rename_functor(Term, NewTerm) :- 208 functor(Term, OldName, Arity), 209 concat_atoms(OldName, ' unblocked', NewName), 210 functor(NewTerm, NewName, Arity), 211 ( for(I,1,Arity), param(Term,NewTerm) do 212 arg(I,Term,Arg), arg(I,NewTerm,Arg) 213 ). 214 215block_to_clauses((B1,B2), D1, C, Pred) :- 216 !, 217 block_to_clauses(B1, D1, C0, Pred), 218 block_to_clauses(B2, C0, C, Pred). 219block_to_clauses(B, [(Head:-Body)|C], C, Name/Arity) :- 220 functor(B, Name, Arity), 221 B =.. [Name|Args], 222 arg_and_body(Args, H, Body, BC, Vars, []), 223 Head =.. [Name|H], 224 BC = (!, make_suspension(Head,0,S), insert_suspension(Vars, S, 1, suspend)). 225 226:- mode arg_and_body(+, -, -, ?, -, ?). 227arg_and_body([], [], BC, BC, V, V). 228arg_and_body([?|A], [_|H], B, BC, V, VC) :- 229 !, 230 arg_and_body(A, H, B, BC, V, VC). 231arg_and_body([-|A], [X|H], (var(X),B), BC, [X|V], VC) :- 232 arg_and_body(A, H, B, BC, V, VC). 233 234 235%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 236:- tool(when/2, when_body/3). 237 238:- system_debug. 239when_body(Condition, Goal, Module) :- 240 condition_fails(Condition, Vars), 241 !, 242 suspend(when_body(Condition, Goal, Module), 2, (Vars->inst)). 243when_body(_Condition, Goal, Module) :- 244 untraced_call(Goal, Module). 245 246:- system. 247:- mode condition_fails(?,-). 248condition_fails(Condition, _) :- var(Condition), !, fail. 249condition_fails(nonvar(X), X) :- var(X), !. 250condition_fails(ground(X), V) :- nonground(X, V), !. 251condition_fails(X == Y, [X|Y]) :- X \== Y, !. 252condition_fails((C1;C2), [V1|V2]) :- 253 condition_fails(C1, V1), 254 condition_fails(C2, V2). 255condition_fails((C1,_C2), V) :- 256 condition_fails(C1, V), !. 257condition_fails((_C1,C2), V) :- 258 condition_fails(C2, V). 259 260 261% call_residue/2 is not quite ok - the variables in the 262% residue list are only dummies, unrelated to the goals 263 264:- system_debug. 265:- tool(call_residue/2, call_residue_body/3). 266call_residue_body(Goal, Residue, Module) :- 267 subcall(Goal, Delayed, Module), 268 add_dummy_variables(Delayed, Residue). 269 270:- tool((if)/3, if_body/4). 271if_body(A, B, C, M) :- 272 *->(untraced_call(A, M), untraced_call(B, M)) ; untraced_call(C, M). 273 274:- system. 275add_dummy_variables([], []). 276add_dummy_variables([G|Gs], [_-G|Rs]) :- 277 add_dummy_variables(Gs, Rs). 278 279%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 280:- tool(load/1, load_body/2). 281 282load_body([File|Files], M) :- 283 !, 284 load_body(File, M), 285 load_body(Files, M). 286load_body(Module:File, _) :- 287 !, 288 compile(File, Module). 289load_body(File, M) :- 290 compile(File, M). 291 292:- export fcompile/1. 293:- tool(fcompile/1, fcompile/2). 294fcompile(File, Module) :- 295 fcompile:fcompile(File)@Module. 296 297:- tool(on_exception/3, on_exception_body/4). 298 299:- system_debug. 300on_exception_body(Tag, Goal, Recovery, M) :- 301 catch(Goal, Tag, Recovery)@M. 302 303:- system. 304raise_exception(Tag) :- 305 throw(Tag). 306 307 308 309%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 310 311:- skipped 312 dif/2, 313 frozen/2. 314 315:- unskipped 316 freeze_body/3, 317 call_residue_body/3, 318 on_exception_body/4. 319 320:- untraceable 321 freeze_body/3, 322 call_residue_body/3, 323 add_dummy_variables/2. 324 325 326 327%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 328% 329% MODULE INITIALIZATION 330% 331%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 332 333