1: ;;
    2: ;; testing module system
    3: ;;
    4: 
    5: (use gauche.test)
    6: 
    7: (test-start "module")
    8: 
    9: ;;------------------------------------------------------------------
   10: ;; basic test
   11: 
   12: (define-module M
   13:   (define a 3)
   14:   (define cons +))
   15: 
   16: (define a 100)
   17: (define b 200)
   18: 
   19: (test "define-module" #t (lambda () (module? (find-module 'M))))
   20: (test "with-module" 3 (lambda () (with-module M a)))
   21: (test "with-module" 5 (lambda () (with-module M (cons a 2))))
   22: (test "with-module" '(3 . 2) (lambda () (cons (with-module M a) 2)))
   23: (test "with-module" 5
   24:       (lambda ()
   25:         (eval '(with-module M (define b 2) (cons a b))
   26:               (interaction-environment))))
   27: (test "with-module" 2 (lambda () (with-module M b)))
   28: (test "with-module" 300
   29:       (lambda () (with-module M
   30:                     (cons (with-module user a) (with-module user b)))))
   31: 
   32: (test "with-module (error)" *test-error*
   33:       (lambda () (eval '(with-module MM 4) (interaction-environment))))
   34: 
   35: (with-module M
   36:   (define + list)
   37:   (define if list))
   38: 
   39: (test "with-module in head position" '(2 3)
   40:       (lambda ()
   41:         ((with-module M +) 2 3)))
   42: 
   43: (test "with-module in head position" '(3 5 6)
   44:       (lambda ()
   45:         (with-module M
   46:           (if ((with-module scheme if) 2 3 4) 5 6))))
   47: 
   48: (define-module MA
   49:   (export with-module)
   50:   (define-syntax with-module
   51:     (syntax-rules ()
   52:       ((_ a b) list))))
   53: 
   54: (test "with-module in head position (shadowed)" '(1 2 3)
   55:       (lambda ()
   56:         (with-module MA
   57:           ((with-module x y) 1 2 3))))
   58: 
   59: (define-module MB
   60:   (import MA)
   61:   (export oops)
   62:   (define-syntax oops
   63:     (syntax-rules ()
   64:       ((_ a) (define a 3)))))
   65: 
   66: (test "with-module in head position (shadowed)" '(1 2 3)
   67:       (lambda ()
   68:         (with-module MB
   69:           ((with-module x y) 1 2 3))))
   70: 
   71: (test "with-module in head position (in lambda body)" 6
   72:       (lambda ()
   73:         (let ((x 1))
   74:           ((with-module MB oops) x)
   75:           (+ x x))))
   76: 
   77: ;;------------------------------------------------------------------
   78: ;; define-in-module
   79: 
   80: (test "define-in-module" 99
   81:       (lambda ()
   82:         (eval '(define-in-module M aa 99) (interaction-environment))
   83:         (eval '(with-module M aa) (interaction-environment))))
   84: 
   85: (test "define-in-module" *test-error*
   86:       (lambda ()
   87:         (eval '(define-in-module MM aa 99) (interaction-environment))
   88:         (eval '(with-module MM aa) (interaction-environment))))
   89: 
   90: ;;------------------------------------------------------------------
   91: ;; import, export
   92: 
   93: (define-module N
   94:   (export push-result get-result reset-result)
   95: 
   96:   (define result '())
   97:   (define (get-result) (reverse result))
   98:   (define (push-result r) (set! result (cons r result)))
   99:   (define (reset-result) (set! result '())))
  100: 
  101: (define-module O
  102:   (import N)
  103: 
  104:   (define + *)
  105:   )
  106: 
  107: (test "import/export" '(56 72)
  108:       (lambda ()
  109:         (eval '(with-module O
  110:                  (reset-result)
  111:                  (define a 7)
  112:                  (define b 8)
  113:                  (define c 9)
  114:                  (push-result (+ a b))
  115:                  (push-result (+ b c))
  116:                  (get-result))
  117:               (interaction-environment))))
  118: 
  119: (test "import (error)" *test-error*
  120:       (lambda () (eval '(import MM) (interaction-environment))))
  121: 
  122: ;;------------------------------------------------------------------
  123: ;; select-module, and restoration in load().
  124: 
  125: (test "select-module" '(O O N O)
  126:       (lambda ()
  127:         (eval
  128:          '(with-module O
  129:             (define load-data '((select-module O)
  130:                                 (push-result (module-name (current-module)))
  131:                                 (select-module N)
  132:                                 (push-result (module-name (current-module)))))
  133:             (reset-result)
  134:             (push-result (module-name (current-module)))
  135:             (with-output-to-file "tmp.t"
  136:               (lambda () (for-each write load-data)))
  137:             (load "./tmp.t")
  138:             (push-result (module-name (current-module)))
  139:             (sys-unlink "tmp.t")
  140:             (get-result)
  141:             )
  142:          (interaction-environment))))
  143: 
  144: (test "select-module" 'user (lambda () (module-name (current-module))))
  145: 
  146: (test "select-module (error)" *test-error*
  147:       (lambda () (eval '(select-moulde MM) (interaction-environment))))
  148: 
  149: ;;------------------------------------------------------------------
  150: ;; module inheritance
  151: 
  152: (define-module P
  153:   (export a b)
  154:   (define a 'alpha)
  155:   (define b 'beta))
  156: (define-module Q
  157:   (export a b d)
  158:   (define a 'ei)
  159:   (define b 'bee)
  160:   (define d 'dee))
  161: (define-module R
  162:   (export c)
  163:   (extend P)
  164:   (define c 'gamma))
  165: (define-module S
  166:   (export c)
  167:   (extend Q P)
  168:   (define c 'delta))
  169: (define-module T
  170:   (export c)
  171:   (extend Q)
  172:   (define c 'delta))
  173: (define-module U
  174:   (extend R T)
  175:   )
  176: (define-module V
  177:   (import U)
  178:   )
  179: 
  180: (test "module inheritance" 'alpha (lambda () (with-module R a)))
  181: (test "module inheritance" 'ei    (lambda () (with-module S a)))
  182: (test "module inheritance" '(gamma beta)
  183:       (lambda ()
  184:         (with-module U (list c b))))
  185: (test "module inheritance" '(alpha beta gamma dee)
  186:       (lambda ()
  187:         (with-module V (list a b c d))))
  188: 
  189: (test "moduel inheritance (error)" *test-error*
  190:       (lambda ()
  191:         (eval '(with-module V (extend Q MM)) (interaction-environment))))
  192: 
  193: (test "global-variable-ref" 'gamma
  194:       (lambda ()
  195:         (global-variable-ref 'U 'c)))
  196: 
  197: (test "global-variable-ref" *test-error*
  198:       (lambda ()
  199:         (global-variable-ref 'U 'e)))
  200: 
  201: (test "global-variable-ref" 'huh?
  202:       (lambda ()
  203:         (global-variable-ref 'U 'e 'huh?)))
  204: 
  205: (test "global-variable-ref" 'huh?
  206:       (lambda ()
  207:         (global-variable-ref 'U 'c 'huh? #t)))
  208: 
  209: ;;------------------------------------------------------------------
  210: ;; creates modules on-the-fly
  211: 
  212: (test "make-module" #t
  213:       (lambda ()
  214:         (make-module 'foo)
  215:         (module? (find-module 'foo))))
  216: 
  217: (test "make-module (duplicate name)" *test-error*
  218:       (lambda ()
  219:         (make-module 'foo)))
  220: 
  221: (test "make-module (duplicate name)" *test-error*
  222:       (lambda ()
  223:         (make-module 'foo :if-exists :error)))
  224: 
  225: (test "make-module (duplicate name)" #f
  226:       (lambda ()
  227:         (make-module 'foo :if-exists #f)))
  228: 
  229: (test "anynomous module" #t
  230:       (lambda ()
  231:         (let ((m0 (make-module #f))
  232:               (m1 (make-module #f)))
  233:           (and (module? m0) (module? m1) (not (eq? m0 m1))))))
  234: 
  235: (test "anonymous module" 13
  236:       (lambda ()
  237:         (let ((m0 (make-module #f)))
  238:           (eval '(define x 13) m0)
  239:           (eval 'x m0))))
  240:               
  241: (test "anonymous module" *test-error*
  242:       (lambda ()
  243:         (let ((m0 (make-module #f))
  244:               (m1 (make-module #f)))
  245:           (eval '(define x 13) m0)
  246:           (eval 'x m1))))
  247: 
  248: (test-end)