diff options
Diffstat (limited to 'gcc/m2')
90 files changed, 3875 insertions, 939 deletions
diff --git a/gcc/m2/ChangeLog b/gcc/m2/ChangeLog index 694b062..ad10605 100644 --- a/gcc/m2/ChangeLog +++ b/gcc/m2/ChangeLog @@ -1,3 +1,502 @@ +2025-08-01 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/121354 + * gm2-compiler/M2GenGCC.mod (FoldHigh): Rewrite. + (IsUnboundedArray): New procedure function. + +2025-07-31 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/121314 + * mc-boot/GFormatStrings.cc (PerformFormatString): Rebuilt. + * mc-boot/GM2EXCEPTION.cc (M2EXCEPTION_M2Exception): Rebuilt. + * mc-boot/GSFIO.cc (SFIO_GetFileName): Rebuilt. + * mc-boot/GSFIO.h (SFIO_GetFileName): Rebuilt. + * mc-boot/Gdecl.cc: Rebuilt. + * mc-boot/GmcFileName.h: Rebuilt. + * mc/decl.mod (getStringChar): New procedure function. + (getStringContents): Call getStringChar. + (addQuotes): New procedure function. + (foldBinary): Call addQuotes to add delimiting quotes + to the new string. + +2025-07-29 Gaius Mulley <gaiusmod2@gmail.com> + + * gm2-compiler/M2GenGCC.mod (FoldBecomes): Remove all + local variables. + (CodeIndrX): Remove length. + Remove newstr. + * gm2-compiler/M2Range.mod (FoldTypeIndrX): Remove desType. + +2025-07-29 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/121289 + * gm2-compiler/M2Students.def (CheckVariableAgainstKeyword): New + parameter tok. + * gm2-compiler/M2Students.mod (CheckVariableAgainstKeyword): New + parameter tok. + Pass tok to PerformVariableKeywordCheck. + (PerformVariableKeywordCheck): New parameter tok. + Pass tok to MetaErrorStringT0. + * gm2-compiler/P2SymBuild.mod (BuildVariable): Pass tok to + CheckVariableAgainstKeyword. + * gm2-libs-iso/LowLong.mod (except): Replace with ... + (exceptSrc): ... this. + * gm2-libs-iso/LowReal.mod (except): Replace with ... + (exceptSrc): ... this. + * gm2-libs-iso/LowShort.mod (except): Replace with ... + (exceptSrc): ... this. + * gm2-libs-iso/Processes.mod (Wait): Replace from with fromCor. + * gm2-libs-iso/RndFile.mod (EndPos): Replace end with endP. + * gm2-libs/SCmdArgs.mod (GetArg): Replace start with startPos. + Replace end with endPos. + (NArg): Replace start with startPos. + Replace end with endPos. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gm2-gcc/m2linemap.cc: Update usage of "diagnostic_info" to + explicitly refer to "diagnostics::diagnostic_info". + * gm2-gcc/rtegraph.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gm2-gcc/m2linemap.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + * gm2-gcc/rtegraph.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gm2-gcc/m2color.cc: Update for move of diagnostic-color.h to + diagnostics/color.h. + +2025-07-23 Gaius Mulley <gaiusmod2@gmail.com> + + * gm2-libs/M2EXCEPTION.mod (M2Exception): Add return + exException in case Raise completes. + +2025-07-23 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/121164 + * gm2-compiler/P1SymBuild.mod: Remove PutProcTypeParam. + Remove PutProcTypeParam. + (CheckFileName): Remove. + (P1EndBuildDefinitionModule): Correct spelling. + (P1EndBuildImplementationModule): Ditto. + (P1EndBuildProgramModule): Ditto. + (EndBuildInnerModule): Ditto. + * gm2-compiler/P2SymBuild.mod (P2EndBuildDefModule): Correct + spelling. + (P2EndBuildImplementationModule): Ditto. + (P2EndBuildProgramModule): Ditto. + (EndBuildInnerModule): Ditto. + (CheckFormalParameterSection): Ditto. + * gm2-compiler/P3SymBuild.mod (P3EndBuildDefModule): Ditto. + * gm2-compiler/PCSymBuild.mod (PCEndBuildDefModule): Ditto. + (fixupProcedureType): Pass tok to PutProcTypeVarParam. + Pass tok to PutProcTypeParam. + * gm2-compiler/SymbolTable.def (PutProcTypeParam): Add tok + parameter. + (PutProcTypeVarParam): Ditto. + * gm2-compiler/SymbolTable.mod (SymParam): At change type to + CARDINAL. + New field FullTok. + New field Scope. + (SymVarParam): At change type to CARDINAL. + New field FullTok. + New field Scope. + (GetVarDeclTok): Check ShadowVar for NulSym and return At. + (PutParam): Initialize FullTok. + Initialize At. + Initialize Scope. + (PutVarParam): Initialize FullTok. + Assign At. + Initialize Scope. + (AddProcedureProcTypeParam): Add tok parameter. + (GetScope): Add ParamSym and VarParamSym clause. + (PutProcTypeVarParam): Add tok parameter. + Initialize At. + Initialize FullTok. + (GetDeclaredDefinition): Clause ParamSym return At. + Clause VarParamSym return At. + (GetDeclaredModule): Ditto. + (PutDeclaredDefinition): Remove clause ParamSym. + Remove clause VarParamSym. + (PutDeclaredModule): Remove clause ParamSym. + Remove clause VarParamSym. + +2025-07-18 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/121164 + * gm2-libs/ARRAYOFCHAR.mod (Write): Rename 2nd parameter + name a to str. + +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 + * gm2-compiler/M2GenGCC.mod (FoldBecomes): Remove the call to + RemoveQuad since this is performed by TypeCheckBecomes. + * gm2-compiler/PCSymBuild.mod (buildConstFunction): Rewrite + header comment. + Check for a set or a type aliased set and appropriately + skip type equivalences and obtain the element type. + * gm2-compiler/SymbolTable.mod (PutConst): Add call to + CheckBreak. + +2025-04-24 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119915 + * gm2-libs/FormatStrings.mod (PerformFormatString): Handle + the %u and %x format specifiers in a similar way to the %d + specifier. Avoid using Slice and use Copy instead. + +2025-04-24 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119914 + * gm2-compiler/M2Check.mod (checkConstMeta): Add check for + Ztype, Rtype and Ctype and unbounded arrays. + (IsZRCType): New procedure function. + (isZRC): Add comment. + * gm2-compiler/M2Quads.mod: + * gm2-compiler/M2Range.mod (gdbinit): New procedure. + (BreakWhenRangeCreated): Ditto. + (CheckBreak): Ditto. + (InitRange): Call CheckBreak. + (Init): Add gdbhook and initialize interactive watch point. + * gm2-compiler/SymbolTable.def (GetNthParamAnyClosest): New + procedure function. + * gm2-compiler/SymbolTable.mod (BreakSym): Remove constant. + (BreakSym): Add Variable. + (stop): Remove. + (gdbhook): New procedure. + (BreakWhenSymCreated): Ditto. + (CheckBreak): Ditto. + (NewSym): Call CheckBreak. + (Init): Add gdbhook and initialize interactive watch point. + (MakeProcedure): Replace guarded call to stop with CheckBreak. + (GetNthParamChoice): New procedure function. + (GetNthParamOrdered): Ditto. + (GetNthParamAnyClosest): Ditto. + (GetOuterModuleScope): Ditto. + +2025-04-11 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119735 + * gm2-compiler/M2MetaError.def: Hide %n from comment. + * gm2-compiler/SymbolTable.def (PutIncludedByDefinition): Remove ' + from comment. + * gm2-gcc/m2expr.def (init): Ditto. + * gm2-libiberty/pexecute.def: Ditto. + * gm2-libs-coroutines/Executive.def (InitSemaphore): Ditto. + (Wait): Ditto. + * gm2-libs-iso/ClientSocket.def: Ditto. + * gm2-libs-log/BlockOps.def (BlockMoveBackward): Ditto. + * gm2-libs-log/InOut.def: Ditto. + * mc/mcFileName.def: Ditto. + +2025-04-09 Jakub Jelinek <jakub@redhat.com> + + * gm2-compiler/M2MetaError.def: Fix comment typo, range" -> "range2". + +2025-03-30 Sandra Loosemore <sloosemore@baylibre.com> + + * lang.opt.urls: Regenerate. + +2025-03-28 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119504 + * gm2-compiler/M2Quads.mod (BuildHighFunction): Defend against + Type = NulSym and fall into BuildConstHighFromSym. + (BuildDesignatorArray): Rewrite to detect an array access to + a constant string. + (BuildDesignatorArrayStaticDynamic): New procedure. + +2025-03-25 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/119449 + * gm2-compiler/M2GCCDeclare.def (TryDeclareType): Remove tokenno + parameter. + * gm2-compiler/M2GCCDeclare.mod (TryDeclareType): Ditto. + * gm2-compiler/M2GenGCC.mod (FoldTBitsize): Remove op2 and + rename op1 as res and op3 as type. + (FoldStandardFunction): Call FoldTBitsize omitting op2. + * gm2-compiler/M2Quads.mod (GetTypeMin): Rewrite. + (GetTypeMinLower): New procedure function. + (GetTypeMax): Rewrite. + (GetTypeMaxLower): New procedure function. + * gm2-compiler/M2Range.mod (CheckCancelled): Comment out. + * gm2-compiler/M2System.mod (CreateMinMaxFor): Add realtype + parameter. + (MapType): Rewrite to use realtype. + (CreateType): Ditto. + (AttemptToCreateType): Ditto. + (MakeFixedSizedTypes): Add realtype boolean. + (InitPIMTypes): Ditto. + (InitISOTypes): Ditto. + (MakeExtraSystemTypes): Ditto. + * gm2-gcc/m2pp.cc (m2pp_nop_expr): Remove code. + * gm2-gcc/m2type.cc (IsGccRealType): New function. + (m2type_GetMinFrom): Rewrite. + (m2type_GetMaxFrom): Ditto. + (do_min_real): Declare static. + (do_max_real): Declare static. + +2025-03-20 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/118600 + * gm2-compiler/M2GenGCC.mod (PerformCodeBecomes): New procedure. + (CodeBecomes): Refactor and call PerformCodeBecomes. + * gm2-gcc/m2builtins.cc (gm2_strncpy_node): New global variable. + (DoBuiltinStrNCopy): New function. + (m2builtins_BuiltinStrNCopy): New function. + (m2builtins_init): Initialize gm2_strncpy_node. + * gm2-gcc/m2builtins.def (BuiltinStrNCopy): New procedure + function. + * gm2-gcc/m2builtins.h (m2builtins_BuiltinStrNCopy): New + function. + * gm2-gcc/m2statement.cc (copy_record_fields): New function. + (copy_array): Ditto. + (copy_strncpy): Ditto. + (copy_memcpy): Ditto. + (CopyByField_Lower): Ditto. + (m2statement_CopyByField): Ditto. + * gm2-gcc/m2statement.def (CopyByField): New procedure function. + * gm2-gcc/m2statement.h (m2statement_CopyByField): New function. + * gm2-gcc/m2type.cc (check_record_fields): Ditto. + (check_array_types): Ditto. + (m2type_IsGccStrictTypeEquivalent): Ditto. + * gm2-gcc/m2type.def (IsGccStrictTypeEquivalent): New procedure + function. + * gm2-gcc/m2type.h (m2type_IsAddress): Replace return type int + with bool. + 2025-03-16 Gaius Mulley <gaiusmod2@gmail.com> PR modula2/115111 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 528c51d..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) @@ -803,13 +968,72 @@ BEGIN THEN typeRight := GetDType (right) ; typeLeft := GetDType (left) ; - RETURN doCheckPair (result, tinfo, typeLeft, typeRight) + IF IsZRCType (typeLeft) AND IsUnbounded (typeRight) + THEN + RETURN falseReason2 ('the constant {%1a} is incompatible' + + ' with an unbounded array of {%2a}', + tinfo, typeLeft, typeRight) + ELSE + RETURN doCheckPair (result, tinfo, typeLeft, typeRight) + END END ; RETURN result 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. @@ -856,26 +1080,33 @@ 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 ; (* - isZRC - + IsZRCType - return TRUE if type is a ZType, RType or a CType. +*) + +PROCEDURE IsZRCType (type: CARDINAL) : BOOLEAN ; +BEGIN + RETURN (type = CType) OR (type = ZType) OR (type = RType) +END IsZRCType ; + + +(* + isZRC - return TRUE if zrc is a ZType, RType or a CType + and sym is either a complex type when zrc = CType + or is not a composite type when zrc is a RType or ZType. *) 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 @@ -894,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 @@ -919,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 @@ -940,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) @@ -952,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 @@ -960,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. @@ -972,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) @@ -1023,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 - *) @@ -1073,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) @@ -1264,7 +1521,6 @@ BEGIN END checkProcTypeEquivalence ; - (* checkTypeKindEquivalence - *) @@ -1534,7 +1790,7 @@ BEGIN THEN RETURN Address ELSE - RETURN GetSType (sym) + RETURN GetDType (sym) END END getSType ; @@ -1610,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 ; (* @@ -1633,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 @@ -1740,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) @@ -1786,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 ; @@ -1835,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 ; @@ -1879,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 ; @@ -1943,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.def b/gcc/m2/gm2-compiler/M2GCCDeclare.def index 1d87d6b..b3a5790 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.def +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.def @@ -98,7 +98,7 @@ PROCEDURE TryDeclareConstant (tokenno: CARDINAL; sym: CARDINAL) ; then enter it into the to do list. *) -PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ; +PROCEDURE TryDeclareType (type: CARDINAL) ; (* diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index 7dcf439..860a89a 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -144,7 +144,7 @@ FROM M2Base IMPORT IsPseudoBaseProcedure, IsPseudoBaseFunction, Boolean, True, False, Nil, IsRealType, IsNeededAtRunTime, IsComplexType ; -FROM M2System IMPORT IsPseudoSystemFunction, IsSystemType, +FROM M2System IMPORT IsPseudoSystemFunction, IsSystemType, IsRealN, GetSystemTypeMinMax, Address, Word, Byte, Loc, System, IntegerN, CardinalN, WordN, RealN, SetN, ComplexN, CSizeT, CSSizeT, COffT ; @@ -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 ; @@ -1918,7 +1928,7 @@ END IsAnyType ; then enter it into the to do list. *) -PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ; +PROCEDURE TryDeclareType (type: CARDINAL) ; BEGIN IF (type#NulSym) AND IsAnyType (type) THEN @@ -2013,7 +2023,7 @@ BEGIN ELSIF IsConstructor(sym) THEN DeclareConstantFromTree(sym, PopConstructorTree(tokenno)) - ELSIF IsRealType(GetDType(sym)) + ELSIF IsRealType (GetDType (sym)) OR IsRealN (GetDType (sym)) THEN type := GetDType(sym) ; DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopRealTree(), TRUE)) @@ -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 ec38dc2..2440b2a 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -43,7 +43,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue, IsConst, IsConstSet, IsProcedure, IsProcType, IsVar, IsVarParamAny, IsTemporary, IsTuple, IsEnumeration, - IsUnbounded, IsArray, IsSet, IsConstructor, + IsUnbounded, IsArray, IsSet, IsConstructor, IsConstructorConstant, IsProcedureVariable, IsUnboundedParamAny, IsRecordField, IsFieldVarient, IsVarient, IsRecord, @@ -232,7 +232,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct BuildReturnValueCode, SetLastFunction, BuildIncludeVarConst, BuildIncludeVarVar, BuildExcludeVarConst, BuildExcludeVarVar, - BuildBuiltinCallTree, + BuildBuiltinCallTree, CopyByField, GetParamTree, BuildCleanUp, BuildTryFinally, GetLastFunction, SetLastFunction, @@ -241,7 +241,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement, GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType, BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor, - GetArrayNoOfElements, GetTreeType ; + GetArrayNoOfElements, GetTreeType, IsGccStrictTypeEquivalent ; FROM m2block IMPORT RememberConstant, pushGlobalScope, popGlobalScope, finishFunctionDecl, pushFunctionScope, popFunctionScope, @@ -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) | @@ -2903,9 +2903,6 @@ END CheckStop ; *) PROCEDURE FoldBecomes (p: WalkAction; bb: BasicBlock; quad: CARDINAL) ; -VAR - op : QuadOperator ; - des, op2, expr: CARDINAL ; BEGIN IF DeclaredOperandsBecomes (p, quad) THEN @@ -2914,9 +2911,6 @@ BEGIN IF TypeCheckBecomes (p, quad) THEN PerformFoldBecomes (p, quad) - ELSE - GetQuad (quad, op, des, op2, expr) ; - RemoveQuad (p, des, quad) END END END @@ -3007,7 +3001,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}', @@ -3236,7 +3230,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 ; @@ -3498,6 +3492,29 @@ END checkDeclare ; (* + PerformCodeBecomes - +*) + +PROCEDURE PerformCodeBecomes (location: location_t; + virtpos: CARDINAL; des, expr: CARDINAL) ; +VAR + destree, exprtree: tree ; +BEGIN + destree := Mod2Gcc (des) ; + exprtree := FoldConstBecomes (virtpos, des, expr) ; + IF IsVar (des) AND IsVariableSSA (des) + THEN + Replace (des, exprtree) + ELSIF IsGccStrictTypeEquivalent (destree, exprtree) + THEN + BuildAssignmentStatement (location, destree, exprtree) + ELSE + CopyByField (location, destree, exprtree) + END +END PerformCodeBecomes ; + + +(* ------------------------------------------------------------------------------ := Operator ------------------------------------------------------------------------------ @@ -3530,7 +3547,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}', @@ -3576,14 +3593,7 @@ BEGIN ELSE IF checkBecomes (des, expr, virtpos, despos, exprpos) THEN - IF IsVar (des) AND IsVariableSSA (des) - THEN - Replace (des, FoldConstBecomes (virtpos, des, expr)) - ELSE - BuildAssignmentStatement (location, - Mod2Gcc (des), - FoldConstBecomes (virtpos, des, expr)) - END + PerformCodeBecomes (location, virtpos, des, expr) ELSE SubQuad (quad) (* We don't want multiple errors for the quad. *) END @@ -3905,8 +3915,6 @@ END NoWalkProcedure ; PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ; VAR - lefttype, - righttype, des, left, right: CARDINAL ; typeChecking, constExpr, @@ -3924,10 +3932,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, @@ -3937,19 +3943,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 @@ -3965,7 +3958,6 @@ END CheckBinaryExpressionTypes ; PROCEDURE CheckElementSetTypes (quad: CARDINAL) : BOOLEAN ; VAR - lefttype, righttype, ignore, left, right: CARDINAL ; constExpr, @@ -3982,13 +3974,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, @@ -4007,17 +3995,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 ; @@ -4821,18 +4798,17 @@ END FoldBuiltinTypeInfo ; PROCEDURE FoldTBitsize (tokenno: CARDINAL; p: WalkAction; quad: CARDINAL; - op1, op2, op3: CARDINAL) ; + res, type: CARDINAL) ; VAR - type : CARDINAL ; location: location_t ; BEGIN location := TokenToLocation(tokenno) ; - TryDeclareType (tokenno, op3) ; - type := GetDType (op3) ; + TryDeclareType (type) ; + type := GetDType (type) ; IF CompletelyResolved (type) THEN - AddModGcc (op1, BuildSystemTBitSize (location, Mod2Gcc (type))) ; - p (op1) ; + AddModGcc (res, BuildSystemTBitSize (location, Mod2Gcc (type))) ; + p (res) ; NoChange := FALSE ; SubQuad (quad) END @@ -4971,7 +4947,7 @@ BEGIN END ELSIF op2=TBitSize THEN - FoldTBitsize (tokenno, p, quad, op1, op2, op3) + FoldTBitsize (tokenno, p, quad, op1, op3) ELSE InternalError ('only expecting LENGTH, CAP, ABS, IM, RE') END @@ -6463,37 +6439,52 @@ END ResolveHigh ; (* + IsUnboundedArray - return TRUE if symbol is an unbounded array. +*) + +PROCEDURE IsUnboundedArray (sym: CARDINAL) : BOOLEAN ; +BEGIN + IF IsParameter (sym) OR IsVar (sym) + THEN + RETURN IsUnbounded (GetType (sym)) + END ; + RETURN FALSE +END IsUnboundedArray ; + + +(* FoldHigh - if the array is not dynamic then we should be able to remove the HighOp quadruple and assign op1 with - the known compile time HIGH(op3). + the known compile time HIGH(array). *) PROCEDURE FoldHigh (tokenno: CARDINAL; p: WalkAction; - quad: CARDINAL; op1, dim, op3: CARDINAL) ; + quad: CARDINAL; op1, dim, array: CARDINAL) ; VAR t : tree ; location: location_t ; BEGIN - (* firstly ensure that any constant literal is declared *) - TryDeclareConstant(tokenno, op3) ; - location := TokenToLocation(tokenno) ; - IF GccKnowsAbout(op3) AND CompletelyResolved(op3) + (* Firstly ensure that any constant literal is declared. *) + TryDeclareConstant (tokenno, array) ; + location := TokenToLocation (tokenno) ; + IF (NOT IsUnboundedArray (array)) AND + GccKnowsAbout (array) AND CompletelyResolved (array) THEN - t := ResolveHigh(tokenno, dim, op3) ; - (* fine, we can take advantage of this and fold constants *) - IF IsConst(op1) AND (t#tree(NIL)) + t := ResolveHigh (tokenno, dim, array) ; + (* We can take advantage of this and fold constants. *) + IF IsConst (op1) AND (t # tree (NIL)) THEN - PutConst(op1, Cardinal) ; - AddModGcc(op1, - DeclareKnownConstant(location, GetCardinalType(), - ToCardinal(location, t))) ; - p(op1) ; + PutConst (op1, Cardinal) ; + AddModGcc (op1, + DeclareKnownConstant (location, GetCardinalType (), + ToCardinal (location, t))) ; + p (op1) ; NoChange := FALSE ; - SubQuad(quad) + SubQuad (quad) ELSE - (* we can still fold the expression, but not the assignment, however, we will - not do this here but in CodeHigh - *) + (* We can still fold the expression but not the assignment, + we will not do this here but in CodeHigh when the result + can be stored. *) END END END FoldHigh ; @@ -8162,25 +8153,50 @@ 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 ; + 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 ; @@ -8217,6 +8233,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 637a27d..3dfe9fa 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.def +++ b/gcc/m2/gm2-compiler/M2MetaError.def @@ -73,7 +73,8 @@ FROM NameKey IMPORT Name ; {%kword} the string word is unquoted and rendered as a keyword. {%C} chain this error on the previous rooted error. {%R} this error will be the root of the future chained errors. - {%n} decimal number. Not quoted. + {% n} decimal number. Not quoted. There is no space between the + % and n (this has been added to hide this comment from gettext). {%N} count (number), for example, 1st, 2nd, 3rd, 4th. Not quoted. {%X} push contents of the output string onto the string stack. {%Yname} place contents of dictionary entry name onto the output string. @@ -92,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 @@ -109,7 +110,8 @@ FROM NameKey IMPORT Name ; describe the symbol. If ordinary text is copied then it is not quoted. The color strings are: "filename", "quote", "error", "warning", "note", - "locus", "insert", "delete", "type", "range1", range2". + "locus", "insert", "delete", "type", "range1", + "range2". *) (* 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 a45d67a..748ce24 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -69,6 +69,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown, GetArraySubscript, GetDimension, GetParam, GetNth, GetNthParamAny, + GetNthParamAnyClosest, GetFirstUsed, GetDeclaredMod, GetQuads, GetReadQuads, GetWriteQuads, GetWriteLimitQuads, GetReadLimitQuads, @@ -225,6 +226,7 @@ FROM M2Options IMPORT NilChecking, GenerateLineDebug, Exceptions, Profiling, Coding, Optimizing, UninitVariableChecking, + StrictTypeAssignment, ScaffoldDynamic, ScaffoldStatic, cflag, ScaffoldMain, SharedFlag, WholeProgram, GetDumpDir, GetM2DumpFilter, @@ -257,8 +259,10 @@ FROM M2Range IMPORT InitAssignmentRangeCheck, InitRotateCheck, InitShiftCheck, InitTypesAssignmentCheck, + InitTypesIndrXCheck, InitTypesExpressionCheck, InitTypesParameterCheck, + InitTypesReturnTypeCheck, InitForLoopBeginRangeCheck, InitForLoopToRangeCheck, InitForLoopEndRangeCheck, @@ -283,7 +287,6 @@ IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ; CONST DebugStackOn = TRUE ; DebugVarients = FALSE ; - BreakAtQuad = 758 ; DebugTokPos = FALSE ; TYPE @@ -396,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. *) (* @@ -1486,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. @@ -3887,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 @@ -4654,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) @@ -5627,7 +5621,7 @@ VAR proctok, paramtok : CARDINAL ; n1, n2 : Name ; - ParamCheckId, + ParamCheckId, Dim, Actual, FormalI, @@ -5676,7 +5670,8 @@ BEGIN WHILE i<=ParamTotal DO IF i <= NoOfParamAny (Proc) THEN - FormalI := GetParam(Proc, i) ; + (* FormalI := GetParam(Proc, i) ; *) + FormalI := GetNthParamAnyClosest (Proc, i, GetCurrentModule ()) ; IF CompilerDebugging THEN n1 := GetSymName(FormalI) ; @@ -5768,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, - GetParam (CheckedProcedure, i), - 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 ; @@ -6150,7 +6149,7 @@ BEGIN MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ; IF NoOfParamAny (ProcedureSym) >= ParameterNo THEN - FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ; + FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo, GetCurrentModule ()) ; IF IsUnboundedParamAny (ProcedureSym, ParameterNo) THEN MetaErrorT2 (GetVarDeclFullTok (FormalParam), 'formal parameter {%1ad} has an open array type {%2tad}', @@ -6205,7 +6204,7 @@ BEGIN MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ; IF NoOfParamAny (ProcedureSym) >= ParameterNo THEN - FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ; + FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo, GetCurrentModule ()) ; IF IsUnboundedParamAny (ProcedureSym, ParameterNo) THEN MetaErrorT2 (GetVarDeclFullTok (FormalParam), '{%W}formal parameter {%1ad} has an open array type {%2tad}', @@ -6270,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 ; @@ -8474,7 +8476,7 @@ BEGIN THEN (* we cannot test for IsConst(Param) AND (GetSType(Param)=Char) as the type might not be assigned yet *) MetaError1 ('base procedure {%EkHIGH} expects a variable or string constant as its parameter {%1d:rather than {%1d}} {%1asa}', Param) - ELSIF IsUnbounded(Type) + ELSIF (Type # NulSym) AND IsUnbounded(Type) THEN BuildHighFromUnbounded (combinedtok) ELSE @@ -9776,11 +9778,30 @@ END CheckBaseTypeValue ; (* - GetTypeMin - returns the minimium value of type. + GetTypeMin - returns the minimium value of type and generate an error + if this is unavailable. *) PROCEDURE GetTypeMin (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; VAR + min: CARDINAL ; +BEGIN + min := GetTypeMinLower (tok, func, type) ; + IF min = NulSym + THEN + MetaErrorT1 (tok, + 'unable to obtain the {%AkMIN} value for type {%1ad}', type) + END ; + RETURN min +END GetTypeMin ; + + +(* + GetTypeMinLower - obtain the maximum value for type. +*) + +PROCEDURE GetTypeMinLower (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; +VAR min, max: CARDINAL ; BEGIN IF IsSubrange (type) @@ -9803,22 +9824,38 @@ BEGIN RETURN min ELSIF GetSType (type) = NulSym THEN - MetaErrorT1 (tok, - 'unable to obtain the {%AkMIN} value for type {%1ad}', type) ; - (* non recoverable error. *) - InternalError ('MetaErrorT1 {%AkMIN} should call abort') + RETURN NulSym ELSE RETURN GetTypeMin (tok, func, GetSType (type)) END -END GetTypeMin ; +END GetTypeMinLower ; (* - GetTypeMax - returns the maximum value of type. + GetTypeMax - returns the maximum value of type and generate an error + if this is unavailable. *) PROCEDURE GetTypeMax (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; VAR + max: CARDINAL ; +BEGIN + max := GetTypeMaxLower (tok, func, type) ; + IF max = NulSym + THEN + MetaErrorT1 (tok, + 'unable to obtain the {%AkMAX} value for type {%1ad}', type) + END ; + RETURN max +END GetTypeMax ; + + +(* + GetTypeMaxLower - obtain the maximum value for type. +*) + +PROCEDURE GetTypeMaxLower (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; +VAR min, max: CARDINAL ; BEGIN IF IsSubrange (type) @@ -9841,14 +9878,11 @@ BEGIN RETURN max ELSIF GetSType (type) = NulSym THEN - MetaErrorT1 (tok, - 'unable to obtain the {%AkMAX} value for type {%1ad}', type) ; - (* non recoverable error. *) - InternalError ('MetaErrorT1 {%AkMAX} should call abort') + RETURN NulSym ELSE RETURN GetTypeMax (tok, func, GetSType (type)) END -END GetTypeMax ; +END GetTypeMaxLower ; (* @@ -11261,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: @@ -11285,7 +11348,6 @@ PROCEDURE BuildReturn (tokreturn: CARDINAL) ; VAR tokcombined, tokexpr : CARDINAL ; - e2, t2, e1, t1, t, f, Des : CARDINAL ; @@ -11305,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) ; @@ -11449,13 +11503,12 @@ END BuildDesignatorPointerError ; (* BuildDesignatorArray - Builds the array referencing. The purpose of this procedure is to work out - whether the DesignatorArray is a static or - dynamic array and to call the appropriate + whether the DesignatorArray is a constant string or + dynamic array/static array and to call the appropriate BuildRoutine. The Stack is expected to contain: - Entry Exit ===== ==== @@ -11468,6 +11521,41 @@ END BuildDesignatorPointerError ; *) PROCEDURE BuildDesignatorArray ; +BEGIN + IF IsConst (OperandT (2)) AND IsConstString (OperandT (2)) + THEN + MetaErrorT1 (OperandTtok (2), + '{%1Ead} is not an array, but a constant string. Hint use a string constant created with an array constructor', + OperandT (2)) ; + BuildDesignatorError ('bad array access') + ELSE + BuildDesignatorArrayStaticDynamic + END +END BuildDesignatorArray ; + + +(* + BuildDesignatorArrayStaticDynamic - Builds the array referencing. + The purpose of this procedure is to work out + whether the DesignatorArray is a static or + dynamic array and to call the appropriate + BuildRoutine. + + The Stack is expected to contain: + + + Entry Exit + ===== ==== + + Ptr -> + +--------------+ + | e | <- Ptr + |--------------| +------------+ + | Sym | Type | | S | T | + |--------------| |------------| +*) + +PROCEDURE BuildDesignatorArrayStaticDynamic ; VAR combinedTok, arrayTok, @@ -11480,10 +11568,7 @@ BEGIN IF IsConst (OperandT (2)) THEN type := GetDType (OperandT (2)) ; - IF type = NulSym - THEN - InternalError ('constant type should have been resolved') - ELSIF IsArray (type) + IF (type # NulSym) AND IsArray (type) THEN PopTtok (e, exprTok) ; PopTFDtok (Sym, Type, dim, arrayTok) ; @@ -11501,7 +11586,7 @@ BEGIN IF (NOT IsVar (OperandT (2))) AND (NOT IsTemporary (OperandT (2))) THEN MetaErrorT1 (OperandTtok (2), - 'can only access arrays using variables or formal parameters not {%1Ead}', + 'can only access arrays using constants, variables or formal parameters not {%1Ead}', OperandT (2)) ; BuildDesignatorError ('bad array access') END ; @@ -11528,7 +11613,7 @@ BEGIN Sym) ; BuildDesignatorError ('bad array access') END -END BuildDesignatorArray ; +END BuildDesignatorArrayStaticDynamic ; (* @@ -15996,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 347012b..f1516d3 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, @@ -154,6 +155,34 @@ TYPE VAR TopOfRange: CARDINAL ; RangeIndex: Index ; + BreakRange: CARDINAL ; + + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenRangeCreated - to be called interactively by gdb. +*) + +PROCEDURE BreakWhenRangeCreated (r: CARDINAL) ; +BEGIN + BreakRange := r +END BreakWhenRangeCreated ; + + +(* + CheckBreak - if sym = BreakRange then call gdbhook. +*) + +PROCEDURE CheckBreak (r: CARDINAL) ; +BEGIN + IF BreakRange = r + THEN + gdbhook + END +END CheckBreak ; (* @@ -261,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 ) | @@ -302,6 +332,7 @@ BEGIN THEN InternalError ('out of memory error') ELSE + CheckBreak (r) ; WITH p^ DO type := none ; des := NulSym ; @@ -793,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. *) @@ -808,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. *) @@ -1190,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 ) | @@ -1217,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) ; @@ -1230,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) @@ -1246,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 @@ -1257,6 +1326,7 @@ END FoldAssignment ; CheckCancelled - check to see if the range has been cancelled and if so remove quad. *) +(* PROCEDURE CheckCancelled (range: CARDINAL; quad: CARDINAL) ; BEGIN IF IsCancelled (range) @@ -1264,6 +1334,7 @@ BEGIN SubQuad (quad) END END CheckCancelled ; +*) (* @@ -1726,21 +1797,92 @@ 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 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. *) + 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 @@ -1754,14 +1896,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 ; (* @@ -1828,35 +1972,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 ; (* @@ -1910,9 +2109,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') @@ -1943,9 +2144,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') @@ -1974,7 +2177,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', @@ -2388,9 +2591,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) | @@ -3526,6 +3731,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') | @@ -3574,9 +3781,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) | @@ -3712,6 +3921,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) | @@ -3744,7 +3955,19 @@ END WriteRangeCheck ; PROCEDURE Init ; BEGIN TopOfRange := 0 ; - RangeIndex := InitIndex(1) + RangeIndex := InitIndex(1) ; + BreakWhenRangeCreated (0) ; (* Disable the intereactive range watch. *) + (* To examine the range when it is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenRangeCreated with the symbol + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenRangeCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this symbol is created. *) END Init ; diff --git a/gcc/m2/gm2-compiler/M2Students.def b/gcc/m2/gm2-compiler/M2Students.def index 7d67a0a..a3ecdcd 100644 --- a/gcc/m2/gm2-compiler/M2Students.def +++ b/gcc/m2/gm2-compiler/M2Students.def @@ -39,7 +39,7 @@ EXPORT QUALIFIED StudentVariableCheck, CheckVariableAgainstKeyword ; as a keyword except for its case. *) -PROCEDURE CheckVariableAgainstKeyword (name: Name) ; +PROCEDURE CheckVariableAgainstKeyword (tok: CARDINAL; name: Name) ; (* diff --git a/gcc/m2/gm2-compiler/M2Students.mod b/gcc/m2/gm2-compiler/M2Students.mod index e539eb0..3df160a 100644 --- a/gcc/m2/gm2-compiler/M2Students.mod +++ b/gcc/m2/gm2-compiler/M2Students.mod @@ -25,7 +25,7 @@ IMPLEMENTATION MODULE M2Students ; FROM SymbolTable IMPORT FinalSymbol, IsVar, IsProcedure, IsModule, GetMainModule, IsType, NulSym, IsRecord, GetSymName, GetNth, GetNthProcedure, GetDeclaredMod, NoOfParam ; FROM NameKey IMPORT GetKey, WriteKey, MakeKey, IsSameExcludingCase, NulName, makekey, KeyToCharStar ; -FROM M2MetaError IMPORT MetaErrorString0, MetaError2 ; +FROM M2MetaError IMPORT MetaErrorStringT0, MetaError2 ; FROM Lists IMPORT List, InitList, IsItemInList, IncludeItemIntoList ; FROM M2Reserved IMPORT IsReserved, toktype ; FROM DynamicStrings IMPORT String, InitString, KillString, ToUpper, InitStringCharStar, string, Mark, ToUpper, Dup ; @@ -78,11 +78,11 @@ END IsNotADuplicateName ; as a keyword except for its case. *) -PROCEDURE CheckVariableAgainstKeyword (name: Name) ; +PROCEDURE CheckVariableAgainstKeyword (tok: CARDINAL; name: Name) ; BEGIN IF StyleChecking THEN - PerformVariableKeywordCheck (name) + PerformVariableKeywordCheck (tok, name) END END CheckVariableAgainstKeyword ; @@ -91,7 +91,7 @@ END CheckVariableAgainstKeyword ; PerformVariableKeywordCheck - performs the check and constructs the metaerror notes if appropriate. *) -PROCEDURE PerformVariableKeywordCheck (name: Name) ; +PROCEDURE PerformVariableKeywordCheck (tok: CARDINAL; name: Name) ; VAR upper : Name ; token : toktype ; @@ -105,9 +105,11 @@ BEGIN THEN IF IsNotADuplicateName (name) THEN - MetaErrorString0 (Sprintf2 (Mark (InitString ('either the identifier has the same name as a keyword or alternatively a keyword has the wrong case ({%%K%s} and {!%%O:{%%K%s}})')), - upperS, orig)) ; - MetaErrorString0 (Sprintf1 (Mark (InitString ('the symbol name {!%%O:{%%K%s}} is legal as an identifier, however as such it might cause confusion and is considered bad programming practice')), orig)) + MetaErrorStringT0 (tok, + Sprintf2 (Mark (InitString ('either the identifier has the same name as a keyword or alternatively a keyword has the wrong case ({%%K%s} and {!%%O:{%%K%s}})')), + upperS, orig)) ; + MetaErrorStringT0 (tok, + Sprintf1 (Mark (InitString ('the symbol name {!%%O:{%%K%s}} is legal as an identifier, however as such it might cause confusion and is considered bad programming practice')), orig)) END END ; upperS := KillString (upperS) ; diff --git a/gcc/m2/gm2-compiler/M2System.mod b/gcc/m2/gm2-compiler/M2System.mod index efd5d11..68ed9dc 100644 --- a/gcc/m2/gm2-compiler/M2System.mod +++ b/gcc/m2/gm2-compiler/M2System.mod @@ -61,7 +61,7 @@ FROM NameKey IMPORT Name, MakeKey, NulName ; FROM M2Batch IMPORT MakeDefinitionSource ; FROM M2Base IMPORT Cardinal, ZType ; FROM M2Size IMPORT Size, MakeSize ; -FROM M2ALU IMPORT PushCard, PushIntegerTree, DivTrunc ; +FROM M2ALU IMPORT PushCard, PushIntegerTree, PushRealTree, DivTrunc ; FROM M2Error IMPORT InternalError ; FROM Lists IMPORT List, InitList, IsItemInList, PutItemIntoList, GetItemFromList, NoOfItemsInList ; FROM SymbolKey IMPORT SymbolTree, InitTree, GetSymKey, PutSymKey ; @@ -114,21 +114,32 @@ END Init ; (* - CreateMinMaxFor - creates the min and max values for, type, given gccType. + CreateMinMaxFor - creates the min and max values for type given gccType. *) -PROCEDURE CreateMinMaxFor (type: CARDINAL; min, max: ARRAY OF CHAR; gccType: tree) ; +PROCEDURE CreateMinMaxFor (type: CARDINAL; min, max: ARRAY OF CHAR; + gccType: tree; realtype: BOOLEAN) ; VAR maxval, minval: CARDINAL ; BEGIN maxval := MakeConstVar (BuiltinTokenNo, MakeKey(max)) ; - PushIntegerTree (GetMaxFrom (BuiltinsLocation (), gccType)) ; + IF realtype + THEN + PushRealTree (GetMaxFrom (BuiltinsLocation (), gccType)) + ELSE + PushIntegerTree (GetMaxFrom (BuiltinsLocation (), gccType)) + END ; PopValue (maxval) ; PutVar (maxval, type) ; PutSymKey (MaxValues, GetSymName (type), maxval) ; minval := MakeConstVar (BuiltinTokenNo, MakeKey(min)) ; - PushIntegerTree (GetMinFrom (BuiltinsLocation (), gccType)) ; + IF realtype + THEN + PushRealTree (GetMinFrom (BuiltinsLocation (), gccType)) + ELSE + PushIntegerTree (GetMinFrom (BuiltinsLocation (), gccType)) + END ; PopValue (minval) ; PutVar (minval, type) ; PutSymKey (MinValues, GetSymName (type), minval) @@ -136,31 +147,32 @@ END CreateMinMaxFor ; (* - MapType - + MapType - create a mapping of the M2 frontend type to gcctype. *) PROCEDURE MapType (type: CARDINAL; name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; t: tree) ; + needsExporting: BOOLEAN; + gcctype: tree; realtype: BOOLEAN) ; VAR n: Name ; BEGIN - PushIntegerTree(BuildSize(BuiltinsLocation(), t, FALSE)) ; - PopSize(type) ; - IF IsItemInList(SystemTypes, type) + PushIntegerTree (BuildSize (BuiltinsLocation (), gcctype, FALSE)) ; + PopSize (type) ; + IF IsItemInList (SystemTypes, type) THEN InternalError ('not expecting system type to already be declared') END ; - PutItemIntoList(SystemTypes, type) ; + PutItemIntoList (SystemTypes, type) ; - (* create min, max constants if type is ordinal *) - IF (NOT StrEqual(min, '')) AND (NOT StrEqual(max, '')) + (* Create min, max constants if type is ordinal or a floating point type. *) + IF (NOT StrEqual (min, '')) AND (NOT StrEqual (max, '')) THEN - CreateMinMaxFor(type, min, max, t) + CreateMinMaxFor (type, min, max, gcctype, realtype) END ; IF needsExporting AND DumpSystemExports THEN - n := GetSymName(type) ; + n := GetSymName (type) ; printf1('SYSTEM module creates type: %a\n', n) END END MapType ; @@ -171,7 +183,8 @@ END MapType ; *) PROCEDURE CreateType (name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; gccType: tree) : CARDINAL ; + needsExporting: BOOLEAN; gccType: tree; + realtype: BOOLEAN) : CARDINAL ; VAR type: CARDINAL ; BEGIN @@ -183,7 +196,7 @@ BEGIN (* Create base type. *) type := MakeType (BuiltinTokenNo, MakeKey (name)) ; PutType (type, NulSym) ; (* a Base Type *) - MapType (type, name, min, max, needsExporting, gccType) ; + MapType (type, name, min, max, needsExporting, gccType, realtype) ; RETURN type END END CreateType ; @@ -195,9 +208,11 @@ END CreateType ; *) PROCEDURE AttemptToCreateType (name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; gccType: tree) ; + needsExporting: BOOLEAN; gccType: tree; + realtype: BOOLEAN) ; BEGIN - Assert (IsLegal (CreateType (name, min, max, needsExporting, gccType))) + Assert (IsLegal (CreateType (name, min, max, needsExporting, + gccType, realtype))) END AttemptToCreateType ; @@ -226,7 +241,7 @@ BEGIN subrange := MakeSubrange (BuiltinTokenNo, NulName) ; PutSubrange (subrange, low, high, Cardinal) ; PutSet (type, subrange, FALSE) ; - MapType (type, name, '', '', needsExporting, gccType) ; + MapType (type, name, '', '', needsExporting, gccType, FALSE) ; RETURN type END END CreateSetType ; @@ -251,33 +266,33 @@ END AttemptToCreateSetType ; PROCEDURE MakeFixedSizedTypes ; BEGIN - AttemptToCreateType ('INTEGER8', 'MinInteger8', 'MaxInteger8', TRUE, GetM2Integer8 ()) ; - AttemptToCreateType ('INTEGER16', 'MinInteger16', 'MaxInteger16', TRUE, GetM2Integer16 ()) ; - AttemptToCreateType ('INTEGER32', 'MinInteger32', 'MaxInteger32', TRUE, GetM2Integer32 ()) ; - AttemptToCreateType ('INTEGER64', 'MinInteger64', 'MaxInteger64', TRUE, GetM2Integer64 ()) ; + AttemptToCreateType ('INTEGER8', 'MinInteger8', 'MaxInteger8', TRUE, GetM2Integer8 (), FALSE) ; + AttemptToCreateType ('INTEGER16', 'MinInteger16', 'MaxInteger16', TRUE, GetM2Integer16 (), FALSE) ; + AttemptToCreateType ('INTEGER32', 'MinInteger32', 'MaxInteger32', TRUE, GetM2Integer32 (), FALSE) ; + AttemptToCreateType ('INTEGER64', 'MinInteger64', 'MaxInteger64', TRUE, GetM2Integer64 (), FALSE) ; - AttemptToCreateType ('CARDINAL8', 'MinCardinal8', 'MaxCardinal8', TRUE, GetM2Cardinal8 ()) ; - AttemptToCreateType ('CARDINAL16', 'MinCardinal16', 'MaxCardinal16', TRUE, GetM2Cardinal16 ()) ; - AttemptToCreateType ('CARDINAL32', 'MinCardinal32', 'MaxCardinal32', TRUE, GetM2Cardinal32 ()) ; - AttemptToCreateType ('CARDINAL64', 'MinCardinal64', 'MaxCardinal64', TRUE, GetM2Cardinal64 ()) ; + AttemptToCreateType ('CARDINAL8', 'MinCardinal8', 'MaxCardinal8', TRUE, GetM2Cardinal8 (), FALSE) ; + AttemptToCreateType ('CARDINAL16', 'MinCardinal16', 'MaxCardinal16', TRUE, GetM2Cardinal16 (), FALSE) ; + AttemptToCreateType ('CARDINAL32', 'MinCardinal32', 'MaxCardinal32', TRUE, GetM2Cardinal32 (), FALSE) ; + AttemptToCreateType ('CARDINAL64', 'MinCardinal64', 'MaxCardinal64', TRUE, GetM2Cardinal64 (), FALSE) ; - AttemptToCreateType ('WORD16', '', '', TRUE, GetM2Word16 ()) ; - AttemptToCreateType ('WORD32', '', '', TRUE, GetM2Word32 ()) ; - AttemptToCreateType ('WORD64', '', '', TRUE, GetM2Word64 ()) ; + AttemptToCreateType ('WORD16', '', '', TRUE, GetM2Word16 (), FALSE) ; + AttemptToCreateType ('WORD32', '', '', TRUE, GetM2Word32 (), FALSE) ; + AttemptToCreateType ('WORD64', '', '', TRUE, GetM2Word64 (), FALSE) ; AttemptToCreateSetType ('BITSET8' , '7' , TRUE, GetM2Bitset8 ()) ; AttemptToCreateSetType ('BITSET16', '15', TRUE, GetM2Bitset16 ()) ; AttemptToCreateSetType ('BITSET32', '31', TRUE, GetM2Bitset32 ()) ; - AttemptToCreateType ('REAL32', '', '', TRUE, GetM2Real32 ()) ; - AttemptToCreateType ('REAL64', '', '', TRUE, GetM2Real64 ()) ; - AttemptToCreateType ('REAL96', '', '', TRUE, GetM2Real96 ()) ; - AttemptToCreateType ('REAL128', '', '', TRUE, GetM2Real128 ()) ; + AttemptToCreateType ('REAL32', 'MinReal32', 'MaxReal32', TRUE, GetM2Real32 (), TRUE) ; + AttemptToCreateType ('REAL64', 'MinReal64', 'MaxReal64', TRUE, GetM2Real64 (), TRUE) ; + AttemptToCreateType ('REAL96', 'MinReal96', 'MaxReal96', TRUE, GetM2Real96 (), TRUE) ; + AttemptToCreateType ('REAL128', 'MinReal128', 'MaxReal128', TRUE, GetM2Real128 (), TRUE) ; - AttemptToCreateType ('COMPLEX32', '', '', TRUE, GetM2Complex32 ()) ; - AttemptToCreateType ('COMPLEX64', '', '', TRUE, GetM2Complex64 ()) ; - AttemptToCreateType ('COMPLEX96', '', '', TRUE, GetM2Complex96 ()) ; - AttemptToCreateType ('COMPLEX128', '', '', TRUE, GetM2Complex128 ()) + AttemptToCreateType ('COMPLEX32', '', '', TRUE, GetM2Complex32 (), TRUE) ; + AttemptToCreateType ('COMPLEX64', '', '', TRUE, GetM2Complex64 (), TRUE) ; + AttemptToCreateType ('COMPLEX96', '', '', TRUE, GetM2Complex96 (), TRUE) ; + AttemptToCreateType ('COMPLEX128', '', '', TRUE, GetM2Complex128 (), TRUE) END MakeFixedSizedTypes ; @@ -287,16 +302,16 @@ END MakeFixedSizedTypes ; PROCEDURE InitPIMTypes ; BEGIN - Loc := CreateType ('LOC', '', '', TRUE, GetISOLocType()) ; + Loc := CreateType ('LOC', '', '', TRUE, GetISOLocType(), FALSE) ; InitSystemTypes(BuiltinsLocation(), Loc) ; - Word := CreateType ('WORD', '', '', TRUE, GetWordType()) ; - Byte := CreateType ('BYTE', '', '', TRUE, GetByteType()) ; + Word := CreateType ('WORD', '', '', TRUE, GetWordType(), FALSE) ; + Byte := CreateType ('BYTE', '', '', TRUE, GetByteType(), FALSE) ; (* ADDRESS = POINTER TO BYTE *) Address := MakePointer (BuiltinTokenNo, MakeKey('ADDRESS')) ; PutPointer (Address, Byte) ; (* Base Type *) - MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType()) + MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE) END InitPIMTypes ; @@ -306,17 +321,15 @@ END InitPIMTypes ; PROCEDURE InitISOTypes ; BEGIN - Loc := CreateType ('LOC', 'MinLoc', 'MaxLoc', TRUE, GetISOLocType ()) ; + Loc := CreateType ('LOC', 'MinLoc', 'MaxLoc', TRUE, GetISOLocType (), FALSE) ; InitSystemTypes (BuiltinsLocation (), Loc) ; Address := MakePointer (BuiltinTokenNo, MakeKey ('ADDRESS')) ; PutPointer (Address, Loc) ; (* Base Type *) - MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType()) ; - - Byte := CreateType ('BYTE', '', '', TRUE, GetISOByteType()) ; - Word := CreateType ('WORD', '', '', TRUE, GetISOWordType()) ; + MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE) ; - (* CreateMinMaxFor(Loc, 'MinLoc', 'MaxLoc', GetISOLocType()) *) + Byte := CreateType ('BYTE', '', '', TRUE, GetISOByteType(), FALSE) ; + Word := CreateType ('WORD', '', '', TRUE, GetISOWordType(), FALSE) ; END InitISOTypes ; @@ -327,9 +340,9 @@ END InitISOTypes ; PROCEDURE MakeExtraSystemTypes ; BEGIN - CSizeT := CreateType ('CSIZE_T' , '', '', TRUE, GetCSizeTType ()) ; - CSSizeT := CreateType ('CSSIZE_T', '', '', TRUE, GetCSSizeTType ()) ; - COffT := CreateType ('COFF_T', '', '', TRUE, GetCOffTType ()) ; + CSizeT := CreateType ('CSIZE_T' , '', '', TRUE, GetCSizeTType (), FALSE) ; + CSSizeT := CreateType ('CSSIZE_T', '', '', TRUE, GetCSSizeTType (), FALSE) ; + COffT := CreateType ('COFF_T', '', '', TRUE, GetCOffTType (), FALSE) END MakeExtraSystemTypes ; @@ -425,9 +438,9 @@ BEGIN MakeKey('THROW')) ; (* Procedure *) PutProcedureNoReturn (Throw, DefProcedure, TRUE) ; - CreateMinMaxFor(Word, 'MinWord', 'MaxWord', GetWordType()) ; - CreateMinMaxFor(Address, 'MinAddress', 'MaxAddress', GetPointerType()) ; - CreateMinMaxFor(Byte, 'MinByte', 'MaxByte', GetByteType()) ; + CreateMinMaxFor(Word, 'MinWord', 'MaxWord', GetWordType(), FALSE) ; + CreateMinMaxFor(Address, 'MinAddress', 'MaxAddress', GetPointerType(), FALSE) ; + CreateMinMaxFor(Byte, 'MinByte', 'MaxByte', GetByteType(), FALSE) ; MakeFixedSizedTypes ; MakeExtraSystemTypes ; diff --git a/gcc/m2/gm2-compiler/P1SymBuild.mod b/gcc/m2/gm2-compiler/P1SymBuild.mod index 02d4ac7..08a0fc3 100644 --- a/gcc/m2/gm2-compiler/P1SymBuild.mod +++ b/gcc/m2/gm2-compiler/P1SymBuild.mod @@ -79,7 +79,6 @@ FROM SymbolTable IMPORT NulSym, MakeSubscript, PutSubscript, PutArray, GetType, IsArray, IsProcType, MakeProcType, - PutProcTypeVarParam, PutProcTypeParam, PutProcedureBuiltin, PutProcedureInline, GetSymName, ResolveImports, PutDeclared, @@ -109,42 +108,6 @@ VAR (* - CheckFileName - checks to see that the module name matches the file name. -*) - -(* -PROCEDURE CheckFileName (tok: CARDINAL; name: Name; ModuleType: ARRAY OF CHAR) ; -VAR - ext, - basename: INTEGER ; - s, - FileName: String ; -BEGIN - FileName := GetFileName() ; - basename := RIndex(FileName, '/', 0) ; - IF basename=-1 - THEN - basename := 0 - END ; - ext := RIndex(FileName, '.', 0) ; - IF ext=-1 - THEN - ext := 0 - END ; - FileName := Slice(FileName, basename, ext) ; - IF EqualCharStar(FileName, KeyToCharStar(name)) - THEN - FileName := KillString(FileName) - ELSE - s := ConCat (InitString (ModuleType), - Mark (InitString (" module name {%1Ea} is inconsistant with the filename {%F{%2a}}"))) ; - MetaErrorString2 (s, MakeError (tok, name), MakeErrorS (tok, FileName)) - END -END CheckFileName ; -*) - - -(* StartBuildDefinitionModule - Creates a definition module and starts a new scope. @@ -227,7 +190,7 @@ BEGIN END ; IF NameStart#NameEnd THEN - MetaError1 ('inconsistant definition module name {%1Wa}', MakeError (start, NameStart)) + MetaError1 ('inconsistent definition module name {%1Wa}', MakeError (start, NameStart)) END ; LeaveBlock END P1EndBuildDefinitionModule ; @@ -301,7 +264,7 @@ BEGIN IF NameStart#NameEnd THEN MetaErrorT1 (end, - 'inconsistant implementation module name {%1Wa}', MakeError (start, NameStart)) + 'inconsistent implementation module name {%1Wa}', MakeError (start, NameStart)) END ; LeaveBlock END P1EndBuildImplementationModule ; @@ -381,7 +344,7 @@ BEGIN IF NameStart#NameEnd THEN MetaErrorT1 (end, - 'inconsistant program module name {%1Wa}', MakeError (start, NameStart)) + 'inconsistent program module name {%1Wa}', MakeError (start, NameStart)) END ; LeaveBlock END P1EndBuildProgramModule ; @@ -446,7 +409,7 @@ BEGIN IF NameStart#NameEnd THEN MetaErrorT1 (end, - 'inconsistant inner module name {%1Wa}', MakeError (start, NameStart)) + 'inconsistent inner module name {%1Wa}', MakeError (start, NameStart)) END ; LeaveBlock END EndBuildInnerModule ; 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..54e624f 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.mod +++ b/gcc/m2/gm2-compiler/P2SymBuild.mod @@ -356,7 +356,7 @@ BEGIN END ; IF NameStart#NameEnd THEN - WriteFormat2('inconsistant definition module name, module began as (%a) and ended with (%a)', NameStart, NameEnd) + WriteFormat2('inconsistent definition module name, module began as (%a) and ended with (%a)', NameStart, NameEnd) END ; M2Error.LeaveErrorScope END P2EndBuildDefModule ; @@ -425,7 +425,7 @@ BEGIN PopT (NameEnd) ; IF NameStart#NameEnd THEN - WriteFormat1('inconsistant implementation module name %a', NameStart) + WriteFormat1('inconsistent implementation module name %a', NameStart) END ; M2Error.LeaveErrorScope END P2EndBuildImplementationModule ; @@ -499,7 +499,7 @@ BEGIN END ; IF NameStart#NameEnd THEN - WriteFormat2('inconsistant program module name %a does not match %a', NameStart, NameEnd) + WriteFormat2('inconsistent program module name %a does not match %a', NameStart, NameEnd) END ; M2Error.LeaveErrorScope END P2EndBuildProgramModule ; @@ -564,7 +564,7 @@ BEGIN PopT(NameEnd) ; IF NameStart#NameEnd THEN - WriteFormat2('inconsistant inner module name %a does not match %a', + WriteFormat2('inconsistent inner module name %a does not match %a', NameStart, NameEnd) END ; M2Error.LeaveErrorScope @@ -1179,8 +1179,8 @@ BEGIN PopT (n) ; i := 1 ; WHILE i <= n DO - CheckVariableAgainstKeyword (OperandT (n+1-i)) ; tok := OperandTok (n+1-i) ; + CheckVariableAgainstKeyword (tok, OperandT (n+1-i)) ; Var := MakeVar (tok, OperandT (n+1-i)) ; AtAddress := OperandA (n+1-i) ; IF AtAddress # NulSym @@ -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 ; @@ -1830,13 +1835,13 @@ BEGIN (* WarnStringAt (InitString ('parampos?'), OperandTok (pi)) ; *) IF Unbounded AND (NOT IsUnboundedParam (ProcSym, prevkind, ParamTotal+i)) THEN - ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', 'the parameter {%3EHa} was not declared as an ARRAY OF type', 'the parameter {%3EVa} was declared as an ARRAY OF type', ParamTotal+i, ProcSym, curkind, prevkind) ELSIF (NOT Unbounded) AND IsUnboundedParam (ProcSym, prevkind, ParamTotal+i) THEN - ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', 'the parameter {%3EHa} was declared as an ARRAY OF type', 'the parameter {%3EVa} was not declared as an ARRAY OF type', ParamTotal+i, ProcSym, curkind, prevkind) @@ -1845,7 +1850,7 @@ BEGIN THEN IF GetDimension (GetNthParam (ProcSym, prevkind, ParamTotal+1)) # ndim THEN - ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', 'the dynamic array parameter {%3EHa} was declared with a different of dimensions', 'the dynamic array parameter {%3EVa} was declared with a different of dimensions', ParamTotal+i, ProcSym, curkind, prevkind) @@ -1854,14 +1859,14 @@ BEGIN IF isVarParam AND (NOT IsVarParam (ProcSym, prevkind, ParamTotal+i)) THEN (* Expecting non VAR parameter. *) - ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', '{%3EHa} was not declared as a {%kVAR} parameter', '{%3EVa} was declared as a {%kVAR} parameter', ParamTotal+i, ProcSym, curkind, prevkind) ELSIF (NOT isVarParam) AND IsVarParam (ProcSym, prevkind, ParamTotal+i) THEN (* Expecting VAR pamarater. *) - ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration of procedure {%%1a} in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', '{%3EHa} was declared as a {%kVAR} parameter', '{%3EVa} was not declared as a {%kVAR} parameter', ParamTotal+i, ProcSym, curkind, prevkind) @@ -1872,7 +1877,7 @@ BEGIN IF GetSymName (ParamI) # OperandT (pi) THEN (* Different parameter names. *) - ParameterError ('procedure {%%1a} in the %s differs from the %s, {%%2N} parameter name is inconsistant, %s', + ParameterError ('procedure {%%1a} in the %s differs from the %s, {%%2N} parameter name is inconsistent, %s', 'named as {%3EVa}', 'named as {%3EVa}', ParamTotal+i, ProcSym, curkind, prevkind) @@ -1892,7 +1897,7 @@ BEGIN (NOT IsUnknown(SkipType(ParamIType))) THEN (* Different parameter types. *) - ParameterError ('declaration in the %s differs from the %s, {%%2N} parameter is inconsistant, %s', + ParameterError ('declaration in the %s differs from the %s, {%%2N} parameter is inconsistent, %s', 'the parameter {%3EHa} was declared with a different type', 'the parameter {%3EVa} was declared with a different type', ParamTotal+i, ProcSym, curkind, prevkind) @@ -3067,10 +3072,10 @@ BEGIN IF Var=VarTok THEN (* VAR parameter *) - PutProcTypeVarParam(ProcTypeSym, TypeSym, IsUnbounded(TypeSym)) + PutProcTypeVarParam (tok, ProcTypeSym, TypeSym, IsUnbounded (TypeSym)) ELSE (* Non VAR parameter *) - PutProcTypeParam(ProcTypeSym, TypeSym, IsUnbounded(TypeSym)) + PutProcTypeParam (tok, ProcTypeSym, TypeSym, IsUnbounded (TypeSym)) END ; PushT(ProcTypeSym) ; Annotate("%1s(%1d)||proc type") 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/P3SymBuild.mod b/gcc/m2/gm2-compiler/P3SymBuild.mod index c4877f7..096057e 100644 --- a/gcc/m2/gm2-compiler/P3SymBuild.mod +++ b/gcc/m2/gm2-compiler/P3SymBuild.mod @@ -126,7 +126,7 @@ BEGIN PopT(NameStart) ; IF NameStart#NameEnd THEN - WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)', + WriteFormat2('inconsistent definition module was named (%a) and concluded as (%a)', NameStart, NameEnd) END ; M2Error.LeaveErrorScope 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/PCSymBuild.mod b/gcc/m2/gm2-compiler/PCSymBuild.mod index b124c3e..4db2730 100644 --- a/gcc/m2/gm2-compiler/PCSymBuild.mod +++ b/gcc/m2/gm2-compiler/PCSymBuild.mod @@ -64,7 +64,7 @@ FROM SymbolTable IMPORT NulSym, ModeOfAddr, ProcedureKind, GetFromOuterModule, CheckForEnumerationInCurrentModule, GetMode, PutVariableAtAddress, ModeOfAddr, SkipType, - IsSet, PutConstSet, + IsSet, PutConstSet, IsType, IsConst, IsConstructor, PutConst, PutConstructor, PopValue, PushValue, MakeTemporary, PutVar, @@ -269,7 +269,7 @@ BEGIN PopT(NameStart) ; IF NameStart#NameEnd THEN - WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)', + WriteFormat2('inconsistent definition module was named (%a) and concluded as (%a)', NameStart, NameEnd) END ; M2Error.LeaveErrorScope @@ -1168,9 +1168,9 @@ BEGIN par := GetParam (p, i) ; IF IsParameterVar (par) THEN - PutProcTypeVarParam (t, GetType (par), IsParameterUnbounded (par)) + PutProcTypeVarParam (tok, t, GetType (par), IsParameterUnbounded (par)) ELSE - PutProcTypeParam (t, GetType (par), IsParameterUnbounded (par)) + PutProcTypeParam (tok, t, GetType (par), IsParameterUnbounded (par)) END ; INC(i) END ; @@ -1408,9 +1408,10 @@ END TypeToMeta ; (* - buildConstFunction - we are only concerned about resolving the return type o + buildConstFunction - we are only concerned about resolving the return type of a function, so we can ignore all parameters - except - the first one in the case of VAL(type, foo). + the first one in the case of VAL(type, foo) + and the type of bar in MIN (bar) and MAX (bar). buildConstFunction uses a unary exprNode to represent a function. *) @@ -1866,11 +1867,11 @@ BEGIN THEN IF (func=Min) OR (func=Max) THEN - IF IsSet (sym) + IF IsSet (sym) OR (IsType (sym) AND IsSet (SkipType (sym))) THEN - type := SkipType(GetType(sym)) + type := GetType (SkipType (sym)) ELSE - (* sym is the type required for MAX, MIN and VAL *) + (* sym is the type required for MAX, MIN and VAL. *) type := sym END ELSE 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-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def index d9d4c87..5b93f29 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -2025,7 +2025,7 @@ PROCEDURE PutIncludedByDefinition (Sym: CARDINAL) ; (* IsIncludedByDefinition - returns TRUE if definition module symbol, Sym, was included - by ModSym's definition module. + by ModSyms definition module. *) PROCEDURE IsIncludedByDefinition (ModSym, Sym: CARDINAL) : BOOLEAN ; @@ -2650,7 +2650,8 @@ PROCEDURE MakeProcType (tok: CARDINAL; ProcTypeName: Name) : CARDINAL ; ParamType into ProcType Sym. *) -PROCEDURE PutProcTypeParam (Sym: CARDINAL; +PROCEDURE PutProcTypeParam (tok: CARDINAL; + Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; @@ -2659,7 +2660,8 @@ PROCEDURE PutProcTypeParam (Sym: CARDINAL; ParamType into ProcType Sym. *) -PROCEDURE PutProcTypeVarParam (Sym: CARDINAL; +PROCEDURE PutProcTypeVarParam (tok: CARDINAL; + Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; @@ -3478,4 +3480,20 @@ PROCEDURE UsesOptArgAny (Sym: CARDINAL) : BOOLEAN ; PROCEDURE GetProcedureKindDesc (kind: ProcedureKind) : String ; +(* + GetNthParamAnyClosest - returns the nth parameter from the order + proper procedure, forward declaration + or definition module procedure. + It chooses the parameter which is closest + in source terms to currentmodule. + The same module will return using the order + proper procedure, forward procedure, definition module. + Whereas an imported procedure will choose from + DefProcedure, ProperProcedure, ForwardProcedure. +*) + +PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL; + currentmodule: CARDINAL) : CARDINAL ; + + END SymbolTable. diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index 826d2d3..00946e5 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -122,8 +122,6 @@ CONST UnboundedAddressName = "_m2_contents" ; UnboundedHighName = "_m2_high_%d" ; - BreakSym = 203 ; - TYPE ProcAnyBoolean = PROCEDURE (CARDINAL, ProcedureKind) : BOOLEAN ; ProcAnyCardinal = PROCEDURE (CARDINAL, ProcedureKind) : CARDINAL ; @@ -465,9 +463,11 @@ TYPE (* of param. *) Type : CARDINAL ; (* Index to the type of param. *) IsUnbounded : BOOLEAN ; (* Is it an ARRAY OF Type? *) + Scope : CARDINAL ; (* Procedure declaration. *) ShadowVar : CARDINAL ; (* The local variable used to *) (* shadow this parameter. *) - At : Where ; (* Where was sym declared/used *) + FullTok, (* name: type virtual token. *) + At : CARDINAL ; (* Where was sym declared. *) END ; SymVarParam = RECORD @@ -478,9 +478,11 @@ TYPE HeapVar : CARDINAL ;(* The pointer value on heap. *) (* Only used by static *) (* analysis. *) + Scope : CARDINAL ;(* Procedure declaration. *) ShadowVar : CARDINAL ;(* The local variable used to *) (* shadow this parameter. *) - At : Where ; (* Where was sym declared/used *) + FullTok, (* name: type virtual token. *) + At : CARDINAL ;(* Where was sym declared. *) END ; ConstStringVariant = (m2str, cstr, m2nulstr, cnulstr) ; @@ -930,6 +932,7 @@ VAR (* passes and reduce duplicate *) (* errors. *) ConstLitArray : Indexing.Index ; + BreakSym : CARDINAL ; (* Allows interactive debugging. *) (* @@ -1032,11 +1035,34 @@ END FinalSymbol ; (* - stop - a debugger convenience hook. + gdbhook - a debugger convenience hook. +*) + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenSymCreated - to be called interactively by gdb. +*) + +PROCEDURE BreakWhenSymCreated (sym: CARDINAL) ; +BEGIN + BreakSym := sym +END BreakWhenSymCreated ; + + +(* + CheckBreak - if sym = BreakSym then call gdbhook. *) -PROCEDURE stop ; -END stop ; +PROCEDURE CheckBreak (sym: CARDINAL) ; +BEGIN + IF sym = BreakSym + THEN + gdbhook + END +END CheckBreak ; (* @@ -1053,10 +1079,7 @@ BEGIN SymbolType := DummySym END ; PutIndice(Symbols, sym, pSym) ; - IF sym = BreakSym - THEN - stop - END ; + CheckBreak (sym) ; INC(FreeSymbol) END NewSym ; @@ -1660,6 +1683,18 @@ PROCEDURE Init ; VAR pCall: PtrToCallFrame ; BEGIN + BreakWhenSymCreated (NulSym) ; (* Disable the intereactive sym watch. *) + (* To examine the symbol table when a symbol is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenSymCreated with the symbol + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenSymCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this symbol is created. *) AnonymousName := 0 ; CurrentError := NIL ; InitTree (ConstLitPoolTree) ; @@ -3959,10 +3994,7 @@ VAR BEGIN tok := CheckTok (tok, 'procedure') ; Sym := DeclareSym(tok, ProcedureName) ; - IF Sym = BreakSym - THEN - stop - END ; + CheckBreak (Sym) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; @@ -4428,9 +4460,19 @@ BEGIN pSym := GetPsym (sym) ; IF IsParameterVar (sym) THEN - RETURN GetVarDeclTok (pSym^.VarParam.ShadowVar) + IF pSym^.VarParam.ShadowVar = NulSym + THEN + RETURN pSym^.VarParam.At + ELSE + RETURN GetVarDeclTok (pSym^.VarParam.ShadowVar) + END ELSE - RETURN GetVarDeclTok (pSym^.Param.ShadowVar) + IF pSym^.Param.ShadowVar = NulSym + THEN + RETURN pSym^.Param.At + ELSE + RETURN GetVarDeclTok (pSym^.Param.ShadowVar) + END END ELSIF IsVar (sym) THEN @@ -4521,9 +4563,9 @@ BEGIN THEN IF IsParameterVar (sym) THEN - RETURN GetVarDeclFullTok (pSym^.VarParam.ShadowVar) + RETURN pSym^.VarParam.FullTok ELSE - RETURN GetVarDeclFullTok (pSym^.Param.ShadowVar) + RETURN pSym^.Param.FullTok END ELSIF IsVar (sym) THEN @@ -6926,6 +6968,89 @@ END GetNthParamAny ; (* + GetNthParamChoice - returns the parameter definition from + sym:ParamNo:kind or NulSym. +*) + +PROCEDURE GetNthParamChoice (sym: CARDINAL; ParamNo: CARDINAL; + kind: ProcedureKind) : CARDINAL ; +BEGIN + IF GetProcedureParametersDefined (sym, kind) + THEN + RETURN GetNthParam (sym, kind, ParamNo) + ELSE + RETURN NulSym + END +END GetNthParamChoice ; + + +(* + GetNthParamOrdered - returns the parameter definition from list {a, b, c} + in order. + sym:ParamNo:{a,b,c} or NulSym. +*) + +PROCEDURE GetNthParamOrdered (sym: CARDINAL; ParamNo: CARDINAL; + a, b, c: ProcedureKind) : CARDINAL ; +VAR + param: CARDINAL ; +BEGIN + param := GetNthParamChoice (sym, ParamNo, a) ; + IF param = NulSym + THEN + param := GetNthParamChoice (sym, ParamNo, b) ; + IF param = NulSym + THEN + param := GetNthParamChoice (sym, ParamNo, c) + END + END ; + RETURN param +END GetNthParamOrdered ; + + +(* + GetNthParamAnyClosest - returns the nth parameter from the order + proper procedure, forward declaration + or definition module procedure. + It chooses the parameter which is closest + in source terms to currentmodule. + The same module will return using the order + proper procedure, forward procedure, definition module. + Whereas an imported procedure will choose from + DefProcedure, ProperProcedure, ForwardProcedure. +*) + +PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL; + currentmodule: CARDINAL) : CARDINAL ; +BEGIN + IF GetOuterModuleScope (currentmodule) = GetOuterModuleScope (sym) + THEN + (* Same module. *) + RETURN GetNthParamOrdered (sym, ParamNo, + ProperProcedure, ForwardProcedure, DefProcedure) + ELSE + (* Procedure is imported. *) + RETURN GetNthParamOrdered (sym, ParamNo, + DefProcedure, ProperProcedure, ForwardProcedure) + END +END GetNthParamAnyClosest ; + + +(* + GetOuterModuleScope - returns the outer module symbol scope for sym. +*) + +PROCEDURE GetOuterModuleScope (sym: CARDINAL) : CARDINAL ; +BEGIN + WHILE NOT (IsDefImp (sym) OR + (IsModule (sym) AND (GetScope (sym) = NulSym))) DO + sym := GetScope (sym) + END ; + RETURN sym +END GetOuterModuleScope ; + + +(* The Following procedures fill in the symbol table with the symbol entities. *) @@ -7154,6 +7279,7 @@ VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; + CheckBreak (Sym) ; WITH pSym^ DO CASE SymbolType OF @@ -10539,8 +10665,10 @@ BEGIN name := ParamName ; Type := ParamType ; IsUnbounded := isUnbounded ; + Scope := Sym ; ShadowVar := NulSym ; - InitWhereDeclaredTok(tok, At) + FullTok := MakeVirtual2Tok (tok, typetok) ; + At := tok END END ; AddParameter (Sym, kind, ParSym) ; @@ -10559,7 +10687,7 @@ BEGIN pSym^.Param.ShadowVar := VariableSym END END ; - AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, FALSE) + AddProcedureProcTypeParam (tok, Sym, ParamType, isUnbounded, FALSE) END ; RETURN( TRUE ) END PutParam ; @@ -10596,9 +10724,11 @@ BEGIN name := ParamName ; Type := ParamType ; IsUnbounded := isUnbounded ; + Scope := Sym ; ShadowVar := NulSym ; HeapVar := NulSym ; (* Will contain a pointer value. *) - InitWhereDeclaredTok(tok, At) + FullTok := MakeVirtual2Tok (tok, typetok) ; + At := tok END END ; AddParameter (Sym, kind, ParSym) ; @@ -10617,7 +10747,7 @@ BEGIN pSym^.VarParam.ShadowVar := VariableSym END END ; - AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, TRUE) + AddProcedureProcTypeParam (tok, Sym, ParamType, isUnbounded, TRUE) END ; RETURN( TRUE ) END PutVarParam ; @@ -10704,7 +10834,8 @@ END AddParameter ; associated with procedure Sym. *) -PROCEDURE AddProcedureProcTypeParam (Sym, ParamType: CARDINAL; +PROCEDURE AddProcedureProcTypeParam (tok: CARDINAL; + Sym, ParamType: CARDINAL; isUnbounded, isVarParam: BOOLEAN) ; VAR pSym: PtrToSymbol ; @@ -10717,10 +10848,12 @@ BEGIN THEN IF isVarParam THEN - PutProcTypeVarParam (Procedure.ProcedureType, + PutProcTypeVarParam (tok, + Procedure.ProcedureType, ParamType, isUnbounded) ELSE - PutProcTypeParam (Procedure.ProcedureType, + PutProcTypeParam (tok, + Procedure.ProcedureType, ParamType, isUnbounded) END END @@ -12915,18 +13048,8 @@ BEGIN ConstLitSym : RETURN( ConstLit.Scope ) | ConstStringSym : RETURN( ConstString.Scope ) | ConstVarSym : RETURN( ConstVar.Scope ) | - ParamSym : IF Param.ShadowVar = NulSym - THEN - RETURN NulSym - ELSE - RETURN( GetScope (Param.ShadowVar) ) - END | - VarParamSym : IF VarParam.ShadowVar = NulSym - THEN - RETURN NulSym - ELSE - RETURN( GetScope (VarParam.ShadowVar) ) - END | + ParamSym : RETURN( Param.Scope ) | + VarParamSym : RETURN( VarParam.Scope ) | UndefinedSym : RETURN( NulSym ) | PartialUnboundedSym: InternalError ('should not be requesting the scope of a PartialUnbounded symbol') @@ -13074,7 +13197,8 @@ END MakeProcType ; ParamType into ProcType Sym. *) -PROCEDURE PutProcTypeParam (Sym: CARDINAL; +PROCEDURE PutProcTypeParam (tok: CARDINAL; + Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; VAR pSym : PtrToSymbol ; @@ -13089,7 +13213,8 @@ BEGIN Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; - InitWhereDeclared(At) + FullTok := tok ; + At := tok END END ; AddParameter (Sym, ProperProcedure, ParSym) @@ -13101,7 +13226,8 @@ END PutProcTypeParam ; ParamType into ProcType Sym. *) -PROCEDURE PutProcTypeVarParam (Sym: CARDINAL; +PROCEDURE PutProcTypeVarParam (tok: CARDINAL; + Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; VAR pSym : PtrToSymbol ; @@ -13116,7 +13242,8 @@ BEGIN Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; - InitWhereDeclared(At) + FullTok := tok ; + At := tok END END ; AddParameter (Sym, ProperProcedure, ParSym) @@ -13806,8 +13933,8 @@ BEGIN UnboundedSym : RETURN( Unbounded.At.DefDeclared ) | ProcedureSym : RETURN( Procedure.At.DefDeclared ) | ProcTypeSym : RETURN( ProcType.At.DefDeclared ) | - ParamSym : RETURN( Param.At.DefDeclared ) | - VarParamSym : RETURN( VarParam.At.DefDeclared ) | + ParamSym : RETURN( Param.At ) | + VarParamSym : RETURN( VarParam.At ) | ConstStringSym : RETURN( ConstString.At.DefDeclared ) | ConstLitSym : RETURN( ConstLit.At.DefDeclared ) | ConstVarSym : RETURN( ConstVar.At.DefDeclared ) | @@ -13856,8 +13983,8 @@ BEGIN UnboundedSym : RETURN( Unbounded.At.ModDeclared ) | ProcedureSym : RETURN( Procedure.At.ModDeclared ) | ProcTypeSym : RETURN( ProcType.At.ModDeclared ) | - ParamSym : RETURN( Param.At.ModDeclared ) | - VarParamSym : RETURN( VarParam.At.ModDeclared ) | + ParamSym : RETURN( Param.At ) | + VarParamSym : RETURN( VarParam.At ) | ConstStringSym : RETURN( ConstString.At.ModDeclared ) | ConstLitSym : RETURN( ConstLit.At.ModDeclared ) | ConstVarSym : RETURN( ConstVar.At.ModDeclared ) | @@ -13907,8 +14034,6 @@ BEGIN UnboundedSym : Unbounded.At.DefDeclared := tok | ProcedureSym : Procedure.At.DefDeclared := tok | ProcTypeSym : ProcType.At.DefDeclared := tok | - ParamSym : Param.At.DefDeclared := tok | - VarParamSym : VarParam.At.DefDeclared := tok | ConstStringSym : ConstString.At.DefDeclared := tok | ConstLitSym : ConstLit.At.DefDeclared := tok | ConstVarSym : ConstVar.At.DefDeclared := tok | @@ -13955,8 +14080,6 @@ BEGIN UnboundedSym : Unbounded.At.ModDeclared := tok | ProcedureSym : Procedure.At.ModDeclared := tok | ProcTypeSym : ProcType.At.ModDeclared := tok | - ParamSym : Param.At.ModDeclared := tok | - VarParamSym : VarParam.At.ModDeclared := tok | ConstStringSym : ConstString.At.ModDeclared := tok | ConstLitSym : ConstLit.At.ModDeclared := tok | ConstVarSym : ConstVar.At.ModDeclared := tok | @@ -14211,8 +14334,10 @@ BEGIN UnboundedSym : RETURN( Unbounded.At.FirstUsed ) | ProcedureSym : RETURN( Procedure.At.FirstUsed ) | ProcTypeSym : RETURN( ProcType.At.FirstUsed ) | + (* ParamSym : RETURN( Param.At.FirstUsed ) | VarParamSym : RETURN( VarParam.At.FirstUsed ) | + *) ConstStringSym : RETURN( ConstString.At.FirstUsed ) | ConstLitSym : RETURN( ConstLit.At.FirstUsed ) | ConstVarSym : RETURN( ConstVar.At.FirstUsed ) | diff --git a/gcc/m2/gm2-gcc/m2builtins.cc b/gcc/m2/gm2-gcc/m2builtins.cc index 175c62a..cb9ef65 100644 --- a/gcc/m2/gm2-gcc/m2builtins.cc +++ b/gcc/m2/gm2-gcc/m2builtins.cc @@ -418,6 +418,7 @@ static GTY (()) tree ldouble_ftype_ldouble; static GTY (()) tree gm2_alloca_node; static GTY (()) tree gm2_memcpy_node; static GTY (()) tree gm2_memset_node; +static GTY (()) tree gm2_strncpy_node; static GTY (()) tree gm2_isfinite_node; static GTY (()) tree gm2_isnan_node; static GTY (()) tree gm2_huge_valf_node; @@ -1040,6 +1041,18 @@ DoBuiltinMemCopy (location_t location, tree dest, tree src, tree bytes) } static tree +DoBuiltinStrNCopy (location_t location, tree dest, tree src, tree bytes) +{ + tree functype = TREE_TYPE (gm2_strncpy_node); + tree rettype = TREE_TYPE (functype); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_strncpy_node); + tree call + = m2treelib_DoCall3 (location, rettype, funcptr, dest, src, bytes); + return call; +} + +static tree DoBuiltinAlloca (location_t location, tree bytes) { tree functype = TREE_TYPE (gm2_alloca_node); @@ -1105,6 +1118,14 @@ m2builtins_BuiltInHugeValLong (location_t location) return call; } +/* BuiltinStrNCopy copy at most n chars from address src to dest. */ + +tree +m2builtins_BuiltinStrNCopy (location_t location, tree dest, tree src, tree n) +{ + return DoBuiltinStrNCopy (location, dest, src, n); +} + static void create_function_prototype (location_t location, struct builtin_function_entry *fe) @@ -1580,6 +1601,7 @@ m2builtins_init (location_t location) gm2_alloca_node = find_builtin_tree ("__builtin_alloca"); gm2_memcpy_node = find_builtin_tree ("__builtin_memcpy"); gm2_memset_node = find_builtin_tree ("__builtin_memset"); + gm2_strncpy_node = find_builtin_tree ("__builtin_strncpy"); gm2_huge_valf_node = find_builtin_tree ("__builtin_huge_valf"); gm2_huge_val_node = find_builtin_tree ("__builtin_huge_val"); gm2_huge_vall_node = find_builtin_tree ("__builtin_huge_vall"); diff --git a/gcc/m2/gm2-gcc/m2builtins.def b/gcc/m2/gm2-gcc/m2builtins.def index 61f769d..5ab5a6d 100644 --- a/gcc/m2/gm2-gcc/m2builtins.def +++ b/gcc/m2/gm2-gcc/m2builtins.def @@ -24,12 +24,6 @@ DEFINITION MODULE FOR "C" m2builtins ; FROM CDataTypes IMPORT CharStar, ConstCharStar ; FROM gcctypes IMPORT location_t, tree ; -EXPORT QUALIFIED GetBuiltinConst, GetBuiltinConstType, - GetBuiltinTypeInfoType, GetBuiltinTypeInfo, - BuiltinExists, BuildBuiltinTree, - BuiltinMemCopy, BuiltinMemSet, BuiltInAlloca, - BuiltInIsfinite ; - (* GetBuiltinConst - returns the gcc tree of a built in constant, name. @@ -124,4 +118,11 @@ PROCEDURE BuiltInAlloca (location: location_t; n: tree) : tree ; PROCEDURE BuiltInIsfinite (location: location_t; e: tree) : tree ; +(* + BuiltinStrNCopy - copy at most n characters from src to dest. +*) + +PROCEDURE BuiltinStrNCopy (location: location_t; dest, src, n: tree) : tree ; + + END m2builtins. diff --git a/gcc/m2/gm2-gcc/m2builtins.h b/gcc/m2/gm2-gcc/m2builtins.h index 37bdbfa..017d2df 100644 --- a/gcc/m2/gm2-gcc/m2builtins.h +++ b/gcc/m2/gm2-gcc/m2builtins.h @@ -54,6 +54,8 @@ EXTERN tree m2builtins_BuildBuiltinTree (location_t location, char *name); EXTERN tree m2builtins_BuiltInHugeVal (location_t location); EXTERN tree m2builtins_BuiltInHugeValShort (location_t location); EXTERN tree m2builtins_BuiltInHugeValLong (location_t location); +EXTERN tree m2builtins_BuiltinStrNCopy (location_t location, tree dest, tree src, tree n); + EXTERN void m2builtins_init (location_t location); #undef EXTERN diff --git a/gcc/m2/gm2-gcc/m2color.cc b/gcc/m2/gm2-gcc/m2color.cc index fd30f46..a638d7c 100644 --- a/gcc/m2/gm2-gcc/m2color.cc +++ b/gcc/m2/gm2-gcc/m2color.cc @@ -23,7 +23,7 @@ along with GNU Modula-2; see the file COPYING3. If not see #include "m2color.h" #include "gcc-consolidation.h" -#include "diagnostic-color.h" +#include "diagnostics/color.h" char * diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def index e9f48b8..a9f5f37 100644 --- a/gcc/m2/gm2-gcc/m2expr.def +++ b/gcc/m2/gm2-gcc/m2expr.def @@ -45,7 +45,7 @@ PROCEDURE init (location: location_t) ; (* CSTIntToString - return an integer string using base 10 and no padding. - The string returned will have been malloc'd. + The string returned will have been mallocd. *) PROCEDURE CSTIntToString (t: tree) : CharStar ; diff --git a/gcc/m2/gm2-gcc/m2linemap.cc b/gcc/m2/gm2-gcc/m2linemap.cc index feb62b3..89a1080 100644 --- a/gcc/m2/gm2-gcc/m2linemap.cc +++ b/gcc/m2/gm2-gcc/m2linemap.cc @@ -188,12 +188,13 @@ m2linemap_ErrorAt (location_t location, char *message) static void m2linemap_ErrorAtf_1 (location_t location, const char *message, ...) { - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; va_list ap; rich_location richloc (line_table, location); va_start (ap, message); - diagnostic_set_info (&diagnostic, message, &ap, &richloc, DK_ERROR); + diagnostic_set_info (&diagnostic, message, &ap, &richloc, + diagnostics::kind::error); diagnostic_report_diagnostic (global_dc, &diagnostic); va_end (ap); } @@ -209,12 +210,13 @@ m2linemap_ErrorAtf (location_t location, const char *message) static void m2linemap_WarningAtf_1 (location_t location, const char *message, ...) { - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; va_list ap; rich_location richloc (line_table, location); va_start (ap, message); - diagnostic_set_info (&diagnostic, message, &ap, &richloc, DK_WARNING); + diagnostic_set_info (&diagnostic, message, &ap, &richloc, + diagnostics::kind::warning); diagnostic_report_diagnostic (global_dc, &diagnostic); va_end (ap); } @@ -230,12 +232,13 @@ m2linemap_WarningAtf (location_t location, const char *message) static void m2linemap_NoteAtf_1 (location_t location, const char *message, ...) { - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; va_list ap; rich_location richloc (line_table, location); va_start (ap, message); - diagnostic_set_info (&diagnostic, message, &ap, &richloc, DK_NOTE); + diagnostic_set_info (&diagnostic, message, &ap, &richloc, + diagnostics::kind::note); diagnostic_report_diagnostic (global_dc, &diagnostic); va_end (ap); } 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-gcc/m2pp.cc b/gcc/m2/gm2-gcc/m2pp.cc index 6ec8aaa..7d4adb8 100644 --- a/gcc/m2/gm2-gcc/m2pp.cc +++ b/gcc/m2/gm2-gcc/m2pp.cc @@ -2367,7 +2367,6 @@ m2pp_asm_expr (pretty *state, tree node) static void m2pp_nop_expr (pretty *state, tree t) { - enum tree_code code = TREE_CODE (t); m2pp_begin (state); m2pp_print (state, "(* NOP for debug location *)"); m2pp_needspace (state); diff --git a/gcc/m2/gm2-gcc/m2statement.cc b/gcc/m2/gm2-gcc/m2statement.cc index d42183f..7952984 100644 --- a/gcc/m2/gm2-gcc/m2statement.cc +++ b/gcc/m2/gm2-gcc/m2statement.cc @@ -36,6 +36,7 @@ along with GNU Modula-2; see the file COPYING3. If not see #include "m2treelib.h" #include "m2type.h" #include "m2convert.h" +#include "m2builtins.h" #include "m2pp.h" static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we @@ -154,6 +155,120 @@ m2statement_SetEndLocation (location_t location) cfun->function_end_locus = location; } +/* copy_record_fields copy each record field from right to left. */ + +static +void +copy_record_fields (location_t location, tree left, tree right) +{ + unsigned int i; + tree right_value; + tree left_type = TREE_TYPE (left); + vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right); + FOR_EACH_CONSTRUCTOR_VALUE (values, i, right_value) + { + tree left_field = m2treelib_get_field_no (left_type, NULL_TREE, false, i); + tree left_ref = m2expr_BuildComponentRef (location, left, left_field); + m2statement_CopyByField (location, left_ref, right_value); + } +} + +/* copy_array copy each element of an array from array right to array left. */ + +static +void +copy_array (location_t location, tree left, tree right) +{ + unsigned int i; + tree value; + vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right); + tree array_type = TREE_TYPE (left); + tree index_type = TYPE_DOMAIN (array_type); + tree elt_type = TREE_TYPE (array_type); + tree low_indice = TYPE_MIN_VALUE (index_type); + low_indice + = m2convert_BuildConvert (location, index_type, low_indice, false); + FOR_EACH_CONSTRUCTOR_VALUE (values, i, value) + { + tree idx = m2decl_BuildIntegerConstant (i); + idx = m2convert_BuildConvert (location, index_type, idx, false); + tree array_ref = build4_loc (location, ARRAY_REF, elt_type, left, + idx, low_indice, NULL_TREE); + m2statement_CopyByField (location, array_ref, value); + } +} + +/* copy_array cst into left using strncpy. */ + +static +void +copy_strncpy (location_t location, tree left, tree cst) +{ + tree result = m2builtins_BuiltinStrNCopy (location, + m2expr_BuildAddr (location, left, false), + m2expr_BuildAddr (location, cst, false), + m2decl_BuildIntegerConstant (m2expr_StringLength (cst))); + TREE_SIDE_EFFECTS (result) = true; + TREE_USED (left) = true; + TREE_USED (cst) = true; + add_stmt (location, result); +} + +/* copy_memcpy copy right into left using builtin_memcpy. */ + +static +void +copy_memcpy (location_t location, tree left, tree right) +{ + tree result = m2builtins_BuiltinMemCopy (location, + m2expr_BuildAddr (location, left, false), + m2expr_BuildAddr (location, right, false), + m2expr_GetSizeOf (location, left)); + TREE_SIDE_EFFECTS (result) = true; + TREE_USED (left) = true; + TREE_USED (right) = true; + add_stmt (location, result); +} + +/* CopyByField_Lower copy right to left using memcpy for unions, + strncpy for string cst, field assignment for records, + array element assignment for array constructors. For all + other types it uses BuildAssignmentStatement. */ + +static +void +CopyByField_Lower (location_t location, + tree left, tree right) +{ + tree left_type = TREE_TYPE (left); + enum tree_code right_code = TREE_CODE (right); + enum tree_code left_code = TREE_CODE (left_type); + + if (left_code == RECORD_TYPE && right_code == CONSTRUCTOR) + copy_record_fields (location, left, right); + else if (left_code == ARRAY_TYPE && right_code == CONSTRUCTOR) + copy_array (location, left, right); + else if (left_code == UNION_TYPE && right_code == CONSTRUCTOR) + copy_memcpy (location, left, right); + else if (right_code == STRING_CST) + copy_strncpy (location, left, right); + else + m2statement_BuildAssignmentStatement (location, left, right); +} + +/* CopyByField recursively checks each field to ensure GCC + type equivalence and if so it uses assignment. + Otherwise use strncpy or memcpy depending upon type. */ + +void +m2statement_CopyByField (location_t location, tree des, tree expr) +{ + if (m2type_IsGccStrictTypeEquivalent (des, expr)) + m2statement_BuildAssignmentStatement (location, des, expr); + else + CopyByField_Lower (location, des, expr); +} + /* BuildAssignmentTree builds the assignment of, des, and, expr. It returns, des. */ diff --git a/gcc/m2/gm2-gcc/m2statement.def b/gcc/m2/gm2-gcc/m2statement.def index 074b768..ffaf697 100644 --- a/gcc/m2/gm2-gcc/m2statement.def +++ b/gcc/m2/gm2-gcc/m2statement.def @@ -314,4 +314,16 @@ PROCEDURE SetEndLocation (location: location_t) ; PROCEDURE BuildBuiltinCallTree (func: tree) : tree ; +(* + CopyByField - copy expr to des, if des is a record, union or an array + then check fields for GCC type equivalence and if necessary + call __builtin_strncpy and __builtin_memcpy. + This can occur if an expr contains a constant string + which is to be assigned into a field declared as + an ARRAY [0..n] OF CHAR. +*) + +PROCEDURE CopyByField (location: location_t; des, expr: tree) ; + + END m2statement. diff --git a/gcc/m2/gm2-gcc/m2statement.h b/gcc/m2/gm2-gcc/m2statement.h index db2daf3..0076b32 100644 --- a/gcc/m2/gm2-gcc/m2statement.h +++ b/gcc/m2/gm2-gcc/m2statement.h @@ -108,6 +108,7 @@ EXTERN tree m2statement_BuildBuiltinCallTree (tree func); EXTERN tree m2statement_BuildTryFinally (location_t location, tree call, tree cleanups); EXTERN tree m2statement_BuildCleanUp (tree param); +EXTERN void m2statement_CopyByField (location_t location, tree des, tree expr); #undef EXTERN #endif /* m2statement_h. */ diff --git a/gcc/m2/gm2-gcc/m2type.cc b/gcc/m2/gm2-gcc/m2type.cc index a946509..e486f12 100644 --- a/gcc/m2/gm2-gcc/m2type.cc +++ b/gcc/m2/gm2-gcc/m2type.cc @@ -1891,6 +1891,22 @@ m2type_GetDefaultType (location_t location, char *name, tree type) return id; } +/* IsGccRealType return true if type is a GCC realtype. */ + +static +bool +IsGccRealType (tree type) +{ + return (type == m2_real_type_node || type == m2type_GetRealType () || + type == m2_long_real_type_node || type == m2type_GetLongRealType () || + type == m2_short_real_type_node || type == m2type_GetShortRealType () || + type == m2type_GetM2Real32 () || + type == m2type_GetM2Real64 () || + type == m2type_GetM2Real96 () || + type == m2type_GetM2Real128 ()); +} + +static tree do_min_real (tree type) { @@ -1911,11 +1927,7 @@ m2type_GetMinFrom (location_t location, tree type) { m2assert_AssertLocation (location); - if (type == m2_real_type_node || type == m2type_GetRealType ()) - return do_min_real (type); - if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) - return do_min_real (type); - if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + if (IsGccRealType (type)) return do_min_real (type); if (type == ptr_type_node) return m2expr_GetPointerZero (location); @@ -1923,6 +1935,7 @@ m2type_GetMinFrom (location_t location, tree type) return TYPE_MIN_VALUE (m2tree_skip_type_decl (type)); } +static tree do_max_real (tree type) { @@ -1943,11 +1956,7 @@ m2type_GetMaxFrom (location_t location, tree type) { m2assert_AssertLocation (location); - if (type == m2_real_type_node || type == m2type_GetRealType ()) - return do_max_real (type); - if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) - return do_max_real (type); - if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + if (IsGccRealType (type)) return do_max_real (type); if (type == ptr_type_node) return fold (m2expr_BuildSub (location, m2expr_GetPointerZero (location), @@ -3105,10 +3114,68 @@ m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type) /* IsAddress returns true if the type is an ADDRESS. */ -int +bool m2type_IsAddress (tree type) { return type == ptr_type_node; } +/* check_record_fields return true if all the fields in left and right + are GCC equivalent. */ + +static +bool +check_record_fields (tree left, tree right) +{ + unsigned int i; + tree right_value; + vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right); + FOR_EACH_CONSTRUCTOR_VALUE (values, i, right_value) + { + tree left_field = TREE_TYPE (m2treelib_get_field_no (left, NULL_TREE, false, i)); + if (! m2type_IsGccStrictTypeEquivalent (left_field, right_value)) + return false; + } + return true; +} + +/* check_array_types return true if left and right have the same type and right + is not a CST_STRING. */ + +static +bool +check_array_types (tree right) +{ + unsigned int i; + tree value; + vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right); + FOR_EACH_CONSTRUCTOR_VALUE (values, i, value) + { + enum tree_code right_code = TREE_CODE (value); + if (right_code == STRING_CST) + return false; + } + return true; +} + +bool +m2type_IsGccStrictTypeEquivalent (tree left, tree right) +{ + enum tree_code right_code = TREE_CODE (right); + enum tree_code left_code = TREE_CODE (left); + if (left_code == VAR_DECL) + return m2type_IsGccStrictTypeEquivalent (TREE_TYPE (left), right); + if (right_code == VAR_DECL) + return m2type_IsGccStrictTypeEquivalent (left, TREE_TYPE (right)); + if (left_code == RECORD_TYPE && right_code == CONSTRUCTOR) + return check_record_fields (left, right); + if (left_code == UNION_TYPE && right_code == CONSTRUCTOR) + return false; + if (left_code == ARRAY_TYPE && right_code == CONSTRUCTOR) + return check_array_types (right); + if (right_code == STRING_CST) + return false; + return true; +} + #include "gt-m2-m2type.h" diff --git a/gcc/m2/gm2-gcc/m2type.def b/gcc/m2/gm2-gcc/m2type.def index 797335e..f74888e 100644 --- a/gcc/m2/gm2-gcc/m2type.def +++ b/gcc/m2/gm2-gcc/m2type.def @@ -996,4 +996,12 @@ PROCEDURE IsAddress (type: tree) : BOOLEAN ; PROCEDURE SameRealType (a, b: tree) : BOOLEAN ; +(* + IsGccStrictTypeEquivalent - return true if left and right and + all their contents have the same type. +*) + +PROCEDURE IsGccStrictTypeEquivalent (left, right: tree) : BOOLEAN ; + + END m2type. diff --git a/gcc/m2/gm2-gcc/m2type.h b/gcc/m2/gm2-gcc/m2type.h index 04370d6..663af3c 100644 --- a/gcc/m2/gm2-gcc/m2type.h +++ b/gcc/m2/gm2-gcc/m2type.h @@ -210,10 +210,10 @@ EXTERN tree m2type_gm2_type_for_size (unsigned int bits, int unsignedp); EXTERN tree m2type_BuildProcTypeParameterDeclaration (location_t location, tree type, bool isreference); -EXTERN int m2type_IsAddress (tree type); +EXTERN bool m2type_IsAddress (tree type); EXTERN tree m2type_GetCardinalAddressType (void); EXTERN bool m2type_SameRealType (tree a, tree b); - +EXTERN bool m2type_IsGccStrictTypeEquivalent (tree left, tree right); #undef EXTERN #endif /* m2type_h */ diff --git a/gcc/m2/gm2-gcc/rtegraph.cc b/gcc/m2/gm2-gcc/rtegraph.cc index cd12582..f7b3065 100644 --- a/gcc/m2/gm2-gcc/rtegraph.cc +++ b/gcc/m2/gm2-gcc/rtegraph.cc @@ -283,9 +283,10 @@ rtegraph_lookup (gimple *g, tree fndecl, bool is_call) /* rte_error_at - wraps up an error message. */ static void -rte_error_at (location_t location, diagnostic_t kind, const char *message, ...) +rte_error_at (location_t location, diagnostics::kind kind, + const char *message, ...) { - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; va_list ap; rich_location richloc (line_table, location); @@ -338,7 +339,7 @@ access_string (tree t, const char **value) give the function context which might be misleading if this is inlined. */ static void -generate_report (gimple *stmt, const char *report, diagnostic_t kind) +generate_report (gimple *stmt, const char *report, diagnostics::kind kind) { if (gimple_call_num_args (stmt) == 5) { @@ -393,15 +394,16 @@ const char *rtenode::create_message (const char *with_name, const char *without_ return message; } -/* error_message issue an DK_ERROR from grtenode. */ +/* error_message issue an diagnostics::kind::error from grtenode. */ void rtenode::error_message (void) { if (grtenode != NULL) - generate_report (grtenode, "runtime error will occur", DK_ERROR); + generate_report (grtenode, "runtime error will occur", + diagnostics::kind::error); } -/* warning_message issue an DK_WARNING from grtenode. */ +/* warning_message issue an diagnostics::kind::warning from grtenode. */ void rtenode::warning_message (void) { @@ -409,15 +411,16 @@ void rtenode::warning_message (void) ("runtime error will occur if an exported procedure is called from %s", "runtime error will occur if an exported procedure is called"); if (grtenode != NULL) - generate_report (grtenode, message, DK_WARNING); + generate_report (grtenode, message, diagnostics::kind::warning); } -/* note_message issue an DK_NOTE from grtenode. */ +/* note_message issue an diagnostics::kind::note from grtenode. */ void rtenode::note_message (void) { if (grtenode != NULL) - generate_report (grtenode, "runtime will occur if this procedure is called", DK_NOTE); + generate_report (grtenode, "runtime will occur if this procedure is called", + diagnostics::kind::note); } /* dump_vec display contents of vector array list. */ 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-libiberty/pexecute.def b/gcc/m2/gm2-libiberty/pexecute.def index 30a41e1..49af52c 100644 --- a/gcc/m2/gm2-libiberty/pexecute.def +++ b/gcc/m2/gm2-libiberty/pexecute.def @@ -31,16 +31,16 @@ EXPORT UNQUALIFIED pexecute ; THIS_PNAME is name of the calling program (i.e. argv[0]). TEMP_BASE is the path name, sans suffix, of a temporary file to use - if needed. This is currently only needed for MSDOS ports that don't use - GO32 (do any still exist?). Ports that don't need it can pass NULL. + if needed. This is currently only needed for MSDOS ports that dont use + GO32 (do any still exist?). Ports that dont need it can pass NULL. (FLAGS & PEXECUTE_SEARCH) is non-zero if $PATH should be searched - (??? It's not clear that GCC passes this flag correctly). + (??? Its not clear that GCC passes this flag correctly). (FLAGS & PEXECUTE_FIRST) is nonzero for the first process in chain. (FLAGS & PEXECUTE_FIRST) is nonzero for the last process in chain. FIRST_LAST could be simplified to only mark the last of a chain of processes but that requires the caller to always mark the last one (and not give up - early if some error occurs). It's more robust to require the caller to + early if some error occurs). Its more robust to require the caller to mark both ends of the chain. The result is the pid on systems like Unix where we fork/exec and on systems @@ -52,20 +52,20 @@ EXPORT UNQUALIFIED pexecute ; Upon failure, ERRMSG_FMT and ERRMSG_ARG are set to the text of the error message with an optional argument (if not needed, ERRMSG_ARG is set to - NULL), and -1 is returned. `errno' is available to the caller to use. + NULL), and -1 is returned. errno is available to the caller to use. pwait: cover function for wait. PID is the process id of the task to wait for. - STATUS is the `status' argument to wait. + STATUS is the status argument to wait. FLAGS is currently unused (allows future enhancement without breaking upward compatibility). Pass 0 for now. The result is the pid of the child reaped, or -1 for failure (errno says why). - On systems that don't support waiting for a particular child, PID is - ignored. On systems like MSDOS that don't really multitask pwait + On systems that dont support waiting for a particular child, PID is + ignored. On systems like MSDOS that dont really multitask pwait is just a mechanism to provide a consistent interface for the caller. pfinish: finish generation of script diff --git a/gcc/m2/gm2-libs-coroutines/Executive.def b/gcc/m2/gm2-libs-coroutines/Executive.def index 40eb8f1..f21a066 100644 --- a/gcc/m2/gm2-libs-coroutines/Executive.def +++ b/gcc/m2/gm2-libs-coroutines/Executive.def @@ -32,7 +32,7 @@ EXPORT QUALIFIED SEMAPHORE, DESCRIPTOR, RotateRunQueue, ProcessName, DebugProcess ; TYPE - SEMAPHORE ; (* defines Dijkstra's semaphores *) + SEMAPHORE ; (* defines Dijkstras semaphores *) DESCRIPTOR ; (* handle onto a process *) @@ -85,7 +85,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. @@ -95,7 +95,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. *) diff --git a/gcc/m2/gm2-libs-iso/ClientSocket.def b/gcc/m2/gm2-libs-iso/ClientSocket.def index 293b53a..98aefc6 100644 --- a/gcc/m2/gm2-libs-iso/ClientSocket.def +++ b/gcc/m2/gm2-libs-iso/ClientSocket.def @@ -1,4 +1,4 @@ -(* ClientSocket.def provides a client TCP interface for ChanId's. +(* ClientSocket.def provides a client TCP interface for ChanIds. Copyright (C) 2008-2025 Free Software Foundation, Inc. Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>. 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-iso/LowLong.mod b/gcc/m2/gm2-libs-iso/LowLong.mod index 92c7d91..f611923 100644 --- a/gcc/m2/gm2-libs-iso/LowLong.mod +++ b/gcc/m2/gm2-libs-iso/LowLong.mod @@ -182,7 +182,7 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), + RAISE(exceptSrc, ORD(badparam), 'LowLong.trunc: cannot truncate to a negative number of digits') ; RETURN x ELSE @@ -230,7 +230,7 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), + RAISE(exceptSrc, ORD(badparam), 'LowLong.round: cannot round to a negative number of digits') ; RETURN x ELSE @@ -287,12 +287,12 @@ END currentMode ; PROCEDURE IsLowException () : BOOLEAN ; BEGIN - RETURN( IsExceptionalExecution() AND IsCurrentSource(except) ) + RETURN( IsExceptionalExecution () AND IsCurrentSource (exceptSrc) ) END IsLowException ; VAR - except: ExceptionSource ; + exceptSrc: ExceptionSource ; BEGIN - AllocateSource(except) + AllocateSource (exceptSrc) END LowLong. diff --git a/gcc/m2/gm2-libs-iso/LowReal.mod b/gcc/m2/gm2-libs-iso/LowReal.mod index 580f36b..6d9ea00 100644 --- a/gcc/m2/gm2-libs-iso/LowReal.mod +++ b/gcc/m2/gm2-libs-iso/LowReal.mod @@ -183,8 +183,8 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), - 'LowReal.trunc: cannot truncate to a negative number of digits') ; + RAISE (exceptSrc, ORD(badparam), + 'LowReal.trunc: cannot truncate to a negative number of digits') ; RETURN x ELSE r := dtoa(x, maxsignificant, 100, point, sign) ; @@ -231,8 +231,8 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), - 'LowReal.round: cannot round to a negative number of digits') ; + RAISE (exceptSrc, ORD(badparam), + 'LowReal.round: cannot round to a negative number of digits') ; RETURN x ELSE s := RealToFloatString(x, n) ; @@ -288,12 +288,12 @@ END currentMode ; PROCEDURE IsLowException () : BOOLEAN ; BEGIN - RETURN( IsExceptionalExecution() AND IsCurrentSource(except) ) + RETURN( IsExceptionalExecution () AND IsCurrentSource (exceptSrc) ) END IsLowException ; VAR - except: ExceptionSource ; + exceptSrc: ExceptionSource ; BEGIN - AllocateSource(except) + AllocateSource (exceptSrc) END LowReal. diff --git a/gcc/m2/gm2-libs-iso/LowShort.mod b/gcc/m2/gm2-libs-iso/LowShort.mod index 8531a88..62e4887 100644 --- a/gcc/m2/gm2-libs-iso/LowShort.mod +++ b/gcc/m2/gm2-libs-iso/LowShort.mod @@ -183,8 +183,8 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), - 'LowLong.trunc: cannot truncate to a negative number of digits') ; + RAISE (exceptSrc, ORD(badparam), + 'LowLong.trunc: cannot truncate to a negative number of digits') ; RETURN x ELSE r := dtoa(x, maxsignificant, 100, point, sign) ; @@ -231,8 +231,8 @@ BEGIN IF n<0 THEN (* exception raised *) - RAISE(except, ORD(badparam), - 'LowLong.round: cannot round to a negative number of digits') ; + RAISE (exceptSrc, ORD(badparam), + 'LowLong.round: cannot round to a negative number of digits') ; RETURN x ELSE s := RealToFloatString(x, n) ; @@ -288,12 +288,12 @@ END currentMode ; PROCEDURE IsLowException () : BOOLEAN ; BEGIN - RETURN( IsExceptionalExecution() AND IsCurrentSource(except) ) + RETURN( IsExceptionalExecution () AND IsCurrentSource (exceptSrc) ) END IsLowException ; VAR - except: ExceptionSource ; + exceptSrc: ExceptionSource ; BEGIN - AllocateSource(except) + AllocateSource (exceptSrc) END LowShort. diff --git a/gcc/m2/gm2-libs-iso/Processes.mod b/gcc/m2/gm2-libs-iso/Processes.mod index 8ef22c0..b0c1b69 100644 --- a/gcc/m2/gm2-libs-iso/Processes.mod +++ b/gcc/m2/gm2-libs-iso/Processes.mod @@ -441,7 +441,7 @@ PROCEDURE Wait ; VAR calling, best : ProcessId ; - from : COROUTINE ; + fromCor: COROUTINE ; BEGIN IF debugging THEN @@ -451,17 +451,17 @@ BEGIN OnWaitingQueue (calling) ; best := chooseProcess () ; currentId := best ; - from := calling^.context ; + fromCor := calling^.context ; IF debugging THEN displayProcesses ("Wait about to perform IOTRANSFER") END ; - IOTRANSFER (from, currentId^.context) ; + IOTRANSFER (fromCor, currentId^.context) ; IF debugging THEN displayProcesses ("Wait after IOTRANSFER") END ; - currentId^.context := from ; + currentId^.context := fromCor ; currentId := calling ; OnReadyQueue (calling) ; IF debugging diff --git a/gcc/m2/gm2-libs-iso/RndFile.mod b/gcc/m2/gm2-libs-iso/RndFile.mod index e04cd8f..0a2264a 100644 --- a/gcc/m2/gm2-libs-iso/RndFile.mod +++ b/gcc/m2/gm2-libs-iso/RndFile.mod @@ -398,9 +398,9 @@ PROCEDURE EndPos (cid: ChanId): FilePos; position after which there have been no writes. *) VAR - d : DeviceTablePtr ; - end, - old: FilePos ; + d : DeviceTablePtr ; + endP, + old : FilePos ; BEGIN IF IsRndFile(cid) THEN @@ -410,9 +410,9 @@ BEGIN old := CurrentPos(cid) ; FIO.SetPositionFromEnd(RTio.GetFile(cid), 0) ; checkErrno(dev, d) ; - end := CurrentPos(cid) ; + endP := CurrentPos(cid) ; FIO.SetPositionFromBeginning(RTio.GetFile(cid), old) ; - RETURN( end ) + RETURN( endP ) END ELSE RAISEdevException(cid, did, IOChan.wrongDevice, diff --git a/gcc/m2/gm2-libs-log/BlockOps.def b/gcc/m2/gm2-libs-log/BlockOps.def index 2978920..b770acc 100644 --- a/gcc/m2/gm2-libs-log/BlockOps.def +++ b/gcc/m2/gm2-libs-log/BlockOps.def @@ -50,7 +50,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. *) PROCEDURE BlockClear (block: ADDRESS; n: CARDINAL) ; 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.def b/gcc/m2/gm2-libs-log/InOut.def index 9335d0a..f2294e9 100644 --- a/gcc/m2/gm2-libs-log/InOut.def +++ b/gcc/m2/gm2-libs-log/InOut.def @@ -45,7 +45,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. *) @@ -63,7 +63,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. *) 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..41aaf68 --- /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; str: ARRAY OF CHAR) ; +VAR + len, i: CARDINAL ; +BEGIN + len := StrLib.StrLen (str) ; + i := 0 ; + WHILE i < len DO + WriteChar (f, str[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/FormatStrings.mod b/gcc/m2/gm2-libs/FormatStrings.mod index ec2985b..aea8da9 100644 --- a/gcc/m2/gm2-libs/FormatStrings.mod +++ b/gcc/m2/gm2-libs/FormatStrings.mod @@ -378,7 +378,7 @@ BEGIN THEN INC (afterperc) ; Cast (u, w) ; - in := ConCat (in, Slice (fmt, startpos, nextperc)) ; + in := Copy (fmt, in, startpos, nextperc) ; in := ConCat (in, CardinalToString (u, width, leader, 16, TRUE)) ; startpos := afterperc ; DSdbExit (NIL) ; @@ -387,7 +387,7 @@ BEGIN THEN INC (afterperc) ; Cast (u, w) ; - in := ConCat (in, Slice (fmt, startpos, nextperc)) ; + in := Copy (fmt, in, startpos, nextperc) ; in := ConCat (in, CardinalToString (u, width, leader, 10, FALSE)) ; startpos := afterperc ; DSdbExit (NIL) ; diff --git a/gcc/m2/gm2-libs/M2EXCEPTION.mod b/gcc/m2/gm2-libs/M2EXCEPTION.mod index a17310f..e92b16d 100644 --- a/gcc/m2/gm2-libs/M2EXCEPTION.mod +++ b/gcc/m2/gm2-libs/M2EXCEPTION.mod @@ -33,7 +33,7 @@ FROM RTExceptions IMPORT EHBlock, GetExceptionBlock, GetNumber, Raise, (* If the program or coroutine is in the exception state then return the enumeration value representing the exception cause. If it is not in the exception state then - raises and exception (exException). *) + raises an exException exception. *) PROCEDURE M2Exception () : M2Exceptions; VAR @@ -45,7 +45,8 @@ BEGIN IF n = MAX (CARDINAL) THEN Raise (ORD (exException), ADR (__FILE__), __LINE__, __COLUMN__, ADR (__FUNCTION__), - ADR ('current coroutine is not in the exceptional execution state')) + ADR ('current coroutine is not in the exceptional execution state')) ; + RETURN exException ELSE RETURN VAL (M2Exceptions, n) END diff --git a/gcc/m2/gm2-libs/SCmdArgs.mod b/gcc/m2/gm2-libs/SCmdArgs.mod index ed76fc4..8443d5f 100644 --- a/gcc/m2/gm2-libs/SCmdArgs.mod +++ b/gcc/m2/gm2-libs/SCmdArgs.mod @@ -132,26 +132,27 @@ PROCEDURE GetArg (CmdLine: String; VAR i : CARDINAL ; sn, - start, end: INTEGER ; + startPos, + endPos : INTEGER ; ch : CHAR ; BEGIN i := 0 ; - start := 0 ; - end := Length(CmdLine) ; + startPos := 0 ; + endPos := Length(CmdLine) ; WHILE i<n DO - start := skipWhite(CmdLine, start, end) ; - sn := skipNextArg(CmdLine, start, end) ; - IF sn<end + startPos := skipWhite(CmdLine, startPos, endPos) ; + sn := skipNextArg(CmdLine, startPos, endPos) ; + IF sn<endPos THEN - start := sn ; + startPos := sn ; INC(i) ELSE RETURN( FALSE ) END END ; - start := skipWhite(CmdLine, start, end) ; - sn := skipNextArg(CmdLine, start, end) ; - Argi := Slice(CmdLine, start, sn) ; + startPos := skipWhite(CmdLine, startPos, endPos) ; + sn := skipNextArg(CmdLine, startPos, endPos) ; + Argi := Slice(CmdLine, startPos, sn) ; RETURN( TRUE ) END GetArg ; @@ -165,17 +166,18 @@ PROCEDURE Narg (CmdLine: String) : CARDINAL ; VAR n : CARDINAL ; s, - start, end: INTEGER ; + startPos, + endPos : INTEGER ; BEGIN n := 0 ; - start := 0 ; - end := Length(CmdLine) ; + startPos := 0 ; + endPos := Length(CmdLine) ; LOOP - start := skipWhite(CmdLine, start, end) ; - s := skipNextArg(CmdLine, start, end) ; - IF s<end + startPos := skipWhite(CmdLine, startPos, endPos) ; + s := skipNextArg(CmdLine, startPos, endPos) ; + IF s<endPos THEN - start := s ; + startPos := s ; INC(n) ELSE RETURN( n ) 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/lang.opt.urls b/gcc/m2/lang.opt.urls index 4c3e690..dc1dbf0 100644 --- a/gcc/m2/lang.opt.urls +++ b/gcc/m2/lang.opt.urls @@ -72,8 +72,8 @@ UrlSuffix(gcc/Preprocessor-Options.html#index-P) LangUrlSuffix_Fortran(gfortran/ ; skipping UrlSuffix for 'ansi' due to multiple URLs: ; duplicate: 'gcc/C-Dialect-Options.html#index-ansi-1' +; duplicate: 'gcc/Library-Builtins.html#index-ansi-2' ; duplicate: 'gcc/Non-bugs.html#index-ansi-3' -; duplicate: 'gcc/Other-Builtins.html#index-ansi-2' ; duplicate: 'gcc/Standards.html#index-ansi' ; skipping UrlSuffix for 'c' due to multiple URLs: 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/mc-boot/GFormatStrings.cc b/gcc/m2/mc-boot/GFormatStrings.cc index f4c4fd6..ad7e7d8 100644 --- a/gcc/m2/mc-boot/GFormatStrings.cc +++ b/gcc/m2/mc-boot/GFormatStrings.cc @@ -464,7 +464,7 @@ static DynamicStrings_String PerformFormatString (DynamicStrings_String fmt, int /* avoid dangling else. */ afterperc += 1; Cast ((unsigned char *) &u, (sizeof (u)-1), (const unsigned char *) w, _w_high); - in = DynamicStrings_ConCat (in, DynamicStrings_Slice (fmt, (*startpos), nextperc)); + in = Copy (fmt, in, (*startpos), nextperc); in = DynamicStrings_ConCat (in, StringConvert_CardinalToString (u, static_cast<unsigned int> (width), leader, 16, true)); (*startpos) = afterperc; DSdbExit (static_cast<DynamicStrings_String> (NULL)); @@ -475,7 +475,7 @@ static DynamicStrings_String PerformFormatString (DynamicStrings_String fmt, int /* avoid dangling else. */ afterperc += 1; Cast ((unsigned char *) &u, (sizeof (u)-1), (const unsigned char *) w, _w_high); - in = DynamicStrings_ConCat (in, DynamicStrings_Slice (fmt, (*startpos), nextperc)); + in = Copy (fmt, in, (*startpos), nextperc); in = DynamicStrings_ConCat (in, StringConvert_CardinalToString (u, static_cast<unsigned int> (width), leader, 10, false)); (*startpos) = afterperc; DSdbExit (static_cast<DynamicStrings_String> (NULL)); diff --git a/gcc/m2/mc-boot/GM2EXCEPTION.cc b/gcc/m2/mc-boot/GM2EXCEPTION.cc index 62d47f0..6baff3c 100644 --- a/gcc/m2/mc-boot/GM2EXCEPTION.cc +++ b/gcc/m2/mc-boot/GM2EXCEPTION.cc @@ -34,7 +34,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see typedef struct { PROC_t proc; } PROC; # endif -# include "Gmcrts.h" #define _M2EXCEPTION_C #include "GM2EXCEPTION.h" @@ -51,18 +50,19 @@ extern "C" M2EXCEPTION_M2Exceptions M2EXCEPTION_M2Exception (void) /* If the program or coroutine is in the exception state then return the enumeration value representing the exception cause. If it is not in the exception state then - raises and exception (exException). */ + raises an exException exception. */ e = RTExceptions_GetExceptionBlock (); n = RTExceptions_GetNumber (e); if (n == (UINT_MAX)) { RTExceptions_Raise ( ((unsigned int) (M2EXCEPTION_exException)), const_cast<void*> (static_cast<const void*>("../../gcc/m2/gm2-libs/M2EXCEPTION.mod")), 47, 6, const_cast<void*> (static_cast<const void*>("M2Exception")), const_cast<void*> (static_cast<const void*>("current coroutine is not in the exceptional execution state"))); + return M2EXCEPTION_exException; } else { return (M2EXCEPTION_M2Exceptions) (n); } - ReturnException ("../../gcc/m2/gm2-libs/M2EXCEPTION.def", 25, 1); + /* static analysis guarentees a RETURN statement will be used before here. */ __builtin_unreachable (); } diff --git a/gcc/m2/mc-boot/GSFIO.cc b/gcc/m2/mc-boot/GSFIO.cc index 6ae0d5e..f8c13d3 100644 --- a/gcc/m2/mc-boot/GSFIO.cc +++ b/gcc/m2/mc-boot/GSFIO.cc @@ -99,6 +99,13 @@ extern "C" DynamicStrings_String SFIO_WriteS (FIO_File file, DynamicStrings_Stri extern "C" DynamicStrings_String SFIO_ReadS (FIO_File file); +/* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*/ + +extern "C" DynamicStrings_String SFIO_GetFileName (FIO_File file); + /* Exists - returns TRUE if a file named, fname exists for reading. @@ -207,6 +214,19 @@ extern "C" DynamicStrings_String SFIO_ReadS (FIO_File file) __builtin_unreachable (); } + +/* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*/ + +extern "C" DynamicStrings_String SFIO_GetFileName (FIO_File file) +{ + return DynamicStrings_InitStringCharStar (FIO_getFileName (file)); + /* static analysis guarentees a RETURN statement will be used before here. */ + __builtin_unreachable (); +} + extern "C" void _M2_SFIO_init (__attribute__((unused)) int argc, __attribute__((unused)) char *argv[], __attribute__((unused)) char *envp[]) { } diff --git a/gcc/m2/mc-boot/GSFIO.h b/gcc/m2/mc-boot/GSFIO.h index 42ffc48..93c8099 100644 --- a/gcc/m2/mc-boot/GSFIO.h +++ b/gcc/m2/mc-boot/GSFIO.h @@ -103,6 +103,13 @@ EXTERN DynamicStrings_String SFIO_WriteS (FIO_File file, DynamicStrings_String s */ EXTERN DynamicStrings_String SFIO_ReadS (FIO_File file); + +/* + GetFileName - return a new string containing the name of the file. + The string should be killed by the caller. +*/ + +EXTERN DynamicStrings_String SFIO_GetFileName (FIO_File file); # ifdef __cplusplus } # endif diff --git a/gcc/m2/mc-boot/Gdecl.cc b/gcc/m2/mc-boot/Gdecl.cc index ae03483..94ea098 100644 --- a/gcc/m2/mc-boot/Gdecl.cc +++ b/gcc/m2/mc-boot/Gdecl.cc @@ -2550,6 +2550,14 @@ static bool isLeafString (decl_node__opaque n); static DynamicStrings_String getLiteralStringContents (decl_node__opaque n); /* + getStringChar - if the string is delimited by single + or double quotes then strip both + quotes from the string. +*/ + +static DynamicStrings_String getStringChar (decl_node__opaque n); + +/* getStringContents - return the string contents of a constant, literal, string or a constexp node. */ @@ -2569,7 +2577,13 @@ static nameKey_Name addNames (decl_node__opaque a, decl_node__opaque b); static decl_node__opaque resolveString (decl_node__opaque n); /* - foldBinary - + addQuotes - adds delimiter quote char to string. +*/ + +static DynamicStrings_String addQuotes (DynamicStrings_String s, char quote); + +/* + foldBinary - attempt to fold binary + for string constants. */ static decl_node__opaque foldBinary (decl_nodeT k, decl_node__opaque l, decl_node__opaque r, decl_node__opaque res); @@ -7590,6 +7604,32 @@ static DynamicStrings_String getLiteralStringContents (decl_node__opaque n) /* + getStringChar - if the string is delimited by single + or double quotes then strip both + quotes from the string. +*/ + +static DynamicStrings_String getStringChar (decl_node__opaque n) +{ + DynamicStrings_String s; + + s = getString (n); + if (((DynamicStrings_char (s, 0)) == '\'') && ((DynamicStrings_char (s, -1)) == '\'')) + { + s = DynamicStrings_Slice (s, 1, -1); + } + else if (((DynamicStrings_char (s, 0)) == '"') && ((DynamicStrings_char (s, -1)) == '"')) + { + /* avoid dangling else. */ + s = DynamicStrings_Slice (s, 1, -1); + } + return s; + /* static analysis guarentees a RETURN statement will be used before here. */ + __builtin_unreachable (); +} + + +/* getStringContents - return the string contents of a constant, literal, string or a constexp node. */ @@ -7608,7 +7648,7 @@ static DynamicStrings_String getStringContents (decl_node__opaque n) else if (isString (n)) { /* avoid dangling else. */ - return getString (n); + return getStringChar (n); } else if (isConstExp (n)) { @@ -7672,11 +7712,29 @@ static decl_node__opaque resolveString (decl_node__opaque n) /* - foldBinary - + addQuotes - adds delimiter quote char to string. +*/ + +static DynamicStrings_String addQuotes (DynamicStrings_String s, char quote) +{ + DynamicStrings_String qs; + + s = DynamicStrings_ConCatChar (s, quote); + qs = DynamicStrings_InitStringChar (quote); + qs = DynamicStrings_ConCat (qs, DynamicStrings_Mark (s)); + return qs; + /* static analysis guarentees a RETURN statement will be used before here. */ + __builtin_unreachable (); +} + + +/* + foldBinary - attempt to fold binary + for string constants. */ static decl_node__opaque foldBinary (decl_nodeT k, decl_node__opaque l, decl_node__opaque r, decl_node__opaque res) { + char qc; decl_node__opaque n; DynamicStrings_String ls; DynamicStrings_String rs; @@ -7686,7 +7744,12 @@ static decl_node__opaque foldBinary (decl_nodeT k, decl_node__opaque l, decl_nod { ls = getStringContents (l); rs = getStringContents (r); + qc = '\''; + /* Add unquoted contents. */ ls = DynamicStrings_Add (ls, rs); + /* Add quote. */ + ls = addQuotes (ls, qc); + /* Build new string. */ n = static_cast<decl_node__opaque> (decl_makeString (nameKey_makekey (DynamicStrings_string (ls)))); ls = DynamicStrings_KillString (ls); rs = DynamicStrings_KillString (rs); @@ -22789,7 +22852,7 @@ static decl_node__opaque doDupExpr (decl_node__opaque n) break; case decl_length: - M2RTS_HALT (-1); + M2RTS_HALT (-1); /* length should have been converted into unary. */ __builtin_unreachable (); break; diff --git a/gcc/m2/mc-boot/GmcFileName.h b/gcc/m2/mc-boot/GmcFileName.h index 11f1512..6c7ec75 100644 --- a/gcc/m2/mc-boot/GmcFileName.h +++ b/gcc/m2/mc-boot/GmcFileName.h @@ -50,7 +50,7 @@ extern "C" { given a module and an extension. This file name length will be operating system specific. String, Extension, is concatenated onto - Module and thus it is safe to `Mark' the extension + Module and thus it is safe to Mark the extension for garbage collection. */ diff --git a/gcc/m2/mc/decl.mod b/gcc/m2/mc/decl.mod index 342487e..197ca5e 100644 --- a/gcc/m2/mc/decl.mod +++ b/gcc/m2/mc/decl.mod @@ -4643,6 +4643,28 @@ END getLiteralStringContents ; (* + getStringChar - if the string is delimited by single + or double quotes then strip both + quotes from the string. +*) + +PROCEDURE getStringChar (n: node) : String ; +VAR + s: String ; +BEGIN + s := getString (n) ; + IF (DynamicStrings.char (s, 0) = "'") AND (DynamicStrings.char (s, -1) = "'") + THEN + s := DynamicStrings.Slice (s, 1, -1) + ELSIF (DynamicStrings.char (s, 0) = '"') AND (DynamicStrings.char (s, -1) = '"') + THEN + s := DynamicStrings.Slice (s, 1, -1) + END ; + RETURN s +END getStringChar ; + + +(* getStringContents - return the string contents of a constant, literal, string or a constexp node. *) @@ -4657,7 +4679,7 @@ BEGIN RETURN getLiteralStringContents (n) ELSIF isString (n) THEN - RETURN getString (n) + RETURN getStringChar (n) ELSIF isConstExp (n) THEN RETURN getStringContents (n^.unaryF.arg) @@ -4709,11 +4731,27 @@ END resolveString ; (* - foldBinary - + addQuotes - adds delimiter quote char to string. +*) + +PROCEDURE addQuotes (s: String; quote: CHAR) : String ; +VAR + qs: String ; +BEGIN + s := DynamicStrings.ConCatChar (s, quote) ; + qs := DynamicStrings.InitStringChar (quote) ; + qs := DynamicStrings.ConCat (qs, DynamicStrings.Mark (s)) ; + RETURN qs +END addQuotes ; + + +(* + foldBinary - attempt to fold binary + for string constants. *) PROCEDURE foldBinary (k: nodeT; l, r: node; res: node) : node ; VAR + qc: CHAR ; n : node ; ls, rs: String ; @@ -4723,7 +4761,12 @@ BEGIN THEN ls := getStringContents (l) ; rs := getStringContents (r) ; + qc := "'" ; + (* Add unquoted contents. *) ls := DynamicStrings.Add (ls, rs) ; + (* Add quote. *) + ls := addQuotes (ls, qc) ; + (* Build new string. *) n := makeString (makekey (DynamicStrings.string (ls))) ; ls := DynamicStrings.KillString (ls) ; rs := DynamicStrings.KillString (rs) diff --git a/gcc/m2/mc/mcFileName.def b/gcc/m2/mc/mcFileName.def index da9db60..7768c2f 100644 --- a/gcc/m2/mc/mcFileName.def +++ b/gcc/m2/mc/mcFileName.def @@ -29,7 +29,7 @@ FROM DynamicStrings IMPORT String ; given a module and an extension. This file name length will be operating system specific. String, Extension, is concatenated onto - Module and thus it is safe to `Mark' the extension + Module and thus it is safe to Mark the extension for garbage collection. *) 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 ; |