path: root/gcc/m2/gm2-compiler/M2System.mod

(* M2System.mod defines the SYSTEM builtin types.

Copyright (C) 2001-2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 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 3, or (at your option)
any later version.

GNU Modula-2 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 GNU Modula-2; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE M2System ;

(*
    Title      : M2System
    Author     : Gaius Mulley
    System     : UNIX (gm2)
    Date       : Mon Jul 10 20:24:31 2000
    Description: gcc version of M2System. It defines the builtin types within the
                 SYSTEM.def module. Remember that these modules (SYSTEM.def, SYSTEM.mod)
                 really exist, but not all type definitions are expressed in this file.
                 We also need to tell the compiler the size of the data types.
*)

FROM SymbolTable IMPORT NulSym,
                        StartScope,
                        EndScope,
      	       	     	MakeConstLit,
                        MakeConstVar,
                        MakePointer,
                        MakeType,
                        MakeProcedure,
      	       	     	MakeSet,
      	       	     	MakeSubrange,
                        PutFunction,
                        PutType, PutPointer,
      	       	     	PutSet, PutVar,
      	       	     	PutSubrange,
                        PutExportQualified,
                        PutProcedureNoReturn,
                        GetSym, GetSymName,
                        GetCurrentModule, SetCurrentModule,
                        IsLegal, ProcedureKind,
                        PopValue,
                        PopSize ;

FROM Assertion IMPORT Assert ;
FROM M2LexBuf IMPORT BuiltinTokenNo ;
FROM M2Options IMPORT Iso, Pim2, Pedantic, DumpSystemExports ;
FROM NameKey IMPORT Name, MakeKey, NulName ;
FROM M2Batch IMPORT MakeDefinitionSource ;
FROM M2Base IMPORT Cardinal, ZType ;
FROM M2Size IMPORT Size, MakeSize ;
FROM M2ALU IMPORT PushCard, PushIntegerTree, PushRealTree, DivTrunc ;
FROM M2Error IMPORT InternalError ;
FROM Lists IMPORT List, InitList, IsItemInList, PutItemIntoList, GetItemFromList, NoOfItemsInList ;
FROM SymbolKey IMPORT SymbolTree, InitTree, GetSymKey, PutSymKey ;
FROM StrLib IMPORT StrEqual ;
FROM M2Printf IMPORT printf1 ;
FROM SymbolConversion IMPORT Mod2Gcc ;

FROM M2Base IMPORT Real, Cardinal, Integer, Complex,
                   LongReal, LongCard, LongInt, LongComplex,
                   ShortReal, ShortCard, ShortInt, ShortComplex ;

FROM gcctypes IMPORT tree ;
FROM m2linemap IMPORT BuiltinsLocation ;
FROM m2decl IMPORT GetBitsPerBitset, GetBitsPerUnit ;

FROM m2type IMPORT GetMaxFrom, GetMinFrom,
                   GetWordType, GetPointerType, GetByteType, GetISOLocType,
                   GetM2Integer8, GetM2Integer16, GetM2Integer32, GetM2Integer64,
                   GetM2Cardinal8, GetM2Cardinal16, GetM2Cardinal32, GetM2Cardinal64,
                   GetM2Word16, GetM2Word32, GetM2Word64,
                   GetM2Bitset8, GetM2Bitset16, GetM2Bitset32,
                   GetM2Real32, GetM2Real64, GetM2Real96, GetM2Real128,
                   GetM2Complex32, GetM2Complex64, GetM2Complex96, GetM2Complex128,
                   GetBitsetType, GetISOByteType, GetISOWordType,
		   GetCSizeTType, GetCSSizeTType, GetCOffTType,
                   InitSystemTypes ;

FROM m2expr IMPORT BuildSize, GetSizeOf, AreConstantsEqual ;


TYPE
   IsP = PROCEDURE (CARDINAL) : BOOLEAN ;

VAR
   MinValues,
   MaxValues  : SymbolTree ;
   SystemTypes: List ;


(*
   Init -
*)

PROCEDURE Init ;
BEGIN
   InitList(SystemTypes) ;
   InitTree(MinValues) ;
   InitTree(MaxValues)
END Init ;


(*
   CreateMinMaxFor - creates the min and max values for type given gccType.
*)

PROCEDURE CreateMinMaxFor (type: CARDINAL; min, max: ARRAY OF CHAR;
                           gccType: tree; realtype: BOOLEAN) ;
VAR
   maxval, minval: CARDINAL ;
BEGIN
   maxval := MakeConstVar (BuiltinTokenNo, MakeKey(max)) ;
   IF realtype
   THEN
      PushRealTree (GetMaxFrom (BuiltinsLocation (), gccType))
   ELSE
      PushIntegerTree (GetMaxFrom (BuiltinsLocation (), gccType))
   END ;
   PopValue (maxval) ;
   PutVar (maxval, type) ;
   PutSymKey (MaxValues, GetSymName (type), maxval) ;

   minval := MakeConstVar (BuiltinTokenNo, MakeKey(min)) ;
   IF realtype
   THEN
      PushRealTree (GetMinFrom (BuiltinsLocation (), gccType))
   ELSE
      PushIntegerTree (GetMinFrom (BuiltinsLocation (), gccType))
   END ;
   PopValue (minval) ;
   PutVar (minval, type) ;
   PutSymKey (MinValues, GetSymName (type), minval)
END CreateMinMaxFor ;


(*
   MapType - create a mapping of the M2 frontend type to gcctype.
*)

PROCEDURE MapType (type: CARDINAL;
                   name, min, max: ARRAY OF CHAR;
                   needsExporting: BOOLEAN;
                   gcctype: tree; realtype: BOOLEAN) ;
VAR
   n: Name ;
BEGIN
   PushIntegerTree (BuildSize (BuiltinsLocation (), gcctype, FALSE)) ;
   PopSize (type) ;
   IF IsItemInList (SystemTypes, type)
   THEN
      InternalError ('not expecting system type to already be declared')
   END ;
   PutItemIntoList (SystemTypes, type) ;

   (* Create min, max constants if type is ordinal or a floating point type.  *)
   IF (NOT StrEqual (min, '')) AND (NOT StrEqual (max, ''))
   THEN
      CreateMinMaxFor (type, min, max, gcctype, realtype)
   END ;
   IF needsExporting AND DumpSystemExports
   THEN
      n := GetSymName (type) ;
      printf1('SYSTEM module creates type: %a\n', n)
   END
END MapType ;


(*
   CreateType - create and return a frontend type which matches the GCC tree type.
*)

PROCEDURE CreateType (name, min, max: ARRAY OF CHAR;
                      needsExporting: BOOLEAN; gccType: tree;
                      realtype: BOOLEAN) : CARDINAL ;
VAR
   type: CARDINAL ;
BEGIN
   IF gccType=NIL
   THEN
      (* GCC backend does not support this type.  *)
      RETURN NulSym
   ELSE
      (* Create base type.  *)
      type := MakeType (BuiltinTokenNo, MakeKey (name)) ;
      PutType (type, NulSym) ;  (* a Base Type *)
      MapType (type, name, min, max, needsExporting, gccType, realtype) ;
      RETURN type
   END
END CreateType ;


(*
   AttemptToCreateType - attempts to create a frontend type which matches the
                         GCC tree type.
*)

PROCEDURE AttemptToCreateType (name, min, max: ARRAY OF CHAR;
                               needsExporting: BOOLEAN; gccType: tree;
                               realtype: BOOLEAN) ;
BEGIN
   Assert (IsLegal (CreateType (name, min, max, needsExporting,
                                gccType, realtype)))
END AttemptToCreateType ;


(*
   CreateSetType - creates and returns a, SET OF [0..highBit], type.
                   It maps this type onto the GCC type.
*)

PROCEDURE CreateSetType (name, highBit: ARRAY OF CHAR;
                         needsExporting: BOOLEAN; gccType: tree) : CARDINAL ;
VAR
   low,
   high,
   subrange,
   type    : CARDINAL ;
BEGIN
   IF gccType=NIL
   THEN
      (* GCC backend does not support this type *)
      RETURN NulSym
   ELSE
      (* create base type *)
      type := MakeSet (BuiltinTokenNo, MakeKey (name)) ;
      low := MakeConstLit (BuiltinTokenNo, MakeKey ('0'), Cardinal) ;
      high := MakeConstLit (BuiltinTokenNo, MakeKey (highBit), Cardinal) ;
      subrange := MakeSubrange (BuiltinTokenNo, NulName) ;
      PutSubrange (subrange, low, high, Cardinal) ;
      PutSet (type, subrange, FALSE) ;
      MapType (type, name, '', '', needsExporting, gccType, FALSE) ;
      RETURN type
   END
END CreateSetType ;


(*
   AttemptToCreateSetType - creates and returns a, SET OF [0..highBit], type.
                            It maps this type onto the GCC type.
*)

PROCEDURE AttemptToCreateSetType (name, highBit: ARRAY OF CHAR;
                                  needsExporting: BOOLEAN; gccType: tree) ;
BEGIN
   Assert (IsLegal (CreateSetType (name, highBit, needsExporting, gccType)))
END AttemptToCreateSetType ;


(*
   MakeFixedSizedTypes - creates the SYSTEM fixed sized types providing the
                         gcc backend supports them.
*)

PROCEDURE MakeFixedSizedTypes ;
BEGIN
   AttemptToCreateType ('INTEGER8', 'MinInteger8', 'MaxInteger8', TRUE, GetM2Integer8 (), FALSE) ;
   AttemptToCreateType ('INTEGER16', 'MinInteger16', 'MaxInteger16', TRUE, GetM2Integer16 (), FALSE) ;
   AttemptToCreateType ('INTEGER32', 'MinInteger32', 'MaxInteger32', TRUE, GetM2Integer32 (), FALSE) ;
   AttemptToCreateType ('INTEGER64', 'MinInteger64', 'MaxInteger64', TRUE, GetM2Integer64 (), FALSE) ;

   AttemptToCreateType ('CARDINAL8', 'MinCardinal8', 'MaxCardinal8', TRUE, GetM2Cardinal8 (), FALSE) ;
   AttemptToCreateType ('CARDINAL16', 'MinCardinal16', 'MaxCardinal16', TRUE, GetM2Cardinal16 (), FALSE) ;
   AttemptToCreateType ('CARDINAL32', 'MinCardinal32', 'MaxCardinal32', TRUE, GetM2Cardinal32 (), FALSE) ;
   AttemptToCreateType ('CARDINAL64', 'MinCardinal64', 'MaxCardinal64', TRUE, GetM2Cardinal64 (), FALSE) ;

   AttemptToCreateType ('WORD16', '', '', TRUE, GetM2Word16 (), FALSE) ;
   AttemptToCreateType ('WORD32', '', '', TRUE, GetM2Word32 (), FALSE) ;
   AttemptToCreateType ('WORD64', '', '', TRUE, GetM2Word64 (), FALSE) ;

   AttemptToCreateSetType ('BITSET8' , '7' , TRUE, GetM2Bitset8 ()) ;
   AttemptToCreateSetType ('BITSET16', '15', TRUE, GetM2Bitset16 ()) ;
   AttemptToCreateSetType ('BITSET32', '31', TRUE, GetM2Bitset32 ()) ;

   AttemptToCreateType ('REAL32', 'MinReal32', 'MaxReal32', TRUE, GetM2Real32 (), TRUE) ;
   AttemptToCreateType ('REAL64', 'MinReal64', 'MaxReal64', TRUE, GetM2Real64 (), TRUE) ;
   AttemptToCreateType ('REAL96', 'MinReal96', 'MaxReal96', TRUE, GetM2Real96 (), TRUE) ;
   AttemptToCreateType ('REAL128', 'MinReal128', 'MaxReal128', TRUE, GetM2Real128 (), TRUE) ;

   AttemptToCreateType ('COMPLEX32', '', '', TRUE, GetM2Complex32 (), TRUE) ;
   AttemptToCreateType ('COMPLEX64', '', '', TRUE, GetM2Complex64 (), TRUE) ;
   AttemptToCreateType ('COMPLEX96', '', '', TRUE, GetM2Complex96 (), TRUE) ;
   AttemptToCreateType ('COMPLEX128', '', '', TRUE, GetM2Complex128 (), TRUE)
END MakeFixedSizedTypes ;


(*
   InitPIMTypes -
*)

PROCEDURE InitPIMTypes ;
BEGIN
   Loc := CreateType ('LOC', '', '', TRUE, GetISOLocType(), FALSE) ;
   InitSystemTypes(BuiltinsLocation(), Loc) ;
   Word := CreateType ('WORD', '', '', TRUE, GetWordType(), FALSE) ;
   Byte := CreateType ('BYTE', '', '', TRUE, GetByteType(), FALSE) ;

   (* ADDRESS = POINTER TO BYTE *)

   Address := MakePointer (BuiltinTokenNo, MakeKey('ADDRESS')) ;
   PutPointer (Address, Byte) ;                (* Base Type       *)
   MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE)
