From Newsgroup: comp.lang.lisp

Rainer Joswig wrote:

(defun average-function (list)
(assert list (list)
"List should not be empty.")
(loop for i from 0
for item in list
sum item into result
finally (return (/ result i))))

Gauche Scheme

"!" is similar to "do".

(define (average-function seq)
(! (x :in seq
sum + x
i 0 +)
#f (/ sum (max i 1))))

gosh> (average-function '(2 3 4 5 6 ))
4
gosh> (average-function '())
0

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
->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 ...) ]
;;
[(_ ((a b ...) :on lst :by kdr z ...) stuff ...)
(!-aux (:let xs lst
:let ys #f
exhausted (null? xs) <>
dummy (begin (set! ys xs)
(when (pair? xs) (set! xs (kdr xs)))) <>
(:pop-or-nothing a ys #f)
(:pop-or-nothing b ys #f) ...
:till exhausted
z ...) stuff ...) ]
[(_ ((a b ...) :on lst z ...) stuff ...)
(!-aux ((a b ...) :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) ]
;; (!-aux () ((a b c) z ...) lets bool ! begin (print a)(sys-sleep 1)) ]
[(_ () 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