View Issue Details

IDProjectCategoryView StatusLast Update
0035608FPCCompilerpublic2019-05-21 12:30
ReporterBenito van der Zander Assigned To 
PrioritynormalSeverityminorReproducibilityunable to reproduce
Status newResolutionopen 
Platformamd64OSlinux 
Product Version3.3.1 
Summary0035608: linking error when generic crc differ
DescriptionI use some source files in multiple projects in the same directory and now FPC has created two different object files for this file:

/usr/local/bin/fpc -MObjFPC -Scgi -Cg -O1 -g -gl -l -vewnhibq -Fu../../../../../benito/hg/components/pascal/import/synapse -Fu../../../../../benito/hg/components/pascal/import/regexpr/Source -Fu../../../../../benito/hg/components/pascal/internet -Fu. -Fu../../../components/pascal/import/bigint -Fu../../../../opt/lazarus/lcl/units/x86_64-linux -Fu../../../../opt/lazarus/components/lazutils/lib/x86_64-linux -Fu../../../components/pascal/lib/x86_64-linux -Fu../../../../opt/lazarus/packager/units/x86_64-linux -oxidelcgi

made a file xquery.namespace.o containing this method:

0000000000000000 g F .text.n_xquery.namespaces$_$tfastinterfacelist$1$crc0a34dd37_$__$$_delete$longint 00000000000000d9 XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC0A34DD37_$__$$_DELETE$LONGINT

while

/usr/local/bin/fpc -MObjFPC -Scaghi -CX -Cg -Cr -O2 -g -gl -gv -XX -l -vewnhibq -Filib/x86_64-linux -Fu../../../components/pascal/import/synapse -Fu../../../components/pascal/internet -Fu../../../components/pascal/data -Fu../../../components/pascal/system -Fu../../../components/pascal/import/regexpr/source -Fu../../../components/pascal/import/utf8tools -Fu../../../components/pascal/lib/x86_64-linux -Fu../../../../opt/lazarus/packager/units/x86_64-linux -Fu. -FUlib/x86_64-linux -FE. -oxidel

made a file lib/x86_64-linux/xquery.namespace.o containing method:

0000000000000000 g F .text.n_xquery.namespaces$_$tfastinterfacelist$1$crc7b637175_$__$$_delete$longint 00000000000000cc XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC7B637175_$__$$_DELETE$LONGINT


Since I made both fpc calls in the same directory, the second call finds the xquery.namespace.o of the first call, and uses the CRC0A34DD37 method. But in the link.res it refers to its input lib/x86_64-linux/xquery.namespace.o, so it does not link:

/home/theo/hg/programs/internet/xidel//../../../components/pascal/data/simplehtmltreeparser.pas:1797: undefined reference to `XQUERY.NAMESPACES$_$TFASTINTERFACELIST$1$CRC0A34DD37_$__$$_DELETE$LONGINT'
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Benito van der Zander

2019-05-21 12:27

reporter  

xquery.namespaces.o (143,040 bytes)
xquery.namespaces.ppu (56,354 bytes)
xquery.namespaces-2.o (142,616 bytes)
xquery.namespaces-2.ppu (56,385 bytes)
xquery.namespaces.pas (9,178 bytes)   
unit xquery.namespaces;
{
Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                          benito@benibela.de
                          www.benibela.de

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

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.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

}

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, xquery.internals.common;

type

TNamespace = class;

//** Namespace interface, storing url and prefix. (Interface, so it is ref-counted)
INamespace = interface
['{5F6DF5F2-548C-4F13-9BEA-CE59EBAE4CAB}']
  function getPrefix: string; //**< Returns the prefix
  function getURL: string; //**< Returns the url
  function serialize: string; //**< Returns an xmlns attribute declaring this namespace with url and prefix
  function getSelf: TNamespace;
  function equal(const ns: string): boolean;
end;


{ TNamespace }

