12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007 |
- {
- $Id$
- Copyright (c) 1993-98 by Florian Klaempfl
- Type checking and register allocation for inline nodes
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit tcinl;
- interface
- uses
- tree;
- procedure firstinline(var p : ptree);
- implementation
- uses
- cobjects,verbose,globals,systems,
- symtable,aasm,types,
- hcodegen,htypechk,pass_1,
- tccal,tcld
- {$ifdef i386}
- ,i386,tgeni386
- {$endif}
- {$ifdef m68k}
- ,m68k,tgen68k
- {$endif}
- ;
- {*****************************************************************************
- FirstInLine
- *****************************************************************************}
- procedure firstinline(var p : ptree);
- var
- vl,vl2 : longint;
- vr : bestreal;
- hp,hpp : ptree;
- {$ifndef NOCOLONCHECK}
- frac_para,length_para : ptree;
- {$endif ndef NOCOLONCHECK}
- store_count_ref,
- isreal,
- dowrite,
- store_valid,
- file_is_typed : boolean;
- procedure do_lowhigh(adef : pdef);
- var
- v : longint;
- enum : penumsym;
- begin
- case Adef^.deftype of
- orddef:
- begin
- if p^.inlinenumber=in_low_x then
- v:=porddef(Adef)^.low
- else
- v:=porddef(Adef)^.high;
- hp:=genordinalconstnode(v,adef);
- firstpass(hp);
- disposetree(p);
- p:=hp;
- end;
- enumdef:
- begin
- enum:=Penumdef(Adef)^.first;
- if p^.inlinenumber=in_high_x then
- while enum^.next<>nil do
- enum:=enum^.next;
- hp:=genenumnode(enum);
- disposetree(p);
- p:=hp;
- end
- end;
- end;
- begin
- store_valid:=must_be_valid;
- store_count_ref:=count_ref;
- count_ref:=false;
- if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x,
- in_typeof_x,in_ord_x,in_str_x_string,
- in_reset_typedfile,in_rewrite_typedfile]) then
- must_be_valid:=true
- else
- must_be_valid:=false;
- { if we handle writeln; p^.left contains no valid address }
- if assigned(p^.left) then
- begin
- if p^.left^.treetype=callparan then
- firstcallparan(p^.left,nil)
- else
- firstpass(p^.left);
- left_right_max(p);
- set_location(p^.location,p^.left^.location);
- end;
- { handle intern constant functions in separate case }
- if p^.inlineconst then
- begin
- { no parameters? }
- if not assigned(p^.left) then
- begin
- case p^.inlinenumber of
- in_const_pi : begin
- hp:=genrealconstnode(pi);
- end;
- else
- internalerror(89);
- end;
- end
- else
- { process constant expression with parameter }
- begin
- vl:=0;
- vl2:=0; { second parameter Ex: ptr(vl,vl2) }
- vr:=0;
- isreal:=false;
- case p^.left^.treetype of
- realconstn :
- begin
- isreal:=true;
- vr:=p^.left^.value_real;
- end;
- ordconstn :
- vl:=p^.left^.value;
- callparan :
- begin
- { both exists, else it was not generated }
- vl:=p^.left^.left^.value;
- vl2:=p^.left^.right^.left^.value;
- end;
- else
- CGMessage(cg_e_illegal_expression);
- end;
- case p^.inlinenumber of
- in_const_trunc : begin
- if isreal then
- hp:=genordinalconstnode(trunc(vr),s32bitdef)
- else
- hp:=genordinalconstnode(trunc(vl),s32bitdef);
- end;
- in_const_round : begin
- if isreal then
- hp:=genordinalconstnode(round(vr),s32bitdef)
- else
- hp:=genordinalconstnode(round(vl),s32bitdef);
- end;
- in_const_frac : begin
- if isreal then
- hp:=genrealconstnode(frac(vr))
- else
- hp:=genrealconstnode(frac(vl));
- end;
- in_const_int : begin
- if isreal then
- hp:=genrealconstnode(int(vr))
- else
- hp:=genrealconstnode(int(vl));
- end;
- in_const_abs : begin
- if isreal then
- hp:=genrealconstnode(abs(vr))
- else
- hp:=genordinalconstnode(abs(vl),p^.left^.resulttype);
- end;
- in_const_sqr : begin
- if isreal then
- hp:=genrealconstnode(sqr(vr))
- else
- hp:=genordinalconstnode(sqr(vl),p^.left^.resulttype);
- end;
- in_const_odd : begin
- if isreal then
- CGMessage(type_e_integer_expr_expected)
- else
- hp:=genordinalconstnode(byte(odd(vl)),booldef);
- end;
- in_const_swap_word : begin
- if isreal then
- CGMessage(type_e_integer_expr_expected)
- else
- hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),p^.left^.resulttype);
- end;
- in_const_swap_long : begin
- if isreal then
- CGMessage(type_e_mismatch)
- else
- hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),p^.left^.resulttype);
- end;
- in_const_ptr : begin
- if isreal then
- CGMessage(type_e_mismatch)
- else
- hp:=genordinalconstnode((vl2 shl 16) or vl,voidpointerdef);
- end;
- in_const_sqrt : begin
- if isreal then
- hp:=genrealconstnode(sqrt(vr))
- else
- hp:=genrealconstnode(sqrt(vl));
- end;
- in_const_arctan : begin
- if isreal then
- hp:=genrealconstnode(arctan(vr))
- else
- hp:=genrealconstnode(arctan(vl));
- end;
- in_const_cos : begin
- if isreal then
- hp:=genrealconstnode(cos(vr))
- else
- hp:=genrealconstnode(cos(vl));
- end;
- in_const_sin : begin
- if isreal then
- hp:=genrealconstnode(sin(vr))
- else
- hp:=genrealconstnode(sin(vl));
- end;
- in_const_exp : begin
- if isreal then
- hp:=genrealconstnode(exp(vr))
- else
- hp:=genrealconstnode(exp(vl));
- end;
- in_const_ln : begin
- if isreal then
- hp:=genrealconstnode(ln(vr))
- else
- hp:=genrealconstnode(ln(vl));
- end;
- else
- internalerror(88);
- end;
- end;
- disposetree(p);
- firstpass(hp);
- p:=hp;
- end
- else
- begin
- case p^.inlinenumber of
- in_lo_long,in_hi_long,
- in_lo_word,in_hi_word:
- begin
- if p^.registers32<1 then
- p^.registers32:=1;
- if p^.inlinenumber in [in_lo_word,in_hi_word] then
- p^.resulttype:=u8bitdef
- else
- p^.resulttype:=u16bitdef;
- p^.location.loc:=LOC_REGISTER;
- if not is_integer(p^.left^.resulttype) then
- CGMessage(type_e_mismatch)
- else
- begin
- if p^.left^.treetype=ordconstn then
- begin
- case p^.inlinenumber of
- in_lo_word : hp:=genordinalconstnode(p^.left^.value and $ff,p^.left^.resulttype);
- in_hi_word : hp:=genordinalconstnode(p^.left^.value shr 8,p^.left^.resulttype);
- in_lo_long : hp:=genordinalconstnode(p^.left^.value and $ffff,p^.left^.resulttype);
- in_hi_long : hp:=genordinalconstnode(p^.left^.value shr 16,p^.left^.resulttype);
- end;
- disposetree(p);
- firstpass(hp);
- p:=hp;
- end;
- end;
- end;
- in_sizeof_x:
- begin
- {$ifndef OLDHIGH}
- if push_high_param(p^.left^.resulttype) then
- begin
- getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
- hp:=gennode(addn,genloadnode(pvarsym(srsym),p^.left^.symtable),
- genordinalconstnode(1,s32bitdef));
- if (p^.left^.resulttype^.deftype=arraydef) and
- (parraydef(p^.left^.resulttype)^.elesize<>1) then
- hp:=gennode(muln,hp,genordinalconstnode(parraydef(p^.left^.resulttype)^.elesize,s32bitdef));
- disposetree(p);
- p:=hp;
- firstpass(p);
- end;
- {$endif OLDHIGH}
- if p^.registers32<1 then
- p^.registers32:=1;
- p^.resulttype:=s32bitdef;
- p^.location.loc:=LOC_REGISTER;
- end;
- in_typeof_x:
- begin
- if p^.registers32<1 then
- p^.registers32:=1;
- p^.location.loc:=LOC_REGISTER;
- p^.resulttype:=voidpointerdef;
- end;
- in_ord_x:
- begin
- if (p^.left^.treetype=ordconstn) then
- begin
- hp:=genordinalconstnode(p^.left^.value,s32bitdef);
- disposetree(p);
- p:=hp;
- firstpass(p);
- end
- else
- begin
- if (p^.left^.resulttype^.deftype=orddef) then
- if (porddef(p^.left^.resulttype)^.typ in [uchar,bool8bit]) then
- begin
- if porddef(p^.left^.resulttype)^.typ=bool8bit then
- begin
- hp:=gentypeconvnode(p^.left,u8bitdef);
- putnode(p);
- p:=hp;
- p^.convtyp:=tc_bool_2_int;
- p^.explizit:=true;
- firstpass(p);
- end
- else
- begin
- hp:=gentypeconvnode(p^.left,u8bitdef);
- putnode(p);
- p:=hp;
- p^.explizit:=true;
- firstpass(p);
- end;
- end
- { can this happen ? }
- else if (porddef(p^.left^.resulttype)^.typ=uvoid) then
- CGMessage(type_e_mismatch)
- else
- { all other orddef need no transformation }
- begin
- hp:=p^.left;
- putnode(p);
- p:=hp;
- end
- else if (p^.left^.resulttype^.deftype=enumdef) then
- begin
- hp:=gentypeconvnode(p^.left,s32bitdef);
- putnode(p);
- p:=hp;
- p^.explizit:=true;
- firstpass(p);
- end
- else
- begin
- { can anything else be ord() ?}
- CGMessage(type_e_mismatch);
- end;
- end;
- end;
- in_chr_byte:
- begin
- hp:=gentypeconvnode(p^.left,cchardef);
- putnode(p);
- p:=hp;
- p^.explizit:=true;
- firstpass(p);
- end;
- in_length_string:
- begin
- if is_ansistring(p^.left^.resulttype) then
- p^.resulttype:=s32bitdef
- else
- p^.resulttype:=u8bitdef;
- { we don't need string conversations here }
- if (p^.left^.treetype=typeconvn) and
- (p^.left^.left^.resulttype^.deftype=stringdef) then
- begin
- hp:=p^.left^.left;
- putnode(p^.left);
- p^.left:=hp;
- end;
- { check the type, must be string or char }
- if (p^.left^.resulttype^.deftype<>stringdef) and
- (not is_char(p^.left^.resulttype)) then
- CGMessage(type_e_mismatch);
- { evaluates length of constant strings direct }
- if (p^.left^.treetype=stringconstn) then
- begin
- hp:=genordinalconstnode(p^.left^.length,s32bitdef);
- disposetree(p);
- firstpass(hp);
- p:=hp;
- end
- { length of char is one allways }
- else if is_constcharnode(p^.left) then
- begin
- hp:=genordinalconstnode(1,s32bitdef);
- disposetree(p);
- firstpass(hp);
- p:=hp;
- end;
- end;
- in_assigned_x:
- begin
- p^.resulttype:=booldef;
- p^.location.loc:=LOC_FLAGS;
- end;
- in_pred_x,
- in_succ_x:
- begin
- inc(p^.registers32);
- p^.resulttype:=p^.left^.resulttype;
- p^.location.loc:=LOC_REGISTER;
- if not is_ordinal(p^.resulttype) then
- CGMessage(type_e_ordinal_expr_expected)
- else
- begin
- if (p^.resulttype^.deftype=enumdef) and
- (penumdef(p^.resulttype)^.has_jumps) then
- CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible)
- else
- if p^.left^.treetype=ordconstn then
- begin
- if p^.inlinenumber=in_succ_x then
- hp:=genordinalconstnode(p^.left^.value+1,p^.left^.resulttype)
- else
- hp:=genordinalconstnode(p^.left^.value-1,p^.left^.resulttype);
- disposetree(p);
- firstpass(hp);
- p:=hp;
- end;
- end;
- end;
- in_inc_x,
- in_dec_x:
- begin
- p^.resulttype:=voiddef;
- if assigned(p^.left) then
- begin
- firstcallparan(p^.left,nil);
- if codegenerror then
- exit;
- { first param must be var }
- if is_constnode(p^.left^.left) then
- CGMessage(type_e_variable_id_expected);
- { check type }
- if (p^.left^.resulttype^.deftype in [enumdef,pointerdef]) or
- is_ordinal(p^.left^.resulttype) then
- begin
- { two paras ? }
- if assigned(p^.left^.right) then
- begin
- { insert a type conversion }
- { the second param is always longint }
- p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,s32bitdef);
- { check the type conversion }
- firstpass(p^.left^.right^.left);
- { need we an additional register ? }
- if not(is_constintnode(p^.left^.right^.left)) and
- (p^.left^.right^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
- (p^.left^.right^.left^.registers32<1) then
- inc(p^.registers32);
- if assigned(p^.left^.right^.right) then
- CGMessage(cg_e_illegal_expression);
- end;
- end
- else
- CGMessage(type_e_ordinal_expr_expected);
- end
- else
- CGMessage(type_e_mismatch);
- end;
- in_read_x,
- in_readln_x,
- in_write_x,
- in_writeln_x :
- begin
- { needs a call }
- procinfo.flags:=procinfo.flags or pi_do_call;
- p^.resulttype:=voiddef;
- { we must know if it is a typed file or not }
- { but we must first do the firstpass for it }
- file_is_typed:=false;
- if assigned(p^.left) then
- begin
- firstcallparan(p^.left,nil);
- { now we can check }
- hp:=p^.left;
- while assigned(hp^.right) do
- hp:=hp^.right;
- { if resulttype is not assigned, then automatically }
- { file is not typed. }
- if assigned(hp) and assigned(hp^.resulttype) then
- Begin
- if (hp^.resulttype^.deftype=filedef) and
- (pfiledef(hp^.resulttype)^.filetype=ft_typed) then
- begin
- file_is_typed:=true;
- { test the type }
- hpp:=p^.left;
- while (hpp<>hp) do
- begin
- if (hpp^.left^.treetype=typen) then
- CGMessage(type_e_cant_read_write_type);
- if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as) then
- CGMessage(type_e_mismatch);
- hpp:=hpp^.right;
- end;
- end;
- end; { endif assigned(hp) }
- { insert type conversions for write(ln) }
- if (not file_is_typed) then
- begin
- dowrite:=(p^.inlinenumber in [in_write_x,in_writeln_x]);
- hp:=p^.left;
- while assigned(hp) do
- begin
- if (hp^.left^.treetype=typen) then
- CGMessage(type_e_cant_read_write_type);
- if assigned(hp^.left^.resulttype) then
- begin
- isreal:=false;
- case hp^.left^.resulttype^.deftype of
- filedef : begin
- { only allowed as first parameter }
- if assigned(hp^.right) then
- CGMessage(type_e_cant_read_write_type);
- end;
- stringdef : begin
- { generate the high() value for the shortstring }
- if (not dowrite) and
- is_shortstring(hp^.left^.resulttype) then
- gen_high_tree(hp,true);
- end;
- pointerdef : begin
- if not is_equal(ppointerdef(hp^.left^.resulttype)^.definition,cchardef) then
- CGMessage(type_e_cant_read_write_type);
- end;
- floatdef : begin
- isreal:=true;
- end;
- orddef : begin
- case porddef(hp^.left^.resulttype)^.typ of
- uchar,
- u32bit,
- s32bit,
- s64bitint,
- u64bit:
- ;
- u8bit,s8bit,
- u16bit,s16bit : if dowrite then
- hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
- bool8bit,
- bool16bit,bool32bit : if dowrite then
- hp^.left:=gentypeconvnode(hp^.left,booldef)
- else
- CGMessage(type_e_cant_read_write_type);
- else
- CGMessage(type_e_cant_read_write_type);
- end;
- end;
- arraydef : begin
- if not((parraydef(hp^.left^.resulttype)^.lowrange=0) and
- is_equal(parraydef(hp^.left^.resulttype)^.definition,cchardef)) then
- begin
- { but we convert only if the first index<>0,
- because in this case we have a ASCIIZ string }
- if dowrite and
- (parraydef(hp^.left^.resulttype)^.lowrange<>0) and
- (parraydef(hp^.left^.resulttype)^.definition^.deftype=orddef) and
- (porddef(parraydef(hp^.left^.resulttype)^.definition)^.typ=uchar) then
- hp^.left:=gentypeconvnode(hp^.left,cshortstringdef)
- else
- CGMessage(type_e_cant_read_write_type);
- end;
- end;
- else
- CGMessage(type_e_cant_read_write_type);
- end;
- { some format options ? }
- {$ifndef NOCOLONCHECK}
- { commented
- because supposes reverse order of parameters
- PM : now restored PM }
- if hp^.is_colon_para then
- begin
- if hp^.right^.is_colon_para then
- begin
- frac_para:=hp;
- length_para:=hp^.right;
- hp:=hp^.right;
- hpp:=hp^.right;
- end
- else
- begin
- length_para:=hp;
- frac_para:=nil;
- hpp:=hp^.right;
- end;
- isreal:=hpp^.resulttype^.deftype=floatdef;
- if (not is_integer(length_para^.resulttype)) then
- CGMessage(type_e_integer_expr_expected)
- else
- length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef);
- if assigned(frac_para) then
- begin
- if isreal then
- begin
- if (not is_integer(frac_para^.resulttype)) then
- CGMessage(type_e_integer_expr_expected)
- else
- frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef);
- end
- else
- CGMessage(parser_e_illegal_colon_qualifier);
- end;
- { do the checking for the colon'd arg }
- hp:=length_para;
- end;
- {$endif ndef NOCOLONCHECK}
- end;
- hp:=hp^.right;
- end;
- end;
- { pass all parameters again for the typeconversions }
- if codegenerror then
- exit;
- must_be_valid:=true;
- firstcallparan(p^.left,nil);
- { calc registers }
- left_right_max(p);
- end;
- end;
- in_settextbuf_file_x :
- begin
- { warning here p^.left is the callparannode
- not the argument directly }
- { p^.left^.left is text var }
- { p^.left^.right^.left is the buffer var }
- { firstcallparan(p^.left,nil);
- already done in firstcalln }
- { now we know the type of buffer }
- getsymonlyin(systemunit,'SETTEXTBUF');
- hp:=gencallnode(pprocsym(srsym),systemunit);
- hp^.left:=gencallparanode(
- genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
- putnode(p);
- p:=hp;
- firstpass(p);
- end;
- { the firstpass of the arg has been done in firstcalln ? }
- in_reset_typedfile,in_rewrite_typedfile :
- begin
- procinfo.flags:=procinfo.flags or pi_do_call;
- { to be sure the right definition is loaded }
- p^.left^.resulttype:=nil;
- firstload(p^.left);
- p^.resulttype:=voiddef;
- end;
- in_str_x_string :
- begin
- procinfo.flags:=procinfo.flags or pi_do_call;
- p^.resulttype:=voiddef;
- { check the amount of parameters }
- if not(assigned(p^.left)) or
- not(assigned(p^.left^.right)) then
- begin
- CGMessage(parser_e_wrong_parameter_size);
- exit;
- end;
- { first pass just the string for first local use }
- hp:=p^.left^.right;
- must_be_valid:=false;
- count_ref:=true;
- p^.left^.right:=nil;
- firstcallparan(p^.left,nil);
- must_be_valid:=true;
- p^.left^.right:=hp;
- firstcallparan(p^.left^.right,nil);
- hp:=p^.left;
- { valid string ? }
- if not assigned(hp) or
- (hp^.left^.resulttype^.deftype<>stringdef) or
- (hp^.right=nil) or
- (hp^.left^.location.loc<>LOC_REFERENCE) then
- CGMessage(cg_e_illegal_expression);
- { generate the high() value for the shortstring }
- if is_shortstring(hp^.left^.resulttype) then
- gen_high_tree(hp,true);
- { !!!! check length of string }
- while assigned(hp^.right) do
- hp:=hp^.right;
- { check and convert the first param }
- if hp^.is_colon_para then
- CGMessage(cg_e_illegal_expression);
- isreal:=false;
- case hp^.resulttype^.deftype of
- orddef : begin
- case porddef(hp^.left^.resulttype)^.typ of
- u32bit,
- s32bit,
- s64bitint,
- u64bit:
- ;
- u8bit,s8bit,
- u16bit,s16bit:
- hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
- else
- CGMessage(type_e_integer_or_real_expr_expected);
- end;
- end;
- floatdef : begin
- isreal:=true;
- end;
- else
- CGMessage(type_e_integer_or_real_expr_expected);
- end;
- { some format options ? }
- hpp:=p^.left^.right;
- if assigned(hpp) and hpp^.is_colon_para then
- begin
- if (not is_integer(hpp^.resulttype)) then
- CGMessage(type_e_integer_expr_expected)
- else
- hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
- hpp:=hpp^.right;
- if assigned(hpp) and hpp^.is_colon_para then
- begin
- if isreal then
- begin
- if (not is_integer(hpp^.resulttype)) then
- CGMessage(type_e_integer_expr_expected)
- else
- hpp^.left:=gentypeconvnode(hpp^.left,s32bitdef);
- end
- else
- CGMessage(parser_e_illegal_colon_qualifier);
- end;
- end;
- { for first local use }
- must_be_valid:=false;
- count_ref:=true;
- { pass all parameters again for the typeconversions }
- if codegenerror then
- exit;
- must_be_valid:=true;
- firstcallparan(p^.left,nil);
- { calc registers }
- left_right_max(p);
- end;
- in_include_x_y,
- in_exclude_x_y:
- begin
- p^.resulttype:=voiddef;
- if assigned(p^.left) then
- begin
- firstcallparan(p^.left,nil);
- p^.registers32:=p^.left^.registers32;
- p^.registersfpu:=p^.left^.registersfpu;
- {$ifdef SUPPORT_MMX}
- p^.registersmmx:=p^.left^.registersmmx;
- {$endif SUPPORT_MMX}
- { first param must be var }
- if (p^.left^.left^.location.loc<>LOC_REFERENCE) and
- (p^.left^.left^.location.loc<>LOC_CREGISTER) then
- CGMessage(cg_e_illegal_expression);
- { check type }
- if (p^.left^.resulttype^.deftype=setdef) then
- begin
- { two paras ? }
- if assigned(p^.left^.right) then
- begin
- { insert a type conversion }
- { to the type of the set elements }
- p^.left^.right^.left:=gentypeconvnode(
- p^.left^.right^.left,
- psetdef(p^.left^.resulttype)^.setof);
- { check the type conversion }
- firstpass(p^.left^.right^.left);
- { only three parameters are allowed }
- if assigned(p^.left^.right^.right) then
- CGMessage(cg_e_illegal_expression);
- end;
- end
- else
- CGMessage(type_e_mismatch);
- end
- else
- CGMessage(type_e_mismatch);
- end;
- in_low_x,in_high_x:
- begin
- if p^.left^.treetype in [typen,loadn,subscriptn] then
- begin
- case p^.left^.resulttype^.deftype of
- orddef,enumdef:
- begin
- do_lowhigh(p^.left^.resulttype);
- firstpass(p);
- end;
- setdef:
- begin
- do_lowhigh(Psetdef(p^.left^.resulttype)^.setof);
- firstpass(p);
- end;
- arraydef:
- begin
- if p^.inlinenumber=in_low_x then
- begin
- hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef);
- disposetree(p);
- p:=hp;
- firstpass(p);
- end
- else
- begin
- if is_open_array(p^.left^.resulttype) then
- begin
- {$ifndef OLDHIGH}
- getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
- hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
- disposetree(p);
- p:=hp;
- firstpass(p);
- {$else OLDHIGH}
- p^.resulttype:=s32bitdef;
- p^.registers32:=max(1,p^.registers32);
- p^.location.loc:=LOC_REGISTER;
- {$endif OLDHIGH}
- end
- else
- begin
- hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,s32bitdef);
- disposetree(p);
- p:=hp;
- firstpass(p);
- end;
- end;
- end;
- stringdef:
- begin
- if p^.inlinenumber=in_low_x then
- begin
- hp:=genordinalconstnode(0,u8bitdef);
- disposetree(p);
- p:=hp;
- firstpass(p);
- end
- else
- begin
- if is_open_string(p^.left^.resulttype) then
- begin
- {$ifndef OLDHIGH}
- getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
- hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
- disposetree(p);
- p:=hp;
- firstpass(p);
- {$else OLDHIGH}
- p^.resulttype:=s32bitdef;
- p^.registers32:=max(1,p^.registers32);
- p^.location.loc:=LOC_REGISTER;
- {$endif OLDHIGH}
- end
- else
- begin
- hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
- disposetree(p);
- p:=hp;
- firstpass(p);
- end;
- end;
- end;
- else
- CGMessage(type_e_mismatch);
- end;
- end
- else
- CGMessage(type_e_varid_or_typeid_expected);
- end;
- in_assert_x_y :
- begin
- p^.resulttype:=voiddef;
- if assigned(p^.left) then
- begin
- firstcallparan(p^.left,nil);
- p^.registers32:=p^.left^.registers32;
- p^.registersfpu:=p^.left^.registersfpu;
- {$ifdef SUPPORT_MMX}
- p^.registersmmx:=p^.left^.registersmmx;
- {$endif SUPPORT_MMX}
- { check type }
- if is_boolean(p^.left^.resulttype) then
- begin
- { must always be a string }
- p^.left^.right^.left:=gentypeconvnode(p^.left^.right^.left,cshortstringdef);
- firstpass(p^.left^.right^.left);
- end
- else
- CGMessage(type_e_mismatch);
- end
- else
- CGMessage(type_e_mismatch);
- end;
- else
- internalerror(8);
- end;
- end;
- { generate an error if no resulttype is set }
- if not assigned(p^.resulttype) then
- p^.resulttype:=generrordef;
- must_be_valid:=store_valid;
- count_ref:=store_count_ref;
- end;
- end.
- {
- $Log$
- Revision 1.16 1999-01-28 19:43:43 peter
- * fixed high generation for ansistrings with str,writeln
- Revision 1.15 1999/01/27 16:28:22 pierre
- * bug0157 solved : write(x:5.3) is rejected now
- Revision 1.14 1999/01/21 22:10:50 peter
- * fixed array of const
- * generic platform independent high() support
- Revision 1.13 1998/12/30 22:13:13 peter
- * check the amount of paras for Str()
- Revision 1.12 1998/12/15 10:23:31 peter
- + -iSO, -iSP, -iTO, -iTP
- Revision 1.11 1998/12/11 23:36:08 florian
- + again more stuff for int64/qword:
- - comparision operators
- - code generation for: str, read(ln), write(ln)
- Revision 1.10 1998/11/27 14:50:53 peter
- + open strings, $P switch support
- Revision 1.9 1998/11/24 17:04:28 peter
- * fixed length(char) when char is a variable
- Revision 1.8 1998/11/14 10:51:33 peter
- * fixed low/high for record.field
- Revision 1.7 1998/11/13 10:15:52 peter
- * fixed ptr() with constants
- Revision 1.6 1998/11/05 12:03:05 peter
- * released useansistring
- * removed -Sv, its now available in fpc modes
- Revision 1.5 1998/10/20 11:16:47 pierre
- + length(c) where C is a char is allways 1
- Revision 1.4 1998/10/06 20:49:11 peter
- * m68k compiler compiles again
- Revision 1.3 1998/10/05 12:32:49 peter
- + assert() support
- Revision 1.2 1998/10/02 09:24:23 peter
- * more constant expression evaluators
- Revision 1.1 1998/09/23 20:42:24 peter
- * splitted pass_1
- }
|