paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 10:45:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/z80@45056 -
This commit is contained in:
nickysn 2020-04-24 19:16:32 +00:00
commit 26ba399a66
10 changed files with 694 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -13267,6 +13267,7 @@ tests/tbs/tb0667.pp svneol=native#text/pascal
tests/tbs/tb0668a.pp svneol=native#text/pascal
tests/tbs/tb0668b.pp svneol=native#text/pascal
tests/tbs/tb0669.pp svneol=native#text/pascal
tests/tbs/tb0670.pp svneol=native#text/pascal
tests/tbs/ub0060.pp svneol=native#text/plain
tests/tbs/ub0069.pp svneol=native#text/plain
tests/tbs/ub0119.pp svneol=native#text/plain

57
compiler/defutil.pas
View File

@ -349,6 +349,10 @@ interface
signdness, the result will also get that signdness }
function get_common_intdef(ld, rd: torddef; keep_sign_if_equal: boolean): torddef;
{ # calculates "not v" based on the provided def; returns true if the def
was negatable, false otherwise }
function calc_not_ordvalue(var v:Tconstexprint; var def:tdef):boolean;
{ # returns whether the type is potentially a valid type of/for an "univ" parameter
(basically: it must have a compile-time size) }
function is_valid_univ_para_type(def: tdef): boolean;
@ -1747,6 +1751,59 @@ implementation
end;
function calc_not_ordvalue(var v:Tconstexprint;var def:tdef):boolean;
begin
if not assigned(def) or (def.typ<>orddef) then
exit(false);
result:=true;
case torddef(def).ordtype of
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64:
v:=byte(not(boolean(int64(v))));
bool8bit,
bool16bit,
bool32bit,
bool64bit:
begin
if v=0 then
v:=-1
else
v:=0;
end;
uchar,
uwidechar,
u8bit,
s8bit,
u16bit,
s16bit,
s32bit,
u32bit,
s64bit,
u64bit:
begin
{ unsigned, equal or bigger than the native int size? }
if (torddef(def).ordtype in [u64bit,u32bit,u16bit,u8bit,uchar,uwidechar]) and
(is_nativeord(def) or is_oversizedord(def)) then
begin
{ Delphi-compatible: not dword = dword (not word = longint) }
{ Extension: not qword = qword }
v:=qword(not qword(v));
{ will be truncated by the ordconstnode for u32bit }
end
else
begin
v:=int64(not int64(v));
def:=get_common_intdef(torddef(def),torddef(sinttype),false);
end;
end;
else
result:=false;
end;
end;
function is_valid_univ_para_type(def: tdef): boolean;
begin
result:=

48
compiler/nmat.pas
View File

@ -1176,52 +1176,8 @@ implementation
begin
v:=tordconstnode(left).value;
def:=left.resultdef;
case torddef(left.resultdef).ordtype of
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64:
v:=byte(not(boolean(int64(v))));
bool8bit,
bool16bit,
bool32bit,
bool64bit:
begin
if v=0 then
v:=-1
else
v:=0;
end;
uchar,
uwidechar,
u8bit,
s8bit,
u16bit,
s16bit,
s32bit,
u32bit,
s64bit,
u64bit:
begin
{ unsigned, equal or bigger than the native int size? }
if (torddef(left.resultdef).ordtype in [u64bit,u32bit,u16bit,u8bit,uchar,uwidechar]) and
(is_nativeord(left.resultdef) or is_oversizedord(left.resultdef)) then
begin
{ Delphi-compatible: not dword = dword (not word = longint) }
{ Extension: not qword = qword }
v:=qword(not qword(v));
{ will be truncated by the ordconstnode for u32bit }
end
else
begin
v:=int64(not int64(v));
def:=get_common_intdef(torddef(left.resultdef),torddef(sinttype),false);
end;
end;
else
CGMessage(type_e_mismatch);
end;
if not calc_not_ordvalue(v,def) then
CGMessage(type_e_mismatch);
{ not-nodes are not range checked by the code generator -> also
don't range check while inlining; the resultdef is a bit tricky
though: the node's resultdef gets changed in most cases compared

40
compiler/scanner.pas
View File

@ -931,6 +931,7 @@ type
function isBoolean: Boolean;
function asBool: Boolean;
function asInt: Integer;
function asInt64: Int64;
function asStr: String;
destructor destroy; override;
end;
@ -1145,6 +1146,12 @@ type
begin
if isBoolean then
result:=texprvalue.create_bool(not asBool)
else if is_ordinal(def) then
begin
result:=texprvalue.create_ord(value.valueord);
result.def:=def;
calc_not_ordvalue(result.value.valueord,result.def);
end
else
begin
error('Boolean', 'NOT');
@ -1161,6 +1168,14 @@ type
v.error('Boolean','OR');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord or v.value.valueord)
else
begin
v.error('Ordinal','OR');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','OR');
@ -1177,6 +1192,14 @@ type
v.error('Boolean','XOR');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord xor v.value.valueord)
else
begin
v.error('Ordinal','XOR');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','XOR');
@ -1193,6 +1216,14 @@ type
v.error('Boolean','AND');
result:=texprvalue.create_error;
end
else if is_ordinal(def) then
if is_ordinal(v.def) then
result:=texprvalue.create_ord(value.valueord and v.value.valueord)
else
begin
v.error('Ordinal','AND');
result:=texprvalue.create_error;
end
else
begin
error('Boolean','AND');
@ -1328,12 +1359,12 @@ type
function texprvalue.isBoolean: Boolean;
var
i: integer;
i: int64;
begin
result:=is_boolean(def);
if not result and is_integer(def) then
begin
i:=asInt;
i:=asInt64;
result:=(i=0)or(i=1);
end;
end;
@ -1348,6 +1379,11 @@ type
result:=value.valueord.svalue;
end;
function texprvalue.asInt64: Int64;
begin
result:=value.valueord.svalue;
end;
function texprvalue.asStr: String;
var
b:byte;

