Merge branch source:main into main

packages/fcl-js/src/jssrcmap.pas

@@ -704,7 +704,7 @@ var
       buf.Write(s[1],length(s)*sizeof(char));
   end;
 
-  procedure AddChar(c: char);
+  procedure AddChar({%H-}c: char);
   begin
     buf.Write(c,sizeof(char));
   end;

packages/fcl-js/src/jswriter.pp

@@ -1,4 +1,4 @@
-{ ********************************************************************* 
+{ *********************************************************************
     This file is part of the Free Component Library (FCL)
     Copyright (c) 2016 Michael Van Canneyt.
        
@@ -29,10 +29,8 @@ uses
 Type
   {$ifdef pas2js}
   TJSWriterString = UnicodeString;
-  TJSWriterChar = WideChar;
   {$else}
   TJSWriterString = AnsiString;
-  TJSWriterChar = AnsiChar;
   {$endif}
 
   TTextWriter = class;
@@ -97,7 +95,7 @@ Type
   end;
   {$endif}
 
-  TBufferWriter_Buffer = Array of {$ifdef fpc}byte{$else}string{$endif};
+  TBufferWriter_Buffer = Array of {$IFDEF PAS2JS}String{$ELSE}Byte{$ENDIF};
 
   { TBufferWriter }
 
@@ -382,22 +380,24 @@ begin
   FCapacity:=FBufPos;
 end;
 {$else}
-Var
-  DesLen,MinLen : Integer;
+var
+  DesLen,MinLen : Cardinal;
 
 begin
-  Result:=Length(S)*SizeOf(TJSWriterChar);
-  if Result=0 then exit;
-  MinLen:=Result+integer(FBufPos);
-  If (MinLen>integer(Capacity)) then
+  Result := Length(S);
+  if Result = 0 then
+    Exit;
+
+  MinLen:=Result + FBufPos;
+  if MinLen > Capacity then
     begin
-    DesLen:=(FCapacity*3) div 2;
-    if DesLen>MinLen then
-      MinLen:=DesLen;
-    Capacity:=MinLen;
+    DesLen:=(FCapacity * 3) div 2;
+    if DesLen > MinLen then
+      MinLen := DesLen;
+    Capacity := MinLen;
     end;
-  Move(S[1],FBuffer[FBufPos],Result);
-  FBufPos:=integer(FBufPos)+Result;
+  Move(S[1], FBuffer[FBufPos], Result);
+  FBufPos:=FBufPos + Result;
 end;
 {$endif}
 

packages/fcl-passrc/src/pasresolver.pp

@@ -29909,7 +29909,8 @@ begin
       btIntSingle,
       btUIntSingle,
       btIntDouble,
-      btUIntDouble:
+      btUIntDouble,
+      btCurrency:
         begin
         Result:=TResEvalRangeInt.Create;
         TResEvalRangeInt(Result).ElKind:=revskInt;

packages/pastojs/src/pas2jslogger.pp

@@ -21,7 +21,7 @@
 unit Pas2jsLogger;
 
 {$mode objfpc}{$H+}
-
+{$WARN 6018 off : Unreachable code}
 {$i pas2js_defines.inc}
 
 interface

packages/pastojs/tests/tcmodules.pas

@@ -940,6 +940,7 @@ type
     procedure TestRangeChecks_StringIndex;
     procedure TestRangeChecks_TypecastInt;
     procedure TestRangeChecks_TypeHelperInt;
+    procedure TestRangeChecks_AssignCurrency;
 
     // Async/AWait
     Procedure TestAsync_Proc;
@@ -34809,6 +34810,52 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRangeChecks_AssignCurrency;
+begin
+  Scanner.Options:=Scanner.Options+[po_CAssignments];
+  StartProgram(false);
+  Add([
+  '{$R+}',
+  'var',
+  '  c: currency = 2.34;',
+  '  i: double;',
+  'procedure DoIt(p: currency);',
+  'begin',
+  '  c:=i;',
+  '  c+=i;',
+  '  c:=1;',
+  'end;',
+  '{$R-}',
+  'procedure DoSome;',
+  'begin',
+  '  DoIt(i);',
+  '  c:=i;',
+  '  c:=2;',
+  'end;',
+  'begin',
+  '{$R+}',
+  '']);
+  ConvertProgram;
+  CheckSource('TestRangeChecks_AssignCurrency',
+    LinesToStr([ // statements
+    'this.c = 2.34;',
+    'this.i = 0.0;',
+    'this.DoIt = function (p) {',
+    '  rtl.rc(p, -922337203685477, 922337203685477);',
+    '  $mod.c = rtl.rc(rtl.trunc($mod.i * 10000), -922337203685477, 922337203685477);',
+    '  rtl.rc($mod.c += rtl.trunc($mod.i * 10000), -922337203685477, 922337203685477);',
+    '  $mod.c = 10000;',
+    '};',
+    'this.DoSome = function () {',
+    '  $mod.DoIt($mod.i * 10000);',
+    '  $mod.c = rtl.trunc($mod.i * 10000);',
+    '  $mod.c = 20000;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestAsync_Proc;
 begin
   StartProgram(false);

packages/paszlib/fpmake.pp

@@ -20,7 +20,7 @@ begin
     P.Directory:=ADirectory;
 {$endif ALLPACKAGES}
     P.Version:='3.3.1';
-    P.OSes := P.OSes - [embedded,msdos,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc,sinclairql,wasi];
+    P.OSes := P.OSes - [embedded,msdos,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc,sinclairql];
     if Defaults.CPU=jvm then
       P.OSes := P.OSes - [java,android];
 

packages/paszlib/src/infblock.pas

@@ -1,7 +1,5 @@
 unit infblock;
 
-{$goto on}
-
 { infblock.h and
   infblock.c -- interpret and process block types to last block
   Copyright (C) 1995-1998 Mark Adler
@@ -172,10 +170,6 @@ end;
 function inflate_blocks (var s : inflate_blocks_state;
                          var z : z_stream;
                          r : integer) : integer;           { initial return code }
-label
-  start_btree, start_dtree,
-  start_blkdone, start_dry,
-  start_codes;
 
 var
   t : cardinal;               { temporary storage }
@@ -194,6 +188,350 @@ var
   i, j, c : cardinal;
 var
   cs : pInflate_codes_state;
+  
+  procedure do_btree;
+  
+  begin
+    while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do
+    begin
+      {NEEDBITS(3);}
+      while (k < 3) do
+      begin
+        {NEEDBYTE;}
+        if (n <> 0) then
+          r :=Z_OK
+        else
+        begin
+          {UPDATE}
+          s.bitb := b;
+          s.bitk := k;
+          z.avail_in := n;
+          Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
+          z.next_in := p;
+          s.write := q;
+          inflate_blocks := inflate_flush(s,z,r);
+          exit;
+        end;
+        dec(n);
+        b := b or (cardinal(p^) shl k);
+        Inc(p);
+        Inc(k, 8);
+      end;
+
+      s.sub.trees.blens^[border[s.sub.trees.index]] := cardinal(b) and 7;
+      Inc(s.sub.trees.index);
+      {DUMPBITS(3);}
+      b := b shr 3;
+      dec(k, 3);
+    end;
+    while (s.sub.trees.index < 19) do
+    begin
+      s.sub.trees.blens^[border[s.sub.trees.index]] := 0;
+      Inc(s.sub.trees.index);
+    end;
+    s.sub.trees.bb := 7;
+    t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb,
+                            s.sub.trees.tb, s.hufts^, z);
+    if (t <> Z_OK) then
+    begin
+      freemem(s.sub.trees.blens);
+      s.sub.trees.blens := nil;
+      r := t;
+      if (r = Z_DATA_ERROR) then
+        s.mode := BLKBAD;
+      { update pointers and return }
+      s.bitb := b;
+      s.bitk := k;
+      z.avail_in := n;
+      Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+      z.next_in := p;
+      s.write := q;
+      inflate_blocks := inflate_flush(s,z,r);
+      exit;
+    end;
+    s.sub.trees.index := 0;
+    {$IFDEF ZLIB_DEBUG}
+    Tracev('inflate:       bits tree ok');
+    {$ENDIF}
+    s.mode := DTREE;
+    { fall through again }
+  end;
+  
+  procedure do_dtree;
+  
+  begin
+    while TRUE do
+    begin
+      t := s.sub.trees.table;
+      if not (s.sub.trees.index < 258 +
+                                 (t and $1f) + ((t shr 5) and $1f)) then
+        break;
+      t := s.sub.trees.bb;
+      {NEEDBITS(t);}
+      while (k < t) do
+      begin
+        {NEEDBYTE;}
+        if (n <> 0) then
+          r :=Z_OK
+        else
+        begin
+          {UPDATE}
+          s.bitb := b;
+          s.bitk := k;
+          z.avail_in := n;
+          Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
+          z.next_in := p;
+          s.write := q;
+          inflate_blocks := inflate_flush(s,z,r);
+          exit;
+        end;
+        dec(n);
+        b := b or (cardinal(p^) shl k);
+        Inc(p);
+        Inc(k, 8);
+      end;
+
+      h := s.sub.trees.tb;
+      Inc(h, cardinal(b) and inflate_mask[t]);
+      t := h^.Bits;
+      c := h^.Base;
+
+      if (c < 16) then
+      begin
+        {DUMPBITS(t);}
+        b := b shr t;
+        dec(k, t);
+
+        s.sub.trees.blens^[s.sub.trees.index] := c;
+        Inc(s.sub.trees.index);
+      end
+      else { c = 16..18 }
+      begin
+        if c = 18 then
+        begin
+          i := 7;
+          j := 11;
+        end
+        else
+        begin
+          i := c - 14;
+          j := 3;
+        end;
+        {NEEDBITS(t + i);}
+        while (k < t + i) do
+        begin
+          {NEEDBYTE;}
+          if (n <> 0) then
+            r :=Z_OK
+          else
+          begin
+            {UPDATE}
+            s.bitb := b;
+            s.bitk := k;
+            z.avail_in := n;
+            Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
+            z.next_in := p;
+            s.write := q;
+            inflate_blocks := inflate_flush(s,z,r);
+            exit;
+          end;
+          dec(n);
+          b := b or (cardinal(p^) shl k);
+          Inc(p);
+          Inc(k, 8);
+        end;
+
+        {DUMPBITS(t);}
+        b := b shr t;
+        dec(k, t);
+
+        Inc(j, cardinal(b) and inflate_mask[i]);
+        {DUMPBITS(i);}
+        b := b shr i;
+        dec(k, i);
+
+        i := s.sub.trees.index;
+        t := s.sub.trees.table;
+        if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or
+           ((c = 16) and (i < 1)) then
+        begin
+          freemem(s.sub.trees.blens);
+          s.sub.trees.blens := nil;
+          s.mode := BLKBAD;
+          z.msg := 'invalid bit length repeat';
+          r := Z_DATA_ERROR;
+          { update pointers and return }
+          s.bitb := b;
+          s.bitk := k;
+          z.avail_in := n;
+          Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+          z.next_in := p;
+          s.write := q;
+          inflate_blocks := inflate_flush(s,z,r);
+          exit;
+        end;
+        if c = 16 then
+          c := s.sub.trees.blens^[i - 1]
+        else
+          c := 0;
+        repeat
+          s.sub.trees.blens^[i] := c;
+          Inc(i);
+          dec(j);
+        until (j=0);
+        s.sub.trees.index := i;
+      end;
+    end; { while }
+    s.sub.trees.tb := nil;
+    begin
+      bl := 9;         { must be <= 9 for lookahead assumptions }
+      bd := 6;         { must be <= 9 for lookahead assumptions }
+      t := s.sub.trees.table;
+      t := inflate_trees_dynamic(257 + (t and $1f),
+              1 + ((t shr 5) and $1f),
+              s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z);
+      freemem(s.sub.trees.blens);
+      s.sub.trees.blens := nil;
+      if (t <> Z_OK) then
+      begin
+        if (t = cardinal(Z_DATA_ERROR)) then
+          s.mode := BLKBAD;
+        r := t;
+        { update pointers and return }
+        s.bitb := b;
+        s.bitk := k;
+        z.avail_in := n;
+        Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+        z.next_in := p;
+        s.write := q;
+        inflate_blocks := inflate_flush(s,z,r);
+        exit;
+      end;
+      {$IFDEF ZLIB_DEBUG}
+      Tracev('inflate:       trees ok');
+      {$ENDIF}          
+      { c renamed to cs }
+      cs := inflate_codes_new(bl, bd, tl, td, z);
+      if (cs = nil) then
+      begin
+        r := Z_MEM_ERROR;
+        { update pointers and return }
+        s.bitb := b;
+        s.bitk := k;
+        z.avail_in := n;
+        Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+        z.next_in := p;
+        s.write := q;
+        inflate_blocks := inflate_flush(s,z,r);
+        exit;
+      end;
+      s.sub.decode.codes := cs;
+    end;
+    s.mode := CODES;
+  end;
+  
+  function do_codes: boolean;
+  
+  begin
+    { update pointers }
+    s.bitb := b;
+    s.bitk := k;
+    z.avail_in := n;
+    Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+    z.next_in := p;
+    s.write := q;
+
+    r := inflate_codes(s, z, r);
+    if (r <> Z_STREAM_END) then
+    begin
+      inflate_blocks := inflate_flush(s, z, r);
+      exit;
+    end;
+    r := Z_OK;
+    inflate_codes_free(s.sub.decode.codes, z);
+    { load local pointers }
+    p := z.next_in;
+    n := z.avail_in;
+    b := s.bitb;
+    k := s.bitk;
+    q := s.write;
+    if ptruint(q) < ptruint(s.read) then
+      m := cardinal(ptruint(s.read)-ptruint(q)-1)
+    else
+      m := cardinal(ptruint(s.zend)-ptruint(q));
+    {$IFDEF ZLIB_DEBUG}
+    if (ptruint(q) >= ptruint(s.read)) then
+      Tracev('inflate:       codes end '+
+          IntToStr(z.total_out + ptruint(q) - ptruint(s.read)) + ' total out')
+    else
+      Tracev('inflate:       codes end '+
+              IntToStr(z.total_out + ptruint(s.zend) - ptruint(s.read) +
+              ptruint(q) - ptruint(s.window)) +  ' total out');
+    {$ENDIF}
+    if (not s.last) then
+    begin
+      s.mode := ZTYPE;
+      exit(false); { break for switch statement in C-code }
+    end;
+    {$ifndef patch112}
+    if (k > 7) then           { return unused byte, if any }
+    begin
+      {$IFDEF ZLIB_DEBUG}
+      Assert(k < 16, 'inflate_codes grabbed too many bytes');
+      {$ENDIF}
+      dec(k, 8);
+      inc(n);
+      dec(p);                    { can always return one }
+    end;
+    {$endif}
+    s.mode := DRY;
+    do_codes:=true;
+  end;
+
+  procedure do_dry;
+  
+  begin
+    {FLUSH}
+    s.write := q;
+    r := inflate_flush(s,z,r);
+    q := s.write;
+
+    { not needed anymore, we are done:
+    if ptruint(q) < ptruint(s.read) then
+      m := cardinal(ptruint(s.read)-ptruint(q)-1)
+    else
+      m := cardinal(ptruint(s.zend)-ptruint(q));
+    }
+
+    if (s.read <> s.write) then
+    begin
+      { update pointers and return }
+      s.bitb := b;
+      s.bitk := k;
+      z.avail_in := n;
+      Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+      z.next_in := p;
+      s.write := q;
+      inflate_blocks := inflate_flush(s,z,r);
+      exit;
+    end;
+    s.mode := BLKDONE;
+  end;
+
+  procedure do_blkdone;
+    
+  begin
+    r := Z_STREAM_END;
+    { update pointers and return }
+    s.bitb := b;
+    s.bitk := k;
+    z.avail_in := n;
+    Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
+    z.next_in := p;
+    s.write := q;
+    inflate_blocks := inflate_flush(s,z,r);
+  end;
+  
 begin
   { copy input/output information to locals }
   p := z.next_in;
@@ -542,350 +880,50 @@ begin
         s.mode := BTREE;
         { fall trough case is handled by the while }
         { try GOTO for speed - Nomssi }
-        goto start_btree;
+        do_btree;
+        do_dtree;
+        if not do_codes then 
+          continue;
+        do_dry;
+        do_blkdone;
+        exit;
       end;
     BTREE:
       begin
-        start_btree:
-        while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do
-        begin
-          {NEEDBITS(3);}
-          while (k < 3) do
-          begin
-            {NEEDBYTE;}
-            if (n <> 0) then
-              r :=Z_OK
-            else
-            begin
-              {UPDATE}
-              s.bitb := b;
-              s.bitk := k;
-              z.avail_in := n;
-              Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
-              z.next_in := p;
-              s.write := q;
-              inflate_blocks := inflate_flush(s,z,r);
-              exit;
-            end;
-            dec(n);
-            b := b or (cardinal(p^) shl k);
-            Inc(p);
-            Inc(k, 8);
-          end;
-
-          s.sub.trees.blens^[border[s.sub.trees.index]] := cardinal(b) and 7;
-          Inc(s.sub.trees.index);
-          {DUMPBITS(3);}
-          b := b shr 3;
-          dec(k, 3);
-        end;
-        while (s.sub.trees.index < 19) do
-        begin
-          s.sub.trees.blens^[border[s.sub.trees.index]] := 0;
-          Inc(s.sub.trees.index);
-        end;
-        s.sub.trees.bb := 7;
-        t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb,
-                                s.sub.trees.tb, s.hufts^, z);
-        if (t <> Z_OK) then
-        begin
-          freemem(s.sub.trees.blens);
-          s.sub.trees.blens := nil;
-          r := t;
-          if (r = Z_DATA_ERROR) then
-            s.mode := BLKBAD;
-          { update pointers and return }
-          s.bitb := b;
-          s.bitk := k;
-          z.avail_in := n;
-          Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-          z.next_in := p;
-          s.write := q;
-          inflate_blocks := inflate_flush(s,z,r);
-          exit;
-        end;
-        s.sub.trees.index := 0;
-        {$IFDEF ZLIB_DEBUG}
-        Tracev('inflate:       bits tree ok');
-        {$ENDIF}
-        s.mode := DTREE;
-        { fall through again }
-        goto start_dtree;
+        do_btree;
+        do_dtree;
+        if not do_codes then
+          continue;
+        do_dry;
+        do_blkdone;
+        exit;
       end;
     DTREE:
       begin
-        start_dtree:
-        while TRUE do
-        begin
-          t := s.sub.trees.table;
-          if not (s.sub.trees.index < 258 +
-                                     (t and $1f) + ((t shr 5) and $1f)) then
-            break;
-          t := s.sub.trees.bb;
-          {NEEDBITS(t);}
-          while (k < t) do
-          begin
-            {NEEDBYTE;}
-            if (n <> 0) then
-              r :=Z_OK
-            else
-            begin
-              {UPDATE}
-              s.bitb := b;
-              s.bitk := k;
-              z.avail_in := n;
-              Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
-              z.next_in := p;
-              s.write := q;
-              inflate_blocks := inflate_flush(s,z,r);
-              exit;
-            end;
-            dec(n);
-            b := b or (cardinal(p^) shl k);
-            Inc(p);
-            Inc(k, 8);
-          end;
-
-          h := s.sub.trees.tb;
-          Inc(h, cardinal(b) and inflate_mask[t]);
-          t := h^.Bits;
-          c := h^.Base;
-
-          if (c < 16) then
-          begin
-            {DUMPBITS(t);}
-            b := b shr t;
-            dec(k, t);
-
-            s.sub.trees.blens^[s.sub.trees.index] := c;
-            Inc(s.sub.trees.index);
-          end
-          else { c = 16..18 }
-          begin
-            if c = 18 then
-            begin
-              i := 7;
-              j := 11;
-            end
-            else
-            begin
-              i := c - 14;
-              j := 3;
-            end;
-            {NEEDBITS(t + i);}
-            while (k < t + i) do
-            begin
-              {NEEDBYTE;}
-              if (n <> 0) then
-                r :=Z_OK
-              else
-              begin
-                {UPDATE}
-                s.bitb := b;
-                s.bitk := k;
-                z.avail_in := n;
-                Inc(z.total_in, ptruint(p)-ptruint(z.next_in));
-                z.next_in := p;
-                s.write := q;
-                inflate_blocks := inflate_flush(s,z,r);
-                exit;
-              end;
-              dec(n);
-              b := b or (cardinal(p^) shl k);
-              Inc(p);
-              Inc(k, 8);
-            end;
-
-            {DUMPBITS(t);}
-            b := b shr t;
-            dec(k, t);
-
-            Inc(j, cardinal(b) and inflate_mask[i]);
-            {DUMPBITS(i);}
-            b := b shr i;
-            dec(k, i);
-
-            i := s.sub.trees.index;
-            t := s.sub.trees.table;
-            if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or
-               ((c = 16) and (i < 1)) then
-            begin
-              freemem(s.sub.trees.blens);
-              s.sub.trees.blens := nil;
-              s.mode := BLKBAD;
-              z.msg := 'invalid bit length repeat';
-              r := Z_DATA_ERROR;
-              { update pointers and return }
-              s.bitb := b;
-              s.bitk := k;
-              z.avail_in := n;
-              Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-              z.next_in := p;
-              s.write := q;
-              inflate_blocks := inflate_flush(s,z,r);
-              exit;
-            end;
-            if c = 16 then
-              c := s.sub.trees.blens^[i - 1]
-            else
-              c := 0;
-            repeat
-              s.sub.trees.blens^[i] := c;
-              Inc(i);
-              dec(j);
-            until (j=0);
-            s.sub.trees.index := i;
-          end;
-        end; { while }
-        s.sub.trees.tb := nil;
-        begin
-          bl := 9;         { must be <= 9 for lookahead assumptions }
-          bd := 6;         { must be <= 9 for lookahead assumptions }
-          t := s.sub.trees.table;
-          t := inflate_trees_dynamic(257 + (t and $1f),
-                  1 + ((t shr 5) and $1f),
-                  s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z);
-          freemem(s.sub.trees.blens);
-          s.sub.trees.blens := nil;
-          if (t <> Z_OK) then
-          begin
-            if (t = cardinal(Z_DATA_ERROR)) then
-              s.mode := BLKBAD;
-            r := t;
-            { update pointers and return }
-            s.bitb := b;
-            s.bitk := k;
-            z.avail_in := n;
-            Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-            z.next_in := p;
-            s.write := q;
-            inflate_blocks := inflate_flush(s,z,r);
-            exit;
-          end;
-          {$IFDEF ZLIB_DEBUG}
-          Tracev('inflate:       trees ok');
-          {$ENDIF}          
-          { c renamed to cs }
-          cs := inflate_codes_new(bl, bd, tl, td, z);
-          if (cs = nil) then
-          begin
-            r := Z_MEM_ERROR;
-            { update pointers and return }
-            s.bitb := b;
-            s.bitk := k;
-            z.avail_in := n;
-            Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-            z.next_in := p;
-            s.write := q;
-            inflate_blocks := inflate_flush(s,z,r);
-            exit;
-          end;
-          s.sub.decode.codes := cs;
-        end;
-        s.mode := CODES;
-        { yet another falltrough }
-        goto start_codes;
+        do_dtree;
+        if not do_codes then 
+          continue;
+        do_dry;
+        do_blkdone;
+        exit;
       end;
     CODES:
       begin
-        start_codes:
-        { update pointers }
-        s.bitb := b;
-        s.bitk := k;
-        z.avail_in := n;
-        Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-        z.next_in := p;
-        s.write := q;
-
-        r := inflate_codes(s, z, r);
-        if (r <> Z_STREAM_END) then
-        begin
-          inflate_blocks := inflate_flush(s, z, r);
-          exit;
-        end;
-        r := Z_OK;
-        inflate_codes_free(s.sub.decode.codes, z);
-        { load local pointers }
-        p := z.next_in;
-        n := z.avail_in;
-        b := s.bitb;
-        k := s.bitk;
-        q := s.write;
-        if ptruint(q) < ptruint(s.read) then
-          m := cardinal(ptruint(s.read)-ptruint(q)-1)
-        else
-          m := cardinal(ptruint(s.zend)-ptruint(q));
-        {$IFDEF ZLIB_DEBUG}
-        if (ptruint(q) >= ptruint(s.read)) then
-          Tracev('inflate:       codes end '+
-              IntToStr(z.total_out + ptruint(q) - ptruint(s.read)) + ' total out')
-        else
-          Tracev('inflate:       codes end '+
-                  IntToStr(z.total_out + ptruint(s.zend) - ptruint(s.read) +
-                  ptruint(q) - ptruint(s.window)) +  ' total out');
-        {$ENDIF}
-        if (not s.last) then
-        begin
-          s.mode := ZTYPE;
-          continue; { break for switch statement in C-code }
-        end;
-        {$ifndef patch112}
-        if (k > 7) then           { return unused byte, if any }
-        begin
-          {$IFDEF ZLIB_DEBUG}
-          Assert(k < 16, 'inflate_codes grabbed too many bytes');
-          {$ENDIF}
-          dec(k, 8);
-          inc(n);
-          dec(p);                    { can always return one }
-        end;
-        {$endif}
-        s.mode := DRY;
-        { another falltrough }
-        goto start_dry;
+        if not do_codes then 
+          continue;
+        do_dry;
+        do_blkdone;
+        exit;
       end;
     DRY:
       begin
-        start_dry:
-        {FLUSH}
-        s.write := q;
-        r := inflate_flush(s,z,r);
-        q := s.write;
-
-        { not needed anymore, we are done:
-        if ptruint(q) < ptruint(s.read) then
-          m := cardinal(ptruint(s.read)-ptruint(q)-1)
-        else
-          m := cardinal(ptruint(s.zend)-ptruint(q));
-        }
-
-        if (s.read <> s.write) then
-        begin
-          { update pointers and return }
-          s.bitb := b;
-          s.bitk := k;
-          z.avail_in := n;
-          Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-          z.next_in := p;
-          s.write := q;
-          inflate_blocks := inflate_flush(s,z,r);
-          exit;
-        end;
-        s.mode := BLKDONE;
-        goto start_blkdone;
+        do_dry;
+        do_blkdone;
+        exit;
       end;
     BLKDONE:
       begin
-        start_blkdone:
-        r := Z_STREAM_END;
-        { update pointers and return }
-        s.bitb := b;
-        s.bitk := k;
-        z.avail_in := n;
-        Inc(z.total_in, ptruint(p) - ptruint(z.next_in));
-        z.next_in := p;
-        s.write := q;
-        inflate_blocks := inflate_flush(s,z,r);
+        do_blkdone;
         exit;
       end;
     BLKBAD:

packages/paszlib/src/zdeflate.pas

@@ -1,6 +1,12 @@
 unit ZDeflate;
 
+{$IFDEF CPUWASM}
+{$DEFINE NOGOTO}
+{$ENDIF}
+
+{$IFNDEF NOGOTO}
 {$goto on}
+{$ENDIF}
 
 { Orginal: deflate.h -- internal compression state
            deflate.c -- compress data using the deflation algorithm
@@ -1206,8 +1212,7 @@ end;
 function longest_match(var s : deflate_state;
                        cur_match : IPos  { current match }
                        ) : cardinal;
-label
-  nextstep;
+
 var
   chain_length : cardinal;    { max hash chain length }
   {register} scan : Pbyte;   { current string }
@@ -1230,6 +1235,19 @@ var
 {$endif}
 var
   MAX_DIST : cardinal;
+  
+{$IFNDEF NOGOTO}  
+label
+  nextstep;
+{$ELSE}  
+  Procedure DoNextStep; inline;
+  
+  begin
+    cur_match := prev^[cur_match and wmask];
+    dec(chain_length);
+  end;
+{$ENDIF}  
+
 begin
   chain_length := s.max_chain_length; { max hash chain length }
   scan := @(s.window^[s.strstart]);
@@ -1307,7 +1325,15 @@ distances are limited to MAX_DIST instead of WSIZE. }
   {$PUSH} {$R-}
         if (match[best_len-1]<>scan_end) or
            (match^ <> scan_start) then
+          {$IFDEF NOGOTO} 
+          begin
+            DoNextStep;
+            Continue;
+          end;  
+          {$ELSE}
           goto nextstep; {continue;}
+          {$ENDIF}
+          
   {$POP}
 
         { It is not necessary to compare scan[2] and match[2] since they are
@@ -1353,11 +1379,25 @@ distances are limited to MAX_DIST instead of WSIZE. }
         if (Pbytearray(match)^[best_len]   <> scan_end) or
            (Pbytearray(match)^[best_len-1] <> scan_end1) or
            (match^ <> scan^) then
+          {$IFDEF NOGOTO} 
+          begin
+            DoNextStep;
+            Continue;
+          end;
+          {$ELSE}
           goto nextstep; {continue;}
+          {$ENDIF}
   {$POP}
         inc(match);
         if (match^ <> Pbytearray(scan)^[1]) then
+          {$IFDEF NOGOTO} 
+          begin
+            DoNextStep;
+            Continue;
+          end;
+          {$ELSE}
           goto nextstep; {continue;}
+          {$ENDIF}
 
         { The check at best_len-1 can be removed because it will be made
           again later. (This heuristic is not always a win.)
@@ -1411,9 +1451,11 @@ distances are limited to MAX_DIST instead of WSIZE. }
 {$endif}
 {$pop}
         end;
+{$ifndef NOGOTO}        
     nextstep:
       cur_match := prev^[cur_match and wmask];
       dec(chain_length);
+{$ENDIF}      
     until (cur_match <= limit) or (chain_length = 0);
 
     if (cardinal(best_len) <= s.lookahead) then

packages/paszlib/tests/README.md

@@ -0,0 +1,13 @@
+
+The WebAssembly version of the tczipper test reads/writes temporary files in the current
+directory and in the TMP directory (this is the directory returned by gettempdir). 
+
+You must pre-open these directories so the wasm environment can write in it. 
+
+Using wasmtime this can be done as follows:
+
+wasmtime --dir=.  --dir=/tmp tczipper.wasm
+
+Similarly the testsingle test needs the same 2 directories:
+
+wasmtime --dir=. --dir=/tmp testsingle.wasm

packages/paszlib/tests/tczipper.pp

@@ -257,7 +257,6 @@ begin
     // ignore mess
   end;
   {$ENDIF}
-
   DestFile:=SysUtils.GetTempFileName('', 'CS2');
   z:=TZipper.Create;
   z.FileName:=DestFile;
@@ -454,8 +453,11 @@ begin
       ContentStreams.Add(ContentStream);
       // Start filenames at 1
       Zipper.Entries.AddFileEntry(TStringStream(ContentStreams.Items[i]), format('%U',[i+1]));
+      if (i mod 100)=0 then
+        write(i,' ');
       inc(i);
     end;
+    Writeln;
     Zipper.ZipAllFiles;
     {
     i:=0;
@@ -493,8 +495,11 @@ begin
       UnzipArchiveFiles.Clear;
       UnzipArchiveFiles.Add(Unzipper.Entries[i].ArchiveFileName);
       Unzipper.UnZipFiles(UnzipArchiveFiles);
+      if (i mod 100)=0 then
+        write(i,' ');
       inc(i);
     end;
+    writeln();
   finally
     CallBackHandler.Free;
     Unzipper.Free;

packages/paszlib/tests/tczstreamseek.pp

@@ -55,4 +55,5 @@ begin
       wasError := True;
   end;
   assert(wasError);
+  writeln('All OK');
 end.

rtl/inc/objpas.inc

@@ -1241,6 +1241,19 @@ begin
     FCallBack(Self,aMethod,aCount,aData); 
 end;
 
+function TInterfaceThunk.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
+
+begin
+  result:=longint(E_NOINTERFACE);
+  if (TMethod(FCallBack).Data<>Nil) then
+    // Query the object that created us, this is normally TVirtualInterface
+    // Take care: do not call QueryInterface, that would create a never-ending loop !!
+    if TObject(TMethod(FCallBack).Data).GetInterface(iid,obj) then
+      result:=S_OK;
+  if (Result<>S_OK) then
+    Result:=Inherited QueryInterface(iid,obj);
+end;
+
 function TInterfaceThunk.InterfaceVMTOffset : word;
 
 begin

rtl/inc/objpash.inc

@@ -356,6 +356,7 @@
        Private  
          FCallback : TThunkCallback;
        Protected  
+         function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
          Procedure Thunk(aMethod: Longint; aCount : Longint; aData : PArgData); virtual;
        Public  
          constructor create(aCallBack : TThunkCallback);
@@ -623,4 +624,4 @@ Type
   end;
   
 operator =(Left, Right: TPtrWrapper) c : Boolean;  
-operator <>(Left, Right: TPtrWrapper) c : Boolean;
+operator <>(Left, Right: TPtrWrapper) c : Boolean;