From Newsgroup: comp.lang.lisp

(defpackage :words (:use))
(format
t "~{~{~A~^ ~}~%~}"
(let ((table (make-hash-table)))
(mapcar
(lambda (k) (sort (gethash k table) (function string-lessp)))
(sort (delete-duplicates
(with-open-file (words "/usr/share/dict/words")
(loop :for w = (read-line words nil nil)
:for k = (intern (sort (string-upcase w)
(function char<=)) :words)
:while w :do (push w (gethash k table nil)) :collect k)))
(lambda (a b) (>= (length (string a)) (length (string b))))))))

Gauche Scheme

"!" is similar to "do".

(let ((table (make-hash-table 'string=?)))
(with-input-from-file "words" (lambda()
(! (w :gen read-line)
#f 'ok
(hash-table-push! table (sort w) w))))
(dolist
(el (sort (hash-table->alist table) >= (compose string-length car)))
(print (string-join (sort (cdr el))))))

Given:

(define (!-flatten it)
(if (null? it) '()
(if (pair? it)
(append (flatten (car it)) (flatten (cdr it)))
(list it))))

(define-syntax !-aux
(syntax-rules (<> @ @@ + - : cons append :meld
cdr :in :across :along
:on :by :pop-or-nothing
:if :if-else ! :also? :also :to :repeat
:till :always :gen
->lets :let := )
[(_ specs seen lets @)
(!-aux specs seen lets #f @) ]
[(_ (->lets ((id val) ...) z ...) seen (lets ...) stuff ...)
(!-aux (z ...) seen (lets ... (id val) ...) stuff ...) ]
[(_ (:let id val z ...) stuff ...)
(!-aux (->lets ((id val)) z ...) stuff ...) ]
[(_ (:= id val z ...) stuff ...)
(!-aux (:let id #f dummy #f (set! id val) z ...) stuff ...) ]
;;
[(_ (:also? bool op x z ...) (seen ... (v i update)) stuff ...)
(!-aux (z ...)
(seen ... (v i (if bool (op x update) update)))
stuff ...) ]
[(_ (:also op x z ...) stuff ...)
(!-aux (:also? #t op x z ...) stuff ...) ]
;;
[(_ ((:pop-or-nothing x xs nil) z ...) stuff ...)
(!-aux (x (if (pair? xs)(pop! xs) nil) <> z ...) stuff ...) ]
;;
[(_ (:always expr z ...) seen lets bool)
(!-aux (ok #t expr
:till (not ok)
z ...)
seen lets bool ok
) ]
[(_ (:always expr z ...) stuff ...)
(!-aux " * * * Bad usage of :always in '!'") ]
[(_ (:till expr z ...) seen lets #f stuff ...)
(!-aux (z ...) seen lets expr stuff ...) ]
[(_ (:till expr z ...) seen lets bool stuff ...)
(!-aux (z ...) seen lets (or expr bool) stuff ...) ]
;;
[(_ (:if bool z ...) (seen ... (v i u)) stuff ...)
(!-aux (z ...)
(seen ... (v i (if bool u v))) stuff ...) ]
;;
[(_ (:if-else bool z ...) (seen ... (a b c)(d e f)) stuff ...)
(!-aux (:let yes #f z ...)
(seen ... (a b (begin (set! yes bool) (if yes c a)))
(d e (if (not yes) f d))) stuff ...) ]
[(_ (:if bool z ...) stuff ...)
(!-aux
" * * * :if used at bad location in '!'; it's postfix.") ]
[(_ (:if-else bool z ...) stuff ...)
(!-aux
" * * * :if-else used without 2 preceding assignments in '!'") ]
;;
[(_ (w :gen func z ...) stuff ...)
(!-aux (:let fun func
w (fun) (fun)
:till (eof-object? w) z ...) stuff ...) ]
;;
[(_ ((a b ...) :on lst :by kdr z ...) stuff ...)
(!-aux (:let xs lst
:let ys #f
dummy (set! ys xs) <>
(:pop-or-nothing a ys #f)
(:pop-or-nothing b ys #f) ...
:till (or (null? xs) (begin (set! xs (kdr xs)) #f))
z ...) stuff ...) ]
[(_ ((a b ...) :on lst z ...) stuff ...)
(!-aux ((a b ...) :on lst :by cdr z ...) stuff ...) ]
;;
[(_ ((y . ys) :on lst :by kdr z ...) stuff ...)
(!-aux (:let xs lst
y (if (null? xs) #f (car xs)) <>
ys (if (null? xs) #f (cdr xs)) <>
:till (or (null? xs) (begin (pop! xs) #f))
z ...) stuff ...) ]
[(_ ((y . ys) :on lst z ...) stuff ...)
(!-aux ((y . ys) :on lst :by cdr z ...) stuff ...) ]
;;
[(_ (s :on lst :by kdr z ...) stuff ...)
(!-aux (s lst (kdr s)
:till (null? s) z ...) stuff ...) ]
[(_ (s :on lst z ...) stuff ...)
(!-aux (s :on lst :by cdr z ...) stuff ...) ]
;;
[(_ ((c d ...) :in lst z ...) stuff ...)
(!-aux (->lets ((xs lst) (c #f) (d #f) ...)
dummy (if (pair? xs)
(set!-values (c d ...)(apply values (!-flatten(pop! xs))))
(set! c !-aux)) <>
:till (eq? c !-aux)
z ...) stuff ...) ]
[(_ (x :in lst z ...) stuff ...)
(!-aux (:let xs lst
x (if (pair? xs)(pop! xs) !-aux) <>
:till (eq? x !-aux)
z ...) stuff ...) ]
;;
[(_ (x :across vec z ...) stuff ...)
(!-aux (:let v vec :let i 0
x (if (< i (vector-length v))
(begin0 (vector-ref v i) (inc! i))
!-aux) <>
:till (eq? x !-aux)
z ...) stuff ...) ]
[(_ (ch :along str z ...) stuff ...)
(!-aux (:let s str :let i 0
ch (and (< i (string-length s))
(begin0 (string-ref s i) (inc! i))) <>
:till (not ch)
z ...)
stuff ...) ]
[(_ (a b <> z ...) stuff ...)
(!-aux (a b b z ...) stuff ...) ]
;;
[(_ (a b + z ...) stuff ...)
(!-aux (a b (+ 1 a) z ...) stuff ...) ]
[(_ (a + n z ...) stuff ...)
(!-aux (a 0 (+ n a) z ...) stuff ...) ]
[(_ (a b - z ...) stuff ...)
(!-aux (a b (- a 1) z ...) stuff ...) ]
[(_ (n lo inc :to hi z ...) stuff ...)
(!-aux (:let step inc :let high hi
n lo (+ n step)
:till (> n high)
z ...) stuff ...) ]
[(_ (n lo :to hi z ...) stuff ...)
(!-aux (n lo 1 :to hi z ...) stuff ...) ]
[(_ (:repeat n z ...) stuff ...)
(!-aux (m 1 :to n z ...) stuff ...) ]
;;
[(_ (v init : kons u z ...) stuff ...)
(!-aux (v init (kons u v) z ...) stuff ...) ]
;;
[(_ (a cons b z ...) stuff ...)
(!-aux (a '() : cons b z ...) stuff ...) ]
[(_ (a append b z ...) stuff ...)
(!-aux (a '() : append (reverse b) z ...) stuff ...) ]
[(_ (a :meld b z ...) stuff ...)
(!-aux (a '()
(if (pair? b) (append (reverse b) a)
(cons b a))
z ...) stuff ...) ]
;;
[(_ (a b cdr z ...) stuff ...)
(!-aux (a b (cdr a) z ...) stuff ...) ]
[(_ (a b c z ...) (seen ...) stuff ...)
(!-aux (z ...) (seen ... (a b c)) stuff ...) ]
[(_ (a b) (seen ...) stuff ...)
(!-aux () (seen ... (a b)) stuff ...) ]
[(_ (a) (seen ...) stuff ...)
(!-aux () (seen ... (a '())) stuff ...) ]
;; Default action is print first variable.
[(_ () ((a b c) z ...) lets bool !)
(!-aux () ((a b c) z ...) lets bool ! print a) ]
[(_ () seen lets bool ! action ...)
(!-aux () seen lets bool #t (action ...)) ]
;; If result not specified, pick one.
[(_ () ((a b c) z ...) lets bool)
(!-aux () ((a b c) z ...) lets bool
(if (pair? a) (reverse a) a)) ]
[(_ () ((a b c) z ...) lets bool @)
(!-aux () ((a b c) z ...) lets bool (reverse a)) ]
[(_ () seen lets bool @ result stuff ...)
(!-aux () seen lets bool (reverse result) stuff ...) ]
;;
[(_ () seen lets bool @@ (what x ...) stuff ...)
(!-aux () seen lets bool (what (reverse x) ...) stuff ...) ]
[(_ () seen lets bool (what @ x z ...) stuff ...)
(!-aux () seen lets bool (what (reverse x) z ...) stuff ...) ]
[(_ () seen lets bool (what x @ y z ...) stuff ...)
(!-aux () seen lets bool (what x (reverse y) z ...) stuff ...) ]
;;
[(_ () ((a b c) z ...) lets 0 stuff ...)
(!-aux () ((a b c) z ...) lets (= 0 a) stuff ...) ]
[(_ () seen lets bool result stuff ...)
(let lets (do seen (bool result) stuff ...)) ]
))
(define-syntax !
(syntax-rules ()
[(_ specs bool stuff ...)
(!-aux specs () () bool stuff ...) ]
[(_ specs) (! specs #f) ]
))
--- Synchronet 3.21a-Linux NewsLink 1.2