46
packages/fcl-json/src/fpjsonrtti.pp
View File

@ -54,8 +54,6 @@ Type
function IsChildStored: boolean;
function StreamChildren(AComp: TComponent): TJSONArray;
protected
Function GetPropertyList(aObject : TObject) : TPropInfoList; virtual;
Procedure StreamProperties(aObject : TObject;aList : TPropInfoList; aParent : TJSONObject); virtual;
function StreamClassProperty(Const AObject: TObject): TJSONData; virtual;
Function StreamProperty(Const AObject : TObject; Const PropertyName : String) : TJSONData;
Function StreamProperty(Const AObject : TObject; PropertyInfo : PPropInfo) : TJSONData;
@ -757,36 +755,12 @@ begin
Result:=(GetChildProperty<>'Children');
end;
Function TJSONStreamer.GetPropertyList(aObject : TObject) : TPropInfoList;
begin
result:=TPropInfoList.Create(AObject,tkProperties);
end;
Procedure TJSONStreamer.StreamProperties(aObject : TObject;aList : TPropInfoList; aParent : TJSONObject);
Var
I : Integer;
PD : TJSONData;
begin
For I:=0 to aList.Count-1 do
begin
PD:=StreamProperty(AObject,aList.Items[i]);
If (PD<>Nil) then
begin
if jsoLowerPropertyNames in Options then
aParent.Add(LowerCase(aList.Items[I]^.Name),PD)
else
aParent.Add(aList.Items[I]^.Name,PD);
end;
end;
end;
function TJSONStreamer.ObjectToJSON(Const AObject: TObject): TJSONObject;
Var
PIL : TPropInfoList;
PD : TJSONData;
I : Integer;
begin
Result:=Nil;
@ -806,12 +780,20 @@ begin
Result.Add('Objects', StreamTList(TList(AObject)))
else
begin
PIL:=GetPropertyList(aObject);
// TPropInfoList.Create(AObject,tkProperties);
PIL:=TPropInfoList.Create(AObject,tkProperties);
try
StreamProperties(aObject,PIL,Result);
For I:=0 to PIL.Count-1 do
begin
PD:=StreamProperty(AObject,PIL.Items[i]);
If (PD<>Nil) then begin
if jsoLowerPropertyNames in Options then
Result.Add(LowerCase(PIL.Items[I]^.Name),PD)
else
Result.Add(PIL.Items[I]^.Name,PD);
end;
end;
finally
FreeAndNil(Pil);
FReeAndNil(Pil);
end;
If (jsoStreamChildren in Options) and (AObject is TComponent) then
Result.Add(ChildProperty,StreamChildren(TComponent(AObject)));

24
packages/fcl-passrc/src/pasresolver.pp
View File

