From a3fbac27afef9de7b71c27d267a05168bc577bdc Mon Sep 17 00:00:00 2001 From: peter Date: Wed, 23 Sep 1998 09:58:48 +0000 Subject: [PATCH] * first working array of const things --- compiler/cg386ld.pas | 150 +++++++++++++++++++++++++- compiler/pass_1.pas | 248 ++++++++++++++++++++++++++++++++++++++++--- compiler/pass_2.pas | 7 +- compiler/pexpr.pas | 168 ++++++----------------------- compiler/tree.pas | 9 +- compiler/types.pas | 25 ++++- 6 files changed, 453 insertions(+), 154 deletions(-) diff --git a/compiler/cg386ld.pas b/compiler/cg386ld.pas index 4ab4d6e6dc..d95516e12e 100644 --- a/compiler/cg386ld.pas +++ b/compiler/cg386ld.pas @@ -40,6 +40,7 @@ interface procedure secondload(var p : ptree); procedure secondassignment(var p : ptree); procedure secondfuncret(var p : ptree); + procedure secondarrayconstruct(var p : ptree); implementation @@ -559,10 +560,157 @@ implementation end; +{***************************************************************************** + SecondArrayConstruct +*****************************************************************************} + + const + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + + procedure emit_mov_value_ref(const t:tlocation;const ref:treference); + begin + case t.loc of + LOC_REGISTER, + LOC_CREGISTER : begin + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + t.register,newreference(ref)))); + end; + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.isintvalue then + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, + t.reference.offset,newreference(ref)))) + else + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, + newreference(t.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,newreference(ref)))); + end; + end; + else + internalerror(330); + end; + end; + + + procedure emit_mov_addr_ref(const t:tlocation;const ref:treference); + begin + case t.loc of + LOC_MEM, + LOC_REFERENCE : begin + if t.reference.isintvalue then + internalerror(331) + else + begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, + newreference(t.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, + R_EDI,newreference(ref)))); + end; + end; + else + internalerror(332); + end; + end; + + + procedure secondarrayconstruct(var p : ptree); + var + hp : ptree; + href : treference; + hreg : tregister; + lt : pdef; + vtype : longint; + begin + clear_reference(p^.location.reference); + gettempofsizereference(parraydef(p^.resulttype)^.highrange*8,p^.location.reference); + hp:=p; + href:=p^.location.reference; + while assigned(hp) do + begin + secondpass(hp^.left); + if codegenerror then + exit; + { find the correct vtype value } + vtype:=$ff; + lt:=hp^.left^.resulttype; + case lt^.deftype of + enumdef, + orddef : begin + if (lt^.deftype=enumdef) or + is_integer(lt) then + vtype:=vtInteger + else + if is_boolean(lt) then + vtype:=vtBoolean + else + if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then + vtype:=vtChar; + emit_mov_value_ref(hp^.left^.location,href); + end; + pointerdef : begin + if is_pchar(lt) then + vtype:=vtPChar + else + vtype:=vtPointer; + emit_mov_value_ref(hp^.left^.location,href); + end; + classrefdef : begin + vtype:=vtClass; + emit_mov_value_ref(hp^.left^.location,href); + end; + stringdef : begin + if is_shortstring(lt) then + begin + vtype:=vtString; + emit_mov_addr_ref(hp^.left^.location,href); + end + else + if is_ansistring(lt) then + begin + vtype:=vtAnsiString; + emit_mov_value_ref(hp^.left^.location,href); + end; + end; + end; + if vtype=$ff then + internalerror(14357); + { update href to the vtype field and write it } + inc(href.offset,4); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, + vtype,newreference(href)))); + { update href to the next element } + inc(href.offset,4); + { load next entry } + hp:=hp^.right; + end; + end; + + end. { $Log$ - Revision 1.17 1998-09-20 18:00:19 florian + Revision 1.18 1998-09-23 09:58:48 peter + * first working array of const things + + Revision 1.17 1998/09/20 18:00:19 florian * small compiling problems fixed Revision 1.16 1998/09/20 17:46:48 florian diff --git a/compiler/pass_1.pas b/compiler/pass_1.pas index cc8b59ed48..03af15f0d3 100644 --- a/compiler/pass_1.pas +++ b/compiler/pass_1.pas @@ -56,7 +56,7 @@ unit pass_1; we don't count the ref } const count_ref : boolean = true; - + allow_array_constructor : boolean = false; { marks an lvalue as "unregable" } procedure make_not_regable(p : ptree); @@ -148,6 +148,218 @@ unit pass_1; function is_assignment_overloaded(from_def,to_def : pdef) : boolean;forward; + procedure arrayconstructor_to_set(var p:ptree); + var + constp, + buildp, + p2,p3,p4 : ptree; + pd : pdef; + constset : pconstset; + constsetlo, + constsethi : longint; + + procedure update_constsethi(p:pdef); + begin + if ((p^.deftype=orddef) and + (porddef(p)^.high>constsethi)) then + constsethi:=porddef(p)^.high + else + if ((p^.deftype=enumdef) and + (penumdef(p)^.max>constsethi)) then + constsethi:=penumdef(p)^.max; + end; + + procedure do_set(pos : longint); + var + mask,l : longint; + begin + if (pos>255) or (pos<0) then + Message(parser_e_illegal_set_expr); + if pos>constsethi then + constsethi:=pos; + if pos0 then + Message(parser_e_illegal_set_expr); + constset^[l]:=constset^[l] or mask; + end; + + var + l : longint; + begin + new(constset); + FillChar(constset^,sizeof(constset^),0); + pd:=nil; + constsetlo:=0; + constsethi:=0; + constp:=gensinglenode(setconstn,nil); + constp^.value_set:=constset; + buildp:=constp; + if assigned(p^.left) then + begin + while assigned(p) do + begin + p4:=nil; { will contain the tree to create the set } + { split a range into p2 and p3 } + if p^.left^.treetype=arrayconstructrangen then + begin + p2:=p^.left^.left; + p3:=p^.left^.right; + { node is not used anymore } + putnode(p^.left); + end + else + begin + p2:=p^.left; + p3:=nil; + end; + firstpass(p2); + if codegenerror then + break; + case p2^.resulttype^.deftype of + enumdef, + orddef : begin + if (p2^.resulttype^.deftype=orddef) and + (porddef(p2^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then + begin + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + end; + { set settype result } + if pd=nil then + pd:=p2^.resulttype; + if not(is_equal(pd,p2^.resulttype)) then + begin + Message(type_e_typeconflict_in_set); + disposetree(p2); + end + else + begin + if assigned(p3) then + begin + if (p3^.resulttype^.deftype=orddef) and + (porddef(p3^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then + begin + p3:=gentypeconvnode(p3,u8bitdef); + firstpass(p3); + end; + if not(is_equal(pd,p3^.resulttype)) then + Message(type_e_typeconflict_in_set) + else + begin + if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then + begin + for l:=p2^.value to p3^.value do + do_set(l); + disposetree(p3); + disposetree(p2); + end + else + begin + update_constsethi(p3^.resulttype); + p4:=gennode(setelementn,p2,p3); + end; + end; + end + else + begin + { Single value } + if p2^.treetype=ordconstn then + begin + do_set(p2^.value); + disposetree(p2); + end + else + begin + update_constsethi(p2^.resulttype); + p4:=gennode(setelementn,p2,nil); + end; + end; + end; + end; + stringdef : begin + if pd=nil then + pd:=cchardef; + if not(is_equal(pd,cchardef)) then + Message(type_e_typeconflict_in_set) + else + for l:=1 to length(pstring(p2^.value_str)^) do + do_set(ord(pstring(p2^.value_str)^[l])); + disposetree(p2); + end; + else + Internalerror(4234); + end; + { insert the set creation tree } + if assigned(p4) then + buildp:=gennode(addn,buildp,p4); + { load next and dispose current node } + p2:=p; + p:=p^.right; + putnode(p2); + end; + end + else + begin + { empty set [], only remove node } + putnode(p); + end; + { set the initial set type } + constp^.resulttype:=new(psetdef,init(pd,constsethi)); + { set the new tree } + p:=buildp; + end; + + + procedure firstarrayconstruct(var p : ptree); + var + pd : pdef; + hp : ptree; + len : longint; + begin + { are we allowing array constructor? Then convert it to a set } + if not allow_array_constructor then + begin + arrayconstructor_to_set(p); + firstpass(p); + exit; + end; + { only pass left tree, right tree contains next construct if any } + pd:=nil; + len:=0; + if assigned(p^.left) then + begin + hp:=p; + while assigned(hp) do + begin + firstpass(hp^.left); + if (pd=nil) then + pd:=hp^.left^.resulttype + else + Comment(V_Warning,'Variant type found !!'); + inc(len); + hp:=hp^.right; + end; + if len=0 then + Internalerror(4235); + end; + calcregisters(p,0,0,0); + p^.resulttype:=new(parraydef,init(0,len,pd)); + p^.location.loc:=LOC_REFERENCE; + end; + + + procedure firstarrayconstructrange(var p : ptree); + begin + { This is not allowed, it's only to support sets when parsing the [a..b] } + Internalerror(4236); + Codegenerror:=true; + end; + + function isconvertable(def_from,def_to : pdef; var doconv : tconverttype;fromtreetype : ttreetyp; explicit : boolean) : boolean; @@ -422,7 +634,7 @@ unit pass_1; { string constant to zero terminated string constant } if (fromtreetype=stringconstn) and - ((def_to^.deftype=pointerdef) and is_equal(Ppointerdef(def_to)^.definition,cchardef)) then + is_pchar(def_to) then begin doconv:=tc_cstring_charpointer; b:=true; @@ -1928,6 +2140,7 @@ unit pass_1; { assignements to open arrays aren't allowed } if is_open_array(p^.left^.resulttype) then CGMessage(type_e_mismatch); + { test if we can avoid copying string to temp as in s:=s+...; (PM) } {$ifdef dummyi386} @@ -2895,6 +3108,7 @@ unit pass_1; procedure firstcallparan(var p : ptree;defcoll : pdefcoll); var store_valid : boolean; + old_array_constructor : boolean; convtyp : tconverttype; begin inc(parsing_para_level); @@ -2912,21 +3126,17 @@ unit pass_1; end; if defcoll=nil then begin - { this breaks typeconversions in write !!! (PM) } - {if not(assigned(p^.resulttype)) then } + old_array_constructor:=allow_array_constructor; + allow_array_constructor:=true; if not(assigned(p^.resulttype)) or (p^.left^.treetype=typeconvn) then firstpass(p^.left); - {else - exit; this broke the - value of registers32 !! } - + allow_array_constructor:=old_array_constructor; if codegenerror then begin dec(parsing_para_level); exit; end; - p^.resulttype:=p^.left^.resulttype; end { if we know the routine which is called, then the type } @@ -2948,7 +3158,12 @@ unit pass_1; p^.left^.treetype,false) then if convtyp=tc_array_to_pointer then must_be_valid:=false; - firstpass(p^.left); + { only process typeconvn, else it will break other trees } + old_array_constructor:=allow_array_constructor; + allow_array_constructor:=true; +{ if (p^.left^.treetype=typeconvn) then } + firstpass(p^.left); + allow_array_constructor:=old_array_constructor; must_be_valid:=store_valid; end; if not(is_shortstring(p^.left^.resulttype) and @@ -4596,7 +4811,7 @@ unit pass_1; firstpass(p^.right); if codegenerror then - exit; + exit; if p^.right^.resulttype^.deftype<>setdef then CGMessage(sym_e_set_expected); @@ -5211,7 +5426,7 @@ unit pass_1; pobjectdef(p^.left^.resulttype)))) then CGMessage(type_e_mismatch); - p^.location:=p^.left^.location; + set_location(p^.location,p^.left^.location); p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.definition; end; @@ -5427,7 +5642,9 @@ unit pass_1; firstgoto,firstsimplenewdispose,firsttryexcept, firstraise,firstnothing,firsttryfinally, firstonn,firstis,firstas,firstadd, - firstnothing,firstadd,firstprocinline,firstnothing,firstloadvmt); + firstnothing,firstadd,firstprocinline, + firstarrayconstruct,firstarrayconstructrange, + firstnothing,firstloadvmt); var oldcodegenerror : boolean; @@ -5516,7 +5733,10 @@ unit pass_1; end. { $Log$ - Revision 1.89 1998-09-22 15:34:10 peter + Revision 1.90 1998-09-23 09:58:49 peter + * first working array of const things + + Revision 1.89 1998/09/22 15:34:10 peter + pchar -> string conversion Revision 1.88 1998/09/21 08:45:14 pierre diff --git a/compiler/pass_2.pas b/compiler/pass_2.pas index e3082a57d9..247f44ab9b 100644 --- a/compiler/pass_2.pas +++ b/compiler/pass_2.pas @@ -196,6 +196,8 @@ implementation secondfail, {failn} secondadd, {starstarn} secondprocinline, {procinlinen} + secondarrayconstruct, {arrayconstructn} + secondnothing, {arrayconstructrangen} secondnothing, {nothingn} secondloadvmt {loadvmtn} ); @@ -483,7 +485,10 @@ implementation end. { $Log$ - Revision 1.5 1998-09-21 10:01:06 peter + Revision 1.6 1998-09-23 09:58:52 peter + * first working array of const things + + Revision 1.5 1998/09/21 10:01:06 peter * check if procinfo.def is assigned before storing registersfpu Revision 1.4 1998/09/21 08:45:16 pierre diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index d1341f0a28..fae2042e3b 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -972,146 +972,42 @@ unit pexpr; { Read a set between [] } function factor_read_set:ptree; var - constp, - buildp, - p2,p3,p4 : ptree; - pd : pdef; - constset : pconstset; - constsetlo, - constsethi : longint; - - procedure update_constsethi(p:pdef); - begin - if ((p^.deftype=orddef) and - (porddef(p)^.high>constsethi)) then - constsethi:=porddef(p)^.high - else - if ((p^.deftype=enumdef) and - (penumdef(p)^.max>constsethi)) then - constsethi:=penumdef(p)^.max; - end; - - procedure do_set(pos : longint); - var - mask,l : longint; - begin - if (pos>255) or (pos<0) then - Message(parser_e_illegal_set_expr); - if pos>constsethi then - constsethi:=pos; - if pos0 then - Message(parser_e_illegal_set_expr); - constset^[l]:=constset^[l] or mask; - end; - - var - l : longint; + p1, + lastp, + buildp : ptree; begin - new(constset); - FillChar(constset^,sizeof(constset^),0); - constsetlo:=0; - constsethi:=0; - constp:=gensinglenode(setconstn,nil); - constp^.value_set:=constset; - buildp:=constp; - pd:=nil; - if token<>RECKKLAMMER then + buildp:=nil; + { be sure that a least one arrayconstructn is used, also for an + empty [] } + if token=RECKKLAMMER then + buildp:=gennode(arrayconstructn,nil,buildp) + else begin while true do begin - p4:=nil; { will contain the tree to create the set } - p2:=comp_expr(true); - do_firstpass(p2); + p1:=comp_expr(true); + do_firstpass(p1); if codegenerror then break; - case p2^.resulttype^.deftype of - enumdef, - orddef : begin - if (p2^.resulttype^.deftype=orddef) and - (porddef(p2^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then - begin - p2:=gentypeconvnode(p2,u8bitdef); - do_firstpass(p2); - end; - { set settype result } - if pd=nil then - pd:=p2^.resulttype; - if not(is_equal(pd,p2^.resulttype)) then - begin - Message(type_e_typeconflict_in_set); - disposetree(p2); - end - else - begin - if token=POINTPOINT then - begin - consume(POINTPOINT); - p3:=comp_expr(true); - do_firstpass(p3); - if codegenerror then - break; - if (p3^.resulttype^.deftype=orddef) and - (porddef(p3^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then - begin - p3:=gentypeconvnode(p3,u8bitdef); - do_firstpass(p3); - end; - if not(is_equal(pd,p3^.resulttype)) then - Message(type_e_typeconflict_in_set) - else - begin - if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then - begin - for l:=p2^.value to p3^.value do - do_set(l); - disposetree(p3); - disposetree(p2); - end - else - begin - update_constsethi(p3^.resulttype); - p4:=gennode(setelementn,p2,p3); - end; - end; - end - else - begin - { Single value } - if p2^.treetype=ordconstn then - begin - do_set(p2^.value); - disposetree(p2); - end - else - begin - update_constsethi(p2^.resulttype); - p4:=gennode(setelementn,p2,nil); - end; - end; - end; - end; - stringdef : begin - if pd=nil then - pd:=cchardef; - if not(is_equal(pd,cchardef)) then - Message(type_e_typeconflict_in_set) - else - for l:=1 to length(pstring(p2^.value_str)^) do - do_set(ord(pstring(p2^.value_str)^[l])); - disposetree(p2); - end; - else - Internalerror(4234); - end; - { insert the set creation tree } - if assigned(p4) then + if token=POINTPOINT then begin - buildp:=gennode(addn,buildp,p4); + consume(POINTPOINT); + p2:=comp_expr(true); + do_firstpass(p2); + if codegenerror then + break; + p1:=gennode(arrayconstructrangen,p1,p2); + end; + { insert at the end of the tree, to get the correct order } + if not assigned(buildp) then + begin + buildp:=gensinglenode(arrayconstructn,p1); + lastp:=buildp; + end + else + begin + lastp^.right:=gensinglenode(arrayconstructn,p1); + lastp:=lastp^.right; end; { there could be more elements } if token=COMMA then @@ -1120,7 +1016,6 @@ unit pexpr; break; end; end; - constp^.resulttype:=new(psetdef,init(pd,constsethi)); factor_read_set:=buildp; end; @@ -1856,7 +1751,10 @@ unit pexpr; end. { $Log$ - Revision 1.52 1998-09-20 09:38:45 florian + Revision 1.53 1998-09-23 09:58:54 peter + * first working array of const things + + Revision 1.52 1998/09/20 09:38:45 florian * hasharray for defs fixed * ansistring code generation corrected (init/final, assignement) diff --git a/compiler/tree.pas b/compiler/tree.pas index 4fa74157bd..60b831cf67 100644 --- a/compiler/tree.pas +++ b/compiler/tree.pas @@ -120,7 +120,9 @@ unit tree; caretn, {Represents the ^ operator.} failn, {Represents the fail statement.} starstarn, {Represents the ** operator exponentiation } - procinlinen, {Procedures that can be inlined } + procinlinen, {Procedures that can be inlined } + arrayconstructn, {Construction node for [...] parsing} + arrayconstructrangen, {Range element to allow sets in array construction tree} { added for optimizations where we cannot suppress } nothingn, loadvmtn); {???.} @@ -1567,7 +1569,10 @@ unit tree; end. { $Log$ - Revision 1.40 1998-09-22 15:34:07 peter + Revision 1.41 1998-09-23 09:58:55 peter + * first working array of const things + + Revision 1.40 1998/09/22 15:34:07 peter + pchar -> string conversion Revision 1.39 1998/09/21 08:45:27 pierre diff --git a/compiler/types.pas b/compiler/types.pas index f09a009684..df67a438f2 100644 --- a/compiler/types.pas +++ b/compiler/types.pas @@ -40,6 +40,9 @@ unit types; { returns true, if def defines an ordinal type } function is_integer(def : pdef) : boolean; + { true if p is a boolean } + function is_boolean(def : pdef) : boolean; + { true if p points to an open array def } function is_open_array(p : pdef) : boolean; @@ -55,6 +58,9 @@ unit types; { true if o is a short string def } function is_shortstring(p : pdef) : boolean; + { true if o is a pchar def } + function is_pchar(p : pdef) : boolean; + { returns true, if def defines a signed data type (only for ordinal types) } function is_signed(def : pdef) : boolean; @@ -204,6 +210,13 @@ unit types; end; + { true if p is a boolean } + function is_boolean(def : pdef) : boolean; + begin + is_boolean:=(def^.deftype=orddef) and + (porddef(def)^.typ in [bool8bit,bool16bit,bool32bit]); + end; + { true if p is signed (integer) } function is_signed(def : pdef) : boolean; var @@ -261,6 +274,13 @@ unit types; (pstringdef(p)^.string_typ=st_shortstring); end; + { true if p is a pchar def } + function is_pchar(p : pdef) : boolean; + begin + is_pchar:=(p^.deftype=pointerdef) and + is_equal(Ppointerdef(p)^.definition,cchardef); + end; + { true if the return value is in accumulator (EAX for i386), D0 for 68k } function ret_in_acc(def : pdef) : boolean; @@ -922,7 +942,10 @@ unit types; end. { $Log$ - Revision 1.30 1998-09-22 15:40:58 peter + Revision 1.31 1998-09-23 09:58:56 peter + * first working array of const things + + Revision 1.30 1998/09/22 15:40:58 peter * some extra ifdef GDB Revision 1.29 1998/09/16 12:37:31 michael