1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1991-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% Contributor(s): IC-Parc, Imperal College London 22% 23% END LICENSE BLOCK 24% 25% System: ECLiPSe Constraint Logic Programming System 26% Version: $Id: source_storage.pl,v 1.1 2008/06/30 17:43:49 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29% 30% IDENTIFICATION: source_storage.pl (part of modes.pl) 31% AUTHOR: Joachim Schimpf 32% PROJECT: IDLE 33% 34% 35% source program storage 36% The source is asserted into the module 'source' 37% 38 39:- module(source_storage). 40%-------------------------------------------------------- 41 42:- use_module(library(apply_macros)). 43 44:- export read_source/1. 45:- export get_clauses/2, undefined_predicate/1. 46 47:- import 48 assert_/2, 49 clause_body/3, 50 current_record_body/2, 51 file_query/2, 52 is_predicate_/2, 53 local_record_body/2, 54 local_body/2, 55 get_flag_body/4, 56 recordz_body/3, 57 recorded_list_body/3 58 from sepia_kernel. 59:- current_module(source) -> true ; create_module(source). 60 61source_clause(Head, Body) :- 62 clause_body(Head, Body, source). 63 64undefined_predicate(PredSpec) :- 65 ( get_flag_body(PredSpec, definition_module, source, source) -> 66 fail 67 ; get_flag_body(PredSpec, declared, on, source) -> 68 fail 69 ; 70 true 71 ). 72 73get_clauses(Call, Clauses) :- 74 functor(Call, F, N), 75 functor(Head, F, N), 76 (get_flag_body(F/N, tool, on, source) -> 77 Head =.. HeadL, 78 append(HeadL, [dummy_module], BodyL), 79 Body =.. BodyL, 80 Clauses = [Head :- Body] 81 ; get_flag_body(F/N, stability, dynamic, source) -> 82 findall((Head :- Body), source_clause(Head, Body), Clauses) 83 ; 84 printf(error, "*** Warning: No source for predicate %w (assuming worst case)\n%b", 85 [F/N]), 86 Clauses = [] 87 ). 88 89/* 90get_clauses(Call, Clauses) :- 91 functor(Call, F, N), 92 (get_flag_body(F/N, tool, on, source) -> 93 Head =.. HeadL, 94 append(HeadL, [dummy_module], BodyL), 95 Body =.. BodyL, 96 Clauses = [Head :- Body] 97 ; 98 recorded_list_body(Call, Clauses, source) 99 ). 100*/ 101 102read_source([H|T]) :- 103 !, 104 erase_module(source), 105 create_module(source), 106 local_body((plus/3, trace/1), source), 107 read_source0([H|T]). 108read_source(File) :- 109 read_source([File]). 110 111read_source0([]). 112read_source0([H|T]) :- 113 read_source1(H), 114 read_source0(T). 115 116read_source1(File) :- 117 printf("reading %w\n", [File]), 118 flush(output), 119 open_source_file(File, Stream), 120 read(Stream, Term), 121 process_input_term(Stream, Term). 122 123 124process_input_term(Stream, end_of_file) :- !, 125 close(Stream). 126process_input_term(Stream, (:- Query)) :- !, 127 ( additional_execute(Query) -> 128 call(Query)@source 129 ; 130 file_query(Query, read_source1(_)) 131 ), 132 read(Stream, Term), 133 process_input_term(Stream, Term). 134process_input_term(Stream, (?- Query)) :- !, 135 ( additional_execute(Query) -> 136 call(Query)@source 137 ; 138 file_query(Query, read_source1(_)) 139 ), 140 read(Stream, Term), 141 process_input_term(Stream, Term). 142process_input_term(Stream, (Head :- Body)) :- !, 143 preprocess_control([(Head :- Body)], Clause1), 144% Clause1 = (Head :- Body), 145 assert_pp_list(Clause1), 146 read(Stream, Term), 147 process_input_term(Stream, Term). 148process_input_term(Stream, Fact) :- 149 preprocess_control([(Fact :- true)], Clause1), 150% Clause1 = (Fact :- true), 151 assert_pp_list(Clause1), 152 read(Stream, Term), 153 process_input_term(Stream, Term). 154 155additional_execute(local(_)). 156additional_execute(dynamic(_)). 157 158%local_recordz_body(Key, Value, Module) :- 159% ( current_record_body(Key, source) -> 160% true 161% ; 162% functor(Key, F, N), 163% local_record_body(F/N, source) 164% ), 165% recordz_body(Key, Value, Module). 166 167assert_pp_list([]). 168assert_pp_list([Clause|Clauses]) :- 169 preprocess_aliasing(Clause, Clause1), 170 assert(Clause1)@source, 171 assert_pp_list(Clauses). 172 173open_source_file(File, Stream) :- 174 (string(File) -> % first convert to a string 175 FileS = File 176 ; atom(File) -> 177 atom_string(File, FileS) 178 ), 179 ( 180 get_flag(prolog_suffix, Suffixes), 181 member(Suffix, Suffixes), 182 concat_strings(FileS, Suffix, PlFile) 183 ), 184 exists(PlFile), 185 !, 186 open(PlFile, read, Stream). 187open_source_file(File, _Stream) :- 188 printf(error, "*** Cannot open source file %w\n%b", [File]), 189 fail. 190 191 192preprocess_aliasing((Head :- Body), (NewHead :- NewBody)) :- 193 preprocess_body(Body, NewBody), 194 mark_aliases(Head, NewHead). 195 196 197preprocess_body(Goal, Goal) :- 198 var(Goal), !, 199 printf(error, "*** possible problem: variable goal in %w\n%b", [Goal]). 200preprocess_body((Goals1 , Goals2), (NewGoals1 , NewGoals2)) :- !, 201 preprocess_body(Goals1, NewGoals1), 202 preprocess_body(Goals2, NewGoals2). 203preprocess_body(X=Y, X=Y) :- !. % handled in the interpreter 204preprocess_body(Goal, NewGoal) :- 205 mark_aliases(Goal, NewGoal). 206 207 208mark_aliases(Term, MarkedTerm) :- 209 critical_variables(Term, Vars), 210 ( Vars == [] -> 211 Term = MarkedTerm 212 ; 213 mapargs(mark_alias(Vars), Term, MarkedTerm) 214 ). 215 216 217mark_alias(Vars, Term, MarkedTerm) :- 218 var(Term), !, 219 ( occurs(Term, Vars) -> 220 MarkedTerm = '$alias'(Term) 221 ; 222 MarkedTerm = Term 223 ). 224mark_alias(Vars, Term, MarkedTerm) :- 225 ( compound(Term) -> 226 mapargs(mark_alias(Vars), Term, MarkedTerm) 227 ; 228 Term = MarkedTerm 229 ). 230 231 232% critical_variables(+Term, -Vars) 233% 234% finds the variables which occur multiply in Term 235 236critical_variables(Term, Vars) :- 237 var(Term), !, 238 printf(error, "*** possible problem: variable goal in %w\n%b", [Term]), 239 Vars = []. % wrong: metacalled variable 240critical_variables(Term, Vars) :- 241 copy_term(Term, Copy), 242 functor(Term, _, A), 243 critical_variables(A, Term, Copy, 0, _, [], Vars). 244 245critical_variables(0, _, _, N, N, Vars, Vars) :- !. 246critical_variables(A, Term, Copy, N0, N, Vars0, Vars) :- 247 A1 is A-1, 248 arg(A, Copy, Carg), 249 arg(A, Term, Targ), 250 check_arg(Carg, Targ, N0, N1, Vars0, Vars1), 251 critical_variables(A1, Term, Copy, N1, N, Vars1, Vars). 252 253 254check_arg('$ARG'(N0), _Targ, N0, N, Vars, Vars) :- !, N is N0+1. % new variable 255check_arg('$ARG'(_), Targ, N, N, Vars0, [Targ|Vars0]) :- !. % already seen 256check_arg(Carg, Targ, N0, N, Vars0, Vars) :- 257 functor(Carg, _, Ar), 258 critical_variables(Ar, Targ, Carg, N0, N, Vars0, Vars). 259 260 261%------------------------------------------------------------------- 262% Transform clauses into disjunction-free form. 263% Also eliminate: \+ not fail_if call once. 264% We don't care about cuts here, since the analyser 265% ignores them anyway. 266%------------------------------------------------------------------- 267 268:- setval(aux_counter, 0). 269 270preprocess_control(OldClauses, NewClauses) :- 271 eliminate_disj(OldClauses, [], NewClauses). 272 273eliminate_disj([], NewClauses, NewClauses). 274eliminate_disj([OldClause|OldClauses], NewClauses0, [NewClause|NewClauses1]) :- 275 eliminate_disj(OldClause, NewClause, [], AuxClauses), 276 eliminate_disj(AuxClauses, NewClauses2, NewClauses1), 277 eliminate_disj(OldClauses, NewClauses0, NewClauses2). 278 279eliminate_disj((Head :- Body), NewClause, AuxCl0, AuxCl) :- 280 comma_to_list(Body, BodyList, []), 281 ( split_body(BodyList, LBody, Disj, RBody) -> 282 collect_vars(Head, [], Vars0), 283 collect_vars(LBody, Vars0, Vars1), 284 collect_vars(RBody, Vars1, OuterVars), 285 collect_vars(Disj, [], DisjVars), 286 common_vars(OuterVars, DisjVars, [], AuxVars), 287 incval(aux_counter), getval(aux_counter, N), 288 concat_atom(['$disj_',N], AuxName), 289 AuxPred =.. [AuxName|AuxVars], 290 append(LBody, [AuxPred|RBody], NewBodyList), 291 list_to_comma(NewBodyList, NewBody), 292 disj_to_clauses(Disj, AuxPred, AuxCl1, AuxCl), 293 eliminate_disj((Head :- NewBody), NewClause, AuxCl0, AuxCl1) 294 ; 295 list_to_comma(BodyList, NewBody), 296 NewClause = (Head :- NewBody), 297 AuxCl0 = AuxCl 298 ). 299 300vars(X, Vars, [X|Vars]) :- var(X), !. 301vars(_, Vars, Vars). 302 303collect_vars(Term, Vars0, Vars) :- 304 sumnodes(vars, Term, Vars0, Vars). 305 306comma_to_list(Goal, [Goal|List], List) :- 307 var(Goal), !. 308comma_to_list((LGoals , RGoals), List0, List) :- !, 309 comma_to_list(LGoals, List0, List1), 310 comma_to_list(RGoals, List1, List). 311comma_to_list((LGoals -> RGoals), List0, List) :- !, 312 comma_to_list(LGoals, List0, List1), 313 comma_to_list(RGoals, List1, List). 314comma_to_list((\+ Goal), [(Goal,fail;true)|List], List) :- !. 315comma_to_list(not(Goal), [(Goal,fail;true)|List], List) :- !. 316comma_to_list(fail_if(Goal), [(Goal,fail;true)|List], List) :- !. 317comma_to_list(call(Goal), [Goal|List], List) :- !. 318comma_to_list(call(Goal,_), [Goal|List], List) :- !. 319comma_to_list(once(Goal), [Goal|List], List) :- !. 320comma_to_list(once(Goal,_), [Goal|List], List) :- !. 321comma_to_list(findall(T, G, L), [(G,fail;true),'$findall'(T, G, L)|List], List) :- !. 322comma_to_list(bagof(T, G, L), [(G,fail;true),'$bagof'(T, G, L)|List], List) :- !. 323comma_to_list(setof(T, G, L), [(G,fail;true),'$setof'(T, G, L)|List], List) :- !. 324comma_to_list(coverof(T, G, L), [(G,fail;true),'$coverof'(T, G, L)|List], List) :- !. 325comma_to_list(block(G,T,R), [(G;R),'$block'(G,T,R)|List], List) :- !. 326comma_to_list(block(G,T,R,_), [(G;R),'$block'(G,T,R)|List], List) :- !. 327 328comma_to_list(gc_block_once(G,T,R), [(G;R),'$block'(G,T,R)|List], List) :- !. 329comma_to_list(gc_block_once(G,T,R,_), [(G;R),'$block'(G,T,R)|List], List) :- !. 330comma_to_list(gc_once(Goal), [Goal|List], List) :- !. 331comma_to_list(gc_once(Goal,_), [Goal|List], List) :- !. 332comma_to_list(gc_prove(Goal), [Goal|List], List) :- !. 333comma_to_list(gc_prove(Goal,_), [Goal|List], List) :- !. 334 335comma_to_list(Goal, [Goal|List], List). 336 337list_to_comma([], true). 338list_to_comma([G], G) :- !. 339list_to_comma([G|T], (G,Gs)) :- 340 list_to_comma(T, Gs). 341 342% split_body(Subgoals, LeftSubgoals, Disj, RightSubgoals) 343% find the leftmost disjunction and split the body in three parts 344 345split_body([Goal|Goals], LGoals, Disj, RGoals) :- 346 nonvar(Goal), 347 Goal = (_;_) -> 348 LGoals = [], Disj = Goal, RGoals = Goals 349 ; 350 LGoals = [Goal|LGoals0], 351 split_body(Goals, LGoals0, Disj, RGoals). 352 353% common_vars(VarList1, VarList2, CommonIn, CommonOut) 354 355common_vars([], _, Common, Common). 356common_vars([V|Vs], Ws, Common0, Common) :- 357 occurs(V, Ws), 358 \+ occurs(V, Common0) 359 -> 360 common_vars(Vs, Ws, [V|Common0], Common) 361 ; 362 common_vars(Vs, Ws, Common0, Common). 363 364% disj_to_clauses(Disjunction, AuxHead, ClausesIn, ClausesOut) 365% make clauses from a disjunction, using the given head 366 367disj_to_clauses((LGoals ; RGoals), Head, Clauses0, Clauses) :- !, 368 disj_to_clauses(LGoals, Head, Clauses1, Clauses), 369 disj_to_clauses(RGoals, Head, Clauses0, Clauses1). 370disj_to_clauses(Goals, Head, Clauses, [(Head :- Goals)|Clauses]). 371 372