@ -5155,6 +5155,7 @@ var
Proc: TPasProcedure;
Store, SameScope: Boolean;
ProcScope: TPasProcedureScope;
CurResolver: TPasResolver;
procedure CountProcInSameScope;
begin
@ -5188,7 +5189,7 @@ begin
fpkProc:
// proc hides a non proc
if (Data^.Proc.GetModule=El.GetModule) then
// forbidden within same module
// forbidden within same CurModule
RaiseMsg(20170216151649,nDuplicateIdentifier,sDuplicateIdentifier,
[El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType)
else
@ -5205,8 +5206,15 @@ begin
end;
fpkMethod:
// method hides a non proc
RaiseMsg(20171118232543,nDuplicateIdentifier,sDuplicateIdentifier,
[El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType);
begin
ProcScope:=TPasProcedureScope(Data^.Proc.CustomData);
CurResolver:=ProcScope.Owner as TPasResolver;
if msDelphi in CurResolver.CurrentParser.CurrentModeswitches then
// ok in delphi
else
RaiseMsg(20171118232543,nDuplicateIdentifier,sDuplicateIdentifier,
[El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType);
end;
end;
exit;
end;
@ -5491,9 +5499,12 @@ var
i, TypeParamCnt: Integer;
OtherScope: TPasIdentifierScope;
ParentScope: TPasScope;
IsGeneric: Boolean;
IsGeneric, IsDelphi: Boolean;
begin
if aName='' then exit(nil);
IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
if Scope is TPasGroupScope then
begin
Group:=TPasGroupScope(Scope);
@ -5523,7 +5534,8 @@ begin
RaiseMsg(20170403223024,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El);
end;
if (Kind=pikSimple) and (Group<>nil) and (El.ClassType<>TPasProperty) then
if (Kind=pikSimple) and (Group<>nil) and (El.ClassType<>TPasProperty)
and not IsDelphi then
begin
// check duplicate in ancestors and helpers
for i:=1 to Group.Count-1 do
@ -5554,7 +5566,7 @@ begin
// check duplicate in current scope
OlderIdentifier:=Identifier.NextSameIdentifier;
if IsGeneric and (msDelphi in CurrentParser.CurrentModeswitches) then
if IsGeneric and IsDelphi then
OlderIdentifier:=SkipGenericTypes(OlderIdentifier,TypeParamCnt);
if OlderIdentifier<>nil then
begin

62
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -614,7 +614,8 @@ type
Procedure TestClass_SubObject;
Procedure TestClass_WithDoClassInstance;
Procedure TestClass_ProcedureExternal;
Procedure TestClass_ReintroducePublicVarFail;
Procedure TestClass_ReintroducePublicVarObjFPCFail;
Procedure TestClass_ReintroducePublicVarDelphi;
Procedure TestClass_ReintroducePrivateVar;
Procedure TestClass_ReintroduceProc;
Procedure TestClass_UntypedParam_TypeCast;
@ -11011,22 +11012,59 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClass_ReintroducePublicVarFail;
procedure TTestResolver.TestClass_ReintroducePublicVarObjFPCFail;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' public');
Add(' Some: longint;');
Add(' end;');
Add(' TCar = class(tobject)');
Add(' public');
Add(' Some: longint;');
Add(' end;');
Add('begin');
Add([
'type',
' TObject = class',
' public',
' Some: longint;',
' end;',
' TCar = class(tobject)',
' public',
' Some: longint;',
' end;',
'begin']);
CheckResolverException('Duplicate identifier "Some" at afile.pp(5,5)',nDuplicateIdentifier);
end;
procedure TTestResolver.TestClass_ReintroducePublicVarDelphi;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class',
' public',
' {#Obj_Some}Some: longint;',
' {#Obj_Foo}Foo: word;',
' function {#Obj_Bar}Bar: string;',
' end;',
' TCar = class(tobject)',
' public',
' {#Car_Some}Some: double;',
' function {#Car_Foo}Foo: boolean;',
' {#Car_Bar}Bar: single;',
' end;',
'function TObject.Bar: string;',
'begin',
'end;',
'function TCar.Foo: boolean;',
'begin',
' {@Car_Some}Some:=3.3;',
' {@Car_Bar}Bar:=4.3;',
' inherited {@Obj_Bar}Bar;',
' inherited {@Obj_Bar}Bar();',
' inherited {@Obj_Foo}Foo := 4;',
' if inherited {@Obj_Some}Some = 5 then ;',
'end;',
'var C: TCar;',
'begin',
' C.Some:=1.3;']);
ParseProgram;
end;
procedure TTestResolver.TestClass_ReintroducePrivateVar;
begin
StartProgram(false);

338
packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
View File

