瀏覽代碼

+ constant pointer support which can happend with typecasting like
const p=pointer(1)
* better procvar parsing in typed consts

peter 26 年之前
父節點
當前提交
2687d75c38

+ 16 - 2
compiler/cg386cnv.pas

@@ -895,6 +895,14 @@ implementation
       end;
       end;
 
 
 
 
+    procedure second_cord_to_pointer(pto,pfrom : ptree;convtyp : tconverttype);
+      begin
+        { this can't happend, because constants are already processed in
+          pass 1 }
+        internalerror(47423985);
+      end;
+
+
     procedure second_int_to_fix(pto,pfrom : ptree;convtyp : tconverttype);
     procedure second_int_to_fix(pto,pfrom : ptree;convtyp : tconverttype);
       var
       var
          hregister : tregister;
          hregister : tregister;
@@ -1288,7 +1296,8 @@ implementation
            second_fix_to_real,
            second_fix_to_real,
            second_proc_to_procvar,
            second_proc_to_procvar,
            second_nothing, {arrayconstructor_to_set}
            second_nothing, {arrayconstructor_to_set}
-           second_load_smallset
+           second_load_smallset,
+           second_cord_to_pointer
          );
          );
 {$ifdef TESTOBJEXT2}
 {$ifdef TESTOBJEXT2}
       var
       var
@@ -1455,7 +1464,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.88  1999-09-26 13:26:04  florian
+  Revision 1.89  1999-09-26 21:30:15  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.88  1999/09/26 13:26:04  florian
     * exception patch of Romio nevertheless the excpetion handling
     * exception patch of Romio nevertheless the excpetion handling
       needs some corections regarding register saving
       needs some corections regarding register saving
     * gettempansistring is again a procedure
     * gettempansistring is again a procedure

+ 20 - 1
compiler/cg386con.pas

@@ -29,6 +29,7 @@ interface
     procedure secondrealconst(var p : ptree);
     procedure secondrealconst(var p : ptree);
     procedure secondfixconst(var p : ptree);
     procedure secondfixconst(var p : ptree);
     procedure secondordconst(var p : ptree);
     procedure secondordconst(var p : ptree);
+    procedure secondpointerconst(var p : ptree);
     procedure secondstringconst(var p : ptree);
     procedure secondstringconst(var p : ptree);
     procedure secondsetconst(var p : ptree);
     procedure secondsetconst(var p : ptree);
     procedure secondniln(var p : ptree);
     procedure secondniln(var p : ptree);
@@ -159,6 +160,19 @@ implementation
       end;
       end;
 
 
 
 
+{*****************************************************************************
+                             SecondPointerConst
+*****************************************************************************}
+
+    procedure secondpointerconst(var p : ptree);
+      begin
+         { an integer const. behaves as a memory reference }
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.is_immediate:=true;
+         p^.location.reference.offset:=p^.value;
+      end;
+
+
 {*****************************************************************************
 {*****************************************************************************
                              SecondStringConst
                              SecondStringConst
 *****************************************************************************}
 *****************************************************************************}
@@ -417,7 +431,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.41  1999-09-20 16:38:52  peter
+  Revision 1.42  1999-09-26 21:30:15  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.41  1999/09/20 16:38:52  peter
     * cs_create_smart instead of cs_smartlink
     * cs_create_smart instead of cs_smartlink
     * -CX is create smartlink
     * -CX is create smartlink
     * -CD is create dynamic, but does nothing atm.
     * -CD is create dynamic, but does nothing atm.

+ 19 - 5
compiler/htypechk.pas

@@ -313,11 +313,20 @@ implementation
                  orddef :
                  orddef :
                    begin
                    begin
                      { char constant to zero terminated string constant }
                      { char constant to zero terminated string constant }
-                     if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and
-                        is_pchar(def_to) then
+                     if (fromtreetype=ordconstn) then
                       begin
                       begin
-                        doconv:=tc_cchar_2_pchar;
-                        b:=1;
+                        if is_equal(def_from,cchardef) and
+                           is_pchar(def_to) then
+                         begin
+                           doconv:=tc_cchar_2_pchar;
+                           b:=1;
+                         end
+                        else
+                         if is_integer(def_from) then
+                          begin
+                            doconv:=tc_cord_2_pointer;
+                            b:=1;
+                          end;
                       end;
                       end;
                    end;
                    end;
                  arraydef :
                  arraydef :
