FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorStringT0, MetaErrorString1 ;
FROM M2Error IMPORT InternalError ;
FROM M2Range IMPORT OverlapsRange, IsEqual, IsGreater ;
-FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt ;
+FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt, PushCard ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInIndexDo, HighIndice ;
FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList ;
-FROM NameKey IMPORT KeyToCharStar ;
+FROM NameKey IMPORT NulName, KeyToCharStar ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar, ConCat, Mark, KillString ;
FROM gcctypes IMPORT tree ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth,
- IsSubrange ;
+ IsSubrange, MakeConstLit, IsConstString, GetStringLength, MakeConstVar, PutConst,
+ PopValue ;
TYPE
RangePair = POINTER TO RECORD
END ;
CaseDescriptor = POINTER TO RECORD
+ resolved : BOOLEAN ;
elseClause : BOOLEAN ;
elseField : CARDINAL ;
record : CARDINAL ;
InternalError ('out of memory error')
ELSE
WITH c^ DO
+ resolved := FALSE ;
elseClause := FALSE ;
elseField := NulSym ;
record := rec ;
PROCEDURE CaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
VAR
- resolved: BOOLEAN ;
+ p: CaseDescriptor ;
+BEGIN
+ p := GetIndice (caseArray, c) ;
+ IF p^.resolved
+ THEN
+ RETURN TRUE
+ ELSE
+ IF CheckCaseBoundsResolved (tokenno, c)
+ THEN
+ ConvertNulStr2NulChar (tokenno, c) ;
+ RETURN TRUE
+ ELSE
+ RETURN FALSE
+ END
+ END
+END CaseBoundsResolved ;
+
+
+(*
+ CheckCaseBoundsResolved - return TRUE if all constants in the case list c are known to GCC.
+*)
+
+PROCEDURE CheckCaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
+VAR
p : CaseDescriptor ;
q : CaseList ;
r : RangePair ;
END
END ;
RETURN( TRUE )
-END CaseBoundsResolved ;
+END CheckCaseBoundsResolved ;
+
+
+(*
+ ConvertNulStr2NulChar -
+*)
+
+PROCEDURE ConvertNulStr2NulChar (tokenno: CARDINAL; c: CARDINAL) ;
+VAR
+ p : CaseDescriptor ;
+ q : CaseList ;
+ r : RangePair ;
+ i, j: CARDINAL ;
+BEGIN
+ p := GetIndice (caseArray, c) ;
+ WITH p^ DO
+ i := 1 ;
+ WHILE i <= maxCaseId DO
+ q := GetIndice (caseListArray, i) ;
+ j := 1 ;
+ WHILE j<=q^.maxRangeId DO
+ r := GetIndice (q^.rangeArray, j) ;
+ r^.low := NulStr2NulChar (tokenno, r^.low) ;
+ r^.high := NulStr2NulChar (tokenno, r^.high) ;
+ INC (j)
+ END ;
+ INC (i)
+ END
+ END
+END ConvertNulStr2NulChar ;
+
+
+(*
+ NulStr2NulChar - if sym is a const string of length 0 then return
+ a nul char instead otherwise return sym.
+*)
+
+PROCEDURE NulStr2NulChar (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+BEGIN
+ IF sym # NulSym
+ THEN
+ IF IsConst (sym) AND IsConstString (sym) AND GccKnowsAbout (sym)
+ THEN
+ IF GetStringLength (tok, sym) = 0
+ THEN
+ sym := MakeConstVar (tok, NulName) ;
+ PutConst (sym, Char) ;
+ PushCard (0) ;
+ PopValue (sym) ;
+ TryDeclareConstant (tok, sym) ;
+ Assert (GccKnowsAbout (sym))
+ END
+ END
+ END ;
+ RETURN sym
+END NulStr2NulChar ;
(*
END Overlaps ;
+(*
+ GetCaseExpression - return the type from the expression.
+*)
+
+PROCEDURE GetCaseExpression (p: CaseDescriptor) : CARDINAL ;
+VAR
+ type: CARDINAL ;
+BEGIN
+ WITH p^ DO
+ IF expression = NulSym
+ THEN
+ type := NulSym
+ ELSE
+ type := SkipType (GetType (expression))
+ END
+ END ;
+ RETURN type
+END GetCaseExpression ;
+
+
(*
OverlappingCaseBound - returns TRUE if, r, overlaps any case bound in the
case statement, c.
i, j : CARDINAL ;
overlap: BOOLEAN ;
BEGIN
- p := GetIndice(caseArray, c) ;
+ p := GetIndice (caseArray, c) ;
overlap := FALSE ;
WITH p^ DO
i := 1 ;
WHILE i<=maxCaseId DO
- q := GetIndice(caseListArray, i) ;
+ q := GetIndice (caseListArray, i) ;
j := 1 ;
WHILE j<=q^.maxRangeId DO
- r := GetIndice(q^.rangeArray, j) ;
+ r := GetIndice (q^.rangeArray, j) ;
IF OverlappingCaseBound (r, c)
THEN
overlap := TRUE
WITH p^ DO
IF NOT elseClause
THEN
- IF expression # NulSym
+ type := GetCaseExpression (p) ;
+ IF type # NulSym
THEN
- type := SkipType (GetType (expression)) ;
- IF type # NulSym
+ IF IsEnumeration (type) OR IsSubrange (type)
THEN
- IF IsEnumeration (type) OR IsSubrange (type)
+ (* A case statement sequence without an else clause but
+ selecting using an enumeration type. *)
+ set := NewSet (type) ;
+ set := ExcludeCaseRanges (set, p) ;
+ IF set # NIL
THEN
- (* A case statement sequence without an else clause but
- selecting using an enumeration type. *)
- set := NewSet (type) ;
- set := ExcludeCaseRanges (set, p) ;
- IF set # NIL
- THEN
- missing := TRUE ;
- MetaErrorT1 (tokenno,
- 'not all {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause',
- type) ;
- EmitMissingRangeErrors (tokenno, type, set)
- END ;
- set := DisposeRanges (set)
- END
+ missing := TRUE ;
+ MetaErrorT1 (tokenno,
+ 'not all {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause',
+ type) ;
+ EmitMissingRangeErrors (tokenno, type, set)
+ END ;
+ set := DisposeRanges (set)
END
END
END
IF IsConstStringKnown (sym)
THEN
size := GetStringLength (tokenno, sym) ;
- IF size=1
+ IF size = 1
THEN
DeclareCharConstant (tokenno, sym)
ELSE
IF IsConstString (low) AND IsConstStringKnown (low)
THEN
size := GetStringLength (tokenno, low) ;
- IF size=1
+ IF size <= 1
THEN
PutSubrange(sym, low, high, Char)
ELSE
VAR
location: location_t ;
BEGIN
- location := TokenToLocation(GetDeclaredMod(operand)) ;
- IF GccKnowsAbout(operand) AND (StringLength(Mod2Gcc(operand))>0)
+ location := TokenToLocation (GetDeclaredMod (operand)) ;
+ IF GccKnowsAbout (operand) AND (StringLength (Mod2Gcc (operand)) > 0)
THEN
- RETURN( BuildIntegerConstant(StringLength(Mod2Gcc(operand))-1) )
+ RETURN( BuildIntegerConstant (StringLength (Mod2Gcc (operand))-1) )
ELSE
- RETURN( GetIntegerZero(location) )
+ RETURN( GetIntegerZero (location) )
END
END BuildHighFromString ;
VAR
type: CARDINAL ;
BEGIN
- type := SkipType (GetType (op)) ;
- IF IsSet (type)
- THEN
- RETURN( PopSetTree (tokenno) )
- ELSIF IsRealType (type)
+ IF IsConst (op) AND IsConstString (op)
THEN
- RETURN( PopRealTree () )
+ (* Converting a nul char or char for example. *)
+ RETURN PopIntegerTree ()
ELSE
- RETURN( PopIntegerTree () )
+ type := SkipType (GetType (op)) ;
+ IF IsSet (type)
+ THEN
+ RETURN( PopSetTree (tokenno) )
+ ELSIF IsRealType (type)
+ THEN
+ RETURN( PopRealTree () )
+ ELSE
+ RETURN( PopIntegerTree () )
+ END
END
END PopKindTree ;
(*
- FoldConvert - attempts to fold op3 to type op2 placing the result into
- op1, providing that op1 and op3 are constants.
- Convert will, if need be, alter the machine representation
- of op3 to comply with TYPE op2.
+ FoldConvert - attempts to fold expr to type into result
+ providing that result and expr are constants.
+ If required convert will alter the machine representation
+ of expr to comply with type.
*)
PROCEDURE FoldConvert (tokenno: CARDINAL; p: WalkAction;
- quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+ quad: CARDINAL; result, type, expr: CARDINAL) ;
VAR
tl : tree ;
location: location_t ;
BEGIN
- location := TokenToLocation(tokenno) ;
- (* firstly ensure that constant literals are declared *)
- TryDeclareConstant(tokenno, op3) ;
- IF IsConstant(op3)
+ location := TokenToLocation (tokenno) ;
+ (* First ensure that constant literals are declared. *)
+ TryDeclareConstant (tokenno, expr) ;
+ IF IsConstant (expr)
THEN
- IF GccKnowsAbout(op2) AND
- (IsProcedure(op3) OR IsValueSolved(op3)) AND
- GccKnowsAbout(SkipType(op2))
+ IF GccKnowsAbout (type) AND
+ (IsProcedure (expr) OR IsValueSolved (expr)) AND
+ GccKnowsAbout (SkipType (type))
THEN
- (* fine, we can take advantage of this and fold constant *)
- IF IsConst(op1)
+ (* The type is known and expr is resolved so fold the convert. *)
+ IF IsConst (result)
THEN
- PutConst(op1, op2) ;
- tl := Mod2Gcc(SkipType(op2)) ;
- IF IsProcedure(op3)
+ PutConst (result, type) ; (* Change result type just in case. *)
+ tl := Mod2Gcc (SkipType (type)) ;
+ IF IsProcedure (expr)
THEN
- AddModGcc(op1, BuildConvert(location, tl, Mod2Gcc(op3), TRUE))
+ AddModGcc (result, BuildConvert (location, tl, Mod2Gcc (expr), TRUE))
ELSE
- PushValue(op3) ;
- IF IsConstSet(op3)
+ PushValue (expr) ;
+ IF IsConstSet (expr)
THEN
- IF IsSet(SkipType(op2))
+ IF IsSet (SkipType (type))
THEN
- WriteFormat0('cannot convert values between sets')
+ WriteFormat0 ('cannot convert values between sets')
ELSE
- PushIntegerTree(FoldAndStrip(BuildConvert(location, tl, PopSetTree(tokenno), TRUE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopIntegerTree())
+ PushIntegerTree (FoldAndStrip (BuildConvert (location, tl, PopSetTree (tokenno), TRUE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopIntegerTree())
END
ELSE
- IF IsSet(SkipType(op2))
+ IF IsSet (SkipType (type))
THEN
- PushSetTree(tokenno,
- FoldAndStrip(BuildConvert(location, tl, PopKindTree(op3, tokenno),
- TRUE)), SkipType(op2)) ;
- PopValue(op1) ;
- PutConstSet(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopSetTree(tokenno))
- ELSIF IsRealType(SkipType(op2))
+ PushSetTree (tokenno,
+ FoldAndStrip (BuildConvert (location, tl, PopKindTree (expr, tokenno),
+ TRUE)), SkipType (type)) ;
+ PopValue (result) ;
+ PutConstSet (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopSetTree (tokenno))
+ ELSIF IsRealType (SkipType (type))
THEN
- PushRealTree(FoldAndStrip(BuildConvert(location, tl, PopKindTree(op3, tokenno),
- TRUE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopKindTree(op1, tokenno))
+ PushRealTree (FoldAndStrip (BuildConvert (location, tl, PopKindTree (expr, tokenno),
+ TRUE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopKindTree (result, tokenno))
ELSE
- (* we let CheckOverflow catch a potential overflow rather than BuildConvert *)
- PushIntegerTree(FoldAndStrip(BuildConvert(location, tl,
- PopKindTree(op3, tokenno),
- FALSE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- CheckOrResetOverflow(tokenno, PopKindTree(op1, tokenno), MustCheckOverflow(quad)) ;
- PushValue(op1) ;
- AddModGcc(op1, PopKindTree(op1, tokenno))
+ (* Let CheckOverflow catch a potential overflow rather than BuildConvert. *)
+ PushIntegerTree (FoldAndStrip (BuildConvert (location, tl,
+ PopKindTree (expr, tokenno),
+ FALSE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ CheckOrResetOverflow (tokenno, PopKindTree (result, tokenno), MustCheckOverflow (quad)) ;
+ PushValue (result) ;
+ AddModGcc (result, PopKindTree (result, tokenno))
END
END
END ;
- p(op1) ;
+ p (result) ;
NoChange := FALSE ;
- SubQuad(quad)
+ SubQuad (quad)
END
END
END
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM M2Debug IMPORT Assert ;
FROM libc IMPORT printf ;
+FROM ASCII IMPORT nul ;
IMPORT Indexing ;
CASE SymbolType OF
ConstStringSym: WITH ConstString DO
- IF Length = 1
+ IF Length = 0
+ THEN
+ PushChar (nul)
+ ELSIF Length = 1
THEN
GetKey (Contents, a) ;
PushChar (a[0])
ELSE
- WriteFormat0 ('ConstString must be length 1')
+ WriteFormat0 ('ConstString must be length 0 or 1')
END
END
--- /dev/null
+MODULE forloopnulchar ;
+
+VAR
+ ch: CHAR ;
+BEGIN
+ FOR ch := '' TO 'z' DO
+ END
+END forloopnulchar.
--- /dev/null
+MODULE nulcharcase ;
+
+FROM libc IMPORT printf ;
+
+VAR
+ ch: CHAR;
+BEGIN
+ ch := '';
+ CASE ch OF
+
+ '' : printf ("null char seen\n") |
+ '1': printf ("1\n")
+
+ ELSE
+ END
+END nulcharcase.
--- /dev/null
+MODULE nulcharvar ;
+
+VAR
+ ch: CHAR ;
+BEGIN
+ ch := ''
+END nulcharvar.
projects / thirdparty / gcc.git / commitdiff
