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