Groups | Search | Server Info | Login | Register

Groups > comp.lang.scheme > #6567

Re: the "loop" macro

Cross-posted to 2 groups.

Show all headers | View raw

Kent M. Pitman wrote:

>  (loop for x in '(1 2 3 4 5 6 7) 
>     when (evenp x) 
>      collect x into evens 
>     else 
>      collect x into odds 
>     finally 
>      (return (values evens odds))) 
>  => (2 4 6), (1 3 5 7) 

It's much shorter if we use a Lispy language
instead of CL.

Gauche Scheme

"!" is similar to "do".

(! (x :in '(1 2 3 4 5 6 7)
      evens cons x
      odds cons x
    :if-else (even? x))
  #f @@ (values evens odds))

  ===>
(2 4 6)
(1 3 5 7)

Given:

(define-syntax !-aux
  (syntax-rules (<> @ @@  + -  :  cons append :meld
                 cdr  :in :across :along
                 :on :by :pop-or-nothing
                 :if :if-else  !  :also? :also :to
                 :till  :always
                 :let := )
    [(_ specs seen lets @)
     (!-aux specs seen lets #f @) ]
    [(_ (:let id val  z ...) seen (lets ...) stuff ...)
     (!-aux (z ...) seen (lets ... (id val)) 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 ...) ]
    ;;
    [(_ (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 ...) ]
    ;;
    [(_ (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 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 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) ]
  ))

-- 
[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
The good news is, it's not Lisp that sucks, but Common Lisp. --- Paul Graham

Back to comp.lang.scheme | Previous | Next — Next in thread | Find similar

Thread

Re: the "loop" macro "B. Pym" <Nobody447095@here-nor-there.org> - 2025-08-28 19:51 +0000
  Re: the "loop" macro "B. Pym" <Nobody447095@here-nor-there.org> - 2025-08-28 19:58 +0000

csiph-web