[teyjus] r1178 committed - Simplified renaming logic, sanitized renaming, added tests...

[tey...@googlecode.com]

Revision: 1178
Author: mitc...@gmail.com
Date: Wed Jan 28 07:00:33 2015 UTC
Log: Simplified renaming logic, sanitized renaming, added tests

Internally, include statements (i.e. {kind a}) are
represented the same way as {kind a => a}. This greatly
simplified the code handling renaming, and now reflects our
specification that statements akin to those two should be
considered equivalent.

Also, before a signature's accumulated signatures are
compiled/translated, they're put through a sanitation
function which:
1) Prints out warnings if there are multiple equivalent
renaming statements, i.e. {kind a, kind a => a}.
2) Removes the signature from the accumulated signature
list if the renaming directive is empty ({}), and
prints a warning.

Currently only does so for signature accumulation - a
generalization which applies to module renaming is
forthcoming in the next commit.


https://code.google.com/p/teyjus/source/detail?r=1178

Added:
/branches/RenamingRedux/source/test/renaming_tests/test4
/branches/RenamingRedux/source/test/renaming_tests/test4/accumulating.mod
/branches/RenamingRedux/source/test/renaming_tests/test4/accumulating.sig
/branches/RenamingRedux/source/test/renaming_tests/test4/base.sig
/branches/RenamingRedux/source/test/renaming_tests/test4/expected.mod
/branches/RenamingRedux/source/test/renaming_tests/test4/expected.sig
/branches/RenamingRedux/source/test/renaming_tests/test4/main.om
/branches/RenamingRedux/source/test/renaming_tests/test5
/branches/RenamingRedux/source/test/renaming_tests/test5/accumulating.mod
/branches/RenamingRedux/source/test/renaming_tests/test5/accumulating.sig
/branches/RenamingRedux/source/test/renaming_tests/test5/base.sig
/branches/RenamingRedux/source/test/renaming_tests/test5/expected.mod
/branches/RenamingRedux/source/test/renaming_tests/test5/expected.sig
/branches/RenamingRedux/source/test/renaming_tests/test5/main.om
/branches/RenamingRedux/source/test/renaming_tests/tests.txt
Modified:
/branches/RenamingRedux/source/compiler/lpyacc.mly
/branches/RenamingRedux/source/compiler/preabsyn.ml
/branches/RenamingRedux/source/compiler/preabsyn.mli
/branches/RenamingRedux/source/compiler/translate.ml

=======================================
--- /dev/null
+++
/branches/RenamingRedux/source/test/renaming_tests/test4/accumulating.mod
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+module accumulating.
=======================================
--- /dev/null
+++
/branches/RenamingRedux/source/test/renaming_tests/test4/accumulating.sig
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,3 @@
+sig accumulating.
+
+accum_sig base {kind a, kind a, type x, type x}.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test4/base.sig Wed
Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,5 @@
+sig base.
+
+kind a type.
+
+type x int.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test4/expected.mod
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+module expected.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test4/expected.sig
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,5 @@
+sig expected.
+
+kind a type.
+
+type x int.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test4/main.om Wed
Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+MAIN = accumulating
=======================================
--- /dev/null
+++
/branches/RenamingRedux/source/test/renaming_tests/test5/accumulating.mod
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+module accumulating.
=======================================
--- /dev/null
+++
/branches/RenamingRedux/source/test/renaming_tests/test5/accumulating.sig
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,3 @@
+sig accumulating.
+
+accum_sig base {}.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test5/base.sig Wed
Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,5 @@
+sig base.
+
+kind a type.
+
+type x int.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test5/expected.mod
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+module expected.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test5/expected.sig
Wed Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+sig expected.
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/test5/main.om Wed
Jan 28 07:00:33 2015 UTC
@@ -0,0 +1,1 @@
+MAIN = accumulating
=======================================
--- /dev/null
+++ /branches/RenamingRedux/source/test/renaming_tests/tests.txt Wed Jan 28
07:00:33 2015 UTC
@@ -0,0 +1,24 @@
+Renaming tests, first set to establish invariants:
+
+First, that the processing of a signature/module is isolated from the rest,
+i.e. that the context the module is used in doesn't affect whether or not
+it'se well-formed.
+
+Secondly, that an inclusion statement, i.e. {type x} is just a special
case of
+a renaming statement {type x => x}. Either we'll cover this with a test
case
+or do some reasoning about the code.
+
+Then, we test that multiple redundant renaming statements are allowed by
the
+compiler.
+
+We also specify that an empty renaming directive, i.e. in
+ accum_sig m1 {}.
+corresponds to not accumulating the module at all. We'll then have a test
case
+that checks this.
+
+Inclusion: with * symbol
+ - Equivalence to manual inclusion of all elements
+ - Name clashes output appropriate error messages
+
+Selective: no * symbol
+ - Check that omitted elements behave as expected
=======================================
--- /branches/RenamingRedux/source/compiler/lpyacc.mly Mon Aug 4 22:03:14
2014 UTC
+++ /branches/RenamingRedux/source/compiler/lpyacc.mly Wed Jan 28 07:00:33
2015 UTC
@@ -151,12 +151,9 @@
(inclusiveRenaming := false);
(auxKindRenamingList := []);
(auxConstRenamingList := []);
- if kindDirectives = [] && constDirectives = []
- then IncludeAll
- else
- if inclusive
- then InclusiveSelect (kindDirectives, constDirectives)
- else SelectOf (kindDirectives, constDirectives)
+ if inclusive
+ then InclusiveSelect (kindDirectives, constDirectives)
+ else SelectOf (kindDirectives, constDirectives)