@ -27,6 +27,8 @@ Type
{ ---------------------------------------------------------------------
JSON-RPC Handler support
---------------------------------------------------------------------}
TJSONRPCHandlerDef = Class;
TCustomJSONRPCDispatcher = Class;
{ TJSONParamDef }
@ -90,6 +92,7 @@ Type
FOptions: TJSONRPCOptions;
FParamDefs: TJSONParamDefs;
FExecParams : TJSONData;
FResultType: TJSONtype;
procedure SetParamDefs(const AValue: TJSONParamDefs);
Protected
function CreateParamDefs: TJSONParamDefs; virtual;
@ -107,7 +110,10 @@ Type
Procedure CheckParams(Const Params : TJSONData);
Function ParamByName(Const AName : String) : TJSONData;
Function Execute(Const Params : TJSONData; AContext : TJSONRPCCallContext = Nil) : TJSONData;
// Checked on incoming request
Property ParamDefs : TJSONParamDefs Read FParamDefs Write SetParamDefs;
// Used in parameter descriptions
Property ResultType : TJSONtype Read FResultType Write FResultType;
end;
TCustomJSONRPCHandlerClass = Class of TCustomJSONRPCHandler;
@ -140,19 +146,60 @@ Type
JSON-RPC dispatcher support
---------------------------------------------------------------------}
TCreateAPIOption = (caoFormatted,caoFullParams);
TCreateAPIOptions = set of TCreateAPIOption;
{ TAPIDescriptionCreator }
TAPIDescriptionCreator = Class(TPersistent)
private
FDefaultOptions: TCreateAPIOptions;
FDispatcher: TCustomJSONRPCDispatcher;
FNameSpace : String;
FURL : String;
FAPIType : String;
function GetNameSpace: String;
function isNameSpaceStored: Boolean;
Protected
Function GetOwner: TPersistent; override;
procedure AddParamDefs(O: TJSONObject; Defs: TJSONParamDefs); virtual;
function CreateParamDef(aDef: TJSONParamDef): TJSONObject; virtual;
function HandlerToAPIMethod(H: TCustomJSONRPCHandler; aOptions: TCreateAPIOptions): TJSONObject; virtual;
function HandlerDefToAPIMethod(H: TJSONRPCHandlerDef; aOptions: TCreateAPIOptions): TJSONObject; virtual;
function DefaultNameSpace: String; virtual;
Function PublishHandler(H: TCustomJSONRPCHandler): Boolean; virtual;
function PublishHandlerDef(HD: TJSONRPCHandlerDef): Boolean; virtual;
Public
Constructor Create(aDispatcher : TCustomJSONRPCDispatcher); virtual;
Procedure Assign(Source : TPersistent); override;
function CreateAPI(aOptions: TCreateAPIOptions): TJSONObject; overload;
function CreateAPI : TJSONObject; overload;
Property Dispatcher : TCustomJSONRPCDispatcher Read FDispatcher;
Published
// Namespace for API description. Must be set. Default 'FPWeb'
Property NameSpace : String Read GetNameSpace Write FNameSpace Stored isNameSpaceStored;
// URL property for API router. Must be set.
Property URL : String Read FURL Write FURL;
// "type". By default: 'remoting'
Property APIType : String Read FAPIType Write FAPIType;
// Default options for creating an API
Property DefaultOptions : TCreateAPIOptions Read FDefaultOptions Write FDefaultOptions;
end;
TJSONRPCDispatchOption = (jdoSearchRegistry, // Check JSON Handler registry
jdoSearchOwner, // Check owner (usually webmodule) for request handler
jdoJSONRPC1, // Allow JSON RPC-1
jdoJSONRPC2, // Allow JSON RPC-2
jdoRequireClass, // Require class name (as in Ext.Direct)
jdoNotifications, // Allow JSON Notifications
jdoStrictNotifications // Error if notification returned result. Default is to discard result.
jdoStrictNotifications, // Error if notification returned result. Default is to discard result.
jdoAllowAPI, // Allow client to get API description
jdoCacheAPI // Cache the API description
);
TJSONRPCDispatchOptions = set of TJSONRPCDispatchOption;
Const
DefaultDispatchOptions = [jdoSearchOwner,jdoJSONRPC1,jdoJSONRPC2,jdoNotifications];
DefaultDispatchOptions = [jdoSearchOwner,jdoJSONRPC1,jdoJSONRPC2,jdoNotifications,jdoAllowAPI,jdoCacheAPI];
Type
TDispatchRequestEvent = Procedure(Sender : TObject; Const AClassName,AMethod : TJSONStringType; Const Params : TJSONData) of object;
@ -160,14 +207,21 @@ Type
{ TCustomJSONRPCDispatcher }
TCustomJSONRPCDispatcher = Class(TComponent)
private
FAPICreator: TAPIDescriptionCreator;
FFindHandler: TFindRPCHandlerEvent;
FOnDispatchRequest: TDispatchRequestEvent;
FOnEndBatch: TNotifyEvent;
FOnStartBatch: TNotifyEvent;
FOptions: TJSONRPCDispatchOptions;
FCachedAPI : TJSONObject;
FCachedAPIOptions : TCreateAPIOptions;
procedure SetAPICreator(AValue: TAPIDescriptionCreator);
Protected
// Create TAPIDescriptionCreator instance. Must have self as owner
Function CreateAPICreator : TAPIDescriptionCreator; virtual;
// Find handler. If none found, nil is returned. Executes OnFindHandler if needed.
// On return 'DoFree' must be set to indicate that the hand
Function FindHandler(Const AClassName,AMethodName : TJSONStringType;AContext : TJSONRPCCallContext; Out FreeObject : TComponent) : TCustomJSONRPCHandler; virtual;
@ -202,8 +256,17 @@ Type
Class Function ParamsProperty : String; virtual;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Class Function TransactionProperty : String; virtual;
// execute request(s) using context
Function Execute(Requests : TJSONData;AContext : TJSONRPCCallContext = Nil) : TJSONData;
// Create an API description. If options are not specified, APICreator.DefaultOptions is used.
Function CreateAPI(aOptions : TCreateAPIOptions): TJSONObject; overload;
Function CreateAPI : TJSONObject; overload;
// Return API Description including namespace, as a string. If options are not specified, APICreator.DefaultOptions is used.
Function APIAsString(aOptions : TCreateAPIOptions) : TJSONStringType; virtual;
Function APIAsString : TJSONStringType; virtual;
Property APICreator : TAPIDescriptionCreator Read FAPICreator Write SetAPICreator;
end;
TJSONRPCDispatcher = Class(TCustomJSONRPCDispatcher)
@ -213,6 +276,7 @@ Type
Property OnFindHandler;
Property OnEndBatch;
Property Options;
Property APICreator;
end;
@ -238,6 +302,7 @@ Type
FDataModuleClass : TDataModuleClass;
FHandlerMethodName: TJSONStringType;
FHandlerClassName: TJSONStringType;
FResultType: TJSONType;
procedure CheckNames(const AClassName, AMethodName: TJSONStringType);
function GetParamDefs: TJSONParamDefs;
procedure SetFPClass(const AValue: TCustomJSONRPCHandlerClass);
@ -257,6 +322,7 @@ Type
Property AfterCreate : TJSONRPCHandlerEvent Read FAfterCreate Write FAfterCreate;
Property ArgumentCount : Integer Read FArgumentCount Write FArgumentCount;
Property ParamDefs : TJSONParamDefs Read GetParamDefs Write SetParamDefs;
Property ResultType : TJSONType Read FResultType Write FResultType;
end;
TJSONRPCHandlerDefClass = Class of TJSONRPCHandlerDef;
@ -490,6 +556,36 @@ begin
raise EJSONRPC.CreateFmt(SErrParams, [Format(Fmt, Args)]);
end;
{ TAPIDescriptionCreator }
function TAPIDescriptionCreator.GetOwner: TPersistent;
begin
Result:=FDispatcher;
end;
constructor TAPIDescriptionCreator.Create(aDispatcher: TCustomJSONRPCDispatcher);
begin
FDispatcher:=aDispatcher;
DefaultOptions:=[caoFullParams];
end;
procedure TAPIDescriptionCreator.Assign(Source: TPersistent);
Var
C : TAPIDescriptionCreator absolute Source;
begin
if Source is TAPIDescriptionCreator then
begin
URL:=C.URL;
NameSpace:=C.FNameSpace;
FAPIType:=C.APIType;
DefaultOptions:=C.DefaultOptions;
end
else
inherited Assign(Source);
end;
{ TJSONParamDef }
@ -800,6 +896,167 @@ end;
{ TCustomJSONRPCDispatcher }
// Create API method description
Function TAPIDescriptionCreator.CreateParamDef(aDef: TJSONParamDef) : TJSONObject;
begin
With aDef do
Result:=TJSONObject.Create(['name',Name,'type',JSONTypeName(DataType),'required',Required]);
end;
procedure TAPIDescriptionCreator.AddParamDefs(O: TJSONObject; Defs: TJSONParamDefs);
Var
A : TJSONArray;
I : Integer;
begin
A:=TJSONArray.Create;
O.Add('paramdefs',A);
For I:=0 to Defs.Count-1 do
A.Add(CreateParamDef(Defs[i]));
end;
Function TAPIDescriptionCreator.HandlerToAPIMethod (H: TCustomJSONRPCHandler; aOptions : TCreateAPIOptions): TJSONObject;
begin
Result:=TJSONObject.Create(['name',H.Name,'len',H.ParamDefs.Count]);
if Not (caoFullParams in aOptions) then exit;
Result.Add('resulttype',JSONTypeName(H.ResultType));
if (H.ParamDefs.Count>0) then
AddParamDefs(Result,H.ParamDefs);
end;
Function TAPIDescriptionCreator.HandlerDefToAPIMethod (H: TJSONRPCHandlerDef; aOptions: TCreateAPIOptions): TJSONObject;
begin
Result:=TJSONObject.Create(['name',H.HandlerMethodName,'len',H.ArgumentCount]);
if Not (caoFullParams in aOptions) then exit;
Result.Add('resulttype',JSONTypeName(H.ResultType));
if (H.ParamDefs.Count>0) then
AddParamDefs(Result,H.ParamDefs);
end;
function TAPIDescriptionCreator.GetNameSpace: String;
begin
Result:=FNameSpace;
If (Result='') then
Result:=DefaultNameSpace
end;
function TAPIDescriptionCreator.isNameSpaceStored: Boolean;
begin
Result:=NameSpace<>DefaultNameSpace;
end;
function TAPIDescriptionCreator.DefaultNameSpace: String;
begin
Result:='';
end;
function TAPIDescriptionCreator.PublishHandler(H: TCustomJSONRPCHandler): Boolean;
begin
Result:=(H<>Nil)
end;
Function TAPIDescriptionCreator.PublishHandlerDef(HD: TJSONRPCHandlerDef): Boolean;
begin
Result:=(HD<>Nil)
end;
function TAPIDescriptionCreator.CreateAPI(aOptions: TCreateAPIOptions): TJSONObject;
Var
A,D : TJSONObject;
R : TJSONArray;
N : TJSONStringType;
H : TCustomJSONRPCHandler;
I,J : Integer;
M : TCustomJSONRPCHandlerManager;
HD : TJSONRPCHandlerDef;
search : Boolean;
C : TComponent;
begin
D:=TJSONObject.Create;
try
D.Add('url',URL);
D.Add('type',APIType);
A:=TJSONObject.Create;
D.Add('actions',A);
R:=Nil;
N:='';
Search:=assigned(Dispatcher) and (jdoSearchOwner in Dispatcher.Options);
C:=Dispatcher.Owner;
If Search and Assigned(C) then
begin
for I:=C.ComponentCount-1 downto 0 do
If C.Components[i] is TCustomJSONRPCHandler then
begin
H:=C.Components[i] as TCustomJSONRPCHandler;
if PublishHandler(H) then
begin
If (R=Nil) then
begin
N:=C.Name;
R:=TJSONArray.Create;
A.Add(N,R);
end;
R.Add(HandlerToAPIMethod(H,aOptions));
end;
end;
end;
Search:=assigned(Dispatcher) and (jdoSearchRegistry in Dispatcher.Options);
If Search then
begin
M:=JSONRPCHandlerManager;
For I:=M.HandlerCount-1 downto 0 do
begin
HD:=M.HandlerDefs[i];
if PublishHandlerDef(HD) then
begin
If (R=Nil) or (CompareText(N,HD.HandlerClassName)<>0) then
begin
N:=HD.HandlerClassName;
J:=A.IndexOfName(N);
If (J=-1) then
begin
R:=TJSONArray.Create;
A.Add(N,R);
end
else
R:=A.Items[J] as TJSONArray;
end;
R.Add(HandlerDefToAPIMethod(HD,aOptions));
end;
end;
end;
Result:=D;
except
FreeAndNil(D);
Raise;
end;
end;
function TAPIDescriptionCreator.CreateAPI: TJSONObject;
begin
Result:=CreateAPI(DefaultOptions);
end;
procedure TCustomJSONRPCDispatcher.SetAPICreator(AValue: TAPIDescriptionCreator);
begin
if FAPICreator=AValue then Exit;
FAPICreator.Assign(AValue);
end;
function TCustomJSONRPCDispatcher.CreateAPICreator: TAPIDescriptionCreator;
begin
Result:=TAPIDescriptionCreator.Create(Self);
end;
function TCustomJSONRPCDispatcher.FindHandler(const AClassName, AMethodName: TJSONStringType;AContext : TJSONRPCCallContext;Out FreeObject : TComponent): TCustomJSONRPCHandler;
Var
@ -862,9 +1119,11 @@ function TCustomJSONRPCDispatcher.FormatResult(Const AClassName, AMethodName: TJ
Const Params,ID, Return : TJSONData) : TJSONData;
begin
Result:=TJSONObject.Create(['result',Return,'error',TJSonNull.Create,transactionproperty,ID.Clone]);
Result:=TJSONObject.Create(['result',Return,transactionproperty,ID.Clone]);
if jdoJSONRPC2 in options then
TJSONObject(Result).Add('jsonrpc','2.0');
TJSONObject(Result).Add('jsonrpc','2.0')
else
TJSONObject(Result).Add('error',TJSonNull.Create);
end;
function TCustomJSONRPCDispatcher.CreateJSON2Error(const AMessage: String;
@ -1101,9 +1360,17 @@ end;
constructor TCustomJSONRPCDispatcher.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAPICreator:=CreateAPICreator;
FOptions:=DefaultDispatchOptions;
end;
destructor TCustomJSONRPCDispatcher.Destroy;
begin
FreeAndNil(FAPICreator);
FreeAndNil(FCachedAPI);
inherited Destroy;
end;
function TCustomJSONRPCDispatcher.Execute(Requests: TJSONData;AContext : TJSONRPCCallContext = Nil): TJSONData;
begin
If Assigned(FOnStartBatch) then
@ -1115,6 +1382,58 @@ begin
FOnEndBatch(Self);
end;
function TCustomJSONRPCDispatcher.CreateAPI(aOptions: TCreateAPIOptions): TJSONObject;
Var
CAO : TCreateAPIOptions;
begin
CAO:=aOptions-[caoFormatted];
Result:=Nil;
if (jdoCacheAPI in Options)
and (FCachedAPI<>Nil)
and (CAO=FCachedAPIOptions) then
Result:=TJSONObject(FCachedAPI.Clone)
else
begin
Result:=APICreator.CreateAPI(aOptions);
if (jdoCacheAPI in Options) then
begin
FCachedAPI:=TJSONObject(Result.Clone);
FCachedAPIOptions:=CAO;
end;
end;
end;
function TCustomJSONRPCDispatcher.CreateAPI: TJSONObject;
begin
Result:=CreateAPI(APICreator.DefaultOptions);
end;
function TCustomJSONRPCDispatcher.APIAsString(aOptions: TCreateAPIOptions): TJSONStringType;
Var
S : TJSONObject;
begin
S:=CreateAPI(aOptions);
try
if caoFormatted in aOptions then
Result:=S.FormatJSON()
else
Result:=S.AsJSON;
if APICreator.NameSpace<>'' then
Result:=APICreator.NameSpace+' = '+Result;
finally
S.Free;
end;
end;
function TCustomJSONRPCDispatcher.APIAsString: TJSONStringType;
begin
Result:=APIAsString(APICreator.DefaultOptions);
end;
{ TJSONRPCHandlerDef }
procedure TJSONRPCHandlerDef.SetFPClass(const AValue: TCustomJSONRPCHandlerClass
@ -1351,6 +1670,7 @@ begin
D:=AddHandlerDef(CN,C.Name);
D.ArgumentCount:=TCustomJSONRPCHandler(C).ParamDefs.Count;
D.ParamDefs:=TCustomJSONRPCHandler(C).ParamDefs;
D.ResultType:=TCustomJSONRPCHandler(C).ResultType;
{$ifdef wmdebug}SendDebug('Registering provider '+C.Name);{$endif}
D.FDataModuleClass:=TDataModuleClass(DM.ClassType);
end;
@ -1378,6 +1698,7 @@ Function TCustomJSONRPCHandlerManager.RegisterHandler(Const AClassName,
Var
I : Integer;
B : Boolean;
H : TCustomJSONRPCHandler;
begin
B:=FRegistering;
@ -1392,6 +1713,13 @@ begin
Result:=AddHandlerDef(AClassName,AMEthodName);
Result.HandlerClass:=AClass;
Result.ArgumentCount:=AArgumentCount;
H:=Aclass.Create(Nil);
try
Result.ParamDefs:=H.ParamDefs;
Result.ResultType:=H.ResultType;
finally
H.Free;
end;
finally
FRegistering:=B;
end;

89
packages/pastojs/tests/tcmodules.pas
View File

@ -522,6 +522,7 @@ type
Procedure TestClass_OverloadsAncestor;
Procedure TestClass_OverloadConstructor;
Procedure TestClass_OverloadDelphiOverride;
Procedure TestClass_ReintroduceVarDelphi;
Procedure TestClass_ReintroducedVar;
Procedure TestClass_RaiseDescendant;
Procedure TestClass_ExternalMethod;
@ -13889,6 +13890,94 @@ begin
'']));
end;
procedure TTestModule.TestClass_ReintroduceVarDelphi;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TAnimal = class',
' public',
' {#animal_a}A: longint;',
' function {#animal_b}B: longint;',
' end;',
' TBird = class(TAnimal)',
' public',
' {#bird_a}A: double;',
' {#bird_b}B: boolean;',
' end;',
' TEagle = class(TBird)',
' public',
' function {#eagle_a}A: boolean;',
' {#eagle_b}B: double;',
' end;',
'function TAnimal.B: longint;',
'begin',
'end;',
'function TEagle.A: boolean;',
'begin',
' {@eagle_b}B:=3.3;',
' {@eagle_a}A();',
' TBird(Self).{@bird_b}B:=true;',
' TAnimal(Self).{@animal_a}A:=17;',
' inherited {@bird_b}B:=inherited {bird_a}A>1;', // Delphi allows only inherited <functionname>
'end;',
'var',
' e: TEagle;',
'begin',
' e.{@eagle_b}B:=5.3;',
' if e.{@eagle_a}A then ;',
'']);
ConvertProgram;
CheckSource('TestClass_ReintroduceVarDelphi',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createClass($mod, "TAnimal", $mod.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.A = 0;',
' };',
' this.B = function () {',
' var Result = 0;',
' return Result;',
' };',
'});',
'rtl.createClass($mod, "TBird", $mod.TAnimal, function () {',
' this.$init = function () {',
' $mod.TAnimal.$init.call(this);',
' this.A$1 = 0.0;',
' this.B$1 = false;',
' };',
'});',
'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
' this.$init = function () {',
' $mod.TBird.$init.call(this);',
' this.B$2 = 0.0;',
' };',
' this.A$2 = function () {',
' var Result = false;',
' this.B$2 = 3.3;',
' this.A$2();',
' this.B$1 = true;',
' this.A = 17;',
' this.B$1 = this.A$1 > 1;',
' return Result;',
' };',
'});',
'this.e = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.e.B$2 = 5.3;',
'if ($mod.e.A$2()) ;',
'']));
end;
procedure TTestModule.TestClass_ReintroducedVar;
begin
StartProgram(false);

