From Newsgroup: comp.lang.scheme

B. Pym wrote:

Pascal Costanza wrote:

I have used NRECONC. When you are processing a list and the
interesting stuff is at the head of the list, you write a loop like
this:

(do ((tail list (cdr tail))
(processed '() (cons (do-something (car tail))
processed)))
((done? ...) (nreconc processed tail)))

The nreconc reverses the processed stuff (which is accumulated
backwards) and pastes it on to the remaining element of LIST.

Ah, finally a clue. Thanks for that!

Indeed, I could have used something like that before, but came up with a solution with LOOP that looks like this:

(loop for (car . cdr) on list
collect (do-something car) into processed
until done
finally (return (nconc processed cdr)))

Gauche Scheme

(use srfi-1) ;; span

(receive (nums rest) (span number? '(2 3 4 a b c))
(append (map square nums) rest))
===>
(4 9 16 a b c)

(lope dolist-by x xs cdr '(2 3 4 a b c)
until (not (number? x))
collect-in (sqr x) processed
returning (append processed xs))

'(4 9 16 a b c)

Gauche Scheme

"!" is similar to "do".

(! ((x . xs) :on '(2 3 4 a b c)
r cons (square x))
(not (number? x)) (append-reverse r (cons x xs)))

===>
(4 9 16 a b c)

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 ...) ]
[(_ (: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 '!'") ]
;;
;; [(_ ((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 :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) ]
;; (!-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