let makeModule () =
reverseResults () ;
@@ -307,7 +304,7 @@

qualifiedsigname:
| signame
- { (makeSymbol $1, Preabsyn.IncludeAll) }
+ { (makeSymbol $1, Preabsyn.InclusiveSelect([],[])) }
| signame LCURLY renamings RCURLY
{ (makeSymbol $1, makeRenamingDirective ()) }

@@ -318,9 +315,9 @@

renaming:
| KIND tok
- { auxKindRenamingList := IncludeKind(makeSymbol
$2) :: !auxKindRenamingList }
+ { auxKindRenamingList := RenameKind(makeSymbol $2, makeSymbol
$2) :: !auxKindRenamingList }
| TYPE tok
- { auxConstRenamingList := IncludeType(makeSymbol
$2) :: !auxConstRenamingList }
+ { auxConstRenamingList := RenameType(makeSymbol $2, makeSymbol
$2) :: !auxConstRenamingList }
| KIND tok IMPLIES tok
{ auxKindRenamingList := RenameKind(makeSymbol $2, makeSymbol
$4) :: !auxKindRenamingList }
| TYPE tok IMPLIES tok
=======================================
--- /branches/RenamingRedux/source/compiler/preabsyn.ml Mon Dec 29 20:36:31
2014 UTC
+++ /branches/RenamingRedux/source/compiler/preabsyn.ml Wed Jan 28 07:00:33
2015 UTC
@@ -43,12 +43,9 @@
type renamingdirective =
RenameKind of psymbol * psymbol
| RenameType of psymbol * psymbol
- | IncludeType of psymbol
- | IncludeKind of psymbol

type renamingdirectives =
- IncludeAll
- | SelectOf of (renamingdirective list * renamingdirective list)
+ SelectOf of (renamingdirective list * renamingdirective list)
| InclusiveSelect of (renamingdirective list * renamingdirective list)

type pterm =
@@ -289,3 +286,6 @@

let getSymbol = function | Symbol(s,_,_) -> s
let getSymbolPos = function | Symbol(_,_,p) -> p
+
+let symbolEqual s1 s2 =
+ Symbol.equal (getSymbol s1) (getSymbol s2)
=======================================
--- /branches/RenamingRedux/source/compiler/preabsyn.mli Mon Dec 29
20:36:31 2014 UTC
+++ /branches/RenamingRedux/source/compiler/preabsyn.mli Wed Jan 28
07:00:33 2015 UTC
@@ -53,13 +53,10 @@
type renamingdirective =
RenameKind of psymbol * psymbol
| RenameType of psymbol * psymbol
- | IncludeType of psymbol
- | IncludeKind of psymbol

