freepascal.compiler/compiler/psystem.pas

{
    $Id$
    Copyright (c) 1998-2000 by Florian Klaempfl

    Load the system unit, create required defs for systemunit

    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 psystem;

{$i defines.inc}

interface
uses
  symbase;

procedure insertinternsyms(p : psymtable);
procedure insert_intern_types(p : psymtable);

procedure readconstdefs;
procedure createconstdefs;


implementation

uses
  globals,
  symconst,symsym,symdef,symtable,
  ninl;

procedure insertinternsyms(p : psymtable);
{
  all intern procedures for the system unit
}
begin
  p^.insert(new(psyssym,init('Concat',in_concat_x)));
  p^.insert(new(psyssym,init('Write',in_write_x)));
  p^.insert(new(psyssym,init('WriteLn',in_writeln_x)));
  p^.insert(new(psyssym,init('Assigned',in_assigned_x)));
  p^.insert(new(psyssym,init('Read',in_read_x)));
  p^.insert(new(psyssym,init('ReadLn',in_readln_x)));
  p^.insert(new(psyssym,init('Ofs',in_ofs_x)));
  p^.insert(new(psyssym,init('SizeOf',in_sizeof_x)));
  p^.insert(new(psyssym,init('TypeOf',in_typeof_x)));
  p^.insert(new(psyssym,init('Low',in_low_x)));
  p^.insert(new(psyssym,init('High',in_high_x)));
  p^.insert(new(psyssym,init('Seg',in_seg_x)));
  p^.insert(new(psyssym,init('Ord',in_ord_x)));
  p^.insert(new(psyssym,init('Pred',in_pred_x)));
  p^.insert(new(psyssym,init('Succ',in_succ_x)));
  p^.insert(new(psyssym,init('Exclude',in_exclude_x_y)));
  p^.insert(new(psyssym,init('Include',in_include_x_y)));
  p^.insert(new(psyssym,init('Break',in_break)));
  p^.insert(new(psyssym,init('Continue',in_continue)));
  p^.insert(new(psyssym,init('Dec',in_dec_x)));
  p^.insert(new(psyssym,init('Inc',in_inc_x)));
  p^.insert(new(psyssym,init('Str',in_str_x_string)));
  p^.insert(new(psyssym,init('Assert',in_assert_x_y)));
  p^.insert(new(psyssym,init('Val',in_val_x)));
  p^.insert(new(psyssym,init('Addr',in_addr_x)));
  p^.insert(new(psyssym,init('TypeInfo',in_typeinfo_x)));
  p^.insert(new(psyssym,init('SetLength',in_setlength_x)));
  p^.insert(new(psyssym,init('Finalize',in_finalize_x)));
end;


procedure insert_intern_types(p : psymtable);
{
  all the types inserted into the system unit
}
var
  { several defs to simulate more or less C++ objects for GDB }
  vmtdef      : precorddef;
  vmtarraydef : parraydef;
  vmtsymtable : psymtable;
begin
{ Internal types }
  p^.insert(new(ptypesym,initdef('$formal',cformaldef)));
  p^.insert(new(ptypesym,initdef('$void',voiddef)));
  p^.insert(new(ptypesym,initdef('$byte',u8bitdef)));
  p^.insert(new(ptypesym,initdef('$word',u16bitdef)));
  p^.insert(new(ptypesym,initdef('$ulong',u32bitdef)));
  p^.insert(new(ptypesym,initdef('$longint',s32bitdef)));
  p^.insert(new(ptypesym,initdef('$qword',cu64bitdef)));
  p^.insert(new(ptypesym,initdef('$int64',cs64bitdef)));
  p^.insert(new(ptypesym,initdef('$char',cchardef)));
  p^.insert(new(ptypesym,initdef('$widechar',cwidechardef)));
  p^.insert(new(ptypesym,initdef('$shortstring',cshortstringdef)));
  p^.insert(new(ptypesym,initdef('$longstring',clongstringdef)));
  p^.insert(new(ptypesym,initdef('$ansistring',cansistringdef)));
  p^.insert(new(ptypesym,initdef('$widestring',cwidestringdef)));
  p^.insert(new(ptypesym,initdef('$openshortstring',openshortstringdef)));
  p^.insert(new(ptypesym,initdef('$boolean',booldef)));
  p^.insert(new(ptypesym,initdef('$void_pointer',voidpointerdef)));
  p^.insert(new(ptypesym,initdef('$char_pointer',charpointerdef)));
  p^.insert(new(ptypesym,initdef('$void_farpointer',voidfarpointerdef)));
  p^.insert(new(ptypesym,initdef('$openchararray',openchararraydef)));
  p^.insert(new(ptypesym,initdef('$file',cfiledef)));
  p^.insert(new(ptypesym,initdef('$s32real',s32floatdef)));
  p^.insert(new(ptypesym,initdef('$s64real',s64floatdef)));
  p^.insert(new(ptypesym,initdef('$s80real',s80floatdef)));
{$ifdef SUPPORT_FIXED}
  p^.insert(new(ptypesym,initdef('$s32fixed',s32fixeddef)));
{$endif SUPPORT_FIXED}
  { Add a type for virtual method tables in lowercase }
  { so it isn't reachable!                            }
  vmtsymtable:=new(pstoredsymtable,init(recordsymtable));
  vmtdef:=new(precorddef,init(vmtsymtable));
  pvmtdef:=new(ppointerdef,initdef(vmtdef));
  vmtsymtable^.insert(new(pvarsym,initdef('$parent',pvmtdef)));
  vmtsymtable^.insert(new(pvarsym,initdef('$length',globaldef('longint'))));
  vmtsymtable^.insert(new(pvarsym,initdef('$mlength',globaldef('longint'))));
  vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
  vmtarraydef^.elementtype.setdef(voidpointerdef);
  vmtsymtable^.insert(new(pvarsym,initdef('$__pfn',vmtarraydef)));
  p^.insert(new(ptypesym,initdef('$__vtbl_ptr_type',vmtdef)));
  p^.insert(new(ptypesym,initdef('$pvmt',pvmtdef)));
  vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
  vmtarraydef^.elementtype.setdef(pvmtdef);
  p^.insert(new(ptypesym,initdef('$vtblarray',vmtarraydef)));
  insertinternsyms(p);
{ Normal types }
  p^.insert(new(ptypesym,initdef('Single',s32floatdef)));
  p^.insert(new(ptypesym,initdef('Double',s64floatdef)));
  p^.insert(new(ptypesym,initdef('Extended',s80floatdef)));
  p^.insert(new(ptypesym,initdef('Real',s64floatdef)));
{$ifdef i386}
  p^.insert(new(ptypesym,initdef('Comp',new(pfloatdef,init(s64comp)))));
{$endif}
  p^.insert(new(ptypesym,initdef('Pointer',voidpointerdef)));
  p^.insert(new(ptypesym,initdef('FarPointer',voidfarpointerdef)));
  p^.insert(new(ptypesym,initdef('ShortString',cshortstringdef)));
  p^.insert(new(ptypesym,initdef('LongString',clongstringdef)));
  p^.insert(new(ptypesym,initdef('AnsiString',cansistringdef)));
  p^.insert(new(ptypesym,initdef('WideString',cwidestringdef)));
  p^.insert(new(ptypesym,initdef('Boolean',booldef)));
  p^.insert(new(ptypesym,initdef('ByteBool',booldef)));
  p^.insert(new(ptypesym,initdef('WordBool',new(porddef,init(bool16bit,0,1)))));
  p^.insert(new(ptypesym,initdef('LongBool',new(porddef,init(bool32bit,0,1)))));
  p^.insert(new(ptypesym,initdef('Char',cchardef)));
  p^.insert(new(ptypesym,initdef('WideChar',cwidechardef)));
  p^.insert(new(ptypesym,initdef('Text',new(pfiledef,inittext))));
  p^.insert(new(ptypesym,initdef('Cardinal',u32bitdef)));
{$ifdef SUPPORT_FIXED}
  p^.insert(new(ptypesym,initdef('Fixed',new(pfloatdef,init(f32bit)))));
  p^.insert(new(ptypesym,initdef('Fixed16',new(pfloatdef,init(f16bit)))));
{$endif SUPPORT_FIXED}
  p^.insert(new(ptypesym,initdef('QWord',cu64bitdef)));
  p^.insert(new(ptypesym,initdef('Int64',cs64bitdef)));
  p^.insert(new(ptypesym,initdef('TypedFile',new(pfiledef,inittypeddef(voiddef)))));
end;


procedure readconstdefs;
{
  Load all default definitions for consts from the system unit
}
begin
  u8bitdef:=porddef(globaldef('byte'));
  u16bitdef:=porddef(globaldef('word'));
  u32bitdef:=porddef(globaldef('ulong'));
  s32bitdef:=porddef(globaldef('longint'));
  cu64bitdef:=porddef(globaldef('qword'));
  cs64bitdef:=porddef(globaldef('int64'));
  cformaldef:=pformaldef(globaldef('formal'));
  voiddef:=porddef(globaldef('void'));
  cchardef:=porddef(globaldef('char'));
  cwidechardef:=porddef(globaldef('char'));
  cshortstringdef:=pstringdef(globaldef('shortstring'));
  clongstringdef:=pstringdef(globaldef('longstring'));
  cansistringdef:=pstringdef(globaldef('ansistring'));
  cwidestringdef:=pstringdef(globaldef('widestring'));
  openshortstringdef:=pstringdef(globaldef('openshortstring'));
  openchararraydef:=parraydef(globaldef('openchararray'));
  s32floatdef:=pfloatdef(globaldef('s32real'));
  s64floatdef:=pfloatdef(globaldef('s64real'));
  s80floatdef:=pfloatdef(globaldef('s80real'));
{$ifdef SUPPORT_FIXED}
  s32fixeddef:=pfloatdef(globaldef('s32fixed'));
{$endif SUPPORT_FIXED}
  booldef:=porddef(globaldef('boolean'));
  voidpointerdef:=ppointerdef(globaldef('void_pointer'));
  charpointerdef:=ppointerdef(globaldef('char_pointer'));
  voidfarpointerdef:=ppointerdef(globaldef('void_farpointer'));
  cfiledef:=pfiledef(globaldef('file'));
  pvmtdef:=ppointerdef(globaldef('pvmt'));
end;


procedure createconstdefs;
{
  Create all default definitions for consts for the system unit
}
var
  oldregisterdef : boolean;
begin
  { create definitions for constants }
  oldregisterdef:=registerdef;
  registerdef:=false;
  cformaldef:=new(pformaldef,init);
  voiddef:=new(porddef,init(uvoid,0,0));
  u8bitdef:=new(porddef,init(u8bit,0,255));
  u16bitdef:=new(porddef,init(u16bit,0,65535));
  u32bitdef:=new(porddef,init(u32bit,0,longint($ffffffff)));
  s32bitdef:=new(porddef,init(s32bit,longint($80000000),$7fffffff));
  cu64bitdef:=new(porddef,init(u64bit,0,0));
  cs64bitdef:=new(porddef,init(s64bit,0,0));
  booldef:=new(porddef,init(bool8bit,0,1));
  cchardef:=new(porddef,init(uchar,0,255));
  cwidechardef:=new(porddef,init(uwidechar,0,65535));
  cshortstringdef:=new(pstringdef,shortinit(255));
  { should we give a length to the default long and ansi string definition ?? }
  clongstringdef:=new(pstringdef,longinit(-1));
  cansistringdef:=new(pstringdef,ansiinit(-1));
  cwidestringdef:=new(pstringdef,wideinit(-1));
  { length=0 for shortstring is open string (needed for readln(string) }
  openshortstringdef:=new(pstringdef,shortinit(0));
  openchararraydef:=new(parraydef,init(0,-1,s32bitdef));
  parraydef(openchararraydef)^.elementtype.setdef(cchardef);
{$ifdef i386}
  s32floatdef:=new(pfloatdef,init(s32real));
  s64floatdef:=new(pfloatdef,init(s64real));
  s80floatdef:=new(pfloatdef,init(s80real));
{$endif}
{$ifdef m68k}
  s32floatdef:=new(pfloatdef,init(s32real));
  s64floatdef:=new(pfloatdef,init(s64real));
  if (cs_fp_emulation in aktmoduleswitches) then
   s80floatdef:=new(pfloatdef,init(s32real))
  else
   s80floatdef:=new(pfloatdef,init(s80real));
{$endif}
{$ifdef SUPPORT_FIXED}
  s32fixeddef:=new(pfloatdef,init(f32bit));
{$endif SUPPORT_FIXED}
  { some other definitions }
  voidpointerdef:=new(ppointerdef,initdef(voiddef));
  charpointerdef:=new(ppointerdef,initdef(cchardef));
  voidfarpointerdef:=new(ppointerdef,initfardef(voiddef));
  cfiledef:=new(pfiledef,inituntyped);
  registerdef:=oldregisterdef;
end;


end.
{
  $Log$
  Revision 1.11  2000-12-07 17:19:43  jonas
    * new constant handling: from now on, hex constants >$7fffffff are
      parsed as unsigned constants (otherwise, $80000000 got sign extended
      and became $ffffffff80000000), all constants in the longint range
      become longints, all constants >$7fffffff and <=cardinal($ffffffff)
      are cardinals and the rest are int64's.
    * added lots of longint typecast to prevent range check errors in the
      compiler and rtl
    * type casts of symbolic ordinal constants are now preserved
    * fixed bug where the original resulttype wasn't restored correctly
      after doing a 64bit rangecheck

  Revision 1.10  2000/11/29 00:30:38  florian
    * unused units removed from uses clause
    * some changes for widestrings

  Revision 1.9  2000/11/09 17:46:56  florian
    * System.TypeInfo fixed
    + System.Finalize implemented
    + some new keywords for interface support added

  Revision 1.8  2000/10/31 22:02:51  peter
    * symtable splitted, no real code changes

  Revision 1.7  2000/10/21 18:16:12  florian
    * a lot of changes:
       - basic dyn. array support
       - basic C++ support
       - some work for interfaces done
       ....

  Revision 1.6  2000/10/14 10:14:52  peter
    * moehrendorf oct 2000 rewrite

  Revision 1.5  2000/09/24 15:06:24  peter
    * use defines.inc

  Revision 1.4  2000/08/27 20:19:39  peter
    * store strings with case in ppu, when an internal symbol is created
      a '$' is prefixed so it's not automatic uppercased

  Revision 1.3  2000/08/16 13:06:06  florian
    + support of 64 bit integer constants

  Revision 1.2  2000/07/13 11:32:47  michael
  + removed logs

}