Streams.Mod 37 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174
  1. (* Aos, Copyright 2001, Pieter Muller, ETH Zurich *)
  2. MODULE Streams; (** AUTHOR "pjm/be"; PURPOSE "I/O buffering and formatted writing and reading"; *)
  3. IMPORT SYSTEM;
  4. CONST
  5. Ok* = 0; (** zero result code means no error occurred *)
  6. EOF* = 4201; (** error returned when Receive reads past end of file or stream *)
  7. EOT* = 1AX; (** EOT character *)
  8. StringFull = 4202;
  9. FormatError* = 4203; (** error returned when ReadInt fails *)
  10. DefaultWriterSize* = 4096;
  11. DefaultReaderSize* = 4096;
  12. Invalid* = -1; (** invalid stream position *)
  13. CONST
  14. CR = 0DX; LF = 0AX; TAB = 9X; SP = 20X;
  15. VAR
  16. H, L: INTEGER;
  17. TYPE
  18. TSize* = LONGINT;
  19. TYPE
  20. Position* = LONGINT;
  21. (** Any stream output procedure or method. *)
  22. Sender* = PROCEDURE {DELEGATE} ( CONST buf: ARRAY OF CHAR; ofs, len: LONGINT; propagate: BOOLEAN; VAR res: WORD );
  23. (** Any stream input procedure or method. *)
  24. Receiver* = PROCEDURE {DELEGATE} ( VAR buf: ARRAY OF CHAR; ofs, size, min: LONGINT; VAR len, res: LONGINT );
  25. Connection* = OBJECT
  26. PROCEDURE Send*( CONST data: ARRAY OF CHAR; ofs, len: LONGINT; propagate: BOOLEAN; VAR res: WORD );
  27. END Send;
  28. PROCEDURE Receive*( VAR data: ARRAY OF CHAR; ofs, size, min: LONGINT; VAR len, res: LONGINT );
  29. END Receive;
  30. PROCEDURE Close*;
  31. END Close;
  32. END Connection;
  33. TYPE
  34. (** A writer buffers output before it is sent to a Sender. Must not be shared between processes. *)
  35. Writer* = OBJECT
  36. VAR
  37. tail: LONGINT;
  38. buf: POINTER TO ARRAY OF CHAR;
  39. res*: LONGINT; (** result of last output operation. *)
  40. send: Sender;
  41. sent*: LONGINT; (** count of sent bytes *)
  42. (* buf[0..tail-1] contains data to write. *)
  43. PROCEDURE & InitWriter*( send: Sender; size: LONGINT );
  44. BEGIN
  45. ASSERT ( send # NIL );
  46. IF (buf = NIL) OR (LEN(buf) # size) THEN
  47. NEW( buf, size );
  48. END;
  49. SELF.send := send; Reset
  50. END InitWriter;
  51. PROCEDURE Reset*;
  52. BEGIN
  53. tail := 0; res := Ok; sent := 0
  54. END Reset;
  55. PROCEDURE CanSetPos*( ): BOOLEAN;
  56. BEGIN
  57. RETURN FALSE
  58. END CanSetPos;
  59. PROCEDURE SetPos*( pos: Position );
  60. BEGIN
  61. HALT( 1234 )
  62. END SetPos;
  63. PROCEDURE Update*;
  64. BEGIN
  65. IF (res = Ok) THEN
  66. send( buf^, 0, tail, TRUE , res );
  67. IF res = Ok THEN INC( sent, tail ); tail := 0 END
  68. END
  69. END Update;
  70. (** Current write position. *)
  71. PROCEDURE Pos*( ): Position;
  72. BEGIN
  73. RETURN sent + tail
  74. END Pos;
  75. (** -- Write raw binary data -- *)
  76. (** Write one byte. *)
  77. PROCEDURE Char*( x: CHAR );
  78. BEGIN
  79. IF (tail = LEN( buf )) & (res = Ok) THEN
  80. send( buf^, 0, tail, FALSE , res );
  81. IF res = Ok THEN INC( sent, tail ); tail := 0 END
  82. END;
  83. IF res = Ok THEN buf[tail] := x; INC( tail ) END
  84. END Char;
  85. (** Write len bytes from x, starting at ofs. *)
  86. PROCEDURE Bytes*(CONST x: ARRAY OF CHAR; ofs, len: LONGINT );
  87. VAR n: LONGINT;
  88. BEGIN
  89. ASSERT ( len >= 0 );
  90. LOOP
  91. n := LEN( buf ) - tail; (* space available *)
  92. IF n = 0 THEN
  93. IF res = Ok THEN (* send current buffer *)
  94. send( buf^, 0, tail, FALSE , res );
  95. IF res = Ok THEN INC( sent, tail ); tail := 0 ELSE EXIT END
  96. ELSE
  97. EXIT (* should not be writing on an erroneous rider *)
  98. END;
  99. n := LEN( buf )
  100. END;
  101. IF n > len THEN n := len END;
  102. ASSERT ( tail + n <= LEN( buf ) ); (* index check *)
  103. SYSTEM.MOVE( ADDRESSOF( x[ofs] ), ADDRESSOF( buf[tail] ), n ); INC( tail, n );
  104. IF len = n THEN EXIT END; (* done *)
  105. INC( ofs, n ); DEC( len, n )
  106. END
  107. END Bytes;
  108. (** Write a SHORTINT. *)
  109. PROCEDURE RawSInt*( x: SHORTINT );
  110. BEGIN
  111. Char( SYSTEM.VAL( CHAR, x ) )
  112. END RawSInt;
  113. (** Write an INTEGER. *)
  114. PROCEDURE RawInt*( x: INTEGER );
  115. BEGIN
  116. Bytes( SYSTEM.VAL( Bytes2, x ), 0, 2 )
  117. END RawInt;
  118. (** Write a LONGINT. *)
  119. PROCEDURE RawLInt*( x: LONGINT );
  120. BEGIN
  121. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4 )
  122. END RawLInt;
  123. (** Write a HUGEINT. *)
  124. PROCEDURE RawHInt*( x: HUGEINT );
  125. BEGIN
  126. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8 )
  127. END RawHInt;
  128. (** Write a 64 bit value in network byte order (most significant byte first) *)
  129. PROCEDURE Net64*( x: HUGEINT );
  130. BEGIN
  131. Net32(LONGINT( x DIV 100000000H MOD 100000000H ));
  132. Net32(LONGINT( x MOD 100000000H ));
  133. END Net64;
  134. (** Write a 32 bit value in network byte order (most significant byte first) *)
  135. PROCEDURE Net32*( x: LONGINT );
  136. BEGIN
  137. Char( CHR( x DIV 1000000H MOD 100H ) ); Char( CHR( x DIV 10000H MOD 100H ) ); Char( CHR( x DIV 100H MOD 100H ) );
  138. Char( CHR( x MOD 100H ) )
  139. END Net32;
  140. (** Write a 16 bit value in network byte order (most significant byte first) *)
  141. PROCEDURE Net16*( x: LONGINT );
  142. BEGIN
  143. Char( CHR( x DIV 100H MOD 100H ) ); Char( CHR( x MOD 100H ) )
  144. END Net16;
  145. (** write unsigned byte *)
  146. PROCEDURE Net8*( x: LONGINT );
  147. BEGIN
  148. Char( CHR( x MOD 100H ) )
  149. END Net8;
  150. (** Write a SET. *)
  151. PROCEDURE RawSet*( x: SET );
  152. BEGIN
  153. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4 )
  154. END RawSet;
  155. (** Write a BOOLEAN. *)
  156. PROCEDURE RawBool*( x: BOOLEAN );
  157. BEGIN
  158. IF x THEN Char( 1X ) ELSE Char( 0X ) END
  159. END RawBool;
  160. (** Write a REAL. *)
  161. PROCEDURE RawReal*( x: REAL );
  162. BEGIN
  163. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4 )
  164. END RawReal;
  165. (** Write a LONGREAL. *)
  166. PROCEDURE RawLReal*( x: LONGREAL );
  167. BEGIN
  168. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8 )
  169. END RawLReal;
  170. (** Write a 0X-terminated string, including the 0X terminator. *)
  171. PROCEDURE RawString*(CONST x: ARRAY OF CHAR );
  172. VAR i: LONGINT;
  173. BEGIN
  174. i := 0;
  175. WHILE x[i] # 0X DO Char( x[i] ); INC( i ) END;
  176. Char( 0X )
  177. END RawString;
  178. (** Write a number in a compressed format. *)
  179. PROCEDURE RawNum*( x: LONGINT );
  180. BEGIN
  181. WHILE (x < -64) OR (x > 63) DO Char( CHR( x MOD 128 + 128 ) ); x := x DIV 128 END;
  182. Char( CHR( x MOD 128 ) )
  183. END RawNum;
  184. (** Write a size in a compressed format. *)
  185. PROCEDURE RawSize*( x: SIZE );
  186. BEGIN
  187. WHILE (x < -64) OR (x > 63) DO Char( CHR( x MOD 128 + 128 ) ); x := x DIV 128 END;
  188. Char( CHR( x MOD 128 ) )
  189. END RawSize;
  190. (** -- Write formatted data -- *)
  191. (** Write an ASCII end-of-line (CR/LF). *)
  192. PROCEDURE Ln*;
  193. BEGIN
  194. Char( CR ); Char( LF )
  195. END Ln;
  196. (** Write a 0X-terminated string, excluding the 0X terminator. *)
  197. PROCEDURE String*(CONST x: ARRAY OF CHAR );
  198. VAR i: LONGINT;
  199. BEGIN
  200. i := 0;
  201. WHILE x[i] # 0X DO Char( x[i] ); INC( i ) END
  202. END String;
  203. (** Write an integer in decimal right-justified in a field of at least w characters. *)
  204. PROCEDURE Int*( x: HUGEINT; w: SIZE );
  205. VAR i: SIZE; x0: HUGEINT;
  206. a: ARRAY 21 OF CHAR;
  207. BEGIN
  208. IF x < 0 THEN
  209. IF x = MIN( HUGEINT ) THEN
  210. DEC( w, 20 );
  211. WHILE w > 0 DO Char( " " ); DEC( w ) END;
  212. String( "-9223372036854775808" ); RETURN
  213. ELSE DEC( w ); x0 := -x
  214. END
  215. ELSE x0 := x
  216. END;
  217. i := 0;
  218. REPEAT a[i] := CHR( x0 MOD 10 + 30H ); x0 := x0 DIV 10; INC( i ) UNTIL x0 = 0;
  219. WHILE w > i DO Char( " " ); DEC( w ) END;
  220. IF x < 0 THEN Char( "-" ) END;
  221. REPEAT DEC( i ); Char( a[i] ) UNTIL i = 0
  222. END Int;
  223. (** Write a SET in Oberon notation. *)
  224. (* PROCEDURE Set*( s: SET ); (* from P. Saladin *)
  225. VAR i, last: LONGINT; dots: BOOLEAN;
  226. BEGIN
  227. Char( "{" ); last := MIN( LONGINT ); dots := FALSE;
  228. FOR i := MIN( SET ) TO MAX( SET ) DO
  229. IF i IN s THEN
  230. IF last = (i - 1) THEN
  231. IF dots THEN String( ".." ); dots := FALSE END;
  232. IF (i = MAX( SET )) OR ~((i + 1) IN s) THEN Int( i, 1 ) END
  233. ELSE
  234. IF last >= MIN( SET ) THEN String( ", " ) END;
  235. Int( i, 1 ); dots := TRUE
  236. END;
  237. last := i
  238. END
  239. END;
  240. Char( "}" )
  241. END Set; *)
  242. PROCEDURE Set*( s: SET ); (* from P. Saladin *)
  243. VAR i, last: LONGINT; dots: BOOLEAN;
  244. BEGIN
  245. Char( "{" ); last := MAX( LONGINT ); dots := FALSE;
  246. FOR i := MAX( SET ) TO 0 BY -1 DO
  247. IF i IN s THEN
  248. IF last = (i + 1) THEN
  249. IF dots THEN String( ".." ); dots := FALSE END;
  250. IF (i = 0) OR ~((i - 1) IN s) THEN Int( i, 1 ) END
  251. ELSE
  252. IF last <= MAX( SET ) THEN String( ", " ) END;
  253. Int( i, 1 ); dots := TRUE
  254. END;
  255. last := i
  256. END
  257. END;
  258. Char( "}" )
  259. END Set;
  260. (**
  261. Write an integer in hexadecimal right-justified in a field of at least ABS(w) characters.
  262. If w < 0 THEN w least significant hex digits of x are written (potentially including leading zeros)
  263. *)
  264. PROCEDURE Hex*(x: HUGEINT; w: SIZE);
  265. VAR filler: CHAR; i,maxw: SIZE; a: ARRAY 20 OF CHAR; y: HUGEINT;
  266. BEGIN
  267. IF w < 0 THEN filler := '0'; w := -w; maxw := w ELSE filler := ' '; maxw := 16 END;
  268. i := 0;
  269. REPEAT
  270. y := x MOD 10H;
  271. IF y < 10 THEN a[i] := CHR(y+ORD('0')) ELSE a[i] := CHR(y-10+ORD('A')) END;
  272. x := x DIV 10H;
  273. INC(i);
  274. UNTIL (x=0) OR (i=maxw);
  275. WHILE w > i DO Char(filler); DEC( w ) END;
  276. REPEAT DEC( i ); Char( a[i] ) UNTIL i = 0
  277. END Hex;
  278. (** Write "x" as a hexadecimal address. Do not use Hex because of arithmetic shift of the sign !*)
  279. PROCEDURE Address* (x: ADDRESS);
  280. BEGIN
  281. Hex(x,-2*SIZEOF(ADDRESS));
  282. END Address;
  283. PROCEDURE Pair( ch: CHAR; x: LONGINT );
  284. BEGIN
  285. IF ch # 0X THEN Char( ch ) END;
  286. Char( CHR( ORD( "0" ) + x DIV 10 MOD 10 ) ); Char( CHR( ORD( "0" ) + x MOD 10 ) )
  287. END Pair;
  288. (** Write the date and time in ISO format (yyyy-mm-dd hh:mm:ss). The t and d parameters are in Oberon time and date format.
  289. If all parameters are within range, the output string is exactly 19 characters wide. The t or d parameter can be -1, in which
  290. case the time or date respectively are left out. *)
  291. PROCEDURE Date*( t, d: LONGINT );
  292. VAR ch: CHAR;
  293. BEGIN
  294. IF d # -1 THEN
  295. Int( 1900 + d DIV 512, 4 ); (* year *)
  296. Pair( "-", d DIV 32 MOD 16 ); (* month *)
  297. Pair( "-", d MOD 32 ); (* day *)
  298. ch := " " (* space between date and time *)
  299. ELSE
  300. ch := 0X (* no space before time *)
  301. END;
  302. IF t # -1 THEN
  303. Pair( ch, t DIV 4096 MOD 32 ); (* hour *)
  304. Pair( ":", t DIV 64 MOD 64 ); (* min *)
  305. Pair( ":", t MOD 64 ) (* sec *)
  306. END
  307. END Date;
  308. (** Write the date and time in RFC 822/1123 format without the optional day of the week (dd mmm yyyy hh:mm:ss SZZZZ) .
  309. The t and d parameters are in Oberon time and date format. The tz parameter specifies the time zone offset in minutes
  310. (from -720 to 720 in steps of 30). If all parameters are within range, the output string is exactly 26 characters wide.
  311. The t, d or tz parameter can be -1, in which case the time, date or timezone respectively are left out. *)
  312. PROCEDURE Date822*( t, d, tz: LONGINT );
  313. VAR i, m: LONGINT; ch: CHAR;
  314. BEGIN
  315. IF d # -1 THEN
  316. Int( d MOD 32, 2 ); (* day *)
  317. m := (d DIV 32 MOD 16 - 1) * 4; (* month *)
  318. FOR i := m TO m + 3 DO Char( months[i] ) END;
  319. Int( 1900 + d DIV 512, 5 ); (* year *)
  320. ch := " " (* space *)
  321. ELSE
  322. ch := 0X (* no space *)
  323. END;
  324. IF t # -1 THEN
  325. Pair( ch, t DIV 4096 MOD 32 ); (* hour *)
  326. Pair( ":", t DIV 64 MOD 64 ); (* min *)
  327. Pair( ":", t MOD 64 ); (* sec *)
  328. ch := " " (* space *)
  329. ELSE
  330. (* leave ch as before *)
  331. END;
  332. IF tz # -1 THEN
  333. IF ch # 0X THEN Char( ch ) END;
  334. IF tz >= 0 THEN Pair( "+", tz DIV 60 ) ELSE Pair( "-", (-tz) DIV 60 ) END;
  335. Pair( 0X, ABS( tz ) MOD 60 )
  336. END
  337. END Date822;
  338. (** Write LONGREAL x using n character positions. *)
  339. PROCEDURE Float*( x: LONGREAL; n: WORD );
  340. (* BM 1993.4.22. Do not simplify rounding! *)
  341. VAR e, h, l, i: LONGINT; z: LONGREAL;
  342. d: ARRAY 16 OF CHAR;
  343. BEGIN
  344. e := ExpoL( x );
  345. IF e = 2047 THEN
  346. WHILE n > 5 DO Char( " " ); DEC( n ) END;
  347. NaNCodeL( x, h, l );
  348. IF (h # 0) OR (l # 0) THEN String( " NaN" )
  349. ELSIF x < 0 THEN String(" -INF" )
  350. ELSE String(" INF" )
  351. END
  352. ELSE
  353. IF n <= 9 THEN n := 1 ELSE DEC( n, 8 ) END;
  354. REPEAT Char( " " ); DEC( n ) UNTIL n <= 15; (* 0 <= n <= 15 fraction digits *)
  355. IF (e # 0) & (x < 0) THEN Char( "-" ); x := -x ELSE Char( " " ) END;
  356. IF e = 0 THEN
  357. h := 0; l := 0 (* no denormals *)
  358. ELSE
  359. e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
  360. z := Ten( e + 1 );
  361. IF x >= z THEN x := x / z; INC( e ) ELSE x := x * Ten( -e ) END;
  362. IF x >= 10 THEN x := x * Ten( -1 ) + 0.5D0 / Ten( n ); INC( e )
  363. ELSE
  364. x := x + 0.5D0 / Ten( n );
  365. IF x >= 10 THEN x := x * Ten( -1 ); INC( e ) END
  366. END;
  367. x := x * Ten( 7 ); h := ENTIER( x ); x := (x - h) * Ten( 8 ); l := ENTIER( x )
  368. END;
  369. i := 15;
  370. WHILE i > 7 DO d[i] := CHR( l MOD 10 + ORD( "0" ) ); l := l DIV 10; DEC( i ) END;
  371. WHILE i >= 0 DO d[i] := CHR( h MOD 10 + ORD( "0" ) ); h := h DIV 10; DEC( i ) END;
  372. Char( d[0] ); Char( "." ); i := 1;
  373. WHILE i <= n DO Char( d[i] ); INC( i ) END;
  374. IF e < 0 THEN String( "E-" ); e := -e ELSE String( "E+" ) END;
  375. Char( CHR( e DIV 100 + ORD( "0" ) ) ); e := e MOD 100; Char( CHR( e DIV 10 + ORD( "0" ) ) ); Char( CHR( e MOD 10 + ORD( "0" ) ) )
  376. END
  377. END Float;
  378. (** Write LONGREAL x in a fixed point notation. n is the overall minimal length for the output field, f the number of fraction digits following the decimal point, D the fixed exponent (printed only when D # 0). *)
  379. PROCEDURE FloatFix*( x: LONGREAL; n, f, D: WORD );
  380. (* BM 1993.4.22. Do not simplify rounding! / JG formatting adjusted *)
  381. VAR e, h, l, i: LONGINT; r, z: LONGREAL;
  382. d: ARRAY 16 OF CHAR;
  383. s: CHAR; dot: BOOLEAN;
  384. BEGIN
  385. e := ExpoL( x );
  386. IF (e = 2047) OR (ABS( D ) > 308) THEN
  387. WHILE n > 5 DO Char( " " ); DEC( n ) END;
  388. NaNCodeL( x, h, l );
  389. IF (h # 0) OR (l # 0) THEN String( " NaN" )
  390. ELSIF x < 0 THEN String( " -INF" )
  391. ELSE String( " INF" )
  392. END
  393. ELSE
  394. IF D = 0 THEN IF (f=0) THEN dot := FALSE; DEC( n, 1 ) ELSE dot := TRUE; DEC(n,2); END; ELSE dot := TRUE; DEC( n, 7 ) END;
  395. IF n < 2 THEN n := 2 END;
  396. IF f < 0 THEN f := 0 END;
  397. IF n < f + 2 THEN n := f + 2 END;
  398. DEC( n, f );
  399. IF (e # 0) & (x < 0) THEN s := "-"; x := -x ELSE s := " " END;
  400. IF e = 0 THEN
  401. h := 0; l := 0; DEC( e, D - 1 ) (* no denormals *)
  402. ELSE
  403. e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
  404. z := Ten( e + 1 );
  405. IF x >= z THEN x := x / z; INC( e ) ELSE x := x * Ten( -e ) END;
  406. DEC( e, D - 1 ); i := -(e + f);
  407. IF i <= 0 THEN r := 5 * Ten( i ) ELSE r := 0 END;
  408. IF x >= 10 THEN x := x * Ten( -1 ) + r; INC( e )
  409. ELSE
  410. x := x + r;
  411. IF x >= 10 THEN x := x * Ten( -1 ); INC( e ) END
  412. END;
  413. x := x * Ten( 7 ); h := ENTIER( x ); x := (x - h) * Ten( 8 ); l := ENTIER( x )
  414. END;
  415. i := 15;
  416. WHILE i > 7 DO d[i] := CHR( l MOD 10 + ORD( "0" ) ); l := l DIV 10; DEC( i ) END;
  417. WHILE i >= 0 DO d[i] := CHR( h MOD 10 + ORD( "0" ) ); h := h DIV 10; DEC( i ) END;
  418. IF n <= e THEN n := e + 1 END;
  419. IF e > 0 THEN
  420. WHILE n > e DO Char( " " ); DEC( n ) END;
  421. Char( s ); e := 0;
  422. WHILE n > 0 DO
  423. DEC( n );
  424. IF e < 16 THEN Char( d[e] ); INC( e ) ELSE Char( "0" ) END
  425. END;
  426. IF dot THEN
  427. Char( "." )
  428. END;
  429. ELSE
  430. WHILE n > 1 DO Char( " " ); DEC( n ) END;
  431. Char( s ); Char( "0" ); IF dot THEN Char( "." ); END;
  432. WHILE (0 < f) & (e < 0) DO Char( "0" ); DEC( f ); INC( e ) END
  433. END;
  434. WHILE f > 0 DO
  435. DEC( f );
  436. IF e < 16 THEN Char( d[e] ); INC( e ) ELSE Char( "0" ) END
  437. END;
  438. IF D # 0 THEN
  439. IF D < 0 THEN String( "E-" ); D := -D ELSE String( "E+" ) END;
  440. Char( CHR( D DIV 100 + ORD( "0" ) ) ); D := D MOD 100; Char( CHR( D DIV 10 + ORD( "0" ) ) ); Char( CHR( D MOD 10 + ORD( "0" ) ) )
  441. END
  442. END
  443. END FloatFix;
  444. END Writer;
  445. (** A special writer that buffers output to be fetched by GetString or GetRawString. *)
  446. StringWriter* = OBJECT (Writer)
  447. PROCEDURE & InitStringWriter*( size: LONGINT );
  448. BEGIN
  449. InitWriter( Send, size )
  450. END InitStringWriter;
  451. PROCEDURE Send( CONST buf: ARRAY OF CHAR; ofs, len: LONGINT; propagate: BOOLEAN; VAR res: WORD );
  452. BEGIN
  453. res := StringFull
  454. END Send;
  455. PROCEDURE CanSetPos*( ): BOOLEAN;
  456. BEGIN
  457. RETURN TRUE;
  458. END CanSetPos;
  459. (* Set the position for the writer *)
  460. PROCEDURE SetPos*( pos: Position );
  461. BEGIN
  462. IF pos > LEN( buf ) THEN pos := LEN( buf ) END;
  463. tail := pos; sent := 0; res := Ok;
  464. END SetPos;
  465. PROCEDURE Update*;
  466. (* nothing to do *)
  467. END Update;
  468. (** Return the contents of the string writer (0X-terminated). *)
  469. PROCEDURE Get*( VAR s: ARRAY OF CHAR );
  470. VAR i, m: LONGINT;
  471. BEGIN
  472. m := LEN( s ) - 1; i := 0;
  473. WHILE (i # tail) & (i < m) DO s[i] := buf[i]; INC( i ) END;
  474. s[i] := 0X; tail := 0; res := Ok
  475. END Get;
  476. (** Return the contents of the string writer (not 0X-terminated). The len parameters returns the string length. *)
  477. PROCEDURE GetRaw*( VAR s: ARRAY OF CHAR; VAR len: LONGINT );
  478. VAR i, m: LONGINT;
  479. BEGIN
  480. m := LEN( s ); i := 0;
  481. WHILE (i # tail) & (i < m) DO s[i] := buf[i]; INC( i ) END;
  482. len := i; tail := 0; res := Ok
  483. END GetRaw;
  484. END StringWriter;
  485. TYPE
  486. (** A reader buffers input received from a Receiver. Must not be shared between processes. *)
  487. Reader* = OBJECT
  488. VAR
  489. head, tail: LONGINT;
  490. buf: POINTER TO ARRAY OF CHAR;
  491. res*: LONGINT; (** result of last input operation. *)
  492. receive: Receiver;
  493. received*: LONGINT; (** count of received bytes *)
  494. (* buf[buf.head..buf.tail-1] contains data to read. *)
  495. PROCEDURE & InitReader*( receive: Receiver; size: LONGINT );
  496. BEGIN
  497. ASSERT ( receive # NIL );
  498. IF (buf = NIL) OR (LEN(buf) # size) THEN
  499. NEW( buf, size );
  500. END;
  501. SELF.receive := receive; Reset
  502. END InitReader;
  503. (** reset the reader by dropping the bytes in the buffer, resetting the result code and setting received to 0.
  504. This is used by seekable extensions of the reader *)
  505. PROCEDURE Reset*;
  506. BEGIN
  507. head := 0; tail := 0; res := Ok; received := 0
  508. END Reset;
  509. PROCEDURE CanSetPos*( ): BOOLEAN;
  510. BEGIN
  511. RETURN FALSE
  512. END CanSetPos;
  513. PROCEDURE SetPos*( pos: Position );
  514. BEGIN
  515. HALT( 1234 )
  516. END SetPos;
  517. (** Return bytes currently available in input buffer. *)
  518. PROCEDURE Available*( ): LONGINT;
  519. VAR n: LONGINT;
  520. BEGIN
  521. IF (res = Ok) THEN
  522. IF (head = tail) THEN head := 0; receive( buf^, 0, LEN( buf ), 0, tail, res ); INC( received, tail );
  523. ELSIF (tail # LEN( buf )) THEN
  524. receive( buf^, tail, LEN( buf ) - tail, 0, n, res ); (* poll *)
  525. INC( tail, n ); INC( received, n )
  526. END;
  527. IF res = EOF THEN res := Ok END (* ignore EOF here *)
  528. END;
  529. RETURN tail - head
  530. END Available;
  531. (** Current read position. *)
  532. PROCEDURE Pos*( ): Position;
  533. BEGIN
  534. RETURN received - (tail - head)
  535. END Pos;
  536. (** -- Read raw binary data -- *)
  537. (** Read one byte. x=0X if no success (e.g. file ended) *)
  538. PROCEDURE Char*( VAR x: CHAR );
  539. BEGIN
  540. IF (head = tail) & (res = Ok) THEN head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail ) END;
  541. IF res = Ok THEN x := buf[head]; INC( head ) ELSE x := 0X END
  542. END Char;
  543. (** Like Read, but return result. Return 0X if no success (e.g. file ended) *)
  544. PROCEDURE Get*( ): CHAR;
  545. BEGIN
  546. IF (head = tail) & (res = Ok) THEN head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail ) END;
  547. IF res = Ok THEN INC( head ); RETURN buf[head - 1] ELSE RETURN 0X END
  548. END Get;
  549. (** Like Get, but leave the byte in the input buffer. *)
  550. PROCEDURE Peek*( ): CHAR;
  551. BEGIN
  552. IF (head = tail) & (res = Ok) THEN
  553. head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail );
  554. IF res = EOF THEN (* ignore EOF here *)
  555. res := Ok; tail := 0; RETURN 0X (* Peek returns 0X at eof *)
  556. END
  557. END;
  558. IF res = Ok THEN RETURN buf[head] ELSE RETURN 0X END
  559. END Peek;
  560. (** Read size bytes into x, starting at ofs. The len parameter returns the number of bytes that were actually read. *)
  561. PROCEDURE Bytes*( VAR x: ARRAY OF CHAR; ofs, size: LONGINT; VAR len: LONGINT );
  562. VAR n: LONGINT;
  563. BEGIN
  564. ASSERT ( size >= 0 );
  565. len := 0;
  566. LOOP
  567. n := tail - head; (* bytes available *)
  568. IF n = 0 THEN (* no data available *)
  569. head := 0;
  570. IF res = Ok THEN (* fill buffer *)
  571. receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail )
  572. END;
  573. IF res # Ok THEN (* should not be reading from erroneous rider *)
  574. WHILE size # 0 DO x[ofs] := 0X; INC( ofs ); DEC( size ) END; (* clear rest of buffer *)
  575. IF (res = EOF) & (len # 0) THEN res := Ok END; (* ignore EOF if some data being returned *)
  576. EXIT
  577. END;
  578. n := tail
  579. END;
  580. IF n > size THEN n := size END;
  581. ASSERT ( ofs + n <= LEN( x ) ); (* index check *)
  582. SYSTEM.MOVE( ADDRESSOF( buf[head] ), ADDRESSOF( x[ofs] ), n ); INC( head, n ); INC( len, n );
  583. IF size = n THEN EXIT END; (* done *)
  584. INC( ofs, n ); DEC( size, n )
  585. END
  586. END Bytes;
  587. (** Skip n bytes on the reader. *)
  588. PROCEDURE SkipBytes*( n: LONGINT );
  589. VAR ch: CHAR;
  590. BEGIN
  591. WHILE n > 0 DO ch := Get(); DEC( n ) END
  592. END SkipBytes;
  593. (** Read a SHORTINT. *)
  594. PROCEDURE RawSInt*( VAR x: SHORTINT );
  595. BEGIN
  596. x := SYSTEM.VAL( SHORTINT, Get() )
  597. END RawSInt;
  598. (** Read an INTEGER. *)
  599. PROCEDURE RawInt*( VAR x: INTEGER );
  600. VAR x0, x1: CHAR;
  601. BEGIN
  602. x0 := Get(); x1 := Get(); (* defined order *)
  603. x := ORD( x1 ) * 100H + ORD( x0 )
  604. END RawInt;
  605. (** Read a LONGINT. *)
  606. PROCEDURE RawLInt*( VAR x: LONGINT );
  607. VAR ignore: LONGINT;
  608. BEGIN
  609. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  610. END RawLInt;
  611. (** Read a HUGEINT. *)
  612. PROCEDURE RawHInt*( VAR x: HUGEINT );
  613. VAR ignore: LONGINT;
  614. BEGIN
  615. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8, ignore )
  616. END RawHInt;
  617. (** Read a 64 bit value in network byte order (most significant byte first) *)
  618. PROCEDURE Net64*( ): HUGEINT;
  619. BEGIN
  620. RETURN Net32() * 100000000H + Net32()
  621. END Net64;
  622. (** Read a 32 bit value in network byte order (most significant byte first) *)
  623. PROCEDURE Net32*( ): LONGINT;
  624. BEGIN
  625. RETURN LONG( ORD( Get() ) ) * 1000000H + LONG( ORD( Get() ) ) * 10000H + LONG( ORD( Get() ) ) * 100H + LONG( ORD( Get() ) )
  626. END Net32;
  627. (** Read an unsigned 16bit value in network byte order (most significant byte first) *)
  628. PROCEDURE Net16*( ): LONGINT;
  629. BEGIN
  630. RETURN LONG( ORD( Get() ) ) * 100H + LONG( ORD( Get() ) )
  631. END Net16;
  632. (** Read an unsigned byte *)
  633. PROCEDURE Net8*( ): LONGINT;
  634. BEGIN
  635. RETURN LONG( ORD( Get() ) )
  636. END Net8;
  637. (** Read a SET. *)
  638. PROCEDURE RawSet*( VAR x: SET );
  639. VAR ignore: LONGINT;
  640. BEGIN
  641. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  642. END RawSet;
  643. (** Read a BOOLEAN. *)
  644. PROCEDURE RawBool*( VAR x: BOOLEAN );
  645. BEGIN
  646. x := (Get() # 0X)
  647. END RawBool;
  648. (** Read a REAL. *)
  649. PROCEDURE RawReal*( VAR x: REAL );
  650. VAR ignore: LONGINT;
  651. BEGIN
  652. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  653. END RawReal;
  654. (** Read a LONGREAL. *)
  655. PROCEDURE RawLReal*( VAR x: LONGREAL );
  656. VAR ignore: LONGINT;
  657. BEGIN
  658. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8, ignore )
  659. END RawLReal;
  660. (** Read a 0X-terminated string. If the input string is larger than x, read the full string and assign the truncated 0X-terminated value to x. *)
  661. PROCEDURE RawString*( VAR x: ARRAY OF CHAR );
  662. VAR i, m: LONGINT; ch: CHAR;
  663. BEGIN
  664. i := 0; m := LEN( x ) - 1;
  665. LOOP
  666. ch := Get(); (* also returns 0X on error *)
  667. IF ch = 0X THEN EXIT END;
  668. IF i < m THEN x[i] := ch; INC( i ) END
  669. END;
  670. x[i] := 0X
  671. END RawString;
  672. (** Read a number in a compressed format. *)
  673. PROCEDURE RawNum*( VAR x: LONGINT );
  674. VAR ch: CHAR; n, y: LONGINT;
  675. BEGIN
  676. n := 0; y := 0; ch := Get();
  677. WHILE ch >= 80X DO INC( y, LSH( LONGINT( ORD( ch ) ) - 128, n ) ); INC( n, 7 ); ch := Get() END;
  678. x := ASH( LSH( LONGINT( ORD( ch ) ), 25 ), n - 25 ) + y
  679. END RawNum;
  680. (** Read a size in a compressed format. *)
  681. PROCEDURE RawSize*( VAR x: SIZE );
  682. VAR ch: CHAR; n, y: SIZE;
  683. BEGIN
  684. n := 0; y := 0; ch := Get();
  685. WHILE ch >= 80X DO INC( y, LSH( SIZE( ORD( ch ) ) - 128, n ) ); INC( n, 7 ); ch := Get() END;
  686. x := ASH( LSH( SIZE( ORD( ch ) ), SIZE OF SIZE * 8 - 7 ), n - SIZE OF SIZE * 8 - 7 ) + y
  687. END RawSize;
  688. (** -- Read formatted data (uses Peek for one character lookahead) -- *)
  689. (** Read an integer value in decimal or hexadecimal. If hex = TRUE, recognize the "H" postfix for hexadecimal numbers. *)
  690. PROCEDURE Int*( VAR x: LONGINT; hex: BOOLEAN );
  691. VAR vd, vh, sgn, d: LONGINT; ch: CHAR; ok: BOOLEAN;
  692. BEGIN
  693. vd := 0; vh := 0; sgn := 1; ok := FALSE;
  694. IF Peek() = "-" THEN sgn := -1; ch := Get() END;
  695. LOOP
  696. ch := Peek();
  697. IF (ch >= "0") & (ch <= "9") THEN d := ORD( ch ) - ORD( "0" )
  698. ELSIF hex & (CAP( ch ) >= "A") & (CAP( ch ) <= "F") THEN d := ORD( CAP( ch ) ) - ORD( "A" ) + 10
  699. ELSE EXIT
  700. END;
  701. vd := 10 * vd + d; vh := 16 * vh + d; (* ignore overflow *)
  702. ch := Get(); ok := TRUE
  703. END;
  704. IF hex & (CAP( ch ) = "H") THEN (* optional "H" present *)
  705. vd := vh; (* use the hex value *)
  706. ch := Get()
  707. END;
  708. x := sgn * vd;
  709. IF (res = 0) & ~ok THEN res := FormatError END
  710. END Int;
  711. (** Read a floating-point number. EBNF: Real = Digit {Digit} '.' Digit {Digit} ['e'|'E' ['+'|'-'] Digit {Digit}]. *)
  712. PROCEDURE Real* (VAR real: LONGREAL);
  713. VAR e: INTEGER; y, g: LONGREAL; neg, negE: BOOLEAN; ch: CHAR;
  714. BEGIN
  715. ch := Get();
  716. WHILE (ch = "0") DO ch := Get() END;
  717. IF ch = "-" THEN neg := TRUE; ch := Get(); ELSE neg := FALSE END;
  718. WHILE (ch = " ") OR (ch = "0") DO ch := Get(); END;
  719. y := 0;
  720. WHILE ("0" <= ch) & (ch <= "9") DO
  721. y := y * 10 + (ORD(ch) - ORD("0"));
  722. ch := Get();
  723. END;
  724. IF ch = "." THEN
  725. ch := Get();
  726. g := 1;
  727. WHILE ("0" <= ch) & (ch <= "9") DO
  728. g := g / 10; y := y + g * (ORD(ch) - ORD("0"));
  729. ch := Get();
  730. END;
  731. END;
  732. IF (ch = "d") OR (ch = "D") OR (ch = "e") OR (ch = "E") THEN
  733. ch := Get(); e := 0;
  734. IF ch = "-" THEN negE := TRUE; ch := Get()
  735. ELSIF ch = "+" THEN negE := FALSE; ch := Get()
  736. ELSE negE := FALSE
  737. END;
  738. WHILE (ch = "0") DO ch := Get() END;
  739. WHILE ("0" <= ch) & (ch <= "9") DO
  740. e := e * 10 + (ORD(ch) - ORD("0"));
  741. ch := Get();
  742. END;
  743. IF negE THEN y := y / Ten(e)
  744. ELSE y := y * Ten(e)
  745. END;
  746. END;
  747. IF neg THEN y := -y END;
  748. real := y
  749. END Real;
  750. (** Return TRUE iff at the end of a line (or file). *)
  751. PROCEDURE EOLN*( ): BOOLEAN;
  752. VAR ch: CHAR;
  753. BEGIN
  754. ch := Peek(); RETURN (ch = CR) OR (ch = LF) OR (res # Ok)
  755. END EOLN;
  756. (** Read all characters until the end of the line (inclusive). If the input string is larger than x, read the full string and assign
  757. the truncated 0X-terminated value to x. *)
  758. PROCEDURE Ln*( VAR x: ARRAY OF CHAR );
  759. VAR i, m: LONGINT; ch: CHAR;
  760. BEGIN
  761. i := 0; m := LEN( x ) - 1;
  762. LOOP
  763. ch := Peek();
  764. IF (ch = CR) OR (ch = LF) OR (res # Ok) THEN EXIT END;
  765. IF i < m THEN x[i] := ch; INC( i ) END;
  766. ch := Get()
  767. END;
  768. x[i] := 0X;
  769. IF ch = CR THEN ch := Get() END;
  770. IF Peek() = LF THEN ch := Get() END
  771. END Ln;
  772. (** Read all characters until the end of the line (inclusive) or an <EOT> character.
  773. If the input string is larger than x, read the full string and assign the truncated 0X-terminated
  774. value to x. *)
  775. PROCEDURE LnEOT*( VAR x: ARRAY OF CHAR );
  776. VAR i, m: LONGINT; ch: CHAR;
  777. BEGIN
  778. i := 0; m := LEN( x ) - 1;
  779. LOOP
  780. ch := Peek();
  781. IF (ch = CR) OR (ch = LF) OR (ch = EOT) OR (res # Ok) THEN EXIT END;
  782. IF i < m THEN x[i] := ch; INC( i ) END;
  783. ch := Get()
  784. END;
  785. x[i] := 0X;
  786. IF ch = CR THEN ch := Get() END;
  787. IF Peek() = LF THEN ch := Get() END;
  788. IF ch = EOT THEN ch := Get() END
  789. END LnEOT;
  790. (** Skip over all characters until the end of the line (inclusive). *)
  791. PROCEDURE SkipLn*;
  792. VAR ch: CHAR;
  793. BEGIN
  794. LOOP
  795. ch := Peek();
  796. IF (ch = CR) OR (ch = LF) OR (res # Ok) THEN EXIT END;
  797. ch := Get()
  798. END;
  799. IF ch = CR THEN ch := Get() END;
  800. IF Peek() = LF THEN ch := Get() END
  801. END SkipLn;
  802. (** Skip over space and TAB characters. *)
  803. PROCEDURE SkipSpaces*;
  804. VAR ch: CHAR;
  805. BEGIN
  806. LOOP
  807. ch := Peek();
  808. IF (ch # TAB) & (ch # SP) THEN EXIT END;
  809. ch := Get()
  810. END
  811. END SkipSpaces;
  812. (** Skip over space, TAB and EOLN characters. *)
  813. PROCEDURE SkipWhitespace*;
  814. VAR ch: CHAR;
  815. BEGIN
  816. LOOP
  817. ch := Peek();
  818. IF (ch # SP) & (ch # CR) & (ch # LF) & (ch # TAB) THEN EXIT END;
  819. ch := Get()
  820. END
  821. END SkipWhitespace;
  822. (** Read a token, consisting of any string of characters terminated by space, TAB or EOLN. *)
  823. PROCEDURE Token*( VAR token: ARRAY OF CHAR );
  824. VAR j, max: LONGINT; ch: CHAR;
  825. BEGIN
  826. j := 0; max := LEN( token ) - 1;
  827. LOOP
  828. ch := Peek();
  829. IF (ch = SP) OR (ch = CR) OR (ch = LF) OR (ch = TAB) OR (res # Ok) THEN EXIT END;
  830. IF j < max THEN token[j] := ch; INC( j ) END;
  831. ch := Get()
  832. END;
  833. token[j] := 0X
  834. END Token;
  835. (** Read an optionally "" or '' enquoted string. Will not read past the end of a line. *)
  836. PROCEDURE String*( VAR string: ARRAY OF CHAR );
  837. VAR c, delimiter: CHAR; i, len: LONGINT;
  838. BEGIN
  839. c := Peek();
  840. IF (c # "'") & (c # '"') THEN Token( string )
  841. ELSE
  842. delimiter := Get(); c := Peek(); i := 0; len := LEN( string ) - 1;
  843. WHILE (i < len) & (c # delimiter) & (c # CR) & (c # LF) & (res = Ok) DO string[i] := Get(); INC( i ); c := Peek() END;
  844. IF (c = delimiter) THEN c := Get() END;
  845. string[i] := 0X
  846. END
  847. END String;
  848. (** First skip whitespace, then read string *)
  849. PROCEDURE GetString*(VAR string : ARRAY OF CHAR): BOOLEAN;
  850. VAR c: CHAR;
  851. BEGIN
  852. SkipWhitespace;
  853. c := Peek();
  854. String(string);
  855. RETURN (string[0] # 0X) OR (c = "'") OR (c = '"');
  856. END GetString;
  857. (** First skip whitespace, then read integer *)
  858. PROCEDURE GetInteger*(VAR integer : LONGINT; isHexadecimal : BOOLEAN): BOOLEAN;
  859. BEGIN
  860. SkipWhitespace;
  861. Int(integer, isHexadecimal);
  862. RETURN res = Ok;
  863. END GetInteger;
  864. (** First skip whitespace, then read a real *)
  865. PROCEDURE GetReal*(VAR real: LONGREAL): BOOLEAN;
  866. BEGIN
  867. SkipWhitespace;
  868. Real(real);
  869. RETURN res = Ok
  870. END GetReal;
  871. (** First skip whitespace, then read 1 byte character *)
  872. PROCEDURE GetChar*(VAR ch : CHAR): BOOLEAN;
  873. BEGIN
  874. SkipWhitespace;
  875. Char(ch);
  876. RETURN ch # 0X;
  877. END GetChar;
  878. END Reader;
  879. TYPE
  880. (** A special reader that buffers input set by SetString or SetRawString. *)
  881. StringReader* = OBJECT (Reader)
  882. PROCEDURE & InitStringReader*( size: LONGINT );
  883. BEGIN
  884. InitReader( Receive, size )
  885. END InitStringReader;
  886. PROCEDURE CanSetPos*( ): BOOLEAN;
  887. BEGIN
  888. RETURN TRUE
  889. END CanSetPos;
  890. (** Set the reader position *)
  891. PROCEDURE SetPos*( pos: Position );
  892. BEGIN
  893. IF pos > LEN( buf ) THEN pos := LEN( buf ) END;
  894. head := pos; tail := LEN( buf ); received := LEN( buf ); res := Ok;
  895. END SetPos;
  896. PROCEDURE Receive( VAR buf: ARRAY OF CHAR; ofs, size, min: LONGINT; VAR len, res: LONGINT );
  897. BEGIN
  898. IF min = 0 THEN res := Ok ELSE res := EOF END;
  899. len := 0;
  900. END Receive;
  901. (** Set the contents of the string buffer. The s parameter is a 0X-terminated string. *)
  902. PROCEDURE Set*(CONST s: ARRAY OF CHAR );
  903. VAR len: LONGINT;
  904. BEGIN
  905. len := 0;
  906. WHILE s[len] # 0X DO INC( len ) END;
  907. IF len > LEN( buf ) THEN len := LEN( buf ) END;
  908. head := 0; tail := len; received := len; res := Ok;
  909. IF len > 0 THEN
  910. SYSTEM.MOVE( ADDRESSOF( s[0] ), ADDRESSOF( buf[0] ), len )
  911. END;
  912. END Set;
  913. (** Set the contents of the string buffer. The len parameter specifies the size of the buffer s. *)
  914. PROCEDURE SetRaw*(CONST s: ARRAY OF CHAR; ofs, len: LONGINT );
  915. BEGIN
  916. IF len > LEN( buf ) THEN len := LEN( buf ) END;
  917. head := 0; tail := len; received := len; res := Ok;
  918. ASSERT ( (len >= 0) & (ofs + len <= LEN( s )) ); (* index check *)
  919. IF len > 0 THEN
  920. SYSTEM.MOVE( ADDRESSOF( s[ofs] ), ADDRESSOF( buf[0] ), len )
  921. END;
  922. END SetRaw;
  923. END StringReader;
  924. Bytes2 = ARRAY 2 OF CHAR;
  925. Bytes4 = ARRAY 4 OF CHAR;
  926. Bytes8 = ARRAY 8 OF CHAR;
  927. VAR
  928. months: ARRAY 12 * 4 + 1 OF CHAR;
  929. (** Open a writer to the specified stream sender. Update must be called after writing to ensure the buffer is written to the stream. *)
  930. PROCEDURE OpenWriter*( VAR b: Writer; send: Sender );
  931. BEGIN
  932. NEW( b, send, DefaultWriterSize )
  933. END OpenWriter;
  934. (** Open a reader from the specified stream receiver. *)
  935. PROCEDURE OpenReader*( VAR b: Reader; receive: Receiver );
  936. BEGIN
  937. NEW( b, receive, DefaultReaderSize )
  938. END OpenReader;
  939. (** Copy the contents of a reader to a writer *)
  940. PROCEDURE Copy* (r: Reader; w: Writer);
  941. VAR char: CHAR;
  942. BEGIN
  943. WHILE r.res = Ok DO
  944. r.Char (char);
  945. IF r.res = Ok THEN w.Char (char) END
  946. END;
  947. END Copy;
  948. (** from module Reals.Mod *)
  949. (*** the following procedures stem from Reals.Mod and are needed for Writer.Float and Writer.FloatFix *)
  950. (** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *)
  951. PROCEDURE NaNCodeL( x: LONGREAL; VAR h, l: LONGINT );
  952. BEGIN
  953. SYSTEM.GET( ADDRESSOF( x ) + H, h ); SYSTEM.GET( ADDRESSOF( x ) + L, l );
  954. IF ASH( h, -20 ) MOD 2048 = 2047 THEN (* Infinite or NaN *)
  955. h := h MOD 100000H (* lowest 20 bits *)
  956. ELSE h := -1; l := -1
  957. END
  958. END NaNCodeL;
  959. (** Returns the shifted binary exponent (0 <= e < 2048). *)
  960. PROCEDURE ExpoL( x: LONGREAL ): LONGINT;
  961. VAR i: LONGINT;
  962. BEGIN
  963. SYSTEM.GET( ADDRESSOF( x ) + H, i ); RETURN ASH( i, -20 ) MOD 2048
  964. END ExpoL;
  965. (** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*)
  966. PROCEDURE RealL( h, l: LONGINT ): LONGREAL;
  967. VAR x: LONGREAL;
  968. BEGIN
  969. SYSTEM.PUT( ADDRESSOF( x ) + H, h ); SYSTEM.PUT( ADDRESSOF( x ) + L, l ); RETURN x
  970. END RealL;
  971. (** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *)
  972. PROCEDURE Ten( e: LONGINT ): LONGREAL; (* naiive version *)
  973. VAR r: LONGREAL;
  974. BEGIN
  975. IF e < -307 THEN RETURN 0
  976. ELSIF 308 < e THEN RETURN RealL( 2146435072, 0 )
  977. END;
  978. r := 1;
  979. WHILE (e > 0) DO r := r * 10; DEC( e ); END;
  980. WHILE (e < 0) DO r := r / 10; INC( e ); END;
  981. RETURN r;
  982. END Ten;
  983. PROCEDURE InitHL;
  984. VAR i: ADDRESS; dmy: INTEGER; littleEndian: BOOLEAN;
  985. BEGIN
  986. dmy := 1; i := ADDRESSOF( dmy );
  987. SYSTEM.GET( i, littleEndian ); (* indirection via i avoids warning on SUN cc -O *)
  988. IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END
  989. END InitHL;
  990. BEGIN
  991. months := " Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"; InitHL;
  992. END Streams.
  993. (**
  994. Notes:
  995. o Any single buffer instance must not be accessed by more than one process concurrently.
  996. o The interface is blocking (synchronous). If an output buffer is full, it is written with a synchronous write, which returns
  997. only when all the data has been written. If an input buffer is empty, it is read with a synchronous read, which only returns
  998. once some data has been read. The only exception is the Available() procedure, which "peeks" at the input stream
  999. and returns 0 if no data is currently available.
  1000. o All procedures set res to the error code reported by the lower-level I/O operation (non-zero indicates error).
  1001. E.g. closing an underlying TCP connection will result in the Read* procedures returning a non-zero error code.
  1002. o res is sticky. Once it becomes non-zero, it remains non-zero.
  1003. o The only way to detect end of file is to attempt to read past the end of file, which returns a non-zero error code.
  1004. o All output written to an erroneous buffer is ignored.
  1005. o The value returned when reading from an erroneous buffer is undefined, except for the Read procedure, which returns 0X.
  1006. o ReadBytes sets the len parameter to the number of bytes that were actually read, e.g. if size = 10, and only 8 bytes are read, len is 8.
  1007. o Raw format is little-endian 2's complement integers, IEEE reals and 0X-terminated strings.
  1008. o Syntax for ReadInt with hex = FALSE: num = ["-"] digit {digit}. digit = "0".."9".
  1009. o Syntax for ReadInt with hex = TRUE: ["-"] hexdigit {hexdigit} ["H"|"h"]. hexdigit = digit | "A".."F" | "a".."f".
  1010. o ReadInt with hex = TRUE allows "A".."F" as digits, and looks for a "H" character after the number.
  1011. If present, the number is interpreted as hexadecimal. If hexadecimal digits are present, but no "H" flag,
  1012. the resulting decimal value is undefined.
  1013. o ReadInt ignores overflow.
  1014. o A Sender sends len bytes from buf at ofs to output and returns res non-zero on error. It waits until all the data is written,
  1015. or an error occurs.
  1016. o A Receiver receives up to size bytes from input into buf at ofs and returns the number of bytes read in len.
  1017. It returns res non-zero on error. It waits until at least min bytes (possibly zero) are available, or an error occurs.
  1018. o EOLN and ReadLn recognize the following end-of-line characters: CR, LF and CR/LF.
  1019. o To read an unstructured file token-by-token: WHILE (r.res = 0) DO SkipWhitespace; ReadToken END
  1020. o To read a line structured file token-by-token: WHILE r.res = 0 DO SkipSpaces; WHILE ~EOLN DO ReadToken; SkipSpaces END END
  1021. o A string writer is not flushed when it becomes full, but res is set to a non-zero value.
  1022. o Update has no effect on a string writer.
  1023. o GetString can be called on a string writer to return the buffer contents and reset it to empty.
  1024. o GetString always appends a 0X character to the buffer, but returns the true length (excluding the added 0X) in the len parameter,
  1025. so it can also be used for binary data that includes 0X characters.
  1026. o Receive procedure should set res to EOF when attempting to read past the end of file.
  1027. *)
  1028. (*
  1029. to do:
  1030. o stream byte count
  1031. o read formatted data
  1032. o reads for all formatted writes
  1033. o write reals
  1034. o low-level version that can be used in kernel (below KernelLog)
  1035. *)