@live-codes/pascal-wasm 0.1.0

package/assets/rtl/system.pas

@@ -0,0 +1,1166 @@
+{
+    This file is part of the Pas2JS run time library.
+    Copyright (c) 2018 by Mattias Gaertner
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+unit System;
+
+{$mode objfpc}
+{$modeswitch externalclass}
+
+interface
+
+{$IFDEF NodeJS}
+var
+  LineEnding: string = #10;
+  sLineBreak: string = #10;
+{$ELSE}
+const
+  LineEnding = #10;
+  sLineBreak = LineEnding;
+{$ENDIF}
+
+Var
+  PathDelim : Char = '/';
+  AllowDirectorySeparators : Set of Char = ['/'];
+  AllowDriveSeparators : Set of Char = [':'];
+  ExtensionSeparator : Char = '.';
+
+const
+  MaxSmallint = 32767;
+  MinSmallint = -32768;
+  MaxShortInt = 127;
+  MinShortInt = -128;
+  MaxByte = $FF;
+  MaxWord = $FFFF;
+  MaxLongint  = $7fffffff;
+  MaxCardinal = LongWord($ffffffff);
+
+  Maxint = MaxLongint;
+  IsMultiThread = false;
+
+{*****************************************************************************
+                               Base types
+*****************************************************************************}
+type
+  HRESULT = Longint; // For Delphi compatibility
+  Int8 = ShortInt;
+  UInt8 = Byte;
+  Int16 = SmallInt;
+  UInt16 = Word;
+  Int32 = Longint;
+  UInt32 = LongWord;
+
+  Integer = LongInt;
+  Cardinal = LongWord;
+  DWord = LongWord;
+  SizeInt = NativeInt;
+  SizeUInt = NativeUInt;
+  PtrInt = NativeInt;
+  PtrUInt = NativeUInt;
+  ValSInt = NativeInt;
+  ValUInt = NativeUInt;
+  CodePointer = Pointer;
+  ValReal = Double;
+  Real = type Double;
+  Extended = type Double;
+
+  TDateTime = type double;
+  TTime = type TDateTime;
+  TDate = type TDateTime;
+
+  Int64 = type NativeInt unimplemented; // only 53 bits at runtime
+  UInt64 = type NativeUInt unimplemented; // only 52 bits at runtime
+  QWord = type NativeUInt unimplemented; // only 52 bits at runtime
+  Single = type Double unimplemented;
+  Comp = type NativeInt unimplemented;
+  NativeLargeInt = NativeInt;
+  NativeLargeUInt = NativeUInt;
+
+  UnicodeChar = Char;
+  UnicodeString = type String;
+  WideString = type String;
+  WideChar = Char;
+
+  TDynArrayIndex = NativeInt;
+  TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
+
+  TCompareOption = ({coLingIgnoreCase, coLingIgnoreDiacritic, }coIgnoreCase{,
+                    coIgnoreKanaType, coIgnoreNonSpace, coIgnoreSymbols, coIgnoreWidth,
+                    coLingCasing, coDigitAsNumbers, coStringSort});
+  TCompareOptions = set of TCompareOption;
+
+  generic TArray<T> = array of T;
+
+{*****************************************************************************
+            TObject, TClass, IUnknown, IInterface, TInterfacedObject
+*****************************************************************************}
+
+type
+  TGuid = record
+    D1: DWord;
+    D2: word;
+    D3: word;
+    D4: array[0..7] of byte;
+  end;
+  TGUIDString = type string;
+
+  TMethod = record
+    Code : CodePointer;
+    Data : Pointer;
+  end;
+
+  PMethod = ^TMethod;
+
+  TClass = class of TObject;
+
+  { TObject }
+  {$IFDEF ENABLE_DELPHI_RTTI}
+    {$RTTI INHERIT
+        METHODS([vcPublic, vcPublished])
+        FIELDS([vcPrivate,vcProtected, vcPublic,vcPublished])
+        PROPERTIES([vcPublic, vcPublished])
+    }
+  {$ENDIF}
+
+  {$DispatchField Msg} // enable checking message methods for record field name "Msg"
+  {$DispatchStrField MsgStr}
+  TObject = class
+  private
+    class var FClassName: String; external name '$classname';
+    class var FClassParent: TClass; external name '$ancestor';
+    class var FUnitName: String; external name '$module.$name';
+  public
+    constructor Create;
+    destructor Destroy; virtual;
+
+    // Free is using compiler magic.
+    // Reasons:
+    // 1. In JS calling obj.Free when obj=nil would crash.
+    // 2. In JS freeing memory requires to set all references to nil.
+    // Therefore any obj.free call is replaced by the compiler with some rtl magic.
+    procedure Free;
+
+    class function ClassType: TClass; assembler;
+    class property ClassName: String read FClassName;
+    class function ClassNameIs(const Name: string): boolean;
+    class property ClassParent: TClass read FClassParent;
+    class function InheritsFrom(aClass: TClass): boolean; assembler;
+    class property UnitName: String read FUnitName;
+    Class function MethodName(aCode : Pointer) : String;
+    Class function MethodAddress(aName : String) : Pointer;
+    Class Function FieldAddress(aName : String) : Pointer;
+    Class Function ClassInfo : Pointer;
+    class function QualifiedClassName: String;
+
+    procedure AfterConstruction; virtual;
+    procedure BeforeDestruction; virtual;
+
+    // message handling routines
+    procedure Dispatch(var aMessage); virtual;
+    procedure DispatchStr(var aMessage); virtual;
+    procedure DefaultHandler(var aMessage); virtual;
+    procedure DefaultHandlerStr(var aMessage); virtual;
+
+    function GetInterface(const iid: TGuid; out obj): boolean;
+    function GetInterface(const iidstr: String; out obj): boolean; inline;
+    function GetInterfaceByStr(const iidstr: String; out obj): boolean;
+    function GetInterfaceWeak(const iid: TGuid; out obj): boolean; // equal to GetInterface but the interface returned is not referenced
+
+    function Equals(Obj: TObject): boolean; virtual;
+    function ToString: String; virtual;
+  end;
+
+  { TCustomAttribute - base class of all user defined attributes. }
+
+  TCustomAttribute = class
+  end;
+  TCustomAttributeClass = class of TCustomAttribute;
+  TCustomAttributeArray = array of TCustomAttribute;
+
+const
+  { IInterface }
+  S_OK          = 0;
+  S_FALSE       = 1;
+  E_NOINTERFACE = -2147467262; // FPC: longint($80004002)
+  E_UNEXPECTED  = -2147418113; // FPC: longint($8000FFFF)
+  E_NOTIMPL     = -2147467263; // FPC: longint($80004001)
+
+type
+  {$Interfaces COM}
+  IUnknown = interface
+    ['{00000000-0000-0000-C000-000000000046}']
+    function QueryInterface(const iid: TGuid; out obj): Integer;
+    function _AddRef: Integer;
+    function _Release: Integer;
+  end;
+  IInterface = IUnknown;
+
+  {$M+}
+  IInvokable = interface(IInterface)
+  end;
+  {$M-}
+
+  { Enumerator support }
+  IEnumerator = interface(IInterface)
+    function GetCurrent: TObject;
+    function MoveNext: Boolean;
+    procedure Reset;
+    property Current: TObject read GetCurrent;
+  end;
+
+  IEnumerable = interface(IInterface)
+    function GetEnumerator: IEnumerator;
+  end;
+
+  { TInterfacedObject }
+
+  TInterfacedObject = class(TObject,IUnknown)
+  protected
+    fRefCount: Integer;
+    { implement methods of IUnknown }
+    function QueryInterface(const iid: TGuid; out obj): Integer; virtual;
+    function _AddRef: Integer; virtual;
+    function _Release: Integer; virtual;
+  public
+    procedure BeforeDestruction; override;
+    property RefCount: Integer read fRefCount;
+  end;
+  TInterfacedClass = class of TInterfacedObject;
+
+  { TAggregatedObject - sub or satellite object using same interface as controller }
+
+  TAggregatedObject = class(TObject)
+  private
+    fController: Pointer;
+    function GetController: IUnknown;
+  protected
+    { implement methods of IUnknown }
+    function QueryInterface(const iid: TGuid; out obj): Integer; virtual;
+    function _AddRef: Integer; virtual;
+    function _Release: Integer; virtual;
+  public
+    constructor Create(const aController: IUnknown); reintroduce;
+    property Controller: IUnknown read GetController;
+  end;
+
+  { TContainedObject }
+
+  TContainedObject = class(TAggregatedObject,IInterface)
+  protected
+    function QueryInterface(const iid: TGuid; out obj): Integer; override;
+  end;
+
+const
+  { for safe as operator support }
+  IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}';
+
+function GUIDToString(const GUID: TGUID): string; external name 'rtl.guidrToStr';
+
+{*****************************************************************************
+                                  RTTI support
+*****************************************************************************}
+type
+  // if you change the following enumeration type in any way
+  // you also have to change the rtl.js in an appropriate way !
+  TTypeKind = (
+    tkUnknown,  // 0
+    tkInteger,  // 1
+    tkChar,     // 2 in Delphi/FPC tkWChar, tkUChar
+    tkString,   // 3 in Delphi/FPC tkSString, tkWString or tkUString
+    tkEnumeration, // 4
+    tkSet,      // 5
+    tkDouble,   // 6
+    tkBool,     // 7
+    tkProcVar,  // 8  function or procedure
+    tkMethod,   // 9  proc var of object
+    tkArray,    // 10 static array
+    tkDynArray, // 11
+    tkRecord,   // 12
+    tkClass,    // 13
+    tkClassRef, // 14
+    tkPointer,  // 15
+    tkJSValue,  // 16
+    tkRefToProcVar, // 17  variable of procedure type
+    tkInterface, // 18
+    //tkObject,
+    //tkSString,tkLString,tkAString,tkWString,
+    //tkVariant,
+    //tkWChar,
+    //tkInt64,
+    //tkQWord,
+    //tkInterfaceRaw,
+    //tkUString,tkUChar,
+    tkHelper,   // 19
+    //tkFile,
+    tkExtClass  // 20
+    );
+  TTypeKinds = set of TTypeKind;
+
+const
+  tkFloat = tkDouble; // for compatibility with Delphi/FPC
+  tkProcedure = tkProcVar; // for compatibility with Delphi
+  tkAny = [Low(TTypeKind)..High(TTypeKind)];
+  tkMethods = [tkMethod];
+  tkProperties = tkAny-tkMethods-[tkUnknown];
+
+{*****************************************************************************
+                              Array of const support
+*****************************************************************************}
+
+const
+  vtInteger       = 0;
+  vtBoolean       = 1;
+  //vtChar          = 2; // Delphi/FPC: ansichar
+  vtExtended      = 3; // Note: double in pas2js, PExtended in Delphi/FPC
+  //vtString        = 4; // Delphi/FPC: PShortString
+  vtPointer       = 5;
+  //vtPChar         = 6;
+  vtObject        = 7;
+  vtClass         = 8;
+  vtWideChar      = 9;
+  //vtPWideChar     = 10;
+  //vtAnsiString    = 11;
+  vtCurrency      = 12; // Note: currency in pas2js, PCurrency in Delphi/FPC
+  //vtVariant       = 13;
+  vtInterface     = 14;
+  //vtWideString    = 15;
+  //vtInt64         = 16;
+  //vtQWord         = 17;
+  vtUnicodeString = 18;
+  // only pas2js, not in Delphi/FPC:
+  vtNativeInt     = 19;
+  vtJSValue       = 20;
+
+type
+  PVarRec = ^TVarRec;
+  TVarRec = record
+    VType: byte;
+    VJSValue: JSValue;
+    VInteger: LongInt external name 'VJSValue';
+    VBoolean: Boolean external name 'VJSValue';
+    VExtended: Double external name 'VJSValue';
+    VPointer: Pointer external name 'VJSValue';
+    VObject: TObject external name 'VJSValue';
+    VClass: TClass external name 'VJSValue';
+    VWideChar: WideChar external name 'VJSValue';
+    VCurrency: Currency external name 'VJSValue';
+    VInterface: Pointer external name 'VJSValue';
+    VUnicodeString: UnicodeString external name 'VJSValue';
+    VNativeInt: NativeInt external name 'VJSValue';
+  end;
+  TVarRecArray = array of TVarRec;
+
+function VarRecs: TVarRecArray; varargs;
+
+{*****************************************************************************
+                            Init / Exit / ExitProc
+*****************************************************************************}
+var
+  ExitCode: Integer; external name 'rtl.exitcode';
+  IsConsole: Boolean = {$IFDEF NodeJS}true{$ELSE}false{$ENDIF};
+  FirstDotAtFileNameStartIsExtension : Boolean = False;
+
+type
+  TOnParamCount = function: Longint;
+  TOnParamStr = function(Index: Longint): String;
+var
+  OnParamCount: TOnParamCount;
+  OnParamStr: TOnParamStr;
+
+function ParamCount: Longint;
+function ParamStr(Index: Longint): String;
+
+{*****************************************************************************
+                                 Math
+*****************************************************************************}
+const
+  PI: Double; external name 'Math.PI';
+  MathE: Double; external name 'Math.E'; // Euler's number
+  MathLN10: Double; external name 'Math.LN10'; // ln(10)
+  MathLN2: Double; external name 'Math.LN2'; // ln(2)
+  MathLog10E: Double; external name 'Math.LOG10E'; // log10(e)
+  MathLog2E: Double; external name 'Math.LOG2E'; // log2(e)
+  MathSQRT1_2: Double; external name 'Math.SQRT1_2'; // sqrt(0.5)
+  MathSQRT2: Double; external name 'Math.SQRT2'; // sqrt(2)
+
+function Abs(const A: integer): integer; overload; external name 'Math.abs';
+function Abs(const A: NativeInt): integer; overload; external name 'Math.abs';
+function Abs(const A: Double): Double; overload; external name 'Math.abs';
+function ArcTan(const A: Double): Double; external name 'Math.atan';
+function ArcTan2(const A,B: Double): Double; external name 'Math.atan2';
+function Cos(const A: Double): Double; external name 'Math.cos';
+function Exp(const A: Double): Double; external name 'Math.exp';
+function Frac(const A: Double): Double; assembler;
+function Ln(const A: Double): Double; external name 'Math.log';
+function Odd(const A: Integer): Boolean; assembler;
+function Random(const Range: Integer): Integer; overload; assembler;
+function Random: Double; overload; external name 'Math.random';
+function Round(const A: Double): NativeInt; external name 'Math.round';
+function Sin(const A: Double): Double; external name 'Math.sin';
+function Sqr(const A: Integer): Integer; assembler; overload;
+function Sqr(const A: Double): Double; assembler; overload;
+function sqrt(const A: Double): Double; external name 'Math.sqrt';
+function Trunc(const A: Double): NativeInt;
+
+{*****************************************************************************
+                          String functions
+*****************************************************************************}
+const
+  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
+
+function Int(const A: Double): double;
+function Copy(const S: string; Index, Size: Integer): String; assembler; overload;
+function Copy(const S: string; Index: Integer): String; assembler; overload;
+procedure Delete(var S: String; Index, Size: Integer); overload;
+function Pos(const Search, InString: String): Integer; assembler; overload;
+function Pos(const Search, InString: String; StartAt : Integer): Integer; assembler; overload;
+procedure Insert(const Insertion: String; var Target: String; Index: Integer); overload;
+function upcase(c : char) : char; assembler;
+function HexStr(Val: NativeInt; cnt: byte): string; external name 'rtl.hexStr'; overload;
+function binstr(val : NativeUInt; cnt : byte) : string;
+
+procedure val(const S: String; out NI : NativeInt; out Code: Integer); overload;
+procedure val(const S: String; out NI : NativeUInt; out Code: Integer); overload;
+procedure val(const S: String; out SI : ShortInt; out Code: Integer); overload;
+procedure val(const S: String; out B : Byte; out Code: Integer); overload;
+procedure val(const S: String; out SI : smallint; out Code: Integer); overload;
+procedure val(const S: String; out W : word; out Code : Integer); overload;
+procedure val(const S: String; out I : integer; out Code : Integer); overload;
+procedure val(const S: String; out C : Cardinal; out Code: Integer); overload;
+procedure val(const S: String; out d : double; out Code : Integer); overload;
+procedure val(const S: String; out b : boolean; out Code: Integer); overload;
+function StringOfChar(c: Char; l: NativeInt): String;
+
+{*****************************************************************************
+                          Other functions
+*****************************************************************************}
+procedure Write; varargs; // ToDo: should be compiler built-in function
+procedure Writeln; varargs; // ToDo: should be compiler built-in function
+
+Type
+  TConsoleHandler = Reference to Procedure (S : JSValue; NewLine : Boolean);
+Function SetWriteCallBack(H : TConsoleHandler) : TConsoleHandler;
+
+function Assigned(const V: JSValue): boolean; assembler; overload;
+function StrictEqual(const A: JSValue; const B): boolean; assembler;
+function StrictInequal(const A: JSValue; const B): boolean; assembler;
+
+implementation
+
+type
+
+  { TJSObj - simple access to JS Object }
+
+  TJSObj = class external name 'Object'
+  private
+    function GetProperties(Name: String): JSValue; external name '[]';
+    procedure SetProperties(Name: String; const AValue: JSValue); external name '[]';
+  public
+    //constructor new;
+    //function hasOwnProperty(prop: String): boolean;
+    property Properties[Name: String]: JSValue read GetProperties write SetProperties; default;
+  end;
+
+  TJSArray = class external name 'Array'
+  public
+    //length: nativeint;
+    //constructor new; overload;
+    function push(aElement : JSValue) : NativeInt; varargs;
+  end;
+
+  TJSArguments = class external name 'arguments'
+  private
+    FLength: NativeInt; external name 'length';
+    function GetElements(Index: NativeInt): JSValue; external name '[]';
+  public
+    property Length: NativeInt read FLength;
+    property Elements[Index: NativeInt]: JSValue read GetElements; default;
+  end;
+var
+  JSArguments: TJSArguments; external name 'arguments';
+
+function isNumber(const v: JSValue): boolean; external name 'rtl.isNumber';
+function isObject(const v: JSValue): boolean; external name 'rtl.isObject'; // true if not null and a JS Object
+function isString(const v: JSValue): boolean; external name 'rtl.isString';
+function isNaN(i: JSValue): boolean; external name 'isNaN'; // may result NaN
+
+// needed by ClassNameIs, the real SameText is in SysUtils
+function SameText(const s1, s2: String): Boolean; assembler;
+asm
+  return s1.toLowerCase() == s2.toLowerCase();
+end;
+
+function VarRecs: TVarRecArray;
+var
+  i: nativeint;
+  v: PVarRec;
+begin
+  Result:=nil;
+  while i<JSArguments.Length do
+    begin
+    new(v);
+    v^.VType:=byte(JSArguments[i]);
+    inc(i);
+    v^.VJSValue:=JSArguments[i];
+    inc(i);
+    TJSArray(Result).push(v^);
+    end;
+end;
+
+function ParamCount: Longint;
+begin
+  if Assigned(OnParamCount) then
+    Result:=OnParamCount()
+  else
+    Result:=0;
+end;
+
+function ParamStr(Index: Longint): String;
+begin
+  if Assigned(OnParamStr) then
+    Result:=OnParamStr(Index)
+  else if Index=0 then
+    Result:='js'
+  else
+    Result:='';
+end;
+
+function Frac(const A: Double): Double; assembler;
+asm
+  return A % 1;
+end;
+
+function Odd(const A: Integer): Boolean; assembler;
+asm
+  return A&1 != 0;
+end;
+
+function Random(const Range: Integer): Integer; assembler;
+asm
+  return Math.floor(Math.random()*Range);
+end;
+
+function Sqr(const A: Integer): Integer; assembler;
+asm
+  return A*A;
+end;
+
+function Sqr(const A: Double): Double; assembler;
+asm
+  return A*A;
+end;
+
+function Trunc(const A: Double): NativeInt; assembler;
+asm
+  if (!Math.trunc) {
+    Math.trunc = function(v) {
+      v = +v;
+      if (!isFinite(v)) return v;
+      return (v - v % 1) || (v < 0 ? -0 : v === 0 ? v : 0);
+    };
+  }
+  $mod.Trunc = Math.trunc;
+  return Math.trunc(A);
+end;
+
+function Copy(const S: string; Index, Size: Integer): String; assembler;
+asm
+  if (Index<1) Index = 1;
+  return (Size>0) ? S.substring(Index-1,Index+Size-1) : "";
+end;
+
+function Copy(const S: string; Index: Integer): String; assembler;
+asm
+  if (Index<1) Index = 1;
+  return S.substr(Index-1);
+end;
+
+procedure Delete(var S: String; Index, Size: Integer);
+var
+  h: String;
+begin
+  if (Index<1) or (Index>length(S)) or (Size<=0) then exit;
+  h:=S;
+  S:=copy(h,1,Index-1)+copy(h,Index+Size);
+end;
+
+function Pos(const Search, InString: String): Integer; assembler;
+asm
+  return InString.indexOf(Search)+1;
+end;
+
+function Pos(const Search, InString: String; StartAt : Integer): Integer; assembler; overload;
+asm
+  return InString.indexOf(Search,StartAt-1)+1;
+end;
+
+procedure Insert(const Insertion: String; var Target: String; Index: Integer);
+var
+  t: String;
+begin
+  if Insertion='' then exit;
+  t:=Target;
+  if Index<1 then
+    Target:=Insertion+t
+  else if Index>length(t) then
+    Target:=t+Insertion
+  else
+    Target:=copy(t,1,Index-1)+Insertion+copy(t,Index,length(t));
+end;
+
+var
+  WriteBuf: String;
+  WriteCallBack : TConsoleHandler;
+
+Function SetWriteCallBack(H : TConsoleHandler) : TConsoleHandler;
+
+begin
+  Result:=WriteCallBack;
+  WriteCallBack:=H;
+end;
+
+procedure Write;
+var
+  i: Integer;
+begin
+  for i:=0 to JSArguments.Length-1 do
+    if Assigned(WriteCallBack) then
+      WriteCallBack(JSArguments[i],False)
+    else
+      WriteBuf:=WriteBuf+String(JSArguments[i]);
+end;
+
+procedure Writeln;
+
+var
+  i,l: Integer;
+  s: String;
+
+begin
+  L:=JSArguments.Length-1;
+  if Assigned(WriteCallBack) then
+    begin
+    for i:=0 to L do
+      WriteCallBack(JSArguments[i],I=L);
+    end
+  else
+    begin
+    s:=WriteBuf;
+    for i:=0 to L do
+      s:=s+String(JSArguments[i]);
+    asm
+      console.log(s);
+    end;
+    WriteBuf:='';
+    end;
+end;
+
+function Int(const A: Double): double;
+
+begin
+  // trunc contains fix for missing Math.trunc in IE
+  Result:=Trunc(A);
+end;
+
+function Number(S: String): Double; external name 'Number';
+
+function valint(const S: String; MinVal, MaxVal: NativeInt; out Code: Integer): NativeInt;
+var
+  x: double;
+begin
+  if S='' then
+    begin
+    code:=1;
+    exit;
+    end;
+  x:=Number(S);
+  if isNaN(x) then
+    case copy(s,1,1) of
+    '$': x:=Number('0x'+copy(S,2));
+    '&': x:=Number('0o'+copy(S,2));
+    '%': x:=Number('0b'+copy(S,2));
+    else
+      Code:=1;
+      exit;
+    end;
+  if isNaN(x) or (X<>Int(X)) then
+    Code:=1
+  else if (x<MinVal) or (x>MaxVal) then
+    Code:=2
+  else
+    begin
+    Result:=Trunc(x);
+    Code:=0;
+    end;
+end;
+
+procedure val(const S: String; out NI : NativeInt; out Code: Integer);
+begin
+  NI:=valint(S,low(NI),high(NI),Code);
+end;
+
+procedure val(const S: String; out NI: NativeUInt; out Code: Integer);
+var
+  x : double;
+begin
+  if S='' then
+    begin
+    code:=1;
+    exit;
+    end;
+  x:=Number(S);
+  if isNaN(x) or (X<>Int(X)) or (X<0) then
+    Code:=1
+  else
+    begin
+    Code:=0;
+    NI:=Trunc(x);
+    end;
+end;
+
+procedure val(const S: String; out SI : ShortInt; out Code: Integer);
+begin
+  SI:=valint(S,low(SI),high(SI),Code);
+end;
+
+procedure val(const S: String; out SI: smallint; out Code: Integer);
+begin
+  SI:=valint(S,low(SI),high(SI),Code);
+end;
+
+procedure val(const S: String; out C: Cardinal; out Code: Integer);
+begin
+  C:=valint(S,low(C),high(C),Code);
+end;
+
+procedure val(const S: String; out B: Byte; out Code: Integer);
+begin
+  B:=valint(S,low(B),high(B),Code);
+end;
+
+procedure val(const S: String; out W: word; out Code: Integer);
+begin
+  W:=valint(S,low(W),high(W),Code);
+end;
+
+procedure val(const S : String; out I : integer; out Code : Integer);
+begin
+  I:=valint(S,low(I),high(I),Code);
+end;
+
+procedure val(const S : String; out d : double; out Code : Integer);
+Var
+  x: double;
+begin
+  if S='' then
+    begin
+    code:=1;
+    exit;
+    end;
+  x:=Number(S);
+  if isNaN(x) then
+    Code:=1
+  else
+    begin
+    Code:=0;
+    d:=x;
+    end;
+end;
+
+procedure val(const S: String; out b: boolean; out Code: Integer);
+begin
+  if SameText(S,'true') then
+    begin
+    Code:=0;
+    b:=true;
+    end
+  else if SameText(S,'false') then
+    begin
+    Code:=0;
+    b:=false;
+    end
+  else
+    Code:=1;
+end;
+
+function binstr(val : NativeUInt;cnt : byte) : string;
+var
+  i : Integer;
+begin
+  SetLength(Result,cnt);
+  for i:=cnt downto 1 do
+   begin
+     Result[i]:=char(48+val and 1);
+     val:=val shr 1;
+   end;
+end;
+
+function upcase(c : char) : char; assembler;
+asm
+  return c.toUpperCase();
+end;
+
+function StringOfChar(c: Char; l: NativeInt): String;
+var
+  i: Integer;
+begin
+  asm
+    if ((l>0) && c.repeat) return c.repeat(l);
+  end;
+  Result:='';
+  for i:=1 to l do Result:=Result+c;
+end;
+
+function Assigned(const V: JSValue): boolean; assembler;
+asm
+  return (V!=undefined) && (V!=null) && (!rtl.isArray(V) || (V.length > 0));
+end;
+
+function StrictEqual(const A: JSValue; const B): boolean; assembler;
+asm
+  return A === B;
+end;
+
+function StrictInequal(const A: JSValue; const B): boolean; assembler;
+asm
+  return A !== B;
+end;
+
+{ TContainedObject }
+
+function TContainedObject.QueryInterface(const iid: TGuid; out obj): Integer;
+begin
+  if GetInterface(iid,obj) then
+    Result:=S_OK
+  else
+    Result:=Integer(E_NOINTERFACE);
+end;
+
+{ TAggregatedObject }
+
+function TAggregatedObject.GetController: IUnknown;
+begin
+  Result := IUnknown(fController);
+end;
+
+function TAggregatedObject.QueryInterface(const iid: TGuid; out obj): Integer;
+begin
+  Result := IUnknown(fController).QueryInterface(iid, obj);
+end;
+
+function TAggregatedObject._AddRef: Integer;
+begin
+  Result := IUnknown(fController)._AddRef;
+end;
+
+function TAggregatedObject._Release: Integer;
+begin
+  Result := IUnknown(fController)._Release;
+end;
+
+constructor TAggregatedObject.Create(const aController: IUnknown);
+begin
+  inherited Create;
+  { do not keep a counted reference to the controller! }
+  fController := Pointer(aController);
+end;
+
+{ TInterfacedObject }
+
+function TInterfacedObject.QueryInterface(const iid: TGuid; out obj): Integer;
+begin
+  if GetInterface(iid,obj) then
+    Result:=S_OK
+  else
+    Result:=Integer(E_NOINTERFACE);
+end;
+
+function TInterfacedObject._AddRef: Integer;
+begin
+  inc(fRefCount);
+  Result:=fRefCount;
+end;
+
+function TInterfacedObject._Release: Integer;
+begin
+  dec(fRefCount);
+  Result:=fRefCount;
+  if fRefCount=0 then
+    Destroy;
+end;
+
+procedure TInterfacedObject.BeforeDestruction;
+begin
+  if fRefCount<>0 then
+    asm
+    rtl.raiseE('EHeapMemoryError');
+    end;
+end;
+
+{ TObject }
+
+constructor TObject.Create;
+begin
+
+end;
+
+destructor TObject.Destroy;
+begin
+
+end;
+
+procedure TObject.Free;
+begin
+  Destroy;
+end;
+
+class function TObject.ClassType: TClass; assembler;
+asm
+  return this;
+end;
+
+class function TObject.ClassNameIs(const Name: string): boolean;
+begin
+  Result:=SameText(Name,ClassName);
+end;
+
+class function TObject.InheritsFrom(aClass: TClass): boolean; assembler;
+asm
+  return (aClass!=null) && ((this==aClass) || aClass.isPrototypeOf(this));
+end;
+
+Class function TObject.MethodName(aCode : Pointer) : String;
+
+begin
+  Result:='';
+  if aCode=Nil then
+    exit;
+asm
+  if (typeof(aCode)!=='function') return "";
+  var i = 0;
+  var TI = this.$rtti;
+  if (rtl.isObject(aCode.scope)){
+    // callback
+    if (typeof aCode.fn === "string") return aCode.fn;
+    aCode = aCode.fn;
+  }
+  // Not a callback, check rtti
+  while ((Result === "") && (TI != null)) {
+    i = 0;
+    while ((Result === "") && (i < TI.methods.length)) {
+      if (this[TI.getMethod(i).name] === aCode)
+        Result=TI.getMethod(i).name;
+      i += 1;
+    };
+    if (Result === "") TI = TI.ancestor;
+  };
+  // return Result;
+end;
+end;
+
+Class function TObject.MethodAddress(aName : String) : Pointer;
+
+// We must do this in asm, because the typinfo unit is not available.
+begin
+  Result:=Nil;
+  if AName='' then
+    exit;
+asm
+  var i = 0;
+  var TI = this.$rtti;
+  var N = "";
+  var MN = "";
+  N = aName.toLowerCase();
+  while ((MN === "") && (TI != null)) {
+    i = 0;
+    while ((MN === "") && (i < TI.methods.length)) {
+      if (TI.getMethod(i).name.toLowerCase() === N) MN = TI.getMethod(i).name;
+      i += 1;
+    };
+    if (MN === "") TI = TI.ancestor;
+  };
+  if (MN !== "") Result = this[MN];
+//  return Result;
+end;
+end;
+
+class function TObject.FieldAddress(aName: String): Pointer;
+
+begin
+  Result:=Nil;
+  if aName='' then exit;
+  asm
+    var aClass = this.$class;
+    var ClassTI = null;
+    var myName = aName.toLowerCase();
+    var MemberTI = null;
+    while (aClass !== null) {
+      ClassTI = aClass.$rtti;
+      for (var i = 0, $end2 = ClassTI.fields.length - 1; i <= $end2; i++) {
+        MemberTI = ClassTI.getField(i);
+        if (MemberTI.name.toLowerCase() === myName) {
+           return MemberTI;
+        };
+      };
+      aClass = aClass.$ancestor ? aClass.$ancestor : null;
+    };
+  end;
+end;
+
+Class Function TObject.ClassInfo : Pointer;
+
+begin
+  // This works different from FPC/Delphi.
+  // We get the actual type info.
+  Result:=TypeInfo(Self);
+end;
+
+procedure TObject.AfterConstruction;
+begin
+
+end;
+
+procedure TObject.BeforeDestruction;
+begin
+
+end;
+
+procedure TObject.Dispatch(var aMessage);
+// aMessage is a record with an integer field 'Msg'
+var
+  aClass: TClass;
+  Msg: TJSObj absolute aMessage;
+  Id: jsvalue;
+begin
+  if not isObject(Msg) then exit;
+  Id:=Msg['Msg'];
+  if not isNumber(Id) then exit;
+  aClass:=ClassType;
+  while aClass<>nil do
+    begin
+    asm
+      var Handlers = aClass.$msgint;
+      if (rtl.isObject(Handlers) && Handlers.hasOwnProperty(Id)){
+        this[Handlers[Id]](aMessage);
+        return;
+      }
+    end;
+    aClass:=aClass.ClassParent;
+    end;
+  DefaultHandler(aMessage);
+end;
+
+procedure TObject.DispatchStr(var aMessage);
+// aMessage is a record with a string field 'MsgStr'
+var
+  aClass: TClass;
+  Msg: TJSObj absolute aMessage;
+  Id: jsvalue;
+begin
+  if not isObject(Msg) then exit;
+  Id:=Msg['MsgStr'];
+  if not isString(Id) then exit;
+  aClass:=ClassType;
+  while (aClass<>Nil) do
+    begin
+    asm
+      var Handlers = aClass.$msgstr;
+      if (rtl.isObject(Handlers) && Handlers.hasOwnProperty(Id)){
+        this[Handlers[Id]](aMessage);
+        return;
+      }
+    end;
+    aClass:=aClass.ClassParent;
+    end;
+  DefaultHandlerStr(aMessage);
+end;
+
+procedure TObject.DefaultHandler(var aMessage);
+begin
+  if jsvalue(TMethod(aMessage)) then ;
+end;
+
+procedure TObject.DefaultHandlerStr(var aMessage);
+begin
+  if jsvalue(TMethod(aMessage)) then ;
+end;
+
+function TObject.GetInterface(const iid: TGuid; out obj): boolean;
+begin
+  asm
+    var i = iid.$intf;
+    if (i){
+      // iid is the private TGuid of an interface
+      i = rtl.getIntfG(this,i.$guid,2);
+      if (i){
+        obj.set(i);
+        return true;
+      }
+    }
+  end;
+  Result := GetInterfaceByStr(GUIDToString(iid),obj);
+end;
+
+function TObject.GetInterface(const iidstr: String; out obj): boolean;
+begin
+  Result := GetInterfaceByStr(iidstr,obj);
+end;
+
+function TObject.GetInterfaceByStr(const iidstr: String; out obj): boolean;
+begin
+  Result:=false;
+  if not TJSObj(IObjectInstance)['$str'] then
+    TJSObj(IObjectInstance)['$str']:=GUIDToString(IObjectInstance);
+  if iidstr = TJSObj(IObjectInstance)['$str'] then
+    begin
+    obj:=Self;
+    exit(true);
+    end;
+  asm
+    var i = rtl.getIntfG(this,iidstr,2);
+    obj.set(i);
+    Result=(i!==null);
+  end;
+end;
+
+function TObject.GetInterfaceWeak(const iid: TGuid; out obj): boolean;
+begin
+  Result:=GetInterface(iid,obj);
+  asm
+    if (Result){
+      var o = obj.get();
+      if (o.$kind==='com'){
+        o._Release();
+      }
+    }
+  end;
+end;
+
+function TObject.Equals(Obj: TObject): boolean;
+begin
+  Result:=Obj=Self;
+end;
+
+function TObject.ToString: String;
+begin
+  Result:=ClassName;
+end;
+
+class function TObject.QualifiedClassName: String;
+begin
+  Result := UnitName + '.' + ClassName;
+end;
+
+initialization
+  ExitCode:=0; // set it here, so that WPO does not remove it
+
+end.
+