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/2.                  % 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         assert(chr_term(File, Term)).
 165 chr_expand(Term, []) :-
 166         Term = (:- chr_preprocessor Preprocessor), !,
 167         prolog_load_context(file,File),
 168         assert(chr_pp(File, Preprocessor)).
 169 chr_expand(end_of_file, FinalProgram) :-
 170         extra_declarations(FinalProgram,Program),
 171         prolog_load_context(file,File),
 172         findall(T, retract(chr_term(File, T)), CHR0),
 173         CHR0 \== [],
 174         prolog_load_context(module, Module),
 175         add_debug_decl(CHR0, CHR1),
 176         add_optimise_decl(CHR1, CHR2),
 177         CHR3 = [ (:- module(Module, [])) | CHR2 ],
 178         findall(P, retract(chr_pp(File, P)), Preprocessors),
 179         ( Preprocessors = [] ->
 180                 CHR3 = CHR
 181         ; Preprocessors = [Preprocessor] ->
 182                 chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]),
 183                 call_chr_preprocessor(Preprocessor,CHR3,CHR)
 184         ;
 185                 chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])),
 186                 fail
 187         ),
 188         catch(call_chr_translate(File,
 189                            [ (:- module(Module, []))
 190                            | CHR
 191                            ],
 192                            Program0),
 193                 chr_error(Error),
 194                 (       chr_compiler_errors:print_chr_error(Error),
 195                         fail
 196                 )
 197         ),
 198         delete_header(Program0, Program).
 199
 200
 201 delete_header([(:- module(_,_))|T0], T) :- !,
 202         delete_header(T0, T).
 203 delete_header(L, L).
 204
 205 add_debug_decl(CHR, CHR) :-
 206         member(option(Name, _), CHR), Name == debug, !.
 207 add_debug_decl(CHR, CHR) :-
 208         member((:- chr_option(Name, _)), CHR), Name == debug, !.
 209 add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :-
 210         (   chr_current_prolog_flag(generate_debug_info, true)
 211         ->  Debug = on
 212         ;   Debug = off
 213         ).
 214
 215 %% SWI begin
 216 chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
 217 %% SWI end
 218
 219 add_optimise_decl(CHR, CHR) :-
 220         \+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !.
 221 add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
 222         chr_current_prolog_flag(optimize, full), !.
 223 add_optimise_decl(CHR, CHR).
 224
 225
 226 %       call_chr_translate(+File, +In, -Out)
 227 %
 228 %       The entire chr_translate/2 translation may fail, in which case we'd
 229 %       better issue a warning  rather  than   simply  ignoring  the CHR
 230 %       declarations.
 231
 232 call_chr_translate(_, In, _Out) :-
 233         ( chr_translate(In, Out0) ->
 234             nb_setval(chr_translated_program,Out0),
 235             fail
 236         ).
 237 call_chr_translate(_, _In, Out) :-
 238         nb_current(chr_translated_program,Out), !,
 239         nb_delete(chr_translated_program).
 240
 241 call_chr_translate(File, _, []) :-
 242         print_message(error, chr(compilation_failed(File))).
 243
 244 call_chr_preprocessor(Preprocessor,CHR,_NCHR) :-
 245         ( call(Preprocessor,CHR,CHR0) ->
 246                 nb_setval(chr_preprocessed_program,CHR0),
 247                 fail
 248         ).
 249 call_chr_preprocessor(_,_,NCHR) :-
 250         nb_current(chr_preprocessed_program,NCHR), !,
 251         nb_delete(chr_preprocessed_program).
 252 call_chr_preprocessor(Preprocessor,_,_) :-
 253         chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
 254
 255 %% SWI begin
 256
 257                  /*******************************
 258                  *      SYNCHRONISE TRACER      *
 259                  *******************************/
 260
 261 :- multifile
 262         user:message_hook/3,
 263         chr:debug_event/2,
 264         chr:debug_interact/3.
 265 :- dynamic
 266         user:message_hook/3.
 267
 268 user:message_hook(trace_mode(OnOff), _, _) :-
 269         (   OnOff == on
 270         ->  chr_trace
 271         ;   chr_notrace
 272         ),
 273         fail.                           % backtrack to other handlers
 274
 275 %       chr:debug_event(+State, +Event)
 276 %
 277 %       Hook into the CHR debugger.  At this moment we will discard CHR
 278 %       events if we are in a Prolog `skip' and we ignore the
 279
 280 chr:debug_event(_State, _Event) :-
 281         tracing,                        % are we tracing?
 282         prolog_skip_level(Skip, Skip),
 283         Skip \== very_deep,
 284         prolog_current_frame(Me),
 285         prolog_frame_attribute(Me, level, Level),
 286         Level > Skip, !.
 287
 288 %       chr:debug_interact(+Event, +Depth, -Command)
 289 %
 290 %       Hook into the CHR debugger to display Event and ask for the next
 291 %       command to execute. This  definition   causes  the normal Prolog
 292 %       debugger to be used for the standard ports.
 293
 294 chr:debug_interact(Event, _Depth, creep) :-
 295         prolog_event(Event),
 296         tracing, !.
 297
 298 prolog_event(call(_)).
 299 prolog_event(exit(_)).
 300 prolog_event(fail(_)).
 301
 302
 303
 304
 305                  /*******************************
 306                  *            MESSAGES          *
 307                  *******************************/
 308
 309 :- multifile
 310         prolog:message/3.
 311
 312 prolog:message(chr(CHR)) -->
 313         chr_message(CHR).
 314
 315                  /*******************************
 316                  *       TOPLEVEL PRINTING      *
 317                  *******************************/
 318
 319 :- set_prolog_flag(chr_toplevel_show_store,true).
 320
 321 prolog:message(query(YesNo)) --> !,
 322         ['~@'-[chr:print_all_stores]],
 323         '$messages':prolog_message(query(YesNo)).
 324
 325 prolog:message(query(YesNo,Bindings)) --> !,
 326         ['~@'-[chr:print_all_stores]],
 327         '$messages':prolog_message(query(YesNo,Bindings)).
 328
 329 print_all_stores :-
 330         ( chr_current_prolog_flag(chr_toplevel_show_store,true),
 331           catch(nb_getval(chr_global, _), _, fail),
 332           chr:'$chr_module'(Mod),
 333           chr_show_store(Mod),
 334           fail
 335         ;
 336           true
 337         ).
 338
 339                  /*******************************
 340                  *         MUST BE LAST!        *
 341                  *******************************/
 342
 343 :- multifile user:term_expansion/2.
 344 :- dynamic   user:term_expansion/2.
 345
 346 user:term_expansion(In, Out) :-
 347         chr_expand(In, Out).
 348 %% SWI end
 349
 350 %% SICStus begin
 351 %
 352 % :- dynamic
 353 %       current_toplevel_show_store/1,
 354 %       current_generate_debug_info/1,
 355 %       current_optimize/1.
 356 %
 357 % current_toplevel_show_store(on).
 358 %
 359 % current_generate_debug_info(false).
 360 %
 361 % current_optimize(off).
 362 %
 363 % chr_current_prolog_flag(generate_debug_info, X) :-
 364 %       chr_flag(generate_debug_info, X, X).
 365 % chr_current_prolog_flag(optimize, X) :-
 366 %       chr_flag(optimize, X, X).
 367 %
 368 % chr_flag(Flag, Old, New) :-
 369 %       Goal = chr_flag(Flag,Old,New),
 370 %       g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1),
 371 %       chr_flag(Flag, Old, New, Goal).
 372 %
 373 % chr_flag(toplevel_show_store, Old, New, Goal) :-
 374 %       clause(current_toplevel_show_store(Old), true, Ref),
 375 %       (   New==Old -> true
 376 %       ;   must_be(New, oneof([on,off]), Goal, 3),
 377 %           erase(Ref),
 378 %           assertz(current_toplevel_show_store(New))
 379 %       ).
 380 % chr_flag(generate_debug_info, Old, New, Goal) :-
 381 %       clause(current_generate_debug_info(Old), true, Ref),
 382 %       (   New==Old -> true
 383 %       ;   must_be(New, oneof([false,true]), Goal, 3),
 384 %           erase(Ref),
 385 %           assertz(current_generate_debug_info(New))
 386 %       ).
 387 % chr_flag(optimize, Old, New, Goal) :-
 388 %       clause(current_optimize(Old), true, Ref),
 389 %       (   New==Old -> true
 390 %       ;   must_be(New, oneof([full,off]), Goal, 3),
 391 %           erase(Ref),
 392 %           assertz(current_optimize(New))
 393 %       ).
 394 %
 395 %
 396 % all_stores_goal(Goal, CVAs) :-
 397 %       chr_flag(toplevel_show_store, on, on), !,
 398 %       findall(C-CVAs, find_chr_constraint(C), Pairs),
 399 %       andify(Pairs, Goal, CVAs).
 400 % all_stores_goal(true, _).
 401 %
 402 % andify([], true, _).
 403 % andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs).
 404 %
 405 % andify([], X, X, _).
 406 % andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs).
 407 %
 408 % :- multifile user:term_expansion/6.
 409 %
 410 % user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :-
 411 %       nonvar(In),
 412 %       nonmember(chr, Ids),
 413 %       chr_expand(In, Out), !.
 414 %
 415 %% SICStus end