92
tests/tbs/tb0670.pp Normal file
View File

@ -0,0 +1,92 @@
{ %NORUN }
program tb0670;
const
Value1 = $06;
Value2 = $60;
Value3 = $6000;
Value4 = $60000000;
Value5 = $60000000000;
Value6 = $40;
Value7 = $4000;
Value8 = $40000000;
Value9 = $40000000000;
ValueNot1 = not Value1;
ValueNot2 = not Value2;
ValueNot3 = not Value3;
ValueNot4 = not Value4;
ValueNot5 = not Value5;
ValueOr1 = Value1 or Value2;
ValueOr2 = Value1 or Value3;
ValueOr3 = Value1 or Value4;
ValueOr4 = Value1 or Value5;
ValueAnd1 = Value2 and Value6;
ValueAnd2 = Value3 and Value7;
ValueAnd3 = Value4 and Value8;
ValueAnd4 = Value5 and Value9;
{ Test "not X" }
{$if not (not Value1 = ValueNot1)}
{$error 'not Value1 = ValueNot1'}
{$endif}
{$if not (not Value2 = ValueNot2)}
{$error 'not Value2 = ValueNot2'}
{$endif}
{$if not (not Value3 = ValueNot3)}
{$error 'not Value3 = ValueNot3'}
{$endif}
{$if not (not Value4 = ValueNot4)}
{$error 'not Value4 = ValueNot4'}
{$endif}
{$if not (not Value5 = ValueNot5)}
{$error 'not Value5 = ValueNot5'}
{$endif}
{ Test "X or Y" }
{$if Value1 or Value2 <> ValueOr1}
{$error 'Value1 or Value2 = ValueOr1'}
{$endif}
{$if Value1 or Value3 <> ValueOr2}
{$error 'Value1 or Value3 = ValueOr2'}
{$endif}
{$if Value1 or Value4 <> ValueOr3}
{$error 'Value1 or Value4 = ValueOr3'}
{$endif}
{$if Value1 or Value5 <> ValueOr4}
{$error 'Value1 or Value5 = ValueOr4'}
{$endif}
{ Test "X and Y" }
{$if Value2 and Value6 <> ValueAnd1 }
{$error 'Value2 and Value6 = ValueAnd1' }
{$endif}
{$if Value3 and Value7 <> ValueAnd2 }
{$error 'Value3 and Value7 = ValueAnd2' }
{$endif}
{$if Value4 and Value8 <> ValueAnd3 }
{$error 'Value4 and Value8 = ValueAnd3' }
{$endif}
{$if Value5 and Value9 <> ValueAnd4 }
{$error 'Value5 and Value9 = ValueAnd4' }
{$endif}
begin
end.