+ internal constant functions

compiler/innr.inc

@@ -3,6 +3,8 @@
     This file is part of the Free Pascal run time library and compiler.
     Copyright (c) 1993,98 by the Free Pascal development team
 
+    Internal Function/Constant Evaluator numbers
+
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
 
@@ -13,54 +15,67 @@
  **********************************************************************}
 
 const
-   in_lo_word = 1;
-   in_hi_word = 2;
-   in_lo_long = 3;
-   in_hi_long = 4;
-   in_ord_x = 5;
-   in_length_string = 6;
-   in_chr_byte = 7;
-{$ifdef VER0_99_5}   
-   in_inc_byte = 8;
-   in_inc_word = 9;
-   in_inc_dword = 10;
-   in_dec_byte = 11;
-   in_dec_word = 12;
-   in_dec_dword = 13;
-{$endif}   
-   in_write_x = 14;
-   in_writeln_x = 15;
-   in_read_x = 16;
-   in_readln_x = 17;
-   in_concat_x = 18;
-   in_assigned_x = 19;
-   in_str_x_string = 20;
-   in_ofs_x = 21;
-   in_sizeof_x = 22;
-   in_typeof_x = 23;
-   in_val_x = 24;
-   in_reset_x = 25;
-   in_rewrite_x = 26;
-   in_low_x = 27;
-   in_high_x = 28;
-   in_seg_x = 29;
-   in_pred_x = 30;
-   in_succ_x = 31;
-   in_reset_typedfile = 32;
+{ Internal functions }
+   in_lo_word           = 1;
+   in_hi_word           = 2;
+   in_lo_long           = 3;
+   in_hi_long           = 4;
+   in_ord_x             = 5;
+   in_length_string     = 6;
+   in_chr_byte          = 7;
+{$ifdef VER0_99_5}
+   in_inc_byte          = 8;
+   in_inc_word          = 9;
+   in_inc_dword         = 10;
+   in_dec_byte          = 11;
+   in_dec_word          = 12;
+   in_dec_dword         = 13;
+{$endif}
+   in_write_x           = 14;
+   in_writeln_x         = 15;
+   in_read_x            = 16;
+   in_readln_x          = 17;
+   in_concat_x          = 18;
+   in_assigned_x        = 19;
+   in_str_x_string      = 20;
+   in_ofs_x             = 21;
+   in_sizeof_x          = 22;
+   in_typeof_x          = 23;
+   in_val_x             = 24;
+   in_reset_x           = 25;
+   in_rewrite_x         = 26;
+   in_low_x             = 27;
+   in_high_x            = 28;
+   in_seg_x             = 29;
+   in_pred_x            = 30;
+   in_succ_x            = 31;
+   in_reset_typedfile   = 32;
    in_rewrite_typedfile = 33;
    in_settextbuf_file_x = 34;
-   in_inc_x = 35;
-   in_dec_x = 36;
-   in_include_x_y = 37;
-   in_exclude_x_y = 38;
-   in_break = 39;
-   in_continue = 40;
-   in_assert_x = 41;
+   in_inc_x             = 35;
+   in_dec_x             = 36;
+   in_include_x_y       = 37;
+   in_exclude_x_y       = 38;
+   in_break             = 39;
+   in_continue          = 40;
+   in_assert_x          = 41;
+
+{ Internal constant functions }
+   in_const_trunc      = 100;
+   in_const_round      = 101;
+   in_const_frac       = 102;
+   in_const_abs        = 103;
+   in_const_int        = 104;
+   in_const_sqr        = 105;
+   in_const_odd        = 106;
+   in_const_ptr        = 107;
+   in_const_swap_word  = 108;
+   in_const_swap_long  = 109;
 
 {
   $Log$
-  Revision 1.6  1998-08-20 12:59:56  peter
-    - removed obsolete in_*
+  Revision 1.7  1998-09-01 17:39:46  peter
+    + internal constant functions
 
 }
 

compiler/pass_1.pas

@@ -3025,7 +3025,8 @@ unit pass_1;
                         (porddef(def_from)^.high<porddef(def_to)^.high);
         end;
 
-
+      var
+        is_const : boolean;
       begin
          { release registers! }
          { if procdefinition<>nil then we called firstpass already }
@@ -3454,22 +3455,21 @@ unit pass_1;
 {$endif CHAINPROCSYMS}
                end;{ end of procedure to call determination }
 
+              is_const:=((p^.procdefinition^.options and pointernconst)<>0) and
+                         (p^.left^.left^.treetype in [realconstn,ordconstn]);
               { handle predefined procedures }
-              if (p^.procdefinition^.options and pointernproc)<>0 then
+              if ((p^.procdefinition^.options and pointernproc)<>0) or is_const then
                 begin
                    { settextbuf needs two args }
                    if assigned(p^.left^.right) then
-                     pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left)
+                     pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left)
                    else
                      begin
-                        pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left);
+                        pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left^.left);
                         putnode(p^.left);
                      end;
                    putnode(p);
                    firstpass(pt);
-                   { was placed after the exit          }
-                   { caused GPF                         }
-                   { error caused and corrected by (PM) }
                    p:=pt;
 
                    must_be_valid:=store_valid;
@@ -3694,6 +3694,10 @@ unit pass_1;
            end;
         end;
 
+      var
+        is_real : boolean;
+        vl      : longint;
+        vr      : bestreal;
       begin
          store_valid:=must_be_valid;
          store_count_ref:=count_ref;
@@ -3714,20 +3718,110 @@ unit pass_1;
               left_right_max(p);
               set_location(p^.location,p^.left^.location);
            end;
-           case p^.inlinenumber of
+         { handle intern constant functions in separate case }
+         if p^.inlineconst then
+          begin
+            is_real:=(p^.left^.treetype=realconstn);
+            vl:=p^.left^.value;
+            vr:=p^.left^.valued;
+            case p^.inlinenumber of
+         in_const_trunc : begin
+                            if is_real then
+                             hp:=genordinalconstnode(trunc(vr),s32bitdef)
+                            else
+                             hp:=genordinalconstnode(trunc(vl),s32bitdef);
+                          end;
+         in_const_round : begin
+                            if is_real then
+                             hp:=genordinalconstnode(round(vr),s32bitdef)
+                            else
+                             hp:=genordinalconstnode(round(vl),s32bitdef);
+                          end;
+          in_const_frac : begin
+                            if is_real then
+                             hp:=genrealconstnode(frac(vr))
+                            else
+                             hp:=genrealconstnode(frac(vl));
+                          end;
+           in_const_int : begin
+                            if is_real then
+                             hp:=genrealconstnode(int(vr))
+                            else
+                             hp:=genrealconstnode(int(vl));
+                          end;
+           in_const_abs : begin
+                            if is_real then
+                             hp:=genrealconstnode(abs(vr))
+                            else
+                             hp:=genordinalconstnode(abs(vl),p^.left^.resulttype);
+                          end;
+           in_const_sqr : begin
+                            if is_real then
+                             hp:=genrealconstnode(sqr(vr))
+                            else
+                             hp:=genordinalconstnode(sqr(vl),p^.left^.resulttype);
+                          end;
+           in_const_odd : begin
+                            if is_real then
+                             Message(sym_e_type_mismatch)
+                            else
+                             hp:=genordinalconstnode(byte(odd(vl)),booldef);
+                          end;
+     in_const_swap_word : begin
+                            if is_real then
+                             Message(sym_e_type_mismatch)
+                            else
+                             hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),p^.left^.resulttype);
+                          end;
+     in_const_swap_long : begin
+                            if is_real then
+                             Message(sym_e_type_mismatch)
+                            else
+                             hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),p^.left^.resulttype);
+                          end;
+           in_const_ptr : begin
+                            if is_real then
+                             Message(sym_e_type_mismatch)
+                            else
+                             hp:=genordinalconstnode(vl,voidpointerdef);
+                          end;
+            else
+              internalerror(88);
+            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;
-                  p^.resulttype:=u8bitdef;
-                  p^.location.loc:=LOC_REGISTER;
-               end;
-             in_lo_long,in_hi_long:
-               begin
-                  if p^.registers32<1 then
-                    p^.registers32:=1;
-                  p^.resulttype:=u16bitdef;
+                  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
+                    Message(sym_e_type_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
@@ -3837,7 +3931,6 @@ unit pass_1;
                        firstpass(hp);
                        p:=hp;
                     end;
-
                end;
              in_assigned_x:
                begin
@@ -3851,25 +3944,22 @@ unit pass_1;
                   p^.resulttype:=p^.left^.resulttype;
                   p^.location.loc:=LOC_REGISTER;
                   if not is_ordinal(p^.resulttype) then
-                     Message(sym_e_type_mismatch)
+                    Message(sym_e_type_mismatch)
                   else
                     begin
-                  if (p^.resulttype^.deftype=enumdef) and
-                     (penumdef(p^.resulttype)^.has_jumps) then
-                    begin
-                      Message(parser_e_succ_and_pred_enums_with_assign_not_possible);
-                    end
-                  else if p^.left^.treetype=ordconstn then
+                      if (p^.resulttype^.deftype=enumdef) and
+                         (penumdef(p^.resulttype)^.has_jumps) then
+                        Message(parser_e_succ_and_pred_enums_with_assign_not_possible)
+                      else
+                        if p^.left^.treetype=ordconstn then
                          begin
-                            if p^.inlinenumber=in_pred_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;
+                           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;
@@ -4194,7 +4284,8 @@ unit pass_1;
                     Message(parser_e_varid_or_typeid_expected);
                end
                  else internalerror(8);
-             end;
+              end;
+            end;
            must_be_valid:=store_valid;
            count_ref:=store_count_ref;
        end;
@@ -5274,7 +5365,10 @@ unit pass_1;
 end.
 {
   $Log$
-  Revision 1.68  1998-09-01 09:02:52  peter
+  Revision 1.69  1998-09-01 17:39:47  peter
+    + internal constant functions
+
+  Revision 1.68  1998/09/01 09:02:52  peter
     * moved message() to hcodegen, so pass_2 also uses them
 
   Revision 1.67  1998/09/01 07:54:20  pierre

compiler/pdecl.pas

@@ -109,6 +109,8 @@ unit pdecl;
                              symtablestack^.insert(new(pconstsym,init(name,constbool,p^.value,nil)))
                            else if p^.resulttype^.deftype=enumdef then
                              symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
+                           else if p^.resulttype^.deftype=pointerdef then
+                             symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
                            else internalerror(111);
                         end;
                       stringconstn:
@@ -1606,7 +1608,7 @@ unit pdecl;
                  else
                    Message(sym_e_error_in_type_def);
                  end
-               end      
+               end
 
              else
                begin
@@ -1961,7 +1963,10 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.45  1998-08-31 12:20:28  peter
+  Revision 1.46  1998-09-01 17:39:48  peter
+    + internal constant functions
+
+  Revision 1.45  1998/08/31 12:20:28  peter
     * fixed array_dec when unknown type was used
 
   Revision 1.44  1998/08/28 10:57:01  peter

compiler/pexpr.pas

@@ -124,7 +124,7 @@ unit pexpr;
                      p1:=comp_expr(true);
                      consume(RKLAMMER);
                      do_firstpass(p1);
-                     p1:=geninlinenode(in_ord_x,p1);
+                     p1:=geninlinenode(in_ord_x,false,p1);
                      do_firstpass(p1);
                      statement_syssym := p1;
                      pd:=p1^.resulttype;
@@ -152,7 +152,7 @@ unit pexpr;
                          end
                         else
                          if p1^.resulttype^.deftype=objectdef then
-                          statement_syssym:=geninlinenode(in_typeof_x,p1)
+                          statement_syssym:=geninlinenode(in_typeof_x,false,p1)
                         else
                          begin
                            Message(sym_e_type_mismatch);
@@ -170,7 +170,7 @@ unit pexpr;
                          end
                         else
                          if p1^.resulttype^.deftype=objectdef then
-                          statement_syssym:=geninlinenode(in_typeof_x,p1)
+                          statement_syssym:=geninlinenode(in_typeof_x,false,p1)
                         else
                          begin
                            Message(sym_e_type_mismatch);
@@ -196,7 +196,7 @@ unit pexpr;
                         do_firstpass(p1);
                         if (p1^.resulttype^.deftype=objectdef) or
                            is_open_array(p1^.resulttype) then
-                         statement_syssym:=geninlinenode(in_sizeof_x,p1)
+                         statement_syssym:=geninlinenode(in_sizeof_x,false,p1)
                         else
                          begin
                            statement_syssym:=genordinalconstnode(p1^.resulttype^.size,pd);
@@ -221,7 +221,7 @@ unit pexpr;
                        Message(parser_e_illegal_parameter_list);
                      end;
                      p2:=gencallparanode(p1,nil);
-                     p2:=geninlinenode(in_assigned_x,p2);
+                     p2:=geninlinenode(in_assigned_x,false,p2);
                      consume(RKLAMMER);
                      pd:=booldef;
                      statement_syssym:=p2;
@@ -259,7 +259,7 @@ unit pexpr;
                      p1:=comp_expr(true);
                      do_firstpass(p1);
                      Must_be_valid:=false;
-                     p2:=geninlinenode(l,p1);
+                     p2:=geninlinenode(l,false,p1);
                      consume(RKLAMMER);
                      pd:=s32bitdef;
                      statement_syssym:=p2;
@@ -271,7 +271,7 @@ unit pexpr;
                      p1:=comp_expr(true);
                      do_firstpass(p1);
                      Must_be_valid:=false;
-                     p2:=geninlinenode(l,p1);
+                     p2:=geninlinenode(l,false,p1);
                      consume(RKLAMMER);
                      pd:=p1^.resulttype;
                      statement_syssym:=p2;
@@ -290,7 +290,7 @@ unit pexpr;
                      else
                       p2:=nil;
                      p2:=gencallparanode(p1,p2);
-                     statement_syssym:=geninlinenode(l,p2);
+                     statement_syssym:=geninlinenode(l,false,p2);
                      consume(RKLAMMER);
                      pd:=voiddef;
                    end;
@@ -333,7 +333,7 @@ unit pexpr;
                      else
                       paras:=nil;
                      pd:=voiddef;
-                     p1:=geninlinenode(l,paras);
+                     p1:=geninlinenode(l,false,paras);
                      do_firstpass(p1);
                      statement_syssym := p1;
                    end;
@@ -350,7 +350,7 @@ unit pexpr;
                      else
                       paras:=nil;
                      pd:=voiddef;
-                     p1 := geninlinenode(l,paras);
+                     p1 := geninlinenode(l,false,paras);
                      do_firstpass(p1);
                      statement_syssym := p1;
                    end;
@@ -359,7 +359,7 @@ unit pexpr;
                      in_args:=true;
                      paras:=parse_paras(true,false);
                      consume(RKLAMMER);
-                     p1 := geninlinenode(l,paras);
+                     p1 := geninlinenode(l,false,paras);
                      do_firstpass(p1);
                      statement_syssym := p1;
                      pd:=voiddef;
@@ -373,8 +373,7 @@ unit pexpr;
                      consume(COMMA);
                      p2:=comp_expr(true);
                      { just a bit lisp feeling }
-                     statement_syssym:=geninlinenode(l,
-                       gencallparanode(p1,gencallparanode(p2,nil)));
+                     statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
                      consume(RKLAMMER);
                      pd:=voiddef;
                    end;
@@ -382,7 +381,7 @@ unit pexpr;
                      consume(LKLAMMER);
                      paras:=parse_paras(false);
                      consume(RKLAMMER);
-                     p1 := geninlinenode(l,paras);
+                     p1 := geninlinenode(l,false,paras);
                      do_firstpass(p1);
                      statement_syssym := p1;
                      pd:=voiddef;
@@ -1856,7 +1855,10 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.44  1998-08-28 10:54:24  peter
+  Revision 1.45  1998-09-01 17:39:49  peter
+    + internal constant functions
+
+  Revision 1.44  1998/08/28 10:54:24  peter
     * fixed smallset generation from elements, it has never worked before!
 
   Revision 1.43  1998/08/23 16:07:24  florian

compiler/tree.pas

@@ -223,7 +223,7 @@ unit tree;
              stringconstn : (values : pstring; labstrnumber : longint;stringtype : tstringtype);
 {$endif UseAnsiString}
              typeconvn : (convtyp : tconverttype;explizit : boolean);
-             inlinen : (inlinenumber : longint);
+             inlinen : (inlinenumber : longint;inlineconst:boolean);
              procinlinen : (inlineprocdef : pprocdef;
                             retoffset,para_offset,para_size : longint);
              setconstrn : (constset : pconstset);
@@ -258,7 +258,7 @@ unit tree;
 {$endif UseAnsiString}
 
     function genzeronode(t : ttreetyp) : ptree;
-    function geninlinenode(number : longint;l : ptree) : ptree;
+    function geninlinenode(number : longint;is_const:boolean;l : ptree) : ptree;
     function genprocinlinenode(callp,code : ptree) : ptree;
     function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
     function genenumnode(v : penumsym) : ptree;
@@ -1079,7 +1079,7 @@ unit tree;
          genselfnode:=p;
       end;
 
-   function geninlinenode(number : longint;l : ptree) : ptree;
+   function geninlinenode(number : longint;is_const:boolean;l : ptree) : ptree;
 
       var
          p : ptree;
@@ -1090,6 +1090,7 @@ unit tree;
          p^.treetype:=inlinen;
          p^.left:=l;
          p^.inlinenumber:=number;
+         p^.inlineconst:=is_const;
          p^.registers32:=0;
 {         p^.registers16:=0;
          p^.registers8:=0; }
@@ -1555,7 +1556,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.33  1998-08-28 12:51:44  florian
+  Revision 1.34  1998-09-01 17:39:54  peter
+    + internal constant functions
+
+  Revision 1.33  1998/08/28 12:51:44  florian
     + ansistring to pchar type cast fixed
 
   Revision 1.32  1998/08/28 10:54:25  peter

compiler/types.pas

@@ -34,6 +34,9 @@ unit types;
     { returns true, if def defines an ordinal type }
     function is_ordinal(def : pdef) : boolean;
 
+    { returns true, if def defines an ordinal type }
+    function is_integer(def : pdef) : boolean;
+
     { true if p points to an open array def }
     function is_open_array(p : pdef) : boolean;
 
@@ -173,6 +176,12 @@ unit types;
          end;
       end;
 
+    function is_integer(def : pdef) : boolean;
+      begin
+        is_integer:=(def^.deftype=orddef) and
+                    (porddef(def)^.typ in [u8bit,u16bit,u32bit,s8bit,s16bit,s32bit]);
+      end;
+
     function is_signed(def : pdef) : boolean;
       var
          dt : tbasetype;
@@ -878,7 +887,10 @@ unit types;
 end.
 {
   $Log$
-  Revision 1.22  1998-09-01 12:53:28  peter
+  Revision 1.23  1998-09-01 17:39:55  peter
+    + internal constant functions
+
+  Revision 1.22  1998/09/01 12:53:28  peter
     + aktpackenum
 
   Revision 1.21  1998/08/19 00:42:45  peter