Honu, top.ss:

- Removed unused contract.
- Added abstraction for setting current-compile-context.
- Changed names of some input variables.
- Added names of introduced definitions to output of run-program.
- Begain writing test-program (for running test cases).

svn: r905

collects/honu/top.ss

@@ -1,6 +1,9 @@
 (module top mzscheme
 
-  (require (lib "contract.ss")
+  (require (lib "etc.ss")
+           (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")
@@ -13,7 +16,7 @@
            )
 
   (require-for-template (lib "contract.ss"))
-  
+
   (define-syntax (define/provide stx)
     (syntax-case stx ()
         [(_ (NAME ARG ...) BODY ...)
@@ -25,7 +28,7 @@
              (define NAME BODY ...)
              (provide NAME))]
         ))
-  
+
   (define-syntax (def/pro/con stx)
     (syntax-case stx ()
         [(_ (NAME ARG ...) CONTRACT BODY ...)
@@ -38,41 +41,70 @@
              (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 ...)]))
-  
+
+  (define-syntax (with-context stx)
+    (syntax-case stx ()
+      [(_ BODY ...)
+       #`(parameterize ([honu:current-compile-context honu:honu-compile-context])
+           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?))
+  (def/pro/con (check-defns defns) ((listof honu:defn?) . -> . (listof honu:defn?))
-    (with-env (honu:typecheck program)))
+    (with-env (honu:typecheck defns)))
 
-  (def/pro/con (translate-defns program)
+  (def/pro/con (translate-defns defns) ((listof honu:defn?) . -> . (syntax/c any/c))
-    ((listof honu:defn?) . -> . (syntax/c any/c))
     (with-env
-     (parameterize ([honu:current-compile-context honu:honu-compile-context])
+     (with-context
        (let-values
-           ([(annotations syntax) (honu:translate program)])
+           ([(annotations syntax) (honu:translate defns)])
          (namespace-syntax-introduce (datum->syntax-object #f (cons 'begin syntax) #f))))))
 
-  (def/pro/con (run-program file) (path-string? . -> . void?)
+  (define honu-introduced-identifiers
-    (reset-env)
+    (opt-lambda ([lenv (current-top-lenv)] [tenv (honu:get-builtin-lenv)])
-    (eval-syntax (translate-defns (check-defns (parse-file file)))))
+      (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 (run-test-class-from-identifier id)
+    (let ([def (eval-syntax id)])
+      (display def)
+      (if (class? def)
+          (error 'test-program "NYI"))))
   
+  (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/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))
+    )
+
   )