xfail scan-tree-dump-not throw in g++.dg/pr99966.C on hppa*64*-*-*
[official-gcc.git] / gcc / m2 / gm2-libs-iso / MemStream.mod
blob9620ed2ba195a08310b42475f6086e98aeaf135c
1 (* MemStream.mod provide a memory stream channel.
3 Copyright (C) 2015-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. *)
27 IMPLEMENTATION MODULE MemStream ;
30 FROM RTgen IMPORT ChanDev, DeviceType,
31 InitChanDev, doLook, doSkip, doSkipLook, doWriteLn,
32 doReadText, doWriteText, doReadLocs, doWriteLocs,
33 checkErrno ;
35 FROM RTdata IMPORT ModuleId, MakeModuleId, InitData, GetData, KillData ;
37 FROM IOLink IMPORT DeviceId, DeviceTablePtr, IsDevice, MakeChan, UnMakeChan,
38 DeviceTablePtrValue, RAISEdevException, AllocateDeviceId,
39 ResetProc ;
41 FROM Builtins IMPORT memcpy ;
42 FROM Assertion IMPORT Assert ;
43 FROM Strings IMPORT Assign ;
44 FROM RTgenif IMPORT GenDevIF, InitGenDevIF ;
45 FROM FIO IMPORT File ;
46 FROM IOConsts IMPORT ReadResults ;
47 FROM ChanConsts IMPORT readFlag, writeFlag ;
48 FROM SYSTEM IMPORT ADR ;
49 FROM ASCII IMPORT nl, nul ;
50 FROM Storage IMPORT ALLOCATE, DEALLOCATE, REALLOCATE ;
51 FROM libc IMPORT printf ;
53 IMPORT SYSTEM, RTio, errno, ErrnoCategory, ChanConsts, IOChan ;
56 CONST
57 InitialLength = 128 ;
58 Debugging = FALSE ;
60 TYPE
61 PtrToLoc = POINTER TO LOC ;
62 PtrToChar = POINTER TO CHAR ;
63 PtrToAddress = POINTER TO ADDRESS ;
64 PtrToCardinal = POINTER TO CARDINAL ;
65 MemInfo = POINTER TO RECORD
66 buffer: ADDRESS ;
67 length: CARDINAL ;
68 index : CARDINAL ;
69 pBuffer: PtrToAddress ;
70 pLength: PtrToCardinal ;
71 pUsed : PtrToCardinal ;
72 dealloc: BOOLEAN ;
73 eof : BOOLEAN ;
74 eoln : BOOLEAN ;
75 END ;
77 VAR
78 dev: ChanDev ;
79 did: DeviceId ;
80 mid: ModuleId ;
84 Min -
87 PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
88 BEGIN
89 IF a<b
90 THEN
91 RETURN( a )
92 ELSE
93 RETURN( b )
94 END
95 END Min ;
98 PROCEDURE look (d: DeviceTablePtr;
99 VAR ch: CHAR; VAR r: ReadResults) ;
100 BEGIN
101 doLook(dev, d, ch, r)
102 END look ;
105 PROCEDURE skip (d: DeviceTablePtr) ;
106 BEGIN
107 doSkip(dev, d)
108 END skip ;
111 PROCEDURE skiplook (d: DeviceTablePtr;
112 VAR ch: CHAR; VAR r: ReadResults) ;
113 BEGIN
114 doSkipLook(dev, d, ch, r)
115 END skiplook ;
118 PROCEDURE lnwrite (d: DeviceTablePtr) ;
119 BEGIN
120 doWriteLn(dev, d)
121 END lnwrite ;
124 PROCEDURE textread (d: DeviceTablePtr;
125 to: SYSTEM.ADDRESS;
126 maxChars: CARDINAL;
127 VAR charsRead: CARDINAL) ;
128 BEGIN
129 doReadText(dev, d, to, maxChars, charsRead)
130 END textread ;
133 PROCEDURE textwrite (d: DeviceTablePtr;
134 from: SYSTEM.ADDRESS;
135 charsToWrite: CARDINAL);
136 BEGIN
137 doWriteText(dev, d, from, charsToWrite)
138 END textwrite ;
141 PROCEDURE rawread (d: DeviceTablePtr;
142 to: SYSTEM.ADDRESS;
143 maxLocs: CARDINAL;
144 VAR locsRead: CARDINAL) ;
145 BEGIN
146 doReadLocs(dev, d, to, maxLocs, locsRead)
147 END rawread ;
150 PROCEDURE rawwrite (d: DeviceTablePtr;
151 from: SYSTEM.ADDRESS;
152 locsToWrite: CARDINAL) ;
153 BEGIN
154 doWriteLocs(dev, d, from, locsToWrite)
155 END rawwrite ;
158 PROCEDURE getname (d: DeviceTablePtr;
159 VAR a: ARRAY OF CHAR) ;
160 BEGIN
161 Assign('memstream', a)
162 END getname ;
165 PROCEDURE flush (d: DeviceTablePtr) ;
166 BEGIN
167 (* nothing to do *)
168 END flush ;
172 doreadchar - returns a CHAR from the file associated with, g.
175 PROCEDURE doreadchar (g: GenDevIF; d: DeviceTablePtr) : CHAR ;
177 m : MemInfo ;
178 pc: PtrToChar ;
179 BEGIN
180 WITH d^ DO
181 m := GetData(d, mid) ;
182 WITH m^ DO
183 IF index<length
184 THEN
185 pc := buffer ;
186 INC(pc, index) ;
187 INC(index) ;
188 AssignIndex(m, index) ;
189 eoln := (pc^=nl) ;
190 eof := FALSE ;
191 RETURN( pc^ )
192 ELSE
193 eof := TRUE ;
194 eoln := FALSE ;
195 RETURN( nul )
199 END doreadchar ;
203 dounreadchar - pushes a CHAR back onto the file associated with, g.
206 PROCEDURE dounreadchar (g: GenDevIF; d: DeviceTablePtr; ch: CHAR) : CHAR ;
208 m : MemInfo ;
209 pc: PtrToChar ;
210 BEGIN
211 WITH d^ DO
212 m := GetData(d, mid) ;
213 WITH m^ DO
214 IF index>0
215 THEN
216 DEC(index) ;
217 AssignIndex(m, index) ;
218 eof := FALSE ;
219 pc := buffer ;
220 INC(pc, index) ;
221 eoln := (ch=nl) ;
222 Assert(pc^=ch) (* expecting to be pushing characters in exactly the reverse order *)
223 ELSE
224 Assert(FALSE) ; (* expecting to be pushing characters in exactly the reverse order *)
226 END ;
227 RETURN( ch )
229 END dounreadchar ;
233 dogeterrno - always return 0 as the memstream device never invokes errno.
236 PROCEDURE dogeterrno (g: GenDevIF; d: DeviceTablePtr) : INTEGER ;
237 BEGIN
238 RETURN 0
239 END dogeterrno ;
243 dorbytes - reads upto, max, bytes setting, actual, and
244 returning FALSE if an error (not due to eof)
245 occurred.
248 PROCEDURE dorbytes (g: GenDevIF; d: DeviceTablePtr;
249 to: ADDRESS;
250 max: CARDINAL;
251 VAR actual: CARDINAL) : BOOLEAN ;
253 m : MemInfo ;
254 pl: PtrToLoc ;
255 BEGIN
256 WITH d^ DO
257 m := GetData(d, mid) ;
258 WITH m^ DO
259 pl := buffer ;
260 INC(pl, index) ;
261 actual := Min(max, length-index) ;
262 to := memcpy(to, pl, actual) ;
263 INC(index, actual) ;
264 AssignIndex(m, index) ;
265 eof := FALSE ;
266 eoln := FALSE
267 END ;
268 RETURN( TRUE )
270 END dorbytes ;
274 dowbytes -
277 PROCEDURE dowbytes (g: GenDevIF; d: DeviceTablePtr;
278 from: ADDRESS;
279 nBytes: CARDINAL;
280 VAR actual: CARDINAL) : BOOLEAN ;
282 m : MemInfo ;
283 pl: PtrToLoc ;
284 BEGIN
285 WITH d^ DO
286 m := GetData(d, mid) ;
287 WITH m^ DO
288 IF index+nBytes>length
289 THEN
290 WHILE index+nBytes>length DO
291 (* buffer needs to grow *)
292 length := length*2
293 END ;
294 REALLOCATE(buffer, length) ;
295 AssignLength(m, length) ;
296 AssignBuffer(m, buffer)
297 END ;
298 pl := buffer ;
299 INC(pl, index) ;
300 actual := Min(nBytes, length-index) ;
301 pl := memcpy(pl, from, actual) ;
302 INC(index, actual) ;
303 AssignIndex(m, index)
304 END ;
305 RETURN( TRUE )
307 END dowbytes ;
311 dowriteln - attempt to write an end of line marker to the
312 file and returns TRUE if successful.
315 PROCEDURE dowriteln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
317 ch: CHAR ;
318 n : CARDINAL ;
319 BEGIN
320 ch := nl ;
321 RETURN( dowbytes(g, d, ADR(ch), SIZE(ch), n) )
322 END dowriteln ;
326 iseof - returns TRUE if end of file has been seen.
329 PROCEDURE iseof (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
331 m: MemInfo ;
332 BEGIN
333 IF Debugging
334 THEN
335 printf ("mid = %p, d = %p\n", mid, d)
336 END ;
337 WITH d^ DO
338 IF Debugging
339 THEN
340 printf ("mid = %p, d = %p\n", mid, d)
341 END ;
342 m := GetData(d, mid) ;
343 RETURN( m^.eof )
345 END iseof ;
349 iseoln - returns TRUE if end of line is seen.
352 PROCEDURE iseoln (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
354 m: MemInfo ;
355 BEGIN
356 WITH d^ DO
357 m := GetData(d, mid) ;
358 RETURN( m^.eoln )
360 END iseoln ;
364 iserror - returns TRUE if an error was seen on the device.
367 PROCEDURE iserror (g: GenDevIF; d: DeviceTablePtr) : BOOLEAN ;
368 BEGIN
369 RETURN( FALSE )
370 END iserror ;
374 AssignLength -
377 PROCEDURE AssignLength (m: MemInfo; l: CARDINAL) ;
378 BEGIN
379 WITH m^ DO
380 length := l ;
381 IF pLength#NIL
382 THEN
383 pLength^ := l
386 END AssignLength ;
390 AssignBuffer -
393 PROCEDURE AssignBuffer (m: MemInfo; b: ADDRESS) ;
394 BEGIN
395 WITH m^ DO
396 buffer := b ;
397 IF pBuffer#NIL
398 THEN
399 pBuffer^ := b
402 END AssignBuffer ;
406 AssignIndex -
409 PROCEDURE AssignIndex (m: MemInfo; i: CARDINAL) ;
410 BEGIN
411 WITH m^ DO
412 index := i ;
413 IF pUsed#NIL
414 THEN
415 pUsed^ := i
418 END AssignIndex ;
422 newCidWrite - returns a ChanId which represents the opened file, name.
423 res is set appropriately on return.
426 PROCEDURE newCidWrite (f: FlagSet;
427 VAR res: OpenResults;
428 VAR buffer: ADDRESS;
429 VAR length: CARDINAL;
430 VAR used: CARDINAL;
431 deallocOnClose: BOOLEAN) : ChanId ;
433 c: ChanId ;
434 d: DeviceTablePtr ;
435 m: MemInfo ;
436 BEGIN
437 MakeChan(did, c) ;
438 d := DeviceTablePtrValue(c, did) ;
439 NEW(m) ;
440 m^.pBuffer := ADR(buffer) ;
441 m^.pLength := ADR(length) ;
442 m^.pUsed := ADR(used) ;
443 m^.dealloc := deallocOnClose ;
444 ALLOCATE(m^.buffer, InitialLength) ;
445 AssignBuffer(m, m^.buffer) ;
446 AssignLength(m, InitialLength) ;
447 AssignIndex(m, 0) ;
448 InitData(d, mid, m, freeMemInfo) ;
449 WITH d^ DO
450 flags := f ;
451 errNum := 0 ;
452 doLook := look ;
453 doSkip := skip ;
454 doSkipLook := skiplook ;
455 doLnWrite := lnwrite ;
456 doTextRead := textread ;
457 doTextWrite := textwrite ;
458 doRawRead := rawread ;
459 doRawWrite := rawwrite ;
460 doGetName := getname ;
461 doReset := resetWrite ;
462 doFlush := flush ;
463 doFree := handlefree
464 END ;
465 res := opened ;
466 RETURN( c )
467 END newCidWrite ;
471 Attempts to obtain and open a channel connected to a contigeous
472 buffer in memory. The write flag is implied; without the raw
473 flag, text is implied. If successful, assigns to cid the identity of
474 the opened channel, assigns the value opened to res.
475 If a channel cannot be opened as required,
476 the value of res indicates the reason, and cid identifies the
477 invalid channel.
479 The parameters, buffer, length and used maybe updated as
480 data is written. The buffer maybe reallocated
481 and its address might alter, however the parameters will
482 always reflect the current active buffer. When this
483 channel is closed the buffer is deallocated and
484 buffer will be set to NIL, length and used will be set to
485 zero.
488 PROCEDURE OpenWrite (VAR cid: ChanId; flags: FlagSet;
489 VAR res: OpenResults;
490 VAR buffer: ADDRESS;
491 VAR length: CARDINAL;
492 VAR used: CARDINAL;
493 deallocOnClose: BOOLEAN) ;
494 BEGIN
495 IF Debugging
496 THEN
497 printf ("OpenWrite called\n")
498 END ;
499 INCL(flags, ChanConsts.writeFlag) ;
500 IF NOT (ChanConsts.rawFlag IN flags)
501 THEN
502 INCL(flags, ChanConsts.textFlag)
503 END ;
504 cid := newCidWrite(flags, res, buffer, length, used, deallocOnClose)
505 END OpenWrite ;
509 newCidRead - returns a ChanId which represents the opened file, name.
510 res is set appropriately on return.
513 PROCEDURE newCidRead (f: FlagSet;
514 VAR res: OpenResults;
515 buffer: ADDRESS;
516 length: CARDINAL;
517 deallocOnClose: BOOLEAN) : ChanId ;
519 c: ChanId ;
520 d: DeviceTablePtr ;
521 m: MemInfo ;
522 BEGIN
523 MakeChan(did, c) ;
524 d := DeviceTablePtrValue(c, did) ;
525 NEW(m) ;
526 m^.pBuffer := NIL ;
527 m^.pLength := NIL ;
528 m^.pUsed := NIL ;
529 m^.dealloc := deallocOnClose ;
530 AssignBuffer(m, buffer) ;
531 AssignLength(m, length) ;
532 AssignIndex(m, 0) ;
533 InitData(d, mid, m, freeMemInfo) ;
534 WITH d^ DO
535 flags := f ;
536 errNum := 0 ;
537 doLook := look ;
538 doSkip := skip ;
539 doSkipLook := skiplook ;
540 doLnWrite := lnwrite ;
541 doTextRead := textread ;
542 doTextWrite := textwrite ;
543 doRawRead := rawread ;
544 doRawWrite := rawwrite ;
545 doGetName := getname ;
546 doReset := resetRead ;
547 doFlush := flush ;
548 doFree := handlefree
549 END ;
550 res := opened ;
551 RETURN( c )
552 END newCidRead ;
556 freeMemInfo -
559 PROCEDURE freeMemInfo (a: ADDRESS) ;
561 m: MemInfo ;
562 BEGIN
563 DEALLOCATE(a, SIZE(m^))
564 END freeMemInfo ;
568 Attempts to obtain and open a channel connected to a contigeous
569 buffer in memory. The read and old flags are implied; without
570 the raw flag, text is implied. If successful, assigns to cid the
571 identity of the opened channel, assigns the value opened to res, and
572 selects input mode, with the read position corresponding to the start
573 of the buffer. If a channel cannot be opened as required, the value of
574 res indicates the reason, and cid identifies the invalid channel.
577 PROCEDURE OpenRead (VAR cid: ChanId; flags: FlagSet;
578 VAR res: OpenResults;
579 buffer: ADDRESS; length: CARDINAL;
580 deallocOnClose: BOOLEAN) ;
581 BEGIN
582 flags := flags + ChanConsts.read + ChanConsts.old ;
583 IF NOT (ChanConsts.rawFlag IN flags)
584 THEN
585 INCL(flags, ChanConsts.textFlag)
586 END ;
587 cid := newCidRead(flags, res, buffer, length, deallocOnClose)
588 END OpenRead ;
592 resetRead - wrap a call to Reread.
595 PROCEDURE resetRead (d: DeviceTablePtr) ;
596 BEGIN
597 Reread(d^.cid)
598 END resetRead ;
602 resetWrite - wrap a call to Rewrite.
605 PROCEDURE resetWrite (d: DeviceTablePtr) ;
606 BEGIN
607 Rewrite(d^.cid)
608 END resetWrite ;
612 Reread - if the channel identified by cid is not open
613 to a memory stream, the exception
614 wrongDevice is raised; otherwise it sets the
615 index to 0. Subsequent reads will read the
616 previous buffer contents.
619 PROCEDURE Reread (cid: ChanId) ;
621 d: DeviceTablePtr ;
622 m: MemInfo ;
623 BEGIN
624 IF IsMem(cid)
625 THEN
626 d := DeviceTablePtrValue(cid, did) ;
627 WITH d^ DO
628 EXCL(flags, writeFlag) ;
629 IF readFlag IN flags
630 THEN
631 m := GetData(d, mid) ;
632 AssignIndex(m, 0)
633 ELSE
634 EXCL(flags, readFlag)
637 ELSE
638 RAISEdevException(cid, did, IOChan.wrongDevice,
639 'MemStream.' + __FUNCTION__ +
640 ': channel is not a memory stream')
642 END Reread ;
646 Rewrite - if the channel identified by cid is not open to a
647 memory stream, the exception wrongDevice
648 is raised; otherwise, it sets the index to 0.
649 Subsequent writes will overwrite the previous buffer
650 contents.
653 PROCEDURE Rewrite (cid: ChanId) ;
655 d: DeviceTablePtr ;
656 m: MemInfo ;
657 BEGIN
658 IF IsMem(cid)
659 THEN
660 d := DeviceTablePtrValue(cid, did) ;
661 WITH d^ DO
662 EXCL(flags, readFlag) ;
663 IF writeFlag IN flags
664 THEN
665 m := GetData(d, mid) ;
666 AssignIndex(m, 0)
667 ELSE
668 EXCL(flags, writeFlag)
671 ELSE
672 RAISEdevException(cid, did, IOChan.wrongDevice,
673 'MemStream.' + __FUNCTION__ +
674 ': channel is not a memory stream')
676 END Rewrite ;
680 handlefree -
683 PROCEDURE handlefree (d: DeviceTablePtr) ;
684 BEGIN
685 END handlefree ;
689 Close - if the channel identified by cid is not open to a sequential
690 stream, the exception wrongDevice is raised; otherwise
691 closes the channel, and assigns the value identifying
692 the invalid channel to cid.
695 PROCEDURE Close (VAR cid: ChanId) ;
696 BEGIN
697 printf ("Close called\n");
698 IF IsMem(cid)
699 THEN
700 UnMakeChan(did, cid) ;
701 cid := IOChan.InvalidChan()
702 ELSE
703 RAISEdevException(cid, did, IOChan.wrongDevice,
704 'MemStream.' + __FUNCTION__ +
705 ': channel is not a sequential file')
707 END Close ;
711 IsMem - tests if the channel identified by cid is open as
712 a memory stream.
715 PROCEDURE IsMem (cid: ChanId) : BOOLEAN ;
716 BEGIN
717 RETURN( (cid # NIL) AND (IOChan.InvalidChan() # cid) AND
718 (IsDevice(cid, did)) AND
719 ((ChanConsts.readFlag IN IOChan.CurrentFlags(cid)) OR
720 (ChanConsts.writeFlag IN IOChan.CurrentFlags(cid))) )
721 END IsMem ;
725 Init -
728 PROCEDURE Init ;
730 gen: GenDevIF ;
731 BEGIN
732 MakeModuleId(mid) ;
733 IF Debugging
734 THEN
735 printf ("mid = %d\n", mid)
736 END ;
737 AllocateDeviceId(did) ;
738 gen := InitGenDevIF(did, doreadchar, dounreadchar,
739 dogeterrno, dorbytes, dowbytes,
740 dowriteln,
741 iseof, iseoln, iserror) ;
742 dev := InitChanDev(streamfile, did, gen)
743 END Init ;
746 BEGIN
747 Init
748 END MemStream.