chr_swi.pl

   1 /*  $Id$
   2
   3     Part of CHR (Constraint Handling Rules)
   4
   5     Author:        Tom Schrijvers and Jan Wielemaker
   6     E-mail:        Tom.Schrijvers@cs.kuleuven.be
   7     WWW:           http://www.swi-prolog.org
   8     Copyright (C): 2003-2004, K.U. Leuven
   9
  10     This program is free software; you can redistribute it and/or
  11     modify it under the terms of the GNU General Public License
  12     as published by the Free Software Foundation; either version 2
  13     of the License, or (at your option) any later version.
  14
  15     This program is distributed in the hope that it will be useful,
  16     but WITHOUT ANY WARRANTY; without even the implied warranty of
  17     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18     GNU General Public License for more details.
  19
  20     You should have received a copy of the GNU Lesser General Public
  21     License along with this library; if not, write to the Free Software
  22     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  23
  24     As a special exception, if you link this library with other files,
  25     compiled with a Free Software compiler, to produce an executable, this
  26     library does not by itself cause the resulting executable to be covered
  27     by the GNU General Public License. This exception does not however
  28     invalidate any other reasons why the executable file might be covered by
  29     the GNU General Public License.
  30 */
  31
  32 %% SWI begin
  33 :- module(chr,
  34           [ op(1180, xfx, ==>),
  35             op(1180, xfx, <=>),
  36             op(1150, fx, constraints),
  37             op(1150, fx, chr_constraint),
  38             op(1150, fx, chr_preprocessor),
  39             op(1150, fx, handler),
  40             op(1150, fx, rules),
  41             op(1100, xfx, \),
  42             op(1200, xfx, @),
  43             op(1190, xfx, pragma),
  44             op( 500, yfx, #),
  45             op(1150, fx, chr_type),
  46             op(1150, fx, chr_declaration),
  47             op(1130, xfx, --->),
  48             op(1150, fx, (?)),
  49             chr_show_store/1,           % +Module
  50             find_chr_constraint/1,      % +Pattern
  51             chr_trace/0,
  52             chr_notrace/0,
  53             chr_leash/1                 % +Ports
  54           ]).
  55
  56 :- set_prolog_flag(generate_debug_info, false).
  57
  58 :- multifile user:file_search_path/2.
  59 :- dynamic   user:file_search_path/2.
  60 :- dynamic   chr_translated_program/1.
  61
  62 user:file_search_path(chr, library(chr)).
  63
  64 :- load_files([ chr(chr_translate),
  65                 chr(chr_runtime),
  66                 chr(chr_messages),
  67                 chr(chr_hashtable_store),
  68                 chr(chr_compiler_errors)
  69               ],
  70               [ if(not_loaded),
  71                 silent(true)
  72               ]).
  73
  74 :- use_module(library(lists),[member/2]).
  75 %% SWI end
  76
  77 %% SICStus begin
  78 %% :- module(chr,[
  79 %%      chr_trace/0,
  80 %%      chr_notrace/0,
  81 %%      chr_leash/0,
  82 %%      chr_flag/3,
  83 %%      chr_show_store/1
  84 %%      ]).
  85 %%
  86 %% :- op(1180, xfx, ==>),
  87 %%      op(1180, xfx, <=>),
  88 %%      op(1150, fx, constraints),
  89 %%      op(1150, fx, handler),
  90 %%      op(1150, fx, rules),
  91 %%      op(1100, xfx, \),
  92 %%      op(1200, xfx, @),
  93 %%      op(1190, xfx, pragma),
  94 %%      op( 500, yfx, #),
  95 %%      op(1150, fx, chr_type),
  96 %%      op(1130, xfx, --->),
  97 %%      op(1150, fx, (?)).
  98 %%
  99 %% :- multifile user:file_search_path/2.
 100 %% :- dynamic   chr_translated_program/1.
 101 %%
 102 %% user:file_search_path(chr, library(chr)).
 103 %%
 104 %%
 105 %% :- use_module('chr/chr_translate').
 106 %% :- use_module('chr/chr_runtime').
 107 %% :- use_module('chr/chr_hashtable_store').
 108 %% :- use_module('chr/hprolog').
 109 %% SICStus end
 110
 111 :- multifile chr:'$chr_module'/1.
 112
 113 :- dynamic chr_term/3.                  % File, Term
 114
 115 :- dynamic chr_pp/2.            % File, Term
 116
 117 %       chr_expandable(+Term)
 118 %
 119 %       Succeeds if Term is a  rule  that   must  be  handled by the CHR
 120 %       compiler. Ideally CHR definitions should be between
 121 %
 122 %               :- constraints ...
 123 %               ...
 124 %               :- end_constraints.
 125 %
 126 %       As they are not we have to   use  some heuristics. We assume any
 127 %       file is a CHR after we've seen :- constraints ...
 128
 129 chr_expandable((:- constraints _)).
 130 chr_expandable((constraints _)).
 131 chr_expandable((:- chr_constraint _)).
 132 chr_expandable((:- chr_type _)).
 133 chr_expandable((chr_type _)).
 134 chr_expandable((:- chr_declaration _)).
 135 chr_expandable(option(_, _)).
 136 chr_expandable((:- chr_option(_, _))).
 137 chr_expandable((handler _)).
 138 chr_expandable((rules _)).
 139 chr_expandable((_ <=> _)).
 140 chr_expandable((_ @ _)).
 141 chr_expandable((_ ==> _)).
 142 chr_expandable((_ pragma _)).
 143
 144 %       chr_expand(+Term, -Expansion)
 145 %
 146 %       Extract CHR declarations and rules from the file and run the
 147 %       CHR compiler when reaching end-of-file.
 148
 149 %% SWI begin
 150 extra_declarations([(:- use_module(chr(chr_runtime)))
 151                    ,(:- style_check(-discontiguous)) % no need to restore; file ends
 152                    ,(:- set_prolog_flag(generate_debug_info, false))
 153                    | Tail], Tail).
 154 %% SWI end
 155
 156 %% SICStus begin
 157 %% extra_declarations([(:-use_module(chr(chr_runtime)))
 158 %%                   , (:- use_module(chr(hprolog),[term_variables/2,term_variables/3]))
 159 %%                   , (:-use_module(chr(hpattvars)))
 160 %%                   | Tail], Tail).
 161 %% SICStus end
 162
 163 chr_expand(Term, []) :-
 164         chr_expandable(Term), !,
 165         prolog_load_context(file,File),
 166         prolog_load_context(term_position,'$stream_position'(_, LineNumber, _, _, _)),
 167         add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm),
 168         assert(chr_term(File, LineNumber, NTerm)).
 169 chr_expand(Term, []) :-
 170         Term = (:- chr_preprocessor Preprocessor), !,
 171         prolog_load_context(file,File),
 172         assert(chr_pp(File, Preprocessor)).
 173 chr_expand(end_of_file, FinalProgram) :-
 174         extra_declarations(FinalProgram,Program),
 175         prolog_load_context(file,File),
 176         findall(T, retract(chr_term(File,_Line,T)), CHR0),
 177         CHR0 \== [],
 178         prolog_load_context(module, Module),
 179         add_debug_decl(CHR0, CHR1),
 180         add_optimise_decl(CHR1, CHR2),
 181         CHR3 = [ (:- module(Module, [])) | CHR2 ],
 182         findall(P, retract(chr_pp(File, P)), Preprocessors),
 183         ( Preprocessors = [] ->
 184                 CHR3 = CHR
 185         ; Preprocessors = [Preprocessor] ->
 186                 chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]),
 187                 call_chr_preprocessor(Preprocessor,CHR3,CHR)
 188         ;
 189                 chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])),
 190                 fail
 191         ),
 192         catch(call_chr_translate(File,
 193                            [ (:- module(Module, []))
 194                            | CHR
 195                            ],
 196                            Program0),
 197                 chr_error(Error),
 198                 (       chr_compiler_errors:print_chr_error(Error),
 199                         fail
 200                 )
 201         ),
 202         delete_header(Program0, Program).
 203
 204
 205 delete_header([(:- module(_,_))|T0], T) :- !,
 206         delete_header(T0, T).
 207 delete_header(L, L).
 208
 209 add_debug_decl(CHR, CHR) :-
 210         member(option(Name, _), CHR), Name == debug, !.
 211 add_debug_decl(CHR, CHR) :-
 212         member((:- chr_option(Name, _)), CHR), Name == debug, !.
 213 add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :-
 214         (   chr_current_prolog_flag(generate_debug_info, true)
 215         ->  Debug = on
 216         ;   Debug = off
 217         ).
 218
 219 %% SWI begin
 220 chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
 221 %% SWI end
 222
 223 add_optimise_decl(CHR, CHR) :-
 224         \+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !.
 225 add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
 226         chr_current_prolog_flag(optimize, full), !.
 227 add_optimise_decl(CHR, CHR).
 228
 229
 230 %       call_chr_translate(+File, +In, -Out)
 231 %
 232 %       The entire chr_translate/2 translation may fail, in which case we'd
 233 %       better issue a warning  rather  than   simply  ignoring  the CHR
 234 %       declarations.
 235
 236 call_chr_translate(File, In, _Out) :-
 237         ( chr_translate_line_info(In, File, Out0) ->
 238             nb_setval(chr_translated_program,Out0),
 239             fail
 240         ).
 241 call_chr_translate(_, _In, Out) :-
 242         nb_current(chr_translated_program,Out), !,
 243         nb_delete(chr_translated_program).
 244
 245 call_chr_translate(File, _, []) :-
 246         print_message(error, chr(compilation_failed(File))).
 247
 248 call_chr_preprocessor(Preprocessor,CHR,_NCHR) :-
 249         ( call(Preprocessor,CHR,CHR0) ->
 250                 nb_setval(chr_preprocessed_program,CHR0),
 251                 fail
 252         ).
 253 call_chr_preprocessor(_,_,NCHR) :-
 254         nb_current(chr_preprocessed_program,NCHR), !,
 255         nb_delete(chr_preprocessed_program).
 256 call_chr_preprocessor(Preprocessor,_,_) :-
 257         chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
 258
 259 %% SWI begin
 260
 261                  /*******************************
 262                  *      SYNCHRONISE TRACER      *
 263                  *******************************/
 264
 265 :- multifile
 266         user:message_hook/3,
 267         chr:debug_event/2,
 268         chr:debug_interact/3.
 269 :- dynamic
 270         user:message_hook/3.
 271
 272 user:message_hook(trace_mode(OnOff), _, _) :-
 273         (   OnOff == on
 274         ->  chr_trace
 275         ;   chr_notrace
 276         ),
 277         fail.                           % backtrack to other handlers
 278
 279 %       chr:debug_event(+State, +Event)
 280 %
 281 %       Hook into the CHR debugger.  At this moment we will discard CHR
 282 %       events if we are in a Prolog `skip' and we ignore the
 283
 284 chr:debug_event(_State, _Event) :-
 285         tracing,                        % are we tracing?
 286         prolog_skip_level(Skip, Skip),
 287         Skip \== very_deep,
 288         prolog_current_frame(Me),
 289         prolog_frame_attribute(Me, level, Level),
 290         Level > Skip, !.
 291
 292 %       chr:debug_interact(+Event, +Depth, -Command)
 293 %
 294 %       Hook into the CHR debugger to display Event and ask for the next
 295 %       command to execute. This  definition   causes  the normal Prolog
 296 %       debugger to be used for the standard ports.
 297
 298 chr:debug_interact(Event, _Depth, creep) :-
 299         prolog_event(Event),
 300         tracing, !.
 301
 302 prolog_event(call(_)).
 303 prolog_event(exit(_)).
 304 prolog_event(fail(_)).
 305
 306
 307
 308
 309                  /*******************************
 310                  *            MESSAGES          *
 311                  *******************************/
 312
 313 :- multifile
 314         prolog:message/3.
 315
 316 prolog:message(chr(CHR)) -->
 317         chr_message(CHR).
 318
 319                  /*******************************
 320                  *       TOPLEVEL PRINTING      *
 321                  *******************************/
 322
 323 :- set_prolog_flag(chr_toplevel_show_store,true).
 324
 325 prolog:message(query(YesNo)) --> !,
 326         ['~@'-[chr:print_all_stores]],
 327         '$messages':prolog_message(query(YesNo)).
 328
 329 prolog:message(query(YesNo,Bindings)) --> !,
 330         ['~@'-[chr:print_all_stores]],
 331         '$messages':prolog_message(query(YesNo,Bindings)).
 332
 333 print_all_stores :-
 334         ( chr_current_prolog_flag(chr_toplevel_show_store,true),
 335           catch(nb_getval(chr_global, _), _, fail),
 336           chr:'$chr_module'(Mod),
 337           chr_show_store(Mod),
 338           fail
 339         ;
 340           true
 341         ).
 342
 343                  /*******************************
 344                  *         MUST BE LAST!        *
 345                  *******************************/
 346
 347 :- multifile user:term_expansion/2.
 348 :- dynamic   user:term_expansion/2.
 349
 350 user:term_expansion(In, Out) :-
 351         chr_expand(In, Out).
 352 %% SWI end
 353
 354 %% SICStus begin
 355 %
 356 % :- dynamic
 357 %       current_toplevel_show_store/1,
 358 %       current_generate_debug_info/1,
 359 %       current_optimize/1.
 360 %
 361 % current_toplevel_show_store(on).
 362 %
 363 % current_generate_debug_info(false).
 364 %
 365 % current_optimize(off).
 366 %
 367 % chr_current_prolog_flag(generate_debug_info, X) :-
 368 %       chr_flag(generate_debug_info, X, X).
 369 % chr_current_prolog_flag(optimize, X) :-
 370 %       chr_flag(optimize, X, X).
 371 %
 372 % chr_flag(Flag, Old, New) :-
 373 %       Goal = chr_flag(Flag,Old,New),
 374 %       g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1),
 375 %       chr_flag(Flag, Old, New, Goal).
 376 %
 377 % chr_flag(toplevel_show_store, Old, New, Goal) :-
 378 %       clause(current_toplevel_show_store(Old), true, Ref),
 379 %       (   New==Old -> true
 380 %       ;   must_be(New, oneof([on,off]), Goal, 3),
 381 %           erase(Ref),
 382 %           assertz(current_toplevel_show_store(New))
 383 %       ).
 384 % chr_flag(generate_debug_info, Old, New, Goal) :-
 385 %       clause(current_generate_debug_info(Old), true, Ref),
 386 %       (   New==Old -> true
 387 %       ;   must_be(New, oneof([false,true]), Goal, 3),
 388 %           erase(Ref),
 389 %           assertz(current_generate_debug_info(New))
 390 %       ).
 391 % chr_flag(optimize, Old, New, Goal) :-
 392 %       clause(current_optimize(Old), true, Ref),
 393 %       (   New==Old -> true
 394 %       ;   must_be(New, oneof([full,off]), Goal, 3),
 395 %           erase(Ref),
 396 %           assertz(current_optimize(New))
 397 %       ).
 398 %
 399 %
 400 % all_stores_goal(Goal, CVAs) :-
 401 %       chr_flag(toplevel_show_store, on, on), !,
 402 %       findall(C-CVAs, find_chr_constraint(C), Pairs),
 403 %       andify(Pairs, Goal, CVAs).
 404 % all_stores_goal(true, _).
 405 %
 406 % andify([], true, _).
 407 % andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs).
 408 %
 409 % andify([], X, X, _).
 410 % andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs).
 411 %
 412 % :- multifile user:term_expansion/6.
 413 %
 414 % user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :-
 415 %       nonvar(In),
 416 %       nonmember(chr, Ids),
 417 %       chr_expand(In, Out), !.
 418 %
 419 %% SICStus end
 420
 421 %%% for SSS %%%
 422
 423 add_pragma_to_chr_rule(Name @ Rule, Pragma, Result) :- !,
 424         add_pragma_to_chr_rule(Rule,Pragma,NRule),
 425         Result = (Name @ NRule).
 426 add_pragma_to_chr_rule(Rule pragma Pragmas, Pragma, Result) :- !,
 427         Result = (Rule pragma (Pragma,Pragmas)).
 428 add_pragma_to_chr_rule(Head ==> Body, Pragma, Result) :- !,
 429         Result = (Head ==> Body pragma Pragma).
 430 add_pragma_to_chr_rule(Head <=> Body, Pragma, Result) :- !,
 431         Result = (Head <=> Body pragma Pragma).
 432 add_pragma_to_chr_rule(Term,_,Term).