1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 2011-2016, VU University Amsterdam 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(predicate_options, 36 [ predicate_options/3, % +PI, +Arg, +Options 37 assert_predicate_options/4, % +PI, +Arg, +Options, ?New 38 39 current_option_arg/2, % ?PI, ?Arg 40 current_predicate_option/3, % ?PI, ?Arg, ?Option 41 check_predicate_option/3, % +PI, +Arg, +Option 42 % Create declarations 43 current_predicate_options/3, % ?PI, ?Arg, ?Options 44 retractall_predicate_options/0, 45 derived_predicate_options/3, % :PI, ?Arg, ?Options 46 derived_predicate_options/1, % +Module 47 % Checking 48 check_predicate_options/0, 49 derive_predicate_options/0, 50 check_predicate_options/1, % :PredicateIndicator 51 check_raw_option_access/0, 52 check_raw_option_access/1 % :Spec 53 ]). 54:- autoload(library(apply),[maplist/3]). 55:- use_module(library(debug),[debug/3]). 56:- autoload(library(error), 57 [ existence_error/2, 58 must_be/2, 59 instantiation_error/1, 60 uninstantiation_error/1, 61 is_of_type/2 62 ]). 63:- use_module(library(dialect/swi/syspred_options)). 64 65:- autoload(library(listing),[portray_clause/1]). 66:- autoload(library(lists),[member/2,nth1/3,append/3,delete/3]). 67:- autoload(library(pairs),[group_pairs_by_key/2]). 68:- autoload(library(prolog_clause),[clause_info/4]). 69 70 71:- meta_predicate 72 predicate_options(, , ), 73 assert_predicate_options(, , , ), 74 current_predicate_option(, , ), 75 check_predicate_option(, , ), 76 current_predicate_options(, , ), 77 current_option_arg(, ), 78 pred_option(,), 79 derived_predicate_options(,,), 80 check_predicate_options(), 81 check_raw_option_access(), 82 raw_option_findings(, ).
151:- multifile option_decl/3, pred_option/3. 152:- dynamic dyn_option_decl/3.
Below is an example that processes the option header(boolean)
and passes all options to open/4:
:- predicate_options(write_xml_file/3, 3,
[ header(boolean),
pass_to(open/4, 4)
]).
write_xml_file(File, XMLTerm, Options) :-
open(File, write, Out, Options),
( option(header(true), Options, true)
-> write_xml_header(Out)
; true
),
...
This predicate may only be used as a directive and is processed by expand_term/2. Option processing can be specified at runtime using assert_predicate_options/3, which is intended to support program analysis.
190predicate_options(PI, Arg, Options) :-
191 throw(error(context_error(nodirective,
192 predicate_options(PI, Arg, Options)), _)).false, the predicate becomes semidet and fails
without modifications if modifications are required.202assert_predicate_options(PI, Arg, Options, New) :- 203 canonical_pi(PI, M:Name/Arity), 204 functor(Head, Name, Arity), 205 ( dyn_option_decl(Head, M, Arg) 206 -> true 207 ; New = true, 208 assertz(dyn_option_decl(Head, M, Arg)) 209 ), 210 phrase('$predopts':option_clauses(Options, Head, M, Arg), 211 OptionClauses), 212 forall(member(Clause, OptionClauses), 213 assert_option_clause(Clause, New)), 214 ( var(New) 215 -> New = false 216 ; true 217 ). 218 219assert_option_clause(Clause, New) :- 220 rename_clause(Clause, NewClause, 221 '$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)), 222 clause_head(NewClause, NewHead), 223 ( clause(NewHead, _) 224 -> true 225 ; New = true, 226 assertz(NewClause) 227 ). 228 229clause_head(M:(Head:-_Body), M:Head) :- !. 230clause_head((M:Head :-_Body), M:Head) :- !. 231clause_head(Head, Head). 232 233rename_clause(M:Clause, M:NewClause, Head, NewHead) :- 234 !, 235 rename_clause(Clause, NewClause, Head, NewHead). 236rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !. 237rename_clause(Head, NewHead, Head, NewHead) :- !. 238rename_clause(Head, Head, _, _). 239 240 241 242 /******************************* 243 * QUERY OPTIONS * 244 *******************************/
251current_option_arg(Module:Name/Arity, Arg) :- 252 current_option_arg(Module:Name/Arity, Arg, _DefM). 253 254current_option_arg(Module:Name/Arity, Arg, DefM) :- 255 atom(Name), integer(Arity), 256 !, 257 resolve_module(Module:Name/Arity, DefM:Name/Arity), 258 functor(Head, Name, Arity), 259 ( option_decl(Head, DefM, Arg) 260 ; dyn_option_decl(Head, DefM, Arg) 261 ). 262current_option_arg(M:Name/Arity, Arg, M) :- 263 ( option_decl(Head, M, Arg) 264 ; dyn_option_decl(Head, M, Arg) 265 ), 266 functor(Head, Name, Arity).
?- current_predicate_option(open/4, 4, type(text)). true.
This predicate is intended to support conditional compilation using if/1 ... endif/0. The predicate current_predicate_options/3 can be used to access the full capabilities of a predicate.
283current_predicate_option(Module:PI, Arg, Option) :-
284 current_option_arg(Module:PI, Arg, DefM),
285 PI = Name/Arity,
286 functor(Head, Name, Arity),
287 catch(pred_option(DefM:Head, Option),
288 error(type_error(_,_),_),
289 fail).302check_predicate_option(Module:PI, Arg, Option) :- 303 define_predicate(Module:PI), 304 once(current_option_arg(Module:PI, Arg, DefM)), 305 PI = Name/Arity, 306 functor(Head, Name, Arity), 307 ( pred_option(DefM:Head, Option) 308 -> true 309 ; existence_error(option, Option) 310 ). 311 312 313pred_option(Head, Option) :- 314 pred_option(Head, Option, []). 315 316pred_option(M:Head, Option, Seen) :- 317 ( has_static_option_decl(M), 318 M:'$pred_option'(Head, _, Option, Seen) 319 ; has_dynamic_option_decl(M), 320 M:'$dyn_pred_option'(Head, _, Option, Seen) 321 ). 322 323has_static_option_decl(M) :- 324 '$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)). 325has_dynamic_option_decl(M) :- 326 '$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)). 327 328 329 /******************************* 330 * TYPE&MODE CONSTRAINTS * 331 *******************************/ 332 333:- public 334 system:predicate_option_mode/2, 335 system:predicate_option_type/2. 336 337add_attr(Var, Value) :- 338 ( get_attr(Var, predicate_options, Old) 339 -> put_attr(Var, predicate_options, [Value|Old]) 340 ; put_attr(Var, predicate_options, [Value]) 341 ). 342 343systempredicate_option_type(Type, Arg) :- 344 var(Arg), 345 !, 346 add_attr(Arg, option_type(Type)). 347systempredicate_option_type(callable+_N, Arg) :- 348 !, 349 must_be(callable, Arg). 350systempredicate_option_type(list, Arg) :- 351 !, 352 must_be(list_or_partial_list, Arg). 353systempredicate_option_type(list(Type), Arg) :- 354 !, 355 must_be(list_or_partial_list(Type), Arg). 356systempredicate_option_type(Type, Arg) :- 357 must_be(Type, Arg). 358 359systempredicate_option_mode(_Mode, Arg) :- 360 var(Arg), 361 !. 362systempredicate_option_mode(Mode, Arg) :- 363 check_mode(Mode, Arg). 364 365check_mode(input, Arg) :- 366 ( nonvar(Arg) 367 -> true 368 ; instantiation_error(Arg) 369 ). 370check_mode(output, Arg) :- 371 ( var(Arg) 372 -> true 373 ; uninstantiation_error(Arg) 374 ). 375 376attr_unify_hook([], _). 377attr_unify_hook([H|T], Var) :- 378 option_hook(H, Var), 379 attr_unify_hook(T, Var). 380 381option_hook(option_type(Type), Value) :- 382 is_of_type(Type, Value). 383option_hook(option_mode(Mode), Value) :- 384 check_mode(Mode, Value). 385 386 387attribute_goals(Var) --> 388 { get_attr(Var, predicate_options, Attrs) }, 389 option_goals(Attrs, Var). 390 391option_goals([], _) --> []. 392option_goals([H|T], Var) --> 393 option_goal(H, Var), 394 option_goals(T, Var). 395 396option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)]. 397option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)]. 398 399 400 /******************************* 401 * OUTPUT DECLARATIONS * 402 *******************************/
412current_predicate_options(PI, Arg, Options) :- 413 define_predicate(PI), 414 setof(Arg-Option, 415 current_predicate_option_decl(PI, Arg, Option), 416 Options0), 417 group_pairs_by_key(Options0, Grouped), 418 member(Arg-Options, Grouped). 419 420current_predicate_option_decl(PI, Arg, Option) :- 421 current_predicate_option(PI, Arg, Option0), 422 Option0 =.. [Name|Values], 423 maplist(mode_and_type, Values, Types), 424 Option =.. [Name|Types]. 425 426mode_and_type(Value, ModeAndType) :- 427 copy_term(Value,_,Goals), 428 ( memberchk(predicate_option_mode(output, _), Goals) 429 -> ModeAndType = -(Type) 430 ; ModeAndType = Type 431 ), 432 ( memberchk(predicate_option_type(Type, _), Goals) 433 -> true 434 ; Type = any 435 ). 436 437define_predicate(PI) :- 438 ground(PI), 439 !, 440 PI = M:Name/Arity, 441 functor(Head, Name, Arity), 442 once(predicate_property(M:Head, _)). 443define_predicate(_).
451derived_predicate_options(PI, Arg, Options) :- 452 define_predicate(PI), 453 setof(Arg-Option, 454 derived_predicate_option(PI, Arg, Option), 455 Options0), 456 group_pairs_by_key(Options0, Grouped), 457 member(Arg-Options1, Grouped), 458 PI = M:_, 459 phrase(expand_pass_to_options(Options1, M), Options2), 460 sort(Options2, Options). 461 462derived_predicate_option(PI, Arg, Decl) :- 463 current_option_arg(PI, Arg, DefM), 464 PI = _:Name/Arity, 465 functor(Head, Name, Arity), 466 has_dynamic_option_decl(DefM), 467 ( has_static_option_decl(DefM), 468 DefM:'$pred_option'(Head, Decl, _, []) 469 ; DefM:'$dyn_pred_option'(Head, Decl, _, []) 470 ).
pass_to(PI,Arg) if PI does not refer to a
public predicate.477expand_pass_to_options([], _) --> []. 478expand_pass_to_options([H|T], M) --> 479 expand_pass_to(H, M), 480 expand_pass_to_options(T, M). 481 482expand_pass_to(pass_to(PI, Arg), Module) --> 483 { strip_module(Module:PI, M, Name/Arity), 484 functor(Head, Name, Arity), 485 \+ ( predicate_property(M:Head, exported) 486 ; predicate_property(M:Head, public) 487 ; M == system 488 ), 489 !, 490 current_predicate_options(M:Name/Arity, Arg, Options) 491 }, 492 list(Options). 493expand_pass_to(Option, _) --> 494 [Option]. 495 496list([]) --> []. 497list([H|T]) --> [H], list(T).
current_output stream.504derived_predicate_options(Module) :- 505 var(Module), 506 !, 507 forall(current_module(Module), 508 derived_predicate_options(Module)). 509derived_predicate_options(Module) :- 510 findall(predicate_options(Module:PI, Arg, Options), 511 ( derived_predicate_options(Module:PI, Arg, Options), 512 PI = Name/Arity, 513 functor(Head, Name, Arity), 514 ( predicate_property(Module:Head, exported) 515 -> true 516 ; predicate_property(Module:Head, public) 517 ) 518 ), 519 Decls0), 520 maplist(qualify_decl(Module), Decls0, Decls1), 521 sort(Decls1, Decls), 522 ( Decls \== [] 523 -> format('~N~n~n% Predicate option declarations for module ~q~n~n', 524 [Module]), 525 forall(member(Decl, Decls), 526 portray_clause((:-Decl))) 527 ; true 528 ). 529 530qualify_decl(M, 531 predicate_options(PI0, Arg, Options0), 532 predicate_options(PI1, Arg, Options1)) :- 533 qualify(PI0, M, PI1), 534 maplist(qualify_option(M), Options0, Options1). 535 536qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- 537 !, 538 qualify(PI0, M, PI1). 539qualify_option(_, Opt, Opt). 540 541qualify(M:Term, M, Term) :- !. 542qualify(QTerm, _, QTerm). 543 544 545 /******************************* 546 * CLEANUP * 547 *******************************/
553retractall_predicate_options :- 554 forall(retract(dyn_option_decl(_,M,_)), 555 abolish(M:'$dyn_pred_option'/4)). 556 557 558 /******************************* 559 * COMPILE-TIME CHECKER * 560 *******************************/ 561 562 563:- thread_local 564 new_decl/1.
580check_predicate_options :-
581 forall(current_module(Module),
582 check_predicate_options_module(Module)).594derive_predicate_options :- 595 derive_predicate_options(NewDecls), 596 ( NewDecls == [] 597 -> true 598 ; print_message(informational, check_options(new(NewDecls))), 599 new_decls(NewDecls), 600 derive_predicate_options 601 ). 602 603new_decls([]). 604new_decls([predicate_options(PI, A, O)|T]) :- 605 assert_predicate_options(PI, A, O, _), 606 new_decls(T). 607 608 609derive_predicate_options(NewDecls) :- 610 call_cleanup( 611 ( forall( 612 current_module(Module), 613 forall( 614 ( predicate_in_module(Module, PI), 615 PI = Name/Arity, 616 functor(Head, Name, Arity), 617 catch(Module:clause(Head, Body, Ref), _, fail) 618 ), 619 check_clause((Head:-Body), Module, Ref, decl))), 620 ( setof(Decl, retract(new_decl(Decl)), NewDecls) 621 -> true 622 ; NewDecls = [] 623 ) 624 ), 625 retractall(new_decl(_))). 626 627 628check_predicate_options_module(Module) :- 629 forall(predicate_in_module(Module, PI), 630 check_predicate_options(Module:PI)). 631 632predicate_in_module(Module, PI) :- 633 current_predicate(Module:PI), 634 PI = Name/Arity, 635 functor(Head, Name, Arity), 636 \+ predicate_property(Module:Head, imported_from(_)).
643check_predicate_options(Module:Name/Arity) :- 644 debug(predicate_options, 'Checking ~q', [Module:Name/Arity]), 645 functor(Head, Name, Arity), 646 forall(catch(Module:clause(Head, Body, Ref), _, fail), 647 check_clause((Head:-Body), Module, Ref, check)). 648 649 650 /******************************* 651 * RAW / ORDER-SENSITIVE * 652 *******************************/ 653 654:- thread_local 655 lint_finding/2. % Finding, ClauseRef
[Opt,...|Tail] is passed to a predicate that
resolves options with PL_scan_options() (rightmost wins, e.g.
open/4). The prepended options look like an override but are
defeated by a duplicate in Tail. Append the option or use
merge_options/3 instead.Spec is a module or a Module:Name/Arity.
681check_raw_option_access :- 682 raw_option_findings_(all, Findings), 683 report_lint_findings(Findings). 684 685check_raw_option_access(Spec) :- 686 raw_option_findings(Spec, Findings), 687 report_lint_findings(Findings).
695raw_option_findings(Spec, Findings) :- 696 ( Spec = M:Name/Arity, 697 atom(Name), integer(Arity) 698 -> raw_option_findings_(M:Name/Arity, Findings) 699 ; strip_module(Spec, _, Module), 700 raw_option_findings_(module(Module), Findings) 701 ). 702 703raw_option_findings_(What, Findings) :- 704 retractall(lint_finding(_,_)), 705 ( What == all 706 -> forall(current_module(Module), lint_module(Module)) 707 ; What = module(Module) 708 -> lint_module(Module) 709 ; lint_predicate(What) 710 ), 711 findall(F-Ref, retract(lint_finding(F, Ref)), Findings). 712 713lint_module(Module) :- 714 forall(predicate_in_module(Module, PI), 715 lint_predicate(Module:PI)). 716 717lint_predicate(Module:Name/Arity) :- 718 functor(Head, Name, Arity), 719 forall(catch(Module:clause(Head, Body, Ref), _, fail), 720 lint_clause(Module:Head, Body, Ref)). 721 722lint_clause(Module:Head, Body, Ref) :- 723 b_setval('$predopts_lint_clause', Ref), 724 \+ \+ ( seed_head_options(Module:Head), 725 catch(check_body(Body, Module, _, decl), _, true), % annotate 726 catch(check_body(Body, Module, _, lint), _, true) ). % report
734seed_head_options(Module:Head) :- 735 functor(Head, Name, Arity), 736 PI = Module:Name/Arity, 737 seed_head_options(1, Arity, PI, Head). 738 739seed_head_options(I, Arity, PI, Head) :- 740 ( I > Arity 741 -> true 742 ; ( once(current_option_arg(PI, I)), 743 arg(I, Head, QArg), 744 remove_qualifier(QArg, A), 745 var(A) 746 -> annotate(A, option_list_var(PI, I)) 747 ; true 748 ), 749 I2 is I+1, 750 seed_head_options(I2, Arity, PI, Head) 751 ). 752 753report_lint_findings(Findings) :- 754 forall(member(Finding-Ref, Findings), 755 print_message(informational, predopts_lint(Finding, Ref))). 756 757record_lint(Finding) :- 758 ( nb_current('$predopts_lint_clause', Ref) 759 -> true 760 ; Ref = (-) 761 ), 762 ( lint_finding(Finding, Ref) % avoid duplicates within a clause 763 -> true 764 ; assertz(lint_finding(Finding, Ref)) 765 ).
771raw_option_goal(memberchk(Opt, List), List, Opt) :- option_shaped(Opt). 772raw_option_goal(member(Opt, List), List, Opt) :- option_shaped(Opt). 773raw_option_goal(select(Opt, List, _), List, Opt) :- option_shaped(Opt). 774raw_option_goal(selectchk(Opt, List, _), List, Opt) :- option_shaped(Opt). 775 776option_shaped(Opt) :- 777 compound(Opt), 778 ( functor(Opt, _, 1) 779 ; Opt = (_=_) 780 ), 781 !. 782 783known_option_list(List) :- 784 var(List), 785 annotations(List, _).
796check_clause((Head:-Body), M, ClauseRef, Action) :-
797 !,
798 catch(check_body(Body, M, _, Action), E, true),
799 ( var(E)
800 -> option_decl(M:Head, Action)
801 ; ( clause_info(ClauseRef, File, TermPos, _NameOffset),
802 TermPos = term_position(_,_,_,_,[_,BodyPos]),
803 catch(check_body(Body, M, BodyPos, Action),
804 error(Formal, ArgPos), true),
805 compound(ArgPos),
806 arg(1, ArgPos, CharCount),
807 integer(CharCount)
808 -> Location = file_char_count(File, CharCount)
809 ; Location = clause(ClauseRef),
810 E = error(Formal, _)
811 ),
812 print_message(error, predicate_option_error(Formal, Location))
813 ).818:- multifile 819 prolog:called_by/4, % +Goal, +Module, +Context, -Called 820 prolog:called_by/2. % +Goal, -Called 821 822check_body(Var, _, _, _) :- 823 var(Var), 824 !. 825check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- 826 !, 827 check_body(G, M, Pos, Action). 828check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- 829 !, 830 check_body(A, M, PA, Action), 831 check_body(B, M, PB, Action). 832check_body((A;B), M, term_position(_,_,_,_,[PA,PB]), Action) :- 833 !, 834 \+ \+ check_body(A, M, PA, Action), 835 \+ \+ check_body(B, M, PB, Action). 836check_body((A->B), M, term_position(_,_,_,_,[PA,PB]), Action) :- 837 !, 838 check_body(A, M, PA, Action), 839 check_body(B, M, PB, Action). 840check_body((A*->B), M, term_position(_,_,_,_,[PA,PB]), Action) :- 841 !, 842 check_body(A, M, PA, Action), 843 check_body(B, M, PB, Action). 844check_body(A=B, _, _, _) :- % partial evaluation 845 unify_with_occurs_check(A,B), 846 !. 847check_body(Goal, M, _, lint) :- % Category A: raw option access 848 raw_option_goal(Goal, ListArg, Opt), 849 !, 850 ( known_option_list(ListArg) 851 -> record_lint(raw_option_access(M:Goal, Opt)) 852 ; true 853 ). 854check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :- 855 callable(Goal), 856 functor(Goal, Name, Arity), 857 ( '$get_predicate_attribute'(M:Goal, imported, DefM) 858 -> true 859 ; DefM = M 860 ), 861 ( eval_option_pred(DefM:Goal) 862 -> true 863 ; current_option_arg(DefM:Name/Arity, OptArg), 864 !, 865 arg(OptArg, Goal, Options), 866 nth1(OptArg, ArgPosList, ArgPos), 867 check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action) 868 ). 869check_body(Goal, M, _, Action) :- 870 ( ( predicate_property(M:Goal, imported_from(IM)) 871 -> true 872 ; IM = M 873 ), 874 prolog:called_by(Goal, IM, M, Called) 875 ; prolog:called_by(Goal, Called) 876 ), 877 !, 878 check_called_by(Called, M, Action). 879check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :- 880 '$get_predicate_attribute'(M:Meta, meta_predicate, Head), 881 !, 882 check_meta_args(1, Head, Meta, M, ArgPosList, Action). 883check_body(_, _, _, _). 884 885check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :- 886 arg(I, Head, AS), 887 !, 888 ( AS == 0 889 -> arg(I, Meta, MA), 890 check_body(MA, M, ArgPos, Action) 891 ; true 892 ), 893 succ(I, I2), 894 check_meta_args(I2, Head, Meta, M, ArgPosList, Action). 895check_meta_args(_,_,_,_, _, _).
901check_called_by([], _, _). 902check_called_by([H|T], M, Action) :- 903 ( H = G+N 904 -> ( extend(G, N, G2) 905 -> check_body(G2, M, _, Action) 906 ; true 907 ) 908 ; check_body(H, M, _, Action) 909 ), 910 check_called_by(T, M, Action). 911 912extend(Goal, N, GoalEx) :- 913 callable(Goal), 914 Goal =.. List, 915 length(Extra, N), 916 append(List, Extra, ListEx), 917 GoalEx =.. ListEx.
pass_to(PI, OptArg).927check_options(PI, OptArg, QOptions, ArgPos, lint) :- 928 !, 929 remove_qualifier(QOptions, Options), 930 ( is_list_or_partial_list(Options) 931 -> lint_prepend(PI, Options), 932 check_option_list(Options, PI, OptArg, Options, ArgPos, lint) 933 ; true % not analysable as a list; ignore 934 ). 935check_options(PI, OptArg, QOptions, ArgPos, Action) :- 936 debug(predicate_options, '\tChecking call to ~q', [PI]), 937 remove_qualifier(QOptions, Options), 938 must_be(list_or_partial_list, Options), 939 check_option_list(Options, PI, OptArg, Options, ArgPos, Action). 940 941is_list_or_partial_list(Term) :- 942 '$skip_list'(_, Term, Tail), 943 ( Tail == [] 944 -> true 945 ; var(Tail) 946 ).
955lint_prepend(PI, Options) :- 956 ( last_wins_option_pred(PI), 957 partial_prefix(Options, Prefix, Tail), 958 Prefix \== [], 959 var(Tail) 960 -> record_lint(prepend_override(PI, Prefix)) 961 ; true 962 ). 963 964partial_prefix(Var, [], Var) :- 965 var(Var), 966 !. 967partial_prefix([], [], []) :- !. 968partial_prefix([H|T], [H|PT], Tail) :- 969 partial_prefix(T, PT, Tail).
977last_wins_option_pred(M:Name/Arity) :- 978 functor(Head, Name, Arity), 979 predicate_property(M:Head, foreign). 980 981remove_qualifier(X, X) :- 982 var(X), 983 !. 984remove_qualifier(_:X, X) :- !. 985remove_qualifier(X, X). 986 987check_option_list(Var, PI, OptArg, _, _, _) :- 988 var(Var), 989 !, 990 annotate(Var, pass_to(PI, OptArg)). 991check_option_list([], _, _, _, _, _). 992check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :- 993 check_option(PI, OptArg, H, ArgPos, Action), 994 check_option_list(T, PI, OptArg, Options, ArgPos, Action). 995 996check_option(_, _, _, _, decl) :- !. 997check_option(_, _, _, _, lint) :- !. 998check_option(PI, OptArg, Opt, ArgPos, _) :- 999 catch(check_predicate_option(PI, OptArg, Opt), E, true), 1000 !, 1001 ( var(E) 1002 -> true 1003 ; E = error(Formal,_), 1004 throw(error(Formal,ArgPos)) 1005 ). 1006 1007 1008 /******************************* 1009 * ANNOTATIONS * 1010 *******************************/
1017annotate(Var, Term) :- 1018 ( get_attr(Var, predopts_analysis, Old) 1019 -> put_attr(Var, predopts_analysis, [Term|Old]) 1020 ; var(Var) 1021 -> put_attr(Var, predopts_analysis, [Term]) 1022 ; true 1023 ). 1024 1025annotations(Var, Annotations) :- 1026 get_attr(Var, predopts_analysis, Annotations). 1027 1028predopts_analysisattr_unify_hook(Opts, Value) :- 1029 get_attr(Value, predopts_analysis, Others), 1030 !, 1031 append(Opts, Others, All), 1032 put_attr(Value, predopts_analysis, All). 1033predopts_analysisattr_unify_hook(_, _). 1034 1035 1036 /******************************* 1037 * PARTIAL EVAL * 1038 *******************************/ 1039 1040eval_option_pred(swi_option:option(Opt, Options)) :- 1041 processes(Opt, Spec), 1042 annotate(Options, Spec). 1043eval_option_pred(swi_option:option(Opt, Options, _Default)) :- 1044 processes(Opt, Spec), 1045 annotate(Options, Spec). 1046eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :- 1047 ignore(unify_with_occurs_check(Rest, Options)), 1048 processes(Opt, Spec), 1049 annotate(Options, Spec). 1050eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :- 1051 ignore(unify_with_occurs_check(Rest, Options)), 1052 processes(Opt, Spec), 1053 annotate(Options, Spec). 1054eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :- 1055 remove_qualifier(QOptionsIn, OptionsIn), 1056 remove_qualifier(QOptionsOut, OptionsOut), 1057 ignore(unify_with_occurs_check(OptionsIn, OptionsOut)). 1058eval_option_pred(lists:append(A, B, C)) :- % C = A ++ B; both are options 1059 propagate_option_list(C, A), 1060 propagate_option_list(C, B). 1061eval_option_pred(swi_option:merge_options(New, Old, Merged)) :- 1062 propagate_option_list(Merged, New), 1063 propagate_option_list(Merged, Old). 1064 1065processes(Opt, Spec) :- 1066 compound(Opt), 1067 functor(Opt, OptName, 1), 1068 Spec =.. [OptName,any].
1077propagate_option_list(A, B) :- 1078 ( annotated_var(A, Ann) 1079 -> copy_annotations(B, Ann) 1080 ; annotated_var(B, Ann) 1081 -> copy_annotations(A, Ann) 1082 ; true 1083 ). 1084 1085annotated_var(V, Ann) :- 1086 var(V), 1087 annotations(V, Ann). 1088 1089copy_annotations(V, Ann) :- 1090 ( var(V) 1091 -> copy_annotations_(Ann, V) 1092 ; true 1093 ). 1094 1095copy_annotations_([], _). 1096copy_annotations_([A|T], V) :- 1097 annotate(V, A), 1098 copy_annotations_(T, V). 1099 1100 1101 /******************************* 1102 * NEW DECLARTIONS * 1103 *******************************/
1114option_decl(_, check) :- !. 1115option_decl(M:_, _) :- 1116 system_module(M), 1117 !. 1118option_decl(M:_, _) :- 1119 has_static_option_decl(M), 1120 !. 1121option_decl(M:Head, _) :- 1122 compound(Head), 1123 arg(AP, Head, QA), 1124 remove_qualifier(QA, A), 1125 annotations(A, Annotations0), 1126 functor(Head, Name, Arity), 1127 PI = M:Name/Arity, 1128 delete(Annotations0, pass_to(PI,AP), Annotations), 1129 Annotations \== [], 1130 Decl = predicate_options(PI, AP, Annotations), 1131 ( new_decl(Decl) 1132 -> true 1133 ; assert_predicate_options(M:Name/Arity, AP, Annotations, false) 1134 -> true 1135 ; assertz(new_decl(Decl)), 1136 debug(predicate_options(decl), '~q', [Decl]) 1137 ), 1138 fail. 1139option_decl(_, _). 1140 1141system_module(system) :- !. 1142system_module(Module) :- 1143 sub_atom(Module, 0, _, _, $). 1144 1145 1146 /******************************* 1147 * MISC * 1148 *******************************/ 1149 1150canonical_pi(M:Name//Arity, M:Name/PArity) :- 1151 integer(Arity), 1152 PArity is Arity+2. 1153canonical_pi(PI, PI).
1163resolve_module(Module:Name/Arity, DefM:Name/Arity) :- 1164 functor(Head, Name, Arity), 1165 ( '$get_predicate_attribute'(Module:Head, imported, M) 1166 -> DefM = M 1167 ; DefM = Module 1168 ). 1169 1170 1171 /******************************* 1172 * MESSAGES * 1173 *******************************/ 1174:- multifile 1175 prolog:message//1. 1176 1177prologmessage(predicate_option_error(Formal, Location)) --> 1178 error_location(Location), 1179 '$messages':term_message(Formal). % TBD: clean interface 1180prologmessage(check_options(new(Decls))) --> 1181 [ 'Inferred declarations:'-[], nl ], 1182 new_decls(Decls). 1183prologmessage(predopts_lint(Finding, Ref)) --> 1184 lint_location(Ref), 1185 lint_message(Finding). 1186 1187lint_location(Ref) --> 1188 { Ref \== (-), 1189 clause_property(Ref, file(File)), 1190 clause_property(Ref, line_count(Line)) 1191 }, 1192 !, 1193 [ url(File:Line), ': ' ]. 1194lint_location(_) --> []. 1195 1196lint_message(raw_option_access(PI, Opt)) --> 1197 [ 'raw option access ~q on an option list; prefer option/2'-[Opt], 1198 nl, ' in ~q'-[PI] ]. 1199lint_message(prepend_override(PI, Prefix)) --> 1200 [ 'option(s) ~q prepended to rightmost-wins predicate ~q;'-[Prefix, PI], 1201 nl, 1202 ' a duplicate in the list tail overrides them - '-[], 1203 'append or use merge_options/3'-[] ]. 1204 1205error_location(file_char_count(File, CharPos)) --> 1206 { filepos_line(File, CharPos, Line, LinePos) }, 1207 [ url(File:Line:LinePos), ': ' ]. 1208error_location(clause(ClauseRef)) --> 1209 { clause_property(ClauseRef, file(File)), 1210 clause_property(ClauseRef, line_count(Line)) 1211 }, 1212 !, 1213 [ url(File:Line), ': ' ]. 1214error_location(clause(ClauseRef)) --> 1215 [ 'Clause ~q: '-[ClauseRef] ]. 1216 1217filepos_line(File, CharPos, Line, LinePos) :- 1218 setup_call_cleanup( 1219 ( open(File, read, In), 1220 open_null_stream(Out) 1221 ), 1222 ( Skip is CharPos-1, 1223 copy_stream_data(In, Out, Skip), 1224 stream_property(In, position(Pos)), 1225 stream_position_data(line_count, Pos, Line), 1226 stream_position_data(line_position, Pos, LinePos) 1227 ), 1228 ( close(Out), 1229 close(In) 1230 )). 1231 1232new_decls([]) --> []. 1233new_decls([H|T]) --> 1234 [ ' :- ~q'-[H], nl ], 1235 new_decls(T). 1236 1237 1238 /******************************* 1239 * SYSTEM DECLARATIONS * 1240 *******************************/
Access and analyse predicate options
This module provides the developers interface for the directive predicate_options/3. This directive allows us to specify that, e.g., open/4 processes options using the 4th argument and supports the option
typeusing the valuestextandbinary. Declaring options that are processed allows for more reliable handling of predicate options and simplifies porting applications. This library provides the following functionality:Below, we describe some use-cases.
lock(write), it may do so using the directive below. This directive raises an exception when loaded on a Prolog implementation that does not support this option.