END InitPIMTypes ;


(*
   InitISOTypes -
*)

PROCEDURE InitISOTypes ;
BEGIN
   Loc := CreateType ('LOC', 'MinLoc', 'MaxLoc', TRUE, GetISOLocType (), FALSE) ;
   InitSystemTypes (BuiltinsLocation (), Loc) ;

   Address := MakePointer (BuiltinTokenNo, MakeKey ('ADDRESS')) ;
   PutPointer (Address, Loc) ;                (* Base Type       *)
   MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE) ;

   Byte := CreateType ('BYTE', '', '', TRUE, GetISOByteType(), FALSE) ;
   Word := CreateType ('WORD', '', '', TRUE, GetISOWordType(), FALSE) ;
END InitISOTypes ;


(*
   MakeExtraSystemTypes - create any extra system types required
                          for portability.
*)

PROCEDURE MakeExtraSystemTypes ;
BEGIN
   CSizeT  := CreateType ('CSIZE_T' , '', '', TRUE, GetCSizeTType (), FALSE) ;
   CSSizeT := CreateType ('CSSIZE_T', '', '', TRUE, GetCSSizeTType (), FALSE) ;
   COffT := CreateType ('COFF_T', '', '', TRUE, GetCOffTType (), FALSE)
END MakeExtraSystemTypes ;


