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