diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod index 7a889bd5d8b..7fcfe1b4072 100644 --- a/gcc/m2/gm2-compiler/M2CaseList.mod +++ b/gcc/m2/gm2-compiler/M2CaseList.mod @@ -27,10 +27,10 @@ FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin, GetTypeMax ; 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 ; @@ -44,7 +44,8 @@ FROM NumberIO IMPORT WriteCard ; 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 @@ -64,6 +65,7 @@ TYPE END ; CaseDescriptor = POINTER TO RECORD + resolved : BOOLEAN ; elseClause : BOOLEAN ; elseField : CARDINAL ; record : CARDINAL ; @@ -110,6 +112,7 @@ BEGIN InternalError ('out of memory error') ELSE WITH c^ DO + resolved := FALSE ; elseClause := FALSE ; elseField := NulSym ; record := rec ; @@ -244,7 +247,30 @@ END GetVariantTagType ; 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 ; @@ -327,7 +353,62 @@ BEGIN 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 ; (* @@ -439,6 +520,26 @@ BEGIN 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. @@ -488,15 +589,15 @@ VAR 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 @@ -1121,27 +1222,24 @@ BEGIN 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 diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index 2680faad7b6..d084096148f 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -1934,7 +1934,7 @@ BEGIN IF IsConstStringKnown (sym) THEN size := GetStringLength (tokenno, sym) ; - IF size=1 + IF size = 1 THEN DeclareCharConstant (tokenno, sym) ELSE @@ -5570,7 +5570,7 @@ BEGIN IF IsConstString (low) AND IsConstStringKnown (low) THEN size := GetStringLength (tokenno, low) ; - IF size=1 + IF size <= 1 THEN PutSubrange(sym, low, high, Char) ELSE diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index c5f5a782595..5811c9d7794 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -6420,12 +6420,12 @@ PROCEDURE BuildHighFromString (operand: CARDINAL) : tree ; 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 ; @@ -6765,96 +6765,102 @@ PROCEDURE PopKindTree (op: CARDINAL; tokenno: CARDINAL) : tree ; VAR type: CARDINAL ; BEGIN - type := SkipType (GetType (op)) ; - IF IsSet (type) + IF IsConst (op) AND IsConstString (op) THEN - RETURN( PopSetTree (tokenno) ) - ELSIF IsRealType (type) - 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 diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index a502fb57641..56a04a9106a 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -26,6 +26,7 @@ FROM SYSTEM IMPORT ADDRESS, ADR ; FROM Storage IMPORT ALLOCATE, DEALLOCATE ; FROM M2Debug IMPORT Assert ; FROM libc IMPORT printf ; +FROM ASCII IMPORT nul ; IMPORT Indexing ; @@ -14958,12 +14959,15 @@ BEGIN 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 diff --git a/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod b/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod new file mode 100644 index 00000000000..a20dc4e884b --- /dev/null +++ b/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod @@ -0,0 +1,8 @@ +MODULE forloopnulchar ; + +VAR + ch: CHAR ; +BEGIN + FOR ch := '' TO 'z' DO + END +END forloopnulchar. diff --git a/gcc/testsuite/gm2/pim/pass/nulcharcase.mod b/gcc/testsuite/gm2/pim/pass/nulcharcase.mod new file mode 100644 index 00000000000..9d3bbdcf194 --- /dev/null +++ b/gcc/testsuite/gm2/pim/pass/nulcharcase.mod @@ -0,0 +1,16 @@ +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. diff --git a/gcc/testsuite/gm2/pim/pass/nulcharvar.mod b/gcc/testsuite/gm2/pim/pass/nulcharvar.mod new file mode 100644 index 00000000000..846cbe6b588 --- /dev/null +++ b/gcc/testsuite/gm2/pim/pass/nulcharvar.mod @@ -0,0 +1,7 @@ +MODULE nulcharvar ; + +VAR + ch: CHAR ; +BEGIN + ch := '' +END nulcharvar.