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