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)
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
,
35 FROM RTdata
IMPORT ModuleId
, MakeModuleId
, InitData
, GetData
, KillData
;
37 FROM IOLink
IMPORT DeviceId
, DeviceTablePtr
, IsDevice
, MakeChan
, UnMakeChan
,
38 DeviceTablePtrValue
, RAISEdevException
, AllocateDeviceId
,
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
;
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
69 pBuffer
: PtrToAddress
;
70 pLength
: PtrToCardinal
;
71 pUsed
: PtrToCardinal
;
87 PROCEDURE Min (a
, b
: CARDINAL) : CARDINAL ;
98 PROCEDURE look (d
: DeviceTablePtr
;
99 VAR ch
: CHAR; VAR r
: ReadResults
) ;
101 doLook(dev
, d
, ch
, r
)
105 PROCEDURE skip (d
: DeviceTablePtr
) ;
111 PROCEDURE skiplook (d
: DeviceTablePtr
;
112 VAR ch
: CHAR; VAR r
: ReadResults
) ;
114 doSkipLook(dev
, d
, ch
, r
)
118 PROCEDURE lnwrite (d
: DeviceTablePtr
) ;
124 PROCEDURE textread (d
: DeviceTablePtr
;
127 VAR charsRead
: CARDINAL) ;
129 doReadText(dev
, d
, to
, maxChars
, charsRead
)
133 PROCEDURE textwrite (d
: DeviceTablePtr
;
134 from
: SYSTEM.ADDRESS
;
135 charsToWrite
: CARDINAL);
137 doWriteText(dev
, d
, from
, charsToWrite
)
141 PROCEDURE rawread (d
: DeviceTablePtr
;
144 VAR locsRead
: CARDINAL) ;
146 doReadLocs(dev
, d
, to
, maxLocs
, locsRead
)
150 PROCEDURE rawwrite (d
: DeviceTablePtr
;
151 from
: SYSTEM.ADDRESS
;
152 locsToWrite
: CARDINAL) ;
154 doWriteLocs(dev
, d
, from
, locsToWrite
)
158 PROCEDURE getname (d
: DeviceTablePtr
;
159 VAR a
: ARRAY OF CHAR) ;
161 Assign('memstream', a
)
165 PROCEDURE flush (d
: DeviceTablePtr
) ;
172 doreadchar - returns a CHAR from the file associated with, g.
175 PROCEDURE doreadchar (g
: GenDevIF
; d
: DeviceTablePtr
) : CHAR ;
181 m
:= GetData(d
, mid
) ;
188 AssignIndex(m
, index
) ;
203 dounreadchar - pushes a CHAR back onto the file associated with, g.
206 PROCEDURE dounreadchar (g
: GenDevIF
; d
: DeviceTablePtr
; ch
: CHAR) : CHAR ;
212 m
:= GetData(d
, mid
) ;
217 AssignIndex(m
, index
) ;
222 Assert(pc^
=ch
) (* expecting to be pushing characters in exactly the reverse order *)
224 Assert(FALSE) ; (* expecting to be pushing characters in exactly the reverse order *)
233 dogeterrno - always return 0 as the memstream device never invokes errno.
236 PROCEDURE dogeterrno (g
: GenDevIF
; d
: DeviceTablePtr
) : INTEGER ;
243 dorbytes - reads upto, max, bytes setting, actual, and
244 returning FALSE if an error (not due to eof)
248 PROCEDURE dorbytes (g
: GenDevIF
; d
: DeviceTablePtr
;
251 VAR actual
: CARDINAL) : BOOLEAN ;
257 m
:= GetData(d
, mid
) ;
261 actual
:= Min(max
, length
-index
) ;
262 to
:= memcpy(to
, pl
, actual
) ;
264 AssignIndex(m
, index
) ;
277 PROCEDURE dowbytes (g
: GenDevIF
; d
: DeviceTablePtr
;
280 VAR actual
: CARDINAL) : BOOLEAN ;
286 m
:= GetData(d
, mid
) ;
288 IF index
+nBytes
>length
290 WHILE index
+nBytes
>length
DO
291 (* buffer needs to grow *)
294 REALLOCATE(buffer
, length
) ;
295 AssignLength(m
, length
) ;
296 AssignBuffer(m
, buffer
)
300 actual
:= Min(nBytes
, length
-index
) ;
301 pl
:= memcpy(pl
, from
, actual
) ;
303 AssignIndex(m
, index
)
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 ;
321 RETURN( dowbytes(g
, d
, ADR(ch
), SIZE(ch
), n
) )
326 iseof - returns TRUE if end of file has been seen.
329 PROCEDURE iseof (g
: GenDevIF
; d
: DeviceTablePtr
) : BOOLEAN ;
335 printf ("mid = %p, d = %p\n", mid
, d
)
340 printf ("mid = %p, d = %p\n", mid
, d
)
342 m
:= GetData(d
, mid
) ;
349 iseoln - returns TRUE if end of line is seen.
352 PROCEDURE iseoln (g
: GenDevIF
; d
: DeviceTablePtr
) : BOOLEAN ;
357 m
:= GetData(d
, mid
) ;
364 iserror - returns TRUE if an error was seen on the device.
367 PROCEDURE iserror (g
: GenDevIF
; d
: DeviceTablePtr
) : BOOLEAN ;
377 PROCEDURE AssignLength (m
: MemInfo
; l
: CARDINAL) ;
393 PROCEDURE AssignBuffer (m
: MemInfo
; b
: ADDRESS
) ;
409 PROCEDURE AssignIndex (m
: MemInfo
; i
: CARDINAL) ;
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
;
429 VAR length
: CARDINAL;
431 deallocOnClose
: BOOLEAN) : ChanId
;
438 d
:= DeviceTablePtrValue(c
, did
) ;
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
) ;
448 InitData(d
, mid
, m
, freeMemInfo
) ;
454 doSkipLook
:= skiplook
;
455 doLnWrite
:= lnwrite
;
456 doTextRead
:= textread
;
457 doTextWrite
:= textwrite
;
458 doRawRead
:= rawread
;
459 doRawWrite
:= rawwrite
;
460 doGetName
:= getname
;
461 doReset
:= resetWrite
;
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
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
488 PROCEDURE OpenWrite (VAR cid
: ChanId
; flags
: FlagSet
;
489 VAR res
: OpenResults
;
491 VAR length
: CARDINAL;
493 deallocOnClose
: BOOLEAN) ;
497 printf ("OpenWrite called\n")
499 INCL(flags
, ChanConsts.writeFlag
) ;
500 IF NOT (ChanConsts.rawFlag
IN flags
)
502 INCL(flags
, ChanConsts.textFlag
)
504 cid
:= newCidWrite(flags
, res
, buffer
, length
, used
, deallocOnClose
)
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
;
517 deallocOnClose
: BOOLEAN) : ChanId
;
524 d
:= DeviceTablePtrValue(c
, did
) ;
529 m^.dealloc
:= deallocOnClose
;
530 AssignBuffer(m
, buffer
) ;
531 AssignLength(m
, length
) ;
533 InitData(d
, mid
, m
, freeMemInfo
) ;
539 doSkipLook
:= skiplook
;
540 doLnWrite
:= lnwrite
;
541 doTextRead
:= textread
;
542 doTextWrite
:= textwrite
;
543 doRawRead
:= rawread
;
544 doRawWrite
:= rawwrite
;
545 doGetName
:= getname
;
546 doReset
:= resetRead
;
559 PROCEDURE freeMemInfo (a
: ADDRESS
) ;
563 DEALLOCATE(a
, SIZE(m^
))
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) ;
582 flags
:= flags
+ ChanConsts.read
+ ChanConsts.old
;
583 IF NOT (ChanConsts.rawFlag
IN flags
)
585 INCL(flags
, ChanConsts.textFlag
)
587 cid
:= newCidRead(flags
, res
, buffer
, length
, deallocOnClose
)
592 resetRead - wrap a call to Reread.
595 PROCEDURE resetRead (d
: DeviceTablePtr
) ;
602 resetWrite - wrap a call to Rewrite.
605 PROCEDURE resetWrite (d
: DeviceTablePtr
) ;
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
) ;
626 d
:= DeviceTablePtrValue(cid
, did
) ;
628 EXCL(flags
, writeFlag
) ;
631 m
:= GetData(d
, mid
) ;
634 EXCL(flags
, readFlag
)
638 RAISEdevException(cid
, did
, IOChan.wrongDevice
,
639 'MemStream.' + __FUNCTION__
+
640 ': channel is not a memory stream')
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
653 PROCEDURE Rewrite (cid
: ChanId
) ;
660 d
:= DeviceTablePtrValue(cid
, did
) ;
662 EXCL(flags
, readFlag
) ;
663 IF writeFlag
IN flags
665 m
:= GetData(d
, mid
) ;
668 EXCL(flags
, writeFlag
)
672 RAISEdevException(cid
, did
, IOChan.wrongDevice
,
673 'MemStream.' + __FUNCTION__
+
674 ': channel is not a memory stream')
683 PROCEDURE handlefree (d
: DeviceTablePtr
) ;
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
) ;
697 printf ("Close called\n");
700 UnMakeChan(did
, cid
) ;
701 cid
:= IOChan.
InvalidChan()
703 RAISEdevException(cid
, did
, IOChan.wrongDevice
,
704 'MemStream.' + __FUNCTION__
+
705 ': channel is not a sequential file')
711 IsMem - tests if the channel identified by cid is open as
715 PROCEDURE IsMem (cid
: ChanId
) : BOOLEAN ;
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
))) )
735 printf ("mid = %d\n", mid
)
737 AllocateDeviceId(did
) ;
738 gen
:= InitGenDevIF(did
, doreadchar
, dounreadchar
,
739 dogeterrno
, dorbytes
, dowbytes
,
741 iseof
, iseoln
, iserror
) ;
742 dev
:= InitChanDev(streamfile
, did
, gen
)