(***************************************************************************

     $RCSfile: StdIO.mod $
  Description: Simple formatted I/O using the standard input and output
               handles.

   Created by: fjc (Frank Copeland)
    $Revision: 1.2 $
      $Author: fjc $
        $Date: 1994/05/12 20:08:14 $

  Copyright © 1994, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

***************************************************************************)

MODULE StdIO;

(* $P- Allows non-portable language extensions. *)
(* $L+ Use absolute long addressing for global variables. *)

IMPORT
  SYS := SYSTEM, T := Types, Exec, Dos, WB := Workbench, Icon, Args, Errors,
  Reals;

CONST
  DefWbConsole = "CON:40/12/480/150/Oberon-A StdIO Window";
  maxD = 9;

VAR
  WbConsole  : Dos.FileHandlePtr;
  OldCleanup : PROCEDURE (rc : LONGINT);

(*------------------------------------*)
PROCEDURE Write* (ch : CHAR);

BEGIN (* Write *)
  SYS.PUTREG (0, Dos.Base.Write (Dos.Base.Output(), ch, 1))
END Write;

(*------------------------------------*)
PROCEDURE WriteLn*;

BEGIN (* WriteLn *)
  Write (0AX)
END WriteLn;

(*------------------------------------*)
(* $D- Disables copying of dynamic array parameters. *)
PROCEDURE WriteStr* (s : ARRAY OF CHAR);

BEGIN (* WriteStr *)
  SYS.PUTREG (0, Dos.Base.Write (Dos.Base.Output (), s, SYS.STRLEN (s)))
END WriteStr;

(*------------------------------------*)
PROCEDURE* PutCh ();

BEGIN (* PutCh *)
  SYS.INLINE (16C0H)   (* MOVE.B D0,(A3)+ *)
END PutCh;

(*------------------------------------*)
PROCEDURE WriteInt* (i : LONGINT);

  VAR
    str : ARRAY 256 OF CHAR;

BEGIN (* WriteInt *)
  Exec.Base.RawDoFmt ("%ld", i, PutCh, str);
  WriteStr (str)
END WriteInt;

(*------------------------------------*)
PROCEDURE WriteHex* (i : LONGINT);

  VAR
    str : ARRAY 256 OF CHAR;

BEGIN (* WriteHex *)
  Exec.Base.RawDoFmt ("%lx", i, PutCh, str);
  WriteStr (str)
END WriteHex;

(*
 * The following WriteReal* and WriteLongReal* procedures have been pinched
 * from Module Texts and have been somewhat modified from the original code
 * described in "Project Oberon".
 *)

(*------------------------------------*)
PROCEDURE WriteReal * ( x : REAL; n : INTEGER );

  VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;

BEGIN (* WriteReal *)
  (*
   * This implementation uses Motorola FFP format reals instead of IEEE
   * single-precision reals.  The Project Oberon code has been modified to
   * remove the special-case handling of unnormal and NaN values and assume
   * 7-bit exponents instead of 8-bit.
   *)
  e := Reals.Expo (x);
  IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  REPEAT Write (" "); DEC (n) UNTIL n <= 8;
  (* there are 2 < n <= 8 digits to be written *)
  IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  e := (e - 64) * 77 DIV 256;
  IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  Reals.Convert (x, n, d);
  DEC (n); Write (d [n]); Write (".");
  REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  Write ("E");
  IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
END WriteReal;

(*------------------------------------*)
PROCEDURE WriteRealFix * ( x : REAL; n, k : INTEGER );

  VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;

  (*------------------------------------*)
  PROCEDURE seq ( ch : CHAR; n : LONGINT );

  BEGIN (* seq *)
    WHILE n > 0 DO Write (ch); DEC (n) END
  END seq;

  (*------------------------------------*)
  PROCEDURE dig (n : INTEGER);

  BEGIN (* dig *)
    WHILE n > 0 DO
      DEC (i); Write (d [i]); DEC (n)
    END;
  END dig;

