Re: iff?

[thi]

   From: Jim Blandy <address@hidden>
   Date: 25 Apr 2001 15:04:31 -0500

   I think that's a splendid idea.

   I don't think the details (markup vs. special form) matter very much.

below is some file-string-pool stuff that we might use...  (i am
probably going to use this for generating non-resident docs for
ttn-pers-scheme.)  to experiment, try:

(use-modules (ttn file-string-pool))
(write-string-pool "/tmp/z" standard-stash '("a" "list" "of" "strings"))
(read-string-pool "/tmp/z" standard-unstash)

there's also `read-string-pool-one' which is designed for use w/
customized stashing/unstashing (indexing for efficiency, for example).
the `standard-select' is not very useful.

thi


___________________________________
;;; ttn/file-string-pool.scm --- Access/modify a string pool in a file

;; $State$:$Name$
;;
;; Copyright (C) 2001 Thien-Thi Nguyen
;; This file is part of ttn's personal scheme library, released under GNU
;; GPL with ABSOLUTELY NO WARRANTY.  See the file COPYING for details.

;;; Commentary:

;; In the file, format is:
;; (version 1)
;; (length N) (HEADER ...)
;; strings ...

;;; Code:

(define-module (ttn file-string-pool)
  :autoload (ice-9 common-list) (find-if)
  :use-module (ttn echo))

(define file-string-pool-version 1)

(define (standard-stash string offset length)
  (list offset length))

(define (write-string-pool file stash ls)
  (with-output-to-file file
    (lambda ()
      (echo `(version ,file-string-pool-version))
      (let loop ((ls ls) (ofs 0) (headers '()))
        (if (null? ls)
            (echo `(length ,ofs) (reverse headers))
            (let* ((s (car ls))
                   (len (string-length s)))
              (loop (cdr ls)
                    (+ ofs len)
                    (cons (stash s ofs len) headers)))))
      (for-each display ls))))

(define (standard-unstash port base offset length)
  (seek port (+ base offset) SEEK_SET)
  (let ((str (make-string length)))
    (do ((so-far 0 (+ so-far (read-string!/partial str port so-far))))
        ((= so-far length)))
    str))

(define (read-string-pool file unstash)
  (with-input-from-file file
    (lambda ()
      (or (equal? `(version ,file-string-pool-version) (read))
          (error "bad version"))
      (let* ((length (cadr (read)))
             (headers (read))
             (cip (current-input-port))
             (base (1+ (seek cip 0 SEEK_CUR))))
        (map (lambda (header)
               (apply unstash cip base header))
             headers)))))

(define (standard-select header) header)

(define (read-string-pool-one file select unstash)
  (with-input-from-file file
    (lambda ()
      (or (equal? `(version ,file-string-pool-version) (read))
          (error "bad version"))
      (let* ((length (cadr (read)))
             (headers (read))
             (cip (current-input-port))
             (base (1+ (seek cip 0 SEEK_CUR))))
        (apply unstash cip base (find-if select headers))))))

(export standard-stash
        write-string-pool

        standard-unstash
        read-string-pool

        standard-select
        read-string-pool-one)

;;; ttn/file-string-pool.scm ends here