Added NEW with return type. Mainly for the interpreter. But can be useful in A2 Oberon also

Example: 
VAR d: Diagnostics.Diagnostics;
BEGIN
d := NEW Diagnostics.StreamDiagnostics(context.out);


git-svn-id: https://svn.inf.ethz.ch/svn/lecturers/a2/trunk@6663 8c9fc860-2736-0410-a75d-ab315db34111

source/FoxIntermediateBackend.Mod

@@ -7335,6 +7335,7 @@ TYPE
 			modifier: SyntaxTree.Modifier;
 			previous, init: IntermediateCode.Section;
 			prevScope: SyntaxTree.Scope;
+			firstPar: LONGINT;
 
 			PROCEDURE CallBodies(self: IntermediateCode.Operand; type: SyntaxTree.Type);
 			VAR recordScope: SyntaxTree.RecordScope; procedure: SyntaxTree.Procedure; body: SyntaxTree.Body; flags: LONGINT;
@@ -7751,7 +7752,13 @@ TYPE
 			(* ---- NEW ----- *)
 			|Global.New:
 				(*! the following code is only correct for "standard" Oberon calling convention *)
-				type := p0.type.resolved;
+				IF x.type # NIL THEN
+					type := x.type.resolved;
+					firstPar := 0;
+				ELSE
+					type := p0.type.resolved;
+					firstPar := 1;
+				END;
 				IF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType)
 				THEN
 					recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
@@ -7772,7 +7779,7 @@ TYPE
 						END;
 						Emit(Push(position,IntermediateCode.Immediate(sizeType,size)));
 						CallThis(position,"Runtime","New", 1);
-						pointer := NewRegisterOperand(IntermediateCode.GetType(system, p0.type));
+						pointer := NewRegisterOperand(IntermediateCode.GetType(system, type));
 						Emit(Result(position, pointer));
 						exit := NewLabel();
 						BreqL(exit,pointer,nil);
@@ -7812,7 +7819,7 @@ TYPE
 							Emit(Push(position,pointer));
 							ReleaseIntermediateOperand(pointer);
 							formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
-							FOR i := 1 TO x.parameters.Length()-1 DO
+							FOR i := firstPar TO x.parameters.Length()-1 DO
 								PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
 								formalParameter := formalParameter.nextParameter;
 							END;
@@ -7831,7 +7838,7 @@ TYPE
 						END;
 
 						(* call bodies *)
-						CallBodies(pointer,p0.type);
+						CallBodies(pointer,type);
 						
 						
 						SetLabel(exit);
@@ -7873,7 +7880,7 @@ TYPE
 						ReleaseIntermediateOperand(reg);
 
 						(* push realtime flag *)
-						IF (p0.type.resolved.isRealtime) THEN Emit(Push(position,true));
+						IF type.resolved.isRealtime THEN Emit(Push(position,true));
 						ELSE Emit(Push(position,false));
 						END;
 
@@ -7898,7 +7905,7 @@ TYPE
 							Emit(Push(position,pointer));
 							ReleaseIntermediateOperand(pointer);
 							formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
-							FOR i := 1 TO x.parameters.Length()-1 DO
+							FOR i := firstPar TO x.parameters.Length()-1 DO
 								PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
 								formalParameter := formalParameter.nextParameter;
 							END;
@@ -7918,19 +7925,21 @@ TYPE
 						IntermediateCode.InitRegister(pointer,addressType,IntermediateCode.GeneralPurposeRegister,AcquireRegister(addressType,IntermediateCode.GeneralPurposeRegister));
 						Emit(Pop(position,pointer));
 