BEGIN (* WriteRealFix *)
  (*
   * This implementation uses Motorola FFP format reals instead of IEEE
   * single-precision reals.  The Project Oberon code has been modified to
   * remove the special-case handling of unnormal and NaN values and assume
   * 7-bit exponents instead of 8-bit.
   *)
  IF k < 0 THEN k := 0 END;
  e := (Reals.Expo (x) - 64) * 77 DIV 256;
  IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  (* 1 <= x < 10 *)
  IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  ELSIF k + e < 0 THEN k := -e; x := 0.0
  END;
  x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  IF x >= 10.0 * x0 THEN INC (e) END;
  (* e = no. of digits before decimal point *)
  INC (e); i := k + e; Reals.Convert (x, i, d);
  IF e > 0 THEN
    seq (" ", n - e - k - 2); Write (sign); dig (e); Write (".");
    dig (k)
  ELSE
    seq (" ", n - k - 3); Write (sign); Write ("0"); Write (".");
    seq ("0", -e); dig (k + e)
  END; (* ELSE *)
END WriteRealFix;

(*------------------------------------*)
PROCEDURE WriteRealHex * ( x : REAL );

  VAR d : ARRAY 9 OF CHAR;

BEGIN (* WriteRealHex *)
  Reals.ConvertH (x, d); d [8] := 0X; WriteStr (d)
END WriteRealHex;

(*------------------------------------*)
PROCEDURE WriteLongReal * ( x : LONGREAL; n : INTEGER );

BEGIN (* WriteLongReal *)
  (*
   * In this implementation, LONGREAL and REAL types are the same, so this
   * procedure is implemented as a call to WriteReal ().
   *)
  WriteReal (SHORT (x), n)
END WriteLongReal;

(*------------------------------------*)
PROCEDURE WriteLongRealHex * ( x : LONGREAL );

BEGIN (* WriteLongRealHex *)
  (*
   * In this implementation, LONGREAL and REAL types are the same, so this
   * procedure is implemented as a call to WriteRealHex ().
   *)
  WriteRealHex (SHORT (x))
END WriteLongRealHex;

(*------------------------------------*)
(* $D- Disables copying of dynamic array parameters. *)
PROCEDURE WriteF* (
  fs : ARRAY OF CHAR; VAR f : ARRAY OF SYS.LONGWORD);

  VAR
    str : ARRAY 256 OF CHAR;

BEGIN (* WriteF *)
  Exec.Base.RawDoFmt (fs, f, PutCh, str);
  WriteStr (str)
END WriteF;

(*------------------------------------*)
(* $D- Disables copying of dynamic array parameters. *)
PROCEDURE WriteF1*
  ( fs     : ARRAY OF CHAR;
    param1 : SYS.LONGWORD);

  VAR str : ARRAY 256 OF CHAR;

BEGIN (* WriteF1 *)
  Exec.Base.RawDoFmt (fs, param1, PutCh, str);
  WriteStr (str)
END WriteF1;

(*------------------------------------*)
(* $D- Disables copying of dynamic array parameters. *)
PROCEDURE WriteF2* (
  fs : ARRAY OF CHAR; param1, param2 : SYS.LONGWORD);

  VAR str : ARRAY 256 OF CHAR;
      t : SYS.LONGWORD;

BEGIN (* WriteF2 *)
  t := param1; param1 := param2; param2 := t;
  Exec.Base.RawDoFmt (fs, param2, PutCh, str);
  WriteStr (str)
END WriteF2;

(*------------------------------------*)
(* $D- Disables copying of dynamic array parameters. *)
PROCEDURE WriteF3* (
  fs : ARRAY OF CHAR; param1, param2, param3 : SYS.LONGWORD);

  VAR str : ARRAY 256 OF CHAR;
      t : SYS.LONGWORD;