(*
   InitSystem - creates the system dependant types and procedures.
                Note that they are not exported here, but they are
                exported in the textual module: SYSTEM.def.
                We build our system types from those given in the gcc
                backend. Essentially we perform double book keeping.
*)

PROCEDURE InitSystem ;
VAR
   Previous: CARDINAL ;
BEGIN
   Init ;

   (* create SYSTEM module *)
   System := MakeDefinitionSource(BuiltinTokenNo, MakeKey('SYSTEM')) ;
   StartScope(System) ;
   Previous := GetCurrentModule() ;
   SetCurrentModule(System) ;

   IF Iso
   THEN
      InitISOTypes ;
      MakeSize ;
      PutExportQualified(BuiltinTokenNo, MakeKey('SIZE'))
   ELSE
      InitPIMTypes ;
      (* SIZE is declared in SYSTEM.def in PIM-2 but not PIM-[34] *)
      IF Pedantic
      THEN
         IF Pim2
         THEN
            MakeSize ;
            PutExportQualified(BuiltinTokenNo, MakeKey('SIZE'))
         END
      ELSE
         MakeSize ;
         PutExportQualified(BuiltinTokenNo, MakeKey('SIZE'))
      END
   END ;

   (* The predefined pseudo functions.  *)

   Adr := MakeProcedure(BuiltinTokenNo,
                        MakeKey('ADR')) ;           (* Function        *)
   PutFunction (BuiltinTokenNo, Adr, DefProcedure, Address) ;
                                                    (* Return Type     *)
                                                    (* Address         *)
   TSize := MakeProcedure(BuiltinTokenNo,
                          MakeKey('TSIZE')) ;       (* Function        *)
   PutFunction (BuiltinTokenNo, TSize, DefProcedure, ZType) ;
                                                    (* Return Type     *)
                                                    (* ZType           *)
   TBitSize := MakeProcedure(BuiltinTokenNo,
                             MakeKey('TBITSIZE')) ; (* GNU extension   *)
                                                    (* Function        *)
   PutFunction (BuiltinTokenNo, TBitSize, DefProcedure, ZType) ;
                                                    (* Return Type     *)
                                                    (* ZType           *)
   (* The ISO specific predefined pseudo functions.  *)

   AddAdr := MakeProcedure(BuiltinTokenNo,
                           MakeKey('ADDADR')) ;     (* Function        *)
   PutFunction (BuiltinTokenNo, AddAdr, DefProcedure, Address) ;
                                                    (* Return Type     *)
   SubAdr := MakeProcedure(BuiltinTokenNo,
                           MakeKey('SUBADR')) ;     (* Function        *)
   PutFunction (BuiltinTokenNo, SubAdr, DefProcedure, Address) ;
                                                    (* Return Type     *)
   DifAdr := MakeProcedure (BuiltinTokenNo,
                            MakeKey ('DIFADR')) ;   (* Function        *)
   PutFunction (BuiltinTokenNo, DifAdr, DefProcedure, Address) ;
                                                    (* Return Type     *)
   MakeAdr := MakeProcedure (BuiltinTokenNo,
                             MakeKey ('MAKEADR')) ; (* Function        *)
   PutFunction (BuiltinTokenNo, MakeAdr, DefProcedure, Address) ;
                                                    (* Return Type     *)

   (* The return value for ROTATE, SHIFT and CAST is the
      same as the first parameter and is faked in M2Quads.  *)

   Rotate := MakeProcedure(BuiltinTokenNo,
                           MakeKey('ROTATE')) ;     (* Function        *)
   Shift := MakeProcedure(BuiltinTokenNo,
                          MakeKey('SHIFT')) ;       (* Function        *)
   Cast := MakeProcedure(BuiltinTokenNo,
                         MakeKey('CAST')) ;         (* Function        *)

   Throw := MakeProcedure(BuiltinTokenNo,
                          MakeKey('THROW')) ;       (* Procedure       *)
   PutProcedureNoReturn (Throw, DefProcedure, TRUE) ;

   CreateMinMaxFor(Word, 'MinWord', 'MaxWord', GetWordType(), FALSE) ;
   CreateMinMaxFor(Address, 'MinAddress', 'MaxAddress', GetPointerType(), FALSE) ;
   CreateMinMaxFor(Byte, 'MinByte', 'MaxByte', GetByteType(), FALSE) ;

   MakeFixedSizedTypes ;
   MakeExtraSystemTypes ;

   EndScope ;
   SetCurrentModule(Previous)