@@ -705,7 +714,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.39  1999-09-17 17:14:04  peter
+  Revision 1.40  1999-09-26 21:30:15  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.39  1999/09/17 17:14:04  peter
     * @procvar fixes for tp mode
     * @procvar fixes for tp mode
     * @<id>:= gives now an error
     * @<id>:= gives now an error
 
 

+ 7 - 1
compiler/pass_1.pas

@@ -231,6 +231,7 @@ implementation
              firstumminus,     {umminusn}
              firstumminus,     {umminusn}
              firstasm,   {asmn}
              firstasm,   {asmn}
              firstvec,   {vecn}
              firstvec,   {vecn}
+             firstpointerconst, {pointerconstn}
              firststringconst, {stringconstn}
              firststringconst, {stringconstn}
              firstfuncret,     {funcretn}
              firstfuncret,     {funcretn}
              firstself, {selfn}
              firstself, {selfn}
@@ -368,7 +369,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.104  1999-09-11 09:08:31  florian
+  Revision 1.105  1999-09-26 21:30:16  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.104  1999/09/11 09:08:31  florian
     * fixed bug 596
     * fixed bug 596
     * fixed some problems with procedure variables and procedures of object,
     * fixed some problems with procedure variables and procedures of object,
       especially in TP mode. Procedure of object doesn't apply only to classes,
       especially in TP mode. Procedure of object doesn't apply only to classes,

+ 7 - 1
compiler/pass_2.pas

@@ -214,6 +214,7 @@ implementation
              secondumminus,     {umminusn}
              secondumminus,     {umminusn}
              secondasm,  {asmn}
              secondasm,  {asmn}
              secondvecn,        {vecn}
              secondvecn,        {vecn}
+             secondpointerconst, {pointerconstn}
              secondstringconst, {stringconstn}
              secondstringconst, {stringconstn}
              secondfuncret,     {funcretn}
              secondfuncret,     {funcretn}
              secondselfn,       {selfn}
              secondselfn,       {selfn}
@@ -696,7 +697,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.38  1999-09-16 23:05:54  florian
+  Revision 1.39  1999-09-26 21:30:17  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.38  1999/09/16 23:05:54  florian
     * m68k compiler is again compilable (only gas writer, no assembler reader)
     * m68k compiler is again compilable (only gas writer, no assembler reader)
 
 
   Revision 1.37  1999/09/15 20:35:41  florian
   Revision 1.37  1999/09/15 20:35:41  florian

+ 10 - 1
compiler/pdecl.pas

@@ -169,6 +169,10 @@ unit pdecl;
                           ps^:=p^.value_set^;
                           ps^:=p^.value_set^;
                           symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype)));
                           symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype)));
                         end;
                         end;
+                      pointerconstn :
+                        begin
+                          symtablestack^.insert(new(pconstsym,init_def(name,constpointer,p^.value,p^.resulttype)))
+                        end;
                       niln :
                       niln :
                         begin
                         begin
                           symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype)));
                           symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype)));
@@ -2536,7 +2540,12 @@ unit pdecl;
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.155  1999-09-20 16:38:59  peter
+  Revision 1.156  1999-09-26 21:30:19  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.155  1999/09/20 16:38:59  peter
     * cs_create_smart instead of cs_smartlink
     * cs_create_smart instead of cs_smartlink
     * -CX is create smartlink
     * -CX is create smartlink
     * -CD is create dynamic, but does nothing atm.
     * -CD is create dynamic, but does nothing atm.

+ 45 - 34
compiler/pexpr.pas

@@ -576,25 +576,37 @@ unit pexpr;
          afterassignment:=prevafterassn;
          afterassignment:=prevafterassn;
       end;
       end;
 
 