BEGIN (* WriteF3 *)
  t := param1; param1 := param3; param3 := t;
  Exec.Base.RawDoFmt (fs, param3, PutCh, str);
  WriteStr (str)
END WriteF3;

(*------------------------------------*)
PROCEDURE Read* (VAR ch : CHAR);

BEGIN (* Read *)
  IF Dos.Base.Read (Dos.Base.Input (), ch, 1) < 1 THEN ch := 0X END;
END Read;

(*------------------------------------*)
PROCEDURE ReadStr* (VAR str : ARRAY OF CHAR);

  VAR ch : CHAR; index, limit : INTEGER;

BEGIN (* ReadStr *)
  (* Skip white space *)
  REPEAT Read (ch) UNTIL (ch # " ") & (ch # 09X);
  (* Read until control char *)
  index := 0; limit := SHORT (LEN (str));
  WHILE (ch >= " ") & (index < limit) DO
    str [index] := ch; INC (index); Read (ch);
  END; (* WHILE *)
  str [index] := 0X;
  (* Skip rest of line if any *)
  WHILE ch >= " " DO Read (ch) END;
END ReadStr;

(* $L- Access global variables through A4 *)
(*------------------------------------*)
PROCEDURE* CloseWbConsole (rc : LONGINT);

BEGIN (* CloseWbConsole *)
  IF WbConsole # NIL THEN Dos.Base.OldClose (WbConsole) END;
  IF OldCleanup # NIL THEN OldCleanup (rc) END
END CloseWbConsole;

(*------------------------------------*)
PROCEDURE SetupWbConsole ();

  VAR
    oldDir    : Dos.FileLockPtr;
    console   : T.STRPTR;
    diskObj   : WB.DiskObjectPtr;
    toolTypes : WB.ToolTypePtr;
    process   : Dos.ProcessPtr;
    conTask   : Exec.MsgPortPtr;

BEGIN (* SetupWbConsole *)
  (* Make sure icon.library is open *)
  Icon.OpenLib ();

  (* First CD to the app's directory *)
  oldDir := Dos.Base.CurrentDir (Args.ArgList [0].waLock);
  (* Attempt to load the app's icon *)
  diskObj := Icon.Base.GetDiskObject (Args.ArgList [0].waName);
  IF diskObj # NIL THEN
    (* Look for a "WINDOW=" tooltype *)
    console := Icon.Base.FindToolType (diskObj.doToolTypes^, "WINDOW");
    (*
     *  We will free diskObj AFTER we have finished with console.  Guess
     *  who got it wrong? :-)
     *)
  END; (* IF *)
  (* Back to where we started *)
  oldDir := Dos.Base.CurrentDir (oldDir);

  (* Open the console window *)
  IF console = NIL THEN console := SYS.ADR (DefWbConsole) END;
  WbConsole := Dos.Base.Open (console^, Dos.modeNewFile);
  IF diskObj # NIL THEN Icon.Base.FreeDiskObject (diskObj) END;
  Errors.Assert (WbConsole # NIL, "Could not open StdIO window");

  (*
   *  Set the console task (so Input(), Output() & Open("*", mode) will
   *  work).  This is from Commodore's startup.asm.
   *)
  process := SYS.VAL (Dos.ProcessPtr, Exec.Base.FindTask (NIL));
  process.prCIS := WbConsole;
  process.prCOS := WbConsole;
  conTask := WbConsole.fhType;
  IF conTask # NIL THEN process.prConsoleTask := conTask END;

  SYS.SETCLEANUP (CloseWbConsole, OldCleanup);
END SetupWbConsole;

BEGIN
  IF ~Args.IsCLI THEN SetupWbConsole () END
END StdIO.

(***************************************************************************

  $Log: StdIO.mod $
  Revision 1.2  1994/05/12  20:08:14  fjc
  - Prepared for release

  Revision 1.1  1994/01/15  21:39:12  fjc
  - Start of revision control

***************************************************************************)