paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 13:09:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46366 -
This commit is contained in:
nickysn 2020-08-11 22:58:54 +00:00
commit 163794ca27
12 changed files with 117 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -18444,6 +18444,7 @@ tests/webtbs/tw37400.pp svneol=native#text/pascal
tests/webtbs/tw3742.pp svneol=native#text/plain
tests/webtbs/tw37423.pp svneol=native#text/plain
tests/webtbs/tw37427.pp svneol=native#text/pascal
tests/webtbs/tw37428.pp svneol=native#text/pascal
tests/webtbs/tw37449.pp svneol=native#text/pascal
tests/webtbs/tw37468.pp svneol=native#text/pascal
tests/webtbs/tw37477.pp svneol=native#text/pascal

9
compiler/nutils.pas
View File

@ -886,7 +886,8 @@ implementation
addn,subn,orn,andn,xorn,muln,divn,modn,symdifn,
shln,shrn,
equaln,unequaln,gtn,gten,ltn,lten,
assignn:
assignn,
slashn:
begin
{$ifdef CPU64BITALU}
correction:=1;
@ -894,8 +895,10 @@ implementation
correction:=2;
{$endif CPU64BITALU}
inc(result,node_complexity(tbinarynode(p).left)+1*correction);
if (p.nodetype in [muln,divn,modn]) then
inc(result,5*correction*correction);
if (p.nodetype in [divn,modn,slashn]) then
inc(result,10*correction*correction)
else if p.nodetype=muln then
inc(result,4*correction*correction);
if (result >= NODE_COMPLEXITY_INF) then
begin
result := NODE_COMPLEXITY_INF;

2
compiler/pdecl.pas
View File

