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) 1992-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: meta.pl,v 1.8 2013/02/12 18:52:16 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29% 30% SEPIA PROLOG KERNEL MODULE 31% 32% IDENTIFICATION: meta.pl, part of module(sepia_kernel) 33% 34% AUTHOR: Micha Meier 35% 36% CONTENTS: Basic metaterm handling 37% 38 39:- pragma(nodebug). 40:- pragma(noskip). 41 42:- export 43 copy_term/2, 44 copy_term_vars/3, 45 delayed_goals/2, 46 suspensions/2, 47 delayed_goals_number/2, 48 instance/2, 49 compare_instances/3, 50 meta_attribute/2, 51 get_var_bounds/3, 52 set_var_bounds/3, 53 not_unify/2, 54 variant/2. 55 56:- export % export tool bodies and handlers 57 meta_attributes/1, 58 unify_attributes/2, 59 test_unify_handler/1. 60 61?- make_array_(meta_index, prolog, local, sepia_kernel), 62 setval(meta_index, 0). 63 64 65%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 66% 67% Generic metaterm stuff, meta transformations, multiple extensions 68% 69%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 70 71%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 72% 73% MULTIPLE EXTENSIONS 74% 75%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 76 77%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 78% Declaring a new extension 79% 80 81:- tool(meta_attribute/2, meta_attribute_body/3). 82:- local_record(pre_unify). 83:- local_record(unify). 84:- local_record(test_unify). 85:- local_record(compare_instances). 86:- local_record(copy_term). 87:- local_record(print). 88:- local_record(get_bounds). 89:- local_record(set_bounds). 90:- local_record(suspensions). 91:- local_record(delayed_goals). 92:- local_record(delayed_goals_number). 93:- local_record(suspension_lists). 94 95meta_attributes(Atts) :- 96 recorded_list(meta_attribute, Atts). 97 98 99meta_attribute_body(Name, List, Module) :- 100 check_atom(Name), 101 meta_name_index(Name, Index), 102 ( Name == suspend, Index == 1 -> 103 % The suspend handlers are handcoded below to avoid use of the 104 % compiler during initial booting 105 check_handlers(List, List1, Name, Module), 106 record_handlers(Index, Name, List1, Module) 107 ; 108 check_handlers(List, List1, Name, Module), 109 record_handlers(Index, Name, List1, Module), 110 recompile_system_handlers 111 ), 112 !. 113meta_attribute_body(Name, List, Module) :- 114 bip_error(meta_attribute(Name, List), Module). 115 116 117meta_name_index(Name, Index) :- 118 recordedchk(meta_attribute, [Name|Index]), 119 !. 120meta_name_index(Name, Index) :- 121 incval(meta_index), 122 getval(meta_index, Index), 123 getval(meta_arity, Max), 124 (Index > Max -> 125 incval(meta_arity) 126 ; 127 true 128 ), 129 recorda(meta_attribute, [Name|Index]). 130 131% can fail with bip_error 132:- mode check_handlers(?,-,+,+). 133check_handlers(L, _, _, _) :- var(L), !, 134 set_bip_error(4). 135check_handlers([], [], _, _) :- !. 136check_handlers([Decl|List], Decls, AttrName, Module) :- !, 137 check_functor(Decl, (:), 2), 138 Decl = H:P, 139 ( is_meta_event(H, _) -> 140 check_predspec(P), 141 ( P == true/0 -> 142 true 143 ; 144 P = _/Arity, 145 once is_meta_event(H, Arity), 146 ( get_flag(P, defined, on)@Module -> 147 get_flag(P, visibility, Vis)@Module, 148 ( Vis == local -> 149 (export P)@Module 150 ; Vis == imported -> 151 get_flag(P, definition_module, DM)@Module, 152 (reexport P from DM)@Module 153 ; 154 true 155 ) 156 ; 157 % require handler to be defined already 158 set_bip_error(60) 159 ) 160 ), 161 Decls = [Decl|Decls1], 162 check_handlers(List, Decls1, AttrName, Module) 163 164 ; H == suspension_lists -> 165 check_proper_list(P), 166 ( foreach(Spec,P), foreach(OutSpec,OutDecl), param(AttrName,Module) do 167 normalise_susp_list_spec(Spec, OutSpec, AttrName, Module) 168 ), 169 Decls = [H:OutDecl|Decls1], 170 check_handlers(List, Decls1, AttrName, Module) 171 ; 172 set_bip_error(6) 173 ). 174check_handlers(_, _, _, _) :- 175 set_bip_error(5). 176 177 178record_handlers(_, _, [], _). 179record_handlers(Index, Name, [H:P|List], Module) :- 180 (recordedchk(H, t(Index, _, _, _, _), Ref) -> 181 erase(Ref) 182 ; 183 true 184 ), 185 ( P == true/0 -> 186 true % remove the handler 187 ; 188 recordz(H, t(Index, Name, H, P, Module)) 189 ), 190 record_handlers(Index, Name, List, Module). 191 192 193% Check and normalise a single suspension_lists declaration: 194% ( atom | atom:(atom|posint|list(atom|posint)) ) ==> atom:list(posint) 195% can fail with bip_error 196:- mode normalise_susp_list_spec(?,-,+,+). 197normalise_susp_list_spec(Spec, _, _, _) :- var(Spec), !, 198 set_bip_error(4). 199normalise_susp_list_spec(Name, Name:[Slot], AttrName, Module) :- atom(Name), !, 200 lookup_slot_number(Name, Slot, AttrName, Module). 201normalise_susp_list_spec(Name:SlotSpecs, NameSlots, AttrName, Module) ?- !, 202 check_atom(Name), 203 NameSlots = Name:Slots, 204 ( atom(SlotSpecs) -> 205 Slots = [Slot], lookup_slot_number(SlotSpecs, Slot, AttrName, Module) 206 ; integer(SlotSpecs) -> 207 check_integer_ge(SlotSpecs, 1), 208 Slots = [SlotSpecs] 209 ; 210 check_proper_list(SlotSpecs), 211 ( foreach(SlotSpec,SlotSpecs), foreach(Slot1,Slots), param(AttrName,Module) do 212 ( atom(SlotSpec) -> 213 lookup_slot_number(SlotSpec, Slot1, AttrName, Module) 214 ; 215 check_integer_ge(SlotSpec, 1), Slot1=SlotSpec 216 ) 217 ) 218 ). 219normalise_susp_list_spec(_, _, _, _) :- 220 set_bip_error(5). 221 222 % can fail with bip_error 223 lookup_slot_number(Name, Slot, AttrName, Module) :- 224 ( tr_of(no_macro_expansion(Name of AttrName), Slot, Module), integer(Slot) -> 225 true 226 ; 227 set_bip_error(6) 228 ). 229 230 231% remove all calls to handlers in the erased module 232erase_module_attribute_handlers(suspend) :- !. 233erase_module_attribute_handlers(Module) :- 234 findall(H, ( 235 meta_event(H, _), 236 recorded(H, t(_, _, _, _, Module), Ref), 237 erase(Ref) 238 ), Erased), 239 ( Erased = [_|_] -> 240 recompile_system_handlers 241 ; 242 true 243 ). 244 245 246is_meta_event(Var, _) :- 247 var(Var), 248 !, 249 set_bip_error(4). 250is_meta_event(Var, _) :- 251 not atom(Var), 252 !, 253 set_bip_error(5). 254is_meta_event(H, A) :- 255 meta_event(H, A), !. 256is_meta_event(_, _) :- 257 set_bip_error(6). 258 259meta_event(pre_unify, 2). 260meta_event(unify, 2). 261meta_event(unify, 3). 262meta_event(test_unify, 2). 263meta_event(compare_instances, 3). 264meta_event(copy_term, 2). 265meta_event(delayed_goals, 3). 266meta_event(suspensions, 3). 267meta_event(delayed_goals_number, 2). 268meta_event(get_bounds, 3). 269meta_event(set_bounds, 3). 270meta_event(print, 2). 271 272 273% lookup_suspension_list(?AttrName, +SuspName, -Slots, +Module) is semidet 274lookup_suspension_list(AttrName, SuspName, Slots, _Module) :- 275 atom(AttrName), 276 % We know the attribute name. If there was a declaration, use it. 277 ( recordedchk(suspension_lists, t(_, AttrName, _, Specs, _)) -> 278 memberchk(SuspName:Slots, Specs) 279 ; 280 % No declaration: For backward compatibility, if a like-named 281 % structure is visible, allow any of its field names. 282 visible_struct(AttrName, ProtoStruct, AttrName, _Scope), % semidet 283 struct_lookup_index(ProtoStruct, SuspName, Slot, AttrName), 284 integer(Slot), Slots = [Slot] 285 ). 286lookup_suspension_list(AttrNameFound, SuspName, Slots, Module) :- 287 var(AttrNameFound), 288 % No attribute name given. 289 % Search those attributes for which a like-named structure is visible. 290 recorded_list(suspension_lists, AttrSusps), 291 ( 292 foreach(t(_,AttrName,_,Specs,_),AttrSusps), 293 param(SuspName,Module,AttrNameFound,Slots) 294 do 295 ( 296 visible_struct(AttrName, _ProtoStruct, Module, _Scope), 297 memberchk(SuspName:Slots0, Specs) 298 -> 299 ( AttrNameFound = AttrName -> Slots = Slots0 ; 300 printf(warning_output, 301 "WARNING: Ignoring ambiguous suspension list name '%w'%n" 302 "WARNING: defined in attributes %w and %w.%n", 303 [SuspName,AttrNameFound,AttrName]), 304 fail 305 ) 306 ; 307 true 308 ) 309 ), 310 ( nonvar(Slots) -> 311 true 312 ; 313 % No matching declaration. For backward compatibility, 314 % try any field of structures that are named like attributes. 315 meta_attributes(Metas), 316 ( 317 foreach([AttrName|_],Metas), 318 param(SuspName,Module,AttrNameFound,Slots) 319 do 320 ( 321 visible_struct(AttrName, ProtoStruct, Module, _Scope), 322 struct_lookup_index(ProtoStruct, SuspName, Slot, Module), 323 integer(Slot) 324 -> 325 ( AttrNameFound = AttrName -> Slots = [Slot] ; 326 printf(warning_output, 327 "WARNING: Ignoring ambiguous suspension list name '%w'%n" 328 "WARNING: defined in attributes %w and %w.%n", 329 [SuspName,AttrNameFound,AttrName]), 330 fail 331 ) 332 ; 333 true 334 ) 335 ), 336 nonvar(Slots) 337 ). 338 339 340recompile_system_handlers :- 341 recompile_unify_handler, 342 recompile_pre_unify_handler, 343 recompile_test_unify_handler, 344 recompile_compare_instances_handler, 345 recompile_copy_term_handler, 346 recompile_delayed_goals_handler, 347 recompile_suspensions_handler, 348 recompile_delayed_goals_number_handler, 349 recompile_get_bounds_handler, 350 recompile_set_bounds_handler, 351 recompile_print_handler. 352 353/* 354 * The handlers have the format 355 * pre_unify_attributes(AttrVar, Term, Pair) :- 356 * pre_handler1(AttrVar, Term), 357 * .... 358 * do_meta_bind(Pair, Term), 359 * 360 * unify_attributes(Term, meta(Attr1, ...)) :- 361 * post_handler1(Term, Attr1), 362 * ... 363 * If there are no pre_unify handlers, their part is omitted. 364 */ 365 366%------------------------------ 367:- mode unify_attributes(?,++). 368unify_attributes(Term, Meta) :- 369 arg(1, Meta, SuspAttr), 370 suspend:unify_suspend(Term , SuspAttr). 371 372recompile_unify_handler :- 373 collect_local_handlers(unify, List), 374 local_unify_handlers(List, Meta, Term, SuspAttr, Body), 375 compile_term((unify_attributes(Term, Meta) :- arg(1,Meta,SuspAttr),Body), [debug:off]). 376 377local_unify_handlers([], _, _, _, untraced_true). 378local_unify_handlers([t(I, _, _, N/A, M)], Meta, Term, SuspAttr, Body) :- 379 !, 380 ( I = 1 -> 381 Attr = SuspAttr, Body = M:Goal 382 ; 383 Body = (arg(I,Meta,Attr), M:Goal) 384 ), 385 ( A = 3 -> 386 Goal =.. [N, Term, Attr, SuspAttr] 387 ; 388 Goal =.. [N, Term, Attr] 389 ). 390local_unify_handlers([t(I, _, _, N/A, M)|List], Meta, Term, SuspAttr, Body) :- 391 ( I = 1 -> 392 Attr = SuspAttr, Body = (M:Goal, NewBody) 393 ; 394 Body = (arg(I,Meta,Attr), M:Goal, NewBody) 395 ), 396 ( A = 3 -> 397 Goal =.. [N, Term, Attr, SuspAttr] 398 ; 399 Goal =.. [N, Term, Attr] 400 ), 401 local_unify_handlers(List, Meta, Term, SuspAttr, NewBody). 402 403%------------------------------ 404pre_unify_attributes(_AttrVar, _Term, _Pair). 405 406recompile_pre_unify_handler :- 407 collect_local_handlers(pre_unify, PreList), 408 (PreList = [] -> 409 compile_term((pre_unify_attributes(_,_,_)), [debug:off]), 410 set_default_error_handler(11, unify_handler/1), 411 set_error_handler(11, unify_handler/1) 412 ; 413 local_pre_unify_handlers(PreList, AttrVar, Term, Pair, Body), 414 compile_term((pre_unify_attributes(AttrVar, Term, Pair) :- Body), [debug:off]), 415 set_default_error_handler(11, pre_unify_handler/1), 416 set_error_handler(11, pre_unify_handler/1) 417 ). 418 419undo_meta_bindings([], []). 420undo_meta_bindings([Pair|List], [p(AttrVar, Term, Pair)|PList]) :- 421 Pair = [Term|_], 422 undo_meta_bind(Pair, AttrVar), 423 undo_meta_bindings(List, PList). 424 425local_pre_unify_handlers([t(_, _, _, N/_, M)], AttrVar, Term, Pair, LastCall) :- 426 !, 427 Goal =.. [N, AttrVar, Term], 428 LastCall = (M:Goal, do_meta_bind(Pair, Term)). 429local_pre_unify_handlers([t(_, _, _, N/_, M)|List], AttrVar, Term, Pair, Body) :- 430 Goal =.. [N, AttrVar, Term], 431 Body = (M:Goal, NewBody), 432 local_pre_unify_handlers(List, AttrVar, Term, Pair, NewBody). 433 434%------------------------------ 435:- mode test_unify_attributes(?, ++). 436test_unify_attributes(_Term, _Attr). 437 438recompile_test_unify_handler :- 439 getval(meta_arity, I), 440 functor(Attr, meta, I), 441 collect_local_handlers(test_unify, List), 442 local_test_unify_handlers(List, Attr, Term, Body), 443 compile_term((test_unify_attributes(Term, Attr) :- Body), [debug:off]). 444 445local_test_unify_handlers([], _, _, untraced_true). 446local_test_unify_handlers([t(I, _, _, N/_, M)], Attr, Term, M:Goal) :- 447 !, 448 arg(I, Attr, LA), 449 Goal =.. [N, Term, LA]. 450local_test_unify_handlers([t(I, _, _, N/_, M)|List], Attr, Term, Body) :- 451 arg(I, Attr, LA), 452 Goal =.. [N, Term, LA], 453 Body = (M:Goal, NewBody), 454 local_test_unify_handlers(List, Attr, Term, NewBody). 455 456%------------------------------ 457:- mode compare_instances_attributes(?, ?, ?). 458compare_instances_attributes(Res, _TermL, _TermR) :- 459 % one or both of TermL, TermR are attributed variables! 460 x_res(=, Res). 461 462recompile_compare_instances_handler :- 463 collect_local_handlers(compare_instances, List), 464 local_compare_instances_handlers(List, Res, TermL, TermR, Body, _), 465 compile_term((compare_instances_attributes(Res, TermL, TermR) :- Body), [debug:off]). 466 467local_compare_instances_handlers([t(_, _, _, N/_, M)|List], Res, TermL, TermR, 468 Body, ResL) :- 469 Goal =.. [N, R, TermL, TermR], 470 Body = (M:Goal, NewBody), 471 (List = [] -> 472 (var(ResL) -> 473 NewBody = (Res is x_res(R)) 474 ; 475 NewBody = (Res is x_res(R) /\ ResL) 476 ) 477 ; 478 (var(ResL) -> 479 ResR = x_res(R) 480 ; 481 ResR = x_res(R) /\ ResL 482 ), 483 local_compare_instances_handlers(List, Res, TermL, TermR, NewBody, ResR) 484 ). 485local_compare_instances_handlers([], RR, _, _, true, _) :- 486 x_res(=, RR). 487 488%------------------------------ 489:- mode copy_term_attributes(?, ?). 490copy_term_attributes(_Meta, _Term). 491 492recompile_copy_term_handler :- 493 collect_local_handlers(copy_term, List), 494 local_copy_term_handlers(List, Meta, Term, Body), 495 compile_term((copy_term_attributes(Meta, Term) :- Body), [debug:off]). 496 497 local_copy_term_handlers([t(_, _, _, N/_, M)|List], Meta, Term, Body) :- 498 Goal =.. [N, Meta, Term], 499 (List = [] -> 500 Body = M:Goal 501 ; 502 Body = (M:Goal, NewBody), 503 local_copy_term_handlers(List, Meta, Term, NewBody) 504 ). 505 local_copy_term_handlers([], _, _, true). 506 507%------------------------------ 508% Create a handler that computes the minimum range from all bounds handlers. 509% The result is always two floats, although the individual handlers may 510% return integers. 511% The handlers are only called if the attribute exists! 512 513get_meta_bounds(_Meta, Lower, Upper) ?- 514 Lower = -1.0Inf, Upper = 1.0Inf. 515 516recompile_get_bounds_handler :- 517 collect_local_handlers(get_bounds, List), 518 local_get_bounds_handlers(List, Meta, -1.0Inf, 1.0Inf, Lower, Upper, Body), 519 compile_term((get_meta_bounds(Meta, Lower, Upper) ?- Body), [debug:off]). 520 521 local_get_bounds_handlers([], _Meta, L0, U0, L, U, (L=L0,U=U0)). 522 local_get_bounds_handlers([t(AttrSlot, _, _, N/_, M)|List], Meta, L0, U0, L, U, Body) :- 523 add_attribute(Meta, Attr, AttrSlot), 524 Goal =.. [N, Meta, L1, U1], 525 Goal1 = (nonvar(Attr) -> M:Goal,max(L0,L1,L2),min(U0,U1,U2) ; L2=L0,U2=U0), 526 (List = [] -> 527 Body = Goal1, 528 U2=U, L2=L 529 ; 530 Body = (Goal1, NewBody), 531 local_get_bounds_handlers(List, Meta, L2, U2, L, U, NewBody) 532 ). 533 534%------------------------------ 535set_meta_bounds(_Meta, _Lwb, _Upb). 536 537recompile_set_bounds_handler :- 538 collect_local_handlers(set_bounds, List), 539 local_set_bounds_handlers(List, Meta, Lwb, Upb, Body), 540 compile_term((set_meta_bounds(Meta, Lwb, Upb) ?- Body), [debug:off]). 541 542 :- mode local_set_bounds_handlers(+,?,?,?,-). 543 local_set_bounds_handlers([], _, _, _, true). 544 local_set_bounds_handlers([t(AttrSlot, _, _, N/_, M)|List], Meta, Lwb, Upb, Body) :- 545 add_attribute(Meta, Attr, AttrSlot), 546 Goal =.. [N, Meta, Lwb, Upb], 547 Goal1 = (nonvar(Attr) -> M:Goal ; true), 548 (List = [] -> 549 Body = Goal1 550 ; 551 Body = (Goal1, NewBody), 552 local_set_bounds_handlers(List, Meta, Lwb, Upb, NewBody) 553 ). 554 555%------------------------------ 556% Obsolete delayed_goals handlers 557% (modified to work as well on top of new suspensions-handler) 558:- mode delayed_goals_attributes(?, ?, ?). 559delayed_goals_attributes(Meta, G, G0) :- 560 suspend:suspensions_suspend(Meta, ListOfSuspLists, []), 561 concat_live_suspensions(ListOfSuspLists, Susps, []), 562 suspensions_to_goals(Susps, G, G0). 563 564recompile_delayed_goals_handler :- 565 collect_local_handlers(suspensions, ListSH), % new 566 collect_local_handlers(delayed_goals, ListDGH), % old 567 append(ListSH, ListDGH, List0), 568 sort(1 /*index of t*/, <, List0, List), % keep only SH if both are there 569 local_delayed_goals_handlers(List, Meta, G, G0, Body), 570 compile_term((delayed_goals_attributes(Meta, G, G0) :- Body), [debug:off]). 571 572local_delayed_goals_handlers([t(_, _, HandlerType, N/_, M)|List], Meta, G, G0, Body) :- 573 ( HandlerType == delayed_goals -> 574 HGoal =.. [N, Meta, G, G1], Goal = M:HGoal 575 ; 576 HGoal =.. [N, Meta, ListOfSuspLists, []], 577 Goal = ( 578 M:HGoal, 579 concat_live_suspensions(ListOfSuspLists, Susps, []), 580 suspensions_to_goals(Susps, G, G1) 581 ) 582 ), 583 (List = [] -> 584 Body = Goal, 585 G0 = G1 586 ; 587 Body = (Goal, NewBody), 588 local_delayed_goals_handlers(List, Meta, G1, G0, NewBody) 589 ). 590local_delayed_goals_handlers([], _, G, G, true). 591 592%------------------------------ 593:- mode suspensions_attributes(?, ?, ?). 594suspensions_attributes(Meta, S, S0) :- 595 suspend:suspensions_suspend(Meta, S, S0). 596 597recompile_suspensions_handler :- 598 collect_local_handlers(suspensions, List), 599 local_suspensions_handlers(List, Meta, S, S0, Body), 600 compile_term((suspensions_attributes(Meta, S, S0) :- Body), [debug:off]). 601 602local_suspensions_handlers([t(_, _, _, N/_, M)|List], Meta, S, S0, Body) :- 603 Goal =.. [N, Meta, S, S1], 604 (List = [] -> 605 Body = M:Goal, 606 S0 = S1 607 ; 608 Body = (M:Goal, NewBody), 609 local_suspensions_handlers(List, Meta, S1, S0, NewBody) 610 ). 611local_suspensions_handlers([], _, S, S, true). 612 613%------------------------------ 614:- mode delayed_goals_number_attributes(?, ?). 615delayed_goals_number_attributes(Meta, NG) :- 616 suspend:delayed_goals_number_suspend(Meta, NG). 617 618recompile_delayed_goals_number_handler :- 619 collect_local_handlers(delayed_goals_number, List), 620 local_delayed_goals_number_handlers(List, Meta, NG, Body, 0), 621 compile_term((delayed_goals_number_attributes(Meta, NG) :- Body), [debug:off]). 622 623local_delayed_goals_number_handlers([t(_, _, _, N/_, M)|List], Meta, NG, Body, NG0) :- 624 Goal =.. [N, Meta, NG1], 625 (List = [] -> 626 ( NG0 == 0 -> % only one 627 Body = M:Goal, 628 NG = NG1 629 ; 630 Body = (M:Goal, NG is NG0 + NG1) 631 ) 632 ; 633 Body = (M:Goal, NewBody), 634 ( NG0 == 0 -> % first 635 NG2 = NG1 636 ; 637 NG2 = NG0 + NG1 638 ), 639 local_delayed_goals_number_handlers(List, Meta, NG, NewBody, NG2) 640 ). 641local_delayed_goals_number_handlers([], _, 0, true, _). 642 643%------------------------------ 644print_attribute(_, _) :- fail. 645 646recompile_print_handler :- 647 collect_local_handlers(print, List), 648 local_print_handlers(List, Var, OL, Body), 649 (Body == (_ = []) -> 650 compile_term((print_attribute(_, _) :- fail), [debug:off]) 651 ; 652 compile_term((print_attribute(Var, OL) :- Body), [debug:off]) 653 ). 654 655local_print_handlers([], _, L, L = []). 656local_print_handlers([t(_, Name, _, N/_, M)|List], Var, L, 657 ((M:Goal -> L = [Name:Out|L1]; L = L1), Body1)) :- 658 Goal =.. [N, Var, Out], 659 local_print_handlers(List, Var, L1, Body1). 660 661%------------------------------ 662collect_local_handlers(Key, List) :- 663 getval(meta_index, I), 664 collect_local_handlers(I, Key, List). 665 666collect_local_handlers(I, Key, List) :- 667 I > 0, 668 !, 669 I1 is I - 1, 670 (Cont = t(I, _, _, P, _), 671 recorded(Key, Cont), 672 P \= true/0 -> 673 List = [Cont|NewList], 674 collect_local_handlers(I1, Key, NewList) 675 ; 676 collect_local_handlers(I1, Key, List) 677 ). 678collect_local_handlers(_, _, []). 679 680 681%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 682% 683% Global handlers 684% 685%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 686 687 688% 689%%%% unification %%%% 690% 691 692:- pragma(debug). 693unify_handler([]) :- -?-> 694 wake. % we want to trace this call (only) 695unify_handler([[Term|Attr]|List]) :- 696 -?-> 697 unify_attributes(Term, Attr), 698 unify_handler(List). 699:- pragma(nodebug). 700 701pre_unify_handler(List) :- 702 undo_meta_bindings(List, NewList), 703 pre_unify_pairs(NewList), 704 unify_handler(List). 705 706pre_unify_pairs([]). 707pre_unify_pairs([p(Var, Term, Pair)|L]) :- 708 pre_unify_attributes(Var, Term, Pair), 709 pre_unify_pairs(L). 710 711 712 713% 714%%%% not_unify/2 %%%% 715% 716not_unify(X, Y) :- 717 unify(X, Y, List), % like =/2 with an explicit list 718 test_unify_handler(List), 719 !, 720 fail. 721not_unify(_, _). 722 723test_unify_handler([]). 724test_unify_handler([[Term|Attr]|List]) :- 725 test_unify_attributes(Term, Attr), 726 test_unify_handler(List). 727 728 729% 730%%%% variant/2 %%%% 731% 732variant(Term1, Term2) :- 733 compare_instances(=, Term1, Term2, List), 734 variant_handler(List). 735 736 variant_handler([]). 737 variant_handler([[TermL|TermR]|List]) :- 738 compare_instances_attributes(3, TermL, TermR), 739 variant_handler(List). 740 741% 742%%%% instance/2 %%%% 743% 744instance(Term1, Term2) :- 745 compare_instances(Res, Term1, Term2, List), 746 Res \== (>), 747 instance_handler(List). 748 749 instance_handler([]). 750 instance_handler([[TermL|TermR]|List]) :- 751 compare_instances_attributes(Res, TermL, TermR), 752 Res >= 2, % fail early if any L>R 753 instance_handler(List). 754 755% 756%%%% compare_instances/3 %%%% 757% The cases where the first arg is instantiated are handled 758% specially because they may fail early. 759% 760compare_instances(=, Term1, Term2) ?- !, 761 compare_instances(=, Term1, Term2, List), 762 variant_handler(List). 763compare_instances(<, Term1, Term2) ?- !, 764 compare_instances(Res, Term1, Term2, List), 765 x_res(Res, R), 766 proper_instance_handler(R, List, 2). 767compare_instances(>, Term1, Term2) ?- !, 768 compare_instances(Res, Term2, Term1, List), % swap args 769 x_res(Res, R), 770 proper_instance_handler(R, List, 2). 771compare_instances(Res, Term1, Term2) :- 772 compare_instances(Res0, Term1, Term2, List), 773 x_res(Res0, R0), 774 comp_instances_handler(R0, List, R), 775 x_res(Res, R). 776 777 proper_instance_handler(R, [], R). 778 proper_instance_handler(Res, [[TermL|TermR]|List], ResL) :- 779 Res >= 2, % fail early if any L>R 780 compare_instances_attributes(Res1, TermL, TermR), 781 Res2 is Res1 /\ Res, 782 proper_instance_handler(Res2, List, ResL). 783 784 comp_instances_handler(R, [], R). 785 comp_instances_handler(R1, [[TermL|TermR]|List], R) :- 786 compare_instances_attributes(R2, TermL, TermR), 787 R3 is R1 /\ R2, 788 R3 > 0, % fail early if incomparable 789 comp_instances_handler(R3, List, R). 790 791 792% 793%%%% copy_term/2 %%%% 794% 795copy_term(Term, Copy) :- 796 copy_term(Term, Copy, List), 797 copy_term_handler(List). 798 799copy_term_vars(Vars, Term, Copy) :- 800 copy_term_vars(Vars, Term, Copy, List), 801 copy_term_handler(List). 802 803copy_term_handler([]). 804copy_term_handler([[Meta|Term]|List]) :- 805 copy_term_attributes(Meta, Term), 806 copy_term_handler(List). 807 808 809% 810%%%% retrieve current numeric range %%%% 811% 812get_var_bounds(X, L, U) :- 813 free(X), !, 814 L = -1.0Inf, U = 1.0Inf. 815get_var_bounds(X, L, U) :- 816 meta(X), !, 817 get_meta_bounds(X, L, U). 818get_var_bounds(X, L, U) :- 819 breal(X), !, 820 breal_bounds(X, L, U). 821get_var_bounds(X, L, U) :- 822 number(X), !, 823 L is float(X), U = L. 824get_var_bounds(X, L, U) :- 825 error(5, get_var_bounds(X, L, U)). 826 827set_var_bounds(X, _, _) :- free(X), !. 828set_var_bounds(X, L, U) :- meta(X), !, 829 set_meta_bounds(X, L, U). 830set_var_bounds(X, L, U) :- number(X), !, 831 L =< X, X =< U. 832set_var_bounds(X, L, U) :- 833 error(5, set_var_bounds(X, L, U)). 834 835 836% 837%%%% delayed_goals/2 %%%% 838% 839delayed_goals(Meta, Goals) :- 840 meta(Meta), 841 !, 842 delayed_goals_attributes(Meta, Goals, []). 843delayed_goals(_free_or_instantiated, []). 844 845 846% 847%%%% suspensions/2 %%%% 848% 849suspensions(Meta, Susps) :- 850 meta(Meta), 851 !, 852 suspensions_attributes(Meta, ListOfSuspLists, []), 853 ( Susps == [] -> 854 % if just testing, we can fail early 855 concat_live_suspensions(ListOfSuspLists, [], []) 856 ; 857 concat_live_suspensions(ListOfSuspLists, Susps0, []), 858 sort(0, <, Susps0, Susps) % remove duplicates 859 ). 860suspensions(_free_or_instantiated, []). 861 862 concat_live_suspensions([], Susps, Susps). 863 concat_live_suspensions([SuspList|SuspLists], Susps, Susps0) :- 864 filter_live_suspensions(SuspList, Susps, Susps1), 865 concat_live_suspensions(SuspLists, Susps1, Susps0). 866 867 filter_live_suspensions(Empty, Ls, Ls) :- var(Empty), !. 868 filter_live_suspensions([], Ls, Ls). 869 filter_live_suspensions([S|Ss], SLs, Ls) :- 870 ( is_suspension(S) -> SLs = [S|Ls0] ; SLs = Ls0 ), 871 filter_live_suspensions(Ss, Ls0, Ls). 872 873 874 875% 876%%%% delayed_goals_number/2 %%%% 877% 878delayed_goals_number(Meta, N) :- 879 meta(Meta), 880 !, 881 delayed_goals_number_attributes(Meta, N). 882delayed_goals_number(X, N) :- 883 var(X), 884 !, 885 N = 0. 886delayed_goals_number(_, 1000000). 887 888 889% 890%%%% print %%%% 891% 892print_attributes(Attr, {Out}) :- 893 print_attribute(Attr, L), 894 list_to_attr(L, OT), 895 (OT = _:Out -> 896 true 897 ; 898 L = [_|_], 899 Out = OT 900 ). 901 902list_to_attr([A], A) :- !. 903list_to_attr([A|L], (A,B)) :- 904 list_to_attr(L, B). 905 906x_res(>, 1). 907x_res(<, 2). 908x_res(=, 3). 909 910?- set_default_error_handler(11, unify_handler/1), 911 set_error_handler(11, unify_handler/1). 912 913:- skipped unify_attributes/2. 914:- set_flag(unify_handler/1, invisible, on). 915 916:- unskipped 917 test_unify_attributes/2, 918 compare_instances_attributes/3, 919 copy_term_attributes/2, 920 print_attributes/2, 921 delayed_goals_attributes/3, 922 delayed_goals_number_attributes/2, 923 delayed_goals/2, 924 delayed_goals_number/2, 925 unify_handler/1, 926 copy_term_handler/1, 927 test_unify_handler/1. 928 929:- untraceable 930 unify_attributes/2, 931 pre_unify_attributes/3, 932 test_unify_attributes/2, 933 compare_instances_attributes/3, 934 copy_term_attributes/2, 935 print_attribute/2, 936 print_attributes/2, 937 delayed_goals_attributes/3, 938 delayed_goals_number_attributes/2, 939 unify_handler/1, 940 pre_unify_handler/1, 941 undo_meta_bindings/2, 942 pre_unify_pairs/1, 943 copy_term_handler/1, 944 test_unify_handler/1. 945 946