//** Class implementing the INamespace interface
TNamespace = class(TInterfacedObject, INamespace)
public
  url: string;
  prefix: string;
  //** Creates a new namespace with url and prefix. (watch the argument order. It follows the XPath fn:QName function)
  constructor create(const aurl: string; aprefix: string);

  class function make(const aurl: string; const aprefix: string): TNamespace; static;
  class function uniqueUrl(const aurl: string): string; static;
  class procedure freeCache; static;

  function getPrefix: string;
  function getURL: string;
  function serialize: string;
  function getSelf: TNamespace;
  function equal(const ns: string): boolean;
  destructor Destroy; override;
end;

{ TNamespaceList }

//** List of namespaces
TNamespaceList = class(specialize TFastInterfaceList<INamespace>)
private
  function getNamespace(const prefix: string): INamespace;
  function getNamespace(i: integer): INamespace;
public
  function hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
  function hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
  function hasNamespacePrefix(const prefix: string): boolean;
  function hasNamespace(const n: INamespace): boolean;

  function lastIndexOfNamespacePrefix(const prefix: string): integer;

  procedure add(const ns: TNamespace);
  procedure add(const ns: INamespace);
  procedure addIfNewPrefix(const ns: TNamespace);
  procedure addIfNewPrefix(const ns: INamespace);
  procedure addIfNewPrefixUrl(const ns: TNamespace);
  procedure addIfNewPrefixUrl(const ns: INamespace);

  procedure deleteFrom(i: integer);

  function clone: TNamespaceList;

  property namespaces[prefix: string]: INamespace read getNamespace;
  property items[i: integer]: INamespace read getNamespace;
end;

const XMLNamespaceUrl_XML = 'http://www.w3.org/XML/1998/namespace';
      XMLNamespaceUrl_XMLNS = 'http://www.w3.org/2000/xmlns/';

var
   XMLNamespace_XMLNS, XMLNamespace_XML: INamespace;

function equalNamespaces(const ans, bns: INamespace): boolean; inline;
function equalNamespaces(const ans, bns: string): boolean; inline;
function namespaceGetURL(const n: INamespace): string; inline;


implementation

uses bbutils;



function equalNamespaces(const ans, bns: INamespace): boolean;
begin
  result := (ans = bns) or ((ans <> nil) and (bns <> nil) and strEqual(ans.getURL, bns.getURL));
end;

function equalNamespaces(const ans, bns: string): boolean;
begin
  result := strEqual(ans, bns);
end;

function namespaceGetURL(const n: INamespace): string;
begin
  if n = nil then result := ''
  else result := n.getURL;
end;



function TNamespaceList.getNamespace(const prefix: string): INamespace;
begin
  hasNamespacePrefix(prefix, result);
end;

function TNamespaceList.getNamespace(i: integer): INamespace;
begin
  result := INamespace(pointer(inherited get(i)));
end;

function TNamespaceList.hasNamespacePrefixBefore(const prefix: string; const c: integer): boolean;
var
  i: Integer;
begin
  for i := c - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then exit(true);
  exit(false);
end;

function TNamespaceList.hasNamespacePrefix(const prefix: string; out ns: INamespace): boolean;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then begin
      ns := items[i];
      exit(true);
    end;
  ns := nil;
  exit(false);
end;

function TNamespaceList.hasNamespacePrefix(const prefix: string): boolean;
var temp: INamespace;
begin
  result := hasNamespacePrefix(prefix, temp);
end;

function TNamespaceList.hasNamespace(const n: INamespace): boolean;
var
  temp: INamespace;
begin
  if not hasNamespacePrefix(n.getPrefix, temp) then exit(false);
  if temp.getURL <> n.getURL then exit(false);
  result := true;
end;

function TNamespaceList.lastIndexOfNamespacePrefix(const prefix: string): integer;
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if (Items[i]).getPrefix = prefix then
      exit(i);
  exit(-1);
end;

procedure TNamespaceList.add(const ns: TNamespace);
begin
  inherited add(INamespace(ns)); //hide ancestor method to prevent crash when tnamespace is treated as inamespace instead being cast
end;

procedure TNamespaceList.add(const ns: INamespace);
begin
  inherited add(ns);
end;

procedure TNamespaceList.addIfNewPrefix(const ns: TNamespace);
begin
  addIfNewPrefix(INamespace(ns));
end;

