-- version control marker $Id: cgmain.occ,v 3.9 1997/03/06 16:36:15 dcw Exp $
#IF NOT DEFINED (COMPILER.TOCK)
#INCLUDE "cglib.module"
#ELSE
#USE "cglib"
#ENDIF

#IF DEFINED (SUCCESSFUL.TESTS)
VAL display.names  IS TRUE :
#ELSE
VAL display.names  IS FALSE :
#ENDIF
--VAL display.names  IS TRUE :
--VAL display.titles IS display.names :
VAL display.titles IS TRUE :

VAL no.of.columns   IS 6 :
VAL width.of.column IS 10 :

TIMER timer:			-- DCW
INT start.time, end.time:	-- DCW

INT column.count :
--{{{  [INLINE] PROC out (VAL INT ch)
INLINE PROC out (VAL INT ch)
  SEQ
    IF
      (ch >= 0) AND (ch < 256)
        scr ! BYTE ch
      TRUE
        SKIP
:
--}}}
--{{{  PROC newline ()
PROC newline ()
  SEQ
    out.nl (scr)
    column.count := 0
:
--}}}
--{{{  PROC writes (VAL []BYTE s)
PROC writes (VAL []BYTE s)
  out.string (s, 0, scr)
:
--}}}
--{{{  [INLINE] PROC in (INT ch)
INLINE PROC in (INT ch)
  --all input goes via this proc, but its only ever used to wait
  SEQ
    --newline ()
    --writes ("(Press any key) ")
    -- keyboard ? ch
    ch := ch  -- stop any warning not used
    newline ()
:
--}}}
--{{{  [INLINE] PROC writen (VAL INT n)
INLINE PROC writen (VAL INT n)
  out.number (n, 0, scr)
:
--}}}
--{{{  [INLINE] PROC writehex (VAL INT value, length)
INLINE PROC writehex (VAL INT value, length)
  --VAL hex IS "0123456789ABCDEF" :
  --SEQ
  --  SEQ i = 1 FOR length
  --    out (INT hex [(value >> ((length - i) * 4)) /\ #F] )
  --  out (-2)
  out.hex.int (value, length, scr)
:
--}}}
--{{{  [INLINE] PROC beep ()
INLINE PROC beep ()
  out (7)
:
--}}}
--{{{  PROC failed.test  (VAL []BYTE where)
PROC failed.test(VAL []BYTE where)
  SEQ
    beep()
    writes(where)
    IF
      display.names
        newline()
      TRUE
        SKIP
    writes (" Failed: ")
:
--}}}
--{{{  PROC completed.ok (VAL []BYTE where)
INT error.count, passed.count:
PROC completed.ok (VAL []BYTE where)
  SEQ
    passed.count := passed.count + 1
    IF
      display.names
        SEQ
          writes (where)
          IF
            column.count < no.of.columns
              VAL spaces IS "            " :
              VAL INT n.spaces IS width.of.column - (SIZE where):
              SEQ
                IF
                  n.spaces > 0
                    writes([spaces FROM 0 FOR width.of.column - (SIZE where)])
                    --SEQ i = 0 FOR width.of.column - (SIZE where)
                    --  out ('*s' (INT))
                  TRUE
                    out ('*s' (INT))
                column.count := column.count + 1
            TRUE
              newline ()
      TRUE
        SKIP
:
--}}}

INT any.integer.name :
VAL []BYTE useless.name RETYPES any.integer.name :
VAL nibbles.per.INT IS (SIZE useless.name) * 2 :

--{{{  PROC check.BOOL (VAL BOOL val1, val2, VAL []BYTE test.type)
PROC check.BOOL (VAL BOOL val1, val2, VAL []BYTE test.type)
  INT key :
  PROC writebool (VAL BOOL b)
    IF
      b
        writes ("TRUE")
      TRUE
        writes ("FALSE")
  :
  SEQ
    IF
      val1 = val2
        completed.ok (test.type)
      TRUE
        SEQ
          failed.test(test.type)
          writebool (val1)
          writes ("  ")
          writebool (val2)
          in (key)
          error.count := error.count + 1
:
--}}}
--{{{  PROC check.BYTE (VAL BYTE val1, val2, VAL []BYTE test.type)
PROC check.BYTE (VAL BYTE val1, val2, VAL []BYTE test.type)
  INT key :
  SEQ
    IF
      val1 = val2
        completed.ok (test.type)
      TRUE
        SEQ
          failed.test(test.type)
          writehex (INT val1, 2)
          writes ("  ")
          writehex (INT val2, 2)
          in (key)
          error.count := error.count + 1
:
--}}}
--{{{  PROC check.INT (VAL INT val1, val2, VAL []BYTE test.type)
PROC check.INT (VAL INT val1, val2, VAL []BYTE test.type)
  INT key :
  SEQ
    IF
      val1 = val2
        completed.ok (test.type)
      TRUE
        SEQ
          failed.test(test.type)
          writehex (val1, nibbles.per.INT)
          writes ("  ")
          writehex (val2, nibbles.per.INT)
          writes ("  ")
          writen (val1)
          writes ("  ")
          writen (val2)
          in (key)
          error.count := error.count + 1
:
--}}}
--{{{  PROC check (VAL INT val1, val2, VAL []BYTE test.type)

--INLINE PROC check (VAL INT val1, val2, VAL []BYTE test.type)
-- If this is inline, every invocation creates an abbreviation
-- VAL test.type IS "..." :
-- and this makes the map file huge!

PROC check (VAL INT val1, val2, VAL []BYTE test.type)
  check.INT (val1, val2, test.type)
  --{{{  COMMENT
  --IF
    --val1 = val2
      --check.INT (val1, val2, test.type)
    --TRUE
      --out.string ("!!! FAILED in check !!!*n*c", 0, out)
  --}}}
:
--}}}

--{{{  PROC init (VAL []BYTE name, description)
[20]BYTE saved.name :
INT saved.name.len :
PROC init (VAL []BYTE name, description)
  SEQ
    timer ? start.time		-- DCW
    writes (name)
    writes ("  --  ")
    writes (description)
    newline ()
    error.count := 0
    passed.count := 0
    saved.name.len := SIZE name
    [saved.name FROM 0 FOR saved.name.len] := name
:
--}}}

--{{{  PROC title (VAL []BYTE string)
PROC title (VAL []BYTE string)
  IF
    display.titles
      SEQ
        IF
          display.names
            newline ()
          TRUE
            SKIP
          TRUE
            STOP
        writes(string)
        newline()
    TRUE
      SKIP
    TRUE
      STOP
:
--}}}

--{{{  PROC finish ()
PROC finish ()
  SEQ
    IF
      display.names
        newline ()
      TRUE
        SKIP
    IF
      error.count > 0
        SEQ
          writes ("^^^ Failed : ")
          writes ([saved.name FROM 0 FOR saved.name.len])
          writes (": ")
	  writen (error.count)
	  writes (" errors detected, ")
      TRUE
        SEQ
          writes ("^^^ Passed : ")
          writes ([saved.name FROM 0 FOR saved.name.len])
          writes (": All ")
    writen (passed.count)
    writes (" tests passed OK")
    timer ? end.time		-- DCW
    newline ()
    writes ("Time = ")
    writen (end.time - start.time)
    writes (" ticks")
    newline ()
:
--}}}

--{{{  identity functions
-- These are designed to help stop the optimiser constant propagating.
-- If it manages to defeat these, make them more complex, as long as they
-- still return the identity function.
BOOL   FUNCTION id.BOOL   (VAL BOOL   x)
  BOOL res :
  VALOF
    res := x
    RESULT res
:
BYTE   FUNCTION id.BYTE   (VAL BYTE   x)
  BYTE   res :
  VALOF
    res := x
    RESULT res
:
INT    FUNCTION id.INT    (VAL INT    x)
  INT    res :
  VALOF
    res := x
    RESULT res
:
INT16  FUNCTION id.INT16  (VAL INT16  x)
  INT16  res :
  VALOF
    res := x
    RESULT res
:
INT32  FUNCTION id.INT32  (VAL INT32  x)
  INT32  res :
  VALOF
    res := x
    RESULT res
:
INT64  FUNCTION id.INT64  (VAL INT64  x)
  INT64  res :
  VALOF
    res := x
    RESULT res
:
REAL32 FUNCTION id.REAL32 (VAL REAL32 x)
  REAL32 res :
  VALOF
    res := x
    RESULT res
:
REAL64 FUNCTION id.REAL64 (VAL REAL64 x)
  REAL64 res :
  VALOF
    res := x
    RESULT res
:
INT    FUNCTION id        (VAL INT    x)
  INT    res :
  VALOF
    res := x
    RESULT res
:

--}}}
