79 lines
2.6 KiB
Racket
79 lines
2.6 KiB
Racket
#lang racket
|
|
(require syntax/modcode)
|
|
|
|
(define dir (find-system-path 'temp-dir))
|
|
(define file.rkt (build-path dir "file.rkt"))
|
|
(define file.ss (build-path dir "file.ss"))
|
|
|
|
(define compiled-dir (build-path dir "compiled"))
|
|
(make-directory* compiled-dir)
|
|
|
|
(define (test expect proc . args)
|
|
(define val (apply proc args))
|
|
(unless (equal? expect val)
|
|
(error 'fail "at (apply ~s '~s): ~e is not expected: ~e" proc args val expect)))
|
|
|
|
(define (try file.sfx src? zo? so?)
|
|
(printf "trying ~s\n" (list file.sfx src? zo? so?))
|
|
(define file.zo
|
|
(let-values ([(base name dir?) (split-path file.sfx)])
|
|
(build-path base "compiled" (path-add-suffix name #".zo"))))
|
|
(define file.rkt (path-replace-suffix file.sfx #".rkt"))
|
|
(define file.so (path-replace-suffix file.sfx #".so"))
|
|
(when (file-exists? file.ss) (delete-file file.ss))
|
|
(when (file-exists? file.rkt) (delete-file file.rkt))
|
|
(when (file-exists? file.zo) (delete-file file.zo))
|
|
(define ns (make-base-namespace))
|
|
(dynamic-wind
|
|
(lambda () (void))
|
|
(lambda ()
|
|
(when src?
|
|
(call-with-output-file*
|
|
file.sfx
|
|
(lambda (o)
|
|
(write '(module file racket/base
|
|
10
|
|
(module inner racket/base 11))
|
|
o))))
|
|
(when zo?
|
|
(call-with-output-file*
|
|
file.zo
|
|
(lambda (o)
|
|
(write (parameterize ([current-namespace ns])
|
|
(compile '(module file racket/base
|
|
12
|
|
(module inner racket/base 13))))
|
|
o))))
|
|
(define (check-name name code)
|
|
(test name module-compiled-name code))
|
|
(check-name
|
|
'file
|
|
(get-module-code file.sfx
|
|
#:choose (lambda (src zo so)
|
|
(test src? file-exists? src)
|
|
(test zo? file-exists? zo)
|
|
(test so? file-exists? so)
|
|
#f)))
|
|
(check-name
|
|
'(file inner)
|
|
(get-module-code file.sfx
|
|
#:submodule-path '(inner)
|
|
#:choose (lambda (src zo so)
|
|
(test src? file-exists? src)
|
|
(test zo? file-exists? zo)
|
|
(test so? file-exists? so)
|
|
#f)))
|
|
(void))
|
|
(lambda ()
|
|
(when src? (delete-file file.sfx))
|
|
(when zo? (delete-file file.zo)))))
|
|
|
|
(try file.rkt #t #f #f)
|
|
(try file.rkt #t #t #f)
|
|
(try file.rkt #f #t #f)
|
|
(try file.ss #t #f #f)
|
|
(try file.ss #t #t #f)
|
|
(try file.ss #f #t #f)
|
|
|
|
(delete-directory/files compiled-dir)
|