@ -390,7 +390,7 @@ implementation
begin
{ strip leading 0's in iso mode }
if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then
while pattern[1]='0' do
while (length(pattern)>1) and (pattern[1]='0') do
delete(pattern,1,1);
labelsym:=clabelsym.create(pattern);
end;

2
compiler/pstatmnt.pas
View File

@ -1168,7 +1168,7 @@ implementation
{ strip leading 0's in iso mode }
if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then
while pattern[1]='0' do
while (length(pattern)>1) and (pattern[1]='0') do
delete(pattern,1,1);
searchsym(pattern,srsym,srsymtable);

13
packages/fcl-db/src/base/fields.inc
View File

@ -177,7 +177,8 @@ end;
function TFieldDef.GetCharSize: Word;
begin
case FDataType of
ftGUID: Result:=1;
ftGuid:
Result := 1;
ftString, ftFixedChar:
case FCodePage of
CP_UTF8: Result := 4;
@ -3349,11 +3350,6 @@ begin
SetAsString(GuidToString(AValue));
end;
function TVariantField.GetDefaultWidth: Integer;
begin
Result := 15;
end;
{ TVariantField }
constructor TVariantField.Create(AOwner: TComponent);
@ -3367,6 +3363,11 @@ begin
{ empty }
end;
function TVariantField.GetDefaultWidth: Integer;
begin
Result := 15;
end;
function TVariantField.GetAsBoolean: Boolean;
begin
Result := GetAsVariant;

7
packages/fcl-db/src/sqldb/mssql/mssqlconn.pp
View File

@ -876,6 +876,11 @@ begin
ftGuid:
begin
desttype:=SQLCHAR;
dest[ 0]:=Ord('{');
dest[37]:=Ord('}');
dest[38]:=0; //strings must be null-terminated
Inc(dest);
destlen:=36;
end;
ftMemo,
ftBlob:
@ -892,7 +897,7 @@ begin
case FieldDef.DataType of
ftString, ftFixedChar:
PAnsiChar(dest + datalen)^ := #0; //strings must be null-terminated
dest[datalen] := 0; //strings must be null-terminated
ftDate, ftTime, ftDateTime:
if desttype = SYBMSDATETIME2 then
PDateTime(buffer)^ := dbdatetimeallcrack(@dbdta)

2
packages/fcl-db/tests/dbtestframework.lpi
View File

@ -121,7 +121,7 @@
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../units/x86_64-linux"/>
<OtherUnitFiles Value="../src/base;../src/dbase;../src/sqldb;../src/sqldb/interbase;../src/sqldb/mssql;../src/sqldb/mysql;../src/sqldb/odbc;../src/sqldb/oracle;../src/sqldb/postgres;../src/sqldb/sqlite;../src/memds;../src/sdf;../src/export"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>

1
packages/fcl-db/tests/sqldbtoolsunit.pas
View File

@ -257,6 +257,7 @@ begin
FieldtypeDefinitions[ftBlob] := 'IMAGE';
FieldtypeDefinitions[ftMemo] := 'TEXT';
FieldtypeDefinitions[ftGraphic] := '';
FieldtypeDefinitions[ftGuid] := 'UNIQUEIDENTIFIER';
FieldtypeDefinitions[ftWideString] := 'NVARCHAR(10)';
FieldtypeDefinitions[ftFixedWideChar] := 'NCHAR(10)';
//FieldtypeDefinitions[ftWideMemo] := 'NTEXT'; // Sybase has UNITEXT?

35
packages/fcl-db/tests/testfieldtypes.pas
View File

@ -53,6 +53,7 @@ type
procedure TestSQLInterval;
procedure TestSQLIdentity;
procedure TestSQLReal;
procedure TestSQLUUID;
procedure TestStringLargerThen8192;
procedure TestInsertLargeStrFields; // bug 9600
@ -133,8 +134,8 @@ type
procedure TestQueryAfterReconnect; // bug 16438
procedure TestStringsReplace;
// Test SQLIte3 AlwaysUseBigInt, introduced after bug ID 36486.
Procedure TestAlwaysUseBigint;
// Test SQLite3 AlwaysUseBigInt, introduced after bug ID 36486.
Procedure TestSQLite3AlwaysUseBigint;
end;
@ -732,7 +733,7 @@ begin
Open;
for i := 0 to testValuesCount-1 do
begin
ACheckFieldValueProc(fields[0],i);
ACheckFieldValueProc(Fields[0],i);
Next;
end;
close;
@ -931,6 +932,30 @@ begin
end;
const testUUIDValues: array[0..2] of shortstring = ('{00000000-0000-0000-0000-000000000000}','{A972C577-DFB0-064E-1189-0154C99310DA}','{A0EEBC99-9C0B-4EF8-BB6D-6BB9BD380A11}');
// Placed here, as long as bug 18702 is not solved
function TestSQLUUID_GetSQLText(const i: integer) : string;
begin
if i < Length(testUUIDValues) then
Result := QuotedStr(Copy(testUUIDValues[i],2,36))
else
Result := 'NULL';
end;
procedure TTestFieldTypes.TestSQLUUID;
procedure CheckFieldValue(AField:TField; i: integer);
begin
if i < Length(testUUIDValues) then
AssertEquals(testUUIDValues[i], AField.AsString)
else
AssertTrue(AField.IsNull);
end;
begin
if FieldtypeDefinitions[ftGuid] = '' then
Ignore(STestNotApplicable);
TestSQLFieldType(ftGuid, FieldtypeDefinitions[ftGuid], 39, @TestSQLUUID_GetSQLText, @CheckFieldValue);
end;
procedure TTestFieldTypes.TestStringLargerThen8192;
// See also: TestInsertLargeStrFields
var
@ -1501,7 +1526,7 @@ begin
TestXXParamQuery(ftFMTBcd, FieldtypeDefinitions[ftFMTBcd], testValuesCount, testFmtBCDValues);
end;
Procedure TTestFieldTypes.TestFmtBCDParamQuery2;
procedure TTestFieldTypes.TestFmtBCDParamQuery2;
begin
// This test tests FmtBCD params with smaller precision, which fits into INT32
// TestFmtBCDParamQuery tests FmtBCD params with bigger precision, which fits into INT64
@ -2429,7 +2454,7 @@ begin
inherited RunTest;
end;
Procedure TTestFieldTypes.TestAlwaysUseBigint;
procedure TTestFieldTypes.TestSQLite3AlwaysUseBigint;
var
I : byte;

52
packages/fcl-passrc/src/paswrite.pp
View File

@ -38,7 +38,8 @@ type
woForceOverload, // Force 'overload;' on overloads that are not marked as such.
woNoAsm, // Do not allow asm block
woSkipPrivateExternals, // Skip generation of external procedure declaration in implementation section
woAlwaysRecordHelper // Force use of record helper for type helper
woAlwaysRecordHelper, // Force use of record helper for type helper
woSkipHints // Do not add identifier hints
);
TPasWriterOptions = Set of TPasWriterOption;
@ -717,9 +718,54 @@ end;
procedure TPasWriter.WriteConst(AConst: TPasConst);
Const
Seps : Array[Boolean] of Char = ('=',':');
Var
Vart,Decl : String;
begin
PrepareDeclSection('const');
AddLn(AConst.GetDeclaration(True)+';');
Decl:='';
With AConst do
begin
If Assigned(VarType) then
begin
If VarType.Name='' then
Vart:=VarType.GetDeclaration(False)
else
Vart:=VarType.SafeName;
Decl:=Vart+Modifiers;
Vart:=LowerCase(Vart);
if (Value<>'') then
Decl:=Decl+' = '+Value
else if (ExportName<>Nil) or ((Parent is TPasClassType) and (TPasClassType(Parent).ExternalName<>'')) then // external name
case VarT of
'integer',
'byte',
'word',
'smallint',
'int64',
'nativeint',
'shortint',
'longint' : Decl:=Decl+' = 0';
'double',
'single',
'extended' : Decl:=Decl+' = 0.0';
'string' : Decl:=Decl+' = ''''';
else
if Pos('array',Vart)>0 then
Decl:=Decl+' = []';
end;
end
else
Decl:=Value;
Decl:=SafeName+' '+Seps[Assigned(VarType)]+' '+Decl;
if NotOption(woSkipHints) then
Decl:=Decl+HintsString;
end;
AddLn(Decl+';');
end;
procedure TPasWriter.WriteVariable(aVar: TPasVariable);
@ -862,7 +908,7 @@ begin
PrepareDeclSection('');
if Not IsImpl then
IsImpl:=FInImplementation;
if FInImplementation and (Assigned(AProc.LibraryExpr) or Assigned(AProc.LibrarySymbolName)) and HasOption(woSkipPrivateExternals) then
if FInImplementation and not forcebody and (Assigned(AProc.LibraryExpr) or Assigned(AProc.LibrarySymbolName)) and HasOption(woSkipPrivateExternals) then
Exit;
Add(AProc.TypeName + ' ' + NamePrefix+AProc.SafeName);
if Assigned(AProc.ProcType) and (AProc.ProcType.Args.Count > 0) then

8
tests/webtbs/tw37428.pp Normal file
View File

@ -0,0 +1,8 @@
{$mode iso}
label
0;
begin
0:
writeln('ok');
end.

7
utils/pas2js/stubcreator.pp
View File

@ -204,9 +204,12 @@ end;
procedure TStubCreator.Execute;
begin
FLastErrorClass:='';
FLastError:='';
if Defines.IndexOf('MakeStub')=-1 then
Try
DoExecute;
except
@ -307,6 +310,8 @@ begin
SCanner.OnLog:=SE.Onlog;
For S in FDefines do
Scanner.AddDefine(S);
if FDefines.IndexOf('MAKESTUB')=-1 then
Scanner.AddDefine('MAKESTUB');
Scanner.OpenFile(InputFilename);
// Parser
Parser:=TPasParser.Create(Scanner, FileResolver, SE);
@ -340,7 +345,7 @@ begin
FLineNumberWidth:=4;
FIndentSize:=2;
FExtraUnits:='';
FOptions:=[woNoImplementation,woNoExternalClass,woNoExternalVar,woNoExternalFunc,woNoAsm,woSkipPrivateExternals,woAlwaysRecordHelper];
FOptions:=[woNoImplementation,woNoExternalClass,woNoExternalVar,woNoExternalFunc,woNoAsm,woSkipPrivateExternals,woAlwaysRecordHelper,woSkipHints];
end;
destructor TStubCreator.Destroy;