public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-8431] modula2: add project regression test and badpointer tests
@ 2024-01-25 16:29 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2024-01-25 16:29 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:0614eb8440b15d238565a8124eb1b1cb4710dc85
commit r14-8431-g0614eb8440b15d238565a8124eb1b1cb4710dc85
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Thu Jan 25 16:29:02 2024 +0000
modula2: add project regression test and badpointer tests
This patch adds four modula-2 testcases to the regression testsuite.
The project example stresses INC/DEC and range checking and the bad
pointer stress attempting to pass a string acual parameter to a
procedure with a pointer formal parameter.
gcc/testsuite/ChangeLog:
* gm2/pim/fail/badpointer.mod: New test.
* gm2/pim/fail/badpointer2.mod: New test.
* gm2/pim/fail/badpointer3.mod: New test.
* gm2/projects/pim/run/pass/pegfive/pegfive.mod: New test.
* gm2/projects/pim/run/pass/pegfive/projects-pim-run-pass-pegfive.exp: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/testsuite/gm2/pim/fail/badpointer.mod | 22 +
gcc/testsuite/gm2/pim/fail/badpointer2.mod | 24 +
gcc/testsuite/gm2/pim/fail/badpointer3.mod | 24 +
.../gm2/projects/pim/run/pass/pegfive/pegfive.mod | 767 +++++++++++++++++++++
.../pass/pegfive/projects-pim-run-pass-pegfive.exp | 39 ++
5 files changed, 876 insertions(+)
diff --git a/gcc/testsuite/gm2/pim/fail/badpointer.mod b/gcc/testsuite/gm2/pim/fail/badpointer.mod
new file mode 100644
index 000000000000..e8a199edde87
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badpointer.mod
@@ -0,0 +1,22 @@
+MODULE badpointer ;
+
+FROM DynamicStrings IMPORT String ;
+
+CONST
+ Hello = "hello world" ;
+
+
+PROCEDURE testproc (s: String) ;
+BEGIN
+END testproc ;
+
+
+PROCEDURE foo ;
+BEGIN
+ testproc (Hello)
+END foo ;
+
+
+BEGIN
+ foo
+END badpointer.
diff --git a/gcc/testsuite/gm2/pim/fail/badpointer2.mod b/gcc/testsuite/gm2/pim/fail/badpointer2.mod
new file mode 100644
index 000000000000..efd6c74897dd
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badpointer2.mod
@@ -0,0 +1,24 @@
+MODULE badpointer2 ;
+
+FROM DynamicStrings IMPORT String ;
+
+CONST
+ A = "hello" ;
+ B = " world" ;
+ Hello = A + B ;
+
+
+PROCEDURE testproc (s: String) ;
+BEGIN
+END testproc ;
+
+
+PROCEDURE foo ;
+BEGIN
+ testproc (Hello)
+END foo ;
+
+
+BEGIN
+ foo
+END badpointer2.
diff --git a/gcc/testsuite/gm2/pim/fail/badpointer3.mod b/gcc/testsuite/gm2/pim/fail/badpointer3.mod
new file mode 100644
index 000000000000..73de3dedbdf8
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badpointer3.mod
@@ -0,0 +1,24 @@
+MODULE badpointer3 ;
+
+FROM SYSTEM IMPORT ADDRESS ;
+
+CONST
+ A = "hello" ;
+ B = " world" ;
+ Hello = A + B ;
+
+
+PROCEDURE testproc (s: ADDRESS) ;
+BEGIN
+END testproc ;
+
+
+PROCEDURE foo ;
+BEGIN
+ testproc (Hello)
+END foo ;
+
+
+BEGIN
+ foo
+END badpointer3.
diff --git a/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/pegfive.mod b/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/pegfive.mod
new file mode 100644
index 000000000000..6ad559ade9be
--- /dev/null
+++ b/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/pegfive.mod
@@ -0,0 +1,767 @@
+(* Copyright (C) 2007 Free Software Foundation, Inc. *)
+(* 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 2, 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.
+
+You should have received a copy of the GNU General Public License along
+with gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE pegfive ;
+
+
+FROM SYSTEM IMPORT BYTE ;
+FROM NumberIO IMPORT WriteCard, StrToCard, WriteInt ;
+FROM StrIO IMPORT ReadString, WriteString, WriteLn ;
+FROM StdIO IMPORT Write ;
+FROM StrLib IMPORT StrLen, StrRemoveWhitePrefix, StrEqual ;
+FROM Selective IMPORT Timeval, GetTimeOfDay, GetTime, InitTime, KillTime ;
+FROM FIO IMPORT FlushBuffer, StdOut ;
+
+
+CONST
+ EnableGame = FALSE ; (* Set to TRUE if you want to play
+ the game. *)
+ BoardX = 16 ;
+ BoardY = 16 ;
+ BoardSize = BoardX * BoardY ;
+ AreaRadius = 1 ;
+ MaxScore = 100000 ;
+ MinScore = -100000 ;
+ OpenFour = 10000 ;
+ OpenThree = 1000 ;
+ OpenTwo = 100 ;
+ WinScore = MaxScore ;
+ LooseScore = -WinScore ;
+ MaxTimePerMove = 8 ;
+ MinTimePerMove = 3 ;
+
+TYPE
+ Squares = [0..BoardSize-1] ;
+
+ Moves = RECORD
+ NoOfPegs: CARDINAL ;
+ Tiles : ARRAY [0..BoardSize] OF BYTE ;
+ END ;
+
+ Board = RECORD
+ Pegs : Moves ;
+ Colours : SetOfSquare ;
+ END ;
+
+ SetOfSquare = SET OF Squares ;
+
+ Colour = (black, white) ;
+
+
+VAR
+ count,
+ NoOfPlies: CARDINAL ;
+
+
+(*
+ InitBoard - initialize the board.
+*)
+
+PROCEDURE InitBoard (VAR b: Board) ;
+BEGIN
+ b.Pegs.NoOfPegs := 0 ;
+ b.Colours := SetOfSquare{}
+END InitBoard ;
+
+
+(*
+ CreateListOfMachineMoves - given board, b, generate a list of possible
+ moves to consider in, m, for colour, c.
+*)
+
+PROCEDURE CreateListOfMoves (VAR b: Board; VAR m: Moves; c: Colour) ;
+VAR
+ i : CARDINAL ;
+ t, j, n: INTEGER ;
+BEGIN
+ m.NoOfPegs := 0 ;
+ n := 0 ;
+ i := 0 ;
+ WHILE i<b.Pegs.NoOfPegs DO
+ t := VAL(INTEGER, b.Pegs.Tiles[i]) ;
+ FOR j := 1 TO AreaRadius DO
+ IfFreeAdd(b, m, (t-1)*j, c) ;
+ IfFreeAdd(b, m, (t+1)*j, c) ;
+ IfFreeAdd(b, m, (t-BoardX)*j, c) ;
+ IfFreeAdd(b, m, (t+BoardX)*j, c) ;
+ IfFreeAdd(b, m, (t-(BoardX+1))*j, c) ;
+ IfFreeAdd(b, m, (t+(BoardX+1))*j, c) ;
+ IfFreeAdd(b, m, (t-(BoardX-1))*j, c) ;
+ IfFreeAdd(b, m, (t+(BoardX-1))*j, c)
+ END ;
+ INC(i)
+ END
+END CreateListOfMoves ;
+
+
+(*
+ IfFreeAdd - tests to see whether position, i, is legal
+ and adds it to the list of moves, m.
+*)
+
+PROCEDURE IfFreeAdd (VAR b: Board; VAR m: Moves; i: INTEGER; c: Colour) ;
+VAR
+ n: CARDINAL ;
+BEGIN
+ IF (i>=0) AND (i<BoardSize)
+ THEN
+ n := 0 ;
+ WHILE n<b.Pegs.NoOfPegs DO
+ IF VAL(INTEGER, b.Pegs.Tiles[n])=i
+ THEN
+ RETURN
+ END ;
+ INC(n)
+ END ;
+ (* it is free, so add it to, m *)
+ m.Tiles[m.NoOfPegs] := VAL(BYTE, i) ;
+ INC(m.NoOfPegs) ;
+ END
+END IfFreeAdd ;
+
+
+(*
+ MaximumScore - returns TRUE if the maximim score was found.
+*)
+
+PROCEDURE MaximumScore (score: INTEGER) : BOOLEAN ;
+BEGIN
+ IF (score<=MinScore) OR (score>=MaxScore)
+ THEN
+ RETURN TRUE
+ ELSE
+ RETURN FALSE
+ END
+END MaximumScore ;
+
+
+(*
+ IsPositionCol - returns TRUE if position, pos, on board, b, contains a peg
+ of colour, c.
+*)
+
+PROCEDURE IsPositionCol (VAR b: Board; pos: CARDINAL; c: Colour) : BOOLEAN ;
+VAR
+ p: CARDINAL ;
+BEGIN
+ p := b.Pegs.NoOfPegs ;
+ WHILE p>0 DO
+ DEC(p) ;
+ IF VAL(CARDINAL, b.Pegs.Tiles[p])=pos
+ THEN
+ IF c=white
+ THEN
+ RETURN pos IN b.Colours
+ ELSE
+ RETURN NOT (pos IN b.Colours)
+ END
+ END
+ END ;
+ RETURN FALSE
+END IsPositionCol ;
+
+
+(*
+ IsPositionEmpty - returns TRUE if position, pos, on board, b, is empty.
+*)
+
+PROCEDURE IsPositionEmpty (VAR b: Board; pos: CARDINAL) : BOOLEAN ;
+VAR
+ p: CARDINAL ;
+BEGIN
+ p := b.Pegs.NoOfPegs ;
+ WHILE p>0 DO
+ DEC(p) ;
+ IF VAL(CARDINAL, b.Pegs.Tiles[p])=pos
+ THEN
+ RETURN FALSE
+ END
+ END ;
+ RETURN TRUE
+END IsPositionEmpty ;
+
+
+(*
+ CheckDir - search back to at most square, begin, and then search forward to
+ at most position, end, for a run of pegs.
+*)
+
+PROCEDURE CheckDir (VAR b: Board; pos: INTEGER;
+ col: Colour; dec, inc: INTEGER;
+ begin, end: INTEGER; score: INTEGER) : INTEGER ;
+VAR
+ newscore: INTEGER ;
+ open,
+ count : CARDINAL ;
+BEGIN
+ WITH b DO
+ IF (pos>=begin) AND IsPositionCol(b, pos, col)
+ THEN
+ WHILE (pos>=begin) AND IsPositionCol(b, pos, col) DO
+ pos := pos + dec
+ END ;
+ open := 0 ;
+ IF (pos>=begin) AND IsPositionEmpty(b, pos)
+ THEN
+ (* open this end *)
+ open := 1
+ END ;
+ pos := pos + inc * 2 ;
+ count := 1 ;
+ WHILE (pos<=end) AND IsPositionCol(b, pos, col) DO
+ pos := pos + inc ;
+ INC(count)
+ END ;
+ IF (pos<end) AND IsPositionEmpty(b, pos)
+ THEN
+ (* open this end *)
+ INC(open)
+ END ;
+ IF open>1
+ THEN
+ DEC(open)
+ END ;
+ CASE count OF
+
+ 2: newscore := open*OpenTwo |
+ 3: newscore := open*OpenThree |
+ 4: newscore := open*OpenFour |
+ 5: IF col=white
+ THEN
+ RETURN MaxScore
+ ELSE
+ RETURN MinScore
+ END
+ ELSE
+ newscore := 0
+ END ;
+ IF col=white
+ THEN
+ RETURN score+newscore
+ ELSE
+ RETURN score-newscore
+ END
+ ELSE
+ RETURN score
+ END
+ END
+END CheckDir ;
+
+
+(*
+ RemoveScore - removes the value of a line of pegs starting at position, pos,
+ from the, score, and returns the new score.
+*)
+
+PROCEDURE RemoveScore (VAR b: Board; pos: INTEGER;
+ dec, inc: INTEGER;
+ begin, end: INTEGER; score: INTEGER) : INTEGER ;
+VAR
+ col: Colour ;
+BEGIN
+ IF (pos >= 0) AND (pos < BoardSize)
+ THEN
+ IF IsPositionEmpty(b, pos)
+ THEN
+ RETURN score
+ ELSE
+ IF IsPositionCol(b, pos, white)
+ THEN
+ col := white
+ ELSE
+ col := black
+ END ;
+ score := score - CheckDir(b, pos, col, dec, inc, begin, end, 0)
+ END
+ END ;
+ RETURN score
+END RemoveScore ;
+
+
+(*
+ CalcScore - returns the new score if move, pos, is played
+ by colour, col.
+*)
+
+PROCEDURE CalcScore (VAR b: Board; score: INTEGER;
+ pos: INTEGER; col: Colour) : INTEGER ;
+VAR
+ s : INTEGER ;
+ x, y,
+ lup, rdown,
+ ldown, rup,
+ up, down,
+ left, right: CARDINAL ;
+BEGIN
+ x := pos MOD BoardX ;
+ y := pos DIV BoardX ;
+ left := y * BoardX ;
+ right := left+BoardX-1 ;
+ down := x ;
+ up := down + (BoardX*(BoardY-1)) ;
+
+ (* diag left down *)
+ IF x>y
+ THEN
+ ldown := x-y
+ ELSE
+ ldown := (y-x) * BoardY
+ END ;
+ (* diag right up *)
+ IF x>y
+ THEN
+ rup := (BoardX-x+y)*BoardY-1
+ ELSE
+ rup := ((BoardY-1)-y+x) + (BoardY-1)*BoardY
+ END ;
+ (* diag left up *)
+ IF x>=BoardY-y
+ THEN
+ lup := (BoardY-1)*BoardX+(x-(BoardY-1-y))
+ ELSE
+ lup := (y+x)*BoardY
+ END ;
+ (* diag right down *)
+ IF y >= BoardX-x
+ THEN
+ rdown := (y-(BoardX-x-1))*BoardY+BoardX-1
+ ELSE
+ rdown := x+y
+ END ;
+
+ (* firstly remove previous score for both colours from adjacent pegs *)
+ score := RemoveScore(b, pos-1, -1, +1, left, right, score) ;
+ score := RemoveScore(b, pos+1, +1, -1, left, right, score) ;
+ score := RemoveScore(b, pos-BoardX, -BoardX, +BoardX, down, up, score) ;
+ score := RemoveScore(b, pos+BoardX, +BoardX, -BoardX, down, up, score) ;
+
+ score := RemoveScore(b, pos+(BoardX-1), +(BoardX-1), -(BoardX-1), rdown, lup, score) ;
+ score := RemoveScore(b, pos-(BoardX-1), -(BoardX-1), +(BoardX-1), rdown, lup, score) ;
+ score := RemoveScore(b, pos+(BoardX+1), +(BoardX+1), -(BoardX+1), ldown, rup, score) ;
+ score := RemoveScore(b, pos-(BoardX+1), -(BoardX+1), +(BoardX+1), ldown, rup, score) ;
+
+ (* now add our new peg *)
+ ApplyMove(b, col, pos) ;
+
+ (* and calculate the new score *)
+
+ s := CheckDir(b, pos, col, -1, +1, left, right, 0) ;
+ IF MaximumScore(s)
+ THEN
+ RETURN s
+ END ;
+ score := score + s ;
+
+ s := CheckDir(b, pos, col, -BoardX, +BoardX, down, up, 0) ;
+ IF MaximumScore(s)
+ THEN
+ RETURN s
+ END ;
+ score := score + s ;
+
+ s := CheckDir(b, pos, col, -(BoardX+1), +(BoardX+1), ldown, rup, 0) ;
+ IF MaximumScore(s)
+ THEN
+ RETURN s
+ END ;
+ score := score + s ;
+
+ s := CheckDir(b, pos, col, -(BoardX-1), +(BoardX-1), rdown, lup, 0) ;
+ IF MaximumScore(s)
+ THEN
+ RETURN s
+ END ;
+ score := score + s ;
+
+ RETURN score
+END CalcScore ;
+
+
+(*
+ DisplayBoard - displays the pegfive board.
+*)
+
+PROCEDURE DisplayBoard (VAR b: Board) ;
+VAR
+ pos,
+ i, x, y: CARDINAL ;
+ written: BOOLEAN ;
+BEGIN
+ WriteString(' A B C D E F G H I J K L M N O P') ; WriteLn ;
+ WriteString(' +---------------------------------+') ; WriteLn ;
+ FOR y := BoardY TO 1 BY -1 DO
+ WriteCard(y, 2) ; Write('|') ;
+ FOR x := 0 TO BoardX-1 DO
+ i := b.Pegs.NoOfPegs ;
+ written := FALSE ;
+ WHILE i>0 DO
+ pos := VAL(CARDINAL, b.Pegs.Tiles[i-1]) ;
+ IF pos=((y-1)*BoardX)+x
+ THEN
+ written := TRUE ;
+ IF pos IN b.Colours
+ THEN
+ WriteString(' O')
+ ELSE
+ WriteString(' X')
+ END
+ END ;
+ DEC(i)
+ END ;
+ IF NOT written
+ THEN
+ WriteString(' .')
+ END
+ END ;
+ WriteString(' |') ; WriteCard(y, 0) ; WriteLn
+ END ;
+ WriteString(' +---------------------------------+') ; WriteLn ;
+ WriteString(' A B C D E F G H I J K L M N O P') ; WriteLn
+END DisplayBoard ;
+
+
+(*
+ WriteColour - displays the colour, c.
+*)
+
+PROCEDURE WriteColour (c: Colour) ;
+BEGIN
+ CASE c OF
+
+ white: WriteString('naughts') |
+ black: WriteString('crosses')
+
+ END
+END WriteColour ;
+
+
+(*
+ ApplyMove - adds move, pos, to board.
+*)
+
+PROCEDURE ApplyMove (VAR b: Board; c: Colour; pos: CARDINAL) ;
+BEGIN
+ IF b.Pegs.NoOfPegs<BoardSize
+ THEN
+ b.Pegs.Tiles[b.Pegs.NoOfPegs] := VAL(BYTE, pos) ;
+ INC(b.Pegs.NoOfPegs) ;
+ IF c=white
+ THEN
+ INCL(b.Colours, pos)
+ END
+ END
+END ApplyMove ;
+
+
+(*
+ RetractMove - removes the last move from the board.
+*)
+
+PROCEDURE RetractMove (VAR b: Board) ;
+VAR
+ pos: CARDINAL ;
+BEGIN
+ IF b.Pegs.NoOfPegs>0
+ THEN
+ DEC(b.Pegs.NoOfPegs) ;
+ pos := VAL(CARDINAL, b.Pegs.Tiles[b.Pegs.NoOfPegs]) ;
+ EXCL(b.Colours, pos)
+ END
+END RetractMove ;
+
+
+(*
+ AskMove - returns a move entered.
+*)
+
+PROCEDURE AskMove (VAR b: Board; c: Colour) : CARDINAL ;
+VAR
+ s : ARRAY [0..80] OF CHAR ;
+ x : CHAR ;
+ y, m: CARDINAL ;
+BEGIN
+ LOOP
+ WriteString('Please enter your move, ') ;
+ WriteColour(c) ;
+ WriteString(': ') ;
+ LOOP
+ ReadString(s) ;
+ StrRemoveWhitePrefix(s, s) ;
+ IF StrEqual (s, 'exit') OR StrEqual (s, 'quit')
+ THEN
+ WriteString ('goodbye') ; WriteLn ;
+ HALT (0)
+ ELSIF StrLen(s)>0
+ THEN
+ x := CAP(s[0]) ;
+ IF (x>='A') AND (x<='P')
+ THEN
+ m := ORD (x) - ORD ('A') ;
+ s[0] := ' ' ;
+ StrRemoveWhitePrefix(s, s) ;
+ IF StrLen(s)>0
+ THEN
+ StrToCard(s, y) ;
+ IF (y=0) OR (y>BoardY)
+ THEN
+ WriteString('Please enter a number between [1-16]') ; WriteLn
+ ELSE
+ m := m+(y-1)*BoardY ;
+ EXIT
+ END
+ END
+ ELSE
+ WriteString('please enter a letter [A-P] followed by a number [1-16]') ; WriteLn
+ END
+ END
+ END ;
+ IF IsPositionEmpty(b, m)
+ THEN
+ RETURN m
+ END ;
+ IF IsPositionCol(b, m, c)
+ THEN
+ WriteString('You have already moved into that position') ; WriteLn
+ ELSE
+ WriteString('That position is occupied by your opponent') ; WriteLn
+ END
+ END
+END AskMove ;
+
+
+(*
+ Opponent - returns the opposite colour.
+*)
+
+PROCEDURE Opponent (col: Colour) : Colour ;
+BEGIN
+ IF col=white
+ THEN
+ RETURN black
+ ELSE
+ RETURN white
+ END
+END Opponent ;
+
+
+(*
+ AlphaBeta - returns the score estimated should move, pos, be chosen.
+ The board, b, and score is in the state _before_ move pos
+ is made.
+*)
+
+PROCEDURE AlphaBeta (pos: CARDINAL; VAR b: Board; col: Colour;
+ depth: CARDINAL;
+ alpha, beta, score: INTEGER) : INTEGER ;
+VAR
+ try : INTEGER ;
+ i, n : CARDINAL ;
+ m : Moves ;
+ newBoard: Board ;
+BEGIN
+ score := CalcScore(b, score, pos, col) ; (* make move and update score *)
+ IF (depth=0) OR MaximumScore(score)
+ THEN
+ RetractMove(b) ;
+ INC(count) ;
+ IF col=white
+ THEN
+ RETURN score+VAL(INTEGER, depth)
+ ELSE
+ RETURN score-VAL(INTEGER, depth)
+ END
+ ELSE
+ col := Opponent(col) ;
+ CreateListOfMoves(b, m, col) ;
+ i := 0 ;
+ IF col=white
+ THEN
+ WHILE i<m.NoOfPegs DO
+ try := AlphaBeta(VAL(CARDINAL, m.Tiles[i]),
+ b, white, depth-1, alpha, beta, score) ;
+ IF try > alpha
+ THEN
+ (* found a better move *)
+ alpha := try
+ END ;
+ IF alpha >= beta
+ THEN
+ RetractMove(b) ;
+ RETURN alpha
+ END ;
+ INC(i)
+ END ;
+ RetractMove(b) ;
+ RETURN alpha
+ ELSE
+ (* black to move, move is possible, continue searching *)
+ WHILE i<m.NoOfPegs DO
+ try := AlphaBeta(VAL(CARDINAL, m.Tiles[i]),
+ b, black, depth-1, alpha, beta, score) ;
+ IF try < beta
+ THEN
+ (* found a better move *)
+ beta := try
+ END ;
+ IF alpha >= beta
+ THEN
+ (* no point searching further as WHITE would choose
+ a different previous move *)
+ RetractMove(b) ;
+ RETURN beta
+ END ;
+ INC(i)
+ END ;
+ RetractMove(b) ;
+ RETURN beta (* the best score for a move BLACK has found *)
+ END
+ END
+END AlphaBeta ;
+
+
+(*
+ MakeMove - computer makes a move for colour, col.
+*)
+
+PROCEDURE MakeMove (VAR b: Board; col: Colour; score: INTEGER) : INTEGER ;
+VAR
+ start, end: Timeval ;
+ try,
+ r, best : INTEGER ;
+ secS, usec,
+ secE, i,
+ move : CARDINAL ;
+ m : Moves ;
+BEGIN
+ start := InitTime(0, 0) ;
+ end := InitTime(0, 0) ;
+
+ WriteString("I'm going to look ") ;
+ WriteCard(NoOfPlies, 0) ; WriteString(' moves ahead') ; WriteLn ;
+
+ r := GetTimeOfDay(start) ;
+ best := MinScore-1 ;
+
+ count := 0 ;
+ i := 0 ;
+ CreateListOfMoves(b, m, col) ;
+ WHILE i<m.NoOfPegs DO
+ try := AlphaBeta(VAL(CARDINAL, m.Tiles[i]), b, col, NoOfPlies,
+ MinScore, MaxScore, score) ;
+ IF try>best
+ THEN
+ best := try ;
+ move := VAL(CARDINAL, m.Tiles[i])
+ END ;
+ INC(i)
+ END ;
+
+ r := GetTimeOfDay(end) ;
+ GetTime(start, secS, usec) ;
+ GetTime(end, secE, usec) ;
+
+ IF best >= WinScore
+ THEN
+ WriteString('I think I can force a win') ; WriteLn
+ END ;
+ IF best <= LooseScore
+ THEN
+ WriteString('You should be able to force a win') ; WriteLn
+ END ;
+
+ WriteString('I took ') ; WriteCard(secE-secS, 0) ;
+ WriteString(' seconds and evaluated ') ;
+ WriteCard(count, 0) ; WriteString(' positions,') ; WriteLn ;
+
+ IF secE-secS > MaxTimePerMove
+ THEN
+ WriteString('sorry about the wait, I took too long so') ; WriteLn ;
+ WriteString('I will reduce my search next go..') ; WriteLn ;
+ IF NoOfPlies >= 3
+ THEN
+ DEC(NoOfPlies)
+ END
+ ELSE
+ IF secE-secS < MinTimePerMove
+ THEN
+ INC(NoOfPlies)
+ END
+ END ;
+
+ start := KillTime(start) ;
+ end := KillTime(end) ;
+ RETURN move
+END MakeMove ;
+
+
+(*
+ Play -
+*)
+
+PROCEDURE Play ;
+VAR
+ b: Board ;
+ c: Colour ;
+ s: INTEGER ;
+ m: CARDINAL ;
+BEGIN
+ InitBoard(b) ;
+ NoOfPlies := 3 ;
+ c := black ;
+ s := 0 ;
+ DisplayBoard(b) ;
+ REPEAT
+ m := AskMove(b, c) ;
+ s := CalcScore(b, s, m, c) ;
+ DisplayBoard(b) ;
+ WriteString('Current score = ') ; WriteInt(s, 0) ; WriteLn ;
+ FlushBuffer(StdOut) ;
+ IF s<=MinScore
+ THEN
+ WriteString('Well done you win') ; WriteLn ;
+ RETURN
+ END ;
+ c := Opponent(c) ;
+ m := MakeMove(b, c, s) ;
+ s := CalcScore(b, s, m, c) ;
+
+ WriteString('I am going to move to position: ') ;
+ Write(CHR(ORD('a')+m MOD BoardY)) ;
+ WriteCard(m DIV BoardX+1, 0) ;
+ WriteLn ;
+ DisplayBoard(b) ;
+ WriteString('Current score = ') ; WriteInt(s, 0) ; WriteLn ;
+ IF s>=MaxScore
+ THEN
+ WriteString('Good try, but I win') ; WriteLn ;
+ RETURN
+ END ;
+ c := Opponent(c)
+ UNTIL b.Pegs.NoOfPegs=BoardSize ;
+ WriteString('The game has ended in a draw as the board is full') ; WriteLn
+END Play ;
+
+
+BEGIN
+ IF EnableGame
+ THEN
+ Play
+ ELSE
+ WriteString ('to enable the game - edit line 31 in pegfive.mod and recompile') ;
+ WriteLn
+ END
+END pegfive.
diff --git a/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/projects-pim-run-pass-pegfive.exp b/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/projects-pim-run-pass-pegfive.exp
new file mode 100644
index 000000000000..b32f5659ba0b
--- /dev/null
+++ b/gcc/testsuite/gm2/projects/pim/run/pass/pegfive/projects-pim-run-pass-pegfive.exp
@@ -0,0 +1,39 @@
+# Expect driver script for GCC Regression Tests
+# Copyright (C) 2022-2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib gm2-torture.exp
+
+set gm2src ${srcdir}/../m2
+
+gm2_init_pim "-g -fsoft-check-all"
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+
+ gm2-torture-execute $testcase "" "pass"
+}
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-01-25 16:29 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-01-25 16:29 [gcc r14-8431] modula2: add project regression test and badpointer tests Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).