(* *)
type renamingdirectives =
- IncludeAll
- | SelectOf of (renamingdirective list * renamingdirective list)
+ SelectOf of (renamingdirective list * renamingdirective list)
| InclusiveSelect of (renamingdirective list * renamingdirective list)

(* Symbols for abstracted variables
@@ -229,6 +226,8 @@

val getModuleName : pmodule -> string
val getSignatureName : pmodule -> string
+
+val symbolEqual : psymbol -> psymbol -> bool
val getSymbol : psymbol -> symbol
val getSymbolPos : psymbol -> pos

=======================================
--- /branches/RenamingRedux/source/compiler/translate.ml Wed Jan 7
18:59:01 2015 UTC
+++ /branches/RenamingRedux/source/compiler/translate.ml Wed Jan 28
07:00:33 2015 UTC
@@ -1180,9 +1180,6 @@
in

(* Adds the inclusion to the original and reverse table *)
- let includeSym s _ (tbl, rev_tbl) =
- (Table.add s s tbl, Table.add s s rev_tbl) in
-
let includeDefault s _ (tbl, rev_tbl) =
match (Table.mem s tbl) with
true -> (tbl, rev_tbl)
@@ -1190,35 +1187,25 @@

let addRenaming (tbl, rev_tbl) renaming =
match renaming with
- | Preabsyn.IncludeKind psym ->
- let (Preabsyn.Symbol (sym,_,pos)) = psym in
- add sym sym ktable (tbl, rev_tbl) pos
- ("Cannot include unknown kind: '" ^ (Symbol.name sym) ^ "'")
| Preabsyn.RenameKind (old_psym,new_psym) ->
let (Preabsyn.Symbol (old_sym,_,old_pos)) = old_psym in
let (Preabsyn.Symbol (new_sym,_,new_pos)) = new_psym in
+ let renstring =
+ if (Symbol.equal old_sym new_sym) then "include" else "rename" in
add old_sym new_sym ktable (tbl, rev_tbl) old_pos
- ("Cannot rename unknown kind: '" ^ (Symbol.name old_sym) ^ "'")
- | Preabsyn.IncludeType psym ->
- let (Preabsyn.Symbol (sym,_,pos)) = psym in
- add sym sym ctable (tbl, rev_tbl) pos
- ("Cannot include unknown type: '" ^ (Symbol.name sym) ^ "'")
+ ("Cannot " ^ renstring ^ " unknown kind: '" ^ (Symbol.name
old_sym) ^ "'")
| Preabsyn.RenameType (old_psym,new_psym) ->
let (Preabsyn.Symbol (old_sym,_,old_pos)) = old_psym in
let (Preabsyn.Symbol (new_sym,_,new_pos)) = new_psym in
+ let renstring =
+ if (Symbol.equal old_sym new_sym) then "include" else "rename" in
add old_sym new_sym ctable (tbl, rev_tbl) old_pos
- ("Cannot rename unknown type: '" ^ (Symbol.name old_sym) ^ "'")
+ ("Cannot " ^ renstring ^ " unknown type: '" ^ (Symbol.name
old_sym) ^ "'")
in
(* build lookup tables *)
let (kRenamingTable, revKindRenTable, cRenamingTable, revConstRenTable) =
match renamings with
- | Preabsyn.IncludeAll ->
- let (kRenamingTable, kRevRenTable) =
- Table.fold includeSym ktable (Table.empty, Table.empty) in
- let (cRenamingTable, cRevRenTable) =
- Table.fold includeSym ctable (Table.empty, Table.empty) in
- (kRenamingTable, kRevRenTable, cRenamingTable, cRevRenTable)
- | Preabsyn.SelectOf (kindRenamings, typeRenamings) ->
+ Preabsyn.SelectOf (kindRenamings, typeRenamings) ->
let (kRenamingTable, kRevRenTable) = List.fold_left addRenaming
(Table.empty, Table.empty) kindRenamings in
let (cRenamingTable, cRevRenTable) = List.fold_left addRenaming
@@ -1451,6 +1438,87 @@
(List.fold_left merge ctable clist)
in

+ let sanitizeRenamings (accumsigs, usesigs) =
+ let isEmpty (_, renaming) =
+ match renaming with
+ Preabsyn.SelectOf([], []) -> true
+ | _ -> false in
+ let (emptyaccum, validaccum) = List.partition isEmpty accumsigs in
+ let (emptyuse, validuse) = List.partition isEmpty usesigs in
+ let warnEmpty (Preabsyn.Symbol(sym, _, pos), _) =
+ let name = Symbol.name sym in
+ Errormsg.warning pos ("Ignoring empty accumulation of " ^ name
^ ".") in
+
+ List.iter warnEmpty emptyaccum;
+ List.iter warnEmpty emptyuse;
+
+ let duplicateRenaming oldStmt newStmt =
+ match oldStmt with
+ Preabsyn.RenameType(old_sym, new_sym) ->
+ (match newStmt with
+ Preabsyn.RenameType(old_sym', new_sym') ->
+ ((Preabsyn.symbolEqual old_sym old_sym')
+ && (Preabsyn.symbolEqual new_sym new_sym'))
+ | _ -> false)
+ | Preabsyn.RenameKind(old_sym, new_sym) ->
+ (match newStmt with
+ Preabsyn.RenameKind(old_sym', new_sym') ->
+ ((Preabsyn.symbolEqual old_sym old_sym')
+ && (Preabsyn.symbolEqual new_sym new_sym'))
+ | _ -> false) in
+
+ let removeDuplicateKinds processed directive =
+ try
+ let duplicate = List.find (duplicateRenaming directive) processed
in
+ let duppos =
+ match duplicate with
+ Preabsyn.RenameKind(sym, _) -> Preabsyn.getSymbolPos sym
+ | _ -> Errormsg.none in
+ Errormsg.warning duppos "Ignoring duplicate renaming kind
statement";
+ processed
+ with Not_found ->
+ (directive :: processed)
+ in
+
+ let removeDuplicateTypes processed directive =
+ try
+ let duplicate = List.find (duplicateRenaming directive) processed
in
+ let duppos =
+ match duplicate with
+ Preabsyn.RenameType(sym, _) -> Preabsyn.getSymbolPos sym
+ | _ -> Errormsg.none in
+ Errormsg.warning duppos "Ignoring duplicate renaming type
statement";
+ processed
+ with Not_found ->
+ (directive :: processed)
+ in
+
+ let removeDuplicates (signature, renamings) =
+ match renamings with
+ Preabsyn.InclusiveSelect(kRenamings, cRenamings) ->
+ let newKRenamings =
+ List.fold_left removeDuplicateKinds [] kRenamings in
+ let newCRenamings =
+ List.fold_left removeDuplicateTypes [] cRenamings in
+ let newDirectives =
+ Preabsyn.InclusiveSelect(newKRenamings, newCRenamings) in
+ (signature, newDirectives)
+ | Preabsyn.SelectOf(kRenamings, cRenamings) ->
+ let newKRenamings =
+ List.fold_left removeDuplicateKinds [] kRenamings in
+ let newCRenamings =
+ List.fold_left removeDuplicateTypes [] cRenamings in
+ let newDirectives =
+ Preabsyn.SelectOf(newKRenamings, newCRenamings) in
+ (signature, newDirectives)
+ in
+
+ let validaccum = List.map removeDuplicates validaccum in
+ let validuse = List.map removeDuplicates validuse in
+
+ (validaccum, validuse)
+ in
+
(******************************************************************
*processAccumSigs:
* Convert a list of accumulated signature filenames into a list of
@@ -1511,6 +1579,8 @@
* switched to useonly.
******************************************************************)
let rec translateUseSigs = translateSigs [] false in
+
+ let (accumsigs, usesigs) = sanitizeRenamings (accumsigs, usesigs) in

(* Process accumulated signatures: *)
let sigs = processSigs accumsigs in