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

+ tempcreate/ref/delete nodes (allows the use of temps in the

Browse Source 
resulttype and first pass)
  * made handling of read(ln)/write(ln) processor independent
  * moved processor independent handling for str and reset/rewrite-typed
    from firstpass to resulttype pass
  * changed names of helpers in text.inc to be generic for use as
    compilerprocs + added "iocheck" directive for most of them
  * reading of ordinals is done by procedures instead of functions
    because otherwise FPC_IOCHECK overwrote the result before it could
    be stored elsewhere (range checking still works)
  * compilerprocs can now be used in the system unit before they are
    implemented
  * added note to errore.msg that booleans can't be read using read/readln
This commit is contained in:
Jonas Maebe 2001-08-23 14:28:35 +00:00
parent 94c968a957
commit a6cfe4083a
12 changed files with 1475 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
compiler/htypechk.pas
View File

@ -758,6 +758,11 @@ implementation
exit;
end;
case hp.nodetype of
temprefn :
begin
valid_for_assign := true;
exit;
end;
derefn :
begin
gotderef:=true;
@ -937,7 +942,22 @@ implementation
end.
{
$Log$
Revision 1.30 2001-08-06 21:40:46 peter
Revision 1.31 2001-08-23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.30 2001/08/06 21:40:46 peter
* funcret moved from tprocinfo to tprocdef
Revision 1.29 2001/06/04 18:04:36 peter

31
compiler/i386/n386inl.pas
View File

@ -79,6 +79,7 @@ implementation
TI386INLINENODE
*****************************************************************************}
{$ifndef hascompilerproc}
procedure StoreDirectFuncResult(var dest:tnode);
var
hp : tnode;
@ -176,6 +177,7 @@ implementation
{ free used registers }
del_locref(dest.location);
end;
{$endif not hascomppilerproc}
procedure ti386inlinenode.pass_2;
const
@ -196,7 +198,7 @@ implementation
addvalue : longint;
hp : tnode;
{$ifndef hascompilerproc}
procedure handlereadwrite(doread,doln : boolean);
{ produces code for READ(LN) and WRITE(LN) }
@ -544,6 +546,7 @@ implementation
myexit:
dummycoll.free;
end;
{$endif not hascomppilerproc}
{$ifndef hascompilerproc}
procedure handle_str;
@ -1491,6 +1494,7 @@ implementation
end;
popusedregisters(pushed);
end;
{$ifndef hascompilerproc}
in_write_x :
handlereadwrite(false,false);
in_writeln_x :
@ -1499,6 +1503,14 @@ implementation
handlereadwrite(true,false);
in_readln_x :
handlereadwrite(true,true);
{$else hascomppilerproc}
in_read_x,
in_readln_x,
in_write_x,
in_writeln_x :
{ should be removed in the resulttype pass already (JM) }
internalerror(200108162);
{$endif not hascomppilerproc}
in_str_x_string :
begin
{$ifndef hascompilerproc}
@ -1705,7 +1717,22 @@ begin
end.
{
$Log$
Revision 1.18 2001-08-13 15:39:52 jonas
Revision 1.19 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.18 2001/08/13 15:39:52 jonas
* made in_reset_typedfile/in_rewrite_typedfile handling processor
independent

3
compiler/msg/errore.msg
View File

@ -1018,7 +1018,8 @@ type_e_succ_and_pred_enums_with_assign_not_possible=04017_E_succ or pred on enum
type_e_cant_read_write_type=04018_E_Can't read or write variables of this type
% You are trying to \var{read} or \var{write} a variable from or to a
% file of type text, which doesn't support that. Only integer types,
% booleans, reals, pchars and strings can be read from/written to a text file.
% reals, pchars and strings can be read from/written to a text file.
% Booleans can only be written to text files.
type_e_no_readln_writeln_for_typed_file=04019_E_Can't use readln or writeln on typed file
% \var{readln} and \var{writeln} are only allowed for text files.
type_e_no_read_write_for_untyped_file=04020_E_Can't use read or write on untyped file.

233
compiler/nbas.pas
View File

@ -27,7 +27,7 @@ unit nbas;
interface
uses
aasm,node;
aasm,symtype,node,cpubase;
type
tnothingnode = class(tnode)
@ -67,12 +67,63 @@ interface
function det_resulttype:tnode;override;
end;
{ to allow access to the location by temp references even after the temp has }
{ already been disposed and to make sure the coherency between temps and }
{ temp references is kept after a getcopy }
ptempinfo = ^ttempinfo;
ttempinfo = record
{ set to the copy of a tempcreate pnode (if it gets copied) so that the }
{ refs and deletenode can hook to this copy once they get copied too }
hookoncopy: ptempinfo;
ref: treference;
restype: ttype;
valid: boolean;
end;
{ a node which will create a *persistent* temp of a given type with a given size }
{ (the size is separate to allow creating "void" temps with a custom size) }
ttempcreatenode = class(tnode)
size: longint;
tempinfo: ptempinfo;
constructor create(const _restype: ttype; _size: longint); virtual;
function getcopy: tnode; override;
function pass_1 : tnode; override;
function det_resulttype: tnode; override;
function docompare(p: tnode): boolean; override;
end;
{ a node which is a reference to a certain temp }
ttemprefnode = class(tnode)
constructor create(const temp: ttempcreatenode); virtual;
function getcopy: tnode; override;
function pass_1 : tnode; override;
function det_resulttype : tnode; override;
function docompare(p: tnode): boolean; override;
protected
tempinfo: ptempinfo;
end;
{ a node which removes a temp }
ttempdeletenode = class(tnode)
constructor create(const temp: ttempcreatenode);
function getcopy: tnode; override;
function pass_1: tnode; override;
function det_resulttype: tnode; override;
function docompare(p: tnode): boolean; override;
destructor destroy; override;
protected
tempinfo: ptempinfo;
end;
var
cnothingnode : class of tnothingnode;
cerrornode : class of terrornode;
casmnode : class of tasmnode;
cstatementnode : class of tstatementnode;
cblocknode : class of tblocknode;
ctempcreatenode : class of ttempcreatenode;
ctemprefnode : class of ttemprefnode;
ctempdeletenode : class of ttempdeletenode;
implementation
@ -387,16 +438,194 @@ implementation
docompare := false;
end;
{*****************************************************************************
TEMPCREATENODE
*****************************************************************************}
constructor ttempcreatenode.create(const _restype: ttype; _size: longint);
begin
inherited create(tempn);
size := _size;
new(tempinfo);
fillchar(tempinfo^,sizeof(tempinfo^),0);
tempinfo^.restype := _restype;
end;
function ttempcreatenode.getcopy: tnode;
var
n: ttempcreatenode;
begin
n := ttempcreatenode(inherited getcopy);
n.size := size;
new(n.tempinfo);
fillchar(n.tempinfo^,sizeof(n.tempinfo^),0);
n.tempinfo^.restype := tempinfo^.restype;
{ signal the temprefs that the temp they point to has been copied, }
{ so that if the refs get copied as well, they can hook themselves }
{ to the copy of the temp }
tempinfo^.hookoncopy := n.tempinfo;
result := n;
end;
function ttempcreatenode.pass_1 : tnode;
begin
result := nil;
end;
function ttempcreatenode.det_resulttype: tnode;
begin
result := nil;
{ a tempcreatenode doesn't have a resulttype, only temprefnodes do }
resulttype := voidtype;
end;
function ttempcreatenode.docompare(p: tnode): boolean;
begin
result :=
inherited docompare(p) and
(ttempcreatenode(p).size = size) and
is_equal(ttempcreatenode(p).tempinfo^.restype.def,tempinfo^.restype.def);
end;
{*****************************************************************************
TEMPREFNODE
*****************************************************************************}
constructor ttemprefnode.create(const temp: ttempcreatenode);
begin
inherited create(temprefn);
tempinfo := temp.tempinfo;
end;
function ttemprefnode.getcopy: tnode;
var
n: ttemprefnode;
begin
n := ttemprefnode(inherited getcopy);
if assigned(tempinfo^.hookoncopy) then
{ if the temp has been copied, assume it becomes a new }
{ temp which has to be hooked by the copied reference }
begin
{ hook the ref to the copied temp }
n.tempinfo := tempinfo^.hookoncopy;
end
else
{ if the temp we refer to hasn't been copied, assume }
{ we're just a new reference to that temp }
begin
n.tempinfo := tempinfo;
end;
result := n;
end;
function ttemprefnode.pass_1 : tnode;
begin
result := nil;
end;
function ttemprefnode.det_resulttype: tnode;
begin
{ check if the temp is already resulttype passed }
if not assigned(tempinfo^.restype.def) then
internalerror(200108233);
result := nil;
resulttype := tempinfo^.restype;
end;
function ttemprefnode.docompare(p: tnode): boolean;
begin
result :=
inherited docompare(p) and
(ttemprefnode(p).tempinfo = tempinfo);
end;
{*****************************************************************************
TEMPDELETENODE
*****************************************************************************}
constructor ttempdeletenode.create(const temp: ttempcreatenode);
begin
inherited create(temprefn);
tempinfo := temp.tempinfo;
end;
function ttempdeletenode.getcopy: tnode;
var
n: ttempdeletenode;
begin
n := ttempdeletenode(inherited getcopy);
if assigned(tempinfo^.hookoncopy) then
{ if the temp has been copied, assume it becomes a new }
{ temp which has to be hooked by the copied deletenode }
begin
{ hook the tempdeletenode to the copied temp }
n.tempinfo := tempinfo^.hookoncopy;
end
else
{ if the temp we refer to hasn't been copied, we have a }
{ problem since that means we now have two delete nodes }
{ for one temp }
internalerror(200108234);
result := n;
end;
function ttempdeletenode.pass_1 : tnode;
begin
result := nil;
end;
function ttempdeletenode.det_resulttype: tnode;
begin
result := nil;
resulttype := voidtype;
end;
function ttempdeletenode.docompare(p: tnode): boolean;
begin
result :=
inherited docompare(p) and
(ttemprefnode(p).tempinfo = tempinfo);
end;
destructor ttempdeletenode.destroy;
begin
dispose(tempinfo);
end;
begin
cnothingnode:=tnothingnode;
cerrornode:=terrornode;
casmnode:=tasmnode;
cstatementnode:=tstatementnode;
cblocknode:=tblocknode;
ctempcreatenode:=ttempcreatenode;
ctemprefnode:=ttemprefnode;
ctempdeletenode:=ttempdeletenode;
end.
{
$Log$
Revision 1.13 2001-08-06 21:40:46 peter
Revision 1.14 2001-08-23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.13 2001/08/06 21:40:46 peter
* funcret moved from tprocinfo to tprocdef
Revision 1.12 2001/06/11 17:41:12 jonas

23
compiler/ncal.pas
View File

@ -551,7 +551,11 @@ implementation
symowner := systemunit;
end
else
searchsym(name,srsym,symowner);
begin
searchsym(name,srsym,symowner);
if not assigned(srsym) then
searchsym(upper(name),srsym,symowner);
end;
if not assigned(srsym) or
(srsym.typ <> procsym) then
internalerror(200107271);
@ -1687,7 +1691,22 @@ begin
end.
{
$Log$
Revision 1.42 2001-08-19 21:11:20 florian
Revision 1.43 2001-08-23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.42 2001/08/19 21:11:20 florian
* some bugs fix:
- overload; with external procedures fixed
- better selection of routine to do an overloaded

73
compiler/ncgbas.pas
View File

@ -45,6 +45,18 @@ interface
tcgblocknode = class(tblocknode)
procedure pass_2;override;
end;
tcgtempcreatenode = class(ttempcreatenode)
procedure pass_2;override;
end;
tcgtemprefnode = class(ttemprefnode)
procedure pass_2;override;
end;
tcgtempdeletenode = class(ttempdeletenode)
procedure pass_2;override;
end;
implementation
@ -63,7 +75,7 @@ interface
{$ifdef i386}
,cgai386
{$endif}
,tgcpu
,tgcpu,temp_gen
;
{*****************************************************************************
TNOTHING
@ -219,16 +231,73 @@ interface
secondpass(left);
end;
{*****************************************************************************
TTEMPCREATENODE
*****************************************************************************}
procedure tcgtempcreatenode.pass_2;
begin
{ if we're secondpassing the same tcgtempcreatenode twice, we have a bug }
if tempinfo^.valid then
internalerror(200108222);
{ get a (persistent) temp }
gettempofsizereferencepersistant(size,tempinfo^.ref);
tempinfo^.valid := true;
end;
{*****************************************************************************
TTEMPREFNODE
*****************************************************************************}
procedure tcgtemprefnode.pass_2;
begin
{ check if the temp is valid }
if not tempinfo^.valid then
internalerror(200108231);
{ set the temp's location }
location.loc := LOC_REFERENCE;
location.reference := tempinfo^.ref;
end;
{*****************************************************************************
TTEMPDELETENODE
*****************************************************************************}
procedure tcgtempdeletenode.pass_2;
begin
ungetpersistanttempreference(tempinfo^.ref);
end;
begin
cnothingnode:=tcgnothingnode;
casmnode:=tcgasmnode;
cstatementnode:=tcgstatementnode;
cblocknode:=tcgblocknode;
ctempcreatenode:=tcgtempcreatenode;
ctemprefnode:=tcgtemprefnode;
ctempdeletenode:=tcgtempdeletenode;
end.
{
$Log$
Revision 1.4 2001-06-02 19:22:15 peter
Revision 1.5 2001-08-23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.4 2001/06/02 19:22:15 peter
* refs count for relabeled asmsymbols fixed
Revision 1.3 2001/05/18 22:31:06 peter

883
compiler/ninl.pas
View File

@ -41,8 +41,9 @@ interface
function docompare(p: tnode): boolean; override;
{$ifdef hascompilerproc}
private
function str_pass_1: tnode;
function reset_rewrite_typed_pass_1: tnode;
function handle_str: tnode;
function handle_reset_rewrite_typed: tnode;
function handle_read_write: tnode;
{$endif hascompilerproc}
end;
@ -55,10 +56,10 @@ implementation
uses
verbose,globals,systems,
globtype,
symconst,symtype,symdef,symsym,symtable,types,
globtype, cutils, aasm,
symbase,symconst,symtype,symdef,symsym,symtable,types,
pass_1,
ncal,ncon,ncnv,nadd,nld,nbas,
ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,
cpubase,hcodegen,tgcpu
{$ifdef newcg}
,cgbase
@ -95,6 +96,720 @@ implementation
end;
{$ifdef hascompilerproc}
function tinlinenode.handle_str : tnode;
var
lenpara,
fracpara,
newparas,
dest,
source : tcallparanode;
newnode : tnode;
len,
fraclen : longint;
procname: string;
is_real : boolean;
begin
result := cerrornode.create;
{ make sure we got at least two parameters (if we got only one, }
{ this parameter may not be encapsulated in a callparan) }
if not assigned(left) or
(left.nodetype <> callparan) then
exit;
{ get destination string }
dest := tcallparanode(left);
{ get source para (number) }
source := dest;
while assigned(source.right) do
source := tcallparanode(source.right);
is_real := source.resulttype.def.deftype = floatdef;
if not assigned(dest) or
(dest.left.resulttype.def.deftype<>stringdef) or
not(is_real or
(source.left.resulttype.def.deftype = orddef)) then
begin
{ the parser will give this message already because we }
{ return an errornode (JM) }
{ CGMessagePos(fileinfo,cg_e_illegal_expression); }
exit;
end;
{ get len/frac parameters }
lenpara := nil;
fracpara := nil;
if (cpf_is_colon_para in tcallparanode(dest.right).callparaflags) then
begin
lenpara := tcallparanode(dest.right);
{ we can let the callnode do the type checking of these parameters too, }
{ but then the error messages aren't as nice }
if not is_integer(lenpara.resulttype.def) then
begin
CGMessagePos1(lenpara.fileinfo,
type_e_integer_expr_expected,lenpara.resulttype.def.typename);
exit;
end;
if (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
begin
{ parameters are in reverse order! }
fracpara := lenpara;
lenpara := tcallparanode(lenpara.right);
if not is_real then
begin
CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
exit
end;
if not is_integer(lenpara.resulttype.def) then
begin
CGMessagePos1(lenpara.fileinfo,
type_e_integer_expr_expected,lenpara.resulttype.def.typename);
exit;
end;
end;
end;
{ generate the parameter list for the compilerproc }
newparas := dest;
{ if we have a float parameter, insert the realtype, len and fracpara parameters }
if is_real then
begin
{ insert realtype parameter }
newparas.right := ccallparanode.create(cordconstnode.create(
ord(tfloatdef(source.left.resulttype.def).typ),s32bittype),newparas.right);
{ if necessary, insert a fraction parameter }
if not assigned(fracpara) then
begin
tcallparanode(newparas.right).right := ccallparanode.create(
cordconstnode.create(-1,s32bittype),tcallparanode(newparas.right).right);
fracpara := tcallparanode(tcallparanode(newparas.right).right);
end;
{ if necessary, insert a length para }
if not assigned(lenpara) then
fracpara.right := ccallparanode.create(cordconstnode.create(-32767,s32bittype),
fracpara.right);
end
else
{ for a normal parameter, insert a only length parameter if one is missing }
if not assigned(lenpara) then
newparas.right := ccallparanode.create(cordconstnode.create(-1,s32bittype),
newparas.right);
{ remove the parameters from the original node so they won't get disposed, }
{ since they're reused }
left := nil;
{ create procedure name }
procname := 'fpc_' + lower(tstringdef(dest.resulttype.def).stringtypname)+'_';
if is_real then
procname := procname + 'float'
else
case torddef(dest.resulttype.def).typ of
u32bit:
procname := procname + 'cardinal';
u64bit:
procname := procname + 'qword';
s64bit:
procname := procname + 'int64';
else
procname := procname + 'longint';
end;
{ create the call node, }
newnode := ccallnode.createintern(procname,newparas);
{ resulttypepass it }
resulttypepass(newnode);
{ and return it (but first free the errornode we generated in the beginning) }
result.free;
result := newnode;
end;
function tinlinenode.handle_reset_rewrite_typed: tnode;
begin
{ since this is a "in_xxxx_typedfile" node, we can be sure we have }
{ a typed file as argument and we don't have to check it again (JM) }
{ add the recsize parameter }
{ note: for some reason, the parameter of intern procedures with only one }
{ parameter is gets lifted out of its original tcallparanode (see round }
{ line 1306 of ncal.pas), so recreate a tcallparanode here (JM) }
left := ccallparanode.create(cordconstnode.create(
tfiledef(left.resulttype.def).typedfiletype.def.size,s32bittype),
ccallparanode.create(left,nil));
{ create the correct call }
if inlinenumber=in_reset_typedfile then
result := ccallnode.createintern('fpc_reset_typed',left)
else
result := ccallnode.createintern('fpc_rewrite_typed',left);
firstpass(result);
{ make sure left doesn't get disposed, since we use it in the new call }
left := nil;
end;
function tinlinenode.handle_read_write: tnode;
function reverseparameters(p: tnode): tnode;
var
hp1, hp2: tnode;
begin
hp1:=nil;
while assigned(p) do
begin
{ pull out }
hp2:=p;
p:=tcallparanode(p).right;
{ pull in }
tcallparanode(hp2).right:=hp1;
hp1:=hp2;
end;
reverseparameters:=hp1;
end;
const
procnames: array[boolean,boolean] of string[11] =
(('write_text_','read_text_'),('typed_write','typed_read'));
var
filepara,
lenpara,
fracpara,
nextpara,
para : tcallparanode;
newstatement : tstatementnode;
newblock : tblocknode;
p1 : tnode;
filetemp,
temp : ttempcreatenode;
tempref : ttemprefnode;
procprefix,
name : string[31];
srsym : tsym;
tempowner : tsymtable;
restype : ^ttype;
is_typed,
do_read,
is_real,
error_para,
found_error,
is_ordinal : boolean;
begin
filepara := nil;
is_typed := false;
filetemp := nil;
do_read := inlinenumber in [in_read_x,in_readln_x];
{ if we fail, we can quickly exit this way. We must generate something }
{ instead of the inline node, because firstpass will bomb with an }
{ internalerror if it encounters a read/write }
result := cerrornode.create;
{ reverse the parameters (needed to get the colon parameters in the }
{ correct order when processing write(ln) }
left := reverseparameters(left);
if assigned(left) then
begin
{ check if we have a file parameter and if yes, what kind it is }
filepara := tcallparanode(left);
if (filepara.resulttype.def.deftype=filedef) then
begin
if (tfiledef(filepara.resulttype.def).filetyp=ft_untyped) then
begin
CGMessagePos(fileinfo,type_e_no_read_write_for_untyped_file);
exit;
end
else
begin
if (tfiledef(filepara.resulttype.def).filetyp=ft_typed) then
begin
if (inlinenumber in [in_readln_x,in_writeln_x]) then
begin
CGMessagePos(fileinfo,type_e_no_readln_writeln_for_typed_file);
exit;
end;
is_typed := true;
end
end;
{ the file para is a var parameter, but it must be valid already }
set_varstate(filepara,true);
end
else
filepara := nil;
end;
{ create a blocknode in which the successive write/read statements will be }
{ put, since they belong together. Also create a dummy statement already to }
{ make inserting of additional statements easier }
newstatement := cstatementnode.create(nil,cnothingnode.create);
newblock := cblocknode.create(newstatement);
{ if we don't have a filepara, create one containing the default }
if not assigned(filepara) then
begin
{ create a loadnode for the standard input/output handle }
if do_read then
name := 'INPUT'
else
name := 'OUTPUT';
{ if we are compiling the system unit, the systemunit symtable is nil. }
{ however, if we aren't compiling the system unit, another unit could }
{ also have defined the INPUT or OUTPUT symbols. Therefore we need the }
{ separate cases (JM) }
if not (cs_compilesystem in aktmoduleswitches) then
begin
srsym := searchsymonlyin(systemunit,name);
tempowner := systemunit;
end
else
searchsym(name,srsym,tempowner);
if not assigned(srsym) then
internalerror(200108141);
{ create the file parameter }
filepara := ccallparanode.create(cloadnode.create(srsym,tempowner),nil);
end
else
{ remove filepara from the parameter chain }
begin
left := filepara.right;
filepara.right := nil;
{ check if we should make a temp to store the result of a complex }
{ expression (better heuristics, anyone?) (JM) }
if (filepara.left.nodetype <> loadn) then
begin
{ create a temp which will hold a pointer to the file }
filetemp := ctempcreatenode.create(voidpointertype,voidpointertype.def.size);
{ add it to the statements }
newstatement.left := cstatementnode.create(nil,filetemp);
newstatement := tstatementnode(newstatement.left);
{ make sure the resulttype of the temp (and as such of the }
{ temprefs coming after it) is set (necessary because the }
{ temprefs will be part of the filepara, of which we need }
{ the resulttype later on and temprefs can only be }
{ resulttypepassed if the resulttype of the temp is known) }
resulttypepass(filetemp);
{ assign the address of the file to the temp }
newstatement.left := cstatementnode.create(nil,
cassignmentnode.create(ctemprefnode.create(filetemp),
caddrnode.create(filepara.left)));
newstatement := tstatementnode(newstatement.left);
resulttypepass(newstatement.right);
{ create a new fileparameter as follows: file_type(temp^) }
{ (so that we pass the value and not the address of the temp }
{ to the read/write routine) }
nextpara := ccallparanode.create(ctypeconvnode.create(
cderefnode.create(ctemprefnode.create(filetemp)),filepara.left.resulttype),nil);
{ make sure the type conversion is explicit, otherwise this }
{ typecast won't work }
nextpara.left.toggleflag(nf_explizit);
{ replace the old file para with the new one }
filepara.left := nil;
filepara.free;
filepara := nextpara;
{ the resulttype of the filepara must be set since it's }
{ used below }
filepara.get_paratype;
end;
end;
{ now, filepara is nowhere referenced anymore, so we can safely dispose it }
{ if something goes wrong or at the end of the procedure }
{ choose the correct procedure prefix }
procprefix := 'fpc_'+procnames[is_typed,do_read];
{ we're going to reuse the paranodes, so make sure they don't get freed }
{ twice }
para := tcallparanode(left);
left := nil;
{ no errors found yet... }
found_error := false;
if is_typed then
begin
{ add the typesize to the filepara }
filepara.right := ccallparanode.create(cordconstnode.create(
tfiledef(filepara.resulttype.def).typedfiletype.def.size,s32bittype),nil);
{ check for "no parameters" (you need at least one extra para for typed files) }
if not assigned(para) then
begin
CGMessage(parser_e_wrong_parameter_size);
found_error := true;
end;
{ process all parameters }
while assigned(para) do
begin
{ check if valid parameter }
if para.left.nodetype=typen then
begin
CGMessagePos(para.left.fileinfo,type_e_cant_read_write_type);
found_error := true;
end;
if not is_equal(para.left.resulttype.def,tfiledef(filepara.resulttype.def).typedfiletype.def) then
begin
CGMessagePos(para.left.fileinfo,type_e_mismatch);
found_error := true;
end;
if assigned(para.right) and
(cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
begin
CGMessagePos(para.right.fileinfo,parser_e_illegal_colon_qualifier);
{ skip all colon para's }
nextpara := tcallparanode(tcallparanode(para.right).right);
while assigned(nextpara) and
(cpf_is_colon_para in nextpara.callparaflags) do
nextpara := tcallparanode(nextpara.right);
found_error := true;
end
else
{ get next parameter }
nextpara := tcallparanode(para.right);
{ add fileparameter }
para.right := filepara.getcopy;
{ create call statment }
{ since the parameters are in the correct order, we have to insert }
{ the statements always at the end of the current block }
newstatement.left := cstatementnode.create(nil,
ccallnode.createintern(procprefix,para));
newstatement := tstatementnode(newstatement.left);
{ process next parameter }
para := nextpara;
end;
{ free the file parameter }
filepara.free;
end
else
{ text write }
begin
while assigned(para) do
begin
{ is this parameter faulty? }
error_para := false;
{ is this parameter an ordinal? }
is_ordinal := false;
{ is this parameter a real? }
is_real:=false;
{ can't read/write types }
if para.left.nodetype=typen then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end;
{ support writeln(procvar) }
if (para.left.resulttype.def.deftype=procvardef) then
begin
p1:=ccallnode.create(nil,nil,nil,nil);
tcallnode(p1).set_procvar(para.left);
resulttypepass(p1);
para.left:=p1;
end;
case para.left.resulttype.def.deftype of
stringdef :
begin
name := procprefix+lower(tstringdef(para.left.resulttype.def).stringtypname);
end;
pointerdef :
begin
if not is_pchar(para.left.resulttype.def) then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
name := procprefix+'pchar_as_pointer';
end;
floatdef :
begin
is_real:=true;
name := procprefix+'float';
end;
orddef :
begin
is_ordinal := true;
case torddef(para.left.resulttype.def).typ of
s8bit,s16bit,s32bit :
name := procprefix+'sint';
u8bit,u16bit,u32bit :
name := procprefix+'uint';
uchar :
name := procprefix+'char';
uwidechar :
name := procprefix+'widechar';
s64bit :
name := procprefix+'int64';
u64bit :
name := procprefix+'qword';
bool8bit,
bool16bit,
bool32bit :
begin
if do_read then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
name := procprefix+'boolean'
end
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end;
end;
end;
arraydef :
begin
if is_chararray(para.left.resulttype.def) then
name := procprefix+'pchar_as_array'
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
end
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
end;
{ check for length/fractional colon para's }
fracpara := nil;
lenpara := nil;
if assigned(para.right) and
(cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
begin
lenpara := tcallparanode(para.right);
if assigned(lenpara.right) and
(cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
fracpara:=tcallparanode(lenpara.right);
end;
{ get the next parameter now already, because we're going }
{ to muck around with the pointers }
if assigned(fracpara) then
nextpara := tcallparanode(fracpara.right)
else if assigned(lenpara) then
nextpara := tcallparanode(lenpara.right)
else
nextpara := tcallparanode(para.right);
{ check if a fracpara is allowed }
if assigned(fracpara) and not is_real then
begin
CGMessagePos(fracpara.fileinfo,parser_e_illegal_colon_qualifier);
error_para := true;
end
else if assigned(lenpara) and do_read then
begin
{ I think this is already filtered out by parsing, but I'm not sure (JM) }
CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
error_para := true;
end;
{ adjust found_error }
found_error := found_error or error_para;
if not error_para then
begin
{ create dummy frac/len para's if necessary }
if not do_read then
begin
{ difference in default value for floats and the rest :( }
if not is_real then
begin
if not assigned(lenpara) then
lenpara := ccallparanode.create(cordconstnode.create(0,s32bittype),nil)
else
{ make sure we don't pass the successive }
{ parameters too. We also already have a }
{ reference to the next parameter in }
{ nextpara }
lenpara.right := nil;
end
else
begin
if not assigned(lenpara) then
lenpara := ccallparanode.create(
cordconstnode.create(-32767,s32bittype),nil);
{ also create a default fracpara if necessary }
if not assigned(fracpara) then
fracpara := ccallparanode.create(
cordconstnode.create(-1,s32bittype),nil);
{ add it to the lenpara }
lenpara.right := fracpara;
{ and add the realtype para (this also removes the link }
{ to any parameters coming after it) }
fracpara.right := ccallparanode.create(
cordconstnode.create(ord(tfloatdef(para.left.resulttype.def).typ),
s32bittype),nil);
end;
end;
if do_read and
((is_ordinal and
(torddef(para.left.resulttype.def).typ in [s8bit,s16bit,u8bit,u16bit])
) or
(is_real and
not is_equal(para.left.resulttype.def,pbestrealtype^.def)
)
) then
{ special handling of reading small numbers, because the helpers }
{ expect a longint/card/bestreal var parameter. Use a temp. can't }
{ use functions because then the call to FPC_IOCHECK destroys }
{ their result before we can store it }
begin
{ get the resulttype of the var parameter of the helper }
if is_real then
restype := pbestrealtype
else if is_signed(para.left.resulttype.def) then
restype := @s32bittype
else
restype := @u32bittype;
{ create the parameter list: the temp ... }
temp := ctempcreatenode.create(restype^,restype^.def.size);
newstatement.left := cstatementnode.create(nil,temp);
newstatement := tstatementnode(newstatement.left);
{ ... and the file }
p1 := ccallparanode.create(ctemprefnode.create(temp),
filepara.getcopy);
{ create the call to the helper }
newstatement.left := cstatementnode.create(nil,
ccallnode.createintern(name,tcallparanode(p1)));
newstatement := tstatementnode(newstatement.left);
{ assign the result to the original var (this automatically }
{ takes care of range checking) }
newstatement.left := cstatementnode.create(nil,
cassignmentnode.create(para.left,
ctemprefnode.create(temp)));
newstatement := tstatementnode(newstatement.left);
{ release the temp location }
newstatement.left := cstatementnode.create(nil,
ctempdeletenode.create(temp));
newstatement := tstatementnode(newstatement.left);
{ statement of para is used }
para.left := nil;
{ free the enclosing tcallparanode, but not the }
{ parameters coming after it }
para.right := nil;
para.free;
end
else
{ read of non s/u-8/16bit, or a write }
begin
{ add the filepara to the current parameter }
para.right := filepara.getcopy;
{ add the lenpara (fracpara and realtype are already linked }
{ with it if necessary) }
tcallparanode(para.right).right := lenpara;
{ create the call statement }
newstatement.left := cstatementnode.create(nil,
ccallnode.createintern(name,para));
newstatement := tstatementnode(newstatement.left);
end
end
else
{ error_para = true }
begin
{ free the parameter, since it isn't referenced anywhere anymore }
para.right := nil;
para.free;
if assigned(lenpara) then
begin
lenpara.right := nil;
lenpara.free;
end;
if assigned(fracpara) then
begin
fracpara.right := nil;
fracpara.free;
end;
end;
{ process next parameter }
para := nextpara;
end;
{ if no error, add the write(ln)/read(ln) end calls }
if not found_error then
begin
case inlinenumber of
in_read_x:
newstatement.left := ccallnode.createintern('fpc_read_end',filepara);
in_write_x:
newstatement.left := ccallnode.createintern('fpc_write_end',filepara);
in_readln_x:
newstatement.left := ccallnode.createintern('fpc_readln_end',filepara);
in_writeln_x:
newstatement.left := ccallnode.createintern('fpc_writeln_end',filepara);
end;
newstatement.left := cstatementnode.create(nil,newstatement.left);
newstatement := tstatementnode(newstatement.left);
end;
end;
{ if we found an error, simply delete the generated blocknode }
if found_error then
newblock.free
else
begin
{ deallocate the temp for the file para if we used one }
if assigned(filetemp) then
begin
newstatement.left := cstatementnode.create(nil,
ctempdeletenode.create(filetemp));
newstatement := tstatementnode(newstatement.left);
end;
{ otherwise return the newly generated block of instructions, }
{ but first free the errornode we generated at the beginning }
result.free;
resulttypepass(newblock);
result := newblock
end;
end;
{$endif hascompilerproc}
function tinlinenode.det_resulttype:tnode;
function do_lowhigh(const t:ttype) : tnode;
@ -768,6 +1483,9 @@ implementation
in_write_x,
in_writeln_x :
begin
{$ifdef hascompilerproc}
result := handle_read_write;
{$else hascompilerproc}
resulttype:=voidtype;
{ we must know if it is a typed file or not }
{ but we must first do the firstpass for it }
@ -941,8 +1659,8 @@ implementation
exit;
set_varstate(left,true);
end;
{$endif hascompilerproc}
end;
in_settextbuf_file_x :
begin
resulttype:=voidtype;
@ -959,12 +1677,19 @@ implementation
in_reset_typedfile,
in_rewrite_typedfile :
begin
{$ifdef hascompilerproc}
result := handle_reset_rewrite_typed;
{$else hascompilerproc}
set_varstate(left,true);
resulttype:=voidtype;
{$endif hascompilerproc}
end;
in_str_x_string :
begin
{$ifdef hascompilerproc}
result := handle_str;
{$else hascompilerproc}
resulttype:=voidtype;
set_varstate(left,false);
{ remove warning when result is passed }
@ -978,13 +1703,11 @@ implementation
CGMessage(cg_e_illegal_expression);
{ we need a var parameter }
valid_for_var(tcallparanode(hp).left);
{$ifndef hascompilerproc}
{ with compilerproc's, this is not necessary anymore, the callnode }
{ will convert it to an openstring itself if necessary (JM) }
{ generate the high() value for the shortstring }
if is_shortstring(tcallparanode(hp).left.resulttype.def) then
tcallparanode(hp).gen_high_tree(true);
{$endif not hascompilerproc}
{ !!!! check length of string }
while assigned(tcallparanode(hp).right) do
hp:=tcallparanode(hp).right;
@ -1044,6 +1767,7 @@ implementation
CGMessage(parser_e_illegal_colon_qualifier);
end;
end;
{$endif not hascompilerproc}
end;
in_val_x :
@ -1388,120 +2112,6 @@ implementation
{$maxfpuregisters 0}
{$endif fpc}
{$ifdef hascompilerproc}
function tinlinenode.str_pass_1 : tnode;
var
lenpara,
fracpara,
newparas,
dest,
source : tcallparanode;
newnode : tnode;
len,
fraclen : longint;
procname: string;
is_real : boolean;
begin
{ get destination string }
dest := tcallparanode(left);
{ get source para (number) }
source := dest;
while assigned(source.right) do
source := tcallparanode(source.right);
is_real := source.resulttype.def.deftype = floatdef;
{ get len/frac parameters }
lenpara := nil;
fracpara := nil;
if (cpf_is_colon_para in tcallparanode(dest.right).callparaflags) then
begin
lenpara := tcallparanode(dest.right);
if (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
begin
fracpara := lenpara;
lenpara := tcallparanode(lenpara.right);
end;
end;
{ generate the parameter list for the compilerproc }
newparas := dest;
{ if we have a float parameter, insert the realtype, len and fracpara parameters }
if is_real then
begin
{ insert realtype parameter }
newparas.right := ccallparanode.create(cordconstnode.create(
ord(tfloatdef(source.left.resulttype.def).typ),s32bittype),newparas.right);
{ if necessary, insert a fraction parameter }
if not assigned(fracpara) then
begin
tcallparanode(newparas.right).right := ccallparanode.create(
cordconstnode.create(-1,s32bittype),tcallparanode(newparas.right).right);
fracpara := tcallparanode(tcallparanode(newparas.right).right);
end;
{ if necessary, insert a length para }
if not assigned(lenpara) then
fracpara.right := ccallparanode.create(cordconstnode.create(-32767,s32bittype),
fracpara.right);
end
else
{ for a normal parameter, insert a only length parameter if one is missing }
if not assigned(lenpara) then
newparas.right := ccallparanode.create(cordconstnode.create(-1,s32bittype),
newparas.right);
{ remove the parameters from the original node so they won't get disposed, }
{ since they're reused }
left := nil;
{ create procedure name }
procname := 'fpc_' + lowercase(tstringdef(dest.resulttype.def).stringtypname)+'_';
if is_real then
procname := procname + 'float'
else
case torddef(dest.resulttype.def).typ of
u32bit:
procname := procname + 'cardinal';
u64bit:
procname := procname + 'qword';
s64bit:
procname := procname + 'int64';
else
procname := procname + 'longint';
end;
{ create the call node, }
newnode := ccallnode.createintern(procname,newparas);
{ firstpass it }
firstpass(newnode);
{ and return it }
result := newnode;
end;
function tinlinenode.reset_rewrite_typed_pass_1: tnode;
begin
{ add the recsize parameter }
{ note: for some reason, the parameter of intern procedures with only one }
{ parameter is gets lifted out of its original tcallparanode (see round }
{ line 1301 of ncal.pas), so recreate a tcallparanode here (JM) }
left := ccallparanode.create(cordconstnode.create(
tfiledef(left.resulttype.def).typedfiletype.def.size,s32bittype),
ccallparanode.create(left,nil));
{ create the correct call }
if inlinenumber=in_reset_typedfile then
result := ccallnode.createintern('fpc_reset_typed',left)
else
result := ccallnode.createintern('fpc_rewrite_typed',left);
firstpass(result);
{ make sure left doesn't get disposed, since we use it in the new call }
left := nil;
end;
{$endif hascompilerproc}
function tinlinenode.pass_1 : tnode;
var
@ -1693,6 +2303,10 @@ implementation
in_write_x,
in_writeln_x :
begin
{$ifdef hascompilerproc}
{ should be handled by det_resulttype }
internalerror(200108234);
{$else hascompilerproc}
{ needs a call }
procinfo^.flags:=procinfo^.flags or pi_do_call;
{ true, if readln needs an extra register }
@ -1744,8 +2358,8 @@ implementation
if extra_register then
inc(registers32);
end;
{$endif hascompilerproc}
end;
in_settextbuf_file_x :
internalerror(200104262);
@ -1755,7 +2369,8 @@ implementation
{$ifndef hascompilerproc}
procinfo^.flags:=procinfo^.flags or pi_do_call;
{$else not hascompilerproc}
result := reset_rewrite_typed_pass_1;
{ should already be removed in det_resulttype (JM) }
internalerror(200108236);
{$endif not hascompilerproc}
end;
@ -1766,7 +2381,8 @@ implementation
{ calc registers }
left_max;
{$else not hascompilerproc}
result := str_pass_1;
{ should already be removed in det_resulttype (JM) }
internalerror(200108235);
{$endif not hascompilerproc}
end;
@ -1926,7 +2542,22 @@ begin
end.
{
$Log$
Revision 1.48 2001-08-13 15:39:52 jonas
Revision 1.49 2001-08-23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.48 2001/08/13 15:39:52 jonas
* made in_reset_typedfile/in_rewrite_typedfile handling processor
independent

21
compiler/node.pas
View File

@ -118,6 +118,8 @@ interface
procinlinen, {Procedures that can be inlined }
arrayconstructorn, {Construction node for [...] parsing}
arrayconstructorrangen, {Range element to allow sets in array construction tree}
tempn, { for temps in the result/firstpass }
temprefn, { references to temps }
{ added for optimizations where we cannot suppress }
addoptn,
nothingn,
@ -203,6 +205,8 @@ interface
'procinlinen',
'arrayconstructn',
'arrayconstructrangen',
'tempn',
'temprefn',
'addoptn',
'nothingn',
'loadvmtn');
@ -797,7 +801,22 @@ implementation
end.
{
$Log$
Revision 1.18 2001-07-30 20:59:27 peter
Revision 1.19 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.18 2001/07/30 20:59:27 peter
* m68k updates from v10 merged
Revision 1.17 2001/06/04 18:14:16 peter

29
compiler/pdecsub.pas
View File

@ -1116,6 +1116,11 @@ begin
end;
end;
procedure pd_compilerproc;
begin
aktprocsym.definition.setmangledname(lower(aktprocsym.name));
end;
type
pd_handler=procedure;
@ -1443,7 +1448,7 @@ const
),(
idtok:_COMPILERPROC;
pd_flags : pd_interface+pd_implemen+pd_body+pd_notobjintf;
handler : nil;
handler : {$ifdef FPCPROCVAR}@{$endif}pd_compilerproc;
pocall : [pocall_compilerproc];
pooption : [];
mutexclpocall : [];
@ -1841,7 +1846,10 @@ const
{ also update the realname that is stored in the ppu }
stringdispose(aktprocsym._realname);
aktprocsym._realname:=stringdup('$'+aktprocsym.name);
aktprocsym.definition.setmangledname(aktprocsym.name);
{ the mangeled name is already changed by the pd_compilerproc }
{ handler. It must be done immediately because if we have a }
{ call to a compilerproc before it's implementation is }
{ encountered, it must already use the new mangled name (JM) }
end;
check_identical_proc:=true;
break;
@ -1918,7 +1926,22 @@ const
end.
{
$Log$
Revision 1.34 2001-08-22 21:16:21 florian
Revision 1.35 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.34 2001/08/22 21:16:21 florian
* some interfaces related problems regarding
mapping of interface implementions fixed

22
compiler/pstatmnt.pas
View File

@ -1085,7 +1085,10 @@ implementation
resulttypepass(tlabelnode(p).left);
end;
if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen,labeln]) then
{ blockn support because a read/write is changed into a blocknode }
{ with a separate statement for each read/write operation (JM) }
{ the same is true for val() if the third parameter is not 32 bit }
if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen,labeln,blockn]) then
Message(cg_e_illegal_expression);
{ specify that we don't use the value returned by the call }
{ Question : can this be also improtant
@ -1222,7 +1225,22 @@ implementation
end.
{
$Log$
Revision 1.32 2001-08-06 21:40:47 peter
Revision 1.33 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.32 2001/08/06 21:40:47 peter
* funcret moved from tprocinfo to tprocdef
Revision 1.31 2001/06/03 21:57:37 peter

50
rtl/inc/compproc.inc
View File

@ -104,6 +104,39 @@ procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);
Procedure fpc_WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString); compilerproc;
Procedure fpc_WideStr_Longint(L : Longint; Len : Longint; Var S : WideString); compilerproc;
{ from text.inc }
Procedure fpc_Write_End(var f:Text); compilerproc;
Procedure fpc_Writeln_End(var f:Text); compilerproc;
Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); compilerproc;
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char); compilerproc;
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); compilerproc;
Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; S : AnsiString); compilerproc;
{$ifdef HASWIDESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; S : WideString); compilerproc;
{$endif HASWIDESTRING}
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); compilerproc;
Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); compilerproc;
procedure fpc_write_text_qword(len : longint;var t : text;q : qword); compilerproc;
procedure fpc_write_text_int64(len : longint;var t : text;i : int64); compilerproc;
Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc;
Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); compilerproc;
Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : Char); compilerproc;
{$ifdef HASWIDECHAR}
Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); compilerproc;
{$endif HASWIDECHAR}
Procedure fpc_Read_End(var f:Text); compilerproc;
Procedure fpc_ReadLn_End(var f : Text); compilerproc;
Procedure fpc_Read_Text_ShortStr(var f : Text;var s : String); compilerproc;
Procedure fpc_Read_Text_PChar_As_Pointer(var f : Text;var s : PChar); compilerproc;
Procedure fpc_Read_Text_PChar_As_Array(var f : Text;var s : array of char); compilerproc;
Procedure fpc_Read_Text_AnsiStr(var f : Text;var s : AnsiString); compilerproc;
Procedure fpc_Read_Text_Char(var f : Text; var c : char); compilerproc;
Procedure fpc_Read_Text_SInt(var f : Text; var l :ValSInt); compilerproc;
Procedure fpc_Read_Text_UInt(var f : Text; var u :ValUInt); compilerproc;
Procedure fpc_Read_Text_Float(var f : Text; var v :ValReal); compilerproc;
Procedure fpc_Read_Text_QWord(var f : text; var q : qword); compilerproc;
Procedure fpc_Read_Text_Int64(var f : text; var i : int64); compilerproc;
{ from int64.inc }
procedure fpc_shortstr_qword(v : qword;len : longint;var s : shortstring); compilerproc;
procedure fpc_shortstr_int64(v : int64;len : longint;var s : shortstring); compilerproc;
@ -197,7 +230,22 @@ Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;var Buf); compiler
{
$Log$
Revision 1.3 2001-08-13 12:40:16 jonas
Revision 1.4 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.3 2001/08/13 12:40:16 jonas
* renamed some str(x,y) and val(x,y) helpers so the naming scheme is the
same for all string types
+ added the str(x,y) and val(x,y,z) helpers for int64/qword to

360
rtl/inc/text.inc
View File

@ -392,7 +392,7 @@ End;
Write(Ln)
*****************************************************************************}
Procedure WriteBuffer(var f:TextRec;const b;len:longint);
Procedure WriteBuffer(var f:Text;const b;len:longint);
var
p : pchar;
left,
@ -400,47 +400,47 @@ var
begin
p:=pchar(@b);
idx:=0;
left:=f.BufSize-f.BufPos;
left:=TextRec(f).BufSize-TextRec(f).BufPos;
while len>left do
begin
move(p[idx],f.Bufptr^[f.BufPos],left);
move(p[idx],TextRec(f).Bufptr^[TextRec(f).BufPos],left);
dec(len,left);
inc(idx,left);
inc(f.BufPos,left);
FileFunc(f.InOutFunc)(f);
left:=f.BufSize-f.BufPos;
inc(TextRec(f).BufPos,left);
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
left:=TextRec(f).BufSize-TextRec(f).BufPos;
end;
move(p[idx],f.Bufptr^[f.BufPos],len);
inc(f.BufPos,len);
move(p[idx],TextRec(f).Bufptr^[TextRec(f).BufPos],len);
inc(TextRec(f).BufPos,len);
end;
Procedure WriteBlanks(var f:TextRec;len:longint);
Procedure WriteBlanks(var f:Text;len:longint);
var
left : longint;
begin
left:=f.BufSize-f.BufPos;
left:=TextRec(f).BufSize-TextRec(f).BufPos;
while len>left do
begin
FillChar(f.Bufptr^[f.BufPos],left,' ');
FillChar(TextRec(f).Bufptr^[TextRec(f).BufPos],left,' ');
dec(len,left);
inc(f.BufPos,left);
FileFunc(f.InOutFunc)(f);
left:=f.BufSize-f.BufPos;
inc(TextRec(f).BufPos,left);
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
left:=TextRec(f).BufSize-TextRec(f).BufPos;
end;
FillChar(f.Bufptr^[f.BufPos],len,' ');
inc(f.BufPos,len);
FillChar(TextRec(f).Bufptr^[TextRec(f).BufPos],len,' ');
inc(TextRec(f).BufPos,len);
end;
Procedure Write_End(var f:TextRec);[Public,Alias:'FPC_WRITE_END'];
Procedure fpc_Write_End(var f:Text);[Public,Alias:'FPC_WRITE_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if f.FlushFunc<>nil then
FileFunc(f.FlushFunc)(f);
if TextRec(f).FlushFunc<>nil then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
end;
Procedure Writeln_End(var f:TextRec);[Public,Alias:'FPC_WRITELN_END'];
Procedure fpc_Writeln_End(var f:Text);[Public,Alias:'FPC_WRITELN_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
const
{$IFDEF SHORT_LINEBREAK}
eollen=1;
@ -456,14 +456,14 @@ const
{$ENDIF SHORT_LINEBREAK}
begin
If InOutRes <> 0 then exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
{ Write EOL }
WriteBuffer(f,(@sLineBreak+1)^,length(sLineBreak));
{ Flush }
if f.FlushFunc<>nil then
FileFunc(f.FlushFunc)(f);
if TextRec(f).FlushFunc<>nil then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
end;
fmInput: InOutRes:=105
else InOutRes:=103;
@ -471,11 +471,11 @@ begin
end;
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_SHORTSTR'];
Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
If (InOutRes<>0) then
exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
If Len>Length(s) Then
@ -487,15 +487,18 @@ Begin
end;
End;
{ provide local access to write_str }
procedure Write_Str(Len : Longint;var f : Text;const s : String); iocheck; [external name 'FPC_WRITE_TEXT_SHORTSTR'];
Procedure Write_Array(Len : Longint;var f : TextRec;const s : array of char);[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY'];
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char); iocheck; [Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
ArrayLen : longint;
p : pchar;
Begin
If (InOutRes<>0) then
exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
p:=pchar(@s);
@ -515,13 +518,13 @@ Begin
End;
Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_POINTER'];
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); iocheck; [Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_POINTER']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
PCharLen : longint;
Begin
If (p=nil) or (InOutRes<>0) then
exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
PCharLen:=StrLen(p);
@ -535,7 +538,7 @@ Begin
End;
Procedure Write_Text_AnsiString (Len : Longint; Var f : TextRec; S : AnsiString);[Public,alias:'FPC_WRITE_TEXT_ANSISTR'];
Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; S : AnsiString); iocheck; [Public,alias:'FPC_WRITE_TEXT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Writes a AnsiString to the Text file T
}
@ -544,7 +547,7 @@ var
begin
If (pointer(S)=nil) or (InOutRes<>0) then
exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
SLen:=Length(s);
@ -559,7 +562,7 @@ end;
{$ifdef HASWIDESTRING}
Procedure Write_Text_WideString (Len : Longint; Var f : TextRec; S : WideString);[Public,alias:'FPC_WRITE_TEXT_WIDESTR'];
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
Writes a WideString to the Text file T
}
@ -568,7 +571,7 @@ var
begin
If (pointer(S)=nil) or (InOutRes<>0) then
exit;
case f.mode of
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
SLen:=Length(s);
@ -582,7 +585,7 @@ begin
end;
{$endif HASWIDESTRING}
Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_SINT'];
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s : String;
Begin
@ -593,7 +596,7 @@ Begin
End;
Procedure Write_UInt(Len : Longint;var t : TextRec;l : ValUInt);[Public,Alias:'FPC_WRITE_TEXT_UINT'];
Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_UINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s : String;
Begin
@ -604,7 +607,7 @@ Begin
End;
procedure write_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_WRITE_TEXT_QWORD'];
procedure fpc_write_text_qword(len : longint;var t : text;q : qword); iocheck; [public,alias:'FPC_WRITE_TEXT_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s : string;
begin
@ -614,7 +617,7 @@ begin
write_str(len,t,s);
end;
procedure write_int64(len : longint;var t : textrec;i : int64);[public,alias:'FPC_WRITE_TEXT_INT64'];
procedure fpc_write_text_int64(len : longint;var t : text;i : int64); iocheck; [public,alias:'FPC_WRITE_TEXT_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s : string;
begin
@ -625,7 +628,7 @@ begin
end;
Procedure Write_Float(rt,fixkomma,Len : Longint;var t : TextRec;r : ValReal);[Public,Alias:'FPC_WRITE_TEXT_FLOAT'];
Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); iocheck; [Public,Alias:'FPC_WRITE_TEXT_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
s : String;
Begin
@ -636,7 +639,7 @@ Begin
End;
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias:'FPC_WRITE_TEXT_BOOLEAN'];
Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); iocheck; [Public,Alias:'FPC_WRITE_TEXT_BOOLEAN']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
If (InOutRes<>0) then
exit;
@ -648,7 +651,7 @@ Begin
End;
Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias:'FPC_WRITE_TEXT_CHAR'];
Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : Char); iocheck; [Public,Alias:'FPC_WRITE_TEXT_CHAR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
If (InOutRes<>0) then
exit;
@ -662,15 +665,15 @@ Begin
end;
If Len>1 Then
WriteBlanks(t,Len-1);
If t.BufPos+1>=t.BufSize Then
FileFunc(t.InOutFunc)(t);
t.Bufptr^[t.BufPos]:=c;
Inc(t.BufPos);
If TextRec(t).BufPos+1>=TextRec(t).BufSize Then
FileFunc(TextRec(t).InOutFunc)(TextRec(t));
TextRec(t).Bufptr^[TextRec(t).BufPos]:=c;
Inc(TextRec(t).BufPos);
End;
{$ifdef HASWIDECHAR}
Procedure Write_WideChar(Len : Longint;var t : TextRec;c : WideChar);[Public,Alias:'FPC_WRITE_TEXT_WIDECHAR'];
Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); iocheck; [Public,Alias:'FPC_WRITE_TEXT_WIDECHAR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
ch : char;
Begin
@ -686,11 +689,11 @@ Begin
end;
If Len>1 Then
WriteBlanks(t,Len-1);
If t.BufPos+1>=t.BufSize Then
FileFunc(t.InOutFunc)(t);
If TextRec(t).BufPos+1>=TextRec(t).BufSize Then
FileFunc(TextRec(t).InOutFunc)(TextRec(t));
ch:=c;
t.Bufptr^[t.BufPos]:=ch;
Inc(t.BufPos);
TextRec(t).Bufptr^[TextRec(t).BufPos]:=ch;
Inc(TextRec(t).BufPos);
End;
{$endif HASWIDECHAR}
@ -699,18 +702,18 @@ End;
Read(Ln)
*****************************************************************************}
Function NextChar(var f:TextRec;var s:string):Boolean;
Function NextChar(var f:Text;var s:string):Boolean;
begin
if f.BufPos<f.BufEnd then
if TextRec(f).BufPos<TextRec(f).BufEnd then
begin
if length(s)<high(s) then
begin
inc(s[0]);
s[length(s)]:=f.BufPtr^[f.BufPos];
s[length(s)]:=TextRec(f).BufPtr^[TextRec(f).BufPos];
end;
Inc(f.BufPos);
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
Inc(TextRec(f).BufPos);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
NextChar:=true;
end
else
@ -718,7 +721,7 @@ begin
end;
Function IgnoreSpaces(var f:TextRec):Boolean;
Function IgnoreSpaces(var f:Text):Boolean;
{
Removes all leading spaces,tab,eols from the input buffer, returns true if
the buffer is empty
@ -728,14 +731,14 @@ var
begin
s:='';
IgnoreSpaces:=false;
while f.Bufptr^[f.BufPos] in [#9,#10,#13,' '] do
while TextRec(f).Bufptr^[TextRec(f).BufPos] in [#9,#10,#13,' '] do
if not NextChar(f,s) then
exit;
IgnoreSpaces:=true;
end;
procedure ReadNumeric(var f:TextRec;var s:string);
procedure ReadNumeric(var f:Text;var s:string);
{
Read numeric input, if buffer is empty then return True
}
@ -743,24 +746,24 @@ begin
repeat
if not NextChar(f,s) then
exit;
until (length(s)=high(s)) or (f.BufPtr^[f.BufPos] in [#9,#10,#13,' ']);
until (length(s)=high(s)) or (TextRec(f).BufPtr^[TextRec(f).BufPos] in [#9,#10,#13,' ']);
end;
Procedure Read_End(var f:TextRec);[Public,Alias:'FPC_READ_END'];
Procedure fpc_Read_End(var f:Text);[Public,Alias:'FPC_READ_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if f.FlushFunc<>nil then
FileFunc(f.FlushFunc)(f);
if TextRec(f).FlushFunc<>nil then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
end;
Procedure ReadLn_End(var f : TextRec);[Public,Alias:'FPC_READLN_END'];
Procedure fpc_ReadLn_End(var f : Text);[Public,Alias:'FPC_READLN_END']; iocheck; {$ifdef hascompilerproc} compilerproc; {$endif}
var prev: char;
Begin
{ Check error and if file is open and load buf if empty }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -770,48 +773,48 @@ Begin
end;
exit;
end;
if f.BufPos>=f.BufEnd Then
if TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
if (f.BufPos>=f.BufEnd) then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
{ Flush if set }
begin
if (f.FlushFunc<>nil) then
FileFunc(f.FlushFunc)(f);
if (TextRec(f).FlushFunc<>nil) then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
exit;
end;
end;
repeat
prev := f.BufPtr^[f.BufPos];
inc(f.BufPos);
prev := TextRec(f).BufPtr^[TextRec(f).BufPos];
inc(TextRec(f).BufPos);
{ no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, }
{ #13#10 = Dos), so if we've got #10, we can safely exit }
if prev = #10 then
exit;
if f.BufPos>=f.BufEnd Then
if TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
if (f.BufPos>=f.BufEnd) then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
{ Flush if set }
begin
if (f.FlushFunc<>nil) then
FileFunc(f.FlushFunc)(f);
if (TextRec(f).FlushFunc<>nil) then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
exit;
end;
end;
if (prev=#13) then
{ is there also a #10 after it? }
begin
if (f.BufPtr^[f.BufPos]=#10) then
if (TextRec(f).BufPtr^[TextRec(f).BufPos]=#10) then
{ yes, skip that one as well }
inc(f.BufPos);
inc(TextRec(f).BufPos);
exit;
end;
until false;
End;
Function ReadPCharLen(var f:TextRec;s:pchar;maxlen:longint):longint;
Function ReadPCharLen(var f:Text;s:pchar;maxlen:longint):longint;
var
sPos,len : Longint;
p,startp,maxp : pchar;
@ -820,7 +823,7 @@ Begin
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -833,24 +836,24 @@ Begin
{ Read maximal until Maxlen is reached }
sPos:=0;
repeat
If f.BufPos>=f.BufEnd Then
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
break;
end;
p:=@f.Bufptr^[f.BufPos];
if SPos+f.BufEnd-f.BufPos>MaxLen then
maxp:=@f.BufPtr^[f.BufPos+MaxLen-SPos]
p:=@TextRec(f).Bufptr^[TextRec(f).BufPos];
if SPos+TextRec(f).BufEnd-TextRec(f).BufPos>MaxLen then
maxp:=@TextRec(f).BufPtr^[TextRec(f).BufPos+MaxLen-SPos]
else
maxp:=@f.Bufptr^[f.BufEnd];
maxp:=@TextRec(f).Bufptr^[TextRec(f).BufEnd];
startp:=p;
{ search linefeed }
while (p<maxp) and not(P^ in [#10,#13]) do
inc(p);
{ calculate read bytes }
len:=p-startp;
inc(f.BufPos,Len);
inc(TextRec(f).BufPos,Len);
Move(startp^,s[sPos],Len);
inc(sPos,Len);
{ was it a LF or CR? then leave }
@ -862,19 +865,19 @@ Begin
End;
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias:'FPC_READ_TEXT_SHORTSTR'];
Procedure fpc_Read_Text_ShortStr(var f : Text;var s : String); iocheck; [Public,Alias:'FPC_READ_TEXT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
s[0]:=chr(ReadPCharLen(f,pchar(@s[1]),high(s)));
End;
Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_POINTER'];
Procedure fpc_Read_Text_PChar_As_Pointer(var f : Text;var s : PChar); iocheck; [Public,Alias:'FPC_READ_TEXT_PCHAR_AS_POINTER']; {$ifdef hascompilerproc} compilerproc; {$endif}
Begin
pchar(s+ReadPCharLen(f,s,$7fffffff))^:=#0;
End;
Procedure Read_Array(var f : TextRec;var s : array of char);[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_ARRAY'];
Procedure fpc_Read_Text_PChar_As_Array(var f : Text;var s : array of char); iocheck; [Public,Alias:'FPC_READ_TEXT_PCHAR_AS_ARRAY']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
len: longint;
Begin
@ -884,7 +887,7 @@ Begin
End;
Procedure Read_AnsiString(var f : TextRec;var s : AnsiString);[Public,Alias:'FPC_READ_TEXT_ANSISTR'];
Procedure fpc_Read_Text_AnsiStr(var f : Text;var s : AnsiString); iocheck; [Public,Alias:'FPC_READ_TEXT_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
slen,len : longint;
Begin
@ -899,14 +902,21 @@ Begin
SetLength(S,Slen);
End;
Function Read_Char(var f : TextRec):char;[Public,Alias:'FPC_READ_TEXT_CHAR'];
{$ifdef hascompilerproc}
procedure fpc_Read_Text_Char(var f : Text; var c: char); iocheck; [Public,Alias:'FPC_READ_TEXT_CHAR'];compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_Char(var f : Text):char;[Public,Alias:'FPC_READ_TEXT_CHAR'];
{$endif hascompilerproc}
Begin
Read_Char:=#0;
{$ifdef hascompilerproc}
c:=#0;
{$else hascompilerproc}
fpc_Read_Text_Char:=#0;
{$endif hascompilerproc}
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -917,27 +927,46 @@ Begin
exit;
end;
{ Read next char or EOF }
If f.BufPos>=f.BufEnd Then
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
{$ifdef hascompilerproc}
begin
c := #26;
exit;
end;
{$else hascompilerproc}
exit(#26);
{$endif hascompilerproc}
end;
Read_Char:=f.Bufptr^[f.BufPos];
inc(f.BufPos);
{$ifdef hascompilerproc}
c:=TextRec(f).Bufptr^[TextRec(f).BufPos];
{$else hascompilerproc}
fpc_Read_Text_Char:=TextRec(f).Bufptr^[TextRec(f).BufPos];
{$endif hascompilerproc}
inc(TextRec(f).BufPos);
end;
Function Read_SInt(var f : TextRec):ValSInt;[Public,Alias:'FPC_READ_TEXT_SINT'];
{$ifdef hascompilerproc}
Procedure fpc_Read_Text_SInt(var f : Text; var l : ValSInt); iocheck; [Public,Alias:'FPC_READ_TEXT_SINT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_SInt(var f : Text):ValSInt;[Public,Alias:'FPC_READ_TEXT_SINT'];
{$endif hascompilerproc}
var
hs : String;
code : Longint;
Begin
Read_SInt:=0;
{$ifdef hascompilerproc}
l:=0;
{$else hascompilerproc}
fpc_Read_Text_SInt:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -947,27 +976,39 @@ Begin
end;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
hs:='';
if IgnoreSpaces(f) then
ReadNumeric(f,hs);
Val(hs,Read_SInt,code);
{$ifdef hascompilerproc}
Val(hs,l,code);
{$else hascompilerproc}
Val(hs,fpc_Read_Text_SInt,code);
{$endif hascompilerproc}
If code<>0 Then
InOutRes:=106;
End;
Function Read_UInt(var f : TextRec):ValUInt;[Public,Alias:'FPC_READ_TEXT_UINT'];
{$ifdef hascompilerproc}
Procedure fpc_Read_Text_UInt(var f : Text; var u : ValUInt); iocheck; [Public,Alias:'FPC_READ_TEXT_UINT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_UInt(var f : Text):ValUInt;[Public,Alias:'FPC_READ_TEXT_UINT'];
{$endif hascompilerproc}
var
hs : String;
code : longint;
Begin
Read_UInt:=0;
{$ifdef hascompilerproc}
u:=0;
{$else hascompilerproc}
fpc_Read_Text_UInt:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -977,27 +1018,39 @@ Begin
end;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
hs:='';
if IgnoreSpaces(f) then
ReadNumeric(f,hs);
val(hs,Read_UInt,code);
{$ifdef hascompilerproc}
val(hs,u,code);
{$else hascompilerproc}
val(hs,fpc_Read_Text_UInt,code);
{$endif hascompilerproc}
If code<>0 Then
InOutRes:=106;
End;
Function Read_Float(var f : TextRec):ValReal;[Public,Alias:'FPC_READ_TEXT_FLOAT'];
{$ifdef hascompilerproc}
procedure fpc_Read_Text_Float(var f : Text; var v : ValReal); iocheck; [Public,Alias:'FPC_READ_TEXT_FLOAT']; compilerproc;
{$else hascompilerproc}
Function fpc_Read_Text_Float(var f : Text):ValReal;[Public,Alias:'FPC_READ_TEXT_FLOAT'];
{$endif hascompilerproc}
var
hs : string;
code : Word;
begin
Read_Float:=0.0;
{$ifdef hascompilerproc}
v:=0.0;
{$else hascompilerproc}
fpc_Read_Text_Float:=0.0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -1007,27 +1060,39 @@ begin
end;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
hs:='';
if IgnoreSpaces(f) then
ReadNumeric(f,hs);
val(hs,Read_Float,code);
{$ifdef hascompilerproc}
val(hs,v,code);
{$else hascompilerproc}
val(hs,fpc_Read_Text_Float,code);
{$endif hascompilerproc}
If code<>0 Then
InOutRes:=106;
end;
function Read_QWord(var f : textrec) : qword;[public,alias:'FPC_READ_TEXT_QWORD'];
{$ifdef hascompilerproc}
procedure fpc_Read_Text_QWord(var f : text; var q : qword); iocheck; [public,alias:'FPC_READ_TEXT_QWORD']; compilerproc;
{$else hascompilerproc}
function fpc_Read_Text_QWord(var f : text) : qword;[public,alias:'FPC_READ_TEXT_QWORD'];
{$endif hascompilerproc}
var
hs : String;
code : longint;
Begin
Read_QWord:=0;
{$ifdef hascompilerproc}
q:=0;
{$else hascompilerproc}
fpc_Read_Text_QWord:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -1037,26 +1102,38 @@ Begin
end;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
hs:='';
if IgnoreSpaces(f) then
ReadNumeric(f,hs);
val(hs,Read_QWord,code);
{$ifdef hascompilerproc}
val(hs,q,code);
{$else hascompilerproc}
val(hs,fpc_Read_Text_QWord,code);
{$endif hascompilerproc}
If code<>0 Then
InOutRes:=106;
End;
function Read_Int64(var f : textrec) : int64;[public,alias:'FPC_READ_TEXT_INT64'];
{$ifdef hascompilerproc}
procedure fpc_Read_Text_Int64(var f : text; var i : int64); iocheck; [public,alias:'FPC_READ_TEXT_INT64']; compilerproc;
{$else hascompilerproc}
function fpc_Read_Text_Int64(var f : text) : int64;[public,alias:'FPC_READ_TEXT_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$endif hascompilerproc}
var
hs : String;
code : Longint;
Begin
Read_Int64:=0;
{$ifdef hascompilerproc}
i:=0;
{$else hascompilerproc}
fpc_Read_Text_Int64:=0;
{$endif hascompilerproc}
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
if (TextRec(f).mode<>fmInput) Then
begin
case TextRec(f).mode of
fmOutPut,fmAppend:
@ -1066,12 +1143,16 @@ Begin
end;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
hs:='';
if IgnoreSpaces(f) then
ReadNumeric(f,hs);
Val(hs,Read_Int64,code);
{$ifdef hascompilerproc}
Val(hs,i,code);
{$else hascompilerproc}
Val(hs,fpc_Read_Text_Int64,code);
{$endif hascompilerproc}
If code<>0 Then
InOutRes:=106;
End;
@ -1103,7 +1184,22 @@ end;
{
$Log$
Revision 1.13 2001-08-22 20:49:18 peter
Revision 1.14 2001-08-23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.13 2001/08/22 20:49:18 peter
* regenerated
Revision 1.12 2001/08/19 11:23:10 peter