Changeset 4524 for trunk/compiler

Timestamp:

10/20/08 19:20:18 (3 months ago)

Author:

pmoura

Message:

Added an optimization and security compiler option, "complements", that allows objects to be compiled with support for complementing categories either enabled or disabled. The default value (set in the config files) is "off" (disabled).

Added an optimization and security compiler option, "dynamic_declarations", that allows objects to be compiled with support for dynamic declaration of predicates (using the built-in database methods asserta/1 and assertz/1) either enabled or disabled. The default value (set in the config files) is "off" (disabled).

Updated the "complements" example to use the new "complements" compiler option. Update the "dynpred" example to use the new "dynamic_declarations" compiler option.

Files:

• trunk/compiler/logtalk.pl (modified) (18 diffs)

trunk/compiler/logtalk.pl

@@ -2237 +2237 @@
     '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType),
     !,
-    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope),
+    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope, Obj::asserta((Head:-Body)), Sender),
     (   (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) ->
         (   (\+ \+ Scope = TestScope; Sender = SCtn) ->
@@ -2271 +2271 @@
     '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType),
     !,
-    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope),
+    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope, Obj::asserta(Head), Sender),
     (   (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) ->
         (   (\+ \+ Scope = TestScope; Sender = SCtn)  ->
@@ -2339 +2339 @@
     '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType),
     !,
-    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope),
+    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope, Obj::assertz((Head:-Body)), Sender),
     (   (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) ->
         (   (\+ \+ Scope = TestScope; Sender = SCtn)  ->
@@ -2373 +2373 @@
     '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType),
     !,
-    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope),
+    '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope, Obj::assertz(Head), Sender),
     (   (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) ->
         (   (\+ \+ Scope = TestScope; Sender = SCtn)  ->
@@ -2401 +2401 @@
 % get or set (if doesn't exist) the declaration for an asserted predicate
 
-'$lgt_assert_pred_dcl'(Dcl, DDcl, Pred, Scope, Type, Meta, SCtn, DclScope) :-
+'$lgt_assert_pred_dcl'(Dcl, DDcl, Pred, Scope, Type, Meta, SCtn, DclScope, Goal, Sender) :-
     (   call_with_args(Dcl, Pred, Scope, Type, Meta, _, _, SCtn, _) ->
         true
     ;   % no previous predicate declaration:
-        '$lgt_assert_ddcl_clause'(DDcl, Pred, DclScope),
-        (Scope, Type, Meta) = (DclScope, (dynamic), no)
+        (   DDcl == nil ->
+            % object doesn't supports dynamic declaration of new predicates:
+            throw(error(permission_error(modify, object_protocol, Pred), Goal, Sender))
+        ;   '$lgt_assert_ddcl_clause'(DDcl, Pred, DclScope),
+            (Scope, Type, Meta) = (DclScope, (dynamic), no)
+        )
     ).
 
@@ -9418 +9422 @@
     assertz('$lgt_pp_directive_'(dynamic(IDcl/8))),
     assertz('$lgt_pp_directive_'(dynamic(IDef/6))),
-    assertz('$lgt_pp_directive_'(dynamic(DDcl/2))),
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        assertz('$lgt_pp_directive_'(dynamic(DDcl/2)))
+    ;   true
+    ),
     assertz('$lgt_pp_directive_'(dynamic(DDef/5))),
     assertz('$lgt_pp_directive_'(dynamic(Rnm/3))),
@@ -9438 +9445 @@
 '$lgt_gen_static_object_dynamic_directives' :-
     '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, DDcl, DDef, _, _),
-    assertz('$lgt_pp_directive_'(dynamic(DDcl/2))),
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        assertz('$lgt_pp_directive_'(dynamic(DDcl/2)))
+    ;   true
+    ),
     assertz('$lgt_pp_directive_'(dynamic(DDef/5))),
     '$lgt_pp_dynamic_'(Functor, Arity),
@@ -9784 +9794 @@
     BodyDcl =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized],
     assertz('$lgt_pp_dcl_'((HeadDcl:-BodyDcl))),
-    HeadDDcl =.. [Dcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
-    BodyDDcl =.. [DDcl, Pred, Scope],
-    assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))).
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        HeadDDcl =.. [Dcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
+        BodyDDcl =.. [DDcl, Pred, Scope],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl)))
+    ;   true
+    ).
 
 '$lgt_gen_prototype_linking_dcl_clauses'(false) :-
     '$lgt_pp_object_'(Obj, _, Dcl, _, _, _, _, DDcl, _, _, _) ->
-    HeadDDcl =.. [Dcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
-    BodyDDcl =.. [DDcl, Pred, Scope],
-    assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))).
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        HeadDDcl =.. [Dcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
+        BodyDDcl =.. [DDcl, Pred, Scope],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl)))
+    ;   HeadDDcl =.. [Dcl, _, _, _, _, _, _, _, _],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-fail)))
+    ).
 
 
@@ -9841 +9858 @@
 
 '$lgt_gen_prototype_imports_dcl_clauses' :-
-    '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, _, _) ->
-    Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
-    Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
-    assertz('$lgt_pp_dcl_'((Head:-Lookup))).
+    (   '$lgt_compiler_flag'(complements, on) ->
+        '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, _, _) ->
+        Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
+        Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
+        assertz('$lgt_pp_dcl_'((Head:-Lookup)))
+    ;   true
+    ).
 
 
@@ -9916 +9936 @@
 
 '$lgt_gen_prototype_imports_def_clauses' :-
