~ chicken-core (chicken-5) /tests/module-tests-2.scm

  1;;;; module-tests-2.scm
  2
  3
  4(module oo (output-of)
  5  (import scheme chicken.port)
  6  (define-syntax output-of 
  7    (syntax-rules ()
  8      ((_ exp) (with-output-to-string (lambda () exp)))))
  9)
 10
 11(module mscheme (lambda)
 12  (import (rename scheme (lambda s:lambda))
 13	  (chicken module))
 14  (reexport (except scheme lambda))
 15  (define-syntax lambda
 16    (syntax-rules ()
 17      ((_ llist . body)
 18       (let ((results #f))
 19	 (s:lambda 
 20	  llist
 21	  (if results
 22	      (apply values results)
 23	      (call-with-values (s:lambda () . body)
 24		(s:lambda rs
 25		  (set! results rs)
 26		  (apply values rs)))))))))
 27)
 28
 29(module m (f1 f2)
 30  (import mscheme)
 31  (define (f1)
 32    (display 'f1) (newline)
 33    'f1)
 34  (define f2
 35    (lambda ()
 36      (display 'f2) (newline)
 37      'f2))
 38)
 39
 40(module mtest ()
 41  (import scheme m (chicken base) oo)
 42  (assert (string=? "f1\n" (output-of (f1))))
 43  (assert (string=? "f1\n" (output-of (f1))))
 44  (assert (string=? "f2\n" (output-of (f2))))
 45  (assert (string=? "" (output-of (f2)))))
 46
 47;;;
 48
 49(module m1 (lambda f1 f2)
 50  (import (rename scheme (lambda s:lambda)))
 51
 52  (define-syntax lambda
 53    (syntax-rules ()
 54      ((_ llist . body)
 55       (s:lambda llist (display 'llist) (newline) . body))))
 56
 57  (define (f1)				; should use standard lambda
 58    (display 'f1)
 59    (newline))
 60
 61  (define f2
 62    (lambda (x)				; should be our lambda
 63      (display 'f2)
 64      (newline)))
 65
 66)
 67
 68(module mtest2 (f3 f4)
 69  (import (except scheme lambda) m1 (chicken base) oo)
 70
 71  (define (f3)				; standard lambda
 72    (display 'f3)
 73    (newline))
 74
 75  (define f4				; our lambda
 76    (lambda (x)
 77      (display 'f4)
 78      (newline)))
 79
 80  (assert (string=? "f1\n" (output-of (f1))))
 81  (assert (string=? "(x)\nf2\n" (output-of (f2 'yes))))
 82  (assert (string=? "f3\n" (output-of (f3))))
 83  (assert (string=? "(x)\nf4\n" (output-of (f4 'yes)))))
 84
 85(module m2 ()
 86  (import m1)
 87  ((lambda () (f1)))) ; should use new lambda (but should be folded by compiler)
 88
 89;; #1132 - internal definitions honor redefinitions of defining forms
 90(module m3 ()
 91  (import (rename scheme (define s:define)))
 92  (import (only (chicken base) assert))
 93  (define-syntax define
 94    (syntax-rules ()
 95      ((_) (display 'oink))
 96      ((_ var value) (s:define var (+ value 1)))))
 97  (define)
 98  ;; Internal definition uses new "define"
 99  (let ()
100    (define a 1)
101    (assert (= a 2)))
102
103  ;; Toplevel definition also uses new "define"
104  (define b 5)
105  (assert (= b 6)))