Merge pull request #174 from peterdell/way2js4

Way2js4 - Fix SarLongint for handling FLOAT16

Author: tebe6502

src/.gitignore

@@ -1,5 +1,7 @@
 *.bak
 *.exe
+*.xex
+*.tmp
 *.log
 *.lps
 backup/

src/Makefile.bat

@@ -7,8 +7,11 @@ rem The script will use the FPC, MP and MADS version from there as reference.
 rem
 rem The script compiles "Test-0.pas" with FPC vs. the new MP.
 rem The script compiles a set of reference examples with the released and the new MP an validates that there are no differences in the binary output.
+rem The optional first argument to the scrip is "FAST" to only compile the first test.
 
 setlocal
+set TEST_MODE=%1
+
 set PATH=%WUDSN_TOOLS_FOLDER%\PAS\FPC.jac;%WUDSN_TOOLS_FOLDER%\ASM\MADS\bin\windows_x86_64;%PATH%
 set MP_FOLDER=%~dp0..
 set MP_SRC_FOLDER=%MP_FOLDER%\src
@@ -64,48 +67,79 @@ goto :eof
   set TEST_MP=%3
 
   set MP_INPUT_PAS=%TEST_MP%.pas
-  set MP_OUTPUT_ASM=%TEST_MP%.a65
+
+  set MP_OUTPUT_ASM_REF=%TEST_MP%-Reference.a65
   set MADS_OUTPUT_XEX_REF=%TEST_MP%-Reference.xex
-  echo %MADS_OUTPUT_XEX_REF%
+
   if %MP%==%WUDSN_MP_EXE% (
+    set MP_OUTPUT_ASM=%MP_OUTPUT_ASM_REF%
     set MADS_OUTPUT_XEX=%MADS_OUTPUT_XEX_REF%
   ) else (
+    set MP_OUTPUT_ASM=%TEST_MP%.a65
     set MADS_OUTPUT_XEX=%TEST_MP%.xex
   )
   pushd %TEST_FOLDER%
-  echo INFO: Compiling "%MP_INPUT_PAS%" in "%TEST_FOLDER%" with "%MP%".
+  echo INFO: Compiling "%MP_INPUT_PAS%" in "%TEST_FOLDER%" with "%MP%" to "%MP_OUTPUT_ASM%" and "%MADS_OUTPUT_XEX%".
   if exist %MP_OUTPUT_ASM% del %MP_OUTPUT_ASM%
-  %MP% -ipath:%MP_FOLDER%\lib %MP_INPUT_PAS%
+  %MP% -ipath:%MP_FOLDER%\lib %MP_INPUT_PAS% -o:%MP_OUTPUT_ASM%
   if errorlevel 1 goto :mp_error
   if exist %MP_OUTPUT_ASM% (
      if exist %MADS_OUTPUT_XEX% del %MADS_OUTPUT_XEX%
      mads %MP_OUTPUT_ASM% -x -i:%MP_FOLDER%\base -o:%MADS_OUTPUT_XEX%
      if exist %MADS_OUTPUT_XEX% (
        echo Starting test program "%MADS_OUTPUT_XEX%".
-       rem %MADS_OUTPUT_XEX%
+       %MADS_OUTPUT_XEX%	
      ) else (
        echo ERROR: MADS output file %MADS_OUTPUT_XEX% not created.
        pause
      ) 
   ) else (
     echo ERROR: MP output file %MP_OUTPUT_ASM% not created.
+    dir *.a65
     pause
   )
 
