(* 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.