diff options
Diffstat (limited to 'gcc/m2')
45 files changed, 2595 insertions, 568 deletions
diff --git a/gcc/m2/ChangeLog b/gcc/m2/ChangeLog index 058468b..f7254f9 100644 --- a/gcc/m2/ChangeLog +++ b/gcc/m2/ChangeLog @@ -1,3 +1,231 @@ +2025-07-01 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120912 + * gm2-libs-iso/IOChanUtils.def (GetFile): New procedure function. + * gm2-libs-iso/IOChanUtils.mod (GetFile): New procedure function. + +2025-06-29 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/117203 + * gm2-libs-log/FileSystem.def (GetFileName): New + procedure function. + (WriteString): New procedure. + * gm2-libs-log/FileSystem.mod (GetFileName): New + procedure function. + (WriteString): New procedure. + * gm2-libs/SFIO.def (GetFileName): New procedure function. + * gm2-libs/SFIO.mod (GetFileName): New procedure function. + * gm2-libs-iso/IOChanUtils.def: New file. + * gm2-libs-iso/IOChanUtils.mod: New file. + +2025-06-22 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120731 + * gm2-libs-log/Strings.def (Delete): Rewrite comment. + * gm2-libs-log/Strings.mod (Pos): Rewrite. + (PosLower): New procedure function. + +2025-06-21 Gaius Mulley <gaiusmod2@gmail.com> + + * gm2-compiler/M2GCCDeclare.mod (StartDeclareModuleScopeSeparate): + Reformat statement comments. + (StartDeclareModuleScopeWholeProgram): Ditto. + +2025-06-17 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120673 + * gm2-compiler/M2GCCDeclare.mod (ErrorDepList): New + global variable set containing every errant dependency symbol. + (mystop): Remove. + (EmitCircularDependancyError): Replace with ... + (EmitCircularDependencyError): ... this. + (AssertAllTypesDeclared): Rewrite. + (DoVariableDeclaration): Ditto. + (TypeDependentsDeclared): New procedure function. + (PrepareGCCVarDeclaration): Ditto. + (DeclareVariable): Remove assert. + (DeclareLocalVariable): Ditto. + (Constructor): Initialize ErrorDepList. + * gm2-compiler/M2MetaError.mod (doErrorScopeProc): Rewrite + and ensure that a symbol with a module scope does not lookup + from a definition module. + * gm2-compiler/P2SymBuild.mod (BuildType): Rewrite so that + a synonym type is created using the token refering to the name + on the lhs. + +2025-06-12 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119650 + * gm2-libs/ARRAYOFCHAR.def: Remove comment about non + existent read. + * target-independent/m2/Builtins.texi: Regenerate. + * target-independent/m2/SYSTEM-iso.texi: Ditto. + * target-independent/m2/SYSTEM-pim.texi: Ditto. + * target-independent/m2/gm2-libs.texi: Ditto. + +2025-06-09 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120606 + * gm2-compiler/M2Quads.mod (ForLoopLastIterator): Dereference + start and end expressions e1 and e2 respectively. + +2025-06-07 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119650 + PR modula2/117203 + * gm2-compiler/P2Build.bnf (CheckModuleQualident): New + procedure. + (Qualident): Rewrite. + * gm2-compiler/P3Build.bnf (PushTFQualident): New procedure. + (CheckModuleQualident): Ditto. + (Qualident): Rewrite. + * gm2-compiler/PCBuild.bnf (PushTFQualident): New procedure. + (CheckModuleQualident): Ditto. + (Qualident): Rewrite. + * gm2-compiler/PHBuild.bnf (PushTFQualident): New procedure. + (CheckModuleQualident): Ditto. + (Qualident): Rewrite. + * gm2-libs/ARRAYOFCHAR.def: New file. + * gm2-libs/ARRAYOFCHAR.mod: New file. + * gm2-libs/CFileSysOp.def: New file. + * gm2-libs/CHAR.def: New file. + * gm2-libs/CHAR.mod: New file. + * gm2-libs/FileSysOp.def: New file. + * gm2-libs/FileSysOp.mod: New file. + * gm2-libs/String.def: New file. + * gm2-libs/String.mod: New file. + * gm2-libs/StringFileSysOp.def: New file. + * gm2-libs/StringFileSysOp.mod: New file. + +2025-06-06 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120542 + * gm2-compiler/M2Quads.mod (BuildReturnLower): New procedure. + (BuildReturn): Allow return without an expression from + module initialization blocks. Generate an error if an + expression is provided. Call BuildReturnLower if no error + was seen. + +2025-06-01 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120474 + * gm2-libs-log/InOut.mod (LocalWrite): Call FIO.FlushBuffer. + +2025-06-01 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120497 + * gm2-compiler/M2Range.mod (IsAssignmentCompatible): Remove from + import list. + (FoldTypeReturnFunc): Rewrite to skip the Lvalue of a var + variable. + (CodeTypeReturnFunc): Ditto. + (CodeTypeIndrX): Call AssignmentTypeCompatible rather than + IsAssignmentCompatible. + (FoldTypeIndrX): Ditto. + +2025-05-31 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120389 + * gm2-compiler/M2Check.def (AssignmentTypeCompatible): Add new + parameter enableReason. + * gm2-compiler/M2Check.mod (EquivalenceProcedure): New type. + (falseReason2): New procedure function. + (falseReason1): Ditto. + (falseReason0): Ditto. + (checkTypeEquivalence): Rewrite. + (checkUnboundedArray): Ditto. + (checkUnbounded): Ditto. + (checkArrayTypeEquivalence): Ditto. + (checkCharStringTypeEquivalence): Ditto. + (buildError4): Add false reason. + (buildError2): Ditto. + (IsTyped): Use GetDType. + (IsTypeEquivalence): New procedure function. + (checkVarTypeEquivalence): Ditto. + (checkVarEquivalence ): Rewrite. + (checkConstMeta): Ditto. + (checkEnumField): New procedure function. + (checkEnumFieldEquivalence): Ditto. + (checkSubrangeTypeEquivalence): Rewrite. + (checkSystemEquivalence): Ditto. + (checkTypeKindViolation): Ditto. + (doCheckPair): Ditto. + (InitEquivalenceArray): New procedure. + (addEquivalence): Ditto. + (checkProcType): Rewrite. + (deconstruct): Deallocate reason string. + (AssignmentTypeCompatible): Initialize reason and reasonEnable + fields. + (ParameterTypeCompatible): Ditto. + (doExpressionTypeCompatible): Ditto. + * gm2-compiler/M2GenGCC.mod (CodeIndrX) Rewrite. + (CheckBinaryExpressionTypes): Rewrite and simplify now that the + type checker is more robust. + (CheckElementSetTypes): Ditto. + (CodeXIndr): Add new range assignment type check. + * gm2-compiler/M2MetaError.def: Correct comments. + * gm2-compiler/M2Options.def (SetStrictTypeAssignment): New procedure. + (SetStrictTypeReason): Ditto. + * gm2-compiler/M2Options.mod: (SetStrictTypeAssignment): New procedure. + (SetStrictTypeReason): Ditto. + (StrictTypeReason): Initialize. + (StrictTypeAssignment): Ditto. + * gm2-compiler/M2Quads.mod (CheckBreak): Delete. + (BreakQuad): New global variable. + (BreakAtQuad): Delete. + (gdbhook): New procedure. + (BreakWhenQuadCreated): Ditto. + (CheckBreak): Ditto. + (Init): Call BreakWhenQuadCreated and gdbhook. + (doBuildAssignment): Add type assignment range check. + (CheckProcTypeAndProcedure): Only check if the procedure + types differ. + (doIndrX): Add type IndrX range check. + (CheckReturnType): Add range return type check. + * gm2-compiler/M2Range.def (InitTypesIndrXCheck): New procedure + function. + (InitTypesReturnTypeCheck): Ditto. + * gm2-compiler/M2Range.mod (InitTypesIndrXCheck): New procedure + function. + (InitTypesReturnTypeCheck): Ditto. + (HandlerExists): Add new clauses. + (FoldAssignment): Pass extra FALSE parameter to + AssignmentTypeCompatible. + (FoldTypeReturnFunc): New procedure. + (FoldTypeAssign): Ditto. + (FoldTypeIndrX): Ditto. + (CodeTypeAssign): Rewrite. + (CodeTypeIndrX): New procedure. + (CodeTypeReturnFunc): Ditto. + (FoldTypeCheck): Add new case clauses. + (CodeTypeCheck): Ditto. + (FoldRangeCheckLower): Ditto. + (IssueWarning): Ditto. + * gm2-gcc/m2options.h (M2Options_SetStrictTypeAssignment): New + function prototype. + (M2Options_SetStrictTypeReason): Ditto. + * gm2-lang.cc (gm2_langhook_handle_option): New case clause + OPT_fm2_strict_type_reason. + * lang.opt (-fm2-strict-type-reason): New option. + +2025-05-22 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120389 + * gm2-compiler/M2GenGCC.mod (CodeXIndr): Check to see that + the type of left is assignment compatible with the type of + right. + +2025-05-13 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/120253 + * m2.flex (FIRST_COLUMN): New define. + (updatepos): Remove commented code. + (consumeLine): Assign column to FIRST_COLUMN. + (initLine): Ditto. + (m2flex_GetColumnNo): Return FIRST_COLUMN if currentLine is NULL. + (m2flex_GetLineNo): Rewrite for positive logic. + (m2flex_GetLocation): Ditto. + 2025-05-05 Gaius Mulley <gaiusmod2@gmail.com> PR modula2/120117 diff --git a/gcc/m2/gm2-compiler/M2Check.def b/gcc/m2/gm2-compiler/M2Check.def index 0ceb173..9d9f760 100644 --- a/gcc/m2/gm2-compiler/M2Check.def +++ b/gcc/m2/gm2-compiler/M2Check.def @@ -50,7 +50,8 @@ PROCEDURE ParameterTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; *) PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; - des, expr: CARDINAL) : BOOLEAN ; + des, expr: CARDINAL; + enableReason: BOOLEAN) : BOOLEAN ; (* diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index d86ef8e..614526c 100644 --- a/gcc/m2/gm2-compiler/M2Check.mod +++ b/gcc/m2/gm2-compiler/M2Check.mod @@ -36,26 +36,33 @@ FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ; FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ; FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ; FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ; -FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4, MetaError1 ; + +FROM M2MetaError IMPORT MetaErrorStringT0, MetaErrorStringT2, MetaErrorStringT3, + MetaErrorStringT4, + MetaString0, MetaString1, MetaString2, MetaString3, + MetaString4, + MetaError0, MetaError1 ; + FROM StrLib IMPORT StrEqual ; FROM M2Debug IMPORT Assert ; -FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType, +FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetType, IsType, SkipType, IsProcedure, NoOfParamAny, IsVarParamAny, GetNth, GetNthParamAny, IsProcType, IsVar, IsEnumeration, IsArray, IsSubrange, GetArraySubscript, IsConst, IsReallyPointer, IsPointer, IsParameter, ModeOfAddr, - GetMode, GetType, IsUnbounded, IsComposite, IsConstructor, + GetMode, IsUnbounded, IsComposite, IsConstructor, IsParameter, IsConstString, IsConstLitInternal, IsConstLit, GetStringLength, GetProcedureProcType, IsHiddenType, - IsHiddenReallyPointer, GetDimension ; + IsHiddenReallyPointer, GetDimension, IsFieldEnumeration ; FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ; FROM M2System IMPORT Address ; FROM M2ALU IMPORT Equ, PushIntegerTree ; +FROM M2Options IMPORT StrictTypeReason ; FROM m2expr IMPORT AreConstantsEqual ; -FROM SymbolConversion IMPORT Mod2Gcc ; -FROM DynamicStrings IMPORT String, InitString, KillString ; +FROM SymbolConversion IMPORT Mod2Gcc, GccKnowsAbout ; +FROM DynamicStrings IMPORT String, InitString, KillString, ConCat, Mark ; FROM M2LexBuf IMPORT GetTokenNo ; FROM Storage IMPORT ALLOCATE ; FROM SYSTEM IMPORT ADR ; @@ -63,7 +70,8 @@ FROM libc IMPORT printf ; CONST - debugging = FALSE ; + debugging = FALSE ; + MaxEquvalence = 20 ; TYPE errorSig = POINTER TO RECORD @@ -83,6 +91,8 @@ TYPE checkType = (parameter, assignment, expression) ; tInfo = POINTER TO RECORD + reasonEnable: BOOLEAN ; + reason, format : String ; kind : checkType ; token, @@ -105,11 +115,14 @@ TYPE status = (true, false, unknown, visited, unused) ; + EquivalenceProcedure = PROCEDURE (status, tInfo, CARDINAL, CARDINAL) : status ; VAR - pairFreeList : pair ; - tinfoFreeList: tInfo ; - errors : Index ; + pairFreeList : pair ; + tinfoFreeList : tInfo ; + errors : Index ; + HighEquivalence: CARDINAL ; + Equivalence : ARRAY [1..MaxEquvalence] OF EquivalenceProcedure ; (* @@ -159,6 +172,53 @@ END dumptInfo ; (* + falseReason2 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason2 (message: ARRAY OF CHAR; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString2 (InitString (message), left, right) + END ; + RETURN false +END falseReason2 ; + + +(* + falseReason1 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason1 (message: ARRAY OF CHAR; tinfo: tInfo; + operand: CARDINAL) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString1 (InitString (message), operand) + END ; + RETURN false +END falseReason1 ; + + +(* + falseReason0 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason0 (message: ARRAY OF CHAR; tinfo: tInfo) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString0 (InitString (message)) + END ; + RETURN false +END falseReason0 ; + + +(* isKnown - returns BOOLEAN:TRUE if result is status:true or status:false. *) @@ -192,31 +252,29 @@ END isFalse ; checkTypeEquivalence - returns TRUE if left and right can be skipped and found to be equal. *) -PROCEDURE checkTypeEquivalence (result: status; left, right: CARDINAL) : status ; -VAR - leftT, rightT: CARDINAL ; +PROCEDURE checkTypeEquivalence (result: status; + tinfo: tInfo; + left, right: CARDINAL) : status ; BEGIN - (* firstly check to see if we already have resolved this as false. *) - IF isFalse (result) + IF left = right THEN - RETURN result - ELSE - (* check to see if we dont care about left or right. *) - IF (left = NulSym) OR (right = NulSym) + RETURN true + ELSIF IsType (left) AND IsType (right) + THEN + IF IsHiddenType (left) AND IsHiddenType (right) + THEN + RETURN falseReason2 ('opaque types {%1a} {%2a} differ', tinfo, left, right) + ELSIF (IsHiddenType (left) AND (right = Address)) OR + (IsHiddenType (right) AND (left = Address)) THEN RETURN true - ELSE - leftT := SkipType (left) ; - rightT := SkipType (right) ; - IF leftT = rightT - THEN - RETURN true - ELSIF IsType (leftT) AND IsType (rightT) - THEN - (* the fundamental types are definitely different. *) - RETURN false - END END + ELSIF IsTypeEquivalence (left) + THEN + RETURN checkPair (result, tinfo, GetDType (left), right) + ELSIF IsTypeEquivalence (right) + THEN + RETURN checkPair (result, tinfo, left, GetDType (right)) END ; RETURN result END checkTypeEquivalence ; @@ -246,13 +304,15 @@ BEGIN PushIntegerTree (Mod2Gcc (rLow)) ; IF NOT Equ (tinfo^.token) THEN - RETURN false + RETURN falseReason2 ('low values of the subrange types {%1a} {%2a} differ', + tinfo, left, right) END ; PushIntegerTree (Mod2Gcc (lHigh)) ; PushIntegerTree (Mod2Gcc (rHigh)) ; IF NOT Equ (tinfo^.token) THEN - RETURN false + RETURN falseReason2 ('high values of the subrange types {%1a} {%2a} differ', + tinfo, left, right) END END ; RETURN true @@ -266,6 +326,7 @@ END checkSubrange ; *) PROCEDURE checkUnboundedArray (result: status; + tinfo: tInfo; unbounded, array: CARDINAL) : status ; VAR dim : CARDINAL ; @@ -280,13 +341,13 @@ BEGIN Assert (IsUnbounded (unbounded)) ; Assert (IsArray (array)) ; dim := GetDimension (unbounded) ; - ubtype := GetType (unbounded) ; + ubtype := GetDType (unbounded) ; type := array ; REPEAT - type := GetType (type) ; + type := GetDType (type) ; DEC (dim) ; (* Check type equivalences. *) - IF checkTypeEquivalence (result, type, ubtype) = true + IF checkTypeEquivalence (result, tinfo, type, ubtype) = true THEN RETURN true END ; @@ -294,11 +355,13 @@ BEGIN (* If we have run out of dimensions we conclude false. *) IF dim = 0 THEN - RETURN false + RETURN falseReason0 ('unbounded array has less dimensions than the array', + tinfo) END ; UNTIL NOT IsArray (type) END ; - RETURN false + RETURN falseReason0 ('array has less dimensions than the unbounded array', + tinfo) END checkUnboundedArray ; @@ -327,14 +390,18 @@ BEGIN referenced. We use GetDimension for 'bar' which is 2. *) IF GetDimension (formal) # GetDimension (tinfo^.actual) THEN - RETURN false + RETURN falseReason2 ('the formal parameter unbounded array {%1a} has a different number' + + ' of dimensions to the actual parameter unbounded array {%2a}', + tinfo, formal, actual) END ; - IF checkTypeEquivalence (result, GetType (formal), GetType (actual)) = true + IF checkTypeEquivalence (result, tinfo, GetType (formal), GetType (actual)) = true THEN RETURN true END END ; - RETURN false + RETURN falseReason2 ('the formal unbounded array type {%1a}' + + ' and the actual unbounded array type {%2a} differ', + tinfo, formal, actual) END checkUnboundedUnbounded ; @@ -373,10 +440,14 @@ BEGIN END ELSIF IsArray (right) THEN - RETURN checkUnboundedArray (result, unbounded, right) + RETURN checkUnboundedArray (result, tinfo, unbounded, right) ELSIF IsUnbounded (right) THEN RETURN checkUnboundedUnbounded (result, tinfo, unbounded, right) + ELSE + RETURN falseReason2 ('the formal unbounded array type {%1a}' + + ' and the actual unbounded array type {%2a} differ', + tinfo, unbounded, right) END END END ; @@ -400,7 +471,7 @@ BEGIN THEN lSub := GetArraySubscript (left) ; rSub := GetArraySubscript (right) ; - result := checkPair (result, tinfo, GetSType (left), GetSType (right)) ; + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) ; IF (lSub # NulSym) AND (rSub # NulSym) THEN result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub)) @@ -423,31 +494,58 @@ BEGIN END ELSIF IsArray (left) AND IsConst (right) THEN - result := checkPair (result, tinfo, GetType (left), GetType (right)) + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) ELSIF IsArray (right) AND IsConst (left) THEN - result := checkPair (result, tinfo, GetType (left), GetType (right)) + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) END ; RETURN result END checkArrayTypeEquivalence ; (* - checkGenericTypeEquivalence - check left and right for generic equivalence. + checkCharStringTypeEquivalence - check char and string constants for type equivalence. *) -PROCEDURE checkGenericTypeEquivalence (result: status; left, right: CARDINAL) : status ; +PROCEDURE checkCharStringTypeEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; BEGIN IF isFalse (result) THEN RETURN result - ELSIF left = right + ELSIF left = Char THEN - RETURN true - ELSE - RETURN result - END -END checkGenericTypeEquivalence ; + IF IsConst (right) + THEN + (* We might not know the length of the string yet, in which case we return true. *) + IF IsConstString (right) AND + ((NOT GccKnowsAbout (right)) OR (GetStringLength (tinfo^.token, right) <= 1)) + THEN + RETURN true + ELSE + RETURN falseReason2 ('the string {%2a} does not fit into a {%1a}', + tinfo, left, right) + END + ELSIF IsParameter (right) + THEN + right := GetDType (right) ; + IF (right = Char) OR (IsUnbounded (right) AND (SkipType (GetDType (right)) = Char)) + THEN + RETURN true + END + ELSIF IsArray (right) + THEN + IF Char = SkipType (GetDType (right)) + THEN + RETURN true + END + END + ELSIF right = Char + THEN + RETURN checkCharStringTypeEquivalence (result, tinfo, right, left) + END ; + RETURN result +END checkCharStringTypeEquivalence ; (* @@ -491,7 +589,7 @@ BEGIN THEN IF tinfo^.error = NIL THEN - (* need to create top level error message first. *) + (* We need to create top level error message first. *) tinfo^.error := NewError (tinfo^.token) ; (* The parameters to MetaString4 in buildError4 must match the order of paramters passed to ParameterTypeCompatible. *) @@ -499,9 +597,17 @@ BEGIN tinfo^.procedure, tinfo^.formal, tinfo^.actual, tinfo^.nth) ; + (* Append the overall reason for the failure. *) + IF tinfo^.reason # NIL + THEN + (* The string tinfo^.reason is given to the error handler. *) + s := ConCat (s, Mark (InitString (" because "))) ; + s := ConCat (s, tinfo^.reason) ; + tinfo^.reason := NIL (* Hand over deconstructing to M2MetaError. *) + END ; ErrorString (tinfo^.error, s) END ; - (* and also generate a sub error containing detail. *) + (* And now also generate a sub error containing detail. *) IF (left # tinfo^.left) OR (right # tinfo^.right) THEN MetaError1 ('formal parameter {%1EDad}', right) ; @@ -512,7 +618,7 @@ END buildError4 ; (* - buildError2 - generate a MetaString2 error. This is called by all three kinds of errors. + buildError2 - generate a MetaString2 error. *) PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ; @@ -543,6 +649,14 @@ BEGIN left, right) END ; + (* Lastly the overall reason for the failure. *) + IF tinfo^.reason # NIL + THEN + (* The string tinfo^.reason is given to the error handler. *) + s := ConCat (s, Mark (InitString (" because "))) ; + s := ConCat (s, tinfo^.reason) ; + tinfo^.reason := NIL (* Hand over deconstructing to M2MetaError. *) + END ; ErrorString (tinfo^.error, s) END END @@ -559,7 +673,7 @@ BEGIN THEN RETURN true ELSE - (* check whether errors are required. *) + (* Check whether errors are required. *) IF tinfo^.format # NIL THEN CASE tinfo^.kind OF @@ -700,11 +814,21 @@ PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN IsVar (sym) OR IsParameter (sym) OR IsConstructor (sym) OR (IsConst (sym) AND IsConstructor (sym)) OR IsParameter (sym) OR - (IsConst (sym) AND (GetType (sym) # NulSym)) + (IsConst (sym) AND (GetDType (sym) # NulSym)) END IsTyped ; (* + IsTypeEquivalence - returns TRUE if sym is a type equivalence symbol. +*) + +PROCEDURE IsTypeEquivalence (sym: CARDINAL) : BOOLEAN ; +BEGIN + RETURN IsType (sym) AND (GetDType (sym) # NulSym) AND (GetDType (sym) # sym) +END IsTypeEquivalence ; + + +(* isLValue - *) @@ -715,6 +839,38 @@ END isLValue ; (* + checkVarTypeEquivalence - +*) + +PROCEDURE checkVarTypeEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF isFalse (result) + THEN + RETURN result + ELSIF (left = NulSym) OR (right = NulSym) + THEN + RETURN true + ELSE + IF IsVar (left) OR IsVar (right) + THEN + (* Either left or right will change, so we can call doCheckPair. *) + IF IsVar (left) + THEN + left := getType (left) + END ; + IF IsVar (right) + THEN + right := getType (right) + END ; + RETURN doCheckPair (result, tinfo, left, right) + END + END ; + RETURN result +END checkVarTypeEquivalence ; + + +(* checkVarEquivalence - this test must be done early as it checks the symbol mode. An LValue is treated as a pointer during assignment and the LValue is attached to a variable. This function skips the variable @@ -722,40 +878,44 @@ END isLValue ; *) PROCEDURE checkVarEquivalence (result: status; tinfo: tInfo; - left, right: CARDINAL) : status ; + des, expr: CARDINAL) : status ; BEGIN IF isFalse (result) THEN RETURN result - ELSIF IsTyped (left) OR IsTyped (right) + ELSIF IsTyped (des) OR IsTyped (expr) THEN IF tinfo^.kind = assignment THEN + IF GetDType (des) = GetDType (expr) + THEN + RETURN true (* LValues are only relevant during assignment. *) - IF isLValue (left) AND (NOT isLValue (right)) + ELSIF isLValue (des) AND (NOT isLValue (expr)) THEN - IF SkipType (getType (right)) = Address + IF SkipType (getType (expr)) = Address THEN RETURN true - ELSIF IsPointer (SkipType (getType (right))) + ELSIF IsPointer (SkipType (getType (expr))) THEN - right := GetDType (SkipType (getType (right))) + expr := GetDType (SkipType (getType (expr))) ; + RETURN doCheckPair (result, tinfo, getType (des), expr) END - ELSIF isLValue (right) AND (NOT isLValue (left)) + ELSIF isLValue (expr) AND (NOT isLValue (des)) THEN - IF SkipType (getType (left)) = Address + IF SkipType (getType (des)) = Address THEN RETURN true - ELSIF IsPointer (SkipType (getType (left))) + ELSIF IsPointer (SkipType (getType (des))) THEN - left := GetDType (SkipType (getType (left))) + des := GetDType (SkipType (getType (des))) ; + RETURN doCheckPair (result, tinfo, des, getType (expr)) END END END ; - RETURN doCheckPair (result, tinfo, getType (left), getType (right)) - ELSE - RETURN result - END + RETURN doCheckPair (result, tinfo, getType (des), getType (expr)) + END ; + RETURN result END checkVarEquivalence ; @@ -790,10 +950,15 @@ BEGIN IsProcedure (typeRight) OR IsRecord (typeRight) OR IsReallyPointer (typeRight) THEN - RETURN false + RETURN falseReason1 ('constant string is incompatible with {%1ad}', + tinfo, typeRight) ELSIF IsArray (typeRight) THEN - RETURN doCheckPair (result, tinfo, Char, GetType (typeRight)) + RETURN doCheckPair (result, tinfo, Char, GetDType (typeRight)) + ELSIF NOT GccKnowsAbout (left) + THEN + (* We do not know the length of this string, so assume true. *) + RETURN true ELSIF GetStringLength (tinfo^.token, left) = 1 THEN RETURN doCheckPair (result, tinfo, Char, typeRight) @@ -805,7 +970,9 @@ BEGIN typeLeft := GetDType (left) ; IF IsZRCType (typeLeft) AND IsUnbounded (typeRight) THEN - RETURN false + RETURN falseReason2 ('the constant {%1a} is incompatible' + + ' with an unbounded array of {%2a}', + tinfo, typeLeft, typeRight) ELSE RETURN doCheckPair (result, tinfo, typeLeft, typeRight) END @@ -815,6 +982,58 @@ END checkConstMeta ; (* + checkEnumField - +*) + +PROCEDURE checkEnumField (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +VAR + typeRight: CARDINAL ; +BEGIN + Assert (IsFieldEnumeration (left)) ; + IF isFalse (result) + THEN + RETURN result + ELSIF IsTyped (right) + THEN + typeRight := GetDType (right) ; + IF typeRight = NulSym + THEN + RETURN result + ELSE + RETURN doCheckPair (result, tinfo, GetDType (left), typeRight) + END + END ; + RETURN result +END checkEnumField ; + + +(* + checkEnumFieldEquivalence - +*) + +PROCEDURE checkEnumFieldEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF isFalse (result) + THEN + RETURN result + ELSIF (left = NulSym) OR (right = NulSym) + THEN + (* No option but to return true. *) + RETURN true + ELSIF IsFieldEnumeration (left) + THEN + RETURN checkEnumField (result, tinfo, left, right) + ELSIF IsFieldEnumeration (right) + THEN + RETURN checkEnumField (result, tinfo, right, left) + END ; + RETURN result +END checkEnumFieldEquivalence ; + + +(* checkConstEquivalence - this check can be done first as it checks symbols which may have no type. Ie constant strings. These constants will likely have their type set during quadruple folding. @@ -861,14 +1080,9 @@ BEGIN IF IsSubrange (right) THEN RETURN doCheckPair (result, tinfo, left, GetDType (right)) - END ; - IF left = right - THEN - RETURN true - ELSE - RETURN result END - END + END ; + RETURN result END checkSubrangeTypeEquivalence ; @@ -892,7 +1106,7 @@ PROCEDURE isZRC (zrc, sym: CARDINAL) : BOOLEAN ; BEGIN IF IsConst (sym) THEN - sym := SkipType (GetType (sym)) + sym := SkipType (GetDType (sym)) END ; IF (zrc = CType) AND (IsComplexN (sym) OR IsComplexType (sym)) THEN @@ -911,11 +1125,11 @@ PROCEDURE isSameSizeConst (a, b: CARDINAL) : BOOLEAN ; BEGIN IF IsConst (a) THEN - a := SkipType (GetType (a)) ; + a := SkipType (GetDType (a)) ; RETURN isZRC (a, b) OR (a = b) OR ((a # NulSym) AND isSameSize (a, b)) ELSIF IsConst (b) THEN - b := SkipType (GetType (b)) ; + b := SkipType (GetDType (b)) ; RETURN isZRC (b, a) OR (a = b) OR ((b # NulSym) AND isSameSize (a, b)) END ; RETURN FALSE @@ -936,13 +1150,15 @@ END isSameSize ; checkSystemEquivalence - check whether left and right are system types and whether they have the same size. *) -PROCEDURE checkSystemEquivalence (result: status; left, right: CARDINAL) : status ; +PROCEDURE checkSystemEquivalence (result: status; tinfo: tInfo <* unused *>; + left, right: CARDINAL) : status ; BEGIN IF isFalse (result) OR (result = visited) THEN RETURN result ELSE IF (IsGenericSystemType (left) OR IsGenericSystemType (right)) AND + GccKnowsAbout (left) AND GccKnowsAbout (right) AND isSameSize (left, right) THEN RETURN true @@ -957,7 +1173,7 @@ END checkSystemEquivalence ; a set, record or array. *) -PROCEDURE checkTypeKindViolation (result: status; +PROCEDURE checkTypeKindViolation (result: status; tinfo: tInfo; left, right: CARDINAL) : status ; BEGIN IF isFalse (result) OR (result = visited) @@ -969,7 +1185,8 @@ BEGIN (IsRecord (left) OR IsRecord (right)) OR (IsArray (left) OR IsArray (right)) THEN - RETURN false + RETURN falseReason2 ('a {%1ad} is incompatible with a {%2ad}', + tinfo, left, right) END END ; RETURN result @@ -977,7 +1194,7 @@ END checkTypeKindViolation ; (* - doCheckPair - invoke a series of ordered type checks checking compatibility + doCheckPair - invoke a series of type checks checking compatibility between left and right modula2 symbols. Pre-condition: left and right are modula-2 symbols. tinfo is configured. @@ -989,50 +1206,28 @@ END checkTypeKindViolation ; PROCEDURE doCheckPair (result: status; tinfo: tInfo; left, right: CARDINAL) : status ; +VAR + i: CARDINAL ; BEGIN - IF isFalse (result) OR (result = visited) + IF (left = NulSym) OR (right = NulSym) + THEN + (* We cannot check NulSym. *) + RETURN true + ELSIF isKnown (result) THEN RETURN return (result, tinfo, left, right) ELSIF left = right THEN RETURN return (true, tinfo, left, right) ELSE - result := checkConstEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkVarEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) + i := 1 ; + WHILE i <= HighEquivalence DO + result := Equivalence[i] (result, tinfo, left, right) ; + IF isKnown (result) THEN - result := checkSystemEquivalence (unknown, left, right) ; - IF NOT isKnown (result) - THEN - result := checkSubrangeTypeEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkBaseTypeEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeEquivalence (unknown, left, right) ; - IF NOT isKnown (result) - THEN - result := checkArrayTypeEquivalence (result, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkGenericTypeEquivalence (result, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeKindEquivalence (result, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeKindViolation (result, left, right) - END - END - END - END - END - END - END - END + RETURN return (result, tinfo, left, right) + END ; + INC (i) END END ; RETURN return (result, tinfo, left, right) @@ -1040,6 +1235,45 @@ END doCheckPair ; (* + InitEquivalenceArray - populate the Equivalence array with the + checking procedures. +*) + +PROCEDURE InitEquivalenceArray ; +BEGIN + HighEquivalence := 0 ; + addEquivalence (checkVarEquivalence) ; + addEquivalence (checkVarTypeEquivalence) ; + addEquivalence (checkCharStringTypeEquivalence) ; + addEquivalence (checkConstEquivalence); + addEquivalence (checkEnumFieldEquivalence) ; + addEquivalence (checkSystemEquivalence) ; + addEquivalence (checkSubrangeTypeEquivalence) ; + addEquivalence (checkBaseTypeEquivalence) ; + addEquivalence (checkTypeEquivalence) ; + addEquivalence (checkArrayTypeEquivalence) ; + addEquivalence (checkTypeKindEquivalence) ; + addEquivalence (checkTypeKindViolation) +END InitEquivalenceArray ; + + +(* + addEquivalence - places proc into Equivalence array. +*) + +PROCEDURE addEquivalence (proc: EquivalenceProcedure) ; +BEGIN + INC (HighEquivalence) ; + IF HighEquivalence <= MaxEquvalence + THEN + Equivalence[HighEquivalence] := proc + ELSE + InternalError ('increase MaxEquivalence constant in M2Check.mod') + END +END addEquivalence ; + + +(* checkProcType - *) @@ -1090,6 +1324,12 @@ BEGIN i := 1 ; n := NoOfParamAny (left) ; WHILE i <= n DO + IF isFalse (result) OR (result = visited) + THEN + (* Seen a mismatch therefore return. *) + RETURN return (result, tinfo, left, right) + END ; + result := unknown ; (* Each parameter must match. *) IF IsVarParamAny (left, i) # IsVarParamAny (right, i) THEN IF IsVarParamAny (left, i) @@ -1281,7 +1521,6 @@ BEGIN END checkProcTypeEquivalence ; - (* checkTypeKindEquivalence - *) @@ -1551,7 +1790,7 @@ BEGIN THEN RETURN Address ELSE - RETURN GetSType (sym) + RETURN GetDType (sym) END END getSType ; @@ -1627,11 +1866,19 @@ BEGIN printf ("doCheck (%d, %d)\n", left, right) ; dumptInfo (tinfo) END ; - IF isInternal (left) OR isInternal (right) + IF (left = NulSym) OR (right = NulSym) + THEN + (* Cannot test if a type is NulSym, we assume true. + It maybe that later on a symbols type is set and later + on checking will be called and more accurately resolved. + For example constant strings can be concatenated during + the quadruple folding phase. *) + RETURN TRUE + ELSIF isInternal (left) OR isInternal (right) THEN (* Do not check constants which have been generated internally. - Currently these are generated by the default BY constant value - in a FOR loop. *) + Currently these are generated by the default BY constant + value in a FOR loop. *) RETURN TRUE END ; (* @@ -1650,9 +1897,9 @@ BEGIN result := tinfo^.checkFunc (unknown, tinfo, left, right) ; IF isKnown (result) THEN - (* remove this pair from the unresolved list. *) + (* Remove this pair from the unresolved list. *) exclude (tinfo^.unresolved, left, right) ; - (* add it to the resolved list. *) + (* Add it to the resolved list. *) include (tinfo^.resolved, left, right, result) ; IF result = false THEN @@ -1757,6 +2004,7 @@ END deconstructIndex ; PROCEDURE deconstruct (tinfo: tInfo) ; BEGIN tinfo^.format := KillString (tinfo^.format) ; + tinfo^.reason := KillString (tinfo^.reason) ; tinfo^.visited := deconstructIndex (tinfo^.visited) ; tinfo^.resolved := deconstructIndex (tinfo^.resolved) ; tinfo^.unresolved := deconstructIndex (tinfo^.unresolved) @@ -1803,11 +2051,14 @@ END collapseString ; *) PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; - des, expr: CARDINAL) : BOOLEAN ; + des, expr: CARDINAL; + enableReason: BOOLEAN) : BOOLEAN ; VAR tinfo: tInfo ; BEGIN tinfo := newtInfo () ; + tinfo^.reason := NIL ; + tinfo^.reasonEnable := enableReason AND StrictTypeReason ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := assignment ; @@ -1852,6 +2103,8 @@ BEGIN tinfo := newtInfo () ; formalT := getSType (formal) ; actualT := getSType (actual) ; + tinfo^.reasonEnable := StrictTypeReason ; + tinfo^.reason := NIL ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := parameter ; @@ -1896,6 +2149,8 @@ VAR tinfo: tInfo ; BEGIN tinfo := newtInfo () ; + tinfo^.reasonEnable := StrictTypeReason ; + tinfo^.reason := NIL ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := expression ; @@ -1960,7 +2215,8 @@ PROCEDURE init ; BEGIN pairFreeList := NIL ; tinfoFreeList := NIL ; - errors := InitIndex (1) + errors := InitIndex (1) ; + InitEquivalenceArray END init ; diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index b12add6..860a89a 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -251,6 +251,7 @@ TYPE VAR FreeGroup, GlobalGroup : Group ; (* The global group of all sets. *) + ErrorDepList, (* The set of symbols with dependency errors. *) VisitedList, ChainedList : Set ; HaveInitDefaultTypes: BOOLEAN ; (* Have we initialized them yet? *) @@ -261,9 +262,6 @@ VAR enumDeps : BOOLEAN ; -PROCEDURE mystop ; BEGIN END mystop ; - - (* *************************************************** *) (* PrintNum - @@ -1315,14 +1313,26 @@ END CanBeDeclaredPartiallyViaPartialDependants ; (* - EmitCircularDependancyError - issue a dependancy error. + EmitCircularDependencyError - issue a dependency error. *) -PROCEDURE EmitCircularDependancyError (sym: CARDINAL) ; +PROCEDURE EmitCircularDependencyError (sym: CARDINAL) ; BEGIN - MetaError1('circular dependancy error found when trying to resolve {%1Uad}', - sym) -END EmitCircularDependancyError ; + (* Ensure we only issue one dependency message per symbol for this + error classification. *) + IF NOT IsElementInSet (ErrorDepList, sym) + THEN + IncludeElementIntoSet (ErrorDepList, sym) ; + IF IsVar (sym) OR IsParameter (sym) + THEN + MetaError1 ('circular dependency error found when trying to resolve {%1Had}', + sym) + ELSE + MetaError1 ('circular dependency error found when trying to resolve {%1Dad}', + sym) + END + END +END EmitCircularDependencyError ; TYPE @@ -1529,17 +1539,17 @@ BEGIN IF ForeachTryDeclare (todolist, circulartodo, NotAllDependantsFullyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN ELSIF ForeachTryDeclare (partiallydeclared, circularpartial, NotAllDependantsPartiallyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN ELSIF ForeachTryDeclare (niltypedarrays, circularniltyped, NotAllDependantsPartiallyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN END END ; @@ -2855,13 +2865,8 @@ BEGIN n := 1 ; Var := GetNth(scope, n) ; WHILE Var#NulSym DO - IF NOT AllDependantsFullyDeclared(GetSType(Var)) - THEN - mystop - END ; - IF NOT AllDependantsFullyDeclared(GetSType(Var)) + IF NOT TypeDependentsDeclared (Var, TRUE) THEN - EmitCircularDependancyError(GetSType(Var)) ; failed := TRUE END ; INC(n) ; @@ -2922,14 +2927,12 @@ BEGIN DeclareTypesConstantsProcedures(scope) ; (* will resolved TYPEs and CONSTs on the ToDo *) (* lists. *) ForeachModuleDo(DeclareProcedure) ; - (* - now that all types have been resolved it is safe to declare - variables - *) + (* Now that all types have been resolved it is safe to declare + variables. *) AssertAllTypesDeclared(scope) ; DeclareGlobalVariables(scope) ; ForeachImportedDo(scope, DeclareImportedVariables) ; - (* now it is safe to declare all procedures *) + (* Now it is safe to declare all procedures. *) ForeachProcedureDo(scope, DeclareProcedure) ; ForeachInnerModuleDo(scope, WalkTypesInModule) ; ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ; @@ -2958,14 +2961,12 @@ BEGIN (* lists. *) ForeachModuleDo(DeclareProcedure) ; ForeachModuleDo(DeclareModuleInit) ; - (* - now that all types have been resolved it is safe to declare - variables - *) + (* Now that all types have been resolved it is safe to declare + variables. *) AssertAllTypesDeclared(scope) ; DeclareGlobalVariablesWholeProgram(scope) ; ForeachImportedDo(scope, DeclareImportedVariablesWholeProgram) ; - (* now it is safe to declare all procedures *) + (* Now it is safe to declare all procedures. *) ForeachProcedureDo(scope, DeclareProcedure) ; ForeachInnerModuleDo(scope, WalkTypesInModule) ; ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ; @@ -3411,15 +3412,55 @@ PROCEDURE DoVariableDeclaration (var: CARDINAL; name: ADDRESS; isImported, isExported, isTemporary, isGlobal: BOOLEAN; scope: tree) ; +BEGIN + IF NOT (IsComponent (var) OR IsVarHeap (var)) + THEN + IF TypeDependentsDeclared (var, TRUE) + THEN + PrepareGCCVarDeclaration (var, name, isImported, isExported, + isTemporary, isGlobal, scope) + END + END +END DoVariableDeclaration ; + + +(* + TypeDependentsDeclared - return TRUE if all type dependents of variable + have been declared. +*) + +PROCEDURE TypeDependentsDeclared (variable: CARDINAL; errorMessage: BOOLEAN) : BOOLEAN ; +VAR + type: CARDINAL ; +BEGIN + type := GetSType (variable) ; + IF AllDependantsFullyDeclared (type) + THEN + RETURN TRUE + ELSE + IF errorMessage + THEN + EmitCircularDependencyError (variable) ; + ForeachElementInSetDo (GlobalGroup^.ToDoList, EmitCircularDependencyError) + END + END ; + RETURN FALSE +END TypeDependentsDeclared ; + + +(* + PrepareGCCVarDeclaration - +*) + +PROCEDURE PrepareGCCVarDeclaration (var: CARDINAL; name: ADDRESS; + isImported, isExported, + isTemporary, isGlobal: BOOLEAN; + scope: tree) ; VAR type : tree ; varType : CARDINAL ; location: location_t ; BEGIN - IF IsComponent (var) OR IsVarHeap (var) - THEN - RETURN - END ; IF GetMode (var) = LeftValue THEN (* @@ -3457,7 +3498,7 @@ BEGIN isGlobal, scope, NIL)) ; WatchRemoveList (var, todolist) ; WatchIncludeList (var, fullydeclared) -END DoVariableDeclaration ; +END PrepareGCCVarDeclaration ; (* @@ -3493,7 +3534,6 @@ BEGIN THEN scope := FindContext (ModSym) ; decl := FindOuterModule (variable) ; - Assert (AllDependantsFullyDeclared (GetSType (variable))) ; PushBinding (ModSym) ; DoVariableDeclaration (variable, KeyToCharStar (GetFullSymName (variable)), @@ -3521,7 +3561,6 @@ BEGIN THEN scope := FindContext (mainModule) ; decl := FindOuterModule (variable) ; - Assert (AllDependantsFullyDeclared (GetSType (variable))) ; PushBinding (mainModule) ; DoVariableDeclaration (variable, KeyToCharStar (GetFullSymName (variable)), @@ -3618,7 +3657,6 @@ END DeclareImportedVariablesWholeProgram ; PROCEDURE DeclareLocalVariable (var: CARDINAL) ; BEGIN - Assert (AllDependantsFullyDeclared (var)) ; DoVariableDeclaration (var, KeyToCharStar (GetFullSymName (var)), FALSE, (* local variables cannot be imported *) @@ -3662,7 +3700,6 @@ BEGIN scope := Mod2Gcc (GetProcedureScope (sym)) ; Var := GetNth (sym, i) ; WHILE Var # NulSym DO - Assert (AllDependantsFullyDeclared (GetSType (Var))) ; DoVariableDeclaration (Var, KeyToCharStar (GetFullSymName (Var)), FALSE, (* inner module variables cannot be imported *) @@ -6658,6 +6695,7 @@ END InitDeclarations ; BEGIN FreeGroup := NIL ; GlobalGroup := InitGroup () ; + ErrorDepList := InitSet (1) ; ChainedList := InitSet(1) ; WatchList := InitSet(1) ; VisitedList := NIL ; diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index bc1d588..4a9ced3 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -681,7 +681,7 @@ BEGIN IfGreOp : CodeIfGre (q) | IfInOp : CodeIfIn (q) | IfNotInOp : CodeIfNotIn (q) | - IndrXOp : CodeIndrX (q, op1, op2, op3) | + IndrXOp : CodeIndrX (q) | XIndrOp : CodeXIndr (q) | CallOp : CodeCall (CurrentQuadToken, op3) | ParamOp : CodeParam (q) | @@ -3004,7 +3004,7 @@ BEGIN despos, op2pos, exprpos) ; Assert (op2pos = UnknownTokenNo) ; IF StrictTypeChecking AND - (NOT AssignmentTypeCompatible (despos, "", des, expr)) + (NOT AssignmentTypeCompatible (despos, "", des, expr, TRUE)) THEN MetaErrorT2 (MakeVirtualTok (becomespos, despos, exprpos), 'assignment check caught mismatch between {%1Ead} and {%2ad}', @@ -3233,7 +3233,7 @@ BEGIN IF SkipType(GetTypeMode(op1))#SkipType(GetTypeMode(op3)) THEN DescribeTypeError (tokenno, op1, op3) ; - (* Assigning an errant op3 might ICE, therefore it is safer to return op1. *) + (* Assigning an errant op3 might ICE, therefore it is safer to return op1. *) RETURN( Mod2Gcc (op1) ) END END ; @@ -3550,7 +3550,7 @@ BEGIN location := TokenToLocation (virtpos) ; IF StrictTypeChecking AND - (NOT AssignmentTypeCompatible (virtpos, "", des, expr)) + (NOT AssignmentTypeCompatible (virtpos, "", des, expr, TRUE)) THEN ErrorMessageDecl (virtpos, 'assignment check caught mismatch between {%1Ead} and {%2ad}', @@ -3918,8 +3918,6 @@ END NoWalkProcedure ; PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ; VAR - lefttype, - righttype, des, left, right: CARDINAL ; typeChecking, constExpr, @@ -3937,10 +3935,8 @@ BEGIN IF typeChecking AND (op # LogicalRotateOp) AND (op # LogicalShiftOp) THEN subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ; - lefttype := GetType (left) ; - righttype := GetType (right) ; IF StrictTypeChecking AND - (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype, + (NOT ExpressionTypeCompatible (subexprpos, "", left, right, StrictTypeChecking, FALSE)) THEN MetaErrorT2 (subexprpos, @@ -3950,19 +3946,6 @@ BEGIN SubQuad (quad) ; p (des) ; RETURN FALSE - END ; - (* --fixme-- the ExpressionTypeCompatible above should be enough - and the code below can be removed once ExpressionTypeCompatible - is bug free. *) - IF NOT IsExpressionCompatible (lefttype, righttype) - THEN - ErrorMessageDecl (subexprpos, - 'expression mismatch between {%1Etad} and {%2tad}', - left, right, TRUE) ; - NoChange := FALSE ; - SubQuad (quad) ; - p (des) ; - RETURN FALSE END END ; RETURN TRUE @@ -3978,7 +3961,6 @@ END CheckBinaryExpressionTypes ; PROCEDURE CheckElementSetTypes (quad: CARDINAL) : BOOLEAN ; VAR - lefttype, righttype, ignore, left, right: CARDINAL ; constExpr, @@ -3995,13 +3977,9 @@ BEGIN overflowChecking, constExpr, leftpos, rightpos, ignorepos) ; subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ; - lefttype := GetType (left) ; righttype := GetType (right) ; - (* --fixme-- the ExpressionTypeCompatible below does not always catch - type errors, it needs to be fixed and then some of the subsequent tests - can be removed (and/or this procedure function rewritten). *) IF StrictTypeChecking AND - (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype, + (NOT ExpressionTypeCompatible (subexprpos, "", left, right, StrictTypeChecking, TRUE)) THEN MetaErrorT2 (subexprpos, @@ -4020,17 +3998,6 @@ BEGIN SubQuad (quad) ; RETURN FALSE END ; - righttype := GetType (SkipType (righttype)) ; - (* Now fall though and compare the set element left against the type of set righttype. *) - IF NOT IsExpressionCompatible (lefttype, righttype) - THEN - ErrorMessageDecl (subexprpos, - 'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible', - left, right, TRUE) ; - NoChange := FALSE ; - SubQuad (quad) ; - RETURN FALSE - END ; RETURN TRUE END CheckElementSetTypes ; @@ -8174,25 +8141,52 @@ END CodeIfNotIn ; (op2 is the type of the data being indirectly copied) *) -PROCEDURE CodeIndrX (quad: CARDINAL; op1, op2, op3: CARDINAL) ; +PROCEDURE CodeIndrX (quad: CARDINAL) ; VAR - location: location_t ; + constExpr, + overflowChecking: BOOLEAN ; + op : QuadOperator ; + tokenno, + left, + type, + right, + leftpos, + rightpos, + typepos, + indrxpos : CARDINAL ; + length, + newstr : tree ; + location : location_t ; BEGIN - location := TokenToLocation (CurrentQuadToken) ; + GetQuadOtok (quad, indrxpos, op, left, type, right, + overflowChecking, constExpr, + leftpos, typepos, rightpos) ; + tokenno := MakeVirtualTok (indrxpos, leftpos, rightpos) ; + location := TokenToLocation (tokenno) ; (* Follow the Quadruple rules: *) - DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *) - DeclareConstructor (CurrentQuadToken, quad, op3) ; - IF IsConstString (op3) + DeclareConstant (rightpos, right) ; (* Checks to see whether it is a constant + and if necessary declare it. *) + DeclareConstructor (rightpos, quad, right) ; + IF IsConstString (right) THEN InternalError ('not expecting to index through a constant string') + ELSIF StrictTypeChecking AND + (NOT AssignmentTypeCompatible (indrxpos, "", left, GetType (right), TRUE)) + THEN + MetaErrorT2 (tokenno, + 'assignment check caught mismatch between {%1Ead} and {%2ad}', + left, right) ; + SubQuad (quad) ELSE + (* Mem[op1] := Mem[Mem[op3]] *) - BuildAssignmentStatement (location, Mod2Gcc (op1), BuildIndirect (location, Mod2Gcc (op3), Mod2Gcc (op2))) + BuildAssignmentStatement (location, Mod2Gcc (left), + BuildIndirect (location, Mod2Gcc (right), Mod2Gcc (type))) END END CodeIndrX ; @@ -8229,6 +8223,14 @@ BEGIN type := SkipType (type) ; DeclareConstant (rightpos, right) ; DeclareConstructor (rightpos, quad, right) ; + IF StrictTypeChecking AND + (NOT AssignmentTypeCompatible (xindrpos, "", GetType (left), right, TRUE)) + THEN + MetaErrorT2 (tokenno, + 'assignment check caught mismatch between {%1Ead} and {%2ad}', + left, right) ; + SubQuad (quad) + END ; IF IsProcType(SkipType(type)) THEN BuildAssignmentStatement (location, BuildIndirect (location, Mod2Gcc (left), GetPointerType ()), Mod2Gcc (right)) diff --git a/gcc/m2/gm2-compiler/M2MetaError.def b/gcc/m2/gm2-compiler/M2MetaError.def index cfe9195..3dfe9fa 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.def +++ b/gcc/m2/gm2-compiler/M2MetaError.def @@ -93,9 +93,9 @@ FROM NameKey IMPORT Name ; %} } the error messages may also embed optional strings such as: - {%1a:this string is emitted if the symbol name is non null} - {!%1a:this string is emitted if the symbol name is null} - {!%1a:{%1d}} + {%1a:this string is emitted if the symbol name is null} + {!%1a:this string is emitted if the symbol name is non null} + {%1a:{%1d}} if the symbol name does not exist then print a description of the symbol. {%1atd} was incompatible with the return type of the procedure diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod index 22bc77f..3aa7543 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.mod +++ b/gcc/m2/gm2-compiler/M2MetaError.mod @@ -1437,35 +1437,22 @@ BEGIN doError (eb, GetDeclaredDef (sym)) ELSE M2Error.EnterErrorScope (GetErrorScope (scope)) ; - IF IsProcedure (scope) + IF IsVar (sym) OR IsParameter (sym) THEN - IF IsVar (sym) OR IsParameter (sym) - THEN - doError (eb, GetVarParamTok (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetVarParamTok (sym)) + ELSIF IsProcedure (scope) + THEN + doError (eb, GetDeclaredDef (sym)) + ELSIF IsModule (scope) + THEN + doError (eb, GetDeclaredMod (sym)) ELSE - IF IsModule (scope) + Assert (IsDefImp (scope)) ; + IF GetDeclaredDefinition (sym) = UnknownTokenNo THEN - IF IsInnerModule (scope) - THEN - doError (eb, GetDeclaredDef (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetDeclaredMod (sym)) ELSE - Assert (IsDefImp (scope)) ; - (* if this fails then we need to skip to the outer scope. - REPEAT - OuterModule := GetScope(OuterModule) - UNTIL GetScope(OuterModule)=NulSym ; *) - IF GetDeclaredDefinition (sym) = UnknownTokenNo - THEN - doError (eb, GetDeclaredMod (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetDeclaredDef (sym)) END END END ; diff --git a/gcc/m2/gm2-compiler/M2Options.def b/gcc/m2/gm2-compiler/M2Options.def index 2b78add..4cb7f8f 100644 --- a/gcc/m2/gm2-compiler/M2Options.def +++ b/gcc/m2/gm2-compiler/M2Options.def @@ -87,6 +87,8 @@ VAR LineDirectives, (* Should compiler understand preprocessor *) (* # linenumber "filename" markers? *) StrictTypeChecking, (* -fm2-strict-type experimental checker. *) + StrictTypeAssignment, (* -fm2-strict-assignment. *) + StrictTypeReason, (* -fm2-strict-reason. *) CPreProcessor, (* Must we run the cpp on the source? *) Xcode, (* Should errors follow Xcode format? *) ExtendedOpaque, (* Do we allow non pointer opaque types? *) @@ -756,6 +758,20 @@ PROCEDURE SetStrictTypeChecking (value: BOOLEAN) ; (* + SetStrictTypeAssignment - assigns the StrictTypeAssignment flag to value. +*) + +PROCEDURE SetStrictTypeAssignment (value: BOOLEAN) ; + + +(* + SetStrictTypeReason - assigns the StrictTypeReason flag to value. +*) + +PROCEDURE SetStrictTypeReason (value: BOOLEAN) ; + + +(* setdefextension - set the source file definition module extension to arg. This should include the . and by default it is set to .def. *) diff --git a/gcc/m2/gm2-compiler/M2Options.mod b/gcc/m2/gm2-compiler/M2Options.mod index 39f0b2a..542b87b 100644 --- a/gcc/m2/gm2-compiler/M2Options.mod +++ b/gcc/m2/gm2-compiler/M2Options.mod @@ -657,6 +657,26 @@ END SetStrictTypeChecking ; (* + SetStrictTypeAssignment - assigns the StrictTypeAssignment flag to value. +*) + +PROCEDURE SetStrictTypeAssignment (value: BOOLEAN) ; +BEGIN + StrictTypeAssignment := value +END SetStrictTypeAssignment ; + + +(* + SetStrictTypeReason - assigns the StrictTypeReason flag to value. +*) + +PROCEDURE SetStrictTypeReason (value: BOOLEAN) ; +BEGIN + StrictTypeReason := value +END SetStrictTypeReason ; + + +(* SetVerboseUnbounded - sets the VerboseUnbounded flag to, value. *) @@ -2111,6 +2131,8 @@ BEGIN UnusedVariableChecking := FALSE ; UnusedParameterChecking := FALSE ; StrictTypeChecking := TRUE ; + StrictTypeAssignment := TRUE ; + StrictTypeReason := TRUE ; AutoInit := FALSE ; SaveTemps := FALSE ; ScaffoldDynamic := TRUE ; diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 4022657..748ce24 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -226,6 +226,7 @@ FROM M2Options IMPORT NilChecking, GenerateLineDebug, Exceptions, Profiling, Coding, Optimizing, UninitVariableChecking, + StrictTypeAssignment, ScaffoldDynamic, ScaffoldStatic, cflag, ScaffoldMain, SharedFlag, WholeProgram, GetDumpDir, GetM2DumpFilter, @@ -258,8 +259,10 @@ FROM M2Range IMPORT InitAssignmentRangeCheck, InitRotateCheck, InitShiftCheck, InitTypesAssignmentCheck, + InitTypesIndrXCheck, InitTypesExpressionCheck, InitTypesParameterCheck, + InitTypesReturnTypeCheck, InitForLoopBeginRangeCheck, InitForLoopToRangeCheck, InitForLoopEndRangeCheck, @@ -284,7 +287,6 @@ IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ; CONST DebugStackOn = TRUE ; DebugVarients = FALSE ; - BreakAtQuad = 758 ; DebugTokPos = FALSE ; TYPE @@ -397,6 +399,7 @@ VAR (* in order. *) NoOfQuads : CARDINAL ; (* Number of used quadruples. *) Head : CARDINAL ; (* Head of the list of quadruples. *) + BreakQuad : CARDINAL ; (* Stop when BreakQuad is created. *) (* @@ -1487,22 +1490,6 @@ BEGIN END AddQuadInformation ; -PROCEDURE stop ; BEGIN END stop ; - - -(* - CheckBreak - check whether QuadNo = BreakAtQuad and if so call stop. -*) - -PROCEDURE CheckBreak (QuadNo: CARDINAL) ; -BEGIN - IF QuadNo = BreakAtQuad - THEN - stop - END -END CheckBreak ; - - (* PutQuadO - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and sets a boolean to determinine whether overflow should be checked. @@ -3888,6 +3875,10 @@ BEGIN THEN MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des) END ; + IF StrictTypeAssignment + THEN + BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) + END ; IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des))) THEN (* Tell code generator to test runtime values of assignment so ensure we @@ -4655,6 +4646,8 @@ BEGIN BySym) ; MetaErrorDecl (BySym, TRUE) ELSE + e1 := DereferenceLValue (e1tok, e1) ; + e2 := DereferenceLValue (e2tok, e2) ; GenQuadOTypetok (bytok, LastForIteratorOp, LastIterator, Make2Tuple (e1, e2), BySym, FALSE, FALSE, bytok, MakeVirtual2Tok (e1tok, e2tok), bytok) @@ -5628,7 +5621,7 @@ VAR proctok, paramtok : CARDINAL ; n1, n2 : Name ; - ParamCheckId, + ParamCheckId, Dim, Actual, FormalI, @@ -5770,42 +5763,46 @@ VAR CheckedProcedure: CARDINAL ; e : Error ; BEGIN - n := NoOfParamAny (ProcType) ; IF IsVar(call) OR IsTemporary(call) OR IsParameter(call) THEN CheckedProcedure := GetDType(call) ELSE CheckedProcedure := call END ; - IF n # NoOfParamAny (CheckedProcedure) + IF ProcType # CheckedProcedure THEN - e := NewError(GetDeclaredMod(ProcType)) ; - n1 := GetSymName(call) ; - n2 := GetSymName(ProcType) ; - ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters', - n1, n2) ; - e := ChainError(GetDeclaredMod(call), e) ; - t := NoOfParamAny (CheckedProcedure) ; - IF n<2 + n := NoOfParamAny (ProcType) ; + (* We need to check the formal parameters between the procedure and proc type. *) + IF n # NoOfParamAny (CheckedProcedure) THEN - ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)', - n1, n, t) - ELSE - ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)', - n1, n, t) - END - ELSE - i := 1 ; - WHILE i<=n DO - IF IsVarParamAny (ProcType, i) # IsVarParamAny (CheckedProcedure, i) + e := NewError(GetDeclaredMod(ProcType)) ; + n1 := GetSymName(call) ; + n2 := GetSymName(ProcType) ; + ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters', + n1, n2) ; + e := ChainError(GetDeclaredMod(call), e) ; + t := NoOfParamAny (CheckedProcedure) ; + IF n<2 THEN - MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ; - MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i) - END ; - BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i, - GetNthParamAnyClosest (CheckedProcedure, i, GetCurrentModule ()), - GetParam (ProcType, i), ParamCheckId)) ; - INC(i) + ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)', + n1, n, t) + ELSE + ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)', + n1, n, t) + END + ELSE + i := 1 ; + WHILE i<=n DO + IF IsVarParamAny (ProcType, i) # IsVarParamAny (CheckedProcedure, i) + THEN + MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ; + MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i) + END ; + BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i, + GetNthParamAnyClosest (CheckedProcedure, i, GetCurrentModule ()), + GetParam (ProcType, i), ParamCheckId)) ; + INC(i) + END END END END CheckProcTypeAndProcedure ; @@ -6272,21 +6269,24 @@ END ExpectVariable ; doIndrX - perform des = *exp with a conversion if necessary. *) -PROCEDURE doIndrX (tok: CARDINAL; - des, exp: CARDINAL) ; +PROCEDURE doIndrX (tok: CARDINAL; des, exp: CARDINAL) ; VAR t: CARDINAL ; BEGIN - IF GetDType(des)=GetDType(exp) + IF GetDType (des) = GetDType (exp) THEN GenQuadOtok (tok, IndrXOp, des, GetSType (des), exp, TRUE, tok, tok, tok) ELSE + IF StrictTypeAssignment + THEN + BuildRange (InitTypesIndrXCheck (tok, des, exp)) + END ; t := MakeTemporary (tok, RightValue) ; PutVar (t, GetSType (exp)) ; GenQuadOtok (tok, IndrXOp, t, GetSType (exp), exp, TRUE, tok, tok, tok) ; - GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType(des), t), TRUE, + GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType (des), t), TRUE, tok, UnknownTokenNo, tok) END END doIndrX ; @@ -11295,12 +11295,41 @@ BEGIN n1, n2) ELSE (* this checks the types are compatible, not the data contents. *) - BuildRange (InitTypesAssignmentCheck (tokno, currentProc, actualVal)) + BuildRange (InitTypesReturnTypeCheck (tokno, currentProc, actualVal)) END END CheckReturnType ; (* + BuildReturnLower - check the return type and value to ensure type + compatibility and no range overflow will occur. +*) + +PROCEDURE BuildReturnLower (tokcombined, tokexpr: CARDINAL; e1, t1: CARDINAL) ; +VAR + e2, t2: CARDINAL ; +BEGIN + (* This will check that the type returned is compatible with + the formal return type of the procedure. *) + CheckReturnType (tokcombined, CurrentProc, e1, t1) ; + (* Dereference LeftValue if necessary. *) + IF GetMode (e1) = LeftValue + THEN + t2 := GetSType (CurrentProc) ; + e2 := MakeTemporary (tokexpr, RightValue) ; + PutVar(e2, t2) ; + CheckPointerThroughNil (tokexpr, e1) ; + doIndrX (tokexpr, e2, e1) ; + e1 := e2 + END ; + (* Here we check the data contents to ensure no overflow. *) + BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; + GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, + tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) +END BuildReturnLower ; + + +(* BuildReturn - Builds the Return part of the procedure. tokreturn is the location of the RETURN keyword. The Stack is expected to contain: @@ -11319,7 +11348,6 @@ PROCEDURE BuildReturn (tokreturn: CARDINAL) ; VAR tokcombined, tokexpr : CARDINAL ; - e2, t2, e1, t1, t, f, Des : CARDINAL ; @@ -11339,26 +11367,18 @@ BEGIN tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ; IF e1 # NulSym THEN - (* this will check that the type returned is compatible with - the formal return type of the procedure. *) - CheckReturnType (tokcombined, CurrentProc, e1, t1) ; - (* dereference LeftValue if necessary *) - IF GetMode (e1) = LeftValue - THEN - t2 := GetSType (CurrentProc) ; - e2 := MakeTemporary (tokexpr, RightValue) ; - PutVar(e2, t2) ; - CheckPointerThroughNil (tokexpr, e1) ; - doIndrX (tokexpr, e2, e1) ; - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + (* Check we are in a procedure scope and that the procedure has a return type. *) + IF CurrentProc = NulSym + THEN + MetaErrorT0 (tokcombined, + '{%1E} attempting to return a value when not in a procedure scope') + ELSIF GetSType (CurrentProc) = NulSym + THEN + MetaErrorT1 (tokcombined, + 'attempting to return a value from procedure {%1Ea} which does not have a return type', + CurrentProc) ELSE - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + BuildReturnLower (tokcombined, tokexpr, e1, t1) END END ; GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ; @@ -16061,12 +16081,55 @@ END StressStack ; (* + gdbhook - a debugger convenience hook. +*) + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenQuadCreated - to be called interactively by gdb. +*) + +PROCEDURE BreakWhenQuadCreated (quad: CARDINAL) ; +BEGIN + BreakQuad := quad +END BreakWhenQuadCreated ; + + +(* + CheckBreak - if quad = BreakQuad then call gdbhook. +*) + +PROCEDURE CheckBreak (quad: CARDINAL) ; +BEGIN + IF quad = BreakQuad + THEN + gdbhook + END +END CheckBreak ; + + +(* Init - initialize the M2Quads module, all the stacks, all the lists and the quads list. *) PROCEDURE Init ; BEGIN + BreakWhenQuadCreated (0) ; (* Disable the intereactive quad watch. *) + (* To examine the quad table when a quad is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenQuadCreated with the quad + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenQuadCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this quad is created. *) LogicalOrTok := MakeKey('_LOR') ; LogicalAndTok := MakeKey('_LAND') ; LogicalXorTok := MakeKey('_LXOR') ; diff --git a/gcc/m2/gm2-compiler/M2Range.def b/gcc/m2/gm2-compiler/M2Range.def index 42aa142..e825d94 100644 --- a/gcc/m2/gm2-compiler/M2Range.def +++ b/gcc/m2/gm2-compiler/M2Range.def @@ -291,6 +291,24 @@ PROCEDURE InitTypesExpressionCheck (tokno: CARDINAL; d, e: CARDINAL; (* + InitTypesIndrXCheck - checks to see that the types of d and e + are assignment compatible. The type checking + will dereference *e during the type check. + d = *e. +*) + +PROCEDURE InitTypesIndrXCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ; + + +(* + InitTypesReturnTypeCheck - checks to see that the type of val can + be returned from func. +*) + +PROCEDURE InitTypesReturnTypeCheck (tokno: CARDINAL; func, val: CARDINAL) : CARDINAL ; + + +(* InitCaseBounds - creates a case bound range check. *) diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod index 8e3943a..dcac2ba 100644 --- a/gcc/m2/gm2-compiler/M2Range.mod +++ b/gcc/m2/gm2-compiler/M2Range.mod @@ -58,7 +58,7 @@ FROM M2Debug IMPORT Assert ; FROM Indexing IMPORT Index, InitIndex, InBounds, PutIndice, GetIndice ; FROM Storage IMPORT ALLOCATE ; FROM M2ALU IMPORT PushIntegerTree, PushInt, ConvertToInt, Equ, Gre, Less, GreEqu ; -FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking, GetPIM ; +FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking, GetPIM, StrictTypeAssignment ; FROM M2Error IMPORT Error, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, FlushErrors, GetAnnounceScope ; @@ -91,7 +91,6 @@ FROM M2Check IMPORT ParameterTypeCompatible, ExpressionTypeCompatible, Assignmen FROM M2Base IMPORT Nil, IsRealType, GetBaseTypeMinMax, Cardinal, Integer, ZType, IsComplexType, - IsAssignmentCompatible, IsExpressionCompatible, IsParameterCompatible, ExceptionAssign, @@ -115,7 +114,9 @@ FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds, TYPE TypeOfRange = (assignment, returnassignment, subrangeassignment, inc, dec, incl, excl, shift, rotate, - typeexpr, typeassign, typeparam, paramassign, + typeindrx, typeexpr, typeassign, typeparam, + typereturn, + paramassign, staticarraysubscript, dynamicarraysubscript, forloopbegin, forloopto, forloopend, @@ -289,9 +290,10 @@ BEGIN excl : RETURN( ExceptionExcl ) | shift : RETURN( ExceptionShift ) | rotate : RETURN( ExceptionRotate ) | - typeassign : InternalError ('not expecting this case value') | - typeparam : InternalError ('not expecting this case value') | - typeexpr : InternalError ('not expecting this case value') | + typeassign, + typeparam, + typeexpr, + typeindrx : InternalError ('not expecting this case value') | paramassign : RETURN( ExceptionParameterBounds ) | staticarraysubscript : RETURN( ExceptionStaticArray ) | dynamicarraysubscript: RETURN( ExceptionDynamicArray ) | @@ -822,7 +824,7 @@ END InitRotateCheck ; (* - InitTypesAssignmentCheck - checks to see that the types of, d, and, e, + InitTypesAssignmentCheck - checks to see that the types of d and e are assignment compatible. *) @@ -837,6 +839,38 @@ END InitTypesAssignmentCheck ; (* + InitTypesIndrXCheck - checks to see that the types of d and e + are assignment compatible. The type checking + will dereference *e during the type check. + d = *e. +*) + +PROCEDURE InitTypesIndrXCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ; +VAR + r: CARDINAL ; +BEGIN + r := InitRange () ; + Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typeindrx, d, e) # NIL) ; + RETURN r +END InitTypesIndrXCheck ; + + +(* + InitTypesReturnTypeCheck - checks to see that the types of des and func + are assignment compatible. +*) + +PROCEDURE InitTypesReturnTypeCheck (tokno: CARDINAL; func, val: CARDINAL) : CARDINAL ; +VAR + r: CARDINAL ; +BEGIN + r := InitRange () ; + Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typereturn, func, val) # NIL) ; + RETURN r +END InitTypesReturnTypeCheck ; + + +(* InitTypesParameterCheck - checks to see that the types of, d, and, e, are parameter compatible. *) @@ -1219,9 +1253,11 @@ BEGIN excl : RETURN( ExceptionExcl#NulSym ) | shift : RETURN( ExceptionShift#NulSym ) | rotate : RETURN( ExceptionRotate#NulSym ) | - typeassign : RETURN( FALSE ) | - typeparam : RETURN( FALSE ) | - typeexpr : RETURN( FALSE ) | + typereturn, + typeassign, + typeparam, + typeexpr, + typeindrx : RETURN( FALSE ) | paramassign : RETURN( ExceptionParameterBounds#NulSym ) | staticarraysubscript : RETURN( ExceptionStaticArray#NulSym ) | dynamicarraysubscript: RETURN( ExceptionDynamicArray#NulSym ) | @@ -1246,7 +1282,9 @@ END HandlerExists ; (* - FoldAssignment - + FoldAssignment - attempts to fold the range violation checks. + It does not issue errors on type violations as that + is performed by FoldTypeAssign. *) PROCEDURE FoldAssignment (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ; @@ -1259,7 +1297,7 @@ BEGIN TryDeclareConstant (exprtok, expr) ; IF desLowestType # NulSym THEN - IF AssignmentTypeCompatible (tokenno, "", des, expr) + IF AssignmentTypeCompatible (tokenno, "", des, expr, FALSE) THEN IF GccKnowsAbout (expr) AND IsConst (expr) AND GetMinMax (tokenno, desLowestType, min, max) @@ -1275,6 +1313,8 @@ BEGIN END END ELSE + (* We do not issue an error if these types are incompatible here + as this is done by FoldTypeAssign. *) SubQuad (q) END END @@ -1757,21 +1797,94 @@ END FoldRotate ; (* + FoldTypeReturnFunc - checks to see that val can be returned from func. +*) + +PROCEDURE FoldTypeReturnFunc (q: CARDINAL; tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ; +VAR + valType, + returnType: CARDINAL ; +BEGIN + returnType := GetType (func) ; + IF returnType = NulSym + THEN + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'procedure {%1Da} is not a procedure function', + '{%2ad} cannot be returned from {%1Da}', + func, val) ; + SubQuad(q) + END + ELSE + valType := val ; + IF IsVar (val) AND (GetMode (val) = LeftValue) + THEN + valType := GetType (val) + END ; + IF AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE) + THEN + SubQuad (q) + ELSE + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} used in procedure {%1Da}', + 'is incompatible with the returned expression {%1ad}}', + func, val) ; + setReported (r) ; + FlushErrors + END + END + END +END FoldTypeReturnFunc ; + + +(* FoldTypeAssign - *) PROCEDURE FoldTypeAssign (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT reportedError (r) + THEN + IF AssignmentTypeCompatible (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' cannot be assigned with' + + ' {%2ad: a {%2td} {%2ad}}{!%2ad: {%2ad} of type {%2tad}}', + des, expr, TRUE) + THEN + SubQuad (q) + ELSE + setReported (r) ; + FlushErrors + END + END +END FoldTypeAssign ; + + +(* + FoldTypeIndrX - check to see that des = *expr is type compatible. +*) + +PROCEDURE FoldTypeIndrX (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; VAR + desType, exprType: CARDINAL ; BEGIN - IF IsProcedure(expr) + (* Need to skip over a variable or temporary in des and expr so + long as expr is not a procedure. In the case of des = *expr, + both expr and des will be variables due to the property of + indirection. *) + desType := GetType (des) ; + IF IsProcedure (expr) THEN + (* Must not GetType for a procedure as it gives the return type. *) exprType := expr ELSE - exprType := GetType(expr) + exprType := GetType (expr) END ; - - IF IsAssignmentCompatible (GetType(des), exprType) + IF AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE) THEN SubQuad(q) ELSE @@ -1785,14 +1898,16 @@ BEGIN des, expr) ; ELSE MetaErrorT3 (tokenNo, - 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%3ad:of type {%3ad}} are incompatible', + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' {%1d:is a {%1d}} and expression {%2a} {%3ad:of type' + + ' {%3ad}} are incompatible', des, expr, exprType) END ; setReported (r) ; FlushErrors END END -END FoldTypeAssign ; +END FoldTypeIndrX ; (* @@ -1859,35 +1974,90 @@ END FoldTypeExpr ; *) PROCEDURE CodeTypeAssign (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT AssignmentTypeCompatible (tokenNo, "", des, expr, FALSE) + THEN + IF NOT reportedError (r) + THEN + MetaErrorT2 (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible', + des, expr) + END ; + setReported (r) + END +END CodeTypeAssign ; + + +(* + CodeTypeReturnFunc - +*) + +PROCEDURE CodeTypeReturnFunc (tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ; VAR - exprType: CARDINAL ; + valType, + returnType: CARDINAL ; BEGIN - IF IsProcedure(expr) + returnType := GetType (func) ; + IF returnType = NulSym THEN - exprType := expr + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'procedure {%1Da} is not a procedure function', + '{%2ad} cannot be returned from {%1Da}', + func, val) ; + END ELSE - exprType := GetType(expr) - END ; - IF NOT IsAssignmentCompatible(GetType(des), exprType) + valType := val ; + IF IsVar (val) AND (GetMode (val) = LeftValue) + THEN + valType := GetType (val) + END ; + IF NOT AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE) + THEN + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} used in procedure function {%1Da}', + 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', + func, val) + END + END + END +END CodeTypeReturnFunc ; + + +(* + CodeTypeIndrX - checks that des = *expr is type compatible and generates an error if they + are not compatible. It skips over the LValue type so that to allow + the error messages to pick up the source variable name rather than + a temporary name or vague name 'expression'. +*) + +PROCEDURE CodeTypeIndrX (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE) THEN IF NOT reportedError (r) THEN - IF IsProcedure(des) + IF IsProcedure (des) THEN - MetaErrorsT2(tokenNo, - 'the return type {%1Etad} declared in procedure {%1Da}', - 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', - des, expr) ; + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} declared in procedure {%1Da}', + 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', + des, expr) ; ELSE - MetaErrorT2(tokenNo, - 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible', - des, expr) + MetaErrorT2 (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' {%1d:is a {%1d}} and expression {%2a}' + + ' {%2tad:of type {%2tad}} are incompatible', + des, expr) END ; setReported (r) END (* FlushErrors *) END -END CodeTypeAssign ; +END CodeTypeIndrX ; (* @@ -1941,9 +2111,11 @@ BEGIN THEN CASE type OF - typeassign: FoldTypeAssign(q, tokenNo, des, expr, r) | - typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo, r) | - typeexpr: FoldTypeExpr(q, tokenNo, des, expr, strict, isin, r) + typeassign: FoldTypeAssign (q, tokenNo, des, expr, r) | + typeparam : FoldTypeParam (q, tokenNo, des, expr, procedure, paramNo, r) | + typeexpr : FoldTypeExpr (q, tokenNo, des, expr, strict, isin, r) | + typeindrx : FoldTypeIndrX (q, tokenNo, des, expr, r) | + typereturn: FoldTypeReturnFunc (q, tokenNo, des, expr, r) ELSE InternalError ('not expecting to reach this point') @@ -1974,9 +2146,11 @@ BEGIN THEN CASE type OF - typeassign: CodeTypeAssign(tokenNo, des, expr, r) | - typeparam: CodeTypeParam(tokenNo, des, expr, procedure, paramNo) | - typeexpr: CodeTypeExpr(tokenNo, des, expr, strict, isin, r) + typeassign: CodeTypeAssign (tokenNo, des, expr, r) | + typeparam : CodeTypeParam (tokenNo, des, expr, procedure, paramNo) | + typeexpr : CodeTypeExpr (tokenNo, des, expr, strict, isin, r) | + typeindrx : CodeTypeIndrX (tokenNo, des, expr, r) | + typereturn: CodeTypeReturnFunc (tokenNo, des, expr, r) ELSE InternalError ('not expecting to reach this point') @@ -2005,7 +2179,7 @@ BEGIN success := TRUE ; WITH p^ DO combinedtok := MakeVirtual2Tok (destok, exprtok) ; - IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr) + IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr, TRUE) THEN MetaErrorT2 (combinedtok, 'type incompatibility between {%1Et} and {%2t} detected during the assignment of the designator {%1a} to the first expression {%2a} in the {%kFOR} loop', @@ -2419,9 +2593,11 @@ BEGIN excl : FoldExcl(tokenno, quad, range) | shift : FoldShift(tokenno, quad, range) | rotate : FoldRotate(tokenno, quad, range) | - typeassign : FoldTypeCheck(tokenno, quad, range) | - typeparam : FoldTypeCheck(tokenno, quad, range) | - typeexpr : FoldTypeCheck(tokenno, quad, range) | + typereturn, + typeassign, + typeparam, + typeexpr, + typeindrx : FoldTypeCheck (tokenno, quad, range) | paramassign : FoldParameterAssign(tokenno, quad, range) | staticarraysubscript : FoldStaticArraySubscript(tokenno, quad, range) | dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, quad, range) | @@ -3557,6 +3733,8 @@ BEGIN typeassign : s := NIL | typeparam : s := NIL | typeexpr : s := NIL | + typeindrx : s := InitString ('assignment between designator {%1ad} and {%2ad} is incompatible') | + typereturn : s := InitString ('the value {%2ad} returned from procedure function {%1a} is type incompatible, expecting {%1tad} rather than a {%2tad}') | paramassign : s := InitString('if this call is executed then the actual parameter {%2Wa} will be out of range of the {%3N} formal parameter {%1a}') | staticarraysubscript : s := InitString('if this access to the static array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') | dynamicarraysubscript: s := InitString('if this access to the dynamic array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') | @@ -3605,9 +3783,11 @@ BEGIN excl : CodeInclExcl (tokenNo, r, function, message) | shift, rotate : CodeShiftRotate (tokenNo, r, function, message) | - typeassign : CodeTypeCheck (tokenNo, r) | - typeparam : CodeTypeCheck (tokenNo, r) | - typeexpr : CodeTypeCheck (tokenNo, r) | + typeassign, + typeparam, + typeexpr, + typeindrx, + typereturn : CodeTypeCheck (tokenNo, r) | staticarraysubscript : CodeStaticArraySubscript (tokenNo, r, function, message) | dynamicarraysubscript: CodeDynamicArraySubscript (tokenNo, r, function, message) | forloopbegin : CodeForLoopBegin (tokenNo, r, function, message) | @@ -3743,6 +3923,8 @@ BEGIN rotate : WriteString('rotate(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeexpr : WriteString('expr compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeassign : WriteString('assignment compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | + typeindrx : WriteString('indrx compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | + typereturn : WriteString('return compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeparam : WriteString('parameter compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | paramassign : WriteString('parameter range (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | staticarraysubscript : WriteString('staticarraysubscript(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | diff --git a/gcc/m2/gm2-compiler/P2Build.bnf b/gcc/m2/gm2-compiler/P2Build.bnf index b9a6daa..c28e630 100644 --- a/gcc/m2/gm2-compiler/P2Build.bnf +++ b/gcc/m2/gm2-compiler/P2Build.bnf @@ -46,7 +46,8 @@ see <https://www.gnu.org/licenses/>. *) IMPLEMENTATION MODULE P2Build ; FROM M2LexBuf IMPORT currentstring, currenttoken, GetToken, InsertToken, - InsertTokenAndRewind, GetTokenNo, MakeVirtual2Tok ; + InsertTokenAndRewind, GetTokenNo, MakeVirtual2Tok, + MakeVirtualTok ; FROM M2MetaError IMPORT MetaErrorStringT0, MetaErrorT1 ; FROM NameKey IMPORT NulName, Name, makekey, MakeKey ; @@ -128,13 +129,13 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutGnuAsmOutput, PutGnuAsmTrash, PutGnuAsmVolatile, MakeRegInterface, PutRegInterface, GetRegInterface, - GetSymName, GetType, MakeConstLit, + GetSymName, GetType, MakeConstLit, IsProcType, NulSym, - StartScope, EndScope, + StartScope, EndScope, GetCurrentModule, PutIncluded, PutExceptionFinally, PutExceptionBlock, GetCurrentScope, IsVarParam, IsProcedure, IsDefImp, IsModule, - IsRecord, IsAModula2Type, + IsRecord, IsAModula2Type, IsImported, RequestSym ; IMPORT M2Error ; @@ -450,6 +451,54 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + init := nextLevel + END ; + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END ; + PutIncluded (init) + ELSE + PushTFtok (init, GetType (init), tok) ; + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") + END +END CheckModuleQualident ; + + % module P2Build end END P2Build. % rules @@ -609,28 +658,10 @@ ImplementationOrProgramModule := ImplementationModule | ProgramModule =: Number := Integer | Real =: -Qualident := % VAR name: Name ; - Type, Sym, tok: CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tok) ; - Sym := RequestSym (tok, name) ; - IF IsDefImp(Sym) OR IsModule(Sym) - THEN - Expect(periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope(Sym) ; - Qualident(stopset0, stopset1, stopset2) ; - (* should we test for lack of ident? *) - PopTFtok(Sym, Type, tok) ; - PushTFtok(Sym, Type, tok) ; - Annotate("%1s(%1d)|%1s(%1d)||qualident|type") ; - EndScope ; - PutIncluded(Sym) - ELSE - PushTFtok(Sym, GetType(Sym), tok) ; - Annotate("%1s(%1d)|%1s(%1d)||qualident|type") - END + CheckModuleQualident (stopset0, stopset1, stopset2) ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod index 8f3b499..5c82ec8 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.mod +++ b/gcc/m2/gm2-compiler/P2SymBuild.mod @@ -1225,7 +1225,8 @@ VAR Sym, Type : CARDINAL ; name : Name ; - tokno : CARDINAL ; + nametokno, + typetokno: CARDINAL ; BEGIN (* Two cases @@ -1234,8 +1235,8 @@ BEGIN - when type with a name that is different to Name. In which case we create a new type. *) - PopTtok(Type, tokno) ; - PopT(name) ; + PopTtok (Type, typetokno) ; + PopTtok (name, nametokno) ; IF Debugging THEN n1 := GetSymName(GetCurrentModule()) ; @@ -1264,11 +1265,11 @@ BEGIN *) (* WriteString('Blank name type') ; WriteLn ; *) - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") ELSIF IsError(Type) THEN - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||error type|error type name|token no") ELSIF GetSymName(Type)=name THEN @@ -1276,7 +1277,7 @@ BEGIN IF isunknown OR (NOT IsDeclaredIn(GetCurrentScope(), Type)) THEN - Sym := MakeType(tokno, name) ; + Sym := MakeType (typetokno, name) ; IF NOT IsError(Sym) THEN IF Sym=Type @@ -1295,19 +1296,23 @@ BEGIN CheckForEnumerationInCurrentModule(Type) END END ; - PushTFtok(Sym, name, tokno) ; + PushTFtok(Sym, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") ELSE - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") END ELSE (* example TYPE a = CARDINAL *) - Sym := MakeType(tokno, name) ; - PutType(Sym, Type) ; - CheckForExportedImplementation(Sym) ; (* May be an exported hidden type *) - PushTFtok(Sym, name, tokno) ; - Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") + Sym := MakeType (nametokno, name) ; + PutType (Sym, Type) ; + CheckForExportedImplementation (Sym) ; (* May be an exported hidden type *) + PushTFtok (Sym, name, nametokno) ; + Annotate ("%1s(%1d)|%2n|%3d||type|type name|token no") ; + IF Debugging + THEN + MetaErrorT1 (nametokno, 'type pos {%1Wa}', Sym) + END END END BuildType ; diff --git a/gcc/m2/gm2-compiler/P3Build.bnf b/gcc/m2/gm2-compiler/P3Build.bnf index 4f6ffb7..0033d33 100644 --- a/gcc/m2/gm2-compiler/P3Build.bnf +++ b/gcc/m2/gm2-compiler/P3Build.bnf @@ -166,14 +166,14 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput MakeRegInterface, PutRegInterface, IsRegInterface, IsGnuAsmVolatile, IsGnuAsm, - GetCurrentModule, + GetCurrentModule, IsInnerModule, GetSymName, GetType, SkipType, NulSym, StartScope, EndScope, PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, IsProcType, IsRecord, - RequestSym, IsExported, + RequestSym, IsExported, IsImported, GetSym, GetLocalSym ; FROM M2Batch IMPORT IsModuleKnown ; @@ -468,6 +468,69 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) OR IsModule (init) OR IsDefImp (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF (IsImported (GetCurrentModule (), init) AND IsDefImp (init)) OR + IsModule (init) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module P3Build end BEGIN BlockState := InitState () @@ -643,37 +706,11 @@ Number := Integer | Real =: -- IsAutoPushOff then we just consume tokens. -- -Qualident := % VAR name : Name ; - init, ip1, - tokstart, tok : CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tokstart) ; - tok := tokstart ; - init := RequestSym (tok, name) ; - WHILE IsDefImp (init) OR IsModule (init) DO - Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope (init) ; - Ident (stopset0, stopset1, stopset2) ; - PopTtok (name, tok) ; - ip1 := RequestSym (tok, name) ; - PutIncluded(ip1) ; - EndScope ; - CheckCanBeImported(init, ip1) ; - init := ip1 - END ; - IF tok#tokstart - THEN - tok := MakeVirtualTok (tokstart, tokstart, tok) - END ; - IF IsProcedure(init) OR IsProcType(init) - THEN - PushTtok(init, tok) - ELSE - PushTFtok(init, GetType(init), tok) ; - END - ELSE % + CheckModuleQualident (stopset0, stopset1, stopset2) + ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/PCBuild.bnf b/gcc/m2/gm2-compiler/PCBuild.bnf index a05a55f..ddbe2f1 100644 --- a/gcc/m2/gm2-compiler/PCBuild.bnf +++ b/gcc/m2/gm2-compiler/PCBuild.bnf @@ -65,7 +65,7 @@ FROM M2Quads IMPORT Top, PushT, PopT, PushTF, PopTF, PopNothing, OperandT, Opera PushTFA, PushTFn, PopTFn, PushTFtok, PopTtok, PopTFtok, PushTtok, PushTFntok, PushT, PushTF, IsAutoPushOn, PushAutoOff, PushAutoOn, PopAuto, - DupFrame, + DupFrame, Annotate, BuildTypeForConstructor, BuildConstructor, BuildConstructorEnd, PopConstructor, NextConstructorField, SilentBuildConstructor, @@ -118,6 +118,7 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, IsRecord, IsProcType, + GetCurrentModule, IsInnerModule, IsImported, RequestSym, GetSym, GetLocalSym ; @@ -412,6 +413,68 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module PCBuild end BEGIN BlockState := InitState () @@ -569,37 +632,11 @@ ImplementationOrProgramModule := % Pus Number := Integer | Real =: -Qualident := % VAR name : Name ; - init, ip1, - tokstart, tok : CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tokstart) ; - tok := tokstart ; - init := RequestSym (tok, name) ; - WHILE IsDefImp (init) OR IsModule (init) DO - Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope (init) ; - Ident (stopset0, stopset1, stopset2) ; - PopTtok (name, tok) ; - ip1 := RequestSym (tok, name) ; - PutIncluded(ip1) ; - EndScope ; - CheckCanBeImported(init, ip1) ; - init := ip1 - END ; - IF tok#tokstart - THEN - tok := MakeVirtualTok (tokstart, tokstart, tok) - END ; - IF IsProcedure(init) OR IsProcType(init) - THEN - PushTtok(init, tok) - ELSE - PushTFtok(init, GetType(init), tok) ; - END - ELSE % + CheckModuleQualident (stopset0, stopset1, stopset2) + ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/PHBuild.bnf b/gcc/m2/gm2-compiler/PHBuild.bnf index 7bd5bcc..8153870 100644 --- a/gcc/m2/gm2-compiler/PHBuild.bnf +++ b/gcc/m2/gm2-compiler/PHBuild.bnf @@ -130,12 +130,12 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutGnuAsmOutput, PutGnuAsmTrash, PutGnuAsmVolatile, MakeRegInterface, PutRegInterface, GetRegInterface, - GetSymName, GetType, + GetSymName, GetType, GetCurrentModule, NulSym, StartScope, EndScope, PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, - IsRecord, IsProcType, + IsRecord, IsProcType, IsInnerModule, IsImported, RequestSym, GetSym, GetLocalSym ; @@ -368,6 +368,68 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module PHBuild end END PHBuild. % rules @@ -541,26 +603,10 @@ ImplementationOrProgramModule := % Pus Number := Integer | Real =: -Qualident := % VAR name: Name ; - Type, Sym, tok: CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tok) ; - Sym := RequestSym (tok, name) ; - IF IsDefImp(Sym) OR IsModule(Sym) - THEN - Expect(periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope(Sym) ; - Qualident(stopset0, stopset1, stopset2) ; - (* should we test for lack of ident? *) - PopTFtok(Sym, Type, tok) ; - PushTFtok(Sym, Type, tok) ; - EndScope ; - PutIncluded(Sym) - ELSE - PushTFtok(Sym, GetType(Sym), tok) ; - END + CheckModuleQualident (stopset0, stopset1, stopset2) ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-gcc/m2options.h b/gcc/m2/gm2-gcc/m2options.h index d60b510..041de26 100644 --- a/gcc/m2/gm2-gcc/m2options.h +++ b/gcc/m2/gm2-gcc/m2options.h @@ -168,6 +168,8 @@ EXTERN char *M2Options_GetM2DumpFilter (void); EXTERN void M2Options_SetM2DebugTraceFilter (bool value, const char *arg); EXTERN bool M2Options_SetM2Dump (bool value, const char *arg); EXTERN bool M2Options_GetDumpGimple (void); +EXTERN void M2Options_SetStrictTypeAssignment (bool value); +EXTERN void M2Options_SetStrictTypeReason (bool value); #undef EXTERN #endif /* m2options_h. */ diff --git a/gcc/m2/gm2-lang.cc b/gcc/m2/gm2-lang.cc index e8820da..31a2e46 100644 --- a/gcc/m2/gm2-lang.cc +++ b/gcc/m2/gm2-lang.cc @@ -525,6 +525,9 @@ gm2_langhook_handle_option ( case OPT_fm2_strict_type: M2Options_SetStrictTypeChecking (value); return 1; + case OPT_fm2_strict_type_reason: + M2Options_SetStrictTypeReason (value); + return 1; case OPT_fm2_debug_trace_: M2Options_SetM2DebugTraceFilter (value, arg); return 1; diff --git a/gcc/m2/gm2-libs-iso/IOChanUtils.def b/gcc/m2/gm2-libs-iso/IOChanUtils.def new file mode 100644 index 0000000..3a8a0c6 --- /dev/null +++ b/gcc/m2/gm2-libs-iso/IOChanUtils.def @@ -0,0 +1,35 @@ +DEFINITION MODULE IOChanUtils ; + +(* + Title : IOChanUtils + Author : Gaius Mulley + System : GNU Modula-2 + Date : Sat Jun 28 23:33:06 2025 + Revision : $Version$ + Description: provides additional procedures to work on + ChanIds. +*) + +FROM DynamicStrings IMPORT String ; +FROM FIO IMPORT File ; + +IMPORT IOChan ; + + +(* + GetFileName - returns the filename as a new string associated + with chanid c. This string should be killed by + the caller. +*) + +PROCEDURE GetFileName (c: IOChan.ChanId) : String ; + + +(* + GetFile - returns the FIO.File associated with ChanId c. +*) + +PROCEDURE GetFile (c: IOChan.ChanId) : File ; + + +END IOChanUtils. diff --git a/gcc/m2/gm2-libs-iso/IOChanUtils.mod b/gcc/m2/gm2-libs-iso/IOChanUtils.mod new file mode 100644 index 0000000..168fe0d --- /dev/null +++ b/gcc/m2/gm2-libs-iso/IOChanUtils.mod @@ -0,0 +1,28 @@ +IMPLEMENTATION MODULE IOChanUtils ; + +IMPORT IOChan, SFIO, RTio ; + + +(* + GetFileName - returns the filename as a new string associated + with chanid c. This string should be killed by + the caller. +*) + +PROCEDURE GetFileName (c: IOChan.ChanId) : String ; +BEGIN + RETURN SFIO.GetFileName (GetFile (c)) +END GetFileName ; + + +(* + GetFile - returns the FIO.File associated with ChanId c. +*) + +PROCEDURE GetFile (c: IOChan.ChanId) : File ; +BEGIN + RETURN RTio.GetFile (c) +END GetFile ; + + +END IOChanUtils. diff --git a/gcc/m2/gm2-libs-log/FileSystem.def b/gcc/m2/gm2-libs-log/FileSystem.def index 3a88720..42e1399 100644 --- a/gcc/m2/gm2-libs-log/FileSystem.def +++ b/gcc/m2/gm2-libs-log/FileSystem.def @@ -33,14 +33,6 @@ FROM SYSTEM IMPORT WORD, BYTE, ADDRESS ; IMPORT FIO ; FROM DynamicStrings IMPORT String ; -EXPORT QUALIFIED File, Response, Flag, FlagSet, - - Create, Close, Lookup, Rename, Delete, - SetRead, SetWrite, SetModify, SetOpen, - Doio, SetPos, GetPos, Length, Reset, - - ReadWord, ReadChar, ReadByte, ReadNBytes, - WriteWord, WriteChar, WriteByte, WriteNBytes ; TYPE File = RECORD @@ -272,4 +264,21 @@ PROCEDURE Doio (VAR f: File) ; PROCEDURE FileNameChar (ch: CHAR) : CHAR ; +(* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*) + +PROCEDURE GetFileName (file: File) : String ; + + +(* + WriteString - writes contents to file. The nul char + will terminate the contents string otherwise + all characters 0..HIGH (contents) are written. +*) + +PROCEDURE WriteString (file: File; contents: ARRAY OF CHAR) ; + + END FileSystem. diff --git a/gcc/m2/gm2-libs-log/FileSystem.mod b/gcc/m2/gm2-libs-log/FileSystem.mod index fbbc422..4b06b5b4 100644 --- a/gcc/m2/gm2-libs-log/FileSystem.mod +++ b/gcc/m2/gm2-libs-log/FileSystem.mod @@ -29,8 +29,11 @@ IMPLEMENTATION MODULE FileSystem ; FROM M2RTS IMPORT InstallTerminationProcedure ; FROM Storage IMPORT ALLOCATE ; FROM SYSTEM IMPORT ADR, COFF_T ; -IMPORT SFIO, libc, wrapc ; -FROM DynamicStrings IMPORT InitString, ConCat, ConCatChar, KillString, string ; +IMPORT SFIO, libc, wrapc, StrLib ; + +FROM DynamicStrings IMPORT InitString, ConCat, ConCatChar, + KillString, string, Dup ; + FROM FormatStrings IMPORT Sprintf2 ; CONST @@ -595,6 +598,37 @@ END FileNameChar ; (* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*) + +PROCEDURE GetFileName (file: File) : String ; +BEGIN + RETURN Dup (file.name) +END GetFileName ; + + +(* + WriteString - writes contents to file. The nul char + will terminate the contents string otherwise + all characters 0..HIGH (contents) are written. +*) + +PROCEDURE WriteString (file: File; contents: ARRAY OF CHAR) ; +VAR + ch : CHAR ; + i, high: CARDINAL ; +BEGIN + i := 0 ; + high := StrLib.StrLen (contents) ; + WHILE i <= high DO + WriteChar (file, contents[i]) ; + INC (i) + END +END WriteString ; + + +(* MakeTemporary - creates a temporary file and returns its name. *) diff --git a/gcc/m2/gm2-libs-log/InOut.mod b/gcc/m2/gm2-libs-log/InOut.mod index 79c706a..6b03034 100644 --- a/gcc/m2/gm2-libs-log/InOut.mod +++ b/gcc/m2/gm2-libs-log/InOut.mod @@ -257,16 +257,8 @@ END WriteString ; PROCEDURE LocalWrite (ch: CHAR) ; BEGIN FIO.WriteChar(outFile, ch) ; - Done := FIO.IsNoError(outFile) -(* - IF outUsed - THEN - FIO.WriteChar(outFile, ch) ; - Done := FIO.IsNoError(outFile) - ELSE - Done := (write(stdout, ADR(ch), 1) = 1) - END -*) + Done := FIO.IsNoError(outFile) ; + FIO.FlushBuffer (outFile) END LocalWrite ; diff --git a/gcc/m2/gm2-libs-log/Strings.def b/gcc/m2/gm2-libs-log/Strings.def index aea35f8..2be4e42 100644 --- a/gcc/m2/gm2-libs-log/Strings.def +++ b/gcc/m2/gm2-libs-log/Strings.def @@ -53,7 +53,9 @@ PROCEDURE Delete (VAR str: ARRAY OF CHAR; index: CARDINAL; length: CARDINAL) ; (* - Pos - return the first position of, substr, in, str. + Pos - return the first position of substr in str. + If substr is not found in str then it returns + HIGH (str) + 1. *) PROCEDURE Pos (substr, str: ARRAY OF CHAR) : CARDINAL ; diff --git a/gcc/m2/gm2-libs-log/Strings.mod b/gcc/m2/gm2-libs-log/Strings.mod index 6046a10..44f47b3 100644 --- a/gcc/m2/gm2-libs-log/Strings.mod +++ b/gcc/m2/gm2-libs-log/Strings.mod @@ -83,39 +83,62 @@ END Delete ; (* - Pos - return the first position of, substr, in, str. + PosLower - return the first position of substr in str. *) -PROCEDURE Pos (substr, str: ARRAY OF CHAR) : CARDINAL ; +PROCEDURE PosLower (substr, str: ARRAY OF CHAR) : CARDINAL ; VAR - i, k, l : INTEGER ; - s1, s2, s3: DynamicStrings.String ; + i, strLen, substrLen : INTEGER ; + strS, substrS, scratchS: DynamicStrings.String ; BEGIN - s1 := DynamicStrings.InitString(str) ; - s2 := DynamicStrings.InitString(substr) ; - k := DynamicStrings.Length(s1) ; - l := DynamicStrings.Length(s2) ; + strS := DynamicStrings.InitString (str) ; + substrS := DynamicStrings.InitString (substr) ; + strLen := DynamicStrings.Length (strS) ; + substrLen := DynamicStrings.Length (substrS) ; i := 0 ; REPEAT - i := DynamicStrings.Index(s1, DynamicStrings.char(s2, 0), i) ; - IF i>=0 + i := DynamicStrings.Index (strS, DynamicStrings.char (substrS, 0), i) ; + IF i < 0 + THEN + (* No match on first character therefore return now. *) + strS := DynamicStrings.KillString (strS) ; + substrS := DynamicStrings.KillString (substrS) ; + scratchS := DynamicStrings.KillString (scratchS) ; + RETURN( HIGH (str) + 1 ) + ELSIF i + substrLen <= strLen THEN - s3 := DynamicStrings.Slice(s1, i, l) ; - IF DynamicStrings.Equal(s3, s2) + scratchS := DynamicStrings.Slice (strS, i, i + substrLen) ; + IF DynamicStrings.Equal (scratchS, substrS) THEN - s1 := DynamicStrings.KillString(s1) ; - s2 := DynamicStrings.KillString(s2) ; - s3 := DynamicStrings.KillString(s3) ; + strS := DynamicStrings.KillString (strS) ; + substrS := DynamicStrings.KillString (substrS) ; + scratchS := DynamicStrings.KillString (scratchS) ; RETURN( i ) END ; - s3 := DynamicStrings.KillString(s3) + scratchS := DynamicStrings.KillString (scratchS) END ; - INC(i) - UNTIL i>=k ; - s1 := DynamicStrings.KillString(s1) ; - s2 := DynamicStrings.KillString(s2) ; - s3 := DynamicStrings.KillString(s3) ; - RETURN( HIGH(str)+1 ) + INC (i) + UNTIL i >= strLen ; + strS := DynamicStrings.KillString (strS) ; + substrS := DynamicStrings.KillString (substrS) ; + scratchS := DynamicStrings.KillString (scratchS) ; + RETURN( HIGH (str) + 1 ) +END PosLower ; + + +(* + Pos - return the first position of substr in str. + If substr is not found in str then it returns + HIGH (str) + 1. +*) + +PROCEDURE Pos (substr, str: ARRAY OF CHAR) : CARDINAL ; +BEGIN + IF Length (substr) <= Length (str) + THEN + RETURN PosLower (substr, str) + END ; + RETURN( HIGH (str) + 1 ) END Pos ; @@ -129,11 +152,11 @@ PROCEDURE Copy (str: ARRAY OF CHAR; VAR s1, s2: DynamicStrings.String ; BEGIN - s1 := DynamicStrings.InitString(str) ; - s2 := DynamicStrings.Slice(s1, index, index+length) ; - DynamicStrings.CopyOut(result, s2) ; - s1 := DynamicStrings.KillString(s1) ; - s2 := DynamicStrings.KillString(s2) + s1 := DynamicStrings.InitString (str) ; + s2 := DynamicStrings.Slice (s1, index, index+length) ; + DynamicStrings.CopyOut (result, s2) ; + s1 := DynamicStrings.KillString (s1) ; + s2 := DynamicStrings.KillString (s2) END Copy ; diff --git a/gcc/m2/gm2-libs/ARRAYOFCHAR.def b/gcc/m2/gm2-libs/ARRAYOFCHAR.def new file mode 100644 index 0000000..7767a52 --- /dev/null +++ b/gcc/m2/gm2-libs/ARRAYOFCHAR.def @@ -0,0 +1,40 @@ +(* ARRAYOFCHAR.def provides output procedures for the ARRAY OF CHAR datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +DEFINITION MODULE ARRAYOFCHAR ; + +FROM FIO IMPORT File ; + + +(* + Description: provides write procedures for ARRAY OF CHAR. +*) + +PROCEDURE Write (f: File; str: ARRAY OF CHAR) ; +PROCEDURE WriteLn (f: File) ; + + +END ARRAYOFCHAR. diff --git a/gcc/m2/gm2-libs/ARRAYOFCHAR.mod b/gcc/m2/gm2-libs/ARRAYOFCHAR.mod new file mode 100644 index 0000000..f27378a --- /dev/null +++ b/gcc/m2/gm2-libs/ARRAYOFCHAR.mod @@ -0,0 +1,56 @@ +(* ARRAYOFCHAR.def provides output procedures for the ARRAY OF CHAR datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +IMPLEMENTATION MODULE ARRAYOFCHAR ; + +FROM FIO IMPORT WriteChar, WriteLine ; +IMPORT StrLib ; + + +(* + Write - writes a string to file f. +*) + +PROCEDURE Write (f: File; a: ARRAY OF CHAR) ; +VAR + len, i: CARDINAL ; +BEGIN + len := StrLib.StrLen (a) ; + i := 0 ; + WHILE i < len DO + WriteChar (f, a[i]) ; + INC (i) + END +END Write ; + + +PROCEDURE WriteLn (f: File) ; +BEGIN + WriteLine (f) +END WriteLn ; + + +END ARRAYOFCHAR. diff --git a/gcc/m2/gm2-libs/CFileSysOp.def b/gcc/m2/gm2-libs/CFileSysOp.def new file mode 100644 index 0000000..1be2135 --- /dev/null +++ b/gcc/m2/gm2-libs/CFileSysOp.def @@ -0,0 +1,56 @@ +DEFINITION MODULE CFileSysOp ; + +FROM SYSTEM IMPORT ADDRESS ; + + +(* + Description: provides access to filesystem operations. + The implementation module is written in C + and the parameters behave as their C + counterparts. +*) + +TYPE + AccessMode = SET OF AccessStatus ; + AccessStatus = (F_OK, R_OK, W_OK, X_OK, A_FAIL) ; + + +PROCEDURE Unlink (filename: ADDRESS) : INTEGER ; + + +(* + Access - test access to a path or file. The behavior is + the same as defined in access(2). Except that + on A_FAIL is only used during the return result + indicating the underlying C access has returned + -1 (and errno can be checked). +*) + +PROCEDURE Access (pathname: ADDRESS; mode: AccessMode) : AccessMode ; + + +(* Return TRUE if the caller can see the existance of the file or + directory on the filesystem. *) + +(* + IsDir - return true if filename is a regular directory. +*) + +PROCEDURE IsDir (dirname: ADDRESS) : BOOLEAN ; + + +(* + IsFile - return true if filename is a regular file. +*) + +PROCEDURE IsFile (filename: ADDRESS) : BOOLEAN ; + + +(* + Exists - return true if pathname exists. +*) + +PROCEDURE Exists (pathname: ADDRESS) : BOOLEAN ; + + +END CFileSysOp. diff --git a/gcc/m2/gm2-libs/CHAR.def b/gcc/m2/gm2-libs/CHAR.def new file mode 100644 index 0000000..71a6791 --- /dev/null +++ b/gcc/m2/gm2-libs/CHAR.def @@ -0,0 +1,40 @@ +(* CHAR.def provides output procedures for the CHAR datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +DEFINITION MODULE CHAR ; + +FROM FIO IMPORT File ; + + +(* + Write a single character ch to file f. +*) + +PROCEDURE Write (f: File; ch: CHAR) ; +PROCEDURE WriteLn (f: File) ; + + +END CHAR. diff --git a/gcc/m2/gm2-libs/CHAR.mod b/gcc/m2/gm2-libs/CHAR.mod new file mode 100644 index 0000000..9673e25 --- /dev/null +++ b/gcc/m2/gm2-libs/CHAR.mod @@ -0,0 +1,48 @@ +(* CHAR.mod provides output procedures for the CHAR datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +IMPLEMENTATION MODULE CHAR ; + +IMPORT FIO ; + + +(* + Write a single character ch to file f. +*) + +PROCEDURE Write (f: File; ch: CHAR) ; +BEGIN + FIO.WriteChar (f, ch) +END Write ; + + +PROCEDURE WriteLn (f: File) ; +BEGIN + FIO.WriteLine (f) +END WriteLn ; + + +END CHAR. diff --git a/gcc/m2/gm2-libs/FileSysOp.def b/gcc/m2/gm2-libs/FileSysOp.def new file mode 100644 index 0000000..64ba392 --- /dev/null +++ b/gcc/m2/gm2-libs/FileSysOp.def @@ -0,0 +1,44 @@ +(* FileSysOp.def provides procedures to manipulate the file system. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +DEFINITION MODULE FileSysOp ; + +FROM CFileSysOp IMPORT AccessMode ; + + +(* + Description: provides access to filesystem operations using + Modula-2 base types. +*) + +PROCEDURE Exists (filename: ARRAY OF CHAR) : BOOLEAN ; +PROCEDURE IsDir (dirname: ARRAY OF CHAR) : BOOLEAN ; +PROCEDURE IsFile (filename: ARRAY OF CHAR) : BOOLEAN ; +PROCEDURE Unlink (filename: ARRAY OF CHAR) : BOOLEAN ; +PROCEDURE Access (pathname: ARRAY OF CHAR; mode: AccessMode) : AccessMode ; + + +END FileSysOp. diff --git a/gcc/m2/gm2-libs/FileSysOp.mod b/gcc/m2/gm2-libs/FileSysOp.mod new file mode 100644 index 0000000..c418c22 --- /dev/null +++ b/gcc/m2/gm2-libs/FileSysOp.mod @@ -0,0 +1,98 @@ +(* FileSysOp.mod provides procedures to manipulate the file system. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +IMPLEMENTATION MODULE FileSysOp ; + +IMPORT StringFileSysOp ; +FROM DynamicStrings IMPORT String, InitString, KillString ; + + +(* + Description: provides access to filesystem operations using + Modula-2 base types. +*) + +PROCEDURE Exists (filename: ARRAY OF CHAR) : BOOLEAN ; +VAR + fn : String ; + result: BOOLEAN ; +BEGIN + fn := InitString (filename) ; + result := StringFileSysOp.Exists (fn) ; + fn := KillString (fn) ; + RETURN result +END Exists ; + + +PROCEDURE IsDir (dirname: ARRAY OF CHAR) : BOOLEAN ; +VAR + fn : String ; + result: BOOLEAN ; +BEGIN + fn := InitString (dirname) ; + result := StringFileSysOp.IsDir (fn) ; + fn := KillString (fn) ; + RETURN result +END IsDir ; + + +PROCEDURE IsFile (filename: ARRAY OF CHAR) : BOOLEAN ; +VAR + fn : String ; + result: BOOLEAN ; +BEGIN + fn := InitString (filename) ; + result := StringFileSysOp.IsFile (fn) ; + fn := KillString (fn) ; + RETURN result +END IsFile ; + + +PROCEDURE Unlink (filename: ARRAY OF CHAR) : BOOLEAN ; +VAR + fn : String ; + result: BOOLEAN ; +BEGIN + fn := InitString (filename) ; + result := StringFileSysOp.Unlink (fn) ; + fn := KillString (fn) ; + RETURN result +END Unlink ; + + +PROCEDURE Access (pathname: ARRAY OF CHAR; mode: AccessMode) : AccessMode ; +VAR + pn : String ; + result: AccessMode ; +BEGIN + pn := InitString (pathname) ; + result := StringFileSysOp.Access (pn, mode) ; + pn := KillString (pn) ; + RETURN result +END Access ; + + +END FileSysOp. diff --git a/gcc/m2/gm2-libs/SFIO.def b/gcc/m2/gm2-libs/SFIO.def index 81adf8a..a390437 100644 --- a/gcc/m2/gm2-libs/SFIO.def +++ b/gcc/m2/gm2-libs/SFIO.def @@ -29,8 +29,6 @@ DEFINITION MODULE SFIO ; FROM DynamicStrings IMPORT String ; FROM FIO IMPORT File ; -EXPORT QUALIFIED OpenToRead, OpenToWrite, OpenForRandom, Exists, WriteS, ReadS ; - (* Exists - returns TRUE if a file named, fname exists for reading. @@ -91,4 +89,12 @@ PROCEDURE WriteS (file: File; s: String) : String ; PROCEDURE ReadS (file: File) : String ; +(* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*) + +PROCEDURE GetFileName (file: File) : String ; + + END SFIO. diff --git a/gcc/m2/gm2-libs/SFIO.mod b/gcc/m2/gm2-libs/SFIO.mod index a4834b6..7feb112 100644 --- a/gcc/m2/gm2-libs/SFIO.mod +++ b/gcc/m2/gm2-libs/SFIO.mod @@ -29,10 +29,12 @@ IMPLEMENTATION MODULE SFIO ; FROM ASCII IMPORT nul ; FROM DynamicStrings IMPORT string, Length, InitString, ConCatChar, + InitStringCharStar, InitStringDB, InitStringCharStarDB, InitStringCharDB, MultDB, DupDB, SliceDB ; -FROM FIO IMPORT exists, openToRead, openToWrite, openForRandom, WriteNBytes, ReadChar, +FROM FIO IMPORT exists, openToRead, openToWrite, openForRandom, + WriteNBytes, ReadChar, getFileName, EOLN, EOF, IsNoError ; (* @@ -144,4 +146,15 @@ BEGIN END ReadS ; +(* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*) + +PROCEDURE GetFileName (file: File) : String ; +BEGIN + RETURN InitStringCharStar (getFileName (file)) +END GetFileName ; + + END SFIO. diff --git a/gcc/m2/gm2-libs/String.def b/gcc/m2/gm2-libs/String.def new file mode 100644 index 0000000..972232d --- /dev/null +++ b/gcc/m2/gm2-libs/String.def @@ -0,0 +1,35 @@ +(* String.def provides output procedures for the String datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +DEFINITION MODULE String ; + +FROM DynamicStrings IMPORT String ; +FROM FIO IMPORT File ; + +PROCEDURE Write (f: File; str: String) ; +PROCEDURE WriteLn (f: File) ; + +END String. diff --git a/gcc/m2/gm2-libs/String.mod b/gcc/m2/gm2-libs/String.mod new file mode 100644 index 0000000..5dfbb3f --- /dev/null +++ b/gcc/m2/gm2-libs/String.mod @@ -0,0 +1,51 @@ +(* String.mod provides output procedures for the String datatype. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +IMPLEMENTATION MODULE String ; + +IMPORT DynamicStrings, CHAR ; + + +PROCEDURE Write (f: File; str: String) ; +VAR + i, len: CARDINAL ; +BEGIN + i := 0 ; + len := DynamicStrings.Length (str) ; + WHILE i < len DO + CHAR.Write (f, DynamicStrings.char (str, i)) ; + INC (i) + END +END Write ; + + +PROCEDURE WriteLn (f: File) ; +BEGIN + CHAR.WriteLn (f) +END WriteLn ; + + +END String. diff --git a/gcc/m2/gm2-libs/StringFileSysOp.def b/gcc/m2/gm2-libs/StringFileSysOp.def new file mode 100644 index 0000000..ce1d05a --- /dev/null +++ b/gcc/m2/gm2-libs/StringFileSysOp.def @@ -0,0 +1,40 @@ +(* StringFileSysOp.def provides procedures to manipulate the file system. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +DEFINITION MODULE StringFileSysOp ; + +FROM DynamicStrings IMPORT String ; +FROM CFileSysOp IMPORT AccessMode ; + + +PROCEDURE Exists (filename: String) : BOOLEAN ; +PROCEDURE IsDir (dirname: String) : BOOLEAN ; +PROCEDURE IsFile (filename: String) : BOOLEAN ; +PROCEDURE Unlink (filename: String) : BOOLEAN ; +PROCEDURE Access (pathname: String; mode: AccessMode) : AccessMode ; + + +END StringFileSysOp. diff --git a/gcc/m2/gm2-libs/StringFileSysOp.mod b/gcc/m2/gm2-libs/StringFileSysOp.mod new file mode 100644 index 0000000..3cf9ef9 --- /dev/null +++ b/gcc/m2/gm2-libs/StringFileSysOp.mod @@ -0,0 +1,63 @@ +(* StringFileSysOp.mod provides procedures to manipulate the file system. + +Copyright (C) 2025 Free Software Foundation, Inc. +Contributed by Gaius Mulley <gaiusmod2@gmail.com>. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. *) + +IMPLEMENTATION MODULE StringFileSysOp ; + +IMPORT CFileSysOp ; +FROM DynamicStrings IMPORT string ; + + +PROCEDURE Exists (filename: String) : BOOLEAN ; +BEGIN + RETURN CFileSysOp.Exists (string (filename)) +END Exists ; + + +PROCEDURE IsDir (dirname: String) : BOOLEAN ; +BEGIN + RETURN CFileSysOp.IsDir (string (dirname)) +END IsDir ; + + +PROCEDURE IsFile (filename: String) : BOOLEAN ; +BEGIN + RETURN CFileSysOp.IsFile (string (filename)) +END IsFile ; + + +PROCEDURE Unlink (filename: String) : BOOLEAN ; +BEGIN + RETURN CFileSysOp.Unlink (string (filename)) = 0 +END Unlink ; + + +PROCEDURE Access (pathname: String; mode: AccessMode) : AccessMode ; +BEGIN + RETURN CFileSysOp.Access (string (pathname), mode) +END Access ; + + +END StringFileSysOp. diff --git a/gcc/m2/lang.opt b/gcc/m2/lang.opt index 1ea55f2..48c2380 100644 --- a/gcc/m2/lang.opt +++ b/gcc/m2/lang.opt @@ -190,6 +190,10 @@ fm2-strict-type Modula-2 experimental flag to turn on the new strict type checker +fm2-strict-type-reason +Modula-2 +provides more detail why the types are incompatible + fm2-whole-program Modula-2 compile all implementation modules and program module at once diff --git a/gcc/m2/m2.flex b/gcc/m2/m2.flex index d08ac3e..e3cf010 100644 --- a/gcc/m2/m2.flex +++ b/gcc/m2/m2.flex @@ -48,6 +48,8 @@ static int cpreprocessor = 0; /* Replace this with correct getter. */ #define EXTERN extern "C" #endif +#define FIRST_COLUMN 1 + /* m2.flex provides a lexical analyser for GNU Modula-2. */ struct lineInfo { @@ -558,7 +560,7 @@ static void consumeLine (void) currentLine->lineno = lineno; currentLine->tokenpos=0; currentLine->nextpos=0; - currentLine->column=0; + currentLine->column=FIRST_COLUMN; START_LINE (lineno, yyleng); yyless(1); /* push back all but the \n */ traceLine (); @@ -621,7 +623,6 @@ static void updatepos (void) seenModuleStart = false; currentLine->nextpos = currentLine->tokenpos+yyleng; currentLine->toklen = yyleng; - /* if (currentLine->column == 0) */ currentLine->column = currentLine->tokenpos+1; currentLine->location = M2Options_OverrideLocation (GET_LOCATION (currentLine->column, @@ -677,7 +678,7 @@ static void initLine (void) currentLine->toklen = 0; currentLine->nextpos = 0; currentLine->lineno = lineno; - currentLine->column = 0; + currentLine->column = FIRST_COLUMN; currentLine->inuse = true; currentLine->next = NULL; } @@ -812,10 +813,10 @@ EXTERN bool m2flex_OpenSource (char *s) EXTERN int m2flex_GetLineNo (void) { - if (currentLine != NULL) - return currentLine->lineno; - else + if (currentLine == NULL) return 0; + else + return currentLine->lineno; } /* @@ -825,10 +826,10 @@ EXTERN int m2flex_GetLineNo (void) EXTERN int m2flex_GetColumnNo (void) { - if (currentLine != NULL) - return currentLine->column; + if (currentLine == NULL) + return FIRST_COLUMN; else - return 0; + return currentLine->column; } /* @@ -837,10 +838,10 @@ EXTERN int m2flex_GetColumnNo (void) EXTERN location_t m2flex_GetLocation (void) { - if (currentLine != NULL) - return currentLine->location; - else + if (currentLine == NULL) return 0; + else + return currentLine->location; } /* diff --git a/gcc/m2/target-independent/m2/Builtins.texi b/gcc/m2/target-independent/m2/Builtins.texi index 4ebad46..57daddd 100644 --- a/gcc/m2/target-independent/m2/Builtins.texi +++ b/gcc/m2/target-independent/m2/Builtins.texi @@ -348,6 +348,15 @@ PROCEDURE __BUILTIN__ strchr (s: ADDRESS; c: INTEGER) : ADDRESS ; @findex strrchr PROCEDURE __BUILTIN__ strrchr (s: ADDRESS; c: INTEGER) : ADDRESS ; +@findex clz +PROCEDURE __BUILTIN__ clz (value: CARDINAL) : INTEGER ; +@findex clzll +PROCEDURE __BUILTIN__ clzll (value: LONGCARD) : INTEGER ; +@findex ctz +PROCEDURE __BUILTIN__ ctz (value: CARDINAL) : INTEGER ; +@findex ctzll +PROCEDURE __BUILTIN__ ctzll (value: LONGCARD) : INTEGER ; + (* longjmp - this GCC builtin restricts the val to always 1. *) diff --git a/gcc/m2/target-independent/m2/SYSTEM-iso.texi b/gcc/m2/target-independent/m2/SYSTEM-iso.texi index dbcc534..d195095 100644 --- a/gcc/m2/target-independent/m2/SYSTEM-iso.texi +++ b/gcc/m2/target-independent/m2/SYSTEM-iso.texi @@ -8,7 +8,7 @@ DEFINITION MODULE SYSTEM; (* The constants and types define underlying properties of storage *) EXPORT QUALIFIED BITSPERLOC, LOCSPERWORD, - LOC, BYTE, WORD, ADDRESS, CSIZE_T, CSSIZE_T, (* + LOC, BYTE, WORD, ADDRESS, CSIZE_T, CSSIZE_T, COFF_T, (* Target specific data types. *) ADDADR, SUBADR, DIFADR, MAKEADR, ADR, ROTATE, SHIFT, CAST, TSIZE, diff --git a/gcc/m2/target-independent/m2/SYSTEM-pim.texi b/gcc/m2/target-independent/m2/SYSTEM-pim.texi index bd446bd..59abfbe 100644 --- a/gcc/m2/target-independent/m2/SYSTEM-pim.texi +++ b/gcc/m2/target-independent/m2/SYSTEM-pim.texi @@ -3,7 +3,7 @@ DEFINITION MODULE SYSTEM ; EXPORT QUALIFIED BITSPERBYTE, BYTESPERWORD, - ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, (* + ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, COFF_T, CARDINAL64, (* Target specific data types. *) ADR, TSIZE, ROTATE, SHIFT, THROW, TBITSIZE ; (* SIZE is also exported if -fpim2 is used. *) diff --git a/gcc/m2/target-independent/m2/gm2-libs.texi b/gcc/m2/target-independent/m2/gm2-libs.texi index e707396..b4d4ffb 100644 --- a/gcc/m2/target-independent/m2/gm2-libs.texi +++ b/gcc/m2/target-independent/m2/gm2-libs.texi @@ -35,17 +35,21 @@ type results in a number of equivalent modules that can either handle These modules have been extensively tested and are used throughout building the GNU Modula-2 compiler. @menu +* gm2-libs/ARRAYOFCHAR::ARRAYOFCHAR.def * gm2-libs/ASCII::ASCII.def * gm2-libs/Args::Args.def * gm2-libs/Assertion::Assertion.def * gm2-libs/Break::Break.def * gm2-libs/Builtins::Builtins.def +* gm2-libs/CFileSysOp::CFileSysOp.def +* gm2-libs/CHAR::CHAR.def * gm2-libs/COROUTINES::COROUTINES.def * gm2-libs/CmdArgs::CmdArgs.def * gm2-libs/Debug::Debug.def * gm2-libs/DynamicStrings::DynamicStrings.def * gm2-libs/Environment::Environment.def * gm2-libs/FIO::FIO.def +* gm2-libs/FileSysOp::FileSysOp.def * gm2-libs/FormatStrings::FormatStrings.def * gm2-libs/FpuIO::FpuIO.def * gm2-libs/GetOpt::GetOpt.def @@ -76,7 +80,9 @@ building the GNU Modula-2 compiler. * gm2-libs/StrCase::StrCase.def * gm2-libs/StrIO::StrIO.def * gm2-libs/StrLib::StrLib.def +* gm2-libs/String::String.def * gm2-libs/StringConvert::StringConvert.def +* gm2-libs/StringFileSysOp::StringFileSysOp.def * gm2-libs/SysExceptions::SysExceptions.def * gm2-libs/SysStorage::SysStorage.def * gm2-libs/TimeString::TimeString.def @@ -95,7 +101,30 @@ building the GNU Modula-2 compiler. * gm2-libs/wrapc::wrapc.def @end menu -@node gm2-libs/ASCII, gm2-libs/Args, , Base libraries +@node gm2-libs/ARRAYOFCHAR, gm2-libs/ASCII, , Base libraries +@subsection gm2-libs/ARRAYOFCHAR + +@example +DEFINITION MODULE ARRAYOFCHAR ; + +FROM FIO IMPORT File ; + + +(* + Description: provides write procedures for ARRAY OF CHAR. +*) + +@findex Write +PROCEDURE Write (f: File; str: ARRAY OF CHAR) ; +@findex WriteLn +PROCEDURE WriteLn (f: File) ; + + +END ARRAYOFCHAR. +@end example +@page + +@node gm2-libs/ASCII, gm2-libs/Args, gm2-libs/ARRAYOFCHAR, Base libraries @subsection gm2-libs/ASCII @example @@ -232,7 +261,7 @@ END Break. @end example @page -@node gm2-libs/Builtins, gm2-libs/COROUTINES, gm2-libs/Break, Base libraries +@node gm2-libs/Builtins, gm2-libs/CFileSysOp, gm2-libs/Break, Base libraries @subsection gm2-libs/Builtins @example @@ -584,6 +613,15 @@ PROCEDURE __BUILTIN__ strchr (s: ADDRESS; c: INTEGER) : ADDRESS ; @findex strrchr PROCEDURE __BUILTIN__ strrchr (s: ADDRESS; c: INTEGER) : ADDRESS ; +@findex clz +PROCEDURE __BUILTIN__ clz (value: CARDINAL) : INTEGER ; +@findex clzll +PROCEDURE __BUILTIN__ clzll (value: LONGCARD) : INTEGER ; +@findex ctz +PROCEDURE __BUILTIN__ ctz (value: CARDINAL) : INTEGER ; +@findex ctzll +PROCEDURE __BUILTIN__ ctzll (value: LONGCARD) : INTEGER ; + (* longjmp - this GCC builtin restricts the val to always 1. *) @@ -632,7 +670,100 @@ END Builtins. @end example @page -@node gm2-libs/COROUTINES, gm2-libs/CmdArgs, gm2-libs/Builtins, Base libraries +@node gm2-libs/CFileSysOp, gm2-libs/CHAR, gm2-libs/Builtins, Base libraries +@subsection gm2-libs/CFileSysOp + +@example +DEFINITION MODULE CFileSysOp ; + +FROM SYSTEM IMPORT ADDRESS ; + + +(* + Description: provides access to filesystem operations. + The implementation module is written in C + and the parameters behave as their C + counterparts. +*) + +TYPE +@findex AccessMode (type) + AccessMode = SET OF AccessStatus ; +@findex AccessStatus (type) + AccessStatus = (F_OK, R_OK, W_OK, X_OK, A_FAIL) ; + + +@findex Unlink +PROCEDURE Unlink (filename: ADDRESS) : INTEGER ; + + +(* + Access - test access to a path or file. The behavior is + the same as defined in access(2). Except that + on A_FAIL is only used during the return result + indicating the underlying C access has returned + -1 (and errno can be checked). +*) + +@findex Access +PROCEDURE Access (pathname: ADDRESS; mode: AccessMode) : AccessMode ; + + +(* Return TRUE if the caller can see the existance of the file or + directory on the filesystem. *) + +(* + IsDir - return true if filename is a regular directory. +*) + +@findex IsDir +PROCEDURE IsDir (dirname: ADDRESS) : BOOLEAN ; + + +(* + IsFile - return true if filename is a regular file. +*) + +@findex IsFile +PROCEDURE IsFile (filename: ADDRESS) : BOOLEAN ; + + +(* + Exists - return true if pathname exists. +*) + +@findex Exists +PROCEDURE Exists (pathname: ADDRESS) : BOOLEAN ; + + +END CFileSysOp. +@end example +@page + +@node gm2-libs/CHAR, gm2-libs/COROUTINES, gm2-libs/CFileSysOp, Base libraries +@subsection gm2-libs/CHAR + +@example +DEFINITION MODULE CHAR ; + +FROM FIO IMPORT File ; + + +(* + Write a single character ch to file f. +*) + +@findex Write +PROCEDURE Write (f: File; ch: CHAR) ; +@findex WriteLn +PROCEDURE WriteLn (f: File) ; + + +END CHAR. +@end example +@page + +@node gm2-libs/COROUTINES, gm2-libs/CmdArgs, gm2-libs/CHAR, Base libraries @subsection gm2-libs/COROUTINES @example @@ -1179,7 +1310,7 @@ END Environment. @end example @page -@node gm2-libs/FIO, gm2-libs/FormatStrings, gm2-libs/Environment, Base libraries +@node gm2-libs/FIO, gm2-libs/FileSysOp, gm2-libs/Environment, Base libraries @subsection gm2-libs/FIO @example @@ -1543,7 +1674,37 @@ END FIO. @end example @page -@node gm2-libs/FormatStrings, gm2-libs/FpuIO, gm2-libs/FIO, Base libraries +@node gm2-libs/FileSysOp, gm2-libs/FormatStrings, gm2-libs/FIO, Base libraries +@subsection gm2-libs/FileSysOp + +@example +DEFINITION MODULE FileSysOp ; + +FROM CFileSysOp IMPORT AccessMode ; + + +(* + Description: provides access to filesystem operations using + Modula-2 base types. +*) + +@findex Exists +PROCEDURE Exists (filename: ARRAY OF CHAR) : BOOLEAN ; +@findex IsDir +PROCEDURE IsDir (dirname: ARRAY OF CHAR) : BOOLEAN ; +@findex IsFile +PROCEDURE IsFile (filename: ARRAY OF CHAR) : BOOLEAN ; +@findex Unlink +PROCEDURE Unlink (filename: ARRAY OF CHAR) : BOOLEAN ; +@findex Access +PROCEDURE Access (pathname: ARRAY OF CHAR; mode: AccessMode) : AccessMode ; + + +END FileSysOp. +@end example +@page + +@node gm2-libs/FormatStrings, gm2-libs/FpuIO, gm2-libs/FileSysOp, Base libraries @subsection gm2-libs/FormatStrings @example @@ -1986,6 +2147,15 @@ PROCEDURE ForeachIndiceInIndexDo (i: Index; p: IndexProcedure) ; PROCEDURE IsEmpty (i: Index) : BOOLEAN ; +(* + FindIndice - returns the indice containing a. + It returns zero if a is not found in array i. +*) + +@findex FindIndice +PROCEDURE FindIndice (i: Index; a: ADDRESS) : CARDINAL ; + + END Indexing. @end example @page @@ -3303,7 +3473,7 @@ END SMathLib0. DEFINITION MODULE SYSTEM ; EXPORT QUALIFIED BITSPERBYTE, BYTESPERWORD, - ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, (* + ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, COFF_T, CARDINAL64, (* Target specific data types. *) ADR, TSIZE, ROTATE, SHIFT, THROW, TBITSIZE ; (* SIZE is also exported if -fpim2 is used. *) @@ -3872,7 +4042,7 @@ END StrIO. @end example @page -@node gm2-libs/StrLib, gm2-libs/StringConvert, gm2-libs/StrIO, Base libraries +@node gm2-libs/StrLib, gm2-libs/String, gm2-libs/StrIO, Base libraries @subsection gm2-libs/StrLib @example @@ -3946,7 +4116,25 @@ END StrLib. @end example @page -@node gm2-libs/StringConvert, gm2-libs/SysExceptions, gm2-libs/StrLib, Base libraries +@node gm2-libs/String, gm2-libs/StringConvert, gm2-libs/StrLib, Base libraries +@subsection gm2-libs/String + +@example +DEFINITION MODULE String ; + +FROM DynamicStrings IMPORT String ; +FROM FIO IMPORT File ; + +@findex Write +PROCEDURE Write (f: File; str: String) ; +@findex WriteLn +PROCEDURE WriteLn (f: File) ; + +END String. +@end example +@page + +@node gm2-libs/StringConvert, gm2-libs/StringFileSysOp, gm2-libs/String, Base libraries @subsection gm2-libs/StringConvert @example @@ -4290,7 +4478,33 @@ END StringConvert. @end example @page -@node gm2-libs/SysExceptions, gm2-libs/SysStorage, gm2-libs/StringConvert, Base libraries +@node gm2-libs/StringFileSysOp, gm2-libs/SysExceptions, gm2-libs/StringConvert, Base libraries +@subsection gm2-libs/StringFileSysOp + +@example +DEFINITION MODULE StringFileSysOp ; + +FROM DynamicStrings IMPORT String ; +FROM CFileSysOp IMPORT AccessMode ; + + +@findex Exists +PROCEDURE Exists (filename: String) : BOOLEAN ; +@findex IsDir +PROCEDURE IsDir (dirname: String) : BOOLEAN ; +@findex IsFile +PROCEDURE IsFile (filename: String) : BOOLEAN ; +@findex Unlink +PROCEDURE Unlink (filename: String) : BOOLEAN ; +@findex Access +PROCEDURE Access (pathname: String; mode: AccessMode) : AccessMode ; + + +END StringFileSysOp. +@end example +@page + +@node gm2-libs/SysExceptions, gm2-libs/SysStorage, gm2-libs/StringFileSysOp, Base libraries @subsection gm2-libs/SysExceptions @example @@ -4476,7 +4690,10 @@ EXPORT UNQUALIFIED alloca, memcpy, index, rindex, memcmp, memset, memmove, strcat, strncat, strcpy, strncpy, strcmp, strncmp, - strlen, strstr, strpbrk, strspn, strcspn, strchr, strrchr ; + strlen, strstr, strpbrk, strspn, strcspn, strchr, strrchr, + + clz, clzll, + ctz, ctzll ; @findex alloca PROCEDURE alloca (i: CARDINAL) : ADDRESS ; @@ -4732,6 +4949,16 @@ PROCEDURE strchr (s: ADDRESS; c: INTEGER) : ADDRESS ; @findex strrchr PROCEDURE strrchr (s: ADDRESS; c: INTEGER) : ADDRESS ; +@findex clz +PROCEDURE clz (value: CARDINAL) : INTEGER ; +@findex clzll +PROCEDURE clzll (value: CARDINAL) : INTEGER ; +@findex ctz +PROCEDURE ctz (value: CARDINAL) : INTEGER ; +@findex ctzll +PROCEDURE ctzll (value: CARDINAL) : INTEGER ; + + END cbuiltin. @end example @page @@ -4893,7 +5120,7 @@ PROCEDURE strtod (s: ADDRESS; VAR error: BOOLEAN) : REAL ; @findex dtoa PROCEDURE dtoa (d : REAL; - mode : Mode; + mode : INTEGER; ndigits : INTEGER; VAR decpt: INTEGER; VAR sign : BOOLEAN) : ADDRESS ; @@ -4999,7 +5226,7 @@ PROCEDURE strtold (s: ADDRESS; VAR error: BOOLEAN) : LONGREAL ; @findex ldtoa PROCEDURE ldtoa (d : LONGREAL; - mode : Mode; + mode : INTEGER; ndigits : INTEGER; VAR decpt: INTEGER; VAR sign : BOOLEAN) : ADDRESS ; @@ -5015,9 +5242,11 @@ END ldtoa. @example DEFINITION MODULE FOR "C" libc ; -FROM SYSTEM IMPORT ADDRESS, CSIZE_T, CSSIZE_T ; +FROM SYSTEM IMPORT ADDRESS, CSIZE_T, CSSIZE_T, COFF_T ; EXPORT UNQUALIFIED time_t, timeb, tm, ptrToTM, + atof, atoi, atol, atoll, + strtod, strtof, strtold, strtol, strtoll, strtoul, strtoull, write, read, system, abort, malloc, free, @@ -5072,6 +5301,99 @@ TYPE (* + double atof(const char *nptr) +*) + +@findex atof +PROCEDURE atof (nptr: ADDRESS) : REAL ; + + +(* + int atoi(const char *nptr) +*) + +@findex atoi +PROCEDURE atoi (nptr: ADDRESS) : INTEGER ; + + +(* + long atol(const char *nptr); +*) + +@findex atol +PROCEDURE atol (nptr: ADDRESS) : CSSIZE_T ; + + +(* + long long atoll(const char *nptr); +*) + +@findex atoll +PROCEDURE atoll (nptr: ADDRESS) : LONGINT ; + + +(* + double strtod(const char *restrict nptr, char **_Nullable restrict endptr) +*) + +@findex strtod +PROCEDURE strtod (nptr, endptr: ADDRESS) : REAL ; + + +(* + float strtof(const char *restrict nptr, char **_Nullable restrict endptr) +*) + +@findex strtof +PROCEDURE strtof (nptr, endptr: ADDRESS) : SHORTREAL ; + + +(* + long double strtold(const char *restrict nptr, + char **_Nullable restrict endptr) +*) + +@findex strtold +PROCEDURE strtold (nptr, endptr: ADDRESS) : LONGREAL ; + + +(* + long strtol(const char *restrict nptr, char **_Nullable restrict endptr, + int base) +*) + +@findex strtol +PROCEDURE strtol (nptr, endptr: ADDRESS; base: INTEGER) : CSSIZE_T ; + + +(* + long long strtoll(const char *restrict nptr, + char **_Nullable restrict endptr, int base) +*) + +@findex strtoll +PROCEDURE strtoll (nptr, endptr: ADDRESS; base: INTEGER) : LONGINT ; + + +(* + unsigned long strtoul(const char *restrict nptr, + char **_Nullable restrict endptr, int base) +*) + +@findex strtoul +PROCEDURE strtoul (nptr, endptr: ADDRESS; base: INTEGER) : CSIZE_T ; + + +(* + unsigned long long strtoull(const char *restrict nptr, + char **_Nullable restrict endptr, int base) +*) + +@findex strtoull +PROCEDURE strtoull (nptr, endptr: ADDRESS; base: INTEGER) : LONGCARD ; + + +(* ssize_t write (int d, void *buf, size_t nbytes) *) @@ -5222,7 +5544,7 @@ PROCEDURE close (d: INTEGER) : [ INTEGER ] ; *) @findex open -PROCEDURE open (filename: ADDRESS; oflag: INTEGER; ...) : INTEGER ; +PROCEDURE open (filename: ADDRESS; oflag: INTEGER; mode: INTEGER) : INTEGER ; (* @@ -5240,7 +5562,7 @@ PROCEDURE creat (filename: ADDRESS; mode: CARDINAL) : INTEGER; *) @findex lseek -PROCEDURE lseek (fd: INTEGER; offset: CSSIZE_T; whence: INTEGER) : [ CSSIZE_T ] ; +PROCEDURE lseek (fd: INTEGER; offset: COFF_T; whence: INTEGER) : [ COFF_T ] ; (* @@ -6720,7 +7042,7 @@ PROCEDURE BlockMoveBackward (dest, src: ADDRESS; n: CARDINAL) ; (* - BlockClear - fills, block..block+n-1, with zero's. + BlockClear - fills, block..block+n-1, with zeros. *) @findex BlockClear @@ -7381,7 +7703,7 @@ PROCEDURE Doio (VAR f: File) ; *) @findex FileNameChar -PROCEDURE FileNameChar (ch: CHAR) ; +PROCEDURE FileNameChar (ch: CHAR) : CHAR ; END FileSystem. @@ -7512,7 +7834,7 @@ VAR (* OpenInput - reads a string from stdin as the filename for reading. - If the filename ends with `.' then it appends the defext + If the filename ends with '.' then it appends the defext extension. The global variable Done is set if all was successful. *) @@ -7532,7 +7854,7 @@ PROCEDURE CloseInput ; (* OpenOutput - reads a string from stdin as the filename for writing. - If the filename ends with `.' then it appends the defext + If the filename ends with '.' then it appends the defext extension. The global variable Done is set if all was successful. *) @@ -8424,7 +8746,7 @@ EXPORT QUALIFIED SEMAPHORE, DESCRIPTOR, TYPE @findex SEMAPHORE (type) - SEMAPHORE ; (* defines Dijkstra's semaphores *) + SEMAPHORE ; (* defines Dijkstras semaphores *) @findex DESCRIPTOR (type) DESCRIPTOR ; (* handle onto a process *) @@ -8483,7 +8805,7 @@ PROCEDURE InitSemaphore (v: CARDINAL; Name: ARRAY OF CHAR) : SEMAPHORE ; (* - Wait - performs dijkstra's P operation on a semaphore. + Wait - performs dijkstras P operation on a semaphore. A process which calls this procedure will wait until the value of the semaphore is > 0 and then it will decrement this value. @@ -8494,7 +8816,7 @@ PROCEDURE Wait (s: SEMAPHORE) ; (* - Signal - performs dijkstra's V operation on a semaphore. + Signal - performs dijkstras V operation on a semaphore. A process which calls the procedure will increment the semaphores value. *) @@ -8621,7 +8943,7 @@ DEFINITION MODULE SYSTEM ; FROM COROUTINES IMPORT PROTECTION ; EXPORT QUALIFIED (* the following are built into the compiler: *) - ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, (* + ADDRESS, WORD, BYTE, CSIZE_T, CSSIZE_T, COFF_T, (* Target specific data types. *) ADR, TSIZE, ROTATE, SHIFT, THROW, TBITSIZE, (* SIZE is exported depending upon -fpim2 and @@ -13322,7 +13644,7 @@ DEFINITION MODULE SYSTEM; (* The constants and types define underlying properties of storage *) EXPORT QUALIFIED BITSPERLOC, LOCSPERWORD, - LOC, BYTE, WORD, ADDRESS, CSIZE_T, CSSIZE_T, (* + LOC, BYTE, WORD, ADDRESS, CSIZE_T, CSSIZE_T, COFF_T, (* Target specific data types. *) ADDADR, SUBADR, DIFADR, MAKEADR, ADR, ROTATE, SHIFT, CAST, TSIZE, @@ -14878,12 +15200,16 @@ IMPORT IOChan ; PROCEDURE SkipSpaces (cid: IOChan.ChanId) ; -(* The following procedures do not read past line marks. *) +(* CharAvailable returns TRUE if IOChan.ReadResult is notKnown or + allRight. *) @findex CharAvailable PROCEDURE CharAvailable (cid: IOChan.ChanId) : BOOLEAN ; +(* EofOrEoln returns TRUE if IOChan.ReadResult is endOfLine or + endOfInput. *) + @findex EofOrEoln PROCEDURE EofOrEoln (cid: IOChan.ChanId) : BOOLEAN ; |