+ RTL support for raising exceptions in native wasm exceptions mode

rtl/wasm32/except_native.inc

@@ -15,3 +15,97 @@
 {****************************************************************************
                                 Exception support
 ****************************************************************************}
+
+{$ifdef FPC_HAS_FEATURE_THREADING}
+ThreadVar
+{$else FPC_HAS_FEATURE_THREADING}
+Var
+{$endif FPC_HAS_FEATURE_THREADING}
+  WASM_ExceptAddrStack   : PExceptAddr;
+  WASM_ExceptObjectStack : PExceptObject;
+  WASM_ExceptTryLevel    : ObjpasInt;
+
+{ This routine is called only from fpc_raiseexception, which uses ExceptTryLevel
+  flag to guard against repeated exceptions which can occur due to corrupted stack
+  or heap. }
+function WASM_PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer): PExceptObject;
+var
+  Newobj : PExceptObject;
+  _ExceptObjectStack : ^PExceptObject;
+  framebufsize,
+  framecount  : PtrInt;
+  frames      : PCodePointer;
+  prev_frame,
+  curr_frame  : Pointer;
+  curr_addr   : CodePointer;
+begin
+{$ifdef excdebug}
+  writeln ('In PushExceptObject');
+{$endif}
+  _ExceptObjectStack:=@WASM_ExceptObjectStack;
+  NewObj:=AllocMem(sizeof(TExceptObject));
+  NewObj^.Next:=_ExceptObjectStack^;
+  _ExceptObjectStack^:=NewObj;
+
+  NewObj^.FObject:=Obj;
+  NewObj^.Addr:=AnAddr;
+  if assigned(get_frame) then
+    begin
+      NewObj^.refcount:=0;
+
+      { Backtrace }
+      curr_frame:=AFrame;
+      curr_addr:=AnAddr;
+      frames:=nil;
+      framecount:=0;
+      framebufsize:=0;
+      { The frame pointer of this procedure is used as initial stack bottom value. }
+      prev_frame:=get_frame;
+      while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
+            (curr_frame<StackTop) do
+        Begin
+          prev_frame:=curr_frame;
+          get_caller_stackinfo(curr_frame,curr_addr);
+          if (curr_addr=nil) or
+             (curr_frame=nil) then
+            break;
+          if (framecount>=framebufsize) then
+            begin
+              inc(framebufsize,16);
+              reallocmem(frames,framebufsize*sizeof(codepointer));
+            end;
+          frames[framecount]:=curr_addr;
+          inc(framecount);
+        End;
+      NewObj^.framecount:=framecount;
+      NewObj^.frames:=frames;
+    end;
+  Result:=NewObj;
+end;
+
+{$define FPC_SYSTEM_HAS_RAISEEXCEPTION}
+procedure fpc_RaiseException (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer);[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
+var
+  _ExceptObjectStack : PExceptObject;
+  _ExceptAddrstack : PExceptAddr;
+begin
+{$ifdef excdebug}
+  writeln ('In RaiseException');
+{$endif}
+  if WASM_ExceptTryLevel<>0 then
+    Halt(217);
+  WASM_ExceptTryLevel:=1;
+  WASM_PushExceptObject(Obj,AnAddr,AFrame);
+  { if PushExceptObject causes another exception, the following won't be executed,
+    causing halt upon entering this routine recursively. }
+  WASM_ExceptTryLevel:=0;
+  //_ExceptAddrstack:=ExceptAddrStack;
+  //If _ExceptAddrStack=Nil then
+//    DoUnhandledException;
+  _ExceptObjectStack:=WASM_ExceptObjectStack;
+  if (RaiseProc <> nil) and (_ExceptObjectStack <> nil) then
+    with _ExceptObjectStack^ do
+      RaiseProc(FObject,Addr,FrameCount,Frames);
+//  longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
+  fpc_wasm32_throw_fpcexception;
+end;