/** * A revised version of the pre-0.9.5 dynamic-rules-tools * Now using the new hash-tables, and implementing scoping * as a 'stack' of hashtables. * * @todo reuse ChangeSets when applying the fix point operator * @todo provide constructs to handle do-while-like structures * issues: - a break inside the do-while * - propagation in the first run could be wrong * @todo investigate if BreakCS and SplitPos need (rulename, label) * or if rulename + scoping of DR_BREAK suffices * @todo when we have a fork-and-merge, after the two change sets * are merged, one of them is lost and not discarded. This needs * to be fixed (unless the garbage collector takes care of this) */ module lang/dynamic-rules imports collection/hash-table/common strategy/traversal/simple collection/set/indexed system/io/file signature constructors RuleScope : IndexedSet * Hashtable -> RuleScope ChangeSet : IndexedSet * IndexedSet * Hashtable -> RuleScope Label : String -> Label SplitPos : String * String -> SplitPos BreakCS : String * String -> BreakCS ContinueCS : String * String -> ContinueCS IgnoreB : String -> IgnoreB IgnoreC : String -> IgnoreC Catch : String * String -> Catch Finally : String -> Finally TryBlock : Int * String * [Catch] * Finally -> TryBlock Structure : String -> Structure IgnoreT : String -> IgnoreT ThrowCS : String * String -> ThrowCS ExceptionCS : String * String -> ExceptionCS /** * Currently active rule set */ strategies /** * Retrieve the primitive dynamic rules hashtable. */ dr-rule-sets-hashtable = prim("SSL_dynamic_rules_hashtable") /** * @type _ -> List(RuleScope) */ dr-get-rule-set(|name) = prim("SSL_hashtable_get", <dr-rule-sets-hashtable>, name) <+ dr-new-rule-set ; dr-set-rule-set(|name) dr-set-rule-set(|name) = where( ?ruleset ; prim("SSL_hashtable_put", <dr-rule-sets-hashtable>, name, ruleset) ) dr-switch-rule-set(|name) = where(dr-get-rule-set(|name) => rs) ; dr-set-rule-set(|name) ; !rs // Note: the storing the currently active rule set should // be done in a global variable at the C level (probably). // We should abstract from that as much as possible and // just consider the rule-set as a value that can be // changed. Manipulating the content should be the same // for any storage solution we use. // a question to consider: should operations be relative // to the current rule-set or should we make a set of // operations that work on a named rule-set and deal // with the pointer change at a higer-level? // Well, we can actually have two APIs, one working on // the implicit global rule-set, and the other working // on the explicit representation. // whose responsibility is it to initialize the outer scope? // In the definition above an initial hashtable is created // when no rule-set was available yet. strategies // high-level API with implicit rule set // Note that the compiler can generate a specifically named // rule for each of the strategies in this API, e.g, // add-rule-name, lookup-rule-name, etc. Then the compiler // can specialize the applications. dr-scope(s | name) = dr-begin-scope(|name) ; (s < dr-end-scope(|name) + dr-end-scope(|name); fail) /** * @type t -> t */ dr-begin-scope(|name) = where( dr-get-rule-set(|name) ; dr-add-scope ; dr-set-rule-set(|name) ) /** * @type t -> t */ dr-end-scope(|name) = where( dr-get-rule-set(|name) ; dr-leave-scope ; dr-set-rule-set(|name) ) dr-scopes(s | names) = dr-begin-scopes(|names) ; (s < dr-end-scopes(|names) + dr-end-scopes(|names); fail) /** * @type t -> t */ dr-begin-scopes(|names) = where( !names ; map({?name ; dr-get-rule-set(|name) ; dr-add-scope ; dr-set-rule-set(|name)}) ) /** * @type t -> t */ dr-end-scopes(|names) = where( !names ; map({?name ; dr-get-rule-set(|name) ; dr-leave-scope ; dr-set-rule-set(|name)}) ) /** * @type t -> t */ dr-start-change-set(|name) = where( dr-get-rule-set(|name) ; dr-start-change-set ; dr-set-rule-set(|name) ) /** * @type t -> t */ dr-commit-change-set(|name) = where( dr-get-rule-set(|name) ; dr-commit-change-set ; dr-set-rule-set(|name) ) /** * @type t -> t */ dr-discard-change-set(|name) = where( dr-get-rule-set(|name) ; dr-discard-change-set ; dr-set-rule-set(|name) ) /** * @type t -> t */ dr-label-scope(|name, label) = where( dr-get-rule-set(|name) ; dr-label-scope(|label) ; dr-set-rule-set(|name) ) /** * Get all scope labels ordered from inner, most recent, to outer, oldest. */ dr-get-scope-labels(|name) = dr-get-rule-set(|name) ; dr-get-scope-labels /** * Get the first scope label for which s succeeds starting with the * inner, most recent, scope. */ dr-get-first-scope-label(s|name) = dr-get-rule-set(|name) ; dr-get-first-scope-label(s) strategies /** * Apply s in a state where the current dynamic rules for name are ignored. * * @param strategy to apply (a -> b) * @param name of the dynamic rules (String) * @type a -> b */ dr-ignore-state(s|name) = where( dr-new-rule-set ; dr-switch-rule-set(|name) => rs ) ; s ; where(<dr-set-rule-set(|name)> rs) /** * Apply s in a state where the current dynamic rules for names are ignored. * * @param strategy to apply (a -> b) * @param names of the dynamic rules (List(String)) * @type a -> b */ dr-ignore-states(s|names) = where( <map(dr-new-rule-set)> names ; zip(dr-switch-rule-set | names) => rss ) ; s ; where(<zip(dr-set-rule-set | names)> rss) strategies dr-lookup-rule(|name, key) = dr-get-rule-set(|name) ; dr-lookup-rule(|key) dr-lookup-all-rules(|name, key) = dr-get-rule-set(|name) ; dr-lookup-all-rules(|key) dr-lookup-rule-pointer(|name, key) = dr-get-rule-set(|name) ; dr-lookup-rule-pointer(|key) dr-all-keys(|name) = dr-get-rule-set(|name) ; dr-all-keys(|[], <new-iset>) dr-set-rule(|name, key, value) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set(|key, [value]) ; dr-set-rule-set(|name) ) dr-set-rule(|name, label, key, value) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set(|label, key, [value]) ; dr-set-rule-set(|name) ) dr-set-rule-vis(|name, label, key, value) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set-vis(|label, key, [value]) ; dr-set-rule-set(|name) ) dr-set-rules-vis(|name, label, key, values) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set-vis(|label, key, values) ; dr-set-rule-set(|name) ) dr-undefine-rule(|name, key) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set(|key, []) ; dr-set-rule-set(|name) ) dr-undefine-rule(|name, label, key) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set(|label, key, []) ; dr-set-rule-set(|name) ) dr-undefine-rule-vis(|name, label, key) = where( dr-get-rule-set(|name) ; dr-set-in-rule-set-vis(|label, key, []) ; dr-set-rule-set(|name) ) dr-add-rule(|name, key, value) = where( dr-get-rule-set(|name) ; dr-add-to-rule-set(|key, value) ; dr-set-rule-set(|name) ) dr-add-rule(|name, label, key, value) = where( dr-get-rule-set(|name) ; dr-add-to-rule-set(|label, key, value) ; dr-set-rule-set(|name) ) dr-add-rule-vis(|name, label, key, value) = where( dr-get-rule-set(|name) ; dr-add-to-rule-set-vis(|label, key, value) ; dr-set-rule-set(|name) ) /** * Intersect live rule-set with given rule set changing the live rule set. */ dr-intersect-with(|name) = <dr-intersect-rule-sets>(<dr-get-rule-set(|name)>, <id>) ; dr-set-rule-set(|name) /** * Intersect live rule-set with given rule set changing both. */ dr-intersect-symm(|name) = <dr-intersect-rule-sets-symm>(<dr-get-rule-set(|name)>, <id>) ; dr-set-rule-set(|name) /** * Merge live rule-set with given rule set using union changing the live rule set. */ dr-union-with(|name) = <dr-union-rule-sets>(<dr-get-rule-set(|name)>, <id>) ; dr-set-rule-set(|name) /** * Merge live rule-set with give rule set using union changing both. */ dr-union-symm(|name) = // <dr-union-rule-sets-symm>(<id>, <dr-get-rule-set(|name)>) <dr-union-rule-sets-symm>(<dr-get-rule-set(|name)>, <id>) ; dr-set-rule-set(|name) /** * Left choice with dynamic rule roll-back in case s1 fails. */ dr-left-choice(s1,s2|rulenames) = where(<map(dr-start-change-set(|<id>))> rulenames) ; s1 < where(<map(dr-commit-change-set(|<id>))> rulenames) + where(<map(dr-discard-change-set(|<id>))> rulenames) ; s2 /** * Low-level API working directly on rule-set. */ strategies // debugging dr-save-rule-set = alltd(hashtable-getlist) strategies // scope // a rule-set is represented by a list of (label list, hash-table) pairs dr-new-scope = !RuleScope(<new-iset; iset-add(|())>, <new-hashtable>) dr-new-rule-set = ![<dr-new-scope>] dr-add-scope = ![<dr-new-scope> | <id>] dr-destroy-scope = RuleScope(iset-destroy, hashtable-destroy) dr-leave-scope : [scope | scopes] -> scopes where <dr-destroy-scope> scope dr-get-inner-scope : [scope | scopes] -> scope dr-label-scope(|label) = [ RuleScope(iset-add(|label), id) + ChangeSet(iset-add(|label), id, id) | id] // todo: distinction between rulescope and changeset necessary here or not?? // [RuleScope(labels, tbl) | scopes] -> [RuleScope([label | labels], tbl) | scopes] dr-get-scope-labels = mapconcat(?RuleScope(<iset-elements>,_) + ?ChangeSet(<iset-elements>,_,_)) /** * Get the first scope label for which s succeeds. */ dr-get-first-scope-label(s) = fetch-elem(?RuleScope(<iset-elements; fetch-elem(s)>,_) + ?ChangeSet(<iset-elements; fetch-elem(s)>,_,_)) strategies // change sets dr-new-change-set = !ChangeSet(<new-iset>, <new-iset>, <new-hashtable>) dr-start-change-set = ![<dr-new-change-set> | <id>] dr-destroy-change-set = ChangeSet(iset-destroy, iset-destroy, dr-destroy-and-unmark) dr-destroy-and-unmark = ?Hashtable(csid) ; hashtable-destroy ; try( <DR_BREAK>IgnoreB(csid) => labelb ; rules(DR_BREAK.labelb :- IgnoreB(csid)) ) ; try( <DR_BREAK>IgnoreC(csid) => labelc ; rules(DR_BREAK.labelc :- IgnoreC(csid)) ) ; try( <DR_EXCEPTION>IgnoreT(csid) ; rules(DR_EXCEPTION :- IgnoreT(csid)) ) dr-clone-change-set = ?ChangeSet(labels1, rmset1, tbl1) ; dr-new-change-set => cs@ChangeSet(labels2, rmset2, tbl2) ; <iset-addlist(|<iset-elements>labels1)>labels2 ; <iset-addlist(|<iset-elements>rmset1)>rmset2 ; <hashtable-keys>tbl1 ; map({key : ?key; <hashtable-put(|key, <hashtable-get(|key)>tbl1)>tbl2}) ; !cs dr-commit-change-set = dr-commit-change-set(id) /** * The strategy destroy indicates whether the change * set should also be destroyed after the commmit. */ dr-commit-change-set(destroy) : [cs@ChangeSet(labelset, rmset, tbl@Hashtable(csid)) | rs] -> rs'' where <hashtable-keys> tbl ; foldr(<dr-commit-labels(|labelset)> rs , dr-apply-change(|tbl)) => rs' ; <iset-elements> rmset ; foldr(!rs', dr-apply-removal) => rs'' ; try( destroy ; <DR_BREAK>IgnoreB(csid) => labelb ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextb)))>rs'' ; dr-define-ignoreB(|csidnextb, labelb) <+ fatal-err(|"dr-break was called outside of a fix and merge operator or a dr-label call")) ) ; try( destroy ; <DR_BREAK>IgnoreC(csid) => labelc ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextc)))>rs'' ; dr-define-ignoreC(|csidnextc, labelc) <+ fatal-err(|"dr-continue was called outside of a fix and merge operator call")) ) ; try( destroy ; <DR_EXCEPTION>IgnoreT(csid) ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextt)))>rs'' ; dr-define-ignoreT(|csidnextt) <+ fatal-err(|"dr-throw was not called in the proper exception handling context")) ) ; try(destroy; <dr-destroy-change-set> cs) dr-discard-change-set : [cs@ChangeSet(_, _, _) | rs] -> rs where <dr-destroy-change-set> cs dr-commit-labels(|labelset) = [ ChangeSet(iset-union(|labelset), id, id) + RuleScope(iset-union(|labelset), id) | id] /** * commit to ruleset is finding the first ChangeSet (any) *or* the first * RuleScope that has the appropriate scopeid (i.e. hashtable pointer) * and setting the key-value into it */ dr-apply-change(|tbl) : (key1@(scpid, key), rs) -> <dr-commit-to-rule-set(|scpid, key, <hashtable-get(|key1)> tbl)> rs dr-commit-to-rule-set(|scpid, key, value) = dr-commit-to-change-set(|scpid, key, value) <+ dr-commit-to-rule-scope(|scpid, key, value) dr-commit-to-change-set(|scpid, key, value) = ?[ChangeSet(_, rmset, tbl) | rs] ; where( (<dr-lookup-rule-in-scope(|key, scpid)>rs => value < <hashtable-remove(|(scpid, key))>tbl + <hashtable-put(|(scpid, key), value)>tbl) ; <iset-remove(|(scpid, key))>rmset ) dr-commit-to-rule-scope(|scpid, key, value) = ?[RuleScope(_, tbl@Hashtable(scpid)) | rs] ; where(<hashtable-put(|key, value)>tbl) <+ [RuleScope(id, id) | dr-commit-to-rule-set(|scpid, key, value) ] /* * the old implementation (for reference) * dr-commit-to-rule-set(|scpid, key, value) = fetch( dr-commit-to-change-set(|scpid, key, value) + dr-commit-to-rule-scope(|scpid, key, value)) dr-commit-to-change-set(|scpid, key, value) = ?ChangeSet(_, _, tbl) ; where(<hashtable-put(|(scpid, key), value)> tbl) dr-commit-to-rule-scope(|scpid, key, value) = ?RuleScope(_,tbl@Hashtable(scpid)) ; where(<hashtable-put(|key, value)> tbl) */ dr-apply-removal : (key1@(scpid, key), rs) -> <dr-remove-from-rule-set(|scpid, key)> rs dr-remove-from-rule-set(|scpid, key) = fetch( dr-remove-from-change-set(|scpid, key) + dr-remove-from-rule-scope(|scpid, key)) dr-remove-from-change-set(|scpid, key) = ChangeSet(id, iset-add(|(scpid, key)), ?tbl) ; where(<hashtable-remove(|(scpid, key))> tbl) dr-remove-from-rule-scope(|scpid, key) = ?RuleScope(_,tbl@Hashtable(scpid)) ; where(<hashtable-remove(|key)> tbl) strategies // looking up /** * Fetch the most recent definition for key. */ // The "removed" parameter is now a list, which allows duplicates // to be added. This is not wrong, but it is marginally inefficient. // We actually need set-like behavior. Indexed sets, however, are // not an option because of the check of whether or not "removed" // contains key' in function look2. Since look2 is called later on, // when a RuleScope is reached, "removed" will potentially contain // some extra elements which should not be considered. This is the // case because of the in-place update of indexed sets. dr-lookup-rule(|key) = dr-lookup-rule(fail | key, []) dr-lookup-rule(look | key, removed) = ?[RuleScope(_, tbl@Hashtable(hptr)) | rs] ; (<look>(hptr, key) <+ <not(fetch(?(hptr, key)))> removed ; <hashtable-get(|key)> tbl <+ <dr-lookup-rule(look | key, removed)> rs) dr-lookup-rule(look1 | key, removed) = ?[ChangeSet(_, rmset, tbl) | rs] ; let look2 = look1 <+ {key': ?key' ; <not(fetch(?key'))> removed ; <hashtable-get(|key')> tbl } in <iset-elements> rmset ; filter(?(_, key)) => keys ; <dr-lookup-rule(look2 | key, <conc>(keys, removed))> rs end /** * Version of dr-lookup-rule that looks for definition of a key * in a particular scope. The expected scope id (scpid) is the * pointer to the hashtable of a rule scope and is usually * identified by means of a label, i.e., a label indicates the * rule scope and the rule scope has a unique scope id. */ dr-lookup-rule-in-scope(|key, scpid) = dr-lookup-rule-in-scope-rs(|key, scpid) <+ dr-lookup-rule-in-scope-cs(|key, scpid) dr-lookup-rule-in-scope-rs(|key, scpid) = ?[RuleScope(_, tbl@Hashtable(scpid)) | rs] // if this is the right scope, < <hashtable-get(|key)>tbl // then check for key + (?[RuleScope(_, _) | rs] // else recurse ; <dr-lookup-rule-in-scope(|key, scpid)>rs) dr-lookup-rule-in-scope-cs(|key, scpid) = ?[ChangeSet(_, rmset, tbl) | rs] ; (<iset-contains(|(scpid, key))>rmset < fail // key is marked for removal, so // in effect it is not defined + (<hashtable-get(|(scpid, key))>tbl <+ <dr-lookup-rule-in-scope(|key, scpid)>rs)) /** * Fetch the most recent definition for key and return a pointer * to the table that defines it. */ dr-lookup-rule-pointer(|key) = dr-lookup-rule-pointer(fail | key, []) dr-lookup-rule-pointer(look | key, removed) = ?[RuleScope(_, tbl@Hashtable(hptr)) | rs] ; (<look>(hptr, key) <+ <not(fetch(?(hptr, key)))> removed ; <hashtable-get(|key)> tbl ; !(<id>, key, tbl) <+ <dr-lookup-rule-pointer(look | key, removed)> rs) dr-lookup-rule-pointer(look1 | key, removed) = ?[ChangeSet(_, rmset, tbl) | rs] ; let look2 = look1 <+ {key': ?key' ; <not(fetch(?key'))> removed ; <hashtable-get(|key'); !(<id>, key', tbl)> tbl } in <iset-elements> rmset ; filter(?(_, key)) => keys ; <dr-lookup-rule-pointer(look2 | key, <conc>(keys, removed))> rs end /** * Fetch all definitions for key. */ dr-lookup-all-rules(|key) = dr-lookup-all-rules(fail | key, []) dr-lookup-all-rules(look | key, removed) = ?[RuleScope(_, tbl@Hashtable(hptr)) | rs] ; <conc>(<<look>(hptr, key) <+ <not(fetch(?(hptr, key)))> removed ; <hashtable-get(|key)> tbl <+ ![]> ,<dr-lookup-all-rules(look | key, removed) <+ ![]> rs) dr-lookup-all-rules(look1 | key, removed) = ?[ChangeSet(_, rmset, tbl) | rs] ; let look2 = look1 <+ {key': ?key' ; <not(fetch(?key'))> removed ; <hashtable-get(|key')> tbl } in <iset-elements> rmset ; filter(?(_, key)) => keys ; <dr-lookup-all-rules(look2 | key, <conc>(keys, removed))> rs end /** * Fetch all keys defined in a rule set. */ dr-all-keys(|removed, result) = ?[RuleScope(_, tbl@Hashtable(hptr)) | rs] ; <partition(?(hptr, <id>))>removed => (localr, removed') ; <hashtable-keys>tbl ; filter({key: ?key; <not(fetch-elem(?key))>localr; !key}) => keys ; <iset-addlist(|keys)>result ; <dr-all-keys(|removed', result)>rs dr-all-keys(|removed, result) = ?[ChangeSet(_, rmset, tbl) | rs] ; <iset-elements>rmset ; <conc>(<id>, removed) => removed' ; <hashtable-keys>tbl ; filter({k, key: ?k@(_, key); <not(fetch-elem(?k))>removed'; !key}) => keys ; <iset-addlist(|keys)>result ; <dr-all-keys(|removed', result)>rs dr-all-keys(|removed, result) = ?[]; <iset-elements>result strategies // setting a rule // A rule is always stored as a mapping from key to a list of values. // Setting a rule entails removing previous rules. /** * set a rule in the inner scope * * The inner scope has label () since all scopes are labeled * this way. */ dr-set-in-rule-set(|key, value) = dr-set-in-rule-set(|(), key, value) /** * set a rule in the scope with specified label */ dr-set-in-rule-set(|label, key, value) = dr-set-in-rule-set(dr-set-fail | label, key, value) dr-set-fail(|scpid, tbl, key, value) = fail dr-set-in-rule-set(set : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm | label, key, value) = ?[RuleScope(labelset, tbl@Hashtable(hptr)) | rs] ; where( <iset-contains(|label)> labelset < (set(|hptr, tbl, key, value) <+ where(<hashtable-put(|key, value)> tbl)) + <dr-set-in-rule-set(set | label, key, value)> rs ) dr-set-in-rule-set(set1 : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm | label, key, value) = ?[ChangeSet(labelset, rmset, tbl1) | rs] ; where( let set2(|scpid, tbl2, key, value) = set1(|scpid, tbl2, key, value) <+ <dr-lookup-rule-in-scope(|key, scpid)> rs => value ; <hashtable-remove(|(scpid, key))> tbl1 ; <iset-remove(|(scpid, key))> rmset <+ <hashtable-put(|(scpid, key), value)> tbl1 ; <iset-remove(|(scpid, key))> rmset in if <iset-contains(|label)> labelset then <fetch-elem(?RuleScope(_,tbl@Hashtable(hptr)))> rs ; set2(|hptr, tbl, key, value) else <dr-set-in-rule-set(set2 | label, key, value)> rs end end ) // what to do if no scope with the label is defined? // currently this fails. This might default to adding to // the inner scope and labeling that inner scope as // well. However, that is quite expensive since // it would entail first going through all scopes to // establish non-existence of a label. /** * Add a rule to the rule-set with the specified label and make sure * it is visible by deleting any rules with the same key in scopes * upto the specified scope. Deleting by removing from the table, not * undefining. */ dr-set-in-rule-set-vis(|key, value) = dr-set-in-rule-set(|key, value) dr-set-in-rule-set-vis(|label, key, value) = dr-set-in-rule-set-vis(dr-set-fail, dr-rm-fail | label, key, value) dr-rm-fail(|scpid, tbl, key) = fail dr-set-in-rule-set-vis( set : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm, rm : ATerm * Hashtable * ATerm * ATerm -> ATerm | label, key, value) = ?[RuleScope(labelset, tbl@Hashtable(hptr)) | rs] ; where( if <iset-contains(|label)> labelset then set(|hptr, tbl, key, value) <+ <hashtable-put(|key, value)> tbl else (rm(|hptr, tbl, key) <+ <hashtable-remove(|key)> tbl) ; <dr-set-in-rule-set-vis(set, rm | label, key, value)> rs end ) dr-set-in-rule-set-vis( set1 : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm, rm1 : ATerm * Hashtable * ATerm * ATerm -> ATerm | label, key, value) = ?[ChangeSet(labelset, rmset, tbl1) | rs] ; where( let set2(|scpid, tbl2, key, value) = set1(|scpid, tbl2, key, value) <+ <dr-lookup-rule-in-scope(|key, scpid)> rs => value ; <hashtable-remove(|(scpid, key))> tbl1 ; <iset-remove(|(scpid, key))> rmset <+ <hashtable-put(|(scpid, key), value)> tbl1 ; <iset-remove(|(scpid, key))> rmset rm2(|scpid, tbl2, key) = rm1(|scpid, tbl2, key) <+ if <dr-lookup-rule-in-scope(|key, scpid)> rs then <hashtable-remove(|(scpid, key))> tbl1 ; <iset-add(|(scpid, key))> rmset end in if <iset-contains(|label)> labelset then <fetch-elem(?RuleScope(_,tbl@Hashtable(hptr)))> rs ; set2(|hptr, tbl, key, value) else <dr-set-in-rule-set-vis(set2, rm2 | label, key, value)> rs end end ) strategies // extending a rule // Extending a rule entails adding a value to the list of values // corresponding to the key. The intended semantics is that all // these values are dr-add-to-rule-set(|key, value) = dr-add-to-rule-set(|(), key, value) /** * add a rule to the scope for label * * @assert: dr-add-to-rule-set(|l, k, v) * = set-rule(|l, k, [v | <lookup-rule(|l, k, v) <+ ![]>]) */ dr-add-to-rule-set(|label, key, value) = dr-add-to-rule-set(dr-add-fail | label, key, value) dr-add-fail(|scpid, tbl, key, value) = fail dr-rm-fail(|scpid, tbl, key) = fail dr-add-to-rule-set(add : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm | label, key, value) = ?[RuleScope(labelset, tbl@Hashtable(hptr)) | rs] ; where( <iset-contains(|label)> labelset < (add(|hptr, tbl, key, value) <+ where(<hashtable-push(|key, value)> tbl)) + <dr-add-to-rule-set(add | label, key, value)> rs ) dr-add-to-rule-set(add1 : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm | label, key, value) = ?[ChangeSet(labelset, rmset, tbl1) | rs] ; where( let add2(|scpid, tbl2, key, value) = add1(|scpid, tbl2, key, value) <+ {values: // this is when the hash table of the change // set already contains a binding for the key ![value | <hashtable-get(|(scpid, key))> tbl1] => values ; if <dr-lookup-rule-in-scope(|key, scpid)> rs => values then <hashtable-remove(|(scpid, key))> tbl1 ; <iset-remove(|(scpid, key))> rmset else <hashtable-put(|(scpid, key), values)> tbl1 ; <iset-remove(|(scpid, key))> rmset end } // this is when the hash table of the change set // already does not already contain a binding for the key <+ (<dr-lookup-rule-in-scope(|key, scpid)> rs <+ ![]) ; \ values -> <hashtable-put(|(scpid, key), [value | values])> tbl1 \ in if <iset-contains(|label)> labelset then <fetch-elem(?RuleScope(_, tbl@Hashtable(hptr)))> rs ; add2(|hptr, tbl, key, value) else <dr-add-to-rule-set(add2 | label, key, value)> rs end end ) /** * add a rule to the scope for label such that it is visible afterwards * * @assert: dr-add-to-rule-set(|l, k, v) * = set-rule(|l, k, [v | <lookup-rule(|l, k, v) <+ ![]>]) */ dr-add-to-rule-set-vis(|label, key, value) = dr-add-to-rule-set-vis(dr-add-fail, dr-rm-fail | label, key, value) dr-add-to-rule-set-vis( add : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm, rm : ATerm * Hashtable * ATerm * ATerm -> ATerm | label, key, value) = ?[RuleScope(labelset, tbl@Hashtable(hptr)) | rs] ; where( if <iset-contains(|label)> labelset then add(|hptr, tbl, key, value) <+ <hashtable-push(|key, value)> tbl else (rm(|hptr, tbl, key) <+ <hashtable-remove(|key)> tbl) ; <dr-add-to-rule-set-vis(add, rm| label, key, value)> rs end ) dr-add-to-rule-set-vis( add1 : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm, rm1 : ATerm * Hashtable * ATerm * ATerm -> ATerm | label, key, value) = ?[ChangeSet(labelset, rmset, tbl1) | rs] ; where( let add2(|scpid, tbl2, key, value) = add1(|scpid, tbl2, key, value) <+ {values: // this is when the hash table of the change // set already contains a binding for the key ![value | <hashtable-get(|(scpid, key))> tbl1] => values ; if <dr-lookup-rule-in-scope(|key, scpid)> rs => values then <hashtable-remove(|(scpid, key))> tbl1 ; <iset-remove(|(scpid, key))> rmset else <hashtable-put(|(scpid, key), values)> tbl1 ; <iset-remove(|(scpid, key))> rmset end } // this is when the hash table of the change set // already does not already contain a binding for the key <+ (<dr-lookup-rule-in-scope(|key, scpid)> rs <+ ![]) ; \ values -> <hashtable-put(|(scpid, key), [value | values])> tbl1 \ rm2(|scpid, tbl2, key) = rm1(|scpid, tbl2, key) <+ if <dr-lookup-rule-in-scope(|key, scpid)> rs then <hashtable-remove(|(scpid, key))> tbl1 ; <iset-add(|(scpid, key))> rmset end in if <iset-contains(|label)> labelset then <fetch-elem(?RuleScope(_, tbl@Hashtable(hptr)))> rs ; add2(|hptr, tbl, key, value) else <dr-add-to-rule-set-vis(add2, rm2 | label, key, value)> rs end end ) strategies // intersection and union of rule-sets /** * Merge two rule sets scope by scope. * * @merge-rs : operation to merge RuleScopes * @merge-cs : operation to merge ChangeSets */ dr-merge-rule-sets(merge-rs, merge-cs) = rec x( eq < fail + (dr-merge-rule-sets1(merge-rs, x) <+ dr-merge-rule-sets2(merge-cs, x)) ) dr-merge-rule-sets1(merge-rs, merge-rec) : (rs1@[RuleScope(labels1, tbl1) | rs1a], rs2@[RuleScope(labels2, tbl2) | rs2a]) -> rs1 where ior(<merge-rs> (rs1, tbl1, rs2, tbl2), <merge-rec> (rs1a, rs2a)) dr-merge-rule-sets2(merge-cs, merge-rec) : (rs1@[cs1@ChangeSet(labels1, rmset1, tbl1@Hashtable(csid1)) | rs1a], rs2@[cs2@ChangeSet(labels2, rmset2, tbl2@Hashtable(csid2)) | rs2a]) -> [cs | rs1a] where ((<DR_BREAK>IgnoreB(csid1) <+ <DR_BREAK>IgnoreC(csid1) <+ <DR_EXCEPTION>IgnoreT(csid1)) < !"ignore" + !"") => slabel1 ; ((<DR_BREAK>IgnoreB(csid2) <+ <DR_BREAK>IgnoreC(csid2) <+ <DR_EXCEPTION>IgnoreT(csid2)) < !"ignore" + !"") => slabel2 // if one branch had a break and one had a continue, // we need to propagate the effect of continue (the // "milder" of the two) in terms of marking the change // set as ignored ; try( <DR_BREAK>IgnoreB(csid1) => lb1 ; <DR_BREAK>IgnoreC(csid2) => lc2 ; rules(DR_BREAK.lb1 :- IgnoreB(csid1)) ; dr-define-ignoreC(|csid1, lc2) ) ; try( <DR_BREAK>IgnoreB(csid2) => lb2 ; <DR_BREAK>IgnoreC(csid1) => lc1 ; rules(DR_BREAK.lb2 :- IgnoreB(csid2)) ; dr-define-ignoreC(|csid2, lc1) ) ; (// "ignore" & "ignore" have to be merged, with the "ignore" system label kept // "" & "" is the normal merge <eq>(slabel1, slabel2) < (ior(<merge-cs> (rs1, rmset1, tbl1, rs2, rmset2, tbl2), <merge-rec> (rs1a, rs2a)) ; !cs1 => cs ; try( <DR_EXCEPTION>IgnoreT(csid2) ; dr-define-ignoreT(|csid1) ) ; try( <DR_BREAK>IgnoreB(csid2) => lb ; dr-define-ignoreB(|csid1, lb) ) ; try( <DR_BREAK>IgnoreC(csid2) => lc ; dr-define-ignoreC(|csid1, lc) ) ) + (<eq>(rs1a, rs2a) < (<eq>(slabel1, "ignore") // slabel1 = "ignore" & slabel2 != "ignore", so we ignore cs1 ; !cs2 <+ <eq>(slabel2, "ignore") // slabel1 != "ignore" & slabel2 = "ignore", so we ignore cs2 ; !cs1) => cs + fatal-err(|"Merging of rulesets cannot continue because the non-ingnored change set is based on a different ruleset than the ignored change set.")) ) /** * Fixes references in change set that point to rule scopes that will * no longer be part of the merged ruleset. It is assumed that the references * that point to rule scopes in rsbad have to be replaced with references to * the corresponding (according to position) rule scopes in rsgood. * * No longer used. */ dr-fix-change-set = ?(cs@ChangeSet(_, rmset, tbl), rsgood, rsbad) ; <filter(?RuleScope(_, Hashtable(<id>)))>rsgood => scpidsgood_ ; <filter(?RuleScope(_, Hashtable(<id>)))>rsgood => scpidsbad_ ; try( // only do this if it is indeed the case <not(eq)>(scpidsgood_, scpidsbad_) ; try( // sanity check <not(eq)>(<length>scpidsgood_, <length>scpidsbad_) ; fatal-err(|"Expected structurally matching rule sets!") ) // some part of the rule sets might still be equal. Eliminate that // part from both lists to avoid needless fixing ; <eliminate-common-suffix>(scpidsgood_, scpidsbad_) => (scpidsgood, scpidsbad) ; <iset-elements>rmset ; map({key, scpid, k, idx : ?key@(scpid, k) ; try( <get-index>(scpid, scpidsbad) => idx ; <iset-remove(|key)>rmset ; <iset-add(|(<index>(idx, scpidsgood), k))>rmset ) }) ; <hashtable-keys>tbl ; map({key, scpid, k, idx, val : ?key@(scpid, k) ; try( <get-index>(scpid, scpidsbad) => idx ; <hashtable-get(|key)>tbl => val ; <hashtable-remove(|key)>tbl ; <hashtable-put(|(<index>(idx, scpidsgood), k), val)>tbl ) }) ) ; !cs /** * Intersection of two rule-sets * * assumption: the scope structure is the same * intersection works scope by scope * note that labels are ignored * * @todo: intersect labelsets as well!!?? */ dr-intersect-rule-sets = dr-merge-rule-sets( {?(rs1, tbl1, rs2, tbl2) ; <hashtable-intersect-wempty(|tbl2, [])> tbl1} , {?(rs1, rmset1, tbl1, rs2, rmset2, tbl2) ; <apply-rm-set(|rmset2)> tbl1 ; <iset-union(|rmset2)> rmset1 ; <hashtable-intersect-wempty(|tbl2, [])> tbl1} ) apply-rm-set(|rmset) = ?tbl ; where( <iset-elements> rmset ; map({x: ?x; <hashtable-remove(|x)> tbl}) ) /** * Symmetric intersection of two rule-sets * * assumption: the scope structure is the same * intersection works scope by scope * note that labels are ignored * * @todo: intersect labelsets as well!! */ dr-intersect-rule-sets-symm = dr-merge-rule-sets( {?(rs1, tbl1, rs2, tbl2) ; <hashtable-intersect-symm-wempty(|[])> (tbl1, tbl2)} , {?(rs1, rmset1, tbl1, rs2, rmset2, tbl2) ; <apply-rm-set(|rmset2)> tbl1 ; <apply-rm-set(|rmset1)> tbl2 ; <iset-union(|rmset2)> rmset1 ; <iset-union(|rmset1)> rmset2 ; <hashtable-intersect-symm-wempty-ignore-left(|[])> (tbl1, tbl2)} ) /** * Union of two rule-sets * * assumption: the scope structure of the two rule-sets is the same * and union works scope by scope * */ dr-union-rule-sets = dr-merge-rule-sets( {?(rs1, tbl1, rs2, tbl2) ; <hashtable-union(|tbl2)> tbl1} , {?(rs1, rmset1, tbl1, rs2, rmset2, tbl2) ; <apply-rm-set(|rmset2)> tbl1 ; <iset-union(|rmset2)> rmset1 ; <hashtable-merge( symmetric-no, iterate1-yes, iterate2-yes, remove-no, union, ![], \ (scpid,key) -> <dr-lookup-rule-in-scope(|key, scpid)> rs1\, \ (scpid,key) -> <dr-lookup-rule-in-scope(|key, scpid)> rs2\ )> (tbl1, tbl2)} ) dr-union-rule-sets-symm = dr-merge-rule-sets( {?(rs1, tbl1, rs2, tbl2) ; <hashtable-union-symm-wempty(|[])> (tbl1, tbl2)} , {?(rs1, rmset1, tbl1, rs2, rmset2, tbl2) ; <apply-rm-set(|rmset2)> tbl1 ; <apply-rm-set(|rmset1)> tbl2 ; <iset-union(|rmset2)> rmset1 ; <iset-union(|rmset1)> rmset2 ; <hashtable-merge( symmetric-yes, iterate1-yes, iterate2-yes, remove-no, union, ![], change1-no, change2-yes, \ (scpid,key) -> <dr-lookup-rule-in-scope(|key, scpid)> rs1 \, \ (scpid,key) -> <dr-lookup-rule-in-scope(|key, scpid)> rs2 \ )> (tbl1, tbl2)} ) strategies // generic fork-and-merge strategies fork-rule-sets : rulename -> (rulename, rs) where dr-get-rule-set(|rulename) ; dr-start-change-set => rs ; dr-start-change-set(|rulename) merge-rule-sets(merge) = ?(rulename, <id>) ; try(<merge>(rulename, <id>)) ; dr-commit-change-set(|rulename) /** * Fork and merge two rule-sets. * * @param merge : */ dr-fork-and-merge(merge, s1, s2 | rulenames) = where(<map(fork-rule-sets)> rulenames => rs1) ; restore(s1, where(<map(dr-discard-change-set(|<id>))> rulenames)) ; where(<map({(?rulename,dr-switch-rule-set(|rulename))})> rs1 => rs2) ; restore(s2, where(<map(dr-discard-change-set(|<id>))> rulenames)) ; where(<map(merge-rule-sets(merge))> rs2) dr-fork-and-merge(merge1, merge2, s1, s2 | rulenames1, rulenames2) = where( <map(fork-rule-sets)> rulenames1 => rs1a; <map(fork-rule-sets)> rulenames2 => rs1b ) ; restore( s1, where( <map(dr-discard-change-set(|<id>))> rulenames1; <map(dr-discard-change-set(|<id>))> rulenames2 ) ) ; where( <map({(?rulename,dr-switch-rule-set(|rulename))})> rs1a => rs2a; <map({(?rulename,dr-switch-rule-set(|rulename))})> rs1b => rs2b ) ; restore( s2, where( <map(dr-discard-change-set(|<id>))> rulenames1; <map(dr-discard-change-set(|<id>))> rulenames2 ) ) ; where( <map(merge-rule-sets(merge1))> rs2a; <map(merge-rule-sets(merge2))> rs2b ) strategies // generic fix-point strategies /** * Iterate and merge two rule-sets. * * @param merge : */ /* * the old implementation (for reference) * dr-fix-and-merge-no-break(merge, s | rulenames) = where(<map(fork-rule-sets)> rulenames => rs) ; repeat( where( restore(s, where(<map(dr-discard-change-set(|<id>))> rulenames)) ; if <filter({?(rulename,<id>); <merge>(rulename, <id>)})> rs; [] then ?e; fail // no changes in any of the rules else id // some rule changed; continue end ) ) ; !e ; where(<map(dr-commit-change-set(|<id>))> rulenames) */ dr-fix-and-merge(merge, s | rulenames) = dr-fix-and-merge(merge, s | rulenames, "") dr-fix-and-merge(merge, s | rulenames, label) = dr-label(merge, dr-fix-and-merge-internal(merge, s | rulenames) | rulenames, label) // notes: // - keep just the last cs's from dr-break dr-fix-and-merge-internal(merge, s | rulenames) = where(<map(fork-rule-sets)> rulenames => rs) ; where( prim("SSL_hashtable_get", <dr-rule-sets-hashtable>, "DR_EXCEPTION") ; [RuleScope(iset-elements, hashtable-getlist)] => [RuleScope(labels, tbl)] ; !0 => exRS <+ !1 => exRS ) ; repeat( where( restore(s, where(<map(dr-discard-change-set(|<id>))> rulenames)) ; if <filter({rulename, ruleset, csid: ?(rulename, ruleset) // getting a change set marked as ignored here means that the // loop _always_ ends with a break, so we might as well not have // had a loop at all, since it will only be executed once ; where(dr-get-rule-set(|rulename) => [ChangeSet(_, _, Hashtable(csid)) | _]) ; if <DR_BREAK>IgnoreB(csid) then <merge>(rulename, ruleset) ; fail else <dr-merge-continue-change-sets(merge | <DR_BREAK>Label(rulename))>rulename ; <merge>(rulename, ruleset) end })> rs; [] then ?e; fail // no changes in any of the rule sets else // further down below, we need to be able to extract the elements // in the list returned by bagof-DR_BREAK which were defined during // the first run (from above) of the strategy s and the ones in the // last run. For this, we need to make sure there will be some // separators in that list which we can use to get what we need. // The separator will be (), and here is the point where we add it where(<map({rulename, label: ?rulename ; <DR_BREAK>Label(rulename) => label ; rules(DR_BREAK :+ BreakCS(rulename, label) -> ()) })>rulenames) ; where(try( <eq>(exRS, 0) ; dr-new-rule-set ; [RuleScope(iset-addlist(|labels), hashtable-putlist(|tbl))] ; dr-set-rule-set(|"DR_EXCEPTION") )) ; id // some rule changed; continue end ) ) // we only want to use those elements from bagof-DR_BREAK that are from // the first and the last run of strategy s in the repeat from above. // For that, we used () as a separator (see comment above). Here we make // sure that when bagof-DR_BREAK is called in dr-label, only the proper // change sets are returned for merging ; <map({rulename, label: ?rulename ; <DR_BREAK>Label(rulename) => label ; (<bagof-DR_BREAK>BreakCS(rulename, label) <+ ![]) ; list-tokenize(|[()]) ; first-last ; concat ; where(rules(DR_BREAK :- BreakCS(rulename, label))) ; reverse-map({val: ?val; rules(DR_BREAK :+ BreakCS(rulename, label) -> val)}) })>rulenames ; !e ; where(<map(dr-commit-change-set(|<id>))> rulenames) dr-fix-and-merge(merge1, merge2, s | rulenames1, rulenames2) = where(<map(fork-rule-sets)> rulenames1 => rs1; <map(fork-rule-sets)> rulenames2 => rs2) ; repeat( where( restore( s, where( <map(dr-discard-change-set(|<id>))> rulenames1; <map(dr-discard-change-set(|<id>))> rulenames2 ) ) ; if and(<filter({?(rulename,<id>); <merge1>(rulename, <id>)})> rs1; [] ,<filter({?(rulename,<id>); <merge2>(rulename, <id>)})> rs2; []) then ?e; fail // no changes in any of the rules end ) ) ; !e ; where(<map(dr-commit-change-set(|<id>))> rulenames1 ;<map(dr-commit-change-set(|<id>))> rulenames2) dr-merge-continue-change-sets(merge | label) = ?rulename ; dr-get-rule-set(|rulename) => [ChangeSet(_, _, Hashtable(csid)) | rs] ; (<bagof-DR_BREAK>ContinueCS(rulename, label) <+ ![]) ; where(rules(DR_BREAK :- ContinueCS(rulename, label))) ; if not(?[]); <DR_BREAK>IgnoreC(csid) then // discard and replace the current change set with the first // one from the list returned by bagof-DR_BREAK (it could have // been any other element of that list just as well) where(dr-discard-change-set(|rulename)) ; [![<id> | rs]; dr-set-rule-set(|rulename) | id]; Tl else id end // merge all the change sets (prepended to the common part of the ruleset) ; map(![<id> | rs]; try(<merge>(rulename, <id>))) strategies // labeling statements, break, continue /** * @todo destroy the change sets introduced by calls to dr-break */ dr-label(merge, s | rulenames, label) = {| DR_BREAK : // register <label> as the active label rules(DR_BREAK+label) ; where(<map({rulename: ?rulename ; rules(DR_BREAK : Label(rulename) -> label) })>rulenames) // for each rule r in <rulenames> define a dynamic rule which // marks the position of the change set created below in the // ruleset of r ; where( <map({rulename, pos: ?rulename ; dr-get-rule-set(|rulename) ; length => pos ; rules(DR_BREAK : SplitPos(rulename, label) -> pos) })>rulenames ) // we need a change set to collect all the changes // to the rule set which are created on control flow // paths that do not end with a call to dr-break or // dr-continue ; where(<map(dr-start-change-set(|<id>))>rulenames) // run the strategy and save the result ; restore(s, where(<map(dr-discard-change-set(|<id>))>rulenames)) ; ?e // for each rule r in <rulenames> we essentially want to merge the current // ruleset for rule r with the change sets for r and the current <label> // returned by bagof-DR_BREAK (prepended to the common part of the ruleset) ; <map({rulename, rs, csid, csidnew, cslbl: ?rulename ; dr-get-rule-set(|rulename) => [ChangeSet(_, _, Hashtable(csid)) | rs] ; (<bagof-DR_BREAK>BreakCS(rulename, label) <+ ![]) ; if not(?[]); <DR_BREAK>IgnoreB(csid) then // discard replace the current change set with the first one from the list // returned by bagof-DR_BREAK (it could have been any other element of that // list just as well) where(dr-discard-change-set(|rulename)) ; [![<id> | rs]; dr-set-rule-set(|rulename) | id]; Tl else id end // merge all the change sets (prepended to the common part of the ruleset) ; map(![<id> | rs]; try(<merge>(rulename, <id>))) // commit the change sets created above ; dr-commit-change-set(|rulename) })>rulenames ; !e |} dr-break(|rulename) = dr-break(|rulename, <DR_BREAK>Label(rulename)) dr-break(|rulename, label) = where( dr-get-rule-set(|rulename) => rs // split the ruleset in two parts: the one before the // labeled statement and the one after it ; back-split-at(|<DR_BREAK>SplitPos(rulename, label)) // build the change set with all the changes from // the first part of the pair generated above... ; dr-build-aggregated-change-set => bcs // ... and add it to the rule which collects all // the change sets pertaining to control flow paths // that lead to a break ; rules(DR_BREAK.label :+ BreakCS(rulename, label) -> bcs) // go back to the active ruleset and mark the innermost change set as ignored ; !rs ; fetch(ChangeSet(id, id, ?Hashtable(csid))) // ; rules(DR_BREAK.label : IgnoreB(csid) -> label) ; dr-define-ignoreB(|csid, label) ) /** * This implementation of the strategy doesn't work. * (left here for reference purposes only) * * Reason: replacing a number of change sets & rule scopes with * their clones introduces inconsistency issues during merging * that are way too difficult to solve. * dr-break-bp(|rulename) = where( <DR_BREAK>Label(rulename) => label ; dr-get-rule-set(|rulename) ; back-split-at(|<DR_BREAK>SplitPos(rulename, label)) ; ?(inRs, outRs) ; <map({scope, lbls : (?ChangeSet(_, _, _); dr-new-change-set) <+ \ RuleScope(labels, table) -> scope where dr-new-scope => scope@RuleScope(lbls, tbl) ; <iset-addlist(|<iset-elements>labels)>lbls ; <hashtable-keys>table ; map({key, val : ?key ; <hashtable-get(|key)>table => val ; <hashtable-put(|key, val)>tbl }) \ })>inRs ; <conc>(<id>, outRs) ; dr-set-rule-set(|rulename) ) */ // dr-break version for backward propagation transformations dr-break-bp(|rulename) = where( <DR_BREAK>Label(rulename) => label ; dr-get-rule-set(|rulename) ; back-split-at(|<DR_BREAK>SplitPos(rulename, label)) // here we make the assumption that we always have a // change set as the first element in the rule set, // which comes from the assumption that the user always // uses dr-transaction with rule scopes in backward // propagation transformations ; ?([ChangeSet(_, rmset, tbl) | inRs], outRs) ; <iset-clear>rmset ; <hashtable-clear>tbl ; <reverse>inRs ; dr-build-bp-change-set(|rmset, tbl, outRs) ) dr-build-bp-change-set(|rmset, tbl, ruleset) = [?rs@RuleScope(_, _) | dr-build-bp-change-set(|rmset, tbl, [rs | ruleset])] <+ [] dr-build-bp-change-set(|rmset, tbl, ruleset) = ?[ChangeSet(_, rmset1, tbl1) | rest] ; <iset-elements>rmset1 ; map({scpid, key, value : ?(scpid, key) ; try( <dr-lookup-rule-in-scope(|key, scpid)>ruleset => value ; <hashtable-put(|(scpid, key), value)>tbl ) }) ; <hashtable-keys>tbl1 ; map({scpid, key, value : ?(scpid, key) ; (<dr-lookup-rule-in-scope(|key, scpid)>ruleset => value < <hashtable-put(|(scpid, key), value)>tbl + <iset-add(|(scpid, key))>rmset) }) ; <dr-build-bp-change-set(|rmset, tbl, ruleset)>rest dr-continue(|rulename) = dr-continue(|rulename, <DR_BREAK>Label(rulename)) dr-continue(|rulename, label) = where( dr-get-rule-set(|rulename) => rs // split the ruleset in two parts: the one before the // labeled statement and the one after it ; back-split-at(|<DR_BREAK>SplitPos(rulename, label)) // build the change set with all the changes from // the first part of the pair generated above... ; dr-build-aggregated-change-set => ccs // ... and add it to the rule which collects all // the change sets pertaining to control flow paths // that lead to a continue ; rules(DR_BREAK.label :+ ContinueCS(rulename, label) -> ccs) // go back to the active ruleset and mark the innermost change set as ignored ; !rs ; fetch(ChangeSet(id, id, ?Hashtable(csid))) ; dr-define-ignoreC(|csid, label) ) /** * This strategy takes a pair of lists of change sets and rule scopes * and returns a change set which contains all the changes from the * change sets in the left member of the input pair which refer to * rule scopes in the right member of the input pair. */ dr-build-aggregated-change-set = // create the extra change set (?sourceRs, dr-start-change-set => rs@[aggCs@ChangeSet(_, rmset, tbl) | _]) // commit all change sets in sourceRs to the extra change set ; <reverse-map( ![<id> | rs] ; try(dr-commit-change-set(fail)) )>sourceRs // collect all the scope ids of the rule scopes in sourceRs ; <filter(?RuleScope(_, Hashtable(<id>)))>sourceRs => scpids // remove all the elements from rmset that refer to rule scopes // whose scope id is part of scpids ; <iset-elements>rmset ; map({k, scpid : ?k@(scpid, _) ; try(<fetch-elem(?scpid)>scpids; <iset-remove(|k)>rmset) }) // remove all the elements from tbl that refer to rule scopes // whose scope id is part of scpids ; <hashtable-keys>tbl ; map({k, scpid : ?k@(scpid, _) ; try(<fetch-elem(?scpid)>scpids; <hashtable-remove(|k)>tbl) }) // return the built change set ; !aggCs strategies // exception handling strategies dr-init-exception-block(has-finally | catch-tags, rulenames) = where(<map({rulename, tb : ?rulename ; !TryBlock( <dr-get-rule-set(|rulename); length> , <new> , <map(!Catch(<new>, <id>))>catch-tags , <has-finally < !Finally(<new>) + !Finally("")>) => tb ; rules(DR_EXCEPTION :+ Structure(rulename) -> tb) ; dr-start-change-set(|rulename) })>rulenames) dr-throw(eq-test | tag, rulename) = where( get-matching-id(eq-test | tag, rulename) => (pos, ID, catchID) ; dr-get-rule-set(|rulename) => rs ; back-split-at(|pos) ; dr-build-aggregated-change-set => tcs ; rules(DR_EXCEPTION :+ ThrowCS(rulename, ID) -> (tcs, catchID)) ; <fetch(ChangeSet(id, id, ?Hashtable(csid)))>rs ; dr-define-ignoreT(|csid) ) get-matching-id(eq-test | tag, rulename) = (<bagof-DR_EXCEPTION>Structure(rulename) <+ ![]) ; where( fetch-elem({pos, catches : ?TryBlock(pos, _, catches, _) ; <fetch-elem({cID, ctag : ?Catch(cID, ctag); <eq-test>(tag, ctag); !cID})>catches }) => catchID <+ fatal-err(|"dr-throw: Thrown exception does not match any catch clause") ) ; fetch-elem({pos, catches, fID : ?TryBlock(pos, _, catches, Finally(fID)) ; (<fetch-elem({cID, ctag : ?Catch(cID, ctag); <eq-test>(tag, ctag); !cID})>catches <+ <not(eq)>(fID, ""); !fID) ; !(pos, <id>, catchID) }) get-matching-id(|catchID, rulename) = (<bagof-DR_EXCEPTION>Structure(rulename) <+ ![]) ; fetch-elem({pos, catches, fID : ?TryBlock(pos, _, catches, Finally(fID)) ; (<fetch-elem(?Catch(catchID, _); !catchID)>catches <+ <not(eq)>(fID, ""); !fID) ; !(pos, <id>) }) <+ fatal-err(|"dr-complete-finally: Could not forward exception due to missing catch clause") dr-complete-catch(merge, s | rulenames) = ?term ; <map({rulename, cID, cs, rs, hd, tl : ?rulename ; (<DR_EXCEPTION>Structure(rulename) => TryBlock(_, _, [Catch(cID, _) | _], _) <+ fatal-err(|"dr-complete-catch was called when no catch clause was active or when a finished exception block was not completed")) ; (dr-get-rule-set(|rulename) => [cs@ChangeSet(_, _, _) | rs] <+ fatal-err(|"dr-complete-catch was not called in a proper exception handling context")) ; <bagof-DR_EXCEPTION>ThrowCS(rulename, cID) ; if ?[(hd, _) | tl] then <dr-set-rule-set(|rulename)>[<dr-clone-change-set>hd | rs] ; <map(![<?(<id>, _)> | rs]; try(<merge>(rulename, <id>)))>tl else <dr-set-rule-set(|rulename)>[<dr-clone-change-set>cs | rs] end ; !cs })>rulenames => css ; restore(<s>term => e, <zip>(css, rulenames) ; map({cs, rulename, rs : ?(cs, rulename) ; dr-get-rule-set(|rulename) ; [dr-destroy-change-set | ?rs] ; ![cs | rs] ; dr-set-rule-set(|rulename) }) ) ; <zip>(css, rulenames) ; map({cs, rulename, pos, ID, cID, catches, fin, fID, cs', rs : ?(cs, rulename) ; (<once-DR_EXCEPTION>Structure(rulename) => TryBlock(pos, ID, [Catch(cID, _) | catches], fin@Finally(fID)) <+ fatal-err(|"dr-complete-catch: Unexpected failure here!")) ; rules(DR_EXCEPTION :+ Structure(rulename) -> TryBlock(pos, ID, catches, fin)) ; rules(DR_EXCEPTION :- ThrowCS(rulename, cID)) ; (dr-get-rule-set(|rulename) => [cs'@ChangeSet(_, _, _) | rs] <+ fatal-err(|"dr-complete-catch: A change set was expected here!")) ; (<eq>(fID, "") < rules(DR_EXCEPTION :+ ExceptionCS(rulename, ID) -> cs') + rules(DR_EXCEPTION :+ ExceptionCS(rulename, fID) -> cs')) ; ![cs | rs] ; dr-set-rule-set(|rulename) }) ; !e dr-complete-finally(merge, s | rulenames) = ?term ; <map({rulename, tb, fID, cs, csid, rs, tcss, hd, tl : ?rulename ; (<once-DR_EXCEPTION>Structure(rulename) => tb@TryBlock(_, _, [], Finally(fID)) <+ fatal-err(|"dr-complete-finally was called when a catch clause was still active")) ; try(<eq>(fID, ""); fatal-err(|"dr-complete-finally was called when a finally clause was not active")) ; (dr-get-rule-set(|rulename) => [cs@ChangeSet(_, _, Hashtable(csid)) | rs] <+ fatal-err(|"dr-complete-finally was not called in a proper exception handling context")) ; (<bagof-DR_EXCEPTION>ThrowCS(rulename, fID) <+ ![]) => tcss ; (<bagof-DR_EXCEPTION>ExceptionCS(rulename, fID) <+ ![]) ; <conc>(<id>, <map(?(<id>, _))>tcss) ; if ?[hd | tl]; <DR_EXCEPTION>IgnoreT(csid) then dr-discard-change-set(|rulename) ; <dr-set-rule-set(|rulename)>[<dr-clone-change-set>hd | rs] ; <map(try(<merge>(rulename, <![<id> | rs]>)))>tl else where(<dr-set-rule-set(|rulename)>[<dr-clone-change-set>cs | rs]) ; map(try(<merge>(rulename, <![<id> | rs]>))) end ; !(tb, cs, rulename) })>rulenames => temp ; restore(<s>term => e, <map({tb, cs, rulename, rs : ?(tb, cs, rulename) ; dr-get-rule-set(|rulename) ; [dr-destroy-change-set | ?rs] ; ![cs | rs] ; dr-set-rule-set(|rulename) ; rules(DR_EXCEPTION :+ Structure(rulename) -> tb) })>temp ) ; <map({rulename, pos, ID, fID, csid, rs : ?(TryBlock(pos, ID, [], Finally(fID)), _, rulename) ; rules(DR_EXCEPTION :+ Structure(rulename) -> TryBlock(pos, ID, [], Finally(""))) ; rules(DR_EXCEPTION :- ExceptionCS(rulename, fID)) ; (dr-get-rule-set(|rulename) => rs@[ChangeSet(_, _, Hashtable(csid)) | _] <+ fatal-err(|"dr-complete-finally: A change set was expected here!")) ; try( <not(DR_EXCEPTION)>IgnoreT(csid) ; (<bagof-DR_EXCEPTION>ThrowCS(rulename, fID) <+ ![]) ; map(?(_, <id>)) ; make-set ; map({catchID, pos, nextID, tcs : ?catchID ; get-matching-id(|catchID, rulename) => (pos, nextID) ; <back-split-at(|pos)>rs ; dr-build-aggregated-change-set => tcs ; rules(DR_EXCEPTION :+ ThrowCS(rulename, nextID) -> (tcs, catchID)) }) ) ; rules(DR_EXCEPTION :- ThrowCS(rulename, fID)) })>temp ; !e dr-complete-exception-block(merge | rulenames) = where( <map({rulename, ID, csid, rs, hd, tl : ?rulename ; (<once-DR_EXCEPTION>Structure(rulename) => TryBlock(_, ID, [], Finally("")) <+ fatal-err(|"dr-complete-exception-block was called before completing all catch clauses (and the finally clause) or in a non-proper exception handling context")) ; (dr-get-rule-set(|rulename) => [ChangeSet(_, _, Hashtable(csid)) | rs] <+ fatal-err(|"dr-complete-exception-block was not called in a proper exception handling context")) ; (<bagof-DR_EXCEPTION>ExceptionCS(rulename, ID) <+ ![]) ; if ?[hd | tl]; <DR_EXCEPTION>IgnoreT(csid) then dr-discard-change-set(|rulename) ; <dr-set-rule-set(|rulename)>[<dr-clone-change-set>hd | rs] ; <map(![<id> | rs]; try(<merge>(rulename, <id>)))>tl else map(![<id> | rs]; try(<merge>(rulename, <id>))) end ; rules(DR_EXCEPTION :- ExceptionCS(rulename, ID)) ; dr-commit-change-set(|rulename) })>rulenames ) strategies // transactional run of a strategy dr-transaction(s | rulenames) = where(<map(dr-start-change-set(|<id>))>rulenames) ; restore(s, where(<map(dr-discard-change-set(|<id>))>rulenames)) ; where(<map(dr-commit-change-set(|<id>))>rulenames) strategies // fork with intersection and union /** * two-way split in data-flow (if-then-else) for list of rules */ /** * Fork and intersection of two rule-sets */ dr-fork-and-intersect(s1, s2 | rulenames) = dr-fork-and-merge(\ (rulename, rs) -> <dr-intersect-with(|rulename)> rs \ , s1, s2 | rulenames) /** * Fork and union of two rule-sets */ dr-fork-and-union(s1, s2 | rulenames) = dr-fork-and-merge(\ (rulename, rs) -> <dr-union-with(|rulename)> rs \ , s1, s2 | rulenames) /** * Fork and combined union and intersection of two rule-sets */ dr-fork-and-intersect-union(s1, s2 | rulenames1, rulenames2) = dr-fork-and-merge(\ (rulename, rs) -> <dr-intersect-with(|rulename)> rs \ ,\ (rulename, rs) -> <dr-union-with(|rulename)> rs \ , s1, s2 | rulenames1, rulenames2) strategies // fix-point with intersection and union /** * loop in data-flow (while) */ /** * Iterate intersection of two rule-sets */ dr-fix-and-intersect(s | rulenames) = dr-fix-and-merge(\ (rulename, rs) -> <dr-intersect-symm(|rulename)> rs \ , s | rulenames) dr-fix-and-intersect(s | rulenames, label) = dr-fix-and-merge(\ (rulename, rs) -> <dr-intersect-symm(|rulename)> rs \ , s | rulenames, label) /** * Iterate union of two rule-sets */ dr-fix-and-union(s | rulenames) = dr-fix-and-merge(\ (rulename, rs) -> <dr-union-symm(|rulename)> rs \ , s | rulenames) dr-fix-and-union(s | rulenames, label) = dr-fix-and-merge(\ (rulename, rs) -> <dr-union-symm(|rulename)> rs \ , s | rulenames, label) /** * Iterate combined union and intersection of two rule-sets */ dr-fix-and-intersect-union(s | rulenames1, rulenames2) = dr-fix-and-merge( \ (rulename, rs) -> <dr-intersect-symm(|rulename)> rs \ , \ (rulename, rs) -> <dr-union-symm(|rulename)> rs \ , s | rulenames1, rulenames2) strategies // label statements with intersection and union /** * labeled _non-iterative_ statement in data-flow */ /** * Label current point in data-flow with <label> to accommodate * break's. Intersection of rule-sets after running <s>: * - the "main" rule-set resulted by running <s> * - all the rule-sets generated by calls to dr-break * with the same label as this one * * !! Only use this to label non-iterative statements. !! * !! Use dr-fix-and-intersect which takes a label !! * !! argument to label iterative statements. !! */ dr-label-intersect(s | rulenames, label) = dr-label(\ (rulename, rs) -> <dr-intersect-symm(|rulename)> rs \ , s | rulenames, label) /** * Label current point in data-flow with <label> to accommodate * break's. Union of rule-sets after running <s>: * - the "main" rule-set resulted by running <s> * - all the rule-sets generated by calls to dr-break * with the same label as this one * * !! Only use this to label non-iterative statements. !! * !! Use dr-fix-and-union which takes a label !! * !! argument to label iterative statements. !! */ dr-label-union(s | rulenames, label) = dr-label(\ (rulename, rs) -> <dr-union-symm(|rulename)> rs \ , s | rulenames, label) strategies // exceptions dr-complete-catch-intersect(s | rulenames) = dr-complete-catch(\ (rulename, rs) -> <dr-intersect-with(|rulename)> rs \ , s | rulenames) dr-complete-finally-intersect(s | rulenames) = dr-complete-finally(\ (rulename, rs) -> <dr-intersect-with(|rulename)> rs \ , s | rulenames) dr-complete-exception-block-intersect(|rulenames) = dr-complete-exception-block(\ (rulename, rs) -> <dr-intersect-with(|rulename)> rs \ | rulenames) dr-complete-catch-union(s | rulenames) = dr-complete-catch(\ (rulename, rs) -> <dr-union-with(|rulename)> rs \ , s | rulenames) dr-complete-finally-union(s | rulenames) = dr-complete-finally(\ (rulename, rs) -> <dr-union-with(|rulename)> rs \ , s | rulenames) dr-complete-exception-block-union(|rulenames) = dr-complete-exception-block(\ (rulename, rs) -> <dr-union-with(|rulename)> rs \ | rulenames) strategies // n-way split /** * n-way split in data-flow (case) * * @todo : generalize to factor out table merge operation */ dr-fold-and-intersect(empty, hd, tl : (a -> a) * a -> a | rulenames) = if empty then id else where(<map(!(<id>, <dr-get-rule-set(|<id>)>))> rulenames => rs0) ; dr-fold-and-intersect(empty, hd, tl | rulenames, rs0) ; where(<map(dr-commit-change-set(|<id>))> rulenames) end dr-fold-and-intersect(empty, hd, tl : (a -> a) * a -> a | rulenames, rs0) = if empty then id else where( <map({?(rulename,<id>) ; dr-start-change-set ; dr-set-rule-set(|rulename)})> rs0 ) ; hd ; where( <map(!(<id>, <dr-get-rule-set(|<id>)>))> rulenames => rs1 ) ; tl(dr-fold-and-intersect(empty, hd, tl | rulenames, rs0)) ; where( <map({?(rulename, <id>); dr-intersect-with(|rulename)})> rs1 ) end /** * fork and intersect over a list * * @todo : generalize to factor out table merge operation */ dr-map-and-intersect(s | rulenames) = let tl(s') = [id | s'] in dr-fold-and-intersect([], [s|id], tl | rulenames) end strategies // workaround for overlapping lhhs in dynamic rule dr-define-ignoreB(|csid, label) = rules(DR_BREAK.label : IgnoreB(csid) -> label) dr-define-ignoreC(|csid, label) = rules(DR_BREAK.label : IgnoreC(csid) -> label) dr-define-ignoreT(|csid) = rules(DR_EXCEPTION : IgnoreT(csid)) strategies // rule-set equality dr-eq-rule-sets = let rseq = ?(RuleScope(lbl1, tbl1), RuleScope(lbl2, tbl2)) ; <iset-eq(|lbl2)> lbl1 ; <hashtable-eq> (tbl1, tbl2) + ?(ChangeSet(lbl1, rmset1, tbl1), ChangeSet(lbl2, rmset1, tbl2)) ; <iset-eq(|lbl2)> lbl1 ; <iset-eq(|rmset2)> rmset1 ; <hashtable-eq> (tbl1, tbl2) in where(zip(rseq)) end strategies // debugging dr-debug-rule-set(|name) = dr-debug-rule-set(|name, "") dr-debug-rule-set(|name, msg) = where( (!msg => "" <+ say(!msg)) ; <debug(!"Ruleset for: ")> name ; dr-print-rule-set(|name) ) dr-print-rule-set(|name) = where( dr-get-rule-set(|name) ; dr-print-rule-set ) dr-print-rule-sets(|names) = where( <map(debug; dr-print-rule-set(|<id>))> names ) dr-print-rule-set-msg(|msg) = where(!msg => "" <+ say(<concat-strings>["\n--- BEGIN(", msg, ") ---"])) ; dr-print-rule-set ; where(!msg => "" <+ say(<concat-strings>["--- END (", msg, ") ---\n"])) dr-print-rule-set = where(map(dr-print-scope)) dr-print-scope = ?RuleScope(labelset, tbl) ; where( debug ; <iset-elements; debug(!"labels: ")> labelset ; <hashtable-keys> tbl ; map(where(<fprintnl>(stderr(), [" ", <id>, " -> " ])) ; where(\ key -> <hashtable-get(|key)> tbl \ ; map(<fprintnl>(stderr(), [" ", <id>])) ) ) ) dr-print-scope = ?ChangeSet(labelset, rmset, tbl@Hashtable(csid)) ; where( debug ; <iset-elements; debug(!"labels: ")> labelset ; <iset-elements; debug(!"removed: ")> rmset ; <hashtable-keys> tbl ; map(where(<fprintnl>(stderr(), [" ", <id>, " -> "])) ; where(\ key -> <hashtable-get(|key)> tbl \ ; map(<fprintnl>(stderr(), [" ", <id>])) ) ) ; try( <DR_BREAK>IgnoreB(csid) => blabel ; <fprintnl>(stderr(), ["Change set is marked as ignored (due to break) up to label ", blabel, "."]) ) ; try( <DR_BREAK>IgnoreC(csid) => clabel ; <fprintnl>(stderr(), ["Change set is marked as ignored (due to continue) up to label ", clabel, "."]) ) ) strategies // friendlier debugging (numbers instead of ugly strings for hashtable ids) dr-friendly-debug-rule-set(|name) = dr-friendly-debug-rule-set(|name, "") dr-friendly-debug-rule-set(|name, msg) = where( (!msg => "" <+ say(!msg)) ; <debug(!"Ruleset for: ")> name ; dr-friendly-print-rule-set(|name) ) dr-friendly-print-rule-set(|name) = where( dr-get-rule-set(|name) ; dr-friendly-print-rule-set ) dr-friendly-print-rule-sets(|names) = where( <map(debug; dr-friendly-print-rule-set(|<id>))> names ) dr-friendly-print-rule-set-msg(|msg) = where(!msg => "" <+ say(<concat-strings>["\n--- BEGIN(", msg, ") ---"])) ; dr-friendly-print-rule-set ; where(!msg => "" <+ say(<concat-strings>["--- END (", msg, ") ---\n"])) dr-friendly-print-rule-set = where({| DRFriendlyName, DR_Count : rules( DRCount : "rs" -> 0 DRCount : "cs" -> 0 ) ; reverse-map({ ?RuleScope(_, Hashtable(rsid)) ; where( <DRCount>"rs" => idxrs; <inc>idxrs => idxrs' ; <concat-strings>["RuleScope(", <int-to-string>idxrs, ")"] => name ) ; rules( DRFriendlyName : rsid -> name DRCount : "rs" -> idxrs' ) <+ ?ChangeSet(_, _, Hashtable(csid)) ; where( <DRCount>"cs" => idxcs; <inc>idxcs => idxcs' ; <concat-strings>["ChangeSet(", <int-to-string>idxcs, ")"] => name ) ; rules( DRFriendlyName : csid -> name DRCount : "cs" -> idxcs' ) }) ; map(dr-friendly-print-scope) |}) dr-friendly-print-rule-set-msg(|msg) = where(!msg => "" <+ say(<concat-strings>["\n--- BEGIN(", msg, ") ---"])) ; dr-friendly-print-rule-set ; where(!msg => "" <+ say(<concat-strings>["--- END (", msg, ") ---\n"])) dr-friendly-print-scope = ?RuleScope(labelset, tbl@Hashtable(rsid)) ; <DRFriendlyName>rsid ; where( debug ; <iset-elements; debug(!"labels: ")> labelset ; <hashtable-keys> tbl ; map( where(<fprintnl>(stderr(), [" ", <id>, " -> " ])) ; where( \ key -> <hashtable-get(|key)> tbl \ ; map(<fprintnl>(stderr(), [" ", <id>])) ) ) ) dr-friendly-print-scope = ?ChangeSet(labelset, rmset, tbl@Hashtable(csid)) ; <DRFriendlyName>csid ; where( debug ; <iset-elements; debug(!"labels: ")> labelset ; <iset-elements; debug(!"removed: ")> rmset ; <hashtable-keys> tbl ; map( where((DRFriendlyName <+ id, id); <fprintnl>(stderr(), [" ", <id>, " -> "])) ; where( \ key -> <hashtable-get(|key)> tbl \ ; map(<fprintnl>(stderr(), [" ", <id>])) ) ) ; try( <DR_BREAK>IgnoreB(csid) => blabel ; <fprintnl>(stderr(), ["Change set is marked as ignored (due to break) up to label ", blabel, "."]) ) ; try( <DR_BREAK>IgnoreC(csid) => clabel ; <fprintnl>(stderr(), ["Change set is marked as ignored (due to continue) up to label ", clabel, "."]) ) )