path: root/pkg/dataio/import/ipfio.gx

include <mach.h>
include <fset.h>
include "../import.h"

define	DEBUG	false


# IP_GSTR --  Get a string of the specifed length from the given offset.

procedure ip_gstr (fd, offset, len, outstr)

int     fd
int	offset
int	len
char    outstr[ARB]

int     nstat, read()
pointer sp, buf

begin
        call smark (sp)
        call salloc (buf, len+2, TY_CHAR)
	call aclrc (Memc[buf], len+2)
	call aclrc (outstr, len+2)

        call ip_lseek (fd, offset)
        nstat = read (fd, Memc[buf], len)

        if (mod(offset,2) == 0 && offset > 1)
            call bytmov (Memc[buf], 2, Memc[buf], 1, len)
        call chrupk (Memc[buf], 1, outstr, 1, len)

	if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); 
	    call pargstr(outstr) ; call pargi (len) }
        call sfree (sp)
end


# IP_GETB --  Get a byte from the given offset.

short procedure ip_getb (fd, offset)

int     fd
int	offset

int     nstat, read()
short	val
char    buf[2]

begin
        call ip_lseek (fd, offset)
        nstat = read (fd, buf, 2)

        if (mod(offset,2) == 0)
            call bytmov (buf, 2, buf, 1, 2)
        call chrupk (buf, 1, buf, 1, 2)

	if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) }
	if (buf[1] < 0)
	    val = buf[1] + 256
	else
	    val = buf[1]
        return (val)
end


# IP_GETU --  Get a unsigned short integer from the given offset.

int procedure ip_getu (fd, offset)

int     fd
int	offset

int	val
short	ip_gets()

begin
	val = ip_gets (fd, offset)
	if (val < 0)
	    val = val + 65536
	return (val)
end

# IP_GET[silrd] --  Get a value of <type> from the given offset.

$for (silrd)

PIXEL procedure ip_get$t (fd, offset)

int     fd
int	offset

int     nstat, read()
PIXEL   val

begin
        call ip_lseek (fd, offset)
	$if (datatype == il)
            nstat = read (fd, val, SZ_INT32 * SZB_CHAR)
	    if (SZ_INT != SZ_INT32)
		call iupk32 (val, val, 1)
	$else
            nstat = read (fd, val, SZ_PIXEL * SZB_CHAR)
	$endif
	$if (datatype == rd)
	call ieeupk$t (val)
	$endif

	if (DEBUG) { call eprintf ("ip_get: %g\n"); call parg$t(val) }
        return (val)
end
$endfor

# IP_GETN --  Get a native floating point number from the given offset.

real procedure ip_getn (fd, offset)

int     fd
int	offset

int     nstat, read()
real	rval

begin
	call ip_lseek (fd, offset)
	nstat = read (fd, rval, SZ_REAL)

	if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) }
	return (rval)
end


# IP_GETN8 --  Get a native double precision floating point number from the 
# given offset.

double procedure ip_getn8 (fd, offset)

int     fd
int	offset

int     nstat, read()
double	dval

begin
	call ip_lseek (fd, offset)
	nstat = read (fd, dval, SZ_DOUBLE)

	if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) }
	return (dval)
end


# IP_AGETB -- Get an array of bytes from the file.  The data pointer is
# allocated if necessary and contains the data on output.

procedure ip_agetb (fd, ptr, len)

int     fd					#i file descriptor
pointer ptr					#i data pointer
int     len					#i length of array

pointer sp, buf
int     fp, nval, nstat
int     ip_lnote(), read()

begin
        fp = ip_lnote(fd)
        if (mod(fp,2) == 0 && fp != 1)
	    nval = len
	else
	    nval = len + 1

        call smark (sp)
        call salloc (buf, nval, TY_CHAR)

        if (ptr == NULL)
            call malloc (ptr, nval * SZB_CHAR, TY_CHAR)
        nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1)

        fp = ip_lnote(fd)
        if (mod(fp,2) == 0 && fp != 1)
            call bytmov (Memc[buf], 2, Memc[buf], 1, nval)
        call achtbc (Memc[buf], Memc[ptr], len)

        call sfree (sp)
end


# IP_AGETU -- Get an array of <type> from the file.  The data pointer is
# allocated if necessary and contains the data on output.

procedure ip_agetu (fd, ptr, len)

int     fd					#i file descriptor
pointer ptr					#i data pointer
int     len					#i length of array

begin
	call ip_agets (fd, ptr, len)
	call achtsu (Mems[ptr], Mems[ptr], len)
end


# IP_AGET[silrd] -- Get an array of <type> from the file.  The data pointer is
# allocated if necessary and contains the data on output.

$for (silrd)
procedure ip_aget$t (fd, ptr, len)

int     fd					#i file descriptor
pointer ptr					#i data pointer
int     len					#i length of array

int     nstat
int     read()

begin
        if (ptr == NULL)
            call malloc (ptr, len, TY_PIXEL)
	$if (datatype == il)
            nstat = read (fd, Mem$t[ptr], len * SZ_INT32)
	    if (SZ_INT != SZ_INT32)
	        call iupk32 (Mem$t[ptr], Mem$t[ptr], len)
	$else
            nstat = read (fd, Mem$t[ptr], len * SZ_PIXEL)
	$endif
	$if (datatype == rd)
	call ieevupk$t (Mem$t[ptr], Mem$t[ptr], len)
	$endif
end

