Re: Random File Access in Scheme48?

   Date: Fri, 6 Aug 2010 15:01:06 -0400
   From: Jake Bartlett <[email protected]>

   Is there any way to do random file access in Scheme48?  I'm looking for
   something like C's fseek function.  I didn't see anything in the manual.

Nothing built-in.  Here's a quick hack with the FFI.  The tricky part
is handling the port's buffer, which I don't think is possible to
synchronize safely between multiple threads given what Scheme48 has,
so don't use this hack with multiple threads operating on a single
port.  Unfortunately, on systems with 32-bit long and 64-bit off_t,
this loses, because Scheme48 has no way to handle C integers wider
than long.  Lightly tested.

/* seek.c */

/* Run `gcc -shared -o seek.so seek.c' or whatever.  */

#include <errno.h>
#include <scheme48.h>
#include <unistd.h>

static s48_value
s48_channel_seek (s48_value fd_s48,
                  s48_value offset_s48,
                  s48_value command_s48)
{
  int fd;
  off_t offset;
  int command;
  off_t result;
  s48_value result_s48 = S48_UNSPECIFIC;
  S48_DECLARE_GC_PROTECT (4);
  S48_GC_PROTECT_4 (fd_s48, offset_s48, command_s48, result_s48);

  fd = (s48_extract_integer (fd_s48));
  offset = (s48_extract_integer (offset_s48));

  switch (s48_extract_integer (command_s48))
    {
    case 0: command = SEEK_SET; break;
    case 1: command = SEEK_CUR; break;
    case 2: command = SEEK_END; break;
    default:
      {
        s48_value min_s48, max_s48;
        S48_DECLARE_GC_PROTECT (2);
        S48_GC_PROTECT_2 (min_s48, max_s48);
        min_s48 = (s48_enter_integer (0));
        max_s48 = (s48_enter_integer (2));
        s48_raise_range_error (command_s48, min_s48, max_s48);
        /* Not reached.  */
        S48_GC_UNPROTECT ();
        goto out;
      }
    }

  while (0 > (result = (lseek (fd, offset, command))))
    if (errno != EINTR)
      s48_raise_os_error (errno);

  result_s48 = (s48_enter_integer (result));

 out:
  S48_GC_UNPROTECT ();
  return (result_s48);
}

void
s48_on_load (void)
{
  S48_EXPORT_FUNCTION (s48_channel_seek);
}

void
s48_on_reload (void)
{
  s48_on_load ();
}

;;; seek.scm

; ,open channel-ports channels external-calls i/o ports
; ,open load-dynamic-externals
; (import-dynamic-externals "./seek.so")

(import-lambda-definition s48-channel-seek (fd offset command))

(define (channel-position channel)
  (s48-channel-seek (channel-os-index channel) 0 1))

(define (set-channel-position! channel position)
  (s48-channel-seek (channel-os-index channel) position 0))

(define (advance-channel-position! channel position)
  (s48-channel-seek (channel-os-index channel) position 1))

(define (set-channel-position-from-end! channel position)
  (s48-channel-seek (channel-os-index channel) position 2))

(define (port-position port)
  (let ((channel (port->channel port)))
    (if (not channel) (error "Not a channel port:" port))
    (+ (channel-position channel)
       (port-buffer-position-adjustment port))))

(define (port-buffer-position-adjustment port)
  (cond ((input-port? port)
         (if (port-buffer port) (- (port-index port) (port-limit port)) 0))
        ((output-port? port)
         (if (port-limit port) (port-index port) 0))
        (else
         (error "What is it, if not an input port or an output port?" port))))

(define (with-port-repositioning port procedure)
  (if (output-port? port) (force-output port))
  (call-with-values procedure
    (lambda results
      (set-port-index! port 0)
      (set-port-limit! port 0)
      (apply values results))))

(define (set-port-position! port position)
  (let ((channel (port->channel port)))
    (if (not channel) (error "Not a channel port:" port))
    (with-port-repositioning port
      (lambda ()
        (set-channel-position! channel position)))))

(define (advance-port-position! port position)
  (let ((channel (port->channel port)))
    (if (not channel) (error "Not a channel port:" port))
    (with-port-repositioning port
      (lambda ()
        (advance-channel-position! channel position)))))

(define (set-port-position-from-end! port position)
  (let ((channel (port->channel port)))
    (if (not channel) (error "Not a channel port:" port))
    (with-port-repositioning port
      (lambda ()
        (set-channel-position-from-end! channel position)))))