END InitSystem ;


(*
   GetSystemTypeMinMax - returns the minimum and maximum values for a given system type.
*)

PROCEDURE GetSystemTypeMinMax (type: CARDINAL; VAR min, max: CARDINAL) ;
BEGIN
   IF IsItemInList(SystemTypes, type)
   THEN
      min := GetSymKey(MinValues, GetSymName(type)) ;
      max := GetSymKey(MaxValues, GetSymName(type))
   ELSE
      InternalError ('system does not know about this type')
   END
END GetSystemTypeMinMax ;


(*
   IsISOPseudoSystemFunction -
*)

PROCEDURE IsISOPseudoSystemFunction (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN Iso AND ((sym=AddAdr) OR (sym=SubAdr) OR (sym=DifAdr) OR
                   (sym=MakeAdr) OR (sym=Rotate) OR (sym=Shift) OR
                   (sym=Cast))
END IsISOPseudoSystemFunction ;


(*
   IsPIMPseudoSystemFunction - returns TRUE if sym is specifically a PIM
                               system function.
*)

PROCEDURE IsPIMPseudoSystemFunction (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN (NOT Iso) AND ((sym=Size) OR (sym=Shift) OR (sym=Rotate))
END IsPIMPseudoSystemFunction ;


(*
   IsPseudoSystemFunction - returns true if sym is a SYSTEM pseudo function.
*)

PROCEDURE IsPseudoSystemFunction (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN( (sym=Adr) OR (sym=TSize) OR (sym=TBitSize) OR
           IsPIMPseudoSystemFunction(sym) OR
           IsISOPseudoSystemFunction(sym) )
END IsPseudoSystemFunction ;


(*
   IsPseudoSystemFunctionConstExpression - returns TRUE if this procedure
                                           is legal in a constant expression.
*)

PROCEDURE IsPseudoSystemFunctionConstExpression (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym=Size) OR (sym=TSize) OR (sym=Rotate) OR (sym=Shift) OR
          (Iso AND ((sym=Cast) OR (sym=MakeAdr)))
         )
END IsPseudoSystemFunctionConstExpression ;


(*
   IsPseudoSystemProcedure - returns true if sym is a SYSTEM pseudo procedure.
*)

PROCEDURE IsPseudoSystemProcedure (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN( sym=Throw )
END IsPseudoSystemProcedure ;


(*
   IsSystemType - returns TRUE if sym is a SYSTEM (inbuilt) type.
                  It does not search your SYSTEM implementation module.
*)

PROCEDURE IsSystemType (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN( IsItemInList(SystemTypes, sym) )
END IsSystemType ;


(*
   GetSafeSystem -
*)

PROCEDURE GetSafeSystem (name: Name) : CARDINAL ;
VAR
   sym,
   i, n: CARDINAL ;
BEGIN
   n := NoOfItemsInList(SystemTypes) ;
   i := 1 ;
   WHILE i<=n DO
      sym := GetItemFromList(SystemTypes, i) ;
      IF GetSymName(sym)=name
      THEN
         RETURN( sym )
      END ;
      INC(i)
   END ;
   RETURN( NulSym )
END GetSafeSystem ;


(*
   IntegerN - returns the symbol associated with INTEGER[N].
              NulSym is returned if the type does not exist.
*)

PROCEDURE IntegerN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   8 :  RETURN( GetSafeSystem(MakeKey('INTEGER8')) ) |
   16:  RETURN( GetSafeSystem(MakeKey('INTEGER16')) ) |
   32:  RETURN( GetSafeSystem(MakeKey('INTEGER32')) ) |
   64:  RETURN( GetSafeSystem(MakeKey('INTEGER64')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END IntegerN ;


(*
   CardinalN - returns the symbol associated with CARDINAL[N].
               NulSym is returned if the type does not exist.
*)

PROCEDURE CardinalN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   8 :  RETURN( GetSafeSystem(MakeKey('CARDINAL8')) ) |
   16:  RETURN( GetSafeSystem(MakeKey('CARDINAL16')) ) |
   32:  RETURN( GetSafeSystem(MakeKey('CARDINAL32')) ) |
   64:  RETURN( GetSafeSystem(MakeKey('CARDINAL64')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END CardinalN ;


(*
   WordN - returns the symbol associated with WORD[N].
           NulSym is returned if the type does not exist.
*)

PROCEDURE WordN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   16:  RETURN( GetSafeSystem(MakeKey('WORD16')) ) |
   32:  RETURN( GetSafeSystem(MakeKey('WORD32')) ) |
   64:  RETURN( GetSafeSystem(MakeKey('WORD64')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END WordN ;


(*
   SetN - returns the symbol associated with SET[N].
          NulSym is returned if the type does not exist.
*)

PROCEDURE SetN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   8 :  RETURN( GetSafeSystem(MakeKey('BITSET8')) ) |
   16:  RETURN( GetSafeSystem(MakeKey('BITSET16')) ) |
   32:  RETURN( GetSafeSystem(MakeKey('BITSET32')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END SetN ;


(*
   RealN - returns the symbol associated with REAL[N].
           NulSym is returned if the type does not exist.
*)

PROCEDURE RealN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   32 :  RETURN( GetSafeSystem(MakeKey('REAL32')) ) |
   64 :  RETURN( GetSafeSystem(MakeKey('REAL64')) ) |
   96 :  RETURN( GetSafeSystem(MakeKey('REAL96')) ) |
   128:  RETURN( GetSafeSystem(MakeKey('REAL128')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END RealN ;


(*
   ComplexN - returns the symbol associated with COMPLEX[N].
              NulSym is returned if the type does not exist.
*)

PROCEDURE ComplexN (bitlength: CARDINAL) : CARDINAL ;
BEGIN
   CASE bitlength OF

   32 :  RETURN( GetSafeSystem(MakeKey('COMPLEX32')) ) |
   64 :  RETURN( GetSafeSystem(MakeKey('COMPLEX64')) ) |
   96 :  RETURN( GetSafeSystem(MakeKey('COMPLEX96')) ) |
   128:  RETURN( GetSafeSystem(MakeKey('COMPLEX128')) )

   ELSE
      InternalError ('system does not know about this type')
   END
END ComplexN ;


(*
   IsIntegerN - returns the TRUE if, sym, is one of the SYSTEM
                INTEGER types (not the base INTEGER type).
*)

PROCEDURE IsIntegerN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=IntegerN(8)) OR (sym=IntegerN(16)) OR
           (sym=IntegerN(32)) OR (sym=IntegerN(64)))
         )
END IsIntegerN ;


(*
   IsCardinalN - returns the TRUE if, sym, is one of the SYSTEM
                 CARDINAL types (not the base CARDINAL type).
*)

PROCEDURE IsCardinalN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=CardinalN(8)) OR (sym=CardinalN(16)) OR
           (sym=CardinalN(32)) OR (sym=CardinalN(64)))
         )
END IsCardinalN ;


(*
   IsWordN - returns the TRUE if, sym, is one of the SYSTEM
             WORD[n] types (not the default SYSTEM WORD type).
*)

PROCEDURE IsWordN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=WordN(16)) OR
           (sym=WordN(32)) OR (sym=WordN(64)))
         )
END IsWordN ;


(*
   IsSetN - returns the TRUE if, sym, is one of the SYSTEM
            SET[n] types (not the default SYSTEM BITSET type).
*)

PROCEDURE IsSetN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=SetN(8)) OR (sym=SetN(16)) OR (sym=SetN(32)))
         )
END IsSetN ;


(*
   IsRealN - returns the TRUE if, sym, is one of the SYSTEM
             REAL[n] types (not the default base REAL type).
*)

PROCEDURE IsRealN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=RealN(32)) OR (sym=RealN(64)) OR
           (sym=RealN(96)) OR (sym=RealN(128)))
         )