$endfor

# IP_AGETN -- Get an array of native floats from the file.  The data pointer is
# allocated if necessary and contains the data on output.

procedure ip_agetn (fd, ptr, len)

int     fd					#i file descriptor
pointer ptr					#i data pointer
int     len					#i length of array

int     nstat
int     read()

begin
        if (ptr == NULL)
            call malloc (ptr, len, TY_REAL)
        nstat = read (fd, Memr[ptr], len * SZ_REAL)
end


# IP_AGETN8 -- Get an array of native doubles from the file.  The data pointer
# is allocated if necessary and contains the data on output.

procedure ip_agetn8 (fd, ptr, len)

int     fd					#i file descriptor
pointer ptr					#i data pointer
int     len					#i length of array

int     nstat
int     read()

begin
        if (ptr == NULL)
            call malloc (ptr, len, TY_DOUBLE)
        nstat = read (fd, Memd[ptr], len * SZ_DOUBLE)
end


# -----------------------------------------------------------------
# ------------------ UTILITY FILE I/O FUNCTIONS -------------------
# -----------------------------------------------------------------


define	BLKSIZE		1024

# IP_LINE -- Return the offset of the start of the given line number.

int procedure ip_line (fd, line)

int	fd					#i input file descriptor
int	line					#i line number to search

pointer	sp, cbuf, buf
int	nl, offset, i, nread, fsize

int	read(), fstati()

define	done_ 	99
define	err_ 	98

begin
	if (line == 1) {
	    return (1)
	} else {
	    call smark (sp)
	    call salloc (buf, BLKSIZE, TY_CHAR)
	    call salloc (cbuf, BLKSIZE, TY_CHAR)

	    # Rewind file descriptor
	    call ip_lseek (fd, BOF)
	    nl = 1
	    offset = 1
	    
	    nread = BLKSIZE / SZB_CHAR
	    fsize = fstati (fd, F_FILESIZE)
	    while (read (fd, Memc[buf], nread) != EOF) {
		# Convert it to spp chars.
	        call ip_lskip (fd, nread)
        	call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE)
		do i = 1, BLKSIZE {
		    if (Memc[cbuf+i-1] == '\n') {
		        nl = nl + 1
		        offset = offset + 1
		        if (nl == line)
			    goto done_
	 	    } else
		        offset = offset + 1
		    if (offset >= fsize)
		        goto err_
		}
	    }
err_	    call sfree (sp)
	    call ip_lseek (fd, BOF)
	    return (ERR)

done_	    if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) }
	    call sfree (sp)
	    call ip_lseek (fd, offset)
	    return (offset)
	}
end


# IP_LOCATE -- Return the offset of the start of the given pattern.

int procedure ip_locate (fd, offset, pattern)

int     fd                                      #i input file descriptor
int	offset					#i offset to begin search
char	pattern[ARB]                            #i pattern to locate

pointer	sp, cbuf, buf
int     fsize, nread, patlen, cur_offset, loc

int     fstati(), read(), strsearch(), strlen()

define	done_	99

begin
        # Rewind file descriptor
        call ip_lseek (fd, offset)
	cur_offset = offset

	call smark (sp)
	call salloc (buf, BLKSIZE, TY_CHAR)
	call salloc (cbuf, BLKSIZE, TY_CHAR)

	if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)}

	nread = BLKSIZE / SZB_CHAR
	fsize = fstati (fd, F_FILESIZE)
	patlen = strlen (pattern)
        while (read (fd, Memc[buf], nread) != EOF) {
            # Convert it to spp chars.
	    call ip_lskip (fd, nread)
            call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE)
	    loc = strsearch (Memc[cbuf], pattern)
	    if (loc != 0) {
  		cur_offset = cur_offset + loc - 1 - patlen
        	goto done_
            } else {
		# Allow some overlap in case the pattern broke over the blocks.
                cur_offset = cur_offset + BLKSIZE - 2 * patlen
		call ip_lseek (fd, cur_offset)
		if (cur_offset + BLKSIZE > fsize)
		    nread = fsize - cur_offset + 1
            }
        }
	call sfree (sp)
	call ip_lseek (fd, BOF)
        return (ERR)

done_	if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)}
	call sfree (sp)
	call ip_lseek (fd, offset)
	return (cur_offset)
end


# IP_LSEEK -- Set the file position as a byte offset.

procedure ip_lseek (fd, offset)

int     fd					#i file descriptor
int     offset					#i requested offset

long    cur_offset, where, fsize
int	fstati()
common  /fiocom/ cur_offset

begin
	if (offset == BOF || offset == ERR) {
            cur_offset = 1
            call seek (fd, BOF)
	} else {
	    fsize = fstati (fd, F_FILESIZE) * SZB_CHAR
            cur_offset = min (fsize, offset)
	    where = min (fsize, (offset/SZB_CHAR+mod(offset,2)))
            call seek (fd, where)
	}
end


# IP_LNOTE -- Note the file position as a byte offset.

int procedure ip_lnote (fd)

int     fd					#i file descriptor (unused)

long    cur_offset
common  /fiocom/ cur_offset

begin
	return (cur_offset)
end


# IP_LSKIP -- Bump the file position by a byte offset.

procedure ip_lskip (fd, skip)

int     fd                                      #i file descriptor
int     skip

long    cur_offset
common  /fiocom/ cur_offset

begin
        call ip_lseek (fd, cur_offset+skip)
end