home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / mwtest < prev    next >
Text File  |  1994-05-25  |  6KB  |  213 lines
  1. ; "mwtest.scm" test macros-that-work
  2. ; From: William Clinger
  3.  
  4. ; A short test suite.
  5. ; Uses PRETTY-PRINT and EVAL, neither of which is standard Scheme.
  6. ; Redefine f and g as desired to fix this.
  7.  
  8. (require 'pretty-print)
  9. (require 'macros-that-work)
  10.  
  11. ; The value returned by MACWORK:EXPAND is expressed using keywords
  12. ; defined in "prefs.sch", which might not be the keywords expected
  13. ; by EVAL.
  14.  
  15. (define begin0  'begin)
  16. (define define0 'define)
  17. (define quote0  'quote)
  18. (define lambda0 'lambda)
  19. (define if0     'if)
  20. (define set!0   'set!)
  21.  
  22. (define begin2  mw:begin1)
  23. (define define2 mw:define1)
  24. (define quote2  mw:quote1)
  25. (define lambda2 mw:lambda1)
  26. (define if2     mw:if1)
  27. (define set!2   mw:set!1)
  28.  
  29. (define original-code #f) ; assigned by f, used by g
  30. (define expanded-code #f) ; assigned by f, used by g
  31.  
  32. (define (f x)
  33.   (set! original-code x)
  34.   (set! mw:begin1  begin2)
  35.   (set! mw:define1 define2)
  36.   (set! mw:quote1  quote2)
  37.   (set! mw:lambda1 lambda2)
  38.   (set! mw:if1     if2)
  39.   (set! mw:set!1   set!2)
  40.   (set! expanded-code (macwork:expand x))
  41.   (pretty-print expanded-code)
  42.   )
  43.  
  44. (define (g answer)
  45.   (set! mw:begin1  begin0)
  46.   (set! mw:define1 define0)
  47.   (set! mw:quote1  quote0)
  48.   (set! mw:lambda1 lambda0)
  49.   (set! mw:if1     if0)
  50.   (set! mw:set!1   set!0)
  51.   (if (not (equal? (slib:eval (macwork:expand original-code)) answer))
  52.       (begin (newline)
  53.              (display "TEST FAILED!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
  54.              (newline)
  55.  
  56.              (display "Original code was:")
  57.              (newline)
  58.              (pretty-print original-code)
  59.              (newline)
  60.              (newline))
  61.       #t))
  62.  
  63. (f '(let ((a 3)) a))
  64. (g 3)
  65.  
  66. (f '(let ((=> #f))
  67.          (cond (#t => 'ok))))
  68. (g 'ok)
  69.  
  70. ; This syntax of set*! matches that of an example in the R4RS.
  71. ; That example was put forth as an example of a hygienic macro
  72. ; that supposedly couldn't be written using syntax-rules.  Hah!
  73.  
  74. (f '(define-syntax set*!
  75.       (syntax-rules
  76.        ()
  77.        ((set*! (?var ?val) ...)
  78.         (set*!-help (?val ...) () (?var ?val) ...)))))
  79.  
  80. (f '(define-syntax set*!-help
  81.       (syntax-rules
  82.        ()
  83.        ((set*!-help () (?temp ...) (?var ?val) ...)
  84.         (let ((?temp ?val) ...)
  85.           (set! ?var ?temp) ...))
  86.        ((set*!-help (?var1 ?var2 ...) ?temps ?assignments ...)
  87.         (set*!-help (?var2 ...) (temp . ?temps) ?assignments ...)))))
  88.  
  89. (f '(let ((x 3)
  90.           (y 4)
  91.           (z 5))
  92.          (set*! (x (+ x y z))
  93.                 (y (- x y z))
  94.                 (z (* x y z)))
  95.          (list x y z)))
  96. (g '(12 -6 60))
  97.  
  98. (f
  99.  '(let ((else #f))
  100.        (cond (#f 3)
  101.              (else 4)
  102.              (#t 5))))
  103. (g '5)
  104.  
  105. (f '(define-syntax push
  106.       (syntax-rules ()
  107.         ((push item place)
  108.          (set! place (cons item place))))))
  109.  
  110. (f '(let* ((cons (lambda (name)
  111.                    (case name
  112.                      ((phil)  '("three-card monte"))
  113.                      ((dick)  '("secret plan to end the war"
  114.                                 "agnew"
  115.                                 "not a crook"))
  116.                      ((jimmy) '("why not the best"))
  117.                      ((ron)   '("abolish the draft"
  118.                                 "balance the budget"))
  119.                      (else    '()))))
  120.            (scams (cons 'phil)))
  121.           (push (car (cons 'jimmy)) scams)
  122.           (push (cadr (cons 'ron)) scams)
  123.           scams))
  124. (g '("balance the budget" "why not the best" "three-card monte"))
  125.  
  126. ; Tests of quasiquote and the vector extension.
  127.  
  128. (f '`(list ,(+ 1 2) 4))
  129. (g '(list 3 4))
  130.  
  131. (f '(let ((name 'a)) `(list ,name ',name)))
  132. (g '(list a (quote a)))
  133.  
  134. (f '`(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
  135. (g '(a 3 4 5 6 b))
  136.  
  137. (f '`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
  138. (g '((foo 7) . cons))
  139.  
  140. (f '`#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
  141. (g '#(10 5 2 4 3 8))
  142.  
  143. ;(f '(let ((who "hoo")
  144. ;          (are "r")
  145. ;          (you "u"))
  146. ;         `#(#(,who ,are ,you)
  147. ;            #(,@(list you are who))
  148. ;            #(you are who?))))
  149. ;(g '#(#("hoo" "r" "u") #("u" "r" "hoo") #(you are who?)))
  150.  
  151. ; Tests of the ::: escape symbol.
  152.  
  153. ; This syntax of set*! matches the syntax of an example in
  154. ; Clinger, "Macros in Scheme".  It is a slightly more difficult
  155. ; syntax than the syntax in R4RS.
  156. ; Note that pattern variables within the scope of the ::: are
  157. ; still expanded, so the auxiliary macro's pattern variables
  158. ; must be different from those of the outer macro.
  159.  
  160. (f '(define-syntax set*!
  161.       (syntax-rules ()
  162.        ((set*! i1 e1 more ...)
  163.         (letrec-syntax
  164.           ((set*!-aux
  165.             (::: (syntax-rules ()
  166.                   ((set*!-aux ((i1_ e1_ t1) ...))
  167.                    (let ((t1 e1_) ...)
  168.                      (set! i1_ t1) ...))
  169.                   ((set*!-aux ((i1_ e1_ t1) ...) i2 e2 more_ ...)
  170.                    (set*!-aux ((i1_ e1_ t1) ... (i2 e2 newtemp)) more_ ...))))))
  171.           (set*!-aux () i1 e1 more ...))))))
  172.  
  173. (f '(let ((x 3)
  174.           (y 4)
  175.           (z 5))
  176.          (set*! x (+ x y z)
  177.                 y (- x y z)
  178.                 z (* x y z))
  179.          (list x y z)))
  180. (g '(12 -6 60))
  181.  
  182. ; Tests of the scoping extension.
  183.  
  184. (f '(define-syntax set! let*
  185.       (syntax-rules (car cdr vector-ref)
  186.         ((set! (car x) y)          (set-car! x y))
  187.         ((set! (cdr x) y)          (set-cdr! x y))
  188.         ((set! (vector-ref x e) y) (vector-set! x e y))
  189.         ((set! x y)                (set! x y)))))
  190.  
  191. (f '(let* ((days (list 'monday 'wednesday 'friday))
  192.            (day1 '(sunday)))
  193.           (set! (car days) 'tuesday)
  194.           (set! day1 (car days))
  195.           day1))
  196. (g 'tuesday)
  197.  
  198. (f '(define-syntax set! let*
  199.       (syntax-rules (string-ref)
  200.         ((set! (string-ref x e) y) (string-set! x e y))
  201.         ((set! x y)                (set! x y)))))
  202.  
  203. (f '(let* ((o (make-string 3 #\o))
  204.            (v (vector o o o))
  205.            (s "woo"))
  206.           (set! (string-ref o 0) #\h)
  207.           (set! (vector-ref v 0) "boo")
  208.           (set! s (string-append (vector-ref v 0)
  209.                                  (vector-ref v 1)
  210.                                  s))
  211.           s))
  212. (g '"boohoowoo")
  213.