Add fail_compilation tests

10 files changed, 204 insertions, 80 deletions

diff --git a/boot/semantic.cc b/boot/semantic.cc
index 29925c2..d8a3c41 100644
--- a/boot/semantic.cc
+++ b/boot/semantic.cc
@@ -35,6 +35,8 @@ namespace elna::boot
                 return "Type '" + identifier + "' not declared";
             case kind::already:
                 return "Symbol '" + identifier + "' has been already declared";
+            case kind::local_export:
+                return "Local symbol '" + this->identifier + "' cannot be exported";
             default:
                 __builtin_unreachable();
         }
@@ -906,6 +908,10 @@ namespace elna::boot
         {
             type->accept(this);
         }
+        for (procedure_declaration *const procedure : unit->procedures)
+        {
+            procedure->accept(this);
+        }
     }
 
     void declaration_visitor::visit(type_declaration *declaration)
@@ -919,6 +925,43 @@ namespace elna::boot
         }
     }
 
+    void declaration_visitor::visit(procedure_declaration *declaration)
+    {
+        if (!declaration->body.has_value())
+        {
+            return;
+        }
+        for (constant_declaration *const constant : declaration->body.value().constants())
+        {
+            constant->accept(this);
+        }
+        for (variable_declaration *const variable : declaration->body.value().variables())
+        {
+            variable->accept(this);
+        }
+    }
+
+    void declaration_visitor::visit(variable_declaration *declaration)
+    {
+        for (const identifier_definition& variable_identifier : declaration->identifiers)
+        {
+            if (variable_identifier.exported)
+            {
+                add_error<declaration_error>(declaration_error::kind::local_export,
+                        variable_identifier.name, declaration->position());
+            }
+        }
+    }
+
+    void declaration_visitor::visit(constant_declaration *declaration)
+    {
+        if (declaration->identifier.exported)
+        {
+                add_error<declaration_error>(declaration_error::kind::local_export,
+                        declaration->identifier.name, declaration->position());
+        }
+    }
+
     bool is_base_of(std::shared_ptr<record_type> base, std::shared_ptr<record_type> derived)
     {
         type current = derived->base;
diff --git a/cl.elna b/cl.elna
index b27c49d..c9754cc 100644
--- a/cl.elna
+++ b/cl.elna
@@ -14,14 +14,6 @@ type
 		first: ^ElnaListNode;
 		last: ^ElnaListNode
 	end
-	ElnaLocation = record
-		line: Word;
-		column: Word
-	end
-	ElnaPosition = record
-		start_location: ElnaLocation;
-		end_location: ElnaLocation
-	end
 
 	(**
 	 * List of intermediate representation items.
@@ -387,26 +379,6 @@ type
 		is_extern: Bool
 	end
 
-	ElnaLexerAction = (none, accumulate, skip, single, eof, finalize, composite, key_id, integer, delimited)
-
-	ElnaLexerTransition = record
-		action: ElnaLexerAction;
-		next_state: ElnaLexerState
-	end
-
-	ElnaLexerToken = record
-		kind: ElnaLexerKind;
-		start: String;
-		position: ElnaPosition
-	end
-	ElnaLexerCursor = record
-		state: ElnaLexerState;
-		start: ^Char;
-		finish: ^Char;
-		token: ^ElnaLexerToken;
-		position: ElnaPosition
-	end
-
 	ElnaTacOperator = (
 		get_address,
 		add,
@@ -644,16 +616,6 @@ var
 	temporary_variable_counter: Word
 	pseudo_counter: Word
 
-	stdout: Pointer
-	stderr: Pointer
-  stdin: Pointer
-
-proc free_and_nil(pointer: Pointer): Pointer
-begin
-	free(pointer);
-	return nil
-end
-
 (**
  * Adds a string to the global, read-only string storage.
  *
diff --git a/gcc/dg.exp b/gcc/dg.exp
index ce424d9..a490409 100644
--- a/gcc/dg.exp
+++ b/gcc/dg.exp
@@ -4,12 +4,12 @@
 # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 3 of the License, or
 # (at your option) any later version.
-# 
+#
 # This program is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
-# 
+#
 # You should have received a copy of the GNU General Public License
 # along with GCC; see the file COPYING3.  If not see
 # <http://www.gnu.org/licenses/>.
@@ -23,7 +23,7 @@ load_lib elna-dg.exp
 dg-init
 
 # Main loop.
-elna-dg-runtest [lsort [find $srcdir/$subdir *.elna]] "" ""
+elna-dg-runtest [lsort [find $srcdir/$subdir *.elna]]
 
 # All done.
 dg-finish
diff --git a/gcc/testlib/elna-dg.exp b/gcc/testlib/elna-dg.exp
index 06c81aa..ddebf58 100644
--- a/gcc/testlib/elna-dg.exp
+++ b/gcc/testlib/elna-dg.exp
@@ -4,12 +4,12 @@
 # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 3 of the License, or
 # (at your option) any later version.
-# 
+#
 # This program is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
-# 
+#
 # You should have received a copy of the GNU General Public License
 # along with GCC; see the file COPYING3.  If not see
 # <http://www.gnu.org/licenses/>.
@@ -20,8 +20,8 @@ load_lib gcc-dg.exp
 
 proc elna-dg-test { prog do_what extra_tool_flags } {
     set result \
-	[gcc-dg-test-1 elna_target_compile $prog $do_what $extra_tool_flags]
-    
+    [gcc-dg-test-1 elna_target_compile $prog $do_what $extra_tool_flags]
+
     set comp_output [lindex $result 0]
     set output_file [lindex $result 1]
 
@@ -35,35 +35,101 @@ proc elna-dg-prune { system text } {
 # Utility routines.
 
 #
-# Modified dg-runtest that can cycle through a list of optimization options
-# as c-torture does.
+# This procedure copies a test file from the source tree to the
+# build directory while rewriting elna-native directives to dejagnu
+# dg-* equivalents.
+#
+# Directives (inside (* ... *) comments):
 #
+#   (* @Error message *)      Expected compiler error on this line.
+#   (* @Flags args *)         Extra compiler flags.
+#
+# base - absolute path to the source directory, e.g. .../testsuite/elna.dg
+# test - relative path from testsuite, e.g. fail_compilation/file_name.elna
+#
+proc elna-convert-test { base test } {
+    set type [file dirname $test]
+    set target $test
 
-proc elna-dg-runtest { testcases flags default-extra-flags } {
-    global runtests
-    global dg-do-what-default
-    global tool
-
-    foreach testcase $testcases {
-	# If we're only testing specific files and this isn't one of them, skip it.
-	if {![runtest_file_p $runtests $testcase]} {
-	    continue
-	}
-	# Check the test directory to detect the test type and set the expectation.
-	set type [file tail [file dirname $testcase]]
+    # Opens a file in the build directory for writing and the source
+    # file for reading.
+    file mkdir $type
+    set fin [open $base/$target r]
+    set fout [open $target w]
+
+    # Reads the source test file line by line and replace directives with
+    # Elna equivalents using a regular expression.
+    while { [gets $fin line] >= 0 } {
+        regsub -all {\(\*\s*@Error\s+(.*?)\s*\*\)} $line {(* { dg-error "\1" } *)} line
+        regsub -all {\(\*\s*@Flags\s+(.*?)\s*\*\)} $line {(* { dg-additional-options "\1" } *)} line
+        puts $fout $line
+    }
+
+    close $fin
+
+    # Suppress excess output so stray diagnostics do not fail the test.
+    puts $fout "(* { dg-prune-output .* } *)"
+
+    # Emit category-specific expectation.
     switch $type {
-	    compilable {
-		set dg-do-what-default "compile"
-	    }
-	    runnable {
-		set dg-do-what-default "run"
-	    }
-	    default {
-		${tool}_fail $testcase "Unknown test type \"$type\""
-		return 0
-	    }
+        compilable {
+            # Assert that an output file was produced.
+            puts $fout "(* { dg-final { output-exists } } *)"
+        }
+        fail_compilation {
+            # Assert that no output file was produced.
+            puts $fout "(* { dg-final { output-exists-not } } *)"
+        }
+        # Other cases are handled automatically.
     }
-	verbose "Testing $type/[file tail $testcase]"
-	dg-test $testcase $flags ${default-extra-flags}
+
+    close $fout
+
+    # Reaches up one stack frame (into elna-dg-runtest) and links the
+    # caller's cleanup_extra_files variable to the local name cleanups.
+    upvar 1 cleanup_extra_files cleanups
+    # This ensures the converted file gets deleted after the test runs.
+    lappend cleanups $target
+
+    return $target
+}
+
+#
+# Main loop for convert each test to dejagnu.
+#
+proc elna-dg-runtest { testcases } {
+    global dg-do-what-default
+    # Saves dejagnu's current "what to do" setting so different test
+    # types don't leak settings between tests. 
+    set saved-dg-do-what-default ${dg-do-what-default}
+
+    foreach test $testcases {
+        set type [file tail [file dirname $test]]
+        set name [file tail $test]
+        set base [file dirname [file dirname $test]]
+
+        set cleanup_extra_files ""
+        # Calls the converter, $target receives the relative path of
+        # the converted file.
+        set target "[elna-convert-test $base $type/$name]"
+
+        switch $type {
+            runnable {
+                set dg-do-what-default "run"
+            }
+            compilable -
+            fail_compilation {
+                set dg-do-what-default "compile"
+            }
+        }
+
+        dg-test $target "" ""
+
+        foreach srcfile $cleanup_extra_files {
+            file delete $srcfile
+        }
+        file delete $target
     }
+
+    set dg-do-what-default ${saved-dg-do-what-default}
 }
diff --git a/include/elna/boot/semantic.h b/include/elna/boot/semantic.h
index c686cf8..b94d269 100644
--- a/include/elna/boot/semantic.h
+++ b/include/elna/boot/semantic.h
@@ -40,7 +40,8 @@ namespace elna::boot
         enum class kind
         {
             undeclared,
-            already
+            already,
+            local_export
         };
 
         declaration_error(const kind error_kind,
@@ -236,6 +237,9 @@ namespace elna::boot
         void visit(import_declaration *) override;
         void visit(unit *unit) override;
         void visit(type_declaration *declaration) override;
+        void visit(procedure_declaration *declaration) override;
+        void visit(variable_declaration *declaration) override;
+        void visit(constant_declaration *declaration) override;
     };
 
     /**
diff --git a/source/common.elna b/source/common.elna
index 7790faf..8bba90f 100644
--- a/source/common.elna
+++ b/source/common.elna
@@ -2,14 +2,17 @@
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. *)
 
-import cstring, cstdio
+import cstring, cstdio, cstdlib
 
 type
-  Identifier = [256]Char
-  TextLocation* = record
+  ElnaLocation* = record
     line: Word;
     column: Word
   end
+	ElnaPosition* = record
+		start_location: ElnaLocation;
+		end_location: ElnaLocation
+	end
 
 proc write*(fd: Int; buf: Pointer; Word: Int): Int
 extern
@@ -69,4 +72,10 @@ begin
   write_i(cast(value: Int))
 end
 
+proc free_and_nil*(pointer: Pointer): Pointer
+begin
+	free(pointer);
+	return nil
+end
+
 end.
diff --git a/source/lexer.elna b/source/lexer.elna
index 3b015ad..318d740 100644
--- a/source/lexer.elna
+++ b/source/lexer.elna
@@ -30,7 +30,9 @@ type
 		finish
 	)
   ElnaLexerToken* = record
-    kind: ElnaLexerKind
+    kind: ElnaLexerKind;
+		start: String; (* DEPRECATED *)
+		position: ElnaPosition
   end
   ElnaLexerBooleanToken* = record(ElnaLexerToken)
     value: Bool
@@ -44,15 +46,27 @@ type
   ElnaLexerIntegerToken* = record(ElnaLexerToken)
     value: Int
   end
+
   TransitionAction = proc(lexer: ^Lexer; token: ^ElnaLexerToken)
+  (* DEPRECATED should be replaced with TransitionAction (but keeping the type name). *)
+	ElnaLexerAction = (none, accumulate, skip, single, eof, finalize, composite, key_id, integer, delimited)
+
   ElnaLexerTransition = record
-    action: TransitionAction;
+    action: ElnaLexerAction;
     next_state: ElnaLexerState
   end
 
+	ElnaLexerCursor = record
+		state: ElnaLexerState;
+		start: ^Char;
+		finish: ^Char;
+		token: ^ElnaLexerToken;
+		position: ElnaPosition
+	end
+
   BufferPosition* = record
     iterator: ^Char;
-    location: TextLocation
+    location: ElnaLocation
   end
   Lexer* = record
     input: ^FILE;
diff --git a/source/main.elna b/source/main.elna
index 781d681..9a43fb8 100644
--- a/source/main.elna
+++ b/source/main.elna
@@ -17,7 +17,7 @@ type
     capacity: Word
   end
   SourceCode = record
-    position: TextLocation;
+    position: ElnaLocation;
 
     input: Pointer;
     empty: proc(stream: Pointer): Bool;
@@ -29,6 +29,11 @@ type
     data: ^^ElnaLexerToken
   end
 
+var
+	stdout: ^FILE
+	stderr: ^FILE
+  stdin: ^FILE
+
 (*
   Standard procedures.
 *)
@@ -826,7 +831,7 @@ begin
       fclose(source_file^.handle)
     end;
 
-    source_code.position := TextLocation(1u, 1u);
+    source_code.position := ElnaLocation(1u, 1u);
     source_code.input := source_file;
     source_code.empty := source_file_empty;
     source_code.head := source_file_head;
@@ -837,5 +842,14 @@ begin
   return return_code
 end
 
+proc initialize_global_state()
+begin
+	stdin := fdopen(0, "r\0".ptr);
+	stdout := fdopen(1, "w\0".ptr);
+	stderr := fdopen(2, "w\0".ptr)
+end
+
+begin
+  initialize_global_state();
   return process(count, parameters)
 end.
diff --git a/testsuite/fail_compilation/local_const_exported.elna b/testsuite/fail_compilation/local_const_exported.elna
new file mode 100644
index 0000000..c914af5
--- /dev/null
+++ b/testsuite/fail_compilation/local_const_exported.elna
@@ -0,0 +1,6 @@
+proc test_local_export()
+const
+  c* := 42 (* @Error Local symbol 'c' cannot be exported *)
+begin
+end
+end.
diff --git a/testsuite/fail_compilation/local_var_exported.elna b/testsuite/fail_compilation/local_var_exported.elna
new file mode 100644
index 0000000..77b408c
--- /dev/null
+++ b/testsuite/fail_compilation/local_var_exported.elna
@@ -0,0 +1,6 @@
+proc test_local_export()
+var
+  v* : Int (* @Error Local symbol 'v' cannot be exported *)
+begin
+end
+end.