procedure TNamespaceList.addIfNewPrefix(const ns: INamespace);
var
  temp: INamespace;
begin
  if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
  if not hasNamespacePrefix(ns.getPrefix, temp) then
    add(ns);
end;

procedure TNamespaceList.addIfNewPrefixUrl(const ns: TNamespace);
begin
  addIfNewPrefixUrl(INamespace(ns));
end;

procedure TNamespaceList.addIfNewPrefixUrl(const ns: INamespace);
var
  temp: INamespace;
begin
  if (ns = nil) or (ns.getURL = XMLNamespaceUrl_XMLNS) or (ns.getURL = XMLNamespaceUrl_XML) then exit;
  if not hasNamespacePrefix(ns.getPrefix, temp) then
    add(ns)
  else if temp.getURL <> ns.getURL then
    add(ns);
end;

procedure TNamespaceList.deleteFrom(i: integer);
begin
  if i < 0 then i := 0;
  while count > i do
    delete(count - 1);
end;


function TNamespaceList.clone: TNamespaceList;
var
  i: Integer;
begin
  result := TNamespaceList.Create;
  for i := 0 to count - 1 do
    result.Add(items[i]);
end;

type
TXQHashmapStrOwningNamespace = specialize TXQHashmapStrOwning<INamespace, TNamespaceList>;
TNamespaceCache = class
  uniqueUrl: string;
  prefixes: TXQHashmapStrOwningNamespace;
  constructor Create;
  destructor Destroy; override;
end;

constructor TNamespaceCache.Create;
begin
  prefixes := TXQHashmapStrOwningNamespace.Create;
end;

destructor TNamespaceCache.Destroy;
begin
  prefixes.free;
  inherited Destroy;
end;

threadvar globalNamespaceCache: TXQHashmapStrOwningObject;

function TNamespace.getSelf: TNamespace;
begin
  result := self;
end;

function TNamespace.equal(const ns: string): boolean;
begin
  result := strEqual(url, ns);
end;

constructor TNamespace.create(const aurl: string; aprefix: string);
begin
  url := aurl;
  prefix := aprefix;
end;

function namespaceCache(const aurl: string): TNamespaceCache;
begin
  if globalNamespaceCache = nil then globalNamespaceCache := TXQHashmapStrOwningObject.Create();
  result := TNamespaceCache(globalNamespaceCache[aurl]);
  if result = nil then begin
    result := TNamespaceCache.Create;
    result.uniqueUrl := aurl;
    globalNamespaceCache.Add(aurl, result);
    //writeln(strFromPtr(pointer(aurl)), ' ',aurl);
  end;
end;

{$ImplicitExceptions off}
class function TNamespace.make(const aurl: string; const aprefix: string): TNamespace;
var cache : TNamespaceCache;
  old: INamespace;
begin
  cache := namespaceCache(aurl);
  old := cache.prefixes[aprefix];
  if old = nil then begin
    result := TNamespace.create(cache.uniqueUrl, aprefix);
    cache.prefixes.Add(aprefix, result);
  end else result := old.getSelf;
end;
{$ImplicitExceptions on}

class function TNamespace.uniqueUrl(const aurl: string): string;
begin
  result := namespaceCache(aurl).uniqueUrl;
end;

class procedure TNamespace.freeCache;
begin
  FreeAndNil(globalNamespaceCache);
end;

function TNamespace.getPrefix: string;
begin
  if self = nil then exit('');
  result := prefix;
end;

function TNamespace.getURL: string;
begin
  if self = nil then exit('');
  result := url;
end;

function TNamespace.serialize: string;
begin
  if prefix = '' then result := 'xmlns="'+xmlStrEscape(url, true)+'"'
  else result := 'xmlns:'+prefix+'="'+xmlStrEscape(url, true)+'"'
end;

destructor TNamespace.Destroy;
begin
  inherited Destroy;
end;

initialization
  XMLNamespace_XML := TNamespace.Make(XMLNamespaceUrl_XML, 'xml');
  XMLNamespace_XMLNS := TNamespace.Make(XMLNamespaceUrl_XMLNS, 'xmlns');

end.

