Test output for procedural-macros [ok]

Testing time: 1s

'/usr/home/chicken/salmonella/build/salmonella-run-publish/chicken/bin/csi' -script run.scm < /dev/null 2>&1

Testing procedural-macros ...
----------------------------
(define-macro
  (swap! x y)
  (where (x symbol?) (y symbol?))
  `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
... passed in (macros?)
(equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y)) '(y x))
... passed in (macros?)
(define-macro
  (nif xpr pos zer neg)
  `(cond ((positive? ,xpr) ,pos) ((negative? ,xpr) ,neg) (else ,zer)))
... passed in (macros?)
(eq? (nif 2 'positive 'zero 'negative) 'positive)
... passed in (macros?)
(define-macro (freeze xpr) `(lambda () ,xpr))
... passed in (macros?)
(= ((freeze 5)) 5)
... passed in (macros?)
(define-macro (swap! x y) `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
... passed in (macros?)
(equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y)) '(y x))
... passed in (macros?)
"LITERALS"
... passed in (macros?)
(define-syntax
  foo
  (macro-rules
    ()
    ((_ "foo" x) x)
    ((_ #f x) `(list 'false))
    ((_ #f x) 'false)
    ((_ a b) (where (a string?)) `(list ,a ,b))
    ((_ a b) (where (a odd?)) `(list ,a ,b))
    ((_ a b) a)))
... passed in (macros?)
(= (foo "foo" 1) 1)
... passed in (macros?)
(equal? (foo "bar" 2) '("bar" 2))
... passed in (macros?)
(equal? (foo #f 'blabla) '(false))
... passed in (macros?)
(equal? (foo 1 2) '(1 2))
... passed in (macros?)
(= (foo 2 3) 2)
... passed in (macros?)
(define-macro (bar #() x) (where (x integer?)) x)
... passed in (macros?)
(= (bar #() 5) 5)
... passed in (macros?)
(define-macro (qux #f) #t)
... passed in (macros?)
(qux #f)
... passed in (macros?)
"IN?"
... passed in (macros?)
(define-macro
  (in? what equ? . choices)
  (let ((insym 'in))
    `(let ((,insym ,what))
       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice)) choices)))))
... passed in (macros?)
(in? 2 = 1 2 3)
... passed in (macros?)
(not (in? 5 = 1 2 3))
... passed in (macros?)
"VERBOSE IFS"
... passed in (macros?)
(define-syntax
  vif
  (macro-rules
    (then else)
    ((_ test (then . xprs)) `(if ,test (begin ,@xprs)))
    ((_ test (else . xprs)) `(if ,(not test) (begin ,@xprs)))
    ((_ test (then . xprs) (else . yprs))
     `(if ,test (begin ,@xprs) (begin ,@yprs)))))
... passed in (macros?)
(define (oux) (vif #t (then 'true)))
... passed in (macros?)
(define (pux) (vif #f (else 'false)))
... passed in (macros?)
(eq? (oux) 'true)
... passed in (macros?)
(eq? (pux) 'false)
... passed in (macros?)
"LOW-LEVEL COND"
... passed in (macros?)
(define-syntax
  my-cond
  (macro-rules
    (else =>)
    ((_ (else xpr . xprs)) `(begin ,xpr ,@xprs))
    ((_ (test => xpr)) `(let ((tmp ,test)) (if tmp (,xpr tmp))))
    ((_ (test => xpr) . clauses)
     `(let ((tmp ,test)) (if tmp (,xpr tmp) (my-cond ,@clauses))))
    ((_ (test)) `(if #f #f))
    ((_ (test) . clauses)
     `(let ((tmp ,test)) (if tmp tmp (my-cond ,@clauses))))
    ((_ (test xpr . xprs)) `(if ,test (begin ,xpr ,@xprs)))
    ((_ (test xpr . xprs) . clauses)
     `(if ,test (begin ,xpr ,@xprs) (my-cond ,@clauses)))))
... passed in (macros?)
(my-cond ((> 3 2)))
... passed in (macros?)
(eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less)) 'greater)
... passed in (macros?)
(eq? (my-cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)) 'equal)
... passed in (macros?)
(= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr) (else #f)) 2)
... passed in (macros?)
(not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr) (else #f)))
... passed in (macros?)
"LETREC"
... passed in (macros?)
(define-macro
  (my-letrec pairs . body)
  (where (pairs (list-of? pair?)))
  (let ((vars (map car pairs))
        (vals (map cadr pairs))
        (aux (map (lambda (x) (gensym)) pairs)))
    `(let ,(map (lambda (var) `(,var #f)) vars)
       (let ,(map (lambda (a v) `(,a ,v)) aux vals)
         ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
         ,@body))))
... passed in (macros?)
(equal?
  (my-letrec
    ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
    (list (o? 95) (e? 95)))
  '(#t #f))
... passed in (macros?)
"GENERIC ADD"
... passed in (macros?)
(define-syntax
  add
  (macro-rules
    ()
    ((_ x y) (where (x string?) (y string?)) `(string-append ,x ,y))
    ((_ x y) (where (x integer?) (y integer?)) `(+ ,x ,y))))
... passed in (macros?)
(= (add 1 2) 3)
... passed in (macros?)
(string=? (add "x" "y") "xy")
... passed in (macros?)
"ANAPHORIC MACROS"
... passed in (macros?)
(define-syntax
  alambda
  (macro-rules
    self
    ()
    ((_ args xpr . xprs)
     `(letrec ((,self (lambda ,args ,xpr ,@xprs))) ,self))))
... passed in (macros?)
(equal?
  (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
  '(1 2 6 24 120))
... passed in (macros?)
(define-syntax
  aif
  (macro-rules
    it
    ()
    ((_ test consequent) `(let ((,it ,test)) (if ,it ,consequent)))
    ((_ test consequent alternative)
     `(let ((,it ,test)) (if ,it ,consequent ,alternative)))))
... passed in (macros?)
(define (mist x)
  (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
... passed in (macros?)
(= (mist 5) 120)
... passed in (macros?)
"ONCE-ONLY"
... passed in (macros?)
(define counter (let ((state 0)) (lambda () (set! state (+ state 1)) state)))
... passed in (macros?)
(define-macro (square x) (once-only (x) `(* ,x ,x)))
... passed in (macros?)
(= (square (counter)) 1)
... passed in (macros?)
(= (square (counter)) 4)
... passed in (macros?)
(= (square (counter)) 9)
... passed in (macros?)
(define-macro
  (for (var start end) . body)
  (once-only
    (start end)
    `(do ((,var ,start (add1 ,var))) ((= ,var ,end)) ,@body)))
... passed in (macros?)
(let ((lst '()))
  (for (x 0 (counter)) (set! lst (cons x lst)))
  (equal? lst '(3 2 1 0)))
... passed in (macros?)
"LOCAL VARIABLES AVAILABLE IN EACH RULE"
... passed in (macros?)
(define-syntax
  add2
  (let ((id (lambda (n) n)))
    (macro-rules () ((_ x) `(+ ,(id x) 2)) ((_ x y) `(+ ,(id x) ,(id y) 2)))))
... passed in (macros?)
(= (add2 5) 7)
... passed in (macros?)
(= (add2 5 7) 14)
... passed in (macros?)
"LET AND LETREC"
... passed in (macros?)
(= (macro-letrec
     (((sec lst) `(car (res ,lst))) ((res lst) `(cdr ,lst)))
     (sec '(1 2 3)))
   2)
... passed in (macros?)
(= (macro-let
     (((fir lst) (where (lst list?)) `(car ,lst))
      ((res lst) (where (lst list?)) `(cdr ,lst)))
     (fir (res '(1 2 3))))
   2)
... passed in (macros?)
(equal?
  (macro-letrec
    (((swap1 x y) `(swap2 ,x ,y))
     ((swap2 x y)
      (where (x symbol?) (y symbol?))
      `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
    (let ((x 'x) (y 'y)) (swap1 x y) (swap2 x y) (list x y)))
  '(x y))
... passed in (macros?)
(equal?
  (macro-let
    (((swap1 x y) `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
     ((swap2 x y) `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
    (let ((x 'x) (y 'y)) (swap1 x y) (swap2 x y) (list x y)))
  '(x y))
... passed in (macros?)

Results of procedural-macros
----------------------------
All tests passed