-						IF temporaryVariable # NIL THEN
+						IF (temporaryVariable # NIL) & (x.type = NIL) THEN
 							Designate(p0,l);
 							ToMemory(l.op,addressType,0);
 							Emit(Mov(position,l.op,pointer));
 							ReleaseOperand(l);
 							result.tag := emptyOperand;
+						ELSIF (x.type # NIL) THEN
+							result := l; (* temporary variable is the result of NEW Type() *)
 						END;
 
 						(* call bodies *)
-						CallBodies(pointer,p0.type);
+						CallBodies(pointer,type);
 						ReleaseIntermediateOperand(pointer);
 
-						IF temporaryVariable # NIL THEN
+						IF (temporaryVariable # NIL) & (x.type = NIL) THEN
 							end := NewLabel();
 							BrL(end);
 							SetLabel(exit);
@@ -7949,7 +7958,7 @@ TYPE
 					dim := 0;
 
 					IF p1 # NIL THEN
-						FOR i := 1 TO x.parameters.Length()-1 DO
+						FOR i := firstPar TO x.parameters.Length()-1 DO
 							type := type(SyntaxTree.ArrayType).arrayBase.resolved;
 							parameter := x.parameters.GetExpression(i);
 							Evaluate(parameter,r);
@@ -8202,7 +8211,7 @@ TYPE
 							isTensor := FALSE;
 						END;
 
-						FOR i := 1 TO x.parameters.Length()-1 DO
+						FOR i := firstPar TO x.parameters.Length()-1 DO
 							IF ~isTensor THEN
 								type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
 							END;
@@ -8466,7 +8475,7 @@ TYPE
 							ReleaseOperand(l);
 						END;
 						formalParameter := constructor.type(SyntaxTree.ProcedureType).firstParameter;
-						FOR i := 1 TO x.parameters.Length()-1 DO
+						FOR i := firstPar TO x.parameters.Length()-1 DO
 							PushParameter(x.parameters.GetExpression(i), formalParameter,SyntaxTree.OberonCallingConvention, FALSE, dummy,-1);
 							formalParameter := formalParameter.nextParameter;
 						END;

source/FoxParser.Mod

@@ -632,6 +632,8 @@ TYPE
 		VAR
 			designator: SyntaxTree.Designator;  expressionList: SyntaxTree.ExpressionList;
 			identifier: SyntaxTree.Identifier; position: LONGINT;
+			qualifiedIdentifier: SyntaxTree.QualifiedIdentifier;
+			qualifiedType : SyntaxTree.QualifiedType;
 		BEGIN
 			IF Trace THEN S( "Designator" ) END;
 			position := symbol.start;
@@ -643,6 +645,24 @@ TYPE
 				identifier := symbol.identifier;
 				designator := SyntaxTree.NewIdentifierDesignator(position,identifier);
 				NextSymbol;
+			ELSIF (Token() = Scanner.New) THEN
+				identifier := symbol.identifier;
+				designator := SyntaxTree.NewIdentifierDesignator(position,identifier);
+				NextSymbol;
+				IF Token() # Scanner.LeftParenthesis THEN (* NEW Type () *)
+					qualifiedIdentifier := QualifiedIdentifier();
+					qualifiedType := SyntaxTree.NewQualifiedType(qualifiedIdentifier.position, currentScope, qualifiedIdentifier);
+					IF Mandatory( Scanner.LeftParenthesis ) THEN
+						expressionList := SyntaxTree.NewExpressionList();
+						IF ~Optional(Scanner.RightParenthesis) THEN
+							ExpressionList( expressionList );
+							Check( Scanner.RightParenthesis )
+						END;
+					END;
+					designator := SyntaxTree.NewBuiltinCallDesignator(position,Global.New, NIL, expressionList);
+					designator(SyntaxTree.BuiltinCallDesignator).SetReturnType(qualifiedType);
+					(* special case: NEW Type() *)
+				END;	
 			ELSE
 				identifier := Identifier(position);
 				designator := SyntaxTree.NewIdentifierDesignator(position,identifier);
@@ -802,7 +822,7 @@ TYPE
 						factor := SyntaxTree.NewUnaryExpression( position, factor, operator );
 					END;
 					factor.End (symbol.end)
-			| Scanner.Self, Scanner.Result, Scanner.Identifier:
+			| Scanner.Self, Scanner.Result, Scanner.Identifier, Scanner.New:
 					factor := Designator();
 					factor.End( symbol.end );
 			| Scanner.LeftBracket:
@@ -954,7 +974,7 @@ TYPE
 		BEGIN
 			IF Trace THEN S( "Statement" ) END;
 			CASE Token() OF
-			| Scanner.Identifier, Scanner.Self, Scanner.Result:
+			| Scanner.Identifier, Scanner.Self, Scanner.Result, Scanner.New:
 					designator := Designator();
 					position := symbol.start;
 					IF OptionalB( Scanner.Becomes ) THEN

source/FoxScanner.Mod

@@ -43,7 +43,7 @@ CONST
     	(* Prefix Unary Operators Plus ... Not *)
 		Not
     	(* expressions may start with Plus ... Identifier *)
-		LeftParenthesis LeftBracket LeftBrace Number Character String Nil Imag True False Self Result Identifier
+		LeftParenthesis LeftBracket LeftBrace Number Character String Nil Imag True False Self Result New Identifier
 		(* statementy may start with Self ... Begin *)
 		If Case While Repeat For Loop With Exit Await Return Begin
 		(* symbols, expressions and statements cannot start with *)
@@ -77,28 +77,28 @@ CONST
 	(* expressions may start with Plus ... Identifier *)
 	LeftParenthesis*= 33; LeftBracket*= 34; LeftBrace*= 35; Number*= 36; Character*= 37; String*= 38; 
 	Nil*= 39; Imag*= 40; True*= 41; False*= 42; Self*= 43; Result*= 44; 
-	Identifier*= 45; 
+	New*= 45; Identifier*= 46; 
 	(* statementy may start with Self ... Begin *)
-	If*= 46; Case*= 47; While*= 48; Repeat*= 49; For*= 50; Loop*= 51; 
-	With*= 52; Exit*= 53; Await*= 54; Return*= 55; Begin*= 56; 
+	If*= 47; Case*= 48; While*= 49; Repeat*= 50; For*= 51; Loop*= 52; 
+	With*= 53; Exit*= 54; Await*= 55; Return*= 56; Begin*= 57; 
 	(* symbols, expressions and statements cannot start with *)
-	Semicolon*= 57; Transpose*= 58; RightBrace*= 59; RightBracket*= 60; RightParenthesis*= 61; Questionmark*= 62; 
-	ExclamationMark*= 63; LessLess*= 64; GreaterGreater*= 65; Upto*= 66; Arrow*= 67; Period*= 68; 
-	Comma*= 69; Colon*= 70; Of*= 71; Then*= 72; Do*= 73; To*= 74; 
-	By*= 75; Becomes*= 76; Bar*= 77; End*= 78; Else*= 79; Elsif*= 80; 
-	Until*= 81; Finally*= 82; 
+	Semicolon*= 58; Transpose*= 59; RightBrace*= 60; RightBracket*= 61; RightParenthesis*= 62; Questionmark*= 63; 
+	ExclamationMark*= 64; LessLess*= 65; GreaterGreater*= 66; Upto*= 67; Arrow*= 68; Period*= 69; 
+	Comma*= 70; Colon*= 71; Of*= 72; Then*= 73; Do*= 74; To*= 75; 
+	By*= 76; Becomes*= 77; Bar*= 78; End*= 79; Else*= 80; Elsif*= 81; 
+	Until*= 82; Finally*= 83; 
 	(* declaration elements *)
-	Code*= 83; Const*= 84; Type*= 85; Var*= 86; Out*= 87; Procedure*= 88; 
-	Operator*= 89; Import*= 90; Definition*= 91; Module*= 92; Cell*= 93; CellNet*= 94; 
-	Extern*= 95; 
+	Code*= 84; Const*= 85; Type*= 86; Var*= 87; Out*= 88; Procedure*= 89; 
+	Operator*= 90; Import*= 91; Definition*= 92; Module*= 93; Cell*= 94; CellNet*= 95; 
+	Extern*= 96; 
 	(* composite type symbols *)
-	Array*= 96; Object*= 97; Record*= 98; Pointer*= 99; Enum*= 100; Port*= 101; 
-	Address*= 102; Size*= 103; Alias*= 104; 
+	Array*= 97; Object*= 98; Record*= 99; Pointer*= 100; Enum*= 101; Port*= 102; 
+	Address*= 103; Size*= 104; Alias*= 105; 
 	(* assembler constants *)
-	Ln*= 105; PC*= 106; PCOffset*= 107; 
+	Ln*= 106; PC*= 107; PCOffset*= 108; 
 	(* number types *)
-	Shortint*= 108; Integer*= 109; Longint*= 110; Hugeint*= 111; Real*= 112; Longreal*= 113; 
-	Comment*= 114; EndOfText*= 115; Escape *= 116;
+	Shortint*= 109; Integer*= 110; Longint*= 111; Hugeint*= 112; Real*= 113; Longreal*= 114; 
+	Comment*= 115; EndOfText*= 116; Escape*= 117; 
 
 	SingleQuote = 27X;  DoubleQuote* = 22X;
 	Ellipsis = 7FX;   (* used in Scanner.GetNumber to return with ".." when reading an interval like 3..5 *)
@@ -1302,6 +1302,7 @@ TYPE
 		tokens[True] := "True";
 		tokens[False] := "False";
 		tokens[Self] := "Self";
+		tokens[New] := "New";
 		tokens[Result] := "Result";
 		tokens[Identifier] := "Identifier";
 		tokens[If] := "If";
@@ -1456,6 +1457,7 @@ TYPE
 		Enter( "repeat" , Repeat);
 		Enter( "return" , Return);
 		Enter( "self", Self);
+		Enter( "new", New);
 		Enter( "result", Result);
 		Enter( "then" , Then);
 		Enter( "true" , True);

source/FoxSemanticChecker.Mod

@@ -4593,7 +4593,10 @@ TYPE
 		**)
 		PROCEDURE VisitBuiltinCallDesignator(x: SyntaxTree.BuiltinCallDesignator);
 		BEGIN
-			IF ExpressionList(x.parameters) THEN
+			IF (x.returnType # NIL) & ExpressionList(x.parameters) THEN
+				resolvedExpression := NewBuiltinCallDesignator(x.position,NIL, x.parameters,NIL, ResolveType(x.returnType));
+				ASSERT(resolvedExpression.type # NIL);
+			ELSIF ExpressionList(x.parameters) THEN
 				resolvedExpression := x;
 			END;
 		END VisitBuiltinCallDesignator;
@@ -4941,10 +4944,10 @@ TYPE
 			RETURN result
 		END CheckPortType;
 
-		(* move to builtin procedure call statement ?
+				(* move to builtin procedure call statement ?
 			remove builtin procedure call designator ?
 		*)
-		PROCEDURE NewBuiltinCallDesignator(position: LONGINT; builtin: SyntaxTree.Builtin; actualParameters:SyntaxTree.ExpressionList; left: SyntaxTree.Designator): SyntaxTree.Expression;
+		PROCEDURE NewBuiltinCallDesignator(position: LONGINT; builtin: SyntaxTree.Builtin; actualParameters:SyntaxTree.ExpressionList; left: SyntaxTree.Designator; returnType: SyntaxTree.Type): SyntaxTree.Expression;
 		VAR
 			numberActualParameters,numberFormalParameters: LONGINT;
 			formalParameter: SyntaxTree.Parameter;
@@ -4961,6 +4964,7 @@ TYPE
 			c: CHAR;
 			id: LONGINT;
 			b: BOOLEAN;
+			first: LONGINT;
 
 			mathArrayType: SyntaxTree.MathArrayType;
 			customBuiltin: SyntaxTree.CustomBuiltin;
@@ -5010,9 +5014,14 @@ TYPE
 				END
 			END;
 
-			id := builtin.id;
-			IF system.operatorDefined[id] THEN (* try to find overloaded operator *)
-				result := NewOperatorCall(position,builtin.id,parameter0,parameter1,NIL);
+			IF returnType # NIL THEN 
+				id := Global.New;
+				result := NIL;
+			ELSE
+				id := builtin.id;
+				IF system.operatorDefined[id] THEN (* try to find overloaded operator *)
+					result := NewOperatorCall(position,builtin.id,parameter0,parameter1,NIL);
+				END;
 			END;
 
 			IF result = SyntaxTree.invalidExpression THEN (* error already handled *)
@@ -5020,6 +5029,9 @@ TYPE
 			ELSE
 				result := SyntaxTree.NewBuiltinCallDesignator(position,id,left,actualParameters);
 				result(SyntaxTree.Designator).SetLeft(left);
+				IF returnType # NIL THEN
+					type := returnType;
+				END;
 				(* ---- ASSERT ----- *)
 				IF (id = Global.Assert) & CheckArity(1,2)  THEN
 					IF CheckBooleanType(parameter0) THEN
@@ -5090,25 +5102,31 @@ TYPE
 					IF CheckObjectType(parameter0) THEN
 					END;
 				(* ---- NEW ----- *)
-				ELSIF (id = Global.New) & CheckArity(1,Infinity) THEN
+				ELSIF (id = Global.New)  THEN
+					IF returnType # NIL THEN
+						first := 0; type2 := type1; type1 := type0 ; type0:= returnType.resolved;
+					ELSE
+						first := 1;
+					END;
+					IF CheckArity(first,Infinity) THEN 
 					IF currentIsRealtime THEN
 						Error(position,Diagnostics.Invalid,"forbidden new in realtime block");
 					END;
 					(* check constructor *)
-					IF CheckVariable(parameter0) THEN
+					IF (first =0) OR CheckVariable(parameter0) THEN
 						IF type0 IS SyntaxTree.PointerType THEN
 							type0 := type0(SyntaxTree.PointerType).pointerBase.resolved;
 						END;
 						IF type0 IS SyntaxTree.ArrayType THEN
 							arrayType := type0(SyntaxTree.ArrayType);
 							IF arrayType.form = SyntaxTree.Static THEN
-								i := 1
+								i := first
 							ELSIF arrayType.form = SyntaxTree.Open THEN
-								i := Dimension(arrayType,{SyntaxTree.Open})+1;
+								i := Dimension(arrayType,{SyntaxTree.Open})+first;
 							ELSE HALT(100)
 							END;
 							IF CheckArity(i,i) & (numberActualParameters>1) THEN
-								i := 1;
+								i := first;
 								REPEAT
 									actualParameter := actualParameters.GetExpression(i);
 									IF CheckSizeType(actualParameter) THEN
@@ -5121,16 +5139,15 @@ TYPE
 						ELSIF (type0 IS SyntaxTree.RecordType) THEN
 							constructor := GetConstructor(type0(SyntaxTree.RecordType));
 							IF constructor = NIL THEN
-								IF CheckArity(1,1) THEN END;
+								IF CheckArity(first,first) THEN END;
 							ELSIF (constructor.scope.ownerModule # currentScope.ownerModule) & ~(SyntaxTree.PublicRead IN constructor.access) THEN
 								Error(position,Diagnostics.Invalid,"new on object with hidden constructor");
 							ELSE
 								procedureType := constructor.type(SyntaxTree.ProcedureType);
 								numberFormalParameters := procedureType.numberParameters;
-								DEC(numberActualParameters);
-								IF numberActualParameters <= numberFormalParameters THEN
+								IF numberActualParameters-first <= numberFormalParameters THEN
 									formalParameter := procedureType.firstParameter;
-									FOR i := 1 TO numberActualParameters DO
+									FOR i := first TO numberActualParameters-1 DO
 										actualParameter := actualParameters.GetExpression(i);
 										IF (actualParameter = SyntaxTree.invalidExpression) THEN
 										ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
@@ -5161,9 +5178,9 @@ TYPE
 								Error(position,Diagnostics.Invalid,"new on static array");
 							ELSE
 								IF mathArrayType.form = SyntaxTree.Tensor THEN
-									i0 := 2; i1 := Infinity;
+									i0 := first+1; i1 := Infinity;
 								ELSIF mathArrayType.form = SyntaxTree.Open THEN
-									i0 := Dimension(mathArrayType,{SyntaxTree.Open})+1;
+									i0 := Dimension(mathArrayType,{SyntaxTree.Open})+first;
 									i1 := i0;
 								ELSE HALT(100);
 								END;
@@ -5190,8 +5207,8 @@ TYPE
 										parameter1 := NewConversion(Diagnostics.Invalid,parameter1,parameterType,NIL); actualParameters.SetExpression(1,parameter1);
 									END;
 								ELSE
-									IF CheckArity(i0,i1) & (numberActualParameters >1) THEN
-										i := 1;
+									IF CheckArity(i0,i1) & (numberActualParameters >first) THEN
+										i := first;
 										REPEAT
 											actualParameter := actualParameters.GetExpression(i);
 											IF CheckSizeType(actualParameter) THEN
@@ -5216,7 +5233,7 @@ TYPE
 									DEC(numberActualParameters);
 									IF numberActualParameters <= numberFormalParameters THEN
 										formalParameter := procedureType.firstParameter;
-										FOR i := 1 TO numberActualParameters DO
+										FOR i := first TO numberActualParameters DO
 											actualParameter := actualParameters.GetExpression(i);
 											IF (actualParameter = SyntaxTree.invalidExpression) THEN
 											ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
@@ -5248,6 +5265,7 @@ TYPE
 							Error(position,Diagnostics.Invalid,"cannot be allocated");
 						END;
 					END;
+					END;
 				(* ---- DISPOSE ----- *)
 				ELSIF (id = Global.Dispose) & CheckArity(1,1) THEN
 					IF ~IsPointerType(parameter0.type) THEN
@@ -6121,7 +6139,7 @@ TYPE
 						result := NewTypeGuardDesignator(designator.position,left,typeDeclaration.declaredType, parameters.GetExpression(0))
 					ELSIF (left.type.resolved IS SyntaxTree.ProcedureType) THEN
 						IF (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Builtin) THEN
-							result := NewBuiltinCallDesignator(designator.position,left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Builtin),parameters,left);
+							result := NewBuiltinCallDesignator(designator.position,left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Builtin),parameters,left,NIL);
 						ELSE
 							result := NewProcedureCallDesignator(designator.position,left,parameters)
 						END
@@ -6824,7 +6842,7 @@ TYPE
 
 		(**
 			a builtin procedure is a global item that may not be modified locally
-			instead the resolving of builtin procedure calls are done in the NewBuiltinCallDesignator
+			instead the resolving of builtin procedure calls are done in the esignator
 		**)
 		PROCEDURE VisitBuiltin(builtinProcedure: SyntaxTree.Builtin);
 		VAR type: SyntaxTree.Type;

source/FoxSyntaxTree.Mod

@@ -2495,12 +2495,18 @@ TYPE
 			id-: LONGINT;
 			parameters-: ExpressionList;
 			builtin-: Builtin;
+			returnType-: Type;
 
 		PROCEDURE & InitBuiltinCallDesignator(position: LONGINT; id: LONGINT; left: Designator; parameters: ExpressionList);
 		BEGIN
-			InitDesignator(position); SELF.parameters := parameters; SELF.id := id; SELF.left := left;
+			InitDesignator(position); SELF.parameters := parameters; SELF.id := id; SELF.left := left; returnType := NIL;
 		END InitBuiltinCallDesignator;
-
+		
+		PROCEDURE SetReturnType*(type: Type);
+		BEGIN
+			returnType := type (* used for NEW Type() expression *)
+		END SetReturnType;
+		
 		PROCEDURE Clone(): Expression;
 		VAR copy: BuiltinCallDesignator;
 		BEGIN