xquery.namespaces.pas (9,178 bytes)   
xquery.internals.common.pas (14,185 bytes)   
unit xquery.internals.common;

{
Copyright (C) 2008 - 2019 Benito van der Zander (BeniBela)
                          benito@benibela.de
                          www.benibela.de

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

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.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

}

{$I ../internettoolsconfig.inc}

interface

uses
  classes, contnrs, SysUtils, {$ifdef USE_FLRE}FLRE{$else}ghashmap{$endif}, bbutils;

type

  TXQHashKeyString = {$ifdef USE_FLRE}TFLRERawByteString{$else}RawByteString{$endif};
{$ifndef USE_FLRE}TXQHash = record
  class function hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt; static;
end;{$endif}
generic TXQHashmapStr<TValue> = class({$ifdef USE_FLRE}TFLRECacheHashMap{$else}specialize THashmap<TXQHashKeyString, TValue, TXQHash>{$endif})
protected
  function GetValue(const Key: TXQHashKeyString): TValue; inline;
  procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
public
  procedure Add(const Key:TXQHashKeyString; const AValue:TValue); inline;
  property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
end;
generic TXQHashmapStrOwning<TValue, TOwningList> = class(specialize TXQHashmapStr<TValue>)
protected
  owner: TOwningList;
  procedure SetValue(const Key: TXQHashKeyString; const AValue: TValue); inline;
public
  constructor create;
  destructor destroy; override;
  procedure Add(const Key:TXQHashKeyString; const Value:TValue); inline;
  property Values[const Key:TXQHashKeyString]: TValue read GetValue write SetValue; default;
end;
generic TXQHashmapStrOwningGenericObject<TValue> = class(specialize TXQHashmapStrOwning<TValue, TObjectList>);
TXQHashmapStrOwningObject = specialize TXQHashmapStrOwningGenericObject<TObject>;

//**a list to store interfaces, similar to TInterfaceList, but faster, because
//**  (1) it assumes all added interfaces are non nil
//**  (2) it is not thread safe
//**  (3) it is generic, so you need no casting
generic TFastInterfaceList<IT> = class
  type PIT = ^IT;
protected
  fcount, fcapacity: integer; // count
  fbuffer: PIT; // Backend storage
  procedure raiseInvalidIndexError(i: integer);  //**< Raise an exception
  procedure checkIndex(i: integer); inline; //**< Range check
  procedure reserve(cap: integer); //**< Allocates new memory if necessary
  procedure compress; //**< Deallocates memory by shorting list if necessary
  procedure setCount(c: integer); //**< Forces a count (elements are initialized with )
  procedure setBufferSize(c: integer);
  procedure insert(i: integer; child: IT);
  procedure put(i: integer; const AValue: IT); inline; //**< Replace the IT at position i
public
  constructor create(capacity: integer = 0);
  destructor Destroy; override;
  procedure delete(i: integer); //**< Deletes a value (since it is an interface, the value is freed iff there are no other references to it remaining)
  procedure remove(const value: IT);
  procedure add(const value: IT);
  procedure addAll(other: TFastInterfaceList);
  function get(i: integer): IT; inline; //**< Gets an interface from the list.
  function last: IT; //**< Last interface in the list.
  function first: IT; //**< First interface in the list.
  procedure clear;
  property items[i: integer]: IT read get write put; default;
  property Count: integer read fcount write setCount;
end;

type TXHTMLStrBuilder = object(TStrBuilder)
  procedure appendHTMLText(inbuffer: pchar; len: SizeInt);
  procedure appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
  procedure appendHTMLText(const s: string);
  procedure appendHTMLAttrib(const s: string);
end;

function xmlStrEscape(s: string; attrib: boolean = false):string;
function xmlStrWhitespaceCollapse(const s: string):string;
function htmlStrEscape(s: string; attrib: boolean = false):string;
function strSplitOnAsciiWS(s: string): TStringArray;
function urlHexDecode(s: string): string;


function nodeNameHash(const s: RawByteString): cardinal;
function nodeNameHashCheckASCII(const s: RawByteString): cardinal;



type  TRaiseXQEvaluationExceptionCallback = procedure (const code, message: string);

