From Newsgroup: comp.lang.scheme

Zach Beane wrote:

The following is something I wrote recently to load words of a
specified length from a dictionary file:

(defun load-words (file length)
(let ((words (make-array 25000 :adjustable t :fill-pointer 0)))
(with-open-file (stream file :direction :input)
(loop for word = (read-line stream nil stream)
until (eq word stream)
when (= (length word) length)
do (vector-push-extend word words)))
words))

Gauche Scheme

(use gauche.sequence) ;; size-of instead of string-length

(define (read-words file len)
(list->vector
(with-input-from-file file
(^()
(do* ((r '() (cons-if (= len (size-of word)) word r))
(word (read-line) <> ))
((eof-object? word) @ r))))))

(read-words "../ruby/words" 21)

===>
#("alkylbenzenesulfonate" "bicycle-built-for-two" "chromatopseudoblepsis"
"electroencephalograph" "hypogammaglobulinemia" "immunoelectrophoresis"
"pellitory-of-the-wall" "psychopharmacological")

Given:

(define (cons-if bool x xs) (if bool (cons x xs) xs))

(define-syntax pop~
(syntax-rules ()
[ (pop~ List) (and (pair? List) (pop! List)) ]))

(define-syntax do*-aux
(syntax-rules ( <> @ :in :on :to-till :su )
;; Simultaneous updates.
[ (do*-aux ((:su (v i u) ...) z ...) stuff ...)
(do*-aux ((v i) ...
(dummy #f
(set!-values (v ...) (apply values (list u ...))))
z ...) stuff ...) ]
[ (do*-aux ((:to-till a ...) z ...) lets sets (bool r ...) stuff ...)
(do*-aux (z ...) lets sets ((or a ... bool) r ...) stuff ...) ]
[ (do*-aux s lets sets (bool more ... @ r) body ...)
(do*-aux s lets sets (bool more ... (reverse r)) body ...) ]
[ (do*-aux (((v ...) :on xs) z ...) stuff ...)
(do*-aux ((:to-till (null? xlist) (begin (set! v (pop~ xlist)) ... #f))
(xlist xs) (v #f) ... z ...) stuff ...) ]
[ (do*-aux ((ys :on xs kdr) z ...) lets sets (bool r ...) stuff ...)
(do*-aux ((ys xs (kdr ys)) z ...) lets sets
((or (null? ys) bool) r ...) stuff ...) ]
[ (do*-aux ((ys :on xs) z ...) stuff ...)
(do*-aux ((ys :on xs cdr) z ...) stuff ...) ]
[ (do*-aux (((v ...) :in xs) z ...) stuff ...)
(do*-aux ((:to-till (null? xlist))
(xlist xs (cdr xlist))
(v #f) ...
(dummy (and (pair? xlist)
(set!-values (v ...) (apply values (car xlist))))
<>) z ...) stuff ...) ]
[ (do*-aux ((x :in xs) z ...) stuff ...)
(do*-aux ((:to-till (null? xlist))
(xlist xs (cdr xlist))
(x (and (pair? xlist) (car xlist)) <> )
z ...) stuff ...) ]
[ (do*-aux ((hd tl :in xs) z ...) stuff ...)
(do*-aux ((:to-till (null? xlist))
(xlist xs (cdr xlist))
(hd (and (pair? xlist) (car xlist)) <> )
(tl (and (pair? xlist) (cdr xlist)) <> )
z ...) stuff ...) ]
[ (do*-aux ((var init <>) z ...) stuff ...)
(do*-aux ((var init init) z ...) stuff ...) ]
[ (do*-aux ((var init update) z ...) (lets ...) (sets ...) stuff ...)
(do*-aux (z ...) (lets ... (var init))
(sets ... (set! var update)) stuff ...) ]
[ (do*-aux ((var init) z ...) (lets ...) stuff ...)
(do*-aux (z ...) (lets ... (var init)) stuff ...) ]
[ (do*-aux () (lets ...) (sets ...) (bool more ...) body ...)
(let* (lets ...)
(if bool
(begin more ...)
(begin
body ...
(let go ()
sets ...
(if bool
(begin more ...)
(begin body ... (go))))))) ] ))

(define-syntax do*
(syntax-rules ( )
[ (do* specs till body ...)
(do*-aux specs () () till body ...) ] ))
--
[T]he problem is that lispniks are as cultish as any other
devout group and basically fall down frothing at the mouth if
they see [heterodoxy]. --- Kenny Tilton (05 Dec 2004)
--- Synchronet 3.21a-Linux NewsLink 1.2