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

+ "compproc" helpers

Browse Source 
* renamed several helpers so that their name is the same as their
    "public alias", which should facilitate the conversion of processor
    specific code in the code generator to processor independent code
  * some small fixes to the val_ansistring and val_widestring helpers
    (always immediately exit if the source string is longer than 255
     chars)
  * fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
    still nil (used to crash, now return resp -1 and 0)
This commit is contained in:
Jonas Maebe 2001-08-01 15:00:09 +00:00
parent 616c6ef979
commit b9f6efc85b
16 changed files with 878 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
rtl/i386/i386.inc
View File

@ -91,7 +91,9 @@ end ['EAX','EBX','ECX','ESI','EDI'];
{$define FPC_SYSTEM_HAS_FILLCHAR}
Procedure FillChar(var x;count:longint;value:byte);
[public,alias: 'FPC_FILLCHAR'];assembler;
{ alias seems to be nowhere used? (JM)
[public,alias: 'FPC_FILLCHAR']; }
assembler;
asm
cld
movl x,%edi
@ -403,7 +405,7 @@ end['EAX','EBX','ECX','EDX','ESI'];
****************************************************************************}
{$define FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
procedure int_help_constructor;assembler; [public,alias:'FPC_HELP_CONSTRUCTOR'];
procedure fpc_help_constructor; assembler; [public,alias:'FPC_HELP_CONSTRUCTOR']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
{ Entry without preamble, since we need the ESP of the constructor
Stack (relative to %ebp):
@ -481,7 +483,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL}
procedure int_help_fail;assembler;[public,alias:'FPC_HELP_FAIL'];
procedure fpc_help_fail;assembler;[public,alias:'FPC_HELP_FAIL']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ should be called with a object that needs to be
freed if VMT field is at -1
%edi contains VMT offset in object again }
@ -515,7 +517,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
procedure int_help_destructor;assembler;[public,alias:'FPC_HELP_DESTRUCTOR'];
procedure fpc_help_destructor;assembler;[public,alias:'FPC_HELP_DESTRUCTOR']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
{ Stack (relative to %ebp):
12 Self
@ -553,7 +555,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS}
procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
procedure fpc_new_class;assembler;[public,alias:'FPC_NEW_CLASS']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
{ to be sure in the future, we save also edit }
pushl %edi
@ -587,7 +589,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS}
procedure int_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
procedure fpc_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
{ to be sure in the future, we save also edit }
pushl %edi
@ -615,13 +617,13 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL_CLASS}
procedure int_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS'];
procedure fpc_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ a non zero class must allways be disposed
VMT is allways at pos 0 }
asm
testl %esi,%esi
je .LHFC_1
call INT_DISPOSE_CLASS
call FPC_DISPOSE_CLASS
{ set both object places to zero }
xorl %esi,%esi
movl %esi,8(%ebp)
@ -632,20 +634,12 @@ end;
{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT}
{$ifdef SYSTEMDEBUG}
{ we want the stack for debugging !! PM }
procedure int_check_object(obj : pointer);[public,alias:'FPC_CHECK_OBJECT'];
procedure fpc_check_object(obj : pointer);[public,alias:'FPC_CHECK_OBJECT']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{$else not SYSTEMDEBUG}
procedure int_check_object;assembler;[public,alias:'FPC_CHECK_OBJECT'];
{$endif not SYSTEMDEBUG}
asm
pushl %edi
{$ifdef SYSTEMDEBUG}
movl obj,%edi
{$else not SYSTEMDEBUG}
movl 8(%esp),%edi
{$endif not SYSTEMDEBUG}
pushl %eax
{ Here we must check if the VMT pointer is nil before }
{ accessing it... }
@ -661,17 +655,12 @@ asm
popl %eax
popl %edi
{ the adress is pushed : it needs to be removed from stack !! PM }
{$ifdef SYSTEMDEBUG}
end;{ of asm }
end;
{$else SYSTEMDEBUG}
ret $4
end;
{$endif not SYSTEMDEBUG}
{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
procedure int_check_object_ext;assembler;[public,alias:'FPC_CHECK_OBJECT_EXT'];
procedure fpc_check_object_ext;assembler;[public,alias:'FPC_CHECK_OBJECT_EXT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ checks for a correct vmt pointer }
{ deeper check to see if the current object is }
{ really related to the true }
@ -717,7 +706,7 @@ end;
****************************************************************************}
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY}
procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
this procedure must save all modified registers except EDI and ESI !!!
}
@ -760,8 +749,8 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
procedure int_strconcat(s1,s2:pointer);
[public,alias:'FPC_SHORTSTR_CONCAT'];
procedure fpc_shortstr_concat(s1,s2:pointer);
[public,alias:'FPC_SHORTSTR_CONCAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
asm
movl s2,%edi
@ -800,7 +789,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
procedure int_strcmp(dstr,sstr:pointer);[public,alias:'FPC_SHORTSTR_COMPARE'];
function fpc_shortstr_compare(dstr,sstr:pointer): longint; [public,alias:'FPC_SHORTSTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
asm
cld
@ -850,7 +839,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
function strpas(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR'];
function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$include strpas.inc}
{$define FPC_SYSTEM_HAS_STRLEN}
@ -858,7 +847,7 @@ function strlen(p:pchar):longint;assembler;
{$include strlen.inc}
{$define FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
function strchararray(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR'];
function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
asm
cld
@ -1115,7 +1104,18 @@ procedure inclocked(var l : longint);assembler;
{
$Log$
Revision 1.13 2001-07-08 21:00:18 peter
Revision 1.14 2001-08-01 15:00:09 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.13 2001/07/08 21:00:18 peter
* various widestring updates, it works now mostly without charset
mapping supported

54
rtl/i386/rttip.inc
View File

@ -18,7 +18,9 @@
{ much faster }
{$define FPC_SYSTEM_HAS_FPC_INITIALIZE}
Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias:'FPC_INITIALIZE'];assembler;
Procedure fpc_Initialize (Data,TypeInfo : pointer);[Public,Alias:'FPC_INITIALIZE']; {$ifdef hascompilerproc} compilerproc; {$endif}
assembler;
asm
// Save registers
push %eax
@ -90,7 +92,7 @@ asm
addl $4,%ebx
// push data
pushl %eax
call Initialize
call INT_INITIALIZE
jmp .LMyRecordInitLoop
// Array handling
.LDoArrayInit:
@ -118,7 +120,7 @@ asm
addl Data,%eax
// push data
pushl %eax
call Initialize
call INT_INITIALIZE
jmp .LMyArrayInitLoop
// AnsiString handling :
.LDoAnsiStringInit:
@ -133,7 +135,9 @@ end;
{$define FPC_SYSTEM_HAS_FPC_FINALIZE}
Procedure int_finalize (Data,TypeInfo: Pointer);[Public,Alias:'FPC_FINALIZE'];assembler;
Procedure fpc_finalize (Data,TypeInfo: Pointer);[Public,Alias:'FPC_FINALIZE']; {$ifdef hascompilerproc} compilerproc; {$endif}
assembler;
asm
push %eax
push %ebx
@ -167,7 +171,7 @@ asm
// Interfaces
.LDoInterfaceFinal:
pushl Data
call Int_Intf_Decr_Ref
call Intf_Decr_Ref
jmp .LExitFinalize
// Variants
.LDoVariantFinal:
@ -176,7 +180,7 @@ asm
.LDoDynArrayFinal:
pushl TypeInfo
pushl Data
call DYNARRAY_DECR_REF
call FPC_DYNARRAY_DECR_REF
jmp .LExitFinalize
.LDoClassFinal:
.LDoObjectFinal:
@ -237,7 +241,7 @@ asm
// AnsiString handling :
.LDoAnsiStringFinal:
pushl Data
call ANSISTR_DECR_REF
call FPC_ANSISTR_DECR_REF
.LExitFinalize:
pop %edx
pop %ecx
@ -247,7 +251,9 @@ end;
{$define FPC_SYSTEM_HAS_FPC_ADDREF}
Procedure Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF'];Assembler;
Procedure fpc_Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF']; {$ifdef hascompilerproc} compilerproc; {$endif}
Assembler;
asm
// Save registers
push %eax
@ -282,7 +288,7 @@ asm
// Interfaces
.LDoInterfaceAddRef:
pushl Data
call INT_INTF_INCR_REF
call INTF_INCR_REF
jmp .LExitAddRef
// Variants
.LDoVariantAddRef:
@ -316,7 +322,7 @@ asm
addl $4,%ebx
// push data
pushl %eax
call ADDREF
call INT_ADDREF
jmp .LMyRecordAddRefLoop
// Array handling
.LDoArrayAddRef:
@ -344,12 +350,12 @@ asm
addl Data,%eax
// push data
pushl %eax
call ADDREF
call INT_ADDREF
jmp .LMyArrayAddRefLoop
// AnsiString handling :
.LDoAnsiStringAddRef:
pushl Data
call ANSISTR_INCR_REF
call FPC_ANSISTR_INCR_REF
.LExitAddRef:
pop %edx
pop %ecx
@ -359,7 +365,8 @@ end;
{$define FPC_SYSTEM_HAS_FPC_DECREF}
Procedure DecRef (Data,TypeInfo : Pointer); [Public,alias : 'FPC_DECREF'];Assembler;
Procedure fpc_DecRef (Data,TypeInfo : Pointer); [Public,alias : 'FPC_DECREF']; {$ifdef hascompilerproc} compilerproc; {$endif}
Assembler;
asm
// Save registers
push %eax
@ -394,7 +401,7 @@ asm
// Interfaces
.LDoInterfaceDecRef:
pushl Data
call INT_INTF_DECR_REF
call INTF_DECR_REF
jmp .LExitDecRef
// Variants
.LDoVariantDecRef:
@ -429,7 +436,7 @@ asm
addl $4,%ebx
// push data
pushl %eax
call DECREF
call INT_DECREF
jmp .LMyRecordDecRefLoop
// Array handling
.LDoArrayDecRef:
@ -457,13 +464,13 @@ asm
addl Data,%eax
// push data
pushl %eax
call DECREF
call INT_DECREF
jmp .LMyArrayDecRefLoop
// AnsiString handling :
.LDoAnsiStringDecRef:
movl Data,%eax
pushl %eax
call ANSISTR_DECR_REF
call FPC_ANSISTR_DECR_REF
.LExitDecRef:
pop %edx
pop %ecx
@ -473,7 +480,18 @@ end;
{
$Log$
Revision 1.9 2001-05-31 22:42:56 florian
Revision 1.10 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.9 2001/05/31 22:42:56 florian
* some fixes for widestrings and variants
Revision 1.8 2001/04/23 18:25:44 peter

57
rtl/i386/set.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
{$define FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
procedure do_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL'];
procedure fpc_set_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
load a normal set p from a smallset l
}
@ -31,7 +31,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
procedure do_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT'];
procedure fpc_set_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
create a new set in p from an element b
}
@ -56,7 +56,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
procedure do_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE'];
procedure fpc_set_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
add the element b to the set pointed by p
}
@ -75,7 +75,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
procedure do_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE'];
procedure fpc_set_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
suppresses the element b to the set pointed by p
used for exclude(set,element)
@ -95,7 +95,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
procedure do_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE'];
procedure fpc_set_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
adds the range [l..h] to the set pointed to by p
}
@ -142,7 +142,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
procedure do_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE'];
procedure fpc_set_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
tests if the element b is in the set p the carryflag is set if it present
}
@ -161,7 +161,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
procedure do_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS'];
procedure fpc_set_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
adds set1 and set2 into set dest
}
@ -181,7 +181,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
procedure do_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS'];
procedure fpc_set_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
multiplies (takes common elements of) set1 and set2 result put in dest
}
@ -201,7 +201,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SUB_SETS}
procedure do_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS'];
procedure fpc_set_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
computes the diff from set1 to set2 result in dest
}
@ -223,7 +223,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS}
procedure do_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS'];
procedure fpc_set_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
computes the symetric diff from set1 to set2 result in dest
}
@ -244,7 +244,7 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
procedure do_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS'];
procedure fpc_set_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
compares set1 and set2 zeroflag is set if they are equal
}
@ -268,9 +268,8 @@ end;
{$IfNDef NoSetInclusion}
{$define FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
procedure do_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS'];
procedure fpc_set_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
@ -292,11 +291,10 @@ asm
we have zero flag set, and that what is expected }
.LMCONTAINSSETEND:
end;
{$EndIf SetInclusion}
{$ifdef LARGESETS}
procedure do_set(p : pointer;b : word);assembler;[public,alias:'FPC_SET_SET_WORD'];
procedure fpc_largeset_set_wor(p : pointer;b : word);assembler;[public,alias:'FPC_LARGESET_SET_WORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
sets the element b in set p works for sets larger than 256 elements
not yet use by the compiler so
@ -315,7 +313,7 @@ asm
end;
procedure do_in(p : pointer;b : word);assembler;[public,alias:'FPC_SET_IN_WORD'];
procedure fpc_largeset_in_word(p : pointer;b : word);assembler;[public,alias:'FPC_LARGESET_IN_WORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
tests if the element b is in the set p the carryflag is set if it present
works for sets larger than 256 elements
@ -334,7 +332,7 @@ asm
end;
procedure add_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_ADD_SETS_SIZE'];
procedure fpc_largeset_add_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_LARGESET_ADD_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
adds set1 and set2 into set dest size is the number of bytes in the set
}
@ -353,7 +351,7 @@ asm
end;
procedure mul_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_MUL_SETS_SIZE'];
procedure fpc_largeset_mul_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_LARGESET_MUL_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
multiplies (i.E. takes common elements of) set1 and set2 result put in
dest size is the number of bytes in the set
@ -373,7 +371,7 @@ asm
end;
procedure sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SUB_SETS_SIZE'];
procedure fpc_largeset_sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_LARGESET_SUB_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
movl set1,%esi
movl set2,%ebx
@ -391,7 +389,7 @@ asm
end;
procedure sym_sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SYMDIF_SETS_SIZE'];
procedure fpc_largeset_symdif_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_LARGESET_SYMDIF_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
computes the symetric diff from set1 to set2 result in dest
}
@ -411,7 +409,7 @@ asm
end;
procedure comp_sets(set1,set2 : pointer;size : longint);assembler;[public,alias:'FPC_SET_COMP_SETS_SIZE'];
procedure fpc_largeset_comp_sets(set1,set2 : pointer;size : longint);assembler;[public,alias:'FPC_LARGESET_COMP_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
asm
movl set1,%esi
movl set2,%edi
@ -429,8 +427,7 @@ asm
.LMCOMPSETSIZEEND:
end;
{$IfNDef NoSetInclusion}
procedure contains_sets(set1,set2 : pointer; size: longint);assembler;[public,alias:'FPC_SET_CONTAINS_SETS'];
procedure fpc_largeset_contains_sets(set1,set2 : pointer; size: longint);assembler;[public,alias:'FPC_LARGESET_CONTAINS_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
@ -452,14 +449,24 @@ asm
we have zero flag set, and that what is expected }
.LMCONTAINSSETEND2:
end;
{$EndIf NoSetInclusion}
{$endif LARGESET}
{
$Log$
Revision 1.4 2001-05-09 19:57:07 peter
Revision 1.5 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.4 2001/05/09 19:57:07 peter
*** empty log message ***
Revision 1.3 2000/09/21 16:09:19 jonas

47
rtl/inc/aliases.inc Normal file
View File

@ -0,0 +1,47 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Florian Klaempfl
member of the Free Pascal development team.
This file contains external definitions (which map to aliases
of functions which are later implemented) so that they can
be called before their implementation is known. We can't use
forward definitions, because there's a bug which causes all
sorts of trouble if you you first declare a procedure as
forward, then call it and then implement it using an
"external name 'bla'" where 'bla' is a public alias of a
procedure defined after the call to the forward defined
procedure.
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.
**********************************************************************
}
{ export for internal usage }
Procedure int_Finalize (Data,TypeInfo: Pointer); [external name 'FPC_FINALIZE'];
Procedure int_Addref (Data,TypeInfo : Pointer);saveregisters; [external name 'FPC_ADDREF'];
Procedure int_DecRef (Data, TypeInfo : Pointer);saveregisters;[external name 'FPC_DECREF'];
Procedure int_Initialize (Data,TypeInfo: Pointer); [external name 'FPC_INITIALIZE'];
procedure int_FinalizeArray(data,typeinfo : pointer;count,size : longint); [external name 'FPC_FINALIZEARRAY'];
{
$Log$
Revision 1.1 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
}

190
rtl/inc/astrings.inc
View File

@ -106,7 +106,7 @@ begin
end;
Procedure AnsiStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_DECR_REF'];
Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Decreases the ReferenceCount of a non constant ansistring;
If the reference count is zero, deallocate the string;
@ -130,8 +130,12 @@ Begin
S:=nil;
end;
{$ifdef hascompilerproc}
{ also define alias for internal use in the system unit }
Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer); [external name 'FPC_ANSISTR_DECR_REF'];
{$endif hascompilerproc}
Procedure AnsiStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_INCR_REF'];
Procedure fpc_AnsiStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
If S=Nil then
exit;
@ -140,8 +144,12 @@ Begin
inclocked(PAnsiRec(S-FirstOff)^.Ref);
end;
{$ifdef hascompilerproc}
{ also define alias which can be used inside the system unit }
Procedure fpc_AnsiStr_Incr_Ref (Var S : Pointer); [external name 'FPC_ANSISTR_INCR_REF'];
{$endif hascompilerproc}
Procedure AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN'];
Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Assigns S2 to S1 (S1:=S2), taking in account reference counts.
}
@ -150,13 +158,17 @@ begin
If PAnsiRec(S2-FirstOff)^.Ref>0 then
inclocked(PAnsiRec(S2-FirstOff)^.ref);
{ Decrease the reference count on the old S1 }
ansistr_decr_ref (S1);
fpc_ansistr_decr_ref (S1);
{ And finally, have S1 pointing to S2 (or its copy) }
S1:=S2;
end;
{$ifdef hascompilerproc}
{ alias for internal use }
Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_ANSISTR_ASSIGN'];
{$endif hascompilerproc}
Procedure AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_ANSISTR_CONCAT'];
Procedure fpc_AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_ANSISTR_CONCAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Concatenates 2 AnsiStrings : S1+S2.
Result Goes to S3;
@ -166,15 +178,14 @@ Var
begin
{ only assign if s1 or s2 is empty }
if (S1=Nil) then
AnsiStr_Assign(S3,S2)
fpc_AnsiStr_Assign(S3,S2)
else
if (S2=Nil) then
AnsiStr_Assign(S3,S1)
fpc_AnsiStr_Assign(S3,S1)
else
begin
{ create new result }
if S3<>nil then
AnsiStr_Decr_Ref(S3);
fpc_AnsiStr_Decr_Ref(S3);
Size:=PAnsiRec(S2-FirstOff)^.Len;
Location:=Length(AnsiString(S1));
SetLength (AnsiString(S3),Size+Location);
@ -206,7 +217,7 @@ end;
{$endif EXTRAANSISHORT}
Procedure AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR'];
Procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a AnsiString to a ShortString;
}
@ -226,7 +237,7 @@ begin
end;
Procedure ShortStr_To_AnsiStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_ANSISTR'];
Procedure fpc_ShortStr_To_AnsiStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a ShortString to a AnsiString;
}
@ -244,7 +255,7 @@ begin
end;
Procedure Char_To_AnsiStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_ANSISTR'];
Procedure fpc_Char_To_AnsiStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a ShortString to a AnsiString;
}
@ -256,13 +267,13 @@ begin
end;
Procedure PChar_To_AnsiStr(var a : ansistring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_ANSISTR'];
Procedure fpc_PChar_To_AnsiStr(var a : ansistring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
L : Longint;
begin
if pointer(a)<>nil then
begin
AnsiStr_Decr_Ref(Pointer(a));
fpc_AnsiStr_Decr_Ref(Pointer(a));
pointer(a):=nil;
end;
if (not assigned(p)) or (p[0]=#0) Then
@ -277,7 +288,7 @@ begin
end;
Procedure CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_ANSISTR'];
Procedure fpc_CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : longint;
begin
@ -293,7 +304,7 @@ begin
end;
Function AnsiStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSISTR_COMPARE'];
Function fpc_AnsiStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSISTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Compares 2 AnsiStrings;
The result is
@ -306,7 +317,7 @@ Var
begin
if S1=S2 then
begin
AnsiStr_Compare:=0;
fpc_AnsiStr_Compare:=0;
exit;
end;
Maxi:=Length(AnsiString(S1));
@ -316,18 +327,18 @@ begin
Temp:=CompareByte(S1^,S2^,MaxI);
if temp=0 then
temp:=Length(AnsiString(S1))-Length(AnsiString(S2));
AnsiStr_Compare:=Temp;
fpc_AnsiStr_Compare:=Temp;
end;
Procedure AnsiStr_CheckZero(p : pointer);[Public,Alias : 'FPC_ANSISTR_CHECKZERO'];
Procedure fpc_AnsiStr_CheckZero(p : pointer);[Public,Alias : 'FPC_ANSISTR_CHECKZERO']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if p=nil then
HandleErrorFrame(201,get_frame);
end;
Procedure AnsiStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_ANSISTR_RANGECHECK'];
Procedure fpc_AnsiStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_ANSISTR_RANGECHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if (index>len) or (Index<1) then
HandleErrorFrame(201,get_frame);
@ -336,7 +347,7 @@ end;
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : AnsiString; l : Longint);
{$else INTERNSETLENGTH}
Procedure AnsiStr_SetLength (Var S : AnsiString; l : Longint);[Public,Alias : 'FPC_ANSISTR_SETLENGTH'];
Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : Longint);[Public,Alias : 'FPC_ANSISTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif INTERNSETLENGTH}
{
Sets The length of string S to L.
@ -367,7 +378,7 @@ begin
else movelen := succ(length(s));
Move(Pointer(S)^,Temp^,movelen);
end;
ansistr_decr_ref(Pointer(S));
fpc_ansistr_decr_ref(Pointer(S));
Pointer(S):=Temp;
end;
{ Force nil termination in case it gets shorter }
@ -378,13 +389,13 @@ begin
begin
{ Length=0 }
if Pointer(S)<>nil then
ansistr_decr_ref (Pointer(S));
fpc_ansistr_decr_ref (Pointer(S));
Pointer(S):=Nil;
end;
end;
{$ifdef EXTRAANSISHORT}
Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint;
Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Compares a AnsiString with a ShortString;
The result is
@ -429,7 +440,10 @@ end;
{$endif INTERNLENGTH}
Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE'];
{ overloaded version of UniqueString for interface }
Procedure UniqueString(Var S : AnsiString); [external name 'FPC_ANSISTR_UNIQUE'];
Procedure fpc_ansistr_Unique(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Make sure reference count of S is 1,
using copy-on-write semantics.
@ -446,7 +460,7 @@ begin
SNew:=NewAnsiString (L);
Move (Pointer(S)^,SNew^,L+1);
PAnsiRec(SNew-FirstOff)^.len:=L;
ansistr_decr_ref (Pointer(S)); { Thread safe }
fpc_ansistr_decr_ref (Pointer(S)); { Thread safe }
Pointer(S):=SNew;
end;
end;
@ -530,92 +544,103 @@ begin
end;
Function ValAnsiFloat(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
Function fpc_Val_Real_AnsiStr(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : String;
begin
AnsiStr_To_ShortStr(SS,Pointer(S));
ValAnsiFloat := ValFloat(SS,Code);
end;
Function ValAnsiUnsignedInt (Const S : AnsiString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR'];
Var
SS : ShortString;
begin
AnsiStr_To_ShortStr(SS,Pointer(S));
ValAnsiUnsignedInt := ValUnsignedInt(SS,Code);
end;
Function ValAnsiSignedInt (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR'];
Var
SS : ShortString;
begin
ValAnsiSignedInt:=0;
if length(S)>255 then
code:=256
fpc_Val_Real_AnsiStr := 0;
if length(S) > 255 then
code := 256
else
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
ValAnsiSignedInt := ValSignedInt(DestSize,SS,Code);
end;
end;
Function ValAnsiUnsignedint64 (Const S : AnsiString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_ANSISTR'];
Var
SS : ShortString;
begin
ValAnsiUnsignedInt64:=0;
if length(S)>255 then
code:=256
else
begin
AnsiStr_To_ShortStr(SS,Pointer(S));
ValAnsiUnsignedInt64 := ValQWord(SS,Code);
SS := S;
Val(SS,fpc_Val_Real_AnsiStr,code);
end;
end;
Function ValAnsiSignedInt64 (Const S : AnsiString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_ANSISTR'];
Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
ValAnsiSignedInt64:=0;
if length(S)>255 then
code:=256
fpc_Val_UInt_AnsiStr := 0;
if length(S) > 255 then
code := 256
else
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
ValAnsiSignedInt64 := valInt64(SS,Code);
SS := S;
Val(SS,fpc_Val_UInt_AnsiStr,code);
end;
end;
procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
Function fpc_Val_SInt_AnsiStr (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_SInt_AnsiStr:=0;
if length(S)>255 then
code:=256
else
begin
SS := S;
fpc_Val_SInt_AnsiStr := fpc_Val_SInt_ShortStr(DestSize,SS,Code);
end;
end;
Function fpc_Val_UInt64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_UInt64_AnsiStr:=0;
if length(S)>255 then
code:=256
else
begin
SS := S;
Val(SS,fpc_Val_UInt64_AnsiStr,Code);
end;
end;
Function fpc_Val_SInt64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_SInt64_AnsiStr:=0;
if length(S)>255 then
code:=256
else
begin
SS := s;
Val(SS,fpc_Val_SInt64_AnsiStr,Code);
end;
end;
procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
ss : shortstring;
ss: ShortString;
begin
str_real(len,fr,d,treal_type(rt),ss);
s:=ss;
end;
Procedure AnsiStr_Cardinal(C : Cardinal;Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_CARDINAL'];
Procedure fpc_AnsiStr_UInt(C : Cardinal;Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
int_str_cardinal(C,Len,SS);
str(C:Len,SS);
S:=SS;
end;
Procedure AnsiStr_Longint(L : Longint; Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_LONGINT'];
Procedure fpc_AnsiStr_SInt(L : Longint; Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
int_Str_Longint (L,Len,SS);
str (L:Len,SS);
S:=SS;
end;
@ -707,7 +732,18 @@ end;
{
$Log$
Revision 1.16 2001-07-10 18:04:37 peter
Revision 1.17 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.16 2001/07/10 18:04:37 peter
* merged textfile, readlink and concat ansistring fixes
Revision 1.15 2001/07/09 21:15:41 peter

195
rtl/inc/compproc.inc Normal file
View File

@ -0,0 +1,195 @@
{
$Id$
This file is part of the Free Pascal Run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
This file contains the declarations of internal compiler helper
routines. That means you can *NOT* call these directly, as they may
be changed or even removed at any time. The only reason they are
included in the interface of the system unit, is so that the
compiler doesn't need special code to access their parameter
list information etc.
Note that due to the "compilerproc" directive, it isn't even possible
to use these routines in your programs.
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.
**********************************************************************}
{$ifdef hascompilerproc}
procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt); compilerproc;
procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer); compilerproc;
procedure fpc_shortstr_concat(s1,s2:pointer); compilerproc;
function fpc_shortstr_compare(dstr,sstr:pointer) : longint; compilerproc;
function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring; compilerproc;
procedure fpc_str_to_chararray(strtyp, arraysize: longint; src,dest: pchar);compilerproc;
function fpc_dynarray_length(p : pointer) : tdynarrayindex; compilerproc;
function fpc_dynarray_high(p : pointer) : tdynarrayindex; compilerproc;
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); compilerproc;
procedure fpc_dynarray_incr_ref(var p : pointer); compilerproc;
procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex); compilerproc;
function fpc_dynarray_copy(var p : pointer;ti : pointer;
dimcount : dword;dims : pdynarrayindex) : pointer; compilerproc;
procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring); compilerproc;
procedure fpc_ShortStr_Longint(v : longint;len : longint;var s : shortstring); compilerproc;
procedure fpc_shortstr_cardinal(v : cardinal;len : longint;var s : shortstring); compilerproc;
Function fpc_Val_SInt_ShortStr(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_Shortstr(Const S: ShortString; var Code: ValSInt): ValUInt; compilerproc;
Function fpc_Val_Real_ShortStr(const s : shortstring; var code : ValSInt): ValReal; compilerproc;
Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_AnsiStr_Incr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
Procedure fpc_AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer); compilerproc;
{$ifdef EXTRAANSISHORT}
Procedure fpc_AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString); compilerproc;
{$endif EXTRAANSISHORT}
Procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); compilerproc;
Procedure fpc_ShortStr_To_AnsiStr (Var S1 : Pointer; Const S2 : ShortString); compilerproc;
Procedure fpc_Char_To_AnsiStr(var S1 : Pointer; c : Char); compilerproc;
Procedure fpc_PChar_To_AnsiStr(var a : ansistring;p : pchar); compilerproc;
Procedure fpc_CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint); compilerproc;
Function fpc_AnsiStr_Compare(S1,S2 : Pointer): Longint; compilerproc;
Procedure fpc_AnsiStr_CheckZero(p : pointer); compilerproc;
Procedure fpc_AnsiStr_CheckRange(len,index : longint); compilerproc;
{$ifdef EXTRAANSISHORT}
Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint; compilerproc;
{$endif EXTRAANSISHORT}
Procedure fpc_ansistr_Unique(Var S : AnsiString); compilerproc;
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_WideStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); compilerproc;
Procedure fpc_ShortStr_To_WideStr (Var S1 : Pointer; Const S2 : ShortString); compilerproc;
Procedure fpc_WideStr_To_AnsiStr (Var S1 : Pointer;S2 : Pointer); compilerproc;
Procedure fpc_AnsiStr_To_WideStr (Var S1 : Pointer; Const S2 : Pointer); compilerproc;
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
Procedure fpc_WideStr_Concat (S1,S2 : Pointer;var S3 : Pointer); compilerproc;
Procedure fpc_Char_To_WideStr(var S1 : Pointer; c : Char); compilerproc;
Procedure fpc_PChar_To_WideStr(var a : widestring;p : pchar); compilerproc;
Procedure fpc_CharArray_To_WideStr(var a : widestring;p : pchar;l:longint); compilerproc;
Function fpc_WideStr_Compare(S1,S2 : Pointer): Longint; compilerproc;
Procedure fpc_WideStr_CheckZero(p : pointer); compilerproc;
Procedure fpc_WideStr_CheckRange(len,index : longint); compilerproc;
Procedure fpc_WideStr_SetLength (Var S : WideString; l : Longint); compilerproc;
Procedure fpc_widestr_Unique(Var S : WideString); compilerproc;
Function fpc_Val_Real_AnsiStr(Const S : AnsiString; Var Code : ValSInt): ValReal; compilerproc;
Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; Var Code : ValSInt): ValUInt; compilerproc;
Function fpc_Val_SInt_AnsiStr (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword;compilerproc;
Function fpc_Val_SInt64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): Int64; compilerproc;
procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring); compilerproc;
Procedure fpc_AnsiStr_UInt(C : Cardinal;Len : Longint; Var S : AnsiString); compilerproc;
Procedure fpc_AnsiStr_SInt(L : Longint; Len : Longint; Var S : AnsiString); compilerproc;
Function fpc_Val_Real_WideStr(Const S : WideString; Var Code : ValSInt): ValReal; compilerproc;
Function fpc_Val_UInt_WideStr (Const S : WideString; Var Code : ValSInt): ValUInt; compilerproc;
Function fpc_Val_SInt_WideStr (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt64_WideStr (Const S : WideString; Var Code : ValSInt): qword; compilerproc;
Function fpc_Val_SInt64_WideStr (Const S : WideString; Var Code : ValSInt): Int64; compilerproc;
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString); compilerproc;
Procedure fpc_WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString); compilerproc;
Procedure fpc_WideStr_Longint(L : Longint; Len : Longint; Var S : WideString); compilerproc;
function fpc_do_is(aclass : tclass;aobject : tobject) : boolean; compilerproc;
procedure fpc_do_as(aclass : tclass;aobject : tobject); compilerproc;
procedure fpc_intf_decr_ref(var i: pointer); compilerproc;
procedure fpc_intf_incr_ref(const i: pointer); compilerproc;
procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc;
procedure fpc_intf_as(var D: pointer; const S: pointer; const iid: TGUID); compilerproc;
Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); compilerproc;
Function fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer) : TObject; compilerproc;
Procedure fpc_PopAddrStack; compilerproc;
function fpc_PopObjectStack : TObject; compilerproc;
function fpc_PopSecondObjectStack : TObject; compilerproc;
Procedure fpc_ReRaise; compilerproc;
Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
Procedure fpc_DestroyException(o : TObject); compilerproc;
procedure fpc_help_constructor; compilerproc;
procedure fpc_help_fail; compilerproc;
procedure fpc_help_destructor; compilerproc;
procedure fpc_new_class; compilerproc;
procedure fpc_dispose_class; compilerproc;
procedure fpc_help_fail_class; compilerproc;
procedure fpc_check_object(obj : pointer); compilerproc;
procedure fpc_check_object_ext; compilerproc;
Procedure fpc_Initialize (Data,TypeInfo : pointer); compilerproc;
Procedure fpc_Finalize (Data,TypeInfo: Pointer); compilerproc;
Procedure fpc_Addref (Data,TypeInfo : Pointer); compilerproc;
Procedure fpc_DecRef (Data,TypeInfo : Pointer); compilerproc;
procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); compilerproc;
procedure fpc_set_load_small(p : pointer;l:longint); compilerproc;
procedure fpc_set_create_element(p : pointer;b : byte); compilerproc;
procedure fpc_set_set_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_unset_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_set_range(p : pointer;l,h : byte); compilerproc;
procedure fpc_set_in_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_add_sets(set1,set2,dest : pointer); compilerproc;
procedure fpc_set_mul_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_sub_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_symdif_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_comp_sets(set1,set2 : pointer); compilerproc;
procedure fpc_set_contains_sets(set1,set2 : pointer); compilerproc;
{$ifdef LARGESETS}
procedure fpc_largeset_set_word(p : pointer;b : word); compilerproc;
procedure fpc_largeset_in_word(p : pointer;b : word); compilerproc;
procedure fpc_largeset_add_sets(set1,set2,dest : pointer;size : longint); compilerproc;
procedure fpc_largeset_sets(set1,set2,dest : pointer;size : longint); compilerproc;
procedure fpc_largeset_sub_sets(set1,set2,dest : pointer;size : longint); compilerproc;
procedure fpc_largeset_symdif_sets(set1,set2,dest : pointer;size : longint); compilerproc;
procedure fpc_largeset_comp_sets(set1,set2 : pointer;size : longint); compilerproc;
procedure fpc_largeset_contains_sets(set1,set2 : pointer; size: longint); compilerproc;
{$endif LARGESETS}
procedure fpc_rangeerror; compilerproc;
procedure fpc_overflow; compilerproc;
procedure fpc_iocheck(addr : longint); compilerproc;
procedure fpc_InitializeUnits; compilerproc;
// not generated by compiler, called directly in system unit
// procedure fpc_FinalizeUnits; compilerproc;
{
Procedure fpc_do_exit; compilerproc;
Procedure fpc_lib_exit; compilerproc;
Procedure fpc_HandleErrorAddrFrame (Errno : longint;addr,frame : longint); compilerproc;
Procedure fpc_HandleError (Errno : longint); compilerproc;
}
procedure fpc_AbstractErrorIntern;compilerproc;
procedure fpc_assert(Const Msg,FName:Shortstring;LineNo,ErrorAddr:Longint); compilerproc;
{$endif hascompilerproc}
{
$Log$
Revision 1.1 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
}

78
rtl/inc/dynarr.inc
View File

@ -16,15 +16,7 @@
**********************************************************************
}
procedure FinalizeArray(data,typeinfo : pointer;count,size : longint);forward;
Procedure Addref (Data,TypeInfo : Pointer);forward;
Procedure int_finalize (Data,TypeInfo: Pointer);forward;
type
tdynarrayindex = longint;
pdynarrayindex = ^tdynarrayindex;
t_size = dword;
{ don't add new fields, the size is used }
{ to calculate memory requirements }
pdynarray = ^tdynarray;
@ -43,18 +35,21 @@ type
end;
function dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH'];
function fpc_dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1;
fpc_dynarray_length := 0;
if assigned(p) then
fpc_dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1;
end;
function dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH'];
function fpc_dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high;
fpc_dynarray_high := -1;
if assigned(p) then
fpc_dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high;
end;
{ releases and finalizes the data of a dyn. array and sets p to nil }
procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
begin
@ -62,7 +57,7 @@ procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
inc(pointer(ti),ord(ti^.namelen));
{ finalize all data }
finalizearray(p,ti^.eletype,p^.high+1,ti^.elesize);
int_finalizearray(p,ti^.eletype,p^.high+1,ti^.elesize);
{ release the data }
freemem(p,sizeof(tdynarray)+(p^.high+1)*ti^.elesize);
@ -70,7 +65,7 @@ procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
end;
procedure dynarray_decr_ref(var p : pointer;ti : pdynarraytypeinfo);[Public,Alias:'FPC_DYNARRAY_DECR_REF'];
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer);[Public,Alias:'FPC_DYNARRAY_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
realp : pdynarray;
begin
@ -84,12 +79,16 @@ procedure dynarray_decr_ref(var p : pointer;ti : pdynarraytypeinfo);[Public,Alia
{ decr. ref. count }
{ should we remove the array? }
if declocked(realp^.refcount) then
dynarray_clear(realp,ti);
dynarray_clear(realp,pdynarraytypeinfo(ti));
p:=nil;
end;
{$ifdef hascompilerproc}
{ provide local access to dynarr_decr_ref for dynarr_setlength }
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); [external name 'FPC_DYNARRAY_DECR_REF'];
{$endif}
procedure dynarray_incr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_INCR_REF'];
procedure fpc_dynarray_incr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
realp : pdynarray;
begin
@ -103,9 +102,17 @@ procedure dynarray_incr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_INCR_RE
inclocked(realp^.refcount);
end;
{$ifdef hascompilerproc}
{ provide local access to dynarr_decr_ref for dynarr_setlength }
procedure fpc_dynarray_incr_ref(var p : pointer;ti : pointer); [external name 'FPC_DYNARRAY_INCR_REF'];
{$endif}
procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH'];
{ provide local access to dynarr_setlength }
procedure int_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex);[external name 'FPC_DYNARR_SETLENGTH'];
procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : tdynarrayindex;
@ -116,7 +123,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
ti : pdynarraytypeinfo;
begin
ti:=pti;
ti:=pdynarraytypeinfo(pti);
{ skip kind and name }
inc(pointer(ti),ord(ti^.namelen));
@ -139,7 +146,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
{ if the new dimension is 0, we've to release all data }
if dims[0]=0 then
begin
dynarray_clear(realp,pti);
dynarray_clear(realp,pdynarraytypeinfo(pti));
p:=nil;
exit;
end;
@ -152,7 +159,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
{ increment ref. count of members }
for i:=0 to dims[0]-1 do
addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
int_addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
{ a declock(ref. count) isn't enough here }
{ it could be that the in MT enviroments }
@ -161,7 +168,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
{ it is, because it doesn't really matter }
{ if the array is now removed }
dynarray_decr_ref(p,ti);
fpc_dynarray_decr_ref(p,ti);
end
else if dims[0]<>realp^.high+1 then
begin
@ -179,7 +186,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
{ shrink the array? }
if dims[0]<realp^.high+1 then
begin
finalizearray(pointer(realp)+sizeof(tdynarray)+ti^.elesize*dims[0],
int_finalizearray(pointer(realp)+sizeof(tdynarray)+ti^.elesize*dims[0],
ti^.eletype,realp^.high-dims[0]+1,ti^.elesize);
reallocmem(realp,size);
end
@ -198,7 +205,7 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
if dimcount>1 then
begin
for i:=0 to dims[0]-1 do
dynarray_setlength(pointer(plongint(pointer(newp)+sizeof(tdynarray))[i*ti^.elesize]),
int_dynarray_setlength(pointer(plongint(pointer(newp)+sizeof(tdynarray))[i*ti^.elesize]),
ti^.eletype,dimcount-1,@dims[1]);
end;
end;
@ -207,17 +214,32 @@ procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
newp^.high:=dims[0]-1;
end;
function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
dimcount : dword;dims : pdynarrayindex) : pointer;[Public,Alias:'FPC_DYNARRAY_COPY'];
function fpc_dynarray_copy(var p : pointer;ti : pointer;
dimcount : dword;dims : pdynarrayindex) : pointer;[Public,Alias:'FPC_DYNARRAY_COPY']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{ note: ti is of type pdynarrayinfo, but it can't be declared }
{ that way because this procedure is also declared in the interface }
{ (as compilerproc) and the pdynarraytypeinfo isn't available there }
{!!!!!!!!!!}
end;
{
$Log$
Revision 1.7 2001-05-27 14:28:44 florian
Revision 1.8 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.7 2001/05/27 14:28:44 florian
+ made the ref. couting MT safe
Revision 1.6 2001/04/13 23:49:48 peter

37
rtl/inc/dynarrh.inc Normal file
View File

@ -0,0 +1,37 @@
{
$Id$
This file is part of the Free Pascal Run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
This file contains type declarations necessary for the dynamic
array routine helpers in syshelp.inc
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.
**********************************************************************}
type
tdynarrayindex = longint;
pdynarrayindex = ^tdynarrayindex;
t_size = dword;
{
$Log$
Revision 1.1 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
}

65
rtl/inc/except.inc
View File

@ -35,7 +35,7 @@ Type
end;
TExceptObjectClass = Class of TObject;
TExceptObjectClass = Class of TObject;
Const
CatchAllExceptions = -1;
@ -54,11 +54,11 @@ begin
end;
{$ifndef HAS_ADDR_STACK_ON_STACK}
Function PushExceptAddr (Ft: Longint): PJmp_buf ;
Function fpc_PushExceptAddr (Ft: Longint): PJmp_buf ;
[Public, Alias : 'FPC_PUSHEXCEPTADDR'];saveregisters;
{$else HAS_ADDR_STACK_ON_HEAP}
Function PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ;
[Public, Alias : 'FPC_PUSHEXCEPTADDR'];saveregisters;
Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ;
[Public, Alias : 'FPC_PUSHEXCEPTADDR'];saveregisters; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif HAS_ADDR_STACK_ON_STACK}
var
@ -94,12 +94,12 @@ begin
{$endif HAS_ADDR_STACK_ON_STACK}
ExceptAddrStack^.Buf:=Buf;
ExceptAddrStack^.FrameType:=ft;
PushExceptAddr:=Buf;
fpc_PushExceptAddr:=Buf;
end;
Procedure PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer);
[Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];saveregisters;
Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer);
[Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];saveregisters; {$ifdef hascompilerproc} compilerproc; {$endif}
var
Newobj : PExceptObject;
begin
@ -122,6 +122,11 @@ begin
ExceptObjectStack^.Frame:=AFrame;
end;
{$ifdef hascompilerproc}
{ make it avalable for local use }
Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); [external name 'FPC_PUSHEXCEPTOBJECT'];
{$endif}
Procedure DoUnHandledException;
begin
@ -132,13 +137,13 @@ begin
end;
Function Raiseexcept (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
Function fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{$ifdef excdebug}
writeln ('In RaiseException');
{$endif}
Raiseexcept:=nil;
PushExceptObj(Obj,AnAddr,AFrame);
fpc_Raiseexception:=nil;
fpc_PushExceptObj(Obj,AnAddr,AFrame);
If ExceptAddrStack=Nil then
DoUnhandledException;
if (RaiseProc <> nil) and (ExceptObjectStack <> nil) then
@ -147,7 +152,7 @@ begin
end;
Procedure PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK'];
Procedure fpc_PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifndef HAS_ADDR_STACK_ON_STACK}
var
hp : PExceptAddr;
@ -175,7 +180,7 @@ begin
end;
function PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK'];
function fpc_PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
hp : PExceptObject;
begin
@ -190,7 +195,7 @@ begin
else
begin
{ we need to return the exception object to dispose it }
PopObjectStack:=ExceptObjectStack^.FObject;
fpc_PopObjectStack:=ExceptObjectStack^.FObject;
hp:=ExceptObjectStack;
ExceptObjectStack:=ExceptObjectStack^.next;
dispose(hp);
@ -199,7 +204,7 @@ end;
{ this is for popping exception objects when a second exception is risen }
{ in an except/on }
function PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK'];
function fpc_PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
hp : PExceptObject;
begin
@ -215,14 +220,14 @@ begin
else
begin
{ we need to return the exception object to dispose it }
PopSecondObjectStack:=ExceptObjectStack^.next^.FObject;
fpc_PopSecondObjectStack:=ExceptObjectStack^.next^.FObject;
hp:=ExceptObjectStack^.next;
ExceptObjectStack^.next:=hp^.next;
dispose(hp);
end;
end;
Procedure ReRaise;[Public, Alias : 'FPC_RERAISE'];
Procedure fpc_ReRaise;[Public, Alias : 'FPC_RERAISE']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{$ifdef excdebug}
writeln ('In reraise');
@ -233,20 +238,23 @@ begin
end;
Function Catches(Objtype : TExceptObjectClass) : TObject;[Public, Alias : 'FPC_CATCHES'];
Function fpc_Catches(Objtype : TClass) : TObject;[Public, Alias : 'FPC_CATCHES']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
_Objtype : TExceptObjectClass;
begin
If ExceptObjectStack=Nil then
begin
Writeln ('Internal error.');
halt (255);
end;
if Not ((Objtype = TExceptObjectClass(CatchAllExceptions)) or
(ExceptObjectStack^.FObject is ObjType)) then
Catches:=Nil
_Objtype := TExceptObjectClass(Objtype);
if Not ((_Objtype = TExceptObjectClass(CatchAllExceptions)) or
(ExceptObjectStack^.FObject is _ObjType)) then
fpc_Catches:=Nil
else
begin
// catch !
Catches:=ExceptObjectStack^.FObject;
fpc_Catches:=ExceptObjectStack^.FObject;
{ this can't be done, because there could be a reraise (PFV)
PopObjectStack;
@ -256,7 +264,7 @@ begin
end;
end;
Procedure DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION'];
Procedure fpc_DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{ with free we're on the really save side }
o.Free;
@ -273,7 +281,18 @@ begin
end;
{
$Log$
Revision 1.6 2001-04-13 22:30:04 peter
Revision 1.7 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.6 2001/04/13 22:30:04 peter
* remove warnings
Revision 1.5 2001/01/24 21:47:18 florian

36
rtl/inc/generic.inc
View File

@ -330,7 +330,7 @@ end;
FPC_HELP_CONSTRUCTOR : generic allways means aa little less efficient (PM) }
{ I don't think we really need to save any registers here }
{ since this is called at the start of the constructor (CEC) }
function int_help_constructor(var _self : pointer; var vmt : pointer; vmt_pos : cardinal) : pointer; [public,alias:'FPC_HELP_CONSTRUCTOR'];
function fpc_help_constructor(var _self : pointer; var vmt : pointer; vmt_pos : cardinal) : pointer; [public,alias:'FPC_HELP_CONSTRUCTOR']; {$ifdef hascompilerproc} compilerproc; {$endif}
type
ppointer = ^pointer;
pvmt = ^tvmt;
@ -363,7 +363,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
procedure int_help_destructor(var _self : pointer; vmt : pointer; vmt_pos : cardinal);saveregisters;[public,alias:'FPC_HELP_DESTRUCTOR'];
procedure fpc_help_destructor(var _self : pointer; vmt : pointer; vmt_pos : cardinal);saveregisters;[public,alias:'FPC_HELP_DESTRUCTOR']; {$ifdef hascompilerproc} compilerproc; {$endif}
type
ppointer = ^pointer;
pvmt = ^tvmt;
@ -431,7 +431,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT}
procedure int_check_object(vmt : pointer);saveregisters;[public,alias:'FPC_CHECK_OBJECT'];
procedure fpc_check_object(vmt : pointer);saveregisters;[public,alias:'FPC_CHECK_OBJECT']; {$ifdef hascompilerproc} compilerproc; {$endif}
type
pvmt = ^tvmt;
tvmt = packed record
@ -453,7 +453,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
procedure int_check_object_ext(vmt, expvmt : pointer);saveregisters;[public,alias:'FPC_CHECK_OBJECT_EXT'];
procedure fpc_check_object_ext(vmt, expvmt : pointer);saveregisters;[public,alias:'FPC_CHECK_OBJECT_EXT']; {$ifdef hascompilerproc} compilerproc; {$endif}
type
pvmt = ^tvmt;
tvmt = packed record
@ -482,7 +482,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY}
procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
slen : byte;
type
@ -509,7 +509,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
procedure int_strconcat(s1,s2:pointer);[public,alias:'FPC_SHORTSTR_CONCAT'];
procedure fpc_shortstr_concat(s1,s2:pointer);[public,alias:'FPC_SHORTSTR_CONCAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s1l, s2l : byte;
type
@ -529,7 +529,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
function int_strcmp(rightstr,leftstr:pointer) : longint;[public,alias:'FPC_SHORTSTR_COMPARE'];
function fpc_shortstr_compare(rightstr,leftstr:pointer) : longint;[public,alias:'FPC_SHORTSTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s1,s2,max,i : byte;
d : longint;
@ -562,7 +562,7 @@ end;
{$ifndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
function strpas(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR'];
function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
l : longint;
s: shortstring;
@ -581,9 +581,12 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
{ also add a strpas alias for internal use in the system unit (JM) }
function strpas(p:pchar):shortstring; [external name 'FPC_PCHAR_TO_SHORTSTR'];
{$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
function strchararray(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR'];
function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s: shortstring;
begin
@ -604,7 +607,7 @@ end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_STR_TO_CHARARRAY}
procedure str_to_chararray(strtyp, arraysize: longint; src,dest: pchar);[public,alias:'FPC_STR_TO_CHARARRAY'];
procedure fpc_str_to_chararray(strtyp, arraysize: longint; src,dest: pchar);[public,alias:'FPC_STR_TO_CHARARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
type
plongint = ^longint;
var
@ -826,7 +829,18 @@ end;
{
$Log$
Revision 1.16 2001-07-31 19:36:51 peter
Revision 1.17 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.16 2001/07/31 19:36:51 peter
* small cleanup of commented code (merged)
Revision 1.15 2001/07/29 13:49:15 peter

48
rtl/inc/genrtti.inc
View File

@ -17,7 +17,7 @@
{$ifndef FPC_SYSTEM_HAS_FPC_INITIALIZE}
Procedure Initialize (Data,TypeInfo : pointer);saveregisters;[Public,Alias : 'FPC_INITIALIZE'];
Procedure fpc_Initialize (Data,TypeInfo : pointer);saveregisters;[Public,Alias : 'FPC_INITIALIZE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ this definition is sometimes (depending on switches)
already defined or not so define it locally to avoid problems PM }
@ -41,7 +41,7 @@ begin
Count:=PArrayRec(Temp)^.Count; // get element Count
TInfo:=PArrayRec(Temp)^.Info; // Get element info
For I:=0 to Count-1 do
Initialize (Data+(I*size),TInfo);
int_Initialize (Data+(I*size),TInfo);
end;
tkrecord :
begin
@ -52,14 +52,15 @@ begin
Count:=PRecRec(Temp)^.Count; // get element Count
For I:=1 to count Do
With PRecRec(Temp)^.elements[I] do
Initialize (Data+Offset,Info);
int_Initialize (Data+Offset,Info);
end;
end;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_FINALIZE}
Procedure Finalize (Data,TypeInfo: Pointer);saveregisters;[Public,Alias : 'FPC_FINALIZE'];
Procedure fpc_Finalize (Data,TypeInfo: Pointer);saveregisters;[Public,Alias : 'FPC_FINALIZE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ this definition is sometimes (depending on switches)
already defined or not so define it locally to avoid problems PM }
@ -83,7 +84,7 @@ begin
Count:=PArrayRec(Temp)^.Count; // get element Count
TInfo:=PArrayRec(Temp)^.Info; // Get element info
For I:=0 to Count-1 do
Finalize (Data+(I*size),TInfo);
int_Finalize (Data+(I*size),TInfo);
end;
tkrecord :
begin
@ -94,14 +95,15 @@ begin
Count:=PRecRec(Temp)^.Count; // get element Count
For I:=1 to count do
With PRecRec(Temp)^.elements[I] do
Finalize (Data+Offset,Info);
int_Finalize (Data+Offset,Info);
end;
end;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_ADDREF}
Procedure Addref (Data,TypeInfo : Pointer);saveregisters; [Public,alias : 'FPC_ADDREF'];
Procedure fpc_Addref (Data,TypeInfo : Pointer);saveregisters; [Public,alias : 'FPC_ADDREF']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ this definition is sometimes (depending on switches)
already defined or not so define it locally to avoid problems PM }
@ -112,7 +114,6 @@ Var Temp : PByte;
I : longint;
Size,Count : longint;
TInfo : Pointer;
begin
Temp:=PByte(TypeInfo);
case temp^ of
@ -122,7 +123,7 @@ begin
{ expects a var parameter, so to pass the address of the }
{ ansistring and not that of the data parameter on the stack, }
{ you have to dereference data (JM) }
tkAstring,tkWstring : AnsiStr_Incr_Ref(PPointer(Data)^);
tkAstring,tkWstring : fpc_AnsiStr_Incr_Ref(PPointer(Data)^);
tkArray :
begin
Temp:=Temp+1;
@ -132,7 +133,7 @@ begin
Count:=PArrayRec(Temp)^.Count; // get element Count
TInfo:=PArrayRec(Temp)^.Info; // Get element info
For I:=0 to Count-1 do
AddRef (Data+(I*size),TInfo);
int_AddRef (Data+(I*size),TInfo);
end;
tkrecord :
begin
@ -143,14 +144,16 @@ begin
Count:=PRecRec(Temp)^.Count; // get element Count
For I:=1 to count do
With PRecRec(Temp)^.elements[I] do
AddRef (Data+Offset,Info);
int_AddRef (Data+Offset,Info);
end;
end;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_DECREF}
Procedure DecRef (Data, TypeInfo : Pointer);saveregisters;[Public,alias : 'FPC_DECREF'];
Procedure fpc_DecRef (Data, TypeInfo : Pointer);saveregisters;[Public,alias : 'FPC_DECREF']; {$ifdef hascompilerproc} compilerproc; {$endif}
{ this definition is sometimes (depending on switches)
already defined or not so define it locally to avoid problems PM }
Type
@ -165,7 +168,7 @@ begin
Temp:=PByte(TypeInfo);
case temp^ of
{ see AddRef for comment about below construct (JM) }
tkAstring,tkWstring : AnsiStr_Decr_Ref(PPointer(Data)^);
tkAstring,tkWstring : fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
tkArray :
begin
Temp:=Temp+1;
@ -175,7 +178,7 @@ begin
Count:=PArrayRec(Temp)^.Count; // get element Count
TInfo:=PArrayRec(Temp)^.Info; // Get element info
For I:=0 to Count-1 do
DecRef (Data+(I*size),TInfo);
fpc_DecRef (Data+(I*size),TInfo);
end;
tkrecord :
begin
@ -186,14 +189,14 @@ begin
Count:=PRecRec(Temp)^.Count; // get element Count
For I:=1 to count do
With PRecRec(Temp)^.elements[I] do
DecRef (Data+Offset,Info);
fpc_DecRef (Data+Offset,Info);
end;
end;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_FINALIZEARRAY}
procedure FinalizeArray(data,typeinfo : pointer;count,size : longint); [Public,Alias:'FPC_FINALIZEARRAY'];
procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); [Public,Alias:'FPC_FINALIZEARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : longint;
begin
@ -204,7 +207,18 @@ procedure FinalizeArray(data,typeinfo : pointer;count,size : longint); [Public,A
{
$Log$
Revision 1.4 2001-06-28 19:18:57 peter
Revision 1.5 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.4 2001/06/28 19:18:57 peter
* ansistr fix merged
Revision 1.3 2001/05/28 20:43:17 peter

52
rtl/inc/objpas.inc
View File

@ -19,15 +19,15 @@
****************************************************************************}
{ the reverse order of the parameters make code generation easier }
function int_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS'];
function fpc_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
int_do_is:=assigned(aobject) and assigned(aclass) and
fpc_do_is:=assigned(aobject) and assigned(aclass) and
aobject.inheritsfrom(aclass);
end;
{ the reverse order of the parameters make code generation easier }
procedure int_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS'];
procedure fpc_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
handleerror(219);
@ -35,38 +35,49 @@
{$ifndef HASINTF}
{ dummies for make cycle with 1.0.x }
procedure int_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
procedure intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
begin
end;
procedure int_intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF'];
procedure intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF'];
begin
end;
procedure int_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
procedure intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
begin
end;
procedure int_intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS'];
procedure intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS'];
begin
end;
{$else HASINTF}
{ interface helpers }
procedure int_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
procedure fpc_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(i) then
IUnknown(i)._Release;
i:=nil;
end;
procedure int_intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF'];
{$ifdef hascompilerproc}
{ local declaration for intf_decr_ref for local access }
procedure intf_decr_ref(var i: pointer); [external name 'FPC_INTF_DECR_REF'];
{$endif hascompilerproc}
procedure fpc_intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(i) then
IUnknown(i)._AddRef;
end;
procedure int_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
{$ifdef hascompilerproc}
{ local declaration of intf_incr_ref for local access }
procedure intf_incr_ref(const i: pointer); [external name 'FPC_INTF_INCR_REF'];
{$endif hascompilerproc}
procedure fpc_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(S) then
IUnknown(S)._AddRef;
@ -75,7 +86,7 @@
D:=S;
end;
procedure int_intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS'];
procedure fpc_intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
const
S_OK = 0;
var
@ -89,7 +100,7 @@
D:=tmpi;
end
else
int_intf_decr_ref(D);
intf_decr_ref(D);
end;
{$endif HASINTF}
@ -540,7 +551,7 @@
IEntry:=getinterfaceentry(iid);
if Assigned(IEntry) then begin
PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
int_intf_incr_ref(pointer(obj)); { it must be an com interface }
intf_incr_ref(pointer(obj)); { it must be an com interface }
getinterface:=True;
end
else begin
@ -557,7 +568,7 @@
if Assigned(IEntry) then begin
PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
if Assigned(IEntry^.iid) then { for Com interfaces }
int_intf_incr_ref(pointer(obj));
intf_incr_ref(pointer(obj));
getinterfacebystr:=True;
end
else begin
@ -681,7 +692,18 @@
{
$Log$
Revision 1.15 2001-05-27 14:28:44 florian
Revision 1.16 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.15 2001/05/27 14:28:44 florian
+ made the ref. couting MT safe
Revision 1.14 2001/04/13 22:30:04 peter

81
rtl/inc/sstrings.inc
View File

@ -21,7 +21,7 @@
{$ifndef INTERNSETLENGTH}
procedure SetLength(var s:shortstring;len:StrLenInt);
{$else INTERNSETLENGTH}
procedure Shortstr_SetLength(var s:shortstring;len:StrLenInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH'];
procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif INTERNSETLENGTH}
begin
if Len>255 then
@ -311,13 +311,13 @@ end;
Str() Helpers
*****************************************************************************}
procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT'];
procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; {$ifdef hascompilerproc}compilerproc;{$endif hascompilerproc}
begin
str_real(len,fr,d,treal_type(rt),s);
end;
procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT'];
procedure fpc_shortstr_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
int_str(v,s);
if length(s)<len then
@ -325,7 +325,7 @@ begin
end;
procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL'];
procedure fpc_shortstr_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
int_str(v,s);
if length(s)<len then
@ -374,14 +374,13 @@ begin
InitVal:=code;
end;
Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
Function fpc_Val_SInt_ShortStr(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
u, temp, prev, maxValue: ValUInt;
base : byte;
negative : boolean;
begin
ValSignedInt := 0;
fpc_Val_SInt_ShortStr := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
if Code>length(s) then
@ -405,34 +404,40 @@ begin
(ValUInt(MaxUIntValue-Temp) < u)) or
(prev > maxValue) Then
Begin
ValSignedInt := 0;
fpc_Val_SInt_ShortStr := 0;
Exit
End;
Temp:=Temp+u;
inc(code);
end;
code := 0;
ValSignedInt := ValSInt(Temp);
fpc_Val_SInt_ShortStr := ValSInt(Temp);
If Negative Then
ValSignedInt := -ValSignedInt;
fpc_Val_SInt_ShortStr := -fpc_Val_SInt_ShortStr;
If Not(Negative) and (base <> 10) Then
{sign extend the result to allow proper range checking}
Case DestSize of
1: ValSignedInt := shortint(ValSignedInt);
2: ValSignedInt := smallint(ValSignedInt);
1: fpc_Val_SInt_ShortStr := shortint(fpc_Val_SInt_ShortStr);
2: fpc_Val_SInt_ShortStr := smallint(fpc_Val_SInt_ShortStr);
{ Uncomment the folling once full 64bit support is in place
4: ValSignedInt := longint(ValSignedInt);}
4: fpc_Val_SInt_ShortStr := longint(fpc_Val_SInt_ShortStr);}
End;
end;
{$ifdef hascompilerproc}
{ we need this for fpc_Val_SInt_Ansistr and fpc_Val_SInt_WideStr because }
{ we have to pass the DestSize parameter on (JM) }
Function fpc_Val_SInt_ShortStr(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [external name 'FPC_VAL_SINT_SHORTSTR'];
{$endif hascompilerproc}
Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
Function fpc_Val_UInt_Shortstr(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
u, prev : ValUInt;
base : byte;
negative : boolean;
begin
ValUnSignedInt:=0;
fpc_Val_UInt_Shortstr:=0;
Code:=InitVal(s,negative,base);
If Negative or (Code>length(s)) Then
Exit;
@ -445,28 +450,28 @@ begin
else
u:=16;
end;
prev := ValUnsignedInt;
prev := fpc_Val_UInt_Shortstr;
If (u>=base) or
(ValUInt(MaxUIntValue-u) div ValUInt(Base)<prev) then
begin
ValUnsignedInt:=0;
fpc_Val_UInt_Shortstr:=0;
exit;
end;
ValUnsignedInt:=ValUnsignedInt*ValUInt(base) + u;
fpc_Val_UInt_Shortstr:=fpc_Val_UInt_Shortstr*ValUInt(base) + u;
inc(code);
end;
code := 0;
end;
Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
Function fpc_Val_Real_ShortStr(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
hd,
esign,sign : valreal;
exponent,i : longint;
flags : byte;
begin
ValFloat:=0.0;
fpc_Val_Real_ShortStr:=0.0;
code:=1;
exponent:=0;
esign:=1;
@ -485,7 +490,8 @@ begin
begin
{ Read integer part }
flags:=flags or 1;
valfloat:=valfloat*10+(ord(s[code])-ord('0'));
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*10+(ord(s[code])-ord('0'));
inc(code);
end;
{ Decimal ? }
@ -497,16 +503,16 @@ begin
begin
{ Read fractional part. }
flags:=flags or 2;
valfloat:=valfloat*10+(ord(s[code])-ord('0'));
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*10+(ord(s[code])-ord('0'));
hd:=hd*10.0;
inc(code);
end;
valfloat:=valfloat/hd;
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
end;
{ Again, read integer and fractional part}
if flags=0 then
begin
valfloat:=0.0;
fpc_Val_Real_ShortStr:=0.0;
exit;
end;
{ Exponent ? }
@ -523,7 +529,7 @@ begin
end;
if not(s[code] in ['0'..'9']) or (length(s)<code) then
begin
valfloat:=0.0;
fpc_Val_Real_ShortStr:=0.0;
exit;
end;
while (s[code] in ['0'..'9']) and (length(s)>=code) do
@ -537,25 +543,25 @@ begin
{
if esign>0 then
for i:=1 to exponent do
valfloat:=valfloat*10
fpc_Val_Real_ShortStr:=Val_Real_ShortStr*10
else
for i:=1 to exponent do
valfloat:=valfloat/10; }
fpc_Val_Real_ShortStr:=Val_Real_ShortStr/10; }
hd:=1.0;
for i:=1 to exponent do
hd:=hd*10.0;
if esign>0 then
valfloat:=valfloat*hd
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*hd
else
valfloat:=valfloat/hd;
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
{ Not all characters are read ? }
if length(s)>=code then
begin
valfloat:=0.0;
fpc_Val_Real_ShortStr:=0.0;
exit;
end;
{ evaluate sign }
valfloat:=valfloat*sign;
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*sign;
{ success ! }
code:=0;
end;
@ -569,7 +575,18 @@ end;
{
$Log$
Revision 1.14 2001-07-08 21:00:18 peter
Revision 1.15 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.14 2001/07/08 21:00:18 peter
* various widestring updates, it works now mostly without charset
mapping supported

30
rtl/inc/system.inc
View File

@ -186,6 +186,8 @@ End;
{$i wstrings.inc}
{$endif HASWIDESTRING}
{$i aliases.inc}
{*****************************************************************************
Dynamic Array support
*****************************************************************************}
@ -343,19 +345,19 @@ end;
Miscellaneous
*****************************************************************************}
procedure int_rangeerror;[public,alias:'FPC_RANGEERROR'];
procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
HandleErrorFrame(201,get_frame);
end;
procedure int_overflow;[public,alias:'FPC_OVERFLOW'];
procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
HandleErrorFrame(215,get_frame);
end;
procedure int_iocheck(addr : longint);[saveregisters,public,alias:'FPC_IOCHECK'];
procedure fpc_iocheck(addr : longint);[saveregisters,public,alias:'FPC_IOCHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
l : longint;
begin
@ -406,7 +408,7 @@ type
var
InitFinalTable : TInitFinalTable;external name 'INITFINAL';
procedure InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS'];
procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : longint;
begin
@ -437,7 +439,6 @@ begin
end;
end;
{*****************************************************************************
Error / Exit / ExitProc
*****************************************************************************}
@ -619,8 +620,12 @@ begin
HandleErrorFrame(211,get_frame);
end;
{$ifdef hascompilerproc}
{ alias for internal usage in the compiler }
procedure fpc_AbstractErrorIntern; compilerproc; external name 'FPC_ABSTRACTERROR';
{$endif hascompilerproc}
Procedure int_assert(Const Msg,FName:Shortstring;LineNo,ErrorAddr:Longint); [SaveRegisters,Public,Alias : 'FPC_ASSERT'];
Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo,ErrorAddr:Longint); [SaveRegisters,Public,Alias : 'FPC_ASSERT']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if pointer(AssertErrorProc)<>nil then
AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
@ -661,7 +666,18 @@ end;
{
$Log$
Revision 1.20 2001-07-30 21:38:55 peter
Revision 1.21 2001-08-01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.20 2001/07/30 21:38:55 peter
* m68k updates merged
Revision 1.19 2001/07/29 14:05:55 peter

22
rtl/inc/systemh.inc
View File

@ -527,9 +527,29 @@ const
{$i objpash.inc}
{*****************************************************************************
Internal helper routines support
*****************************************************************************}
{$i dynarrh.inc}
{$i compproc.inc}
{
$Log$
Revision 1.32 2001-07-31 08:57:22 marco
Revision 1.33 2001-08-01 15:00:11 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.32 2001/07/31 08:57:22 marco
* Either I did something wrong, or Peter's merge killed wchar decl. Fixed.
Revision 1.31 2001/07/30 21:38:55 peter

188
rtl/inc/wstrings.inc
View File

@ -161,7 +161,7 @@ begin
end;
Procedure WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF'];
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Decreases the ReferenceCount of a non constant widestring;
If the reference count is zero, deallocate the string;
@ -185,8 +185,12 @@ Begin
S:=nil;
end;
{$ifdef hascompilerproc}
{ alias for internal use }
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
{$endif compilerproc}
Procedure WideStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF'];
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
If S=Nil then
exit;
@ -196,7 +200,7 @@ Begin
end;
Procedure WideStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR'];
Procedure fpc_WideStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a WideString to a ShortString;
}
@ -216,7 +220,7 @@ begin
end;
Procedure ShortStr_To_WideStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_WIDESTR'];
Procedure fpc_ShortStr_To_WideStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a ShortString to a WideString;
}
@ -230,7 +234,7 @@ begin
end;
Procedure WideStr_To_AnsiStr (Var S1 : Pointer;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_ANSISTR'];
Procedure fpc_WideStr_To_AnsiStr (Var S1 : Pointer;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a WideString to an AnsiString
}
@ -253,7 +257,7 @@ begin
end;
Procedure AnsiStr_To_WideStr (Var S1 : Pointer; Const S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_WIDESTR'];
Procedure fpc_AnsiStr_To_WideStr (Var S1 : Pointer; Const S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts an AnsiString to a WideString;
}
@ -277,7 +281,7 @@ end;
{ checked against the ansistring routine, 2001-05-27 (FK) }
Procedure WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN'];
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Assigns S2 to S1 (S1:=S2), taking in account reference counts.
}
@ -286,13 +290,18 @@ begin
If PWideRec(S2-WideFirstOff)^.Ref>0 then
Inc(PWideRec(S2-WideFirstOff)^.ref);
{ Decrease the reference count on the old S1 }
widestr_decr_ref (S1);
fpc_widestr_decr_ref (S1);
{ And finally, have S1 pointing to S2 (or its copy) }
S1:=S2;
end;
{$ifdef hascompilerproc}
{ alias for internal use }
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
{$endif hascompilerproc}
{ checked against the ansistring routine, 2001-05-27 (FK) }
Procedure WideStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_WIDESTR_CONCAT'];
Procedure fpc_WideStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_WIDESTR_CONCAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Concatenates 2 WideStrings : S1+S2.
Result Goes to S3;
@ -302,15 +311,14 @@ Var
begin
{ only assign if s1 or s2 is empty }
if (S1=Nil) then
WideStr_Assign(S3,S2)
fpc_WideStr_Assign(S3,S2)
else
if (S2=Nil) then
WideStr_Assign(S3,S1)
fpc_WideStr_Assign(S3,S1)
else
begin
{ create new result }
if S3<>nil then
WideStr_Decr_Ref(S3);
{ create new result }
fpc_WideStr_Decr_Ref(S3);
Size:=PWideRec(S2-WideFirstOff)^.Len;
Location:=Length(WideString(S1));
SetLength (WideString(S3),Size+Location);
@ -320,7 +328,7 @@ begin
end;
Procedure Char_To_WideStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_WIDESTR'];
Procedure fpc_Char_To_WideStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Converts a Char to a WideString;
}
@ -332,13 +340,13 @@ begin
end;
Procedure PChar_To_WideStr(var a : widestring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_WIDESTR'];
Procedure fpc_PChar_To_WideStr(var a : widestring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
L : Longint;
begin
if pointer(a)<>nil then
begin
WideStr_Decr_Ref(Pointer(a));
fpc_WideStr_Decr_Ref(Pointer(a));
pointer(a):=nil;
end;
if (not assigned(p)) or (p[0]=#0) Then
@ -353,7 +361,7 @@ begin
end;
Procedure CharArray_To_WideStr(var a : widestring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_WIDESTR'];
Procedure fpc_CharArray_To_WideStr(var a : widestring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : longint;
begin
@ -369,7 +377,7 @@ begin
end;
Function WideStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_WIDESTR_COMPARE'];
Function fpc_WideStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_WIDESTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Compares 2 WideStrings;
The result is
@ -382,7 +390,7 @@ Var
begin
if S1=S2 then
begin
WideStr_Compare:=0;
fpc_WideStr_Compare:=0;
exit;
end;
Maxi:=Length(WideString(S1));
@ -392,18 +400,18 @@ begin
Temp:=CompareWord(S1^,S2^,MaxI);
if temp=0 then
temp:=Length(WideString(S1))-Length(WideString(S2));
WideStr_Compare:=Temp;
fpc_WideStr_Compare:=Temp;
end;
Procedure WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO'];
Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if p=nil then
HandleErrorFrame(201,get_frame);
end;
Procedure WideStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_WIDESTR_RANGECHECK'];
Procedure fpc_WideStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if (index>len) or (Index<1) then
HandleErrorFrame(201,get_frame);
@ -412,7 +420,7 @@ end;
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : WideString; l : Longint);
{$else INTERNSETLENGTH}
Procedure WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH'];
Procedure fpc_WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif INTERNSETLENGTH}
{
Sets The length of string S to L.
@ -436,7 +444,7 @@ begin
Temp:=Pointer(NewWideString(L));
if Length(S)>0 then
Move(Pointer(S)^,Temp^,L*sizeof(WideChar));
WideStr_decr_ref(Pointer(S));
fpc_WideStr_decr_ref(Pointer(S));
Pointer(S):=Temp;
end;
{ Force nil termination in case it gets shorter }
@ -447,7 +455,7 @@ begin
begin
{ Length=0 }
if Pointer(S)<>nil then
WideStr_decr_ref (Pointer(S));
fpc_WideStr_decr_ref (Pointer(S));
Pointer(S):=Nil;
end;
end;
@ -473,8 +481,10 @@ begin
end;
{$endif INTERNLENGTH}
{ overloaded version of UniqueString for interface }
procedure UniqueString(Var S : WideString); [external name 'FPC_WIDESTR_UNIQUE'];
Procedure UniqueString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
Procedure fpc_widestr_Unique(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Make sure reference count of S is 1,
using copy-on-write semantics.
@ -491,7 +501,7 @@ begin
SNew:=NewWideString (L);
Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
PWideRec(SNew-WideFirstOff)^.len:=L;
widestr_decr_ref (Pointer(S)); { Thread safe }
fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
Pointer(S):=SNew;
end;
end;
@ -656,70 +666,81 @@ begin
Move (Buf[0],S[1],Len*2);
end;}
Function ValWideFloat(Const S : WideString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR'];
Function fpc_Val_Real_WideStr(Const S : WideString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : String;
SS : String;
begin
WideStr_To_ShortStr(SS,Pointer(S));
ValWideFloat := ValFloat(SS,Code);
end;
Function ValWideUnsignedInt (Const S : WideString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR'];
Var
SS : ShortString;
begin
WideStr_To_ShortStr(SS,Pointer(S));
ValWideUnsignedInt := ValUnsignedInt(SS,Code);
end;
Function ValWideSignedInt (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR'];
Var
SS : ShortString;
begin
ValWideSignedInt:=0;
if length(S)>255 then
code:=256
fpc_Val_Real_WideStr := 0;
if length(S) > 255 then
code := 256
else
begin
WideStr_To_ShortStr (SS,Pointer(S));
ValWideSignedInt := ValSignedInt(DestSize,SS,Code);
end;
end;
Function ValWideUnsignedint64 (Const S : WideString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR'];
Var
SS : ShortString;
begin
ValWideUnsignedInt64:=0;
if length(S)>255 then
code:=256
else
begin
WideStr_To_ShortStr(SS,Pointer(S));
ValWideUnsignedInt64 := ValQWord(SS,Code);
SS := S;
Val(SS,fpc_Val_Real_WideStr,code);
end;
end;
Function ValWideSignedInt64 (Const S : WideString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR'];
Function fpc_Val_UInt_WideStr (Const S : WideString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
ValWideSignedInt64:=0;
fpc_Val_UInt_WideStr := 0;
if length(S) > 255 then
code := 256
else
begin
SS := S;
Val(SS,fpc_Val_UInt_WideStr,code);
end;
end;
Function fpc_Val_SInt_WideStr (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_SInt_WideStr:=0;
if length(S)>255 then
code:=256
else
begin
WideStr_To_ShortStr (SS,Pointer(S));
ValWideSignedInt64 := valInt64(SS,Code);
SS := S;
fpc_Val_SInt_WideStr := fpc_Val_SInt_ShortStr(DestSize,SS,Code);
end;
end;
Function fpc_Val_UInt64_WideStr (Const S : WideString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_UInt64_WideStr:=0;
if length(S)>255 then
code:=256
else
begin
SS := S;
Val(SS,fpc_Val_UInt64_WideStr,Code);
end;
end;
Function fpc_Val_SInt64_WideStr (Const S : WideString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
fpc_Val_SInt64_WideStr:=0;
if length(S)>255 then
code:=256
else
begin
SS := S;
Val(SS,fpc_Val_SInt64_WideStr,Code);
end;
end;
procedure WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);[public,alias:'FPC_WIDESTR_FLOAT'];
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);[public,alias:'FPC_WIDESTR_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
ss : shortstring;
begin
@ -728,21 +749,21 @@ begin
end;
Procedure WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_CARDINAL'];
Procedure fpc_WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
int_str_cardinal(C,Len,SS);
str(C:Len,SS);
S:=SS;
end;
Procedure WideStr_Longint(L : Longint; Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_LONGINT'];
Procedure fpc_WideStr_Longint(L : Longint; Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
Var
SS : ShortString;
begin
int_Str_Longint (L,Len,SS);
Str (L:Len,SS);
S:=SS;
end;
@ -750,7 +771,18 @@ end;
{
$Log$
Revision 1.10 2001-07-16 12:33:08 jonas
Revision 1.11 2001-08-01 15:00:11 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.10 2001/07/16 12:33:08 jonas
* fixed wrong public alieases for val(widestring,...)
Revision 1.9 2001/07/09 21:15:41 peter