home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / useful / dev / obero / oberon-a / source / library / stdio.mod < prev    next >
Encoding:
Text File  |  1994-09-03  |  8.4 KB  |  314 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: StdIO.mod $
  4.   Description: Simple formatted I/O using the standard input and output
  5.                handles.
  6.  
  7.    Created by: fjc (Frank Copeland)
  8.     $Revision: 1.9 $
  9.       $Author: fjc $
  10.         $Date: 1994/09/03 16:18:21 $
  11.  
  12.   Copyright © 1994, Frank Copeland.
  13.   This file is part of the Oberon-A Library.
  14.   See Oberon-A.doc for conditions of use and distribution.
  15.  
  16. ***************************************************************************)
  17.  
  18. MODULE StdIO;
  19.  
  20. (*
  21. ** $C= CaseChk       $I= IndexChk  $L+ LongAdr   $N- NilChk
  22. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  23. ** $V= OvflChk       $Z= ZeroVars
  24. *)
  25.  
  26. IMPORT
  27.   SYS := SYSTEM, Exec, Dos, WB := Workbench, Reals, WbConsole;
  28.  
  29. VAR
  30.   enableBreak * : BOOLEAN;
  31.  
  32. CONST
  33.   maxD = 9;
  34.  
  35. (*------------------------------------*)
  36. PROCEDURE^ CheckBreak ();
  37.  
  38. (*------------------------------------*)
  39. PROCEDURE Write* (ch : CHAR);
  40.  
  41. BEGIN (* Write *)
  42.   CheckBreak ();
  43.   SYS.PUTREG (0, Dos.base.Write (Dos.base.Output(), ch, 1))
  44. END Write;
  45.  
  46. (*------------------------------------*)
  47. PROCEDURE WriteLn*;
  48.  
  49. BEGIN (* WriteLn *)
  50.   Write (0AX)
  51. END WriteLn;
  52.  
  53. (*------------------------------------*)
  54. PROCEDURE WriteStr* (s : ARRAY OF CHAR);
  55.  
  56. (* $D- Disables copying of dynamic array parameters. *)
  57. BEGIN (* WriteStr *)
  58.   CheckBreak ();
  59.   SYS.PUTREG (0, Dos.base.Write (Dos.base.Output (), s, SYS.STRLEN (s)))
  60. END WriteStr;
  61.  
  62. (*
  63. ** $S- Disable compiler stack checking.
  64. **
  65. ** CheckBreak() is always called from within a procedure which has already
  66. ** done it, and PutCh() won't work with it on.
  67. *)
  68.  
  69. (*------------------------------------*)
  70. PROCEDURE CheckBreak ();
  71.  
  72.   VAR signals : SET;
  73.  
  74. BEGIN (* CheckBreak *)
  75.   IF enableBreak THEN
  76.     signals := Exec.base.SetSignal ({}, {});
  77.     IF Dos.sigBreakCtrlC IN signals THEN
  78.       enableBreak := FALSE;
  79.       WriteStr ("\n***BREAK -- User aborted\n");
  80.       HALT (Dos.returnWarn)
  81.     END
  82.   END
  83. END CheckBreak;
  84.  
  85. (*------------------------------------*)
  86. PROCEDURE* PutCh ();
  87.  
  88. BEGIN (* PutCh *)
  89.   SYS.INLINE (16C0H)   (* MOVE.B D0,(A3)+ *)
  90. END PutCh;
  91. (* $S= Enable compiler stack checking *)
  92.  
  93. (*------------------------------------*)
  94. PROCEDURE WriteInt* (i : LONGINT);
  95.  
  96.   VAR
  97.     str : ARRAY 256 OF CHAR;
  98.  
  99. BEGIN (* WriteInt *)
  100.   Exec.base.OldRawDoFmtL ("%ld", i, PutCh, SYS.ADR (str));
  101.   WriteStr (str)
  102. END WriteInt;
  103.  
  104. (*------------------------------------*)
  105. PROCEDURE WriteHex* (i : LONGINT);
  106.  
  107.   VAR
  108.     str : ARRAY 256 OF CHAR;
  109.  
  110. BEGIN (* WriteHex *)
  111.   Exec.base.OldRawDoFmtL ("%lx", i, PutCh, SYS.ADR (str));
  112.   WriteStr (str)
  113. END WriteHex;
  114.  
  115. (*
  116.  * The following WriteReal* and WriteLongReal* procedures have been pinched
  117.  * from Module Texts and have been somewhat modified from the original code
  118.  * described in "Project Oberon".
  119.  *)
  120.  
  121. (*------------------------------------*)
  122. PROCEDURE WriteReal * ( x : REAL; n : INTEGER );
  123.  
  124.   VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;
  125.  
  126. BEGIN (* WriteReal *)
  127.   (*
  128.    * This implementation uses Motorola FFP format reals instead of IEEE
  129.    * single-precision reals.  The Project Oberon code has been modified to
  130.    * remove the special-case handling of unnormal and NaN values and assume
  131.    * 7-bit exponents instead of 8-bit.
  132.    *)
  133.   e := Reals.Expo (x);
  134.   IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  135.   REPEAT Write (" "); DEC (n) UNTIL n <= 8;
  136.   (* there are 2 < n <= 8 digits to be written *)
  137.   IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  138.   e := (e - 64) * 77 DIV 256;
  139.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  140.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  141.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  142.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  143.   Reals.Convert (x, n, d);
  144.   DEC (n); Write (d [n]); Write (".");
  145.   REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  146.   Write ("E");
  147.   IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  148.   Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
  149. END WriteReal;
  150.  
  151. (*------------------------------------*)
  152. PROCEDURE WriteRealFix * ( x : REAL; n, k : INTEGER );
  153.  
  154.   VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;
  155.  
  156.   (*------------------------------------*)
  157.   PROCEDURE seq ( ch : CHAR; n : LONGINT );
  158.  
  159.   BEGIN (* seq *)
  160.     WHILE n > 0 DO Write (ch); DEC (n) END
  161.   END seq;
  162.  
  163.   (*------------------------------------*)
  164.   PROCEDURE dig (n : INTEGER);
  165.  
  166.   BEGIN (* dig *)
  167.     WHILE n > 0 DO
  168.       DEC (i); Write (d [i]); DEC (n)
  169.     END;
  170.   END dig;
  171.  
  172. BEGIN (* WriteRealFix *)
  173.   (*
  174.    * This implementation uses Motorola FFP format reals instead of IEEE
  175.    * single-precision reals.  The Project Oberon code has been modified to
  176.    * remove the special-case handling of unnormal and NaN values and assume
  177.    * 7-bit exponents instead of 8-bit.
  178.    *)
  179.   IF k < 0 THEN k := 0 END;
  180.   e := (Reals.Expo (x) - 64) * 77 DIV 256;
  181.   IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  182.   IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  183.   ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  184.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  185.   (* 1 <= x < 10 *)
  186.   IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  187.   ELSIF k + e < 0 THEN k := -e; x := 0.0
  188.   END;
  189.   x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  190.   IF x >= 10.0 * x0 THEN INC (e) END;
  191.   (* e = no. of digits before decimal point *)
  192.   INC (e); i := k + e; Reals.Convert (x, i, d);
  193.   IF e > 0 THEN
  194.     seq (" ", n - e - k - 2); Write (sign); dig (e); Write (".");
  195.     dig (k)
  196.   ELSE
  197.     seq (" ", n - k - 3); Write (sign); Write ("0"); Write (".");
  198.     seq ("0", -e); dig (k + e)
  199.   END; (* ELSE *)
  200. END WriteRealFix;
  201.  
  202. (*------------------------------------*)
  203. PROCEDURE WriteRealHex * ( x : REAL );
  204.  
  205.   VAR d : ARRAY 9 OF CHAR;
  206.  
  207. BEGIN (* WriteRealHex *)
  208.   Reals.ConvertH (x, d); d [8] := 0X; WriteStr (d)
  209. END WriteRealHex;
  210.  
  211. (*------------------------------------*)
  212. PROCEDURE WriteLongReal * ( x : LONGREAL; n : INTEGER );
  213.  
  214. BEGIN (* WriteLongReal *)
  215.   (*
  216.    * In this implementation, LONGREAL and REAL types are the same, so this
  217.    * procedure is implemented as a call to WriteReal ().
  218.    *)
  219.   WriteReal (SHORT (x), n)
  220. END WriteLongReal;
  221.  
  222. (*------------------------------------*)
  223. PROCEDURE WriteLongRealHex * ( x : LONGREAL );
  224.  
  225. BEGIN (* WriteLongRealHex *)
  226.   (*
  227.    * In this implementation, LONGREAL and REAL types are the same, so this
  228.    * procedure is implemented as a call to WriteRealHex ().
  229.    *)
  230.   WriteRealHex (SHORT (x))
  231. END WriteLongRealHex;
  232.  
  233. (*------------------------------------*)
  234. (* $D- Disables copying of dynamic array parameters. *)
  235. PROCEDURE WriteF* (
  236.   fs : ARRAY OF CHAR; VAR f : ARRAY OF SYS.LONGWORD);
  237.  
  238.   VAR
  239.     str : ARRAY 256 OF CHAR;
  240.  
  241. BEGIN (* WriteF *)
  242.   Exec.base.OldRawDoFmtL (fs, f, PutCh, SYS.ADR (str));
  243.   WriteStr (str)
  244. END WriteF;
  245.  
  246. (*------------------------------------*)
  247. (* $D- Disables copying of dynamic array parameters. *)
  248. PROCEDURE WriteF1*
  249.   ( fs     : ARRAY OF CHAR;
  250.     param1 : SYS.LONGWORD);
  251.  
  252.   VAR str : ARRAY 256 OF CHAR;
  253.  
  254. BEGIN (* WriteF1 *)
  255.   Exec.base.OldRawDoFmtL (fs, param1, PutCh, SYS.ADR (str));
  256.   WriteStr (str)
  257. END WriteF1;
  258.  
  259. (*------------------------------------*)
  260. (* $D- Disables copying of dynamic array parameters. *)
  261. PROCEDURE WriteF2* (
  262.   fs : ARRAY OF CHAR; param1, param2 : SYS.LONGWORD);
  263.  
  264.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  265.  
  266. BEGIN (* WriteF2 *)
  267.   t := param1; param1 := param2; param2 := t;
  268.   Exec.base.OldRawDoFmtL (fs, param2, PutCh, SYS.ADR (str));
  269.   WriteStr (str)
  270. END WriteF2;
  271.  
  272. (*------------------------------------*)
  273. (* $D- Disables copying of dynamic array parameters. *)
  274. PROCEDURE WriteF3* (
  275.   fs : ARRAY OF CHAR; param1, param2, param3 : SYS.LONGWORD);
  276.  
  277.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  278.  
  279. BEGIN (* WriteF3 *)
  280.   t := param1; param1 := param3; param3 := t;
  281.   Exec.base.OldRawDoFmtL (fs, param3, PutCh, SYS.ADR (str));
  282.   WriteStr (str)
  283. END WriteF3;
  284.  
  285. (*------------------------------------*)
  286. PROCEDURE Read* (VAR ch : CHAR);
  287.  
  288. BEGIN (* Read *)
  289.   CheckBreak ();
  290.   IF Dos.base.Read (Dos.base.Input (), ch, 1) < 1 THEN ch := 0X END;
  291. END Read;
  292.  
  293. (*------------------------------------*)
  294. PROCEDURE ReadStr* (VAR str : ARRAY OF CHAR);
  295.  
  296.   VAR ch : CHAR; index, limit : INTEGER;
  297.  
  298. BEGIN (* ReadStr *)
  299.   (* Skip white space *)
  300.   REPEAT Read (ch) UNTIL (ch # " ") & (ch # 09X);
  301.   (* Read until control char *)
  302.   index := 0; limit := SHORT (LEN (str));
  303.   WHILE (ch >= " ") & (index < limit) DO
  304.     str [index] := ch; INC (index); Read (ch);
  305.   END; (* WHILE *)
  306.   str [index] := 0X;
  307.   (* Skip rest of line if any *)
  308.   WHILE ch >= " " DO Read (ch) END;
  309. END ReadStr;
  310.  
  311. BEGIN
  312.   enableBreak := TRUE;
  313. END StdIO.
  314.