-  REM TODO Compare file if both files reference exists
-  if not "%MADS_OUTPUT_XEX%" == "%MADS_OUTPUT_XEX_REF%" (
-    if exist %MADS_OUTPUT_XEX% (
+  REM Compare file if both files reference exists
+  call :compare_files %MP_OUTPUT_ASM%   %MP_OUTPUT_ASM_REF%   TEXT
+  call :compare_files %MADS_OUTPUT_XEX% %MADS_OUTPUT_XEX_REF% BINARY
+  popd
+goto :eof
+
+rem Compare file if both files and reference file exist
+rem call :compare_files actual_file reference_file mode (TEXT or BINARY)
+:compare_files
+  set COMPARE_CURRENT_FILE=%1
+  set COMPARE_REFERENCE_FILE=%2
+  set COMPARE_MODE=%3
+  if not "%COMPARE_CURRENT_FILE%" == "%COMPARE_REFERENCE_FILE%" (
+    if exist %COMPARE_CURRENT_FILE% (
 
-      if exist %MADS_OUTPUT_XEX_REF% (
-        fc /b %MADS_OUTPUT_XEX%  %MADS_OUTPUT_XEX_REF%
-        if errorlevel 1 goto :fc_error
+      if exist %COMPARE_CURRENT_FILE% (
+        rem echo INFO: Comparing "%COMPARE_CURRENT_FILE%" with "%COMPARE_REFERENCE_FILE%" in mode %COMPARE_MODE%.
+        if "%COMPARE_MODE%"=="TEXT" (
+          rem Strip the compiler version difference.
+          more +2 "%COMPARE_CURRENT_FILE%"   > "%COMPARE_CURRENT_FILE%.tmp"
+          more +2 "%COMPARE_REFERENCE_FILE%" > "%COMPARE_REFERENCE_FILE%.tmp"
+          fc /L %COMPARE_CURRENT_FILE%.tmp %COMPARE_REFERENCE_FILE%.tmp
+          if errorlevel 1 (
+            echo ERROR: "%COMPARE_CURRENT_FILE%" and "%COMPARE_REFERENCE_FILE%" are different.
+            pause
+          )
+          del %COMPARE_CURRENT_FILE%.tmp %COMPARE_REFERENCE_FILE%.tmp
+        ) else (
+          fc /B %COMPARE_CURRENT_FILE% %COMPARE_REFERENCE_FILE%
+          if errorlevel 1 ( 
+            echo ERROR: "%COMPARE_CURRENT_FILE%" and "%COMPARE_REFERENCE_FILE%" are binary different.
+            pause
+          )
+        )
       ) else (
-        echo WARNING: Reference file "%MADS_OUTPUT_XEX_REF%" does not exist, no comparsion possible.
+        echo WARNING: Reference file "%COMPARE_REFERENCE_FILE%" does not exist, no comparsion possible.
       )
     )
   )
-  popd
-goto :eof
+  goto :eof
+
 
 :mp_error
   popd
@@ -114,22 +148,18 @@ goto :eof
   goto :eof
 
 
-:fc_error
-  popd
-  echo ERROR: %MADS_OUTPUT_XEX%  and %MADS_OUTPUT_XEX_REF% are binary different.
-  pause
-  goto :eof
-
- rem Run all tests with a given mp.exe.
- rem IN: Path to mp.exe
- rem
+rem Run all tests with a given mp.exe.
+rem IN: Path to mp.exe
+rem
 :run_tests
-rem    call :run_mp % %MP_SRC_FOLDER% Test-MPP
-rem    call :run_mp %1=%MP_FOLDER%\samples\a8\games\PacMad pacmadd
-    call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform fedorahat
-    call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform cannabis
-    call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform snowflake
-    call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform spline
-    call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform fern
-    goto :eof
+  call :run_mp %1 %MP_SRC_FOLDER% Test-MP
+  if "%TEST_MODE%"=="FAST" goto :eof
+  call :run_mp %1 %MP_FOLDER%\samples\a8\games\PacMad pacmad
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform fedorahat
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform cannabis
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform snowflake
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform snowflake_float16
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform spline
+  call :run_mp %1 %MP_FOLDER%\samples\a8\graph_crossplatform fern
+  goto :eof
 

src/Numbers.pas

@@ -80,22 +80,19 @@ procedure MoveTFloat(const ftmp: TFloat; var ConstVal: TNumber); overload;
 
 
 // ----------------------------------------------------------------------------
+// The https://www.freepascal.org/docs-html/rtl/system/sarlongint.html is currently
+// missing from the Javascript RTL. The native arithemtic shift right works the same
+// for 32-bit operands.
+// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Right_shift
 // ----------------------------------------------------------------------------
 
-// https://www.freepascal.org/docs-html/rtl/system/sarlongint.html
-function SarLongint(const Value: Longint; const Shift: Byte = 1): Longint;
+{$IFDEF PAS2JS}
+function SarLongint(const AValue: Longint; const Shift: Byte = 1): Longint;
 begin
-
-  if Value > 0 then
-  begin
-    Result := Value shr Shift;
-  end
-  else
-  begin
-    Result := -(-Value shr Shift);
-  end;
+asm
+  return (AValue>>Shift);
 end;
-
+{$ENDIF}
 
 // ----------------------------------------------------------------------------
 // ----------------------------------------------------------------------------
@@ -279,7 +276,6 @@ function CastToHalfSingle(const a: TNumber): TNumber;
 
   MoveTFloat(a, ftmp);
   Result := CardToHalf(ftmp);
-
 end;
 
 function Assign(const valType: Byte; const s: Single): TNumber;

src/Parser.pas

@@ -11,7 +11,7 @@ interface
 
 	function CompileType(i: Integer; out DataType: Byte; out NumAllocElements: cardinal; out AllocElementType: Byte): Integer;
 
-	function CompileConstExpression(i: Integer; out ConstVal: Int64; out ConstValType: Byte; VarType: Byte = INTEGERTOK; Err: Boolean = false; War: Boolean = true): Integer;
+	function CompileConstExpression(i: Integer; out ConstVal: Int64; out ConstValType: Byte; const VarType: Byte = INTEGERTOK; const Err: Boolean = false; const War: Boolean = true): Integer;
 
 	function CompileConstTerm(i: Integer; out ConstVal: Int64; out ConstValType: Byte): Integer;
 
@@ -408,10 +408,9 @@ function CompileConstFactor(i: Integer; out ConstVal: Int64; out ConstValType: B
 
 begin
 
- Result := i;
-
  ConstVal:=0;
  ConstValType:=0;
+ Result := i;
 
  j:=0;
 
@@ -1143,6 +1142,8 @@ function CompileConstTerm(i: Integer; out ConstVal: Int64; out ConstValType: Byt
   RightConstValType: Byte;
 begin
 
+ConstVal:=0;
+ConstValType:=0;
 Result:=i;
 
 j := CompileConstFactor(i, ConstVal, ConstValType);
@@ -1227,14 +1228,16 @@ function CompileConstTerm(i: Integer; out ConstVal: Int64; out ConstValType: Byt
 // ----------------------------------------------------------------------------
 
 
-function CompileSimpleConstExpression(i: Integer; out ConstVal: Int64; out ConstValType: Byte): Integer;
+function CompileSimpleConstExpression(const i: Integer; out ConstVal: Int64; out ConstValType: Byte): Integer;
 var
   j, k: Integer;
   RightConstVal: Int64;
   RightConstValType: Byte;
 
 begin
 
+ConstVal:=0;
+ConstValType:=0;
 Result:=i;
 
 if Tok[i].Kind in [PLUSTOK, MINUSTOK] then j := i + 1 else j := i;
@@ -1304,14 +1307,16 @@ function CompileSimpleConstExpression(i: Integer; out ConstVal: Int64; out Const
 // ----------------------------------------------------------------------------
 
 
-function CompileConstExpression(i: Integer; out ConstVal: Int64; out ConstValType: Byte; VarType: Byte = INTEGERTOK; Err: Boolean = false; War: Boolean = True): Integer;
+function CompileConstExpression(i: Integer; out ConstVal: Int64; out ConstValType: Byte; const VarType: Byte = INTEGERTOK; const Err: Boolean = false; const War: Boolean = True): Integer;
 var
   j: Integer;
   RightConstVal: Int64;
   RightConstValType: Byte;
   Yes: Boolean;
 begin
 
+ConstVal:=0;
+ConstValType:=0;
 Result:=i;
 
 i := CompileSimpleConstExpression(i, ConstVal, ConstValType);
@@ -1391,7 +1396,9 @@ procedure DefineIdent(ErrTokenIndex: Integer; Name: TString; Kind: Byte; DataTyp
 
   Inc(NumIdent);
 
+  // For debugging
   // Writeln('NumIdent='+IntToStr(NumIdent)+' ErrTokenIndex='+IntToStr(ErrTokenIndex)+' Name='+name+' Kind='+IntToStr( Kind)+' DataType='+IntToStr( DataType)+' NumAllocElements='+IntToStr( NumAllocElements)+' AllocElementType='+IntToStr( AllocElementType));
+
   if NumIdent > High(Ident) then
     Error(NumTok, 'Out of resources, IDENT');
 

src/Test-MP.pas

@@ -1,28 +1,70 @@
 program test;
-uses Crt;
 
+uses
+  Crt;
 
-procedure Assert(b: Boolean; s: String);
-begin
- if (b) then
- begin
-   Write('OK: ');
- end
- else
- begin
-   Write('ERROR:');
- end;
- Writeln(s);
-end;
-
-var i: Integer;
+  procedure Assert(b: Boolean; s: String); overload;
+  begin
+    if (b) then
+    begin
+      Write('OK: ');
+    end
+    else
+    begin
+      Write('ERROR: ');
+    end;
+    Writeln(s);
+  end;
+
+  procedure AssertEquals(actual: String; expected: String); overload;
+  begin
+    if (actual = expected) then
+    begin
+      Writeln('OK: Got ''', actual, ''' = ''', expected, '''.');
+    end
+    else
+    begin
+      Writeln('ERROR: Got ''', actual, ''' but expected ''', expected, '''.');
+    end;
+  end;
+
+  procedure TestExpressions;
+  var
+    i: Integer;
+  begin
+    i := 1;
+    Writeln('i:=1 equals ', i);
+    Inc(i);
+    Writeln('Inc(i) equals ', i);
+    Assert(i = 2, 'I=2');
+    Assert(1 + 1 = 2, '1+1=2');
+  end;
+
+  procedure TestFloats;
+  const
+    FLOAT16_CONST: Float16 = 0.288675135;  { SQRT(3) / 6 }
+    FLOAT16_CONST_STRING: String = '0.2890';
+
+    REAL_CONST: Real = 0.288675135;  { SQRT(3) / 6 }
+    REAL_CONST_STRING: String = '0.2890';
+
+    SINGLE_CONST: Single = 0.288675135;  { SQRT(3) / 6 }
+    SINGLE_CONST_STRING: String = '0.2890';
+
+  begin
+    AssertEquals(FloatToStr(FLOAT16_CONST), FLOAT16_CONST_STRING);
+    AssertEquals(FloatToStr(REAL_CONST), REAL_CONST_STRING);
+    AssertEquals(FloatToStr(SINGLE_CONST), SINGLE_CONST_STRING);
+  end;
+
+var
+  i: Integer;
+var
+  s, msg: String;
 begin
-  i:=1;
-  Writeln(i);
-  Inc(i);
-  Writeln(i);
-  Assert(i=2, 'I=2');
-  Assert(1+1=2, '1+1=2');
+  TestExpressions;
+  TestFloats;
+
   Writeln('Test completed. Press any key');
   repeat
   until KeyPressed;

src/TestLanguage.lpi

@@ -44,8 +44,20 @@
     <Parsing>
       <SyntaxOptions>
         <SyntaxMode Value="Delphi"/>
+        <IncludeAssertionCode Value="True"/>
       </SyntaxOptions>
     </Parsing>
+    <CodeGeneration>
+      <Checks>
+        <RangeChecks Value="True"/>
+        <OverflowChecks Value="True"/>
+        <StackChecks Value="True"/>
+      </Checks>
+      <VerifyObjMethodCallValidity Value="True"/>
+      <Optimizations>
+        <OptimizationLevel Value="0"/>
+      </Optimizations>
+    </CodeGeneration>
     <Linking>
       <Debugging>
         <DebugInfoType Value="dsDwarf2Set"/>