-    procedure handle_procvar(procvar : pprocvardef;var t : ptree);
-      var
-        hp : ptree;
+    procedure handle_procvar(pv : pprocvardef;var p2 : ptree);
+
+        procedure doconv(procvar : pprocvardef;var t : ptree);
+        var
+          hp : ptree;
+        begin
+          hp:=nil;
+          if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
+           begin
+             if (po_methodpointer in procvar^.procoptions) then
+               hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
+             else
+               hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
+           end;
+          if assigned(hp) then
+           begin
+             disposetree(t);
+             t:=hp;
+           end;
+        end;
+
       begin
       begin
-        hp:=nil;
-        if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
-         begin
-           if (po_methodpointer in procvar^.procoptions) then
-             hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
-           else
-             hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
-         end;
-        if assigned(hp) then
-         begin
-           disposetree(t);
-           t:=hp;
-         end;
+        if (p2^.treetype=calln) then
+         doconv(pv,p2)
+        else
+         if (p2^.treetype=typeconvn) and
+            (p2^.left^.treetype=calln) then
+          doconv(pv,p2^.left);
       end;
       end;
 
 
+
     { the following procedure handles the access to a property symbol }
     { the following procedure handles the access to a property symbol }
     procedure handle_propertysym(sym : psym;st : psymtable;var p1 : ptree;
     procedure handle_propertysym(sym : psym;st : psymtable;var p1 : ptree;
       var pd : pdef);
       var pd : pdef);
@@ -642,14 +654,7 @@ unit pexpr;
                          getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
                          getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
                          p2:=comp_expr(true);
                          p2:=comp_expr(true);
                          if getprocvar then
                          if getprocvar then
-                          begin
-                            if (p2^.treetype=calln) then
-                             handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2)
-                            else
-                             if (p2^.treetype=typeconvn) and
-                                (p2^.left^.treetype=calln) then
-                              handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2^.left);
-                          end;
+                           handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2);
                          p1^.left:=gencallparanode(p2,p1^.left);
                          p1^.left:=gencallparanode(p2,p1^.left);
                          getprocvar:=false;
                          getprocvar:=false;
                        end;
                        end;