END IsRealN ;


(*
   IsComplexN - returns the TRUE if, sym, is one of the SYSTEM
                COMPLEX[n] types (not the default base COMPLEX,
                LONGCOMPLEX or SHORTCOMPLEX types).
*)

PROCEDURE IsComplexN (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          ((sym=ComplexN(32)) OR (sym=ComplexN(64)) OR
           (sym=ComplexN(96)) OR (sym=ComplexN(128)))
         )
END IsComplexN ;


(*
   IsGenericSystemType - returns TRUE if, sym, is of type
                         BYTE, WORD or any other length.
*)

PROCEDURE IsGenericSystemType (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN(
          (sym#NulSym) AND
          (IsWordN(sym) OR (sym=Word) OR (sym=Byte) OR (sym=Loc))
         )
END IsGenericSystemType ;


(*
   IsSameSize - return TRUE if SIZE(a)=SIZE(b)
*)

PROCEDURE IsSameSize (a, b: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN( AreConstantsEqual(BuildSize(BuiltinsLocation(), Mod2Gcc(a), FALSE),
                             BuildSize(BuiltinsLocation(), Mod2Gcc(b), FALSE)) )
END IsSameSize ;


(*
   IsSameType - returns TRUE if, t, is the same type as a or b
                and a or b are a type, p.
*)

PROCEDURE IsSameType (t: CARDINAL; p: IsP; a, b: CARDINAL) : BOOLEAN ;
BEGIN
   IF t=a
   THEN
      RETURN( p(b) AND IsSameSize(a, b) )
   ELSIF t=b
   THEN
      RETURN( p(a) AND IsSameSize(a, b) )
   ELSE
      RETURN( FALSE )
   END
END IsSameType ;


(*
   IsSameSizePervasiveType - returns TRUE if a or b are CARDINAL, INTEGER, REAL,
                             LONGREAL, SHORTREAL and the other type is the same
                             size and of the same type.
*)

PROCEDURE IsSameSizePervasiveType (a, b: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN( IsSameType(Integer, IsIntegerN, a, b) OR
           IsSameType(Cardinal, IsCardinalN, a, b) OR
           IsSameType(Word, IsWordN, a, b) OR
           IsSameType(Real, IsRealN, a, b) OR
           IsSameType(Complex, IsComplexN, a, b) OR
           IsSameType(LongInt, IsIntegerN, a, b) OR
           IsSameType(LongCard, IsCardinalN, a, b) OR
           IsSameType(LongComplex, IsComplexN, a, b) OR
           IsSameType(LongReal, IsRealN, a, b) OR
           IsSameType(ShortInt, IsIntegerN, a, b) OR
           IsSameType(ShortCard, IsCardinalN, a, b) OR
           IsSameType(ShortComplex, IsComplexN, a, b) OR
           IsSameType(ShortReal, IsRealN, a, b) )
END IsSameSizePervasiveType ;


END M2System.