var raiseXQEvaluationExceptionCallback: TRaiseXQEvaluationExceptionCallback = nil;

procedure raiseXQEvaluationException(const code, message: string); overload; noreturn;

type xqfloat = double;
function xqround(const f: xqfloat): Int64;

implementation

function xqround(const f: xqfloat): Int64;
var tempf: xqfloat;
begin
  tempf := f + 0.5;
  result := trunc(tempf);
  if frac(tempf) < 0 then result -= 1;
end;


function TXQHashmapStr.GetValue(const Key: TXQHashKeyString): TValue;
begin
  {$ifdef USE_FLRE}
  result := TValue(pointer(inherited GetValue(key)));
  {$else}
  if not inherited GetValue(key, result) then result := default(TValue);
  {$endif}
end;

procedure TXQHashmapStr.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
begin
  {$ifdef USE_FLRE}
  inherited SetValue(key, TFLRECacheHashMapData(pointer(AValue)) );
  {$else}
  insert(key, AValue);
  {$endif}
end;

procedure TXQHashmapStr.Add(const Key: TXQHashKeyString; const AValue: TValue);
begin
  {$ifdef USE_FLRE}
  inherited Add(key, TFLRECacheHashMapData(pointer(AValue)));
  {$else}
  insert(key, AValue);
  {$endif}
end;

procedure TXQHashmapStrOwning.SetValue(const Key: TXQHashKeyString; const AValue: TValue);
var
  old: TValue;
begin
  old := GetValue(key);
  if old = AValue then exit;
  if old <> nil then owner.remove(old);
  add(key, Avalue);
end;

constructor TXQHashmapStrOwning.create;
begin
  inherited;
  owner := TOwningList.create;
end;

destructor TXQHashmapStrOwning.destroy;
begin
  owner.free;
  inherited destroy;
end;

procedure TXQHashmapStrOwning.Add(const Key: TXQHashKeyString; const Value: TValue);
begin
  owner.add(value);
  inherited add(key, value);
end;


function xmlStrEscape(s: string; attrib: boolean = false):string;
var
  i: Integer;
  builder: TStrBuilder;

begin
  builder.init(@result, length(s));
  i := 1;
  while i <= length(s) do begin
    case s[i] of
      '<': builder.append('&lt;');
      '>': builder.append('&gt;');
      '&': builder.append('&amp;');
      '''': builder.append('&apos;');
      '"': builder.append('&quot;');
      #13: builder.append('&#xD;');
      #10: if attrib then builder.append('&#xA;') else builder.append(#10);
      #9: if attrib then builder.append('&#x9;') else builder.append(#9);
      #0..#8,#11,#12,#14..#$1F,#$7F: builder.appendhexentity(ord(s[i]));
      #$C2: if (i = length(s)) or not (s[i+1] in [#$80..#$9F]) then builder.append(#$C2) else begin
        i+=1;
        builder.appendhexentity(ord(s[i]));
      end;
      #$E2: if (i + 2 > length(s)) or (s[i+1] <> #$80) or (s[i+2] <> #$A8) then builder.append(#$E2) else begin
        builder.append('&#x2028;');
        i+=2;
      end;
      else builder.append(s[i]);
    end;
    i+=1;
  end;
  builder.final;
end;

function xmlStrWhitespaceCollapse(const s: string): string;
begin
  result := strTrimAndNormalize(s, [#9,#$A,#$D,' ']);
end;

procedure TXHTMLStrBuilder.appendHTMLText(inbuffer: pchar; len: SizeInt);
var
  inbufferend: pchar;
begin
  inbufferend := inbuffer + len;
  reserveadd(len);
  while inbuffer < inbufferend do begin
    case inbuffer^ of
      '&': append('&amp;');
      '<': append('&lt;');
      '>': append('&gt;');
      else append(inbuffer^);
    end;
    inc(inbuffer);
  end;
end;


procedure TXHTMLStrBuilder.appendHTMLAttrib(inbuffer: pchar; len: SizeInt);
var
  inbufferend: pchar;
begin
  inbufferend := inbuffer + len;
  reserveadd(len);
  while inbuffer < inbufferend do begin
    case inbuffer^ of
      '&': append('&amp;');
      '"': append('&quot;');
      '''': append('&apos;');
      else append(inbuffer^);
    end;
    inc(inbuffer);
  end;
