suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Honu, top.ss:

Browse Source 
- Changed names:
  - no longer add honu: prefix to imports
  - now include top: prefix on exports
  - *-introduced-identifiers now *-names (produce symbols, not identifiers)
- Added tenv:entry-mangled-name
- Implemented run-test-class-from-name to print whether a class is/isn't test code

svn: r906
This commit is contained in:
Carl Eastlund 2005-09-23 01:47:34 +00:00
parent fd91f3afdc
commit d023288e05
1 changed files with 63 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
collects/honu/top.ss
View File

@ -4,15 +4,17 @@
(lib "class.ss")
(lib "contract.ss")
(lib "boundmap.ss" "syntax")
(prefix honu: "parsers/parse.ss")
(prefix honu: "parsers/post-parsing.ss")
(prefix honu: "private/typechecker/typechecker.ss")
(prefix honu: "private/compiler/translate.ss")
(prefix honu: "tenv.ss")
(prefix honu: "tenv-utils.ss")
(prefix honu: "parameters.ss")
(prefix honu: "honu-context.ss")
"parsers/parse.ss"
"parsers/post-parsing.ss"
"private/typechecker/type-utils.ss"
"private/typechecker/typechecker.ss"
"private/compiler/translate.ss"
"private/compiler/translate-utils.ss"
"tenv-utils.ss"
"parameters.ss"
"honu-context.ss"
"ast.ss"
"tenv.ss"
)
(require-for-template (lib "contract.ss"))
@ -41,70 +43,80 @@
(provide/contract [NAME CONTRACT]))]
))
(def/pro/con current-top-tenv parameter? (make-parameter (honu:empty-tenv)))
(def/pro/con current-top-lenv parameter? (make-parameter (honu:get-builtin-lenv)))
(def/pro/con top:current-tenv parameter? (make-parameter (empty-tenv)))
(def/pro/con top:current-lenv parameter? (make-parameter (get-builtin-lenv)))
(def/pro/con (reset-env) (-> void?)
(current-top-tenv (honu:empty-tenv))
(current-top-lenv (honu:get-builtin-lenv)))
(def/pro/con (top:reset-env) (-> void?)
(top:current-tenv (empty-tenv))
(top:current-lenv (get-builtin-lenv)))
(define-syntax (with-env stx)
(syntax-case stx ()
[(_ BODY ...)
#`(parameterize ([honu:current-type-environment (current-top-tenv)]
[honu:current-lexical-environment (current-top-lenv)])
#`(parameterize ([current-type-environment (top:current-tenv)]
[current-lexical-environment (top:current-lenv)])
BODY ...)]))
(define-syntax (with-context stx)
(syntax-case stx ()
[(_ BODY ...)
#`(parameterize ([honu:current-compile-context honu:honu-compile-context])
#`(parameterize ([current-compile-context honu-compile-context])
BODY ...)]))
(def/pro/con (parse-file file) (path-string? . -> . (listof honu:defn?))
(def/pro/con (top:parse-file file) (path-string? . -> . (listof honu:defn?))
(with-env
(honu:post-parse-program
(honu:add-defns-to-tenv
(honu:parse-port (open-input-file file) file)))))
(post-parse-program
(add-defns-to-tenv
(parse-port (open-input-file file) file)))))
(def/pro/con (check-defns defns) ((listof honu:defn?) . -> . (listof honu:defn?))
(with-env (honu:typecheck defns)))
(def/pro/con (top:check-defns defns) ((listof honu:defn?) . -> . (listof honu:defn?))
(with-env (typecheck defns)))
(def/pro/con (translate-defns defns) ((listof honu:defn?) . -> . (syntax/c any/c))
(def/pro/con (top:translate-defns defns) ((listof honu:defn?) . -> . (syntax/c any/c))
(with-env
(with-context
(let-values
([(annotations syntax) (honu:translate defns)])
([(annotations syntax) (translate defns)])
(namespace-syntax-introduce (datum->syntax-object #f (cons 'begin syntax) #f))))))
(define honu-introduced-identifiers
(opt-lambda ([lenv (current-top-lenv)] [tenv (honu:get-builtin-lenv)])
(let* ([orig (honu:get-builtin-lenv)]
[ids '()])
(bound-identifier-mapping-for-each
lenv
(lambda (id _)
(if (bound-identifier-mapping-get orig id (lambda () #f))
(void)
(set! ids (cons id ids)))))
(reverse! ids))))
(define (lenv-names)
(let* ([lenv (top:current-lenv)]
[orig (get-builtin-lenv)]
[ids '()])
(bound-identifier-mapping-for-each
lenv
(lambda (id entry)
(if (bound-identifier-mapping-get orig id (lambda () #f))
(void)
(set! ids (cons (syntax-e id) ids)))))
(reverse! ids)))
(define (run-test-class-from-identifier id)
(let ([def (eval-syntax id)])
(display def)
(if (class? def)
(error 'test-program "NYI"))))
(define (tenv:entry-mangled-name id entry)
(cond [(tenv:type? entry) (syntax-e (translate-iface-name (make-iface-type id id)))]
[(tenv:class? entry) (syntax-e (translate-class-name id))]
[(tenv:mixin? entry) (syntax-e (translate-mixin-name id))]))
(def/pro/con (run-program file) (path-string? . -> . (listof symbol?))
(reset-env)
(eval-syntax (translate-defns (check-defns (parse-file file))))
(map syntax-e (honu-introduced-identifiers))
)
(define (tenv-names)
(let* ([tenv (top:current-tenv)])
(bound-identifier-mapping-map tenv tenv:entry-mangled-name)))
(define/provide (test-program file)
(reset-env)
(eval-syntax (translate-defns (check-defns (parse-file file))))
(for-each run-test-class-from-identifier (honu-introduced-identifiers))
)
(define test<%> (interface ()))
(define (run-test-class-from-name name)
(let ([def (eval name)])
(if (and (class? def) (implementation? def test<%>))
(printf "WILL test ~s [~s]~n" def name)
(printf "WONT test ~s [~s]~n" def name))))
(define/provide (top:run-program file)
#;(path-string? . -> . (values (listof (list/c symbol? any/c)) (listof (list/c symbol? any/c))))
(top:reset-env)
(eval-syntax (top:translate-defns (top:check-defns (top:parse-file file))))
(values (tenv-names) (lenv-names)))
)
(define/provide (top:test-program file)
(top:reset-env)
(eval-syntax (top:translate-defns (top:check-defns (top:parse-file file))))
(for-each run-test-class-from-name (tenv-names)))
)