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) 1989-2007 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: dynamic.pl,v 1.10 2013/02/18 00:42:59 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * IDENTIFICATION: dynamic.pl, part of module(sepia_kernel) 35 * 36 * DESCRIPTION: This file contains all the Prolog predicates 37 * that handle dynamic predicates. 38 * 39 * CONTENTS: 40 * 41 * REVISION HISTORY: 42 * 43 * AUTHOR VERSION DATE REASON 44 * periklis 26.9.89 Major revision for the logical update semantics. 45 * micha 20.3.89 Moved all the dynamic-related predicates 46 * from db.pl into this file. 47 * joachim 2007 Radically simplified record-based version 48 */ 49 50:- system. % compiler directive to add the SYSTEM flag 51 52:- export 53 (abolish)/1, 54 assert/1, 55 asserta/1, 56 assertz/1, 57 (dynamic)/1, 58 is_dynamic/1, 59 clause/1,clause/2, 60 (listing)/0,(listing)/1, 61 retract/1, 62 retract_all/1, 63 retractall/1, 64 writeclause/1, 65 writeclause/2. 66 67 68/* 69 * TOOL DIRECTIVES 70 * (body names are chosen for backward compatibility) 71 */ 72 73:- tool((abolish)/1, abolish_body/2). 74:- tool(assert/1, assert_/2). 75:- tool(asserta/1, asserta_/2). 76:- tool(assertz/1, assert_/2). 77:- tool(clause/1, clause_body/2). 78:- tool(clause/2, clause_body/3). 79:- tool((dynamic)/1, dynamic_body/2). 80:- tool(is_dynamic/1, is_dynamic_body/2). 81:- tool(listing/1, listing_body/2). 82:- tool(listing/0, listing_body/1). 83:- tool(retract/1, retract_body/2). 84:- tool(retract_all/1, retract_all_body/2). 85:- tool(retractall/1, retract_all_body/2). 86:- tool(write_goal/3, write_goal/4). % exported, for opium 87 88:- meta_predicate(( 89 assert(:-), 90 asserta(:-), 91 assertz(:-), 92 clause(:-), 93 retract(:-) 94 )). 95 96 97% 98% Dynamic clauses are recorded in source form in the indexed database, 99% under an anonymous SrcHandle. 100% 101% Additionally every dynamic predicate has the following stub code, 102% which contains that SrcHandle. E.g. for p/3: 103% 104% p(A, B, C) :- 105% call_dynamic_(<SrcHandle for p/3>, p(A,B,C), <home module>). 106% 107% call_dynamic_/3 is common code, essentially an interpreter for the 108% clauses stored under SrcHandle. Note that cuts in the clause body 109% must cut the recorded-choicepoint that backtracks over the clauses! 110 111call_dynamic_(SrcHandle, Goal, Module) :- 112 get_cut(Cut), 113 recorded(SrcHandle, (Goal:-Body)), 114 call_with_cut(Body, Module, Module, Cut). 115 116 117 118% Dynamic declaration - we allow several variants: 119% dynamic n/a 120% dynamic n/a, n/a, n/a % Sepia 121% dynamic [n/a, n/a, n/a] % Quintus, ISO, ... 122 123dynamic_body((F1, F2), Module) ?- 124 dynamic_body_enum((F1,F2), Module), 125 !. 126dynamic_body([F|Fs], Module) ?- 127 dynamic_body_list([F|Fs], Module), 128 !. 129dynamic_body(F, Module) :- 130 dynamic_body_single(F, Module), 131 !. 132dynamic_body(Preds, Module) :- 133 get_bip_error(E), 134 error(E, dynamic(Preds), Module). 135 136 dynamic_body_enum((F1,F2), Module) ?- !, 137 dynamic_body_enum(F1, Module), 138 dynamic_body_enum(F2, Module). 139 dynamic_body_enum(F, Module) :- 140 dynamic_body_single(F, Module). 141 142 dynamic_body_list(Fs, _Module) :- var(Fs), !, 143 set_bip_error(4). 144 dynamic_body_list([], _Module) :- !. 145 dynamic_body_list([F|Fs], Module) :- !, 146 dynamic_body_single(F, Module), 147 dynamic_body_list(Fs, Module). 148 dynamic_body_list(_, _) :- 149 set_bip_error(5). 150 151 dynamic_body_single(Name/Arity, Module) ?- 152 atom(Name), integer(Arity), Arity >= 0, !, 153 dynamic_create_(Name, Arity, Module). 154 dynamic_body_single(Pred, _) :- 155 nonground(Pred) -> set_bip_error(4) ; set_bip_error(5). 156 157 158is_dynamic_body(Functor, Module) :- 159 ( check_predspec(Functor, Module) -> 160 Functor = Name/Arity, 161 is_dynamic_(Name, Arity, Module) 162 ; 163 bip_error(is_dynamic(Functor), Module) 164 ). 165 166 167% abolish/1 gets rid of the definition of the predicate specified 168% by the argument. Name must be fully instantiated. 169% Arity must be fully instantiated (we differ from BSI). 170 171abolish_body(Name/Arity, Module ) :- !, 172 ( abolish_(Name,Arity,Module) -> 173 true 174 ; 175 get_bip_error(Error), 176 error(Error, abolish(Name/Arity), Module) 177 ). 178abolish_body( (F1, F2), Module ) :- !, 179 abolish_body( F1, Module ), 180 abolish_body( F2, Module ). 181abolish_body(Functor, Module ) :- 182 error(5, abolish(Functor), Module). 183 184 185% Auxiliary to check and decompose clause arguments 186 187clause_info(Clause, _N, _A, _NormClause) :- var(Clause), !, 188 set_bip_error(4). 189clause_info(Clause, N, A, NormClause) :- Clause = (Head:-_), !, 190 NormClause = Clause, 191 check_callable(Head), 192 functor(Head, N, A). 193clause_info(Head, N, A, NormClause) :- 194 NormClause = (Head:-true), 195 check_callable(Head), 196 functor(Head, N, A). 197 198 199% Handler for event 70 200 201undef_dynamic_handler(N, assert(Clause), Module) :- !, 202 undef_dynamic_handler(N, assertz(Clause), Module). 203undef_dynamic_handler(_N, asserta(Clause), Module) :- 204 clause_info(Clause, Name, Arity, _NormClause), 205 dynamic_create_(Name, Arity, Module), 206 !, 207 asserta(Clause)@Module. 208undef_dynamic_handler(_N, assertz(Clause), Module) :- 209 clause_info(Clause, Name, Arity, _NormClause), 210 dynamic_create_(Name, Arity, Module), 211 !, 212 assertz(Clause)@Module. 213undef_dynamic_handler(N, Goal, _) :- 214 ( get_bip_error(E) -> 215 error_handler(E, Goal) 216 ; 217 error_handler(N, Goal) 218 ). 219 220 221asserta_(Clause, Module) :- 222 ( clause_info(Clause, N, A, NormClause), 223 dynamic_source_(N, A, SrcHandle, Module) -> 224 recorda(SrcHandle, NormClause) 225 ; 226 bip_error(asserta(Clause), Module) 227 ). 228 229 230assert_(Clause, Module) :- 231 ( clause_info(Clause, N, A, NormClause), 232 dynamic_source_(N, A, SrcHandle, Module) -> 233 recordz(SrcHandle, NormClause) 234 ; 235 bip_error(assertz(Clause), Module) 236 ). 237 238 239clause_body(Clause, Module) :- 240 ( clause_info(Clause, N, A, NormClause), 241 dynamic_source_(N, A, SrcHandle, Module) -> 242 recorded(SrcHandle, NormClause) 243 ; 244 bip_error(clause(Clause), Module) 245 ). 246 247 248clause_body(Head, Body, Module) :- 249 ( check_callable(Head), 250 functor(Head, N, A), 251 dynamic_source_(N, A, SrcHandle, Module) -> 252 recorded(SrcHandle, (Head:-Body)) 253 ; 254 bip_error(clause(Head, Body), Module) 255 ). 256 257 258retract_body(Clause, Module) :- 259 ( clause_info(Clause, N, A, NormClause), 260 dynamic_source_(N, A, SrcHandle, Module) -> 261 recorded(SrcHandle, NormClause, DbRef), 262 ( erase(DbRef) -> true ; true ) 263 ; 264 bip_error(retract(Clause), Module) 265 ). 266 267 268retract_all_body(Head, Module) :- 269 ( check_callable(Head), 270 functor(Head, N, A), 271 dynamic_source_(N, A, SrcHandle, Module) -> 272 erase_all(SrcHandle, Head :- _)@Module 273 ; 274 bip_error(retract_all(Head), Module) 275 ). 276 277 278listing_body(Pred, Module) :- 279 ( check_predspec(Pred), 280 Pred = N/A, 281 dynamic_source_(N, A, SrcHandle, Module) -> 282 ( 283 recorded(SrcHandle, Clause)@Module, 284 writeclause(Clause)@Module, 285 fail 286 ; 287 true 288 ) 289 ; 290 bip_error(listing(Pred), Module) 291 ). 292 293 294listing_body(Module) :- 295 ( 296 Pred = N/A, 297 current_predicate_body(Pred, Module), 298 is_dynamic_(N, A, Module), 299 proc_flags(Pred, 0, Module, Module), % definition module = Module 300 listing_body(Pred, Module), 301 nl(output), 302 fail 303 ; 304 true 305 ). 306 307 308 309 310%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 311% some predicates to output a clause (used in listing) 312 313writeclause_body(C,M):- 314 writeclause_body(output, C, M). 315 316writeclause_body(Stream, Clause, Module) :- 317 write_clause(Stream, Clause, Module), 318 put_separated(Stream, 0'., Module), 319 nl(Stream). 320 321put_separated(Stream, Char, Module) :- 322 get_chtab(Char, Class), 323 ( 324 get_stream_info(Stream, last_written, LastChar), % may fail 325 get_chtab(LastChar, Class)@Module 326 -> 327 put(Stream, 0' ) 328 ; 329 true 330 ), 331 put(Stream, Char). 332 333write_clause(Str, (H?-B), M) ?- !, 334 write_bracketed_if_needed(Str, H, 1199, M), 335 write_(Str, ' ?-', M), 336 nl(Str), 337 write_goal(Str, B, 2, 1199, M). 338write_clause(Str, (H:-B), M) ?- !, 339 (B == true -> 340 writeq_(Str, H, M) 341 ; 342 write_bracketed_if_needed(Str, H, 1199, M), 343 write_(Str, ' :-', M), 344 nl(Str), 345 write_goal(Str, B, 2, 1199, M) 346 ). 347write_clause(Str, (H-->B), M) ?- !, 348 write_bracketed_if_needed(Str, H, 1199, M), 349 write_(Str, '-->', M), 350 nl(Str), 351 write_goal(Str, B, 2, 1199, M). 352write_clause(Str, H, M):- 353 writeq_(Str, H, M). 354 355 356write_goal(Str, Term, Indent, M) :- 357 write_goal(Str, Term, Indent, 1200, M). 358 359% be careful not to instantiate input arguments! 360write_goal(Str, B, Indent, _Prec, M):- 361 var(B), !, 362 indent(Str, Indent, M), 363 writeq_(Str, B, M). 364write_goal(Str, (B,C), Indent, _Prec, M):- !, 365 write_goal(Str, B, Indent, 999, M), 366 put(Str, 0',), nl(Str), 367 write_goal(Str, C, Indent, 1000, M). 368write_goal(Str, (IfThen;D), Indent, _Prec, M) :- 369 nonvar(IfThen), 370 IfThen = (B->C), 371 !, 372 Ind1 is Indent+1, 373 indent(Str, Indent, M), 374 put(Str, 0'(), nl(Str), 375 write_goal(Str, B, Ind1, 1049, M), 376 nl(Str), 377 indent(Str, Indent, M), 378 write_(Str, '->', M), 379 nl(Str), 380 write_goal(Str, C, Ind1, 1050, M), 381 nl(Str), 382 indent(Str, Indent, M), 383 put(Str, 0';), nl(Str), 384 write_goal(Str, D, Ind1, 1100, M), 385 nl(Str), 386 indent(Str, Indent, M), 387 put(Str, 0')). 388write_goal(Str, (B;C), Indent, _Prec, M):- !, 389 Ind1 is Indent+1, 390 indent(Str, Indent, M), 391 put(Str, 0'(), nl(Str), 392 write_goal(Str, B, Ind1, 1099, M), 393 nl(Str), 394 indent(Str, Indent, M), 395 put(Str, 0';), nl(Str), 396 write_goal(Str, C, Ind1, 1100, M), 397 nl(Str), 398 indent(Str, Indent, M), 399 put(Str, 0')). 400write_goal(Str, (B->C), Indent, _Prec, M):- !, 401 Ind1 is Indent+1, 402 indent(Str, Indent, M), 403 put(Str, 0'(), nl(Str), 404 write_goal(Str, B, Ind1, 1049, M), 405 nl(Str), 406 indent(Str, Indent, M), 407 write_(Str, '->', M), 408 nl(Str), 409 write_goal(Str, C, Ind1, 1050, M), 410 nl(Str), 411 indent(Str, Indent, M), 412 put(Str, 0')). 413write_goal(Str, (B do C), Indent, _Prec, M):- !, 414 Ind1 is Indent+1, 415 indent(Str, Indent, M), 416 put(Str, 0'(), nl(Str), 417 write_goal(Str, B, Ind1, 1099, M), 418 nl(Str), 419 indent(Str, Indent, M), 420 write_(Str, do, M), 421 nl(Str), 422 write_goal(Str, C, Ind1, 1100, M), 423 nl(Str), 424 indent(Str, Indent, M), 425 put(Str, 0')). 426write_goal(Str, (-?-> B), Indent, _Prec, M):- !, 427 indent(Str, Indent, M), 428 write_(Str, '-?->', M), 429 nl(Str), 430 write_goal(Str, B, Indent, 1179, M). 431write_goal(Str, '{}'(B), Indent, _Prec, M):- !, 432 Ind1 is Indent+1, 433 indent(Str, Indent, M), 434 put(Str, 0'{), nl(Str), 435 write_goal(Str, B, Ind1, 1200, M), 436 nl(Str), 437 indent(Str, Indent, M), 438 put(Str, 0'}). 439write_goal(Str, B, Indent, Prec, M):- 440 indent(Str, Indent, M), 441 write_bracketed_if_needed(Str, B, Prec, M). 442 443 444% this is just to fix the bugs, better code is in the public domain write.pl 445 446write_bracketed_if_needed(Str, Term, MaxPrec, M) :- 447 compound(Term), 448 functor(Term, F, A), 449 current_op_body(Prec, Assoc, F, M), 450 atom_length(Assoc) =:= A + 1, % Functor is an operator 451 Prec > MaxPrec, 452 !, % Term might needs brackets 453 put(Str, 0'(), 454 writeq_(Str, Term, M), 455 put(Str, 0')). 456write_bracketed_if_needed(Str, Term, _Prec, M) :- 457 writeq_(Str, Term, M). 458 459 460indent(_, 0, _) :- !. 461indent(Str, 1, M) :- !, 462 write_(Str, ' ', M). % write 4 spaces 463indent(Str, N, M) :- 464 N >= 2, N1 is N-2, 465 write_(Str, '\t', M), 466 indent(Str, N1, M). 467 468%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 469 470?- skipped 471 (abolish)/1, 472 abolish_body/2, 473 clause/1, 474 clause/2, 475 clause_body/2, 476 clause_body/3, 477 (dynamic)/1, 478 dynamic_body/2, 479 is_dynamic/1, 480 is_dynamic_body/2, 481 (listing)/0, 482 (listing)/1, 483 listing_body/1, 484 listing_body/2, 485 retract/1, 486 retract_all/1, 487 retract_all_body/2, 488 retract_body/2, 489 writeclause/1, 490 writeclause/2, 491 writeclause_body/2, 492 writeclause_body/3. 493