-    '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
-    Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
-    Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
-    assertz('$lgt_pp_fdef_'((Head:-Lookup))).
+    (   '$lgt_compiler_flag'(complements, on) ->
+        '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
+        Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
+        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        assertz('$lgt_pp_fdef_'((Head:-Lookup)))
+    ;   true
+    ).
 
 
@@ -10032 +10055 @@
     BodyDcl =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized],
     assertz('$lgt_pp_dcl_'((HeadDcl:-BodyDcl))),
-    HeadDDcl =.. [IDcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
-    BodyDDcl =.. [DDcl, Pred, Scope],
-    assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))).
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        HeadDDcl =.. [IDcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
+        BodyDDcl =.. [DDcl, Pred, Scope],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl)))
+    ;   true
+    ).
 
 '$lgt_gen_ic_linking_idcl_clauses'(false) :-
     '$lgt_pp_object_'(Obj, _, _, _, _, IDcl, _, DDcl, _, _, _) ->
-    HeadDDcl =.. [IDcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
-    BodyDDcl =.. [DDcl, Pred, Scope],
-    assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))).
+    (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+        HeadDDcl =.. [IDcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj],
+        BodyDDcl =.. [DDcl, Pred, Scope],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl)))
+    ;   HeadDDcl =.. [IDcl, _, _, _, _, _, _, _, _],
+        assertz('$lgt_pp_dcl_'((HeadDDcl:-fail)))
+    ).
 
 
@@ -10089 +10119 @@
 
 '$lgt_gen_ic_category_idcl_clauses' :-
-    '$lgt_pp_object_'(Obj, _, _, _, _, OIDcl, _, _, _, _, _) ->
-    Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
-    Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
-    assertz('$lgt_pp_dcl_'((Head:-Lookup))).
+    (   '$lgt_compiler_flag'(complements, on) ->
+        '$lgt_pp_object_'(Obj, _, _, _, _, OIDcl, _, _, _, _, _) ->
+        Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
+        Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
+        assertz('$lgt_pp_dcl_'((Head:-Lookup)))
+    ;   true
+    ).
 
 
@@ -10165 +10198 @@
 
 '$lgt_gen_ic_imports_def_clauses' :-
-    '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
-    Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
-    Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
-    assertz('$lgt_pp_fdef_'((Head:-Lookup))).
+    (   '$lgt_compiler_flag'(complements, on) ->
+        '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
+        Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
+        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        assertz('$lgt_pp_fdef_'((Head:-Lookup)))
+    ;   true
+    ).
 
 
@@ -10228 +10264 @@
 
 '$lgt_gen_ic_category_idef_clauses' :-
-    '$lgt_pp_object_'(Obj, _, _, _, _, _, OIDef, _, _, _, _) ->
-    Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctn],
-    Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
-    assertz('$lgt_pp_fdef_'((Head:-Lookup))).
+    (   '$lgt_compiler_flag'(complements, on) ->
+        '$lgt_pp_object_'(Obj, _, _, _, _, _, OIDef, _, _, _, _) ->
+        Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctn],
+        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        assertz('$lgt_pp_fdef_'((Head:-Lookup)))
+    ;   true
+    ).
 
 
@@ -11023 +11062 @@
         atom_concat(Prefix, '_idcl', IDcl),
         atom_concat(Prefix, '_idef', IDef),
-        atom_concat(Prefix, '_ddcl', DDcl),
+        (   '$lgt_compiler_flag'(dynamic_declarations, on) ->
+            atom_concat(Prefix, '_ddcl', DDcl)
+        ;   DDcl = nil
+        ),
         atom_concat(Prefix, '_ddef', DDef),
         atom_concat(Prefix, '_alias', Rnm)
@@ -11698 +11740 @@
 '$lgt_valid_flag'(tmpdir).
 '$lgt_valid_flag'(hook).
+'$lgt_valid_flag'(complements).
+'$lgt_valid_flag'(dynamic_declarations).
 '$lgt_valid_flag'(events).
 '$lgt_valid_flag'(code_prefix).
@@ -11779 +11823 @@
 '$lgt_valid_flag_value'(debug, on) :- !.
 '$lgt_valid_flag_value'(debug, off) :- !.
+
+'$lgt_valid_flag_value'(complements, on) :- !.
+'$lgt_valid_flag_value'(complements, off) :- !.
+
+'$lgt_valid_flag_value'(dynamic_declarations, on) :- !.
+'$lgt_valid_flag_value'(dynamic_declarations, off) :- !.
 
 '$lgt_valid_flag_value'(events, on) :- !.
@@ -13851 +13901 @@
     '$lgt_default_flag'(debug, Debug),
     write('  Compile entities in debug mode (debug):                     '), writeq(Debug), nl,
+    '$lgt_default_flag'(complements, Complements),
+    write('  Complementing category support (complements):               '), write(Complements), nl,
+    '$lgt_default_flag'(dynamic_declarations, DynamicDeclarations),
+    write('  Dynamic declarations support (dynamic_declarations):        '), write(DynamicDeclarations), nl,
     '$lgt_default_flag'(events, Events),
     write('  Compile messages with event support (events):               '), write(Events), nl,