diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss index 1fa391e8c6..86fcfad923 100644 --- a/collects/honu/tool.ss +++ b/collects/honu/tool.ss @@ -86,13 +86,16 @@ (if (eof-object? (peek-char-or-special port)) eof (let* ([parsed (level-parser port name)]) - (let-values ([(cruft-for-stx compiled-defns) (compile/defns tenv lenv parsed)]) + (let-values + ([(cruft-for-stx compiled-defns) (compile/defns tenv lenv parsed)]) ;; if we wrap this in something special for the syntax-case below, then ;; Check Syntax breaks (unsurprisingly), so we'll just do special ;; wrappers for the interaction stuff. - (datum->syntax-object #f (list 'begin cruft-for-stx - (datum->syntax-object #f (cons 'begin compiled-defns) #f)) - #f))))))) + (datum->syntax-object + #f + (list 'begin cruft-for-stx + (datum->syntax-object #f (cons 'begin compiled-defns) #f)) + #f))))))) (define/public (front-end/interaction port settings teachpack-cache) (let ([name (object-name port)]) (lambda () @@ -161,8 +164,8 @@ (super-instantiate ()))) - ;; The following copies the Java mode to make one for Honu, but it's better right now than using - ;; the Scheme mode. Ugh. + ;; The following copies the Java mode to make one for Honu, but it's better right now than + ;; using the Scheme mode. Ugh. ;; matches-language : (union #f (listof string)) -> boolean (define (matches-language l) @@ -218,7 +221,8 @@ (fold (lambda (v s) ;; if there are no objects, then we'll just print out ;; the list on the same line. - (string-append s ", " (format-honu-value v settings (+ indent 1)))) + (string-append s ", " + (format-honu-value v settings (+ indent 1)))) (format-honu-value (car value) settings (+ indent 1)) (cdr value)) ")"))] diff --git a/collects/honu/top.ss b/collects/honu/top.ss new file mode 100644 index 0000000000..9ff3d7d0a2 --- /dev/null +++ b/collects/honu/top.ss @@ -0,0 +1,78 @@ +(module top mzscheme + + (require (lib "contract.ss") + (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") + "ast.ss" + ) + + (require-for-template (lib "contract.ss")) + + (define-syntax (define/provide stx) + (syntax-case stx () + [(_ (NAME ARG ...) BODY ...) + #`(begin + (define (NAME ARG ...) BODY ...) + (provide NAME))] + [(_ NAME BODY ...) + #`(begin + (define NAME BODY ...) + (provide NAME))] + )) + + (define-syntax (def/pro/con stx) + (syntax-case stx () + [(_ (NAME ARG ...) CONTRACT BODY ...) + #`(begin + (define (NAME ARG ...) BODY ...) + (provide/contract [NAME CONTRACT]))] + [(_ NAME CONTRACT BODY ...) + #`(begin + (define NAME BODY ...) + (provide/contract [NAME CONTRACT]))] + )) + + (define type-syntax/c any/c) + + (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 (reset-env) (-> void?) + (current-top-tenv (honu:empty-tenv)) + (current-top-lenv (honu: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)]) + BODY ...)])) + + (def/pro/con (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))))) + + (def/pro/con (check-defns program) ((listof honu:defn?) . -> . (listof honu:defn?)) + (with-env (honu:typecheck program))) + + (def/pro/con (translate-defns program) + ((listof honu:defn?) . -> . (syntax/c any/c)) + (with-env + (parameterize ([honu:current-compile-context honu:honu-compile-context]) + (let-values + ([(annotations syntax) (honu:translate program)]) + (namespace-syntax-introduce (datum->syntax-object #f (cons 'begin syntax) #f)))))) + + (def/pro/con (run-program file) (path-string? . -> . void?) + (reset-env) + (eval-syntax (translate-defns (check-defns (parse-file file))))) + + ) \ No newline at end of file