end;

procedure TXHTMLStrBuilder.appendHTMLText(const s: string);
begin
  appendHTMLText(pchar(pointer(s)), length(s));
end;
procedure TXHTMLStrBuilder.appendHTMLAttrib(const s: string);
begin
  appendHTMLAttrib(pchar(pointer(s)), length(s));
end;

function htmlStrEscape(s: string; attrib: boolean): string;
var
  i: Integer;
  builder: TXHTMLStrBuilder;

begin
  builder.init(@result, length(s));
  if attrib then builder.appendHTMLAttrib(s)
  else builder.appendHTMLText(s);
  builder.final;
end;

function strSplitOnAsciiWS(s: string): TStringArray;
begin
  result := strSplit(strTrimAndNormalize(s, [#9,#$A,#$C,#$D,' ']), ' ');
end;

function urlHexDecode(s: string): string;
var
  p: Integer;
  i: Integer;
begin
  SetLength(result, length(s));
  p := 1;
  i := 1;
  while i <= length(s) do begin
    case s[i] of
      '+': result[p] := ' ';
      '%': if (i + 2 <= length(s)) and (s[i+1] in ['a'..'f','A'..'F','0'..'9']) and (s[i+2] in ['a'..'f','A'..'F','0'..'9']) then begin
        result[p] := chr(StrToInt('$'+s[i+1]+s[i+2])); //todo: optimize
        i+=2;
      end else raiseXQEvaluationException('pxp:uri', 'Invalid input string at: '+copy(s,i,10))
      else result[p] := s[i];
    end;
    i+=1;
    p+=1;
  end;
  setlength(result, p-1);
end;








{$PUSH}{$RangeChecks off}{$OverflowChecks off}
function nodeNameHash(const s: RawByteString): cardinal;
var
  p, last: PByte;
begin
  if s = '' then exit(1);
  p := pbyte(pointer(s));
  last := p + length(s);
  result := 0;
  while p < last do begin
    if p^ < 128  then begin //give the same hash independent of latin1/utf8 encoding and collation
      result := result + p^;
      if (p^ >= ord('a')) and (p^ <= ord('z')) then result := result - ord('a') + ord('A');
      result := result + (result shl 10);
      result := result xor (result shr 6);
    end;
    inc(p);
  end;

  result := result + (result shl 3);
  result := result xor (result shr 11);
  result := result + (result shl 15);
  //remember to update HTMLNodeNameHashs when changing anything here;
end;
function nodeNameHashCheckASCII(const s: RawByteString): cardinal;
var
  i: Integer;
begin
  for i := 1 to length(s) do if s[i] >= #128 then exit(0);
  result := nodeNameHash(s);
end;
{$ifndef USE_FLRE}
class function TXQHash.hash(const a: TXQHashKeyString; n: SizeUInt): SizeUInt;
begin
  result := nodeNameHash(a) and (n-1);
end;
{$endif}

{$POP}


procedure raiseXQEvaluationException(const code, message: string); noreturn;
begin
  if Assigned(raiseXQEvaluationExceptionCallback) then raiseXQEvaluationExceptionCallback(code, message)
  else raise exception.Create(code + ': ' + message);
end;






procedure TFastInterfaceList.raiseInvalidIndexError(i: integer);
begin
  raiseXQEvaluationException('pxp:INTERNAL', 'Invalid index: '+IntToStr(i));
end;

procedure TFastInterfaceList.checkIndex(i: integer);
begin
  if (i < 0) or (i >= fcount) then raiseInvalidIndexError(i);
end;


procedure TFastInterfaceList.put(i: integer; const AValue: IT); inline;
begin
  checkIndex(i);
  fbuffer[i] := AValue;
end;

procedure TFastInterfaceList.delete(i: integer);
begin
  checkIndex(i);
  fbuffer[i] := nil;
  if i <> fcount - 1 then begin
    move(fbuffer[i+1], fbuffer[i], (fcount - i - 1) * sizeof(IT));
    FillChar(fbuffer[fcount-1], sizeof(fbuffer[fcount-1]), 0);
  end;
  fcount -= 1;
  compress;
end;

procedure TFastInterfaceList.remove(const value: IT);
var
  i: Integer;
begin
  for i := fcount - 1 downto 0 do
    if fbuffer[i] = value then
      delete(i);
end;

procedure TFastInterfaceList.add(const value: IT);
begin
  if fcount = fcapacity then
    reserve(fcount + 1);
  PPointer(fbuffer)[fcount] := value;
  value._AddRef;
  fcount += 1;
end;

procedure TFastInterfaceList.addAll(other: TFastInterfaceList);
var
  i: Integer;
begin
  reserve(fcount + other.Count);
  for i := 0 to other.Count - 1 do
    add(other.fbuffer[i]);
end;

function TFastInterfaceList.get(i: integer): IT;
begin
  checkIndex(i);
  result := fbuffer[i];
end;

function TFastInterfaceList.last: IT;
begin
  checkIndex(0);
  result := fbuffer[fcount-1];
end;

function TFastInterfaceList.first: IT;
begin
  checkIndex(0);
  result := fbuffer[0];
end;




{$ImplicitExceptions off}

procedure TFastInterfaceList.setBufferSize(c: integer);
begin
  ReAllocMem(fbuffer, c * sizeof(IT));
  fcapacity := c;
end;

procedure TFastInterfaceList.reserve(cap: integer);
var
  oldcap: Integer;
begin
  if cap <= fcapacity then exit;

  oldcap := fcapacity;
  if cap < 4 then setBufferSize(4)
  else if (cap < 1024) and (cap <= fcapacity * 2) then setBufferSize(fcapacity * 2)
  else if (cap < 1024) then setBufferSize(cap)
  else if cap <= fcapacity + 1024 then setBufferSize(fcapacity + 1024)
  else setBufferSize(cap);

  FillChar(fbuffer[oldcap], sizeof(IT) * (fcapacity - oldcap), 0);
end;

procedure TFastInterfaceList.compress;
begin
  if fcount <= fcapacity div 2 then setBufferSize(fcapacity div 2)
  else if fcount <= fcapacity - 1024 then setBufferSize(fcapacity - 1024);
end;

procedure TFastInterfaceList.setCount(c: integer);
var
  i: Integer;
begin
  reserve(c);
  if c < fcount then begin
    for i := c to fcount - 1 do
      fbuffer[i]._Release;
    FillChar(fbuffer[c], (fcount - c) * sizeof(IT), 0);
  end;
  fcount:=c;
end;




{$ImplicitExceptions on}

procedure TFastInterfaceList.clear;
var
  i: Integer;
begin
  for i := 0 to fcount - 1 do
    fbuffer[i]._Release;
  fcount:=0;
  setBufferSize(0);
end;

destructor TFastInterfaceList.Destroy;
begin
  clear;
  inherited Destroy;
end;

procedure TFastInterfaceList.insert(i: integer; child: IT);
begin
  reserve(fcount + 1);
  if i <> fcount then begin
    checkIndex(i);
    move(fbuffer[i], fbuffer[i+1], (fcount - i) * sizeof(fbuffer[i]));
    fillchar(fbuffer[i],sizeof(fbuffer[i]),0);
  end;
  fbuffer[i] := child;
  fcount+=1;
end;

constructor TFastInterfaceList.create(capacity: integer);
begin
  reserve(capacity);
  fcount := 0;
end;



end.

xquery.internals.common.pas (14,185 bytes)   

Benito van der Zander

2019-05-21 12:30

reporter   ~0116304

This is my 300th bug tracker report!

Issue History

Date Modified Username Field Change
2019-05-21 12:27 Benito van der Zander New Issue
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.o
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.ppu
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces-2.o
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces-2.ppu
2019-05-21 12:27 Benito van der Zander File Added: xquery.namespaces.pas
2019-05-21 12:27 Benito van der Zander File Added: xquery.internals.common.pas
2019-05-21 12:30 Benito van der Zander Note Added: 0116304