@@ -784,10 +789,13 @@ unit pexpr;
                    begin
                    begin
                       p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
                       p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
                       do_proc_call(getaddr or
                       do_proc_call(getaddr or
+                        (block_type=bt_const) or
                         (getprocvar and
                         (getprocvar and
                          (m_tp_procvar in aktmodeswitches) and
                          (m_tp_procvar in aktmodeswitches) and
                          proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
                          proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
                         ,again,p1,pd);
                         ,again,p1,pd);
+                      if (block_type=bt_const) then
+                        handle_procvar(getprocvardef,p1);
                       { now we know the real method e.g. we can check for a class method }
                       { now we know the real method e.g. we can check for a class method }
                       if isclassref and
                       if isclassref and
                          assigned(p1^.procdefinition) and
                          assigned(p1^.procdefinition) and
@@ -1140,6 +1148,9 @@ unit pexpr;
                                 constord :
                                 constord :
                                   p1:=genordinalconstnode(pconstsym(srsym)^.value,
                                   p1:=genordinalconstnode(pconstsym(srsym)^.value,
                                         pconstsym(srsym)^.definition);
                                         pconstsym(srsym)^.definition);
+                                constpointer :
+                                  p1:=genpointerconstnode(pconstsym(srsym)^.value,
+                                        pconstsym(srsym)^.definition);
                                 constnil :
                                 constnil :
                                   p1:=genzeronode(niln);
                                   p1:=genzeronode(niln);
                                 constresourcestring:
                                 constresourcestring:
@@ -1158,10 +1169,13 @@ unit pexpr;
                               p1:=gencallnode(pprocsym(srsym),srsymtable);
                               p1:=gencallnode(pprocsym(srsym),srsymtable);
                               p1^.unit_specific:=unit_specific;
                               p1^.unit_specific:=unit_specific;
                               do_proc_call(getaddr or
                               do_proc_call(getaddr or
+                                (block_type=bt_const) or
                                 (getprocvar and
                                 (getprocvar and
                                  (m_tp_procvar in aktmodeswitches) and
                                  (m_tp_procvar in aktmodeswitches) and
                                  proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
                                  proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
                                 again,p1,pd);
                                 again,p1,pd);
+                              if (block_type=bt_const) then
+                                handle_procvar(getprocvardef,p1);
                               if possible_error and
                               if possible_error and
                                  not(po_classmethod in p1^.procdefinition^.procoptions) then
                                  not(po_classmethod in p1^.procdefinition^.procoptions) then
                                 Message(parser_e_only_class_methods);
                                 Message(parser_e_only_class_methods);
@@ -2008,15 +2022,7 @@ _LECKKLAMMER : begin
                               end;
                               end;
                             p2:=sub_expr(opcompare,true);
                             p2:=sub_expr(opcompare,true);
                             if getprocvar then
                             if getprocvar then
-                             begin
-                               if (p2^.treetype=calln) then
-                                handle_procvar(getprocvardef,p2)
-                               else
-                                { also allow p:= proc(t); !! (PM) }
-                                if (p2^.treetype=typeconvn) and
-                                   (p2^.left^.treetype=calln) then
-                                 handle_procvar(getprocvardef,p2^.left);
-                             end;
+                              handle_procvar(getprocvardef,p2);
                             getprocvar:=false;
                             getprocvar:=false;
                             p1:=gennode(assignn,p1,p2);
                             p1:=gennode(assignn,p1,p2);
                          end;
                          end;
@@ -2100,7 +2106,12 @@ _LECKKLAMMER : begin
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.143  1999-09-15 20:35:41  florian
+  Revision 1.144  1999-09-26 21:30:19  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.143  1999/09/15 20:35:41  florian
     * small fix to operator overloading when in MMX mode
     * small fix to operator overloading when in MMX mode
     + the compiler uses now fldz and fld1 if possible
     + the compiler uses now fldz and fld1 if possible
     + some fixes to floating point registers
     + some fixes to floating point registers

+ 68 - 23
compiler/ptconst.pas

@@ -58,11 +58,10 @@ unit ptconst;
          i,l,offset,
          i,l,offset,
          strlength : longint;
          strlength : longint;
          curconstsegment : paasmoutput;
          curconstsegment : paasmoutput;
-         ll     : pasmlabel;
-         s       : string;
-         ca     : pchar;
+         ll        : pasmlabel;
+         s         : string;
+         ca        : pchar;
          aktpos    : longint;
          aktpos    : longint;
-         pd     : pprocdef;
          obj       : pobjectdef;
          obj       : pobjectdef;
          symt      : psymtable;
          symt      : psymtable;
          value     : bestreal;
          value     : bestreal;
@@ -560,25 +559,66 @@ unit ptconst;
                 if not(m_tp_procvar in aktmodeswitches) then
                 if not(m_tp_procvar in aktmodeswitches) then
                   if token=_KLAMMERAFFE then
                   if token=_KLAMMERAFFE then
                     consume(_KLAMMERAFFE);
                     consume(_KLAMMERAFFE);
-              getsym(pattern,true);
-              consume(_ID);
-              if srsym^.typ=unitsym then
-                begin
-                   consume(_POINT);
-                   getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
-                   consume(_ID);
-                end;
-              if srsym^.typ<>procsym then
-                Message(cg_e_illegal_expression)
+              getprocvar:=true;
+              getprocvardef:=pprocvardef(def);
+              p:=comp_expr(true);
+              getprocvar:=false;
+              do_firstpass(p);
+              if codegenerror then
+               begin
+                 disposetree(p);
+                 exit;
+               end;
+              { convert calln to loadn }
+              if p^.treetype=calln then
+               begin
+                 if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
+                    (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
+                  hp:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
+                        getcopy(p^.methodpointer))
+                 else
+                  hp:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
+                 disposetree(p);
+                 do_firstpass(hp);
+                 p:=hp;
+                 if codegenerror then
+                  begin
+                    disposetree(p);
+                    exit;
+                  end;
+               end;
+              { let type conversion check everything needed }
+              p:=gentypeconvnode(p,def);
+              do_firstpass(p);
+              if codegenerror then
+               begin
+                 disposetree(p);
+                 exit;
+               end;
+              { remove typeconvn, that will normally insert a lea
+                instruction which is not necessary for us }
+              if p^.treetype=typeconvn then
+               begin
+                 hp:=p^.left;
+                 putnode(p);
+                 p:=hp;
+               end;
+              { remove addrn which we also don't need here }
+              if p^.treetype=addrn then
+               begin
+                 hp:=p^.left;
+                 putnode(p);
+                 p:=hp;
+               end;
+              { we now need to have a loadn with a procsym }
+              if (p^.treetype=loadn) and
+                 (p^.symtableentry^.typ=procsym) then
+               begin
+                 curconstsegment^.concat(new(pai_const_symbol,
+                   initname(pprocsym(p^.symtableentry)^.definition^.mangledname)));
+               end
               else
               else
-                begin
-                   pd:=pprocsym(srsym)^.definition;
-                   if assigned(pd^.nextoverloaded) then
-                     Message(parser_e_no_overloaded_procvars);
-                   if not proc_to_procvar_equal(pd,pprocvardef(def)) then
-                     Message2(type_e_incompatible_types,pd^.typename,pprocvardef(def)^.typename);
-                   curconstsegment^.concat(new(pai_const_symbol,initname(pd^.mangledname)));
-                end;
+               Message(cg_e_illegal_expression);
            end;
            end;
          { reads a typed constant record }
          { reads a typed constant record }
          recorddef:
          recorddef:
@@ -700,7 +740,12 @@ unit ptconst;
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.52  1999-08-10 12:30:02  pierre
+  Revision 1.53  1999-09-26 21:30:20  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.52  1999/08/10 12:30:02  pierre
    * avoid unused locals
    * avoid unused locals
 
 
   Revision 1.51  1999/08/04 13:03:02  jonas
   Revision 1.51  1999/08/04 13:03:02  jonas

+ 8 - 2
compiler/symdef.inc

@@ -3088,7 +3088,8 @@ Const local_symtable_index : longint = $8001;
     function tprocvardef.gettypename : string;
     function tprocvardef.gettypename : string;
 
 
       begin
       begin
-         if assigned(retdef) then
+         if assigned(retdef) and
+            (retdef<>pdef(voiddef)) then
            gettypename:='<procedure variable type of function'+demangled_paras+':'+retdef^.gettypename+'>'
            gettypename:='<procedure variable type of function'+demangled_paras+':'+retdef^.gettypename+'>'
          else
          else
            gettypename:='<procedure variable type of procedure'+demangled_paras+'>';
            gettypename:='<procedure variable type of procedure'+demangled_paras+'>';
@@ -3778,7 +3779,12 @@ Const local_symtable_index : longint = $8001;
 
 
 {
 {
   $Log$
   $Log$
-  Revision 1.165  1999-09-20 16:39:02  peter
+  Revision 1.166  1999-09-26 21:30:21  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.165  1999/09/20 16:39:02  peter
     * cs_create_smart instead of cs_smartlink
     * cs_create_smart instead of cs_smartlink
     * -CX is create smartlink
     * -CX is create smartlink
     * -CD is create dynamic, but does nothing atm.
     * -CD is create dynamic, but does nothing atm.

+ 16 - 4
compiler/symsym.inc

@@ -1673,7 +1673,9 @@
          case consttype of
          case consttype of
            constint,
            constint,
            constbool,
            constbool,
-           constchar : value:=readlong;
+           constchar :
+             value:=readlong;
+           constpointer,
            constord :
            constord :
              begin
              begin
                definition:=readdefref;
                definition:=readdefref;
@@ -1729,7 +1731,7 @@
 
 
     procedure tconstsym.deref;
     procedure tconstsym.deref;
       begin
       begin
-        if consttype in [constord,constset] then
+        if consttype in [constord,constpointer,constset] then
          resolvedef(pdef(definition));
          resolvedef(pdef(definition));
       end;
       end;
 
 
@@ -1744,6 +1746,7 @@
            constbool,
            constbool,
            constchar :
            constchar :
              writelong(value);
              writelong(value);
+           constpointer,
            constord :
            constord :
              begin
              begin
                writedefref(definition);
                writedefref(definition);
@@ -1781,7 +1784,11 @@
                           {st := ibm2ascii(pstring(value)^);}
                           {st := ibm2ascii(pstring(value)^);}
                           st := 's'''+st+'''';
                           st := 's'''+st+'''';
                           end;
                           end;
-            constbool, constint, constord, constchar : st := 'i'+tostr(value);
+            constbool,
+            constint,
+            constpointer,
+            constord,
+            constchar : st := 'i'+tostr(value);
             constreal : begin
             constreal : begin
                         system.str(pbestreal(value)^,st);
                         system.str(pbestreal(value)^,st);
                         st := 'r'+st;
                         st := 'r'+st;
@@ -2157,7 +2164,12 @@
 
 
 {
 {
   $Log$
   $Log$
-  Revision 1.118  1999-09-20 16:39:03  peter
+  Revision 1.119  1999-09-26 21:30:22  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.118  1999/09/20 16:39:03  peter
     * cs_create_smart instead of cs_smartlink
     * cs_create_smart instead of cs_smartlink
     * -CX is create smartlink
     * -CX is create smartlink
     * -CD is create dynamic, but does nothing atm.
     * -CD is create dynamic, but does nothing atm.

+ 7 - 2
compiler/symsymh.inc

@@ -281,7 +281,7 @@
        end;
        end;
 
 
        tconsttype = (constord,conststring,constreal,constbool,
        tconsttype = (constord,conststring,constreal,constbool,
-                     constint,constchar,constset,constnil,
+                     constint,constchar,constset,constpointer,constnil,
                      constresourcestring);
                      constresourcestring);
 
 
        pconstsym = ^tconstsym;
        pconstsym = ^tconstsym;
@@ -338,7 +338,12 @@
 
 
 {
 {
   $Log$
   $Log$
-  Revision 1.34  1999-08-31 15:42:26  pierre
+  Revision 1.35  1999-09-26 21:30:22  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.34  1999/08/31 15:42:26  pierre
    + tmacrosym is_used and defined_at_startup boolean fields added
    + tmacrosym is_used and defined_at_startup boolean fields added
 
 
   Revision 1.33  1999/08/23 11:45:45  michael
   Revision 1.33  1999/08/23 11:45:45  michael

+ 25 - 2
compiler/tccnv.pas

@@ -505,6 +505,23 @@ implementation
       end;
       end;
 
 
 
 
+    procedure first_cord_to_pointer(var p : ptree);
+      var
+        t : ptree;
+      begin
+        if p^.left^.treetype=ordconstn then
+          begin
+            t:=genpointerconstnode(p^.left^.value,p^.resulttype);
+            firstpass(t);
+            disposetree(p);
+            p:=t;
+            exit;
+          end
+        else
+          internalerror(432472389);
+      end;
+
+
     procedure first_pchar_to_string(var p : ptree);
     procedure first_pchar_to_string(var p : ptree);
       begin
       begin
          p^.location.loc:=LOC_REFERENCE;
          p^.location.loc:=LOC_REFERENCE;
@@ -565,7 +582,8 @@ implementation
          first_fix_to_real,
          first_fix_to_real,
          first_proc_to_procvar,
          first_proc_to_procvar,
          first_arrayconstructor_to_set,
          first_arrayconstructor_to_set,
-         first_load_smallset
+         first_load_smallset,
+         first_cord_to_pointer
        );
        );
      begin
      begin
        aprocdef:=nil;
        aprocdef:=nil;
@@ -944,7 +962,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.48  1999-09-17 17:14:12  peter
+  Revision 1.49  1999-09-26 21:30:22  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.48  1999/09/17 17:14:12  peter
     * @procvar fixes for tp mode
     * @procvar fixes for tp mode
     * @<id>:= gives now an error
     * @<id>:= gives now an error
 
 

+ 17 - 1
compiler/tccon.pas

@@ -29,6 +29,7 @@ interface
     procedure firstrealconst(var p : ptree);
     procedure firstrealconst(var p : ptree);
     procedure firstfixconst(var p : ptree);
     procedure firstfixconst(var p : ptree);
     procedure firstordconst(var p : ptree);
     procedure firstordconst(var p : ptree);
+    procedure firstpointerconst(var p : ptree);
     procedure firststringconst(var p : ptree);
     procedure firststringconst(var p : ptree);
     procedure firstsetconst(var p : ptree);
     procedure firstsetconst(var p : ptree);
     procedure firstniln(var p : ptree);
     procedure firstniln(var p : ptree);
@@ -77,6 +78,16 @@ implementation
       end;
       end;
 
 
 
 
+{*****************************************************************************
+                             FirstPointerConst
+*****************************************************************************}
+
+    procedure firstpointerconst(var p : ptree);
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+
 {*****************************************************************************
 {*****************************************************************************
                             FirstStringConst
                             FirstStringConst
 *****************************************************************************}
 *****************************************************************************}
@@ -125,7 +136,12 @@ implementation
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.9  1999-09-04 20:52:07  florian
+  Revision 1.10  1999-09-26 21:30:22  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.9  1999/09/04 20:52:07  florian
     * bug 580 fixed
     * bug 580 fixed
 
 
   Revision 1.8  1999/08/04 00:23:38  florian
   Revision 1.8  1999/08/04 00:23:38  florian

+ 31 - 2
compiler/tree.pas

@@ -71,6 +71,7 @@ unit tree;
           umminusn,     {Represents a sign change (i.e. -2).}
           umminusn,     {Represents a sign change (i.e. -2).}
           asmn,     {Represents an assembler node }
           asmn,     {Represents an assembler node }
           vecn,     {Represents array indexing.}
           vecn,     {Represents array indexing.}
+          pointerconstn,
           stringconstn,    {Represents a string constant.}
           stringconstn,    {Represents a string constant.}
           funcretn,     {Represents the function result var.}
           funcretn,     {Represents the function result var.}
           selfn,           {Represents the self parameter.}
           selfn,           {Represents the self parameter.}
@@ -143,7 +144,8 @@ unit tree;
           tc_fix_2_real,
           tc_fix_2_real,
           tc_proc_2_procvar,
           tc_proc_2_procvar,
           tc_arrayconstructor_2_set,
           tc_arrayconstructor_2_set,
-          tc_load_smallset
+          tc_load_smallset,
+          tc_cord_2_pointer
        );
        );
 
 
        { allows to determine which elementes are to be replaced }
        { allows to determine which elementes are to be replaced }
@@ -248,6 +250,7 @@ unit tree;
     function gensinglenode(t : ttreetyp;l : ptree) : ptree;
     function gensinglenode(t : ttreetyp;l : ptree) : ptree;
     function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
     function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
     function genordinalconstnode(v : longint;def : pdef) : ptree;
     function genordinalconstnode(v : longint;def : pdef) : ptree;
+    function genpointerconstnode(v : longint;def : pdef) : ptree;
     function genfixconstnode(v : longint;def : pdef) : ptree;
     function genfixconstnode(v : longint;def : pdef) : ptree;
     function gentypeconvnode(node : ptree;t : pdef) : ptree;
     function gentypeconvnode(node : ptree;t : pdef) : ptree;
     function gentypenode(t : pdef;sym:ptypesym) : ptree;
     function gentypenode(t : pdef;sym:ptypesym) : ptree;
@@ -772,6 +775,27 @@ unit tree;
          genordinalconstnode:=p;
          genordinalconstnode:=p;
       end;
       end;
 
 
+    function genpointerconstnode(v : longint;def : pdef) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=pointerconstn;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=def;
+         p^.value:=v;
+         genpointerconstnode:=p;
+      end;
+
     function genenumnode(v : penumsym) : ptree;
     function genenumnode(v : penumsym) : ptree;
 
 
       var
       var
@@ -1766,7 +1790,12 @@ unit tree;
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.97  1999-09-17 17:14:13  peter
+  Revision 1.98  1999-09-26 21:30:22  peter
+    + constant pointer support which can happend with typecasting like
+      const p=pointer(1)
+    * better procvar parsing in typed consts
+
+  Revision 1.97  1999/09/17 17:14:13  peter
     * @procvar fixes for tp mode
     * @procvar fixes for tp mode
     * @<id>:= gives now an error
     * @<id>:= gives now an error