Streams.Mod 37 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190
  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. PROCEDURE Append( VAR str: ARRAY OF CHAR; c: CHAR );
  339. VAR i: LONGINT;
  340. BEGIN
  341. WHILE str[i] # 0X DO INC( i ) END;
  342. str[i] := c; str[i+1] := 0X
  343. END Append;
  344. (** Write LONGREAL x using n character positions. *)
  345. PROCEDURE Float*( x: LONGREAL; n: WORD );
  346. (* BM 1993.4.22. Do not simplify rounding! *)
  347. VAR e, h, l, i, le, ndigits: LONGINT; z: LONGREAL;
  348. d, exp: ARRAY 24 OF CHAR;
  349. neg: BOOLEAN;
  350. BEGIN
  351. e := ExpoL( x );
  352. IF e = 2047 THEN
  353. WHILE n > 5 DO Char( " " ); DEC( n ) END;
  354. NaNCodeL( x, h, l );
  355. IF (h # 0) OR (l # 0) THEN String( " NaN" )
  356. ELSIF x < 0 THEN String(" -INF" )
  357. ELSE String(" INF" )
  358. END
  359. ELSE
  360. IF (e # 0) & (x < 0) THEN x := -x; neg := TRUE ELSE neg := FALSE END;
  361. IF e = 0 THEN
  362. h := 0; l := 0 (* no denormals *)
  363. ELSE
  364. e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
  365. z := Ten( e + 1 );
  366. IF x >= z THEN x := x / z; INC( e ) ELSE x := x * Ten( -e ) END;
  367. IF x >= 10 THEN x := x * Ten( -1 ) + 0.5D0 / Ten( n ); INC( e )
  368. ELSE
  369. x := x + 0.5D0 / Ten( n );
  370. IF x >= 10 THEN x := x * Ten( -1 ); INC( e ) END
  371. END;
  372. x := x * Ten( 7 ); h := ENTIER( x ); x := (x - h) * Ten( 8 ); l := ENTIER( x )
  373. END;
  374. IF e = 0 THEN exp := ""; le := 0
  375. ELSE
  376. IF e < 0 THEN exp := "E-"; e := -e ELSE exp := "E+" END; le := 2;
  377. IF e >= 100 THEN Append( exp, CHR( e DIV 100 + ORD( '0' ) ) ); INC( le ); e := e MOD 100 END;
  378. IF (le > 2) OR (e >= 10) THEN Append( exp, CHR( e DIV 10 + ORD( '0' ) ) ); INC( le ) END;
  379. Append( exp, CHR( e MOD 10 + ORD( '0' ) ) ); INC( le )
  380. END;
  381. IF neg THEN INC( le ) END;
  382. IF n < 10 THEN ndigits := 7 ELSE ndigits := 15 END;
  383. WHILE n > ndigits+le+1 DO Char( ' ' ); DEC( n ) END;
  384. IF neg THEN Char( '-' ) END;
  385. i := 15;
  386. WHILE i > 7 DO d[i] := CHR( l MOD 10 + ORD( "0" ) ); l := l DIV 10; DEC( i ) END;
  387. WHILE i >= 0 DO d[i] := CHR( h MOD 10 + ORD( "0" ) ); h := h DIV 10; DEC( i ) END;
  388. Char( d[0] ); Char( "." ); i := 1;
  389. WHILE i < ndigits DO Char( d[i] ); INC( i ) END;
  390. String( exp )
  391. END
  392. END Float;
  393. (** Write LONGREAL x in a fixed point notation. n is the overall minimal length for the output field,
  394. f the number of fraction digits following the decimal point, D the fixed exponent (printed only when D # 0). *)
  395. PROCEDURE FloatFix*( x: LONGREAL; n, f, D: WORD );
  396. (* BM 1993.4.22. Do not simplify rounding! / JG formatting adjusted *)
  397. VAR e, h, l, i: LONGINT; r, z: LONGREAL;
  398. d: ARRAY 16 OF CHAR;
  399. s: CHAR; dot: BOOLEAN;
  400. BEGIN
  401. e := ExpoL( x );
  402. IF (e = 2047) OR (ABS( D ) > 308) THEN
  403. WHILE n > 5 DO Char( " " ); DEC( n ) END;
  404. NaNCodeL( x, h, l );
  405. IF (h # 0) OR (l # 0) THEN String( " NaN" )
  406. ELSIF x < 0 THEN String( " -INF" )
  407. ELSE String( " INF" )
  408. END
  409. ELSE
  410. 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;
  411. IF n < 2 THEN n := 2 END;
  412. IF f < 0 THEN f := 0 END;
  413. IF n < f + 2 THEN n := f + 2 END;
  414. DEC( n, f );
  415. IF (e # 0) & (x < 0) THEN s := "-"; x := -x ELSE s := " " END;
  416. IF e = 0 THEN
  417. h := 0; l := 0; DEC( e, D - 1 ) (* no denormals *)
  418. ELSE
  419. e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
  420. z := Ten( e + 1 );
  421. IF x >= z THEN x := x / z; INC( e ) ELSE x := x * Ten( -e ) END;
  422. DEC( e, D - 1 ); i := -(e + f);
  423. IF i <= 0 THEN r := 5 * Ten( i ) ELSE r := 0 END;
  424. IF x >= 10 THEN x := x * Ten( -1 ) + r; INC( e )
  425. ELSE
  426. x := x + r;
  427. IF x >= 10 THEN x := x * Ten( -1 ); INC( e ) END
  428. END;
  429. x := x * Ten( 7 ); h := ENTIER( x ); x := (x - h) * Ten( 8 ); l := ENTIER( x )
  430. END;
  431. i := 15;
  432. WHILE i > 7 DO d[i] := CHR( l MOD 10 + ORD( "0" ) ); l := l DIV 10; DEC( i ) END;
  433. WHILE i >= 0 DO d[i] := CHR( h MOD 10 + ORD( "0" ) ); h := h DIV 10; DEC( i ) END;
  434. IF n <= e THEN n := e + 1 END;
  435. IF e > 0 THEN
  436. WHILE n > e DO Char( " " ); DEC( n ) END;
  437. Char( s ); e := 0;
  438. WHILE n > 0 DO
  439. DEC( n );
  440. IF e < 16 THEN Char( d[e] ); INC( e ) ELSE Char( "0" ) END
  441. END;
  442. IF dot THEN
  443. Char( "." )
  444. END;
  445. ELSE
  446. WHILE n > 1 DO Char( " " ); DEC( n ) END;
  447. Char( s ); Char( "0" ); IF dot THEN Char( "." ); END;
  448. WHILE (0 < f) & (e < 0) DO Char( "0" ); DEC( f ); INC( e ) END
  449. END;
  450. WHILE f > 0 DO
  451. DEC( f );
  452. IF e < 16 THEN Char( d[e] ); INC( e ) ELSE Char( "0" ) END
  453. END;
  454. IF D # 0 THEN
  455. IF D < 0 THEN String( "E-" ); D := -D ELSE String( "E+" ) END;
  456. 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" ) ) )
  457. END
  458. END
  459. END FloatFix;
  460. END Writer;
  461. (** A special writer that buffers output to be fetched by GetString or GetRawString. *)
  462. StringWriter* = OBJECT (Writer)
  463. PROCEDURE & InitStringWriter*( size: LONGINT );
  464. BEGIN
  465. InitWriter( Send, size )
  466. END InitStringWriter;
  467. PROCEDURE Send( CONST buf: ARRAY OF CHAR; ofs, len: LONGINT; propagate: BOOLEAN; VAR res: WORD );
  468. BEGIN
  469. res := StringFull
  470. END Send;
  471. PROCEDURE CanSetPos*( ): BOOLEAN;
  472. BEGIN
  473. RETURN TRUE;
  474. END CanSetPos;
  475. (* Set the position for the writer *)
  476. PROCEDURE SetPos*( pos: Position );
  477. BEGIN
  478. IF pos > LEN( buf ) THEN pos := LEN( buf ) END;
  479. tail := pos; sent := 0; res := Ok;
  480. END SetPos;
  481. PROCEDURE Update*;
  482. (* nothing to do *)
  483. END Update;
  484. (** Return the contents of the string writer (0X-terminated). *)
  485. PROCEDURE Get*( VAR s: ARRAY OF CHAR );
  486. VAR i, m: LONGINT;
  487. BEGIN
  488. m := LEN( s ) - 1; i := 0;
  489. WHILE (i # tail) & (i < m) DO s[i] := buf[i]; INC( i ) END;
  490. s[i] := 0X; tail := 0; res := Ok
  491. END Get;
  492. (** Return the contents of the string writer (not 0X-terminated). The len parameters returns the string length. *)
  493. PROCEDURE GetRaw*( VAR s: ARRAY OF CHAR; VAR len: LONGINT );
  494. VAR i, m: LONGINT;
  495. BEGIN
  496. m := LEN( s ); i := 0;
  497. WHILE (i # tail) & (i < m) DO s[i] := buf[i]; INC( i ) END;
  498. len := i; tail := 0; res := Ok
  499. END GetRaw;
  500. END StringWriter;
  501. TYPE
  502. (** A reader buffers input received from a Receiver. Must not be shared between processes. *)
  503. Reader* = OBJECT
  504. VAR
  505. head, tail: LONGINT;
  506. buf: POINTER TO ARRAY OF CHAR;
  507. res*: LONGINT; (** result of last input operation. *)
  508. receive: Receiver;
  509. received*: LONGINT; (** count of received bytes *)
  510. (* buf[buf.head..buf.tail-1] contains data to read. *)
  511. PROCEDURE & InitReader*( receive: Receiver; size: LONGINT );
  512. BEGIN
  513. ASSERT ( receive # NIL );
  514. IF (buf = NIL) OR (LEN(buf) # size) THEN
  515. NEW( buf, size );
  516. END;
  517. SELF.receive := receive; Reset
  518. END InitReader;
  519. (** reset the reader by dropping the bytes in the buffer, resetting the result code and setting received to 0.
  520. This is used by seekable extensions of the reader *)
  521. PROCEDURE Reset*;
  522. BEGIN
  523. head := 0; tail := 0; res := Ok; received := 0
  524. END Reset;
  525. PROCEDURE CanSetPos*( ): BOOLEAN;
  526. BEGIN
  527. RETURN FALSE
  528. END CanSetPos;
  529. PROCEDURE SetPos*( pos: Position );
  530. BEGIN
  531. HALT( 1234 )
  532. END SetPos;
  533. (** Return bytes currently available in input buffer. *)
  534. PROCEDURE Available*( ): LONGINT;
  535. VAR n: LONGINT;
  536. BEGIN
  537. IF (res = Ok) THEN
  538. IF (head = tail) THEN head := 0; receive( buf^, 0, LEN( buf ), 0, tail, res ); INC( received, tail );
  539. ELSIF (tail # LEN( buf )) THEN
  540. receive( buf^, tail, LEN( buf ) - tail, 0, n, res ); (* poll *)
  541. INC( tail, n ); INC( received, n )
  542. END;
  543. IF res = EOF THEN res := Ok END (* ignore EOF here *)
  544. END;
  545. RETURN tail - head
  546. END Available;
  547. (** Current read position. *)
  548. PROCEDURE Pos*( ): Position;
  549. BEGIN
  550. RETURN received - (tail - head)
  551. END Pos;
  552. (** -- Read raw binary data -- *)
  553. (** Read one byte. x=0X if no success (e.g. file ended) *)
  554. PROCEDURE Char*( VAR x: CHAR );
  555. BEGIN
  556. IF (head = tail) & (res = Ok) THEN head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail ) END;
  557. IF res = Ok THEN x := buf[head]; INC( head ) ELSE x := 0X END
  558. END Char;
  559. (** Like Read, but return result. Return 0X if no success (e.g. file ended) *)
  560. PROCEDURE Get*( ): CHAR;
  561. BEGIN
  562. IF (head = tail) & (res = Ok) THEN head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail ) END;
  563. IF res = Ok THEN INC( head ); RETURN buf[head - 1] ELSE RETURN 0X END
  564. END Get;
  565. (** Like Get, but leave the byte in the input buffer. *)
  566. PROCEDURE Peek*( ): CHAR;
  567. BEGIN
  568. IF (head = tail) & (res = Ok) THEN
  569. head := 0; receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail );
  570. IF res = EOF THEN (* ignore EOF here *)
  571. res := Ok; tail := 0; RETURN 0X (* Peek returns 0X at eof *)
  572. END
  573. END;
  574. IF res = Ok THEN RETURN buf[head] ELSE RETURN 0X END
  575. END Peek;
  576. (** Read size bytes into x, starting at ofs. The len parameter returns the number of bytes that were actually read. *)
  577. PROCEDURE Bytes*( VAR x: ARRAY OF CHAR; ofs, size: LONGINT; VAR len: LONGINT );
  578. VAR n: LONGINT;
  579. BEGIN
  580. ASSERT ( size >= 0 );
  581. len := 0;
  582. LOOP
  583. n := tail - head; (* bytes available *)
  584. IF n = 0 THEN (* no data available *)
  585. head := 0;
  586. IF res = Ok THEN (* fill buffer *)
  587. receive( buf^, 0, LEN( buf ), 1, tail, res ); INC( received, tail )
  588. END;
  589. IF res # Ok THEN (* should not be reading from erroneous rider *)
  590. WHILE size # 0 DO x[ofs] := 0X; INC( ofs ); DEC( size ) END; (* clear rest of buffer *)
  591. IF (res = EOF) & (len # 0) THEN res := Ok END; (* ignore EOF if some data being returned *)
  592. EXIT
  593. END;
  594. n := tail
  595. END;
  596. IF n > size THEN n := size END;
  597. ASSERT ( ofs + n <= LEN( x ) ); (* index check *)
  598. SYSTEM.MOVE( ADDRESSOF( buf[head] ), ADDRESSOF( x[ofs] ), n ); INC( head, n ); INC( len, n );
  599. IF size = n THEN EXIT END; (* done *)
  600. INC( ofs, n ); DEC( size, n )
  601. END
  602. END Bytes;
  603. (** Skip n bytes on the reader. *)
  604. PROCEDURE SkipBytes*( n: LONGINT );
  605. VAR ch: CHAR;
  606. BEGIN
  607. WHILE n > 0 DO ch := Get(); DEC( n ) END
  608. END SkipBytes;
  609. (** Read a SHORTINT. *)
  610. PROCEDURE RawSInt*( VAR x: SHORTINT );
  611. BEGIN
  612. x := SYSTEM.VAL( SHORTINT, Get() )
  613. END RawSInt;
  614. (** Read an INTEGER. *)
  615. PROCEDURE RawInt*( VAR x: INTEGER );
  616. VAR x0, x1: CHAR;
  617. BEGIN
  618. x0 := Get(); x1 := Get(); (* defined order *)
  619. x := ORD( x1 ) * 100H + ORD( x0 )
  620. END RawInt;
  621. (** Read a LONGINT. *)
  622. PROCEDURE RawLInt*( VAR x: LONGINT );
  623. VAR ignore: LONGINT;
  624. BEGIN
  625. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  626. END RawLInt;
  627. (** Read a HUGEINT. *)
  628. PROCEDURE RawHInt*( VAR x: HUGEINT );
  629. VAR ignore: LONGINT;
  630. BEGIN
  631. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8, ignore )
  632. END RawHInt;
  633. (** Read a 64 bit value in network byte order (most significant byte first) *)
  634. PROCEDURE Net64*( ): HUGEINT;
  635. BEGIN
  636. RETURN Net32() * 100000000H + Net32()
  637. END Net64;
  638. (** Read a 32 bit value in network byte order (most significant byte first) *)
  639. PROCEDURE Net32*( ): LONGINT;
  640. BEGIN
  641. RETURN LONG( ORD( Get() ) ) * 1000000H + LONG( ORD( Get() ) ) * 10000H + LONG( ORD( Get() ) ) * 100H + LONG( ORD( Get() ) )
  642. END Net32;
  643. (** Read an unsigned 16bit value in network byte order (most significant byte first) *)
  644. PROCEDURE Net16*( ): LONGINT;
  645. BEGIN
  646. RETURN LONG( ORD( Get() ) ) * 100H + LONG( ORD( Get() ) )
  647. END Net16;
  648. (** Read an unsigned byte *)
  649. PROCEDURE Net8*( ): LONGINT;
  650. BEGIN
  651. RETURN LONG( ORD( Get() ) )
  652. END Net8;
  653. (** Read a SET. *)
  654. PROCEDURE RawSet*( VAR x: SET );
  655. VAR ignore: LONGINT;
  656. BEGIN
  657. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  658. END RawSet;
  659. (** Read a BOOLEAN. *)
  660. PROCEDURE RawBool*( VAR x: BOOLEAN );
  661. BEGIN
  662. x := (Get() # 0X)
  663. END RawBool;
  664. (** Read a REAL. *)
  665. PROCEDURE RawReal*( VAR x: REAL );
  666. VAR ignore: LONGINT;
  667. BEGIN
  668. Bytes( SYSTEM.VAL( Bytes4, x ), 0, 4, ignore )
  669. END RawReal;
  670. (** Read a LONGREAL. *)
  671. PROCEDURE RawLReal*( VAR x: LONGREAL );
  672. VAR ignore: LONGINT;
  673. BEGIN
  674. Bytes( SYSTEM.VAL( Bytes8, x ), 0, 8, ignore )
  675. END RawLReal;
  676. (** 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. *)
  677. PROCEDURE RawString*( VAR x: ARRAY OF CHAR );
  678. VAR i, m: LONGINT; ch: CHAR;
  679. BEGIN
  680. i := 0; m := LEN( x ) - 1;
  681. LOOP
  682. ch := Get(); (* also returns 0X on error *)
  683. IF ch = 0X THEN EXIT END;
  684. IF i < m THEN x[i] := ch; INC( i ) END
  685. END;
  686. x[i] := 0X
  687. END RawString;
  688. (** Read a number in a compressed format. *)
  689. PROCEDURE RawNum*( VAR x: LONGINT );
  690. VAR ch: CHAR; n, y: LONGINT;
  691. BEGIN
  692. n := 0; y := 0; ch := Get();
  693. WHILE ch >= 80X DO INC( y, LSH( LONGINT( ORD( ch ) ) - 128, n ) ); INC( n, 7 ); ch := Get() END;
  694. x := ASH( LSH( LONGINT( ORD( ch ) ), 25 ), n - 25 ) + y
  695. END RawNum;
  696. (** Read a size in a compressed format. *)
  697. PROCEDURE RawSize*( VAR x: SIZE );
  698. VAR ch: CHAR; n, y: SIZE;
  699. BEGIN
  700. n := 0; y := 0; ch := Get();
  701. WHILE ch >= 80X DO INC( y, LSH( SIZE( ORD( ch ) ) - 128, n ) ); INC( n, 7 ); ch := Get() END;
  702. x := ASH( LSH( SIZE( ORD( ch ) ), SIZE OF SIZE * 8 - 7 ), n - SIZE OF SIZE * 8 - 7 ) + y
  703. END RawSize;
  704. (** -- Read formatted data (uses Peek for one character lookahead) -- *)
  705. (** Read an integer value in decimal or hexadecimal. If hex = TRUE, recognize the "H" postfix for hexadecimal numbers. *)
  706. PROCEDURE Int*( VAR x: LONGINT; hex: BOOLEAN );
  707. VAR vd, vh, sgn, d: LONGINT; ch: CHAR; ok: BOOLEAN;
  708. BEGIN
  709. vd := 0; vh := 0; sgn := 1; ok := FALSE;
  710. IF Peek() = "-" THEN sgn := -1; ch := Get() END;
  711. LOOP
  712. ch := Peek();
  713. IF (ch >= "0") & (ch <= "9") THEN d := ORD( ch ) - ORD( "0" )
  714. ELSIF hex & (CAP( ch ) >= "A") & (CAP( ch ) <= "F") THEN d := ORD( CAP( ch ) ) - ORD( "A" ) + 10
  715. ELSE EXIT
  716. END;
  717. vd := 10 * vd + d; vh := 16 * vh + d; (* ignore overflow *)
  718. ch := Get(); ok := TRUE
  719. END;
  720. IF hex & (CAP( ch ) = "H") THEN (* optional "H" present *)
  721. vd := vh; (* use the hex value *)
  722. ch := Get()
  723. END;
  724. x := sgn * vd;
  725. IF (res = 0) & ~ok THEN res := FormatError END
  726. END Int;
  727. (** Read a floating-point number. EBNF: Real = Digit {Digit} '.' Digit {Digit} ['e'|'E' ['+'|'-'] Digit {Digit}]. *)
  728. PROCEDURE Real* (VAR real: LONGREAL);
  729. VAR e: INTEGER; y, g: LONGREAL; neg, negE: BOOLEAN; ch: CHAR;
  730. BEGIN
  731. ch := Get();
  732. WHILE (ch = "0") DO ch := Get() END;
  733. IF ch = "-" THEN neg := TRUE; ch := Get(); ELSE neg := FALSE END;
  734. WHILE (ch = " ") OR (ch = "0") DO ch := Get(); END;
  735. y := 0;
  736. WHILE ("0" <= ch) & (ch <= "9") DO
  737. y := y * 10 + (ORD(ch) - ORD("0"));
  738. ch := Get();
  739. END;
  740. IF ch = "." THEN
  741. ch := Get();
  742. g := 1;
  743. WHILE ("0" <= ch) & (ch <= "9") DO
  744. g := g / 10; y := y + g * (ORD(ch) - ORD("0"));
  745. ch := Get();
  746. END;
  747. END;
  748. IF (ch = "d") OR (ch = "D") OR (ch = "e") OR (ch = "E") THEN
  749. ch := Get(); e := 0;
  750. IF ch = "-" THEN negE := TRUE; ch := Get()
  751. ELSIF ch = "+" THEN negE := FALSE; ch := Get()
  752. ELSE negE := FALSE
  753. END;
  754. WHILE (ch = "0") DO ch := Get() END;
  755. WHILE ("0" <= ch) & (ch <= "9") DO
  756. e := e * 10 + (ORD(ch) - ORD("0"));
  757. ch := Get();
  758. END;
  759. IF negE THEN y := y / Ten(e)
  760. ELSE y := y * Ten(e)
  761. END;
  762. END;
  763. IF neg THEN y := -y END;
  764. real := y
  765. END Real;
  766. (** Return TRUE iff at the end of a line (or file). *)
  767. PROCEDURE EOLN*( ): BOOLEAN;
  768. VAR ch: CHAR;
  769. BEGIN
  770. ch := Peek(); RETURN (ch = CR) OR (ch = LF) OR (res # Ok)
  771. END EOLN;
  772. (** Read all characters until the end of the line (inclusive). If the input string is larger than x, read the full string and assign
  773. the truncated 0X-terminated value to x. *)
  774. PROCEDURE Ln*( VAR x: ARRAY OF CHAR );
  775. VAR i, m: LONGINT; ch: CHAR;
  776. BEGIN
  777. i := 0; m := LEN( x ) - 1;
  778. LOOP
  779. ch := Peek();
  780. IF (ch = CR) OR (ch = LF) OR (res # Ok) THEN EXIT END;
  781. IF i < m THEN x[i] := ch; INC( i ) END;
  782. ch := Get()
  783. END;
  784. x[i] := 0X;
  785. IF ch = CR THEN ch := Get() END;
  786. IF Peek() = LF THEN ch := Get() END
  787. END Ln;
  788. (** Read all characters until the end of the line (inclusive) or an <EOT> character.
  789. If the input string is larger than x, read the full string and assign the truncated 0X-terminated
  790. value to x. *)
  791. PROCEDURE LnEOT*( VAR x: ARRAY OF CHAR );
  792. VAR i, m: LONGINT; ch: CHAR;
  793. BEGIN
  794. i := 0; m := LEN( x ) - 1;
  795. LOOP
  796. ch := Peek();
  797. IF (ch = CR) OR (ch = LF) OR (ch = EOT) OR (res # Ok) THEN EXIT END;
  798. IF i < m THEN x[i] := ch; INC( i ) END;
  799. ch := Get()
  800. END;
  801. x[i] := 0X;
  802. IF ch = CR THEN ch := Get() END;
  803. IF Peek() = LF THEN ch := Get() END;
  804. IF ch = EOT THEN ch := Get() END
  805. END LnEOT;
  806. (** Skip over all characters until the end of the line (inclusive). *)
  807. PROCEDURE SkipLn*;
  808. VAR ch: CHAR;
  809. BEGIN
  810. LOOP
  811. ch := Peek();
  812. IF (ch = CR) OR (ch = LF) OR (res # Ok) THEN EXIT END;
  813. ch := Get()
  814. END;
  815. IF ch = CR THEN ch := Get() END;
  816. IF Peek() = LF THEN ch := Get() END
  817. END SkipLn;
  818. (** Skip over space and TAB characters. *)
  819. PROCEDURE SkipSpaces*;
  820. VAR ch: CHAR;
  821. BEGIN
  822. LOOP
  823. ch := Peek();
  824. IF (ch # TAB) & (ch # SP) THEN EXIT END;
  825. ch := Get()
  826. END
  827. END SkipSpaces;
  828. (** Skip over space, TAB and EOLN characters. *)
  829. PROCEDURE SkipWhitespace*;
  830. VAR ch: CHAR;
  831. BEGIN
  832. LOOP
  833. ch := Peek();
  834. IF (ch # SP) & (ch # CR) & (ch # LF) & (ch # TAB) THEN EXIT END;
  835. ch := Get()
  836. END
  837. END SkipWhitespace;
  838. (** Read a token, consisting of any string of characters terminated by space, TAB or EOLN. *)
  839. PROCEDURE Token*( VAR token: ARRAY OF CHAR );
  840. VAR j, max: LONGINT; ch: CHAR;
  841. BEGIN
  842. j := 0; max := LEN( token ) - 1;
  843. LOOP
  844. ch := Peek();
  845. IF (ch = SP) OR (ch = CR) OR (ch = LF) OR (ch = TAB) OR (res # Ok) THEN EXIT END;
  846. IF j < max THEN token[j] := ch; INC( j ) END;
  847. ch := Get()
  848. END;
  849. token[j] := 0X
  850. END Token;
  851. (** Read an optionally "" or '' enquoted string. Will not read past the end of a line. *)
  852. PROCEDURE String*( VAR string: ARRAY OF CHAR );
  853. VAR c, delimiter: CHAR; i, len: LONGINT;
  854. BEGIN
  855. c := Peek();
  856. IF (c # "'") & (c # '"') THEN Token( string )
  857. ELSE
  858. delimiter := Get(); c := Peek(); i := 0; len := LEN( string ) - 1;
  859. WHILE (i < len) & (c # delimiter) & (c # CR) & (c # LF) & (res = Ok) DO string[i] := Get(); INC( i ); c := Peek() END;
  860. IF (c = delimiter) THEN c := Get() END;
  861. string[i] := 0X
  862. END
  863. END String;
  864. (** First skip whitespace, then read string *)
  865. PROCEDURE GetString*(VAR string : ARRAY OF CHAR): BOOLEAN;
  866. VAR c: CHAR;
  867. BEGIN
  868. SkipWhitespace;
  869. c := Peek();
  870. String(string);
  871. RETURN (string[0] # 0X) OR (c = "'") OR (c = '"');
  872. END GetString;
  873. (** First skip whitespace, then read integer *)
  874. PROCEDURE GetInteger*(VAR integer : LONGINT; isHexadecimal : BOOLEAN): BOOLEAN;
  875. BEGIN
  876. SkipWhitespace;
  877. Int(integer, isHexadecimal);
  878. RETURN res = Ok;
  879. END GetInteger;
  880. (** First skip whitespace, then read a real *)
  881. PROCEDURE GetReal*(VAR real: LONGREAL): BOOLEAN;
  882. BEGIN
  883. SkipWhitespace;
  884. Real(real);
  885. RETURN res = Ok
  886. END GetReal;
  887. (** First skip whitespace, then read 1 byte character *)
  888. PROCEDURE GetChar*(VAR ch : CHAR): BOOLEAN;
  889. BEGIN
  890. SkipWhitespace;
  891. Char(ch);
  892. RETURN ch # 0X;
  893. END GetChar;
  894. END Reader;
  895. TYPE
  896. (** A special reader that buffers input set by SetString or SetRawString. *)
  897. StringReader* = OBJECT (Reader)
  898. PROCEDURE & InitStringReader*( size: LONGINT );
  899. BEGIN
  900. InitReader( Receive, size )
  901. END InitStringReader;
  902. PROCEDURE CanSetPos*( ): BOOLEAN;
  903. BEGIN
  904. RETURN TRUE
  905. END CanSetPos;
  906. (** Set the reader position *)
  907. PROCEDURE SetPos*( pos: Position );
  908. BEGIN
  909. IF pos > LEN( buf ) THEN pos := LEN( buf ) END;
  910. head := pos; tail := LEN( buf ); received := LEN( buf ); res := Ok;
  911. END SetPos;
  912. PROCEDURE Receive( VAR buf: ARRAY OF CHAR; ofs, size, min: LONGINT; VAR len, res: LONGINT );
  913. BEGIN
  914. IF min = 0 THEN res := Ok ELSE res := EOF END;
  915. len := 0;
  916. END Receive;
  917. (** Set the contents of the string buffer. The s parameter is a 0X-terminated string. *)
  918. PROCEDURE Set*(CONST s: ARRAY OF CHAR );
  919. VAR len: LONGINT;
  920. BEGIN
  921. len := 0;
  922. WHILE s[len] # 0X DO INC( len ) END;
  923. IF len > LEN( buf ) THEN len := LEN( buf ) END;
  924. head := 0; tail := len; received := len; res := Ok;
  925. IF len > 0 THEN
  926. SYSTEM.MOVE( ADDRESSOF( s[0] ), ADDRESSOF( buf[0] ), len )
  927. END;
  928. END Set;
  929. (** Set the contents of the string buffer. The len parameter specifies the size of the buffer s. *)
  930. PROCEDURE SetRaw*(CONST s: ARRAY OF CHAR; ofs, len: LONGINT );
  931. BEGIN
  932. IF len > LEN( buf ) THEN len := LEN( buf ) END;
  933. head := 0; tail := len; received := len; res := Ok;
  934. ASSERT ( (len >= 0) & (ofs + len <= LEN( s )) ); (* index check *)
  935. IF len > 0 THEN
  936. SYSTEM.MOVE( ADDRESSOF( s[ofs] ), ADDRESSOF( buf[0] ), len )
  937. END;
  938. END SetRaw;
  939. END StringReader;
  940. Bytes2 = ARRAY 2 OF CHAR;
  941. Bytes4 = ARRAY 4 OF CHAR;
  942. Bytes8 = ARRAY 8 OF CHAR;
  943. VAR
  944. months: ARRAY 12 * 4 + 1 OF CHAR;
  945. (** Open a writer to the specified stream sender. Update must be called after writing to ensure the buffer is written to the stream. *)
  946. PROCEDURE OpenWriter*( VAR b: Writer; send: Sender );
  947. BEGIN
  948. NEW( b, send, DefaultWriterSize )
  949. END OpenWriter;
  950. (** Open a reader from the specified stream receiver. *)
  951. PROCEDURE OpenReader*( VAR b: Reader; receive: Receiver );
  952. BEGIN
  953. NEW( b, receive, DefaultReaderSize )
  954. END OpenReader;
  955. (** Copy the contents of a reader to a writer *)
  956. PROCEDURE Copy* (r: Reader; w: Writer);
  957. VAR char: CHAR;
  958. BEGIN
  959. WHILE r.res = Ok DO
  960. r.Char (char);
  961. IF r.res = Ok THEN w.Char (char) END
  962. END;
  963. END Copy;
  964. (** from module Reals.Mod *)
  965. (*** the following procedures stem from Reals.Mod and are needed for Writer.Float and Writer.FloatFix *)
  966. (** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *)
  967. PROCEDURE NaNCodeL( x: LONGREAL; VAR h, l: LONGINT );
  968. BEGIN
  969. SYSTEM.GET( ADDRESSOF( x ) + H, h ); SYSTEM.GET( ADDRESSOF( x ) + L, l );
  970. IF ASH( h, -20 ) MOD 2048 = 2047 THEN (* Infinite or NaN *)
  971. h := h MOD 100000H (* lowest 20 bits *)
  972. ELSE h := -1; l := -1
  973. END
  974. END NaNCodeL;
  975. (** Returns the shifted binary exponent (0 <= e < 2048). *)
  976. PROCEDURE ExpoL( x: LONGREAL ): LONGINT;
  977. VAR i: LONGINT;
  978. BEGIN
  979. SYSTEM.GET( ADDRESSOF( x ) + H, i ); RETURN ASH( i, -20 ) MOD 2048
  980. END ExpoL;
  981. (** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*)
  982. PROCEDURE RealL( h, l: LONGINT ): LONGREAL;
  983. VAR x: LONGREAL;
  984. BEGIN
  985. SYSTEM.PUT( ADDRESSOF( x ) + H, h ); SYSTEM.PUT( ADDRESSOF( x ) + L, l ); RETURN x
  986. END RealL;
  987. (** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *)
  988. PROCEDURE Ten( e: LONGINT ): LONGREAL; (* naiive version *)
  989. VAR r: LONGREAL;
  990. BEGIN
  991. IF e < -307 THEN RETURN 0
  992. ELSIF 308 < e THEN RETURN RealL( 2146435072, 0 )
  993. END;
  994. r := 1;
  995. WHILE (e > 0) DO r := r * 10; DEC( e ); END;
  996. WHILE (e < 0) DO r := r / 10; INC( e ); END;
  997. RETURN r;
  998. END Ten;
  999. PROCEDURE InitHL;
  1000. VAR i: ADDRESS; dmy: INTEGER; littleEndian: BOOLEAN;
  1001. BEGIN
  1002. dmy := 1; i := ADDRESSOF( dmy );
  1003. SYSTEM.GET( i, littleEndian ); (* indirection via i avoids warning on SUN cc -O *)
  1004. IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END
  1005. END InitHL;
  1006. BEGIN
  1007. months := " Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"; InitHL;
  1008. END Streams.
  1009. (**
  1010. Notes:
  1011. o Any single buffer instance must not be accessed by more than one process concurrently.
  1012. o The interface is blocking (synchronous). If an output buffer is full, it is written with a synchronous write, which returns
  1013. only when all the data has been written. If an input buffer is empty, it is read with a synchronous read, which only returns
  1014. once some data has been read. The only exception is the Available() procedure, which "peeks" at the input stream
  1015. and returns 0 if no data is currently available.
  1016. o All procedures set res to the error code reported by the lower-level I/O operation (non-zero indicates error).
  1017. E.g. closing an underlying TCP connection will result in the Read* procedures returning a non-zero error code.
  1018. o res is sticky. Once it becomes non-zero, it remains non-zero.
  1019. 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.
  1020. o All output written to an erroneous buffer is ignored.
  1021. o The value returned when reading from an erroneous buffer is undefined, except for the Read procedure, which returns 0X.
  1022. 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.
  1023. o Raw format is little-endian 2's complement integers, IEEE reals and 0X-terminated strings.
  1024. o Syntax for ReadInt with hex = FALSE: num = ["-"] digit {digit}. digit = "0".."9".
  1025. o Syntax for ReadInt with hex = TRUE: ["-"] hexdigit {hexdigit} ["H"|"h"]. hexdigit = digit | "A".."F" | "a".."f".
  1026. o ReadInt with hex = TRUE allows "A".."F" as digits, and looks for a "H" character after the number.
  1027. If present, the number is interpreted as hexadecimal. If hexadecimal digits are present, but no "H" flag,
  1028. the resulting decimal value is undefined.
  1029. o ReadInt ignores overflow.
  1030. 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,
  1031. or an error occurs.
  1032. o A Receiver receives up to size bytes from input into buf at ofs and returns the number of bytes read in len.
  1033. It returns res non-zero on error. It waits until at least min bytes (possibly zero) are available, or an error occurs.
  1034. o EOLN and ReadLn recognize the following end-of-line characters: CR, LF and CR/LF.
  1035. o To read an unstructured file token-by-token: WHILE (r.res = 0) DO SkipWhitespace; ReadToken END
  1036. o To read a line structured file token-by-token: WHILE r.res = 0 DO SkipSpaces; WHILE ~EOLN DO ReadToken; SkipSpaces END END
  1037. o A string writer is not flushed when it becomes full, but res is set to a non-zero value.
  1038. o Update has no effect on a string writer.
  1039. o GetString can be called on a string writer to return the buffer contents and reset it to empty.
  1040. o GetString always appends a 0X character to the buffer, but returns the true length (excluding the added 0X) in the len parameter,
  1041. so it can also be used for binary data that includes 0X characters.
  1042. o Receive procedure should set res to EOF when attempting to read past the end of file.
  1043. *)
  1044. (*
  1045. to do:
  1046. o stream byte count
  1047. o read formatted data
  1048. o reads for all formatted writes
  1049. o write reals
  1050. o low-level version that can be used in kernel (below KernelLog)
  1051. *)