Merge remote-tracking branch 'origin/master'

Makefile

@@ -4,6 +4,9 @@
 all: planet-link launcher setup
 
 
+bump-version:
+	racket bump-version.rkt
+
 launcher: 
 	racket make-launcher.rkt
 

bump-version.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+
+(require racket/runtime-path
+	 racket/port
+	 racket/list)
+
+(define-runtime-path version.rkt "version.rkt")
+
+(define version-text (call-with-input-file version.rkt port->string))
+
+(define revised-text (regexp-replace #px"\\.(\\d+)"
+				     version-text
+				     (lambda (whole sub)
+				       (string-append 
+					"."
+					(number->string 
+					 (add1 (string->number sub)))))))
+  
+(call-with-output-file version.rkt (lambda (op) (display revised-text op))
+		       #:exists 'replace)

cs019/cs019.rkt

@@ -1,7 +1,452 @@
-#lang s-exp "../lang/whalesong.rkt"
+#lang s-exp "../lang/kernel.rkt"
 
 ;; Like the big whalesong language, but with additional ASL restrictions.
 
+
 (current-print-mode "constructor")
 
-(provide (all-from-out "../lang/whalesong.rkt"))
+(require (for-syntax racket/base syntax/stx racket/match))
+
+
+
+(require (prefix-in whalesong: "../lang/whalesong.rkt"))
+(provide (except-out (filtered-out
+                      (lambda (name)
+                        (match name
+                          [(regexp #rx"^whalesong:(.+)$" (list _ real-name))
+                           real-name]
+                          [else
+                           #f]))
+                      (all-from-out "../lang/whalesong.rkt"))
+                     if
+                     cond
+                     case
+                     when
+                     unless
+                     member))
+                     
+
+
+
+(define-for-syntax (local-expand-for-error stx ctx stops)
+  ;; This function should only be called in an 'expression
+  ;;  context. In case we mess up, avoid bogus error messages.
+  (when (memq (syntax-local-context) '(expression))
+    (local-expand stx ctx stops)))
+
+
+
+    
+
+
+;; Raise a syntax error:
+(define-for-syntax (teach-syntax-error form stx detail msg . args)
+  (let ([form (if (eq? form '|function call|)
+                  form
+                  #f)] ; extract name from stx
+        [msg (apply format msg args)])
+    (if detail
+        (raise-syntax-error form msg stx detail)
+        (raise-syntax-error form msg stx))))
+
+(define-for-syntax (teach-syntax-error* form stx details msg . args)
+  (let ([exn (with-handlers ([exn:fail:syntax?
+                              (lambda (x) x)])
+               (apply teach-syntax-error form stx #f msg args))])
+    (raise
+     (make-exn:fail:syntax
+      (exn-message exn)
+      (exn-continuation-marks exn)
+      details))))
+
+
+
+;; The syntax error when a form's name doesn't follow a "("
+(define-for-syntax (bad-use-error name stx)
+  (teach-syntax-error
+   name
+   stx
+   #f
+   "found a use of `~a' that does not follow an open parenthesis"
+   name))
+
+(define-for-syntax (something-else v)
+  (let ([v (syntax-e v)])
+    (cond
+      [(number? v) "a number"]
+      [(string? v) "a string"]
+      [else "something else"])))
+
+;; verify-boolean is inserted to check for boolean results:
+(define-for-syntax (verify-boolean b where)
+  (with-syntax ([b b]
+                [where where])
+    (quasisyntax/loc #'b
+      (let ([bv b])
+        (if (or (eq? bv #t) (eq? bv #f))
+            bv
+            #,(syntax/loc #'b
+                (whalesong:#%app raise
+                                 (make-exn:fail:contract
+                                  (format "~a: question result is not true or false: ~e" 'where bv)
+                                  (current-continuation-marks)))))))))
+
+
+(define-syntax (-cond stx)
+  (syntax-case stx ()
+    [(_)
+     (teach-syntax-error
+      'cond
+      stx
+      #f
+      "expected a question--answer clause after `cond', but nothing's there")]
+    [(_ clause ...)
+     (let* ([clauses (syntax->list (syntax (clause ...)))]
+            [check-preceding-exprs
+             (lambda (stop-before)
+               (let/ec k
+                 (for-each (lambda (clause)
+                             (if (eq? clause stop-before)
+                                 (k #t)
+                                 (syntax-case clause ()
+                                   [(question answer)
+                                    (begin
+                                      (unless (and (identifier? (syntax question))
+                                                   (free-identifier=? (syntax question)
+                                                                      #'else))
+                                        (local-expand-for-error (syntax question) 'expression null))
+                                      (local-expand-for-error (syntax answer) 'expression null))])))
+                           clauses)))])
+       (let ([checked-clauses
+              (map
+               (lambda (clause)
+                 (syntax-case clause (else)
+                   [(else answer)
+                    (let ([lpos (memq clause clauses)])
+                      (when (not (null? (cdr lpos)))
+                        (teach-syntax-error
+                         'cond
+                         stx
+                         clause
+                         "found an `else' clause that isn't the last clause ~
+                                    in its `cond' expression"))
+                      (with-syntax ([new-test (syntax #t) ])
+                        (syntax/loc clause (new-test answer))))]
+                   [(question answer)
+                    (with-syntax ([verified 
+                                   (verify-boolean #'question 'cond)])
+                      (syntax/loc clause (verified answer)))]
+                   [()
+                    (check-preceding-exprs clause)
+                    (teach-syntax-error
+                     'cond
+                     stx
+                     clause
+                     "expected a question--answer clause, but found an empty clause")]
+                   [(question?)
+                    (check-preceding-exprs clause)
+                    (teach-syntax-error
+                     'cond
+                     stx
+                     clause
+                     "expected a clause with a question and answer, but found a clause with only one part")]
+                   [(question? answer? ...)
+                    (check-preceding-exprs clause)
+                    (let ([parts (syntax->list clause)])
+                      ;; to ensure the illusion of left-to-right checking, make sure 
+                      ;; the question and first answer (if any) are ok:
+                      (unless (and (identifier? (car parts))
+                                   (free-identifier=? (car parts) #'else))
+                        (local-expand-for-error (car parts) 'expression null))
+                      (unless (null? (cdr parts))
+                        (local-expand-for-error (cadr parts) 'expression null))
+                      ;; question and answer (if any) are ok, raise a count-based exception:
+                      (teach-syntax-error*
+                       'cond
+                       stx
+                       parts
+                       "expected a clause with one question and one answer, but found a clause with ~a parts"
+                       (length parts)))]
+                   [_else
+                    (teach-syntax-error
+                     'cond
+                     stx
+                     clause
+                     "expected a question--answer clause, but found ~a"
+                     (something-else clause))]))
+               clauses)])
+         ;; Add `else' clause for error (always):
+         (let ([clauses (append checked-clauses 
+                                (list 
+                                 (with-syntax ([error-call (syntax/loc stx (whalesong:#%app raise (make-exn:fail:contract "cond: all question results were false" (current-continuation-marks))))])
+                                   (syntax [else error-call]))))])
+           (with-syntax ([clauses clauses])
+             (syntax/loc stx (cond . clauses))))))]
+    [_else (bad-use-error 'cond stx)]))
+
+(provide (rename-out [-cond cond]))
+
+
+
+
+
+
+(define-syntax (-if stx)
+  (syntax-case stx ()
+    [(_ test then else)
+     (with-syntax ([new-test (verify-boolean #'test 'if)])
+       (syntax/loc stx
+         (if new-test
+             then
+             else)))]
+    [(_ . rest)
+     (let ([n (length (syntax->list (syntax rest)))])
+       (teach-syntax-error
+        'if
+        stx
+        #f
+        "expected one question expression and two answer expressions, but found ~a expression~a"
+        (if (zero? n) "no" n)
+        (if (= n 1) "" "s")))]
+    [_else (bad-use-error 'if stx)]))
+
+(provide (rename-out [-if if]))
+
+
+
+
+;; Use to generate nicer error messages than direct pattern
+;; matching. The `where' argument is an English description
+;; of the portion of the larger expression where a single
+;; sub-expression was expected.
+(define-for-syntax (check-single-expression who where stx exprs will-bind)
+  (when (null? exprs)
+    (teach-syntax-error
+     who
+     stx
+     #f
+     "expected an expression ~a, but nothing's there"
+     where))
+  (unless (null? (cdr exprs))
+    ;; In case it's erroneous, to ensure left-to-right reading, let's
+    ;;  try expanding the first expression. We have to use
+    ;;  `will-bind' to avoid errors for unbound ids that will actually
+    ;;  be bound. Since they're used as stopping points, we may miss
+    ;;  some errors after all. It's worth a try, though. We also
+    ;;  have to stop at advanced-set!, in case it's used with
+    ;;  one of the identifiers in will-bind.
+    (when will-bind
+      (local-expand-for-error (car exprs) 'expression (cons #'advanced-set!
+                                                            will-bind)))
+    ;; First expression seems ok, report an error for 2nd and later:
+    (teach-syntax-error
+     who
+     stx
+     (cadr exprs)
+     "expected only one expression ~a, but found ~a extra part"
+     where
+     (if (null? (cddr exprs))
+         "one"
+         "at least one"))))
+
+
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; case
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax (-case stx)
+  (syntax-case stx ()
+    [(_)
+     (teach-syntax-error
+      'case
+      stx
+      #f
+      "expected an expression after `case', but nothing's there")]
+    [(_ expr)
+     (teach-syntax-error
+      'case
+      stx
+      #f
+      "expected a choices--answer clause after the expression following `case', but nothing's there")]
+    [(_ v-expr clause ...)
+     (let ([clauses (syntax->list (syntax (clause ...)))])
+       (for-each
+        (lambda (clause)
+          (syntax-case clause (else)
+            [(else answer ...)
+             (let ([lpos (memq clause clauses)])
+               (when (not (null? (cdr lpos)))
+                 (teach-syntax-error
+                  'case
+                  stx
+                  clause
+                  "found an `else' clause that isn't the last clause ~
+                                    in its `case' expression"))
+               (let ([answers (syntax->list (syntax (answer ...)))])
+                 (check-single-expression 'case
+                                          "for the answer in a case clause"
+                                          clause
+                                          answers
+                                          null)))]
+            [(choices answer ...)
+             (let ([choices (syntax choices)]
+                   [answers (syntax->list (syntax (answer ...)))])
+               (syntax-case choices ()
+                 [(elem ...)
+                  (let ([elems (syntax->list (syntax (elem ...)))])
+                    (for-each (lambda (e)
+                                (let ([v (syntax-e e)])
+                                  (unless (or (number? v)
+                                              (symbol? v))
+                                    (teach-syntax-error
+                                     'case
+                                     stx
+                                     e
+                                     "expected a name (for a symbol) or a number as a choice value, but found ~a"
+                                     (something-else e)))))
+                              elems))]
+                 [_else (teach-syntax-error
+                         'case
+                         stx
+                         choices
+                         "expected a parenthesized sequence of choice values, but found ~a"
+                         (something-else choices))])
+               (when (stx-null? choices)
+                 (teach-syntax-error
+                  'case
+                  stx
+                  choices
+                  "expected at least once choice in a parenthesized sequence of choice values, but nothing's there"))
+               (check-single-expression 'case
+                                        "for the answer in a `case' clause"
+                                        clause
+                                        answers
+                                        null))]
+            [()
+             (teach-syntax-error
+              'case
+              stx
+              clause
+              "expected a choices--answer clause, but found an empty clause")]
+            [_else
+             (teach-syntax-error
+              'case
+              stx
+              clause
+              "expected a choices--answer clause, but found ~a"
+              (something-else clause))]))
+        clauses)
+       ;; Add `else' clause for error, if necessary:
+       (let ([clauses (let loop ([clauses clauses])
+                        (cond
+                          [(null? clauses)
+                           (list
+                            (syntax/loc stx
+                              [else (whalesong:#%app raise (make-exn:fail:contract "case: the expression matched none of the choices" (current-continuation-marks)))]))]
+                          [(syntax-case (car clauses) (else)
+                             [(else . _) (syntax/loc (car clauses) (else . _))]
+                             [_else #f])
+                           => 
+                           (lambda (x) (cons x (cdr clauses)))]
+                          [else (cons (car clauses) (loop (cdr clauses)))]))])
+         (with-syntax ([clauses clauses])
+           (syntax/loc stx (case v-expr . clauses)))))]
+    [_else (bad-use-error 'case stx)]))
+
+(provide (rename-out [-case case]))
+
+
+
+#;(define-for-syntax (make-when-unless who target-stx)
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ q expr ...)
+       (let ([exprs (syntax->list (syntax (expr ...)))])
+         (check-single-expression who
+                                  (format "for the answer in `~a'"
+                                          who)
+                                  stx
+                                  exprs
+                                  null)
+         )]
+      [(_)
+       (teach-syntax-error
+        who
+        stx
+        #f
+        "expected a question expression after `~a', but nothing's there"
+        who)]
+      [_else
+       (bad-use-error who stx)])))
+
+
+;; FIXME: I'm seeing a bad error message when trying to use the functional
+;; abstraction in teach.rkt to define the -when and -unless macros.
+;;
+;; The error message is: module-path-index-resolve: "self" index has
+;; no resolution: #<module-path-index>
+;; As soon as the bug's resolved, refactor this back.
+(define-syntax (-when stx)
+  (syntax-case stx ()
+    [(_ q expr ...)
+     (let ([exprs (syntax->list (syntax (expr ...)))])
+       (check-single-expression #'when
+                                (format "for the answer in `~a'"
+                                        #'when)
+                                stx
+                                exprs
+                                null)
+       (with-syntax ([new-test (verify-boolean #'q 'when)])
+         (let ([result
+                (syntax/loc stx 
+                  (when new-test expr ...))])
+           result)))]
+    [(_)
+     (teach-syntax-error
+      #'when
+      stx
+      #f
+      "expected a question expression after `~a', but nothing's there"
+      #'when)]
+    [_else
+     (bad-use-error #'when stx)]))
+(define-syntax (-unless stx)
+  (syntax-case stx ()
+    [(_ q expr ...)
+     (let ([exprs (syntax->list (syntax (expr ...)))])
+       (check-single-expression #'unless
+                                (format "for the answer in `~a'"
+                                        #'unless)
+                                stx
+                                exprs
+                                null)
+       (with-syntax ([new-test (verify-boolean #'q 'when)])
+         (let ([result
+                (syntax/loc stx 
+                  (unless new-test expr ...))])
+           result)))]
+    [(_)
+     (teach-syntax-error
+      #'unless
+      stx
+      #f
+      "expected a question expression after `~a', but nothing's there"
+      #'unless)]
+    [_else
+     (bad-use-error #'unless stx)]))
+
+(provide (rename-out [-when when]
+                     [-unless unless]))
+
+
+
+
+
+;; ASL's member returns booleans.
+(define (-member x L)
+  (cond
+    [(eq? (member x L) #f) #f]
+    [else #t]))
+
+(provide (rename-out [-member member]))

examples/read-bytes.rkt

@@ -0,0 +1,9 @@
+#lang planet dyoo/whalesong
+
+(let loop ([b (read-byte)])
+  (cond
+   [(eof-object? b)
+    (void)]
+   [else
+    (display (string (integer->char b)))
+    (loop (read-byte))]))

expand-out-images.rkt

@@ -1,15 +1,9 @@
 #lang racket/base
 
 (require racket/runtime-path
-         planet/version
          syntax/kerncase
          net/base64
-         (for-template (this-package-in lang/kernel)
+         (for-template "lang/kernel.rkt"))
-                       #;(this-package-in image/main))
-         
-         ;; FIXME: I don't quite understand why I should be doing a require
-         ;; of the image library at compile time, and not at template time.
-         (this-package-in image/main))
 
 
 
@@ -34,9 +28,10 @@
   ;; fruitfully use compiler/zo-parse.    
   (define rewritten
     (parameterize
-        ([my-image-url (car (generate-temporaries #'(image-url)))])
+        ([my-image-url (car (generate-temporaries #'(my-image-url)))])
       
-      (kernel-syntax-case (syntax-disarm expanded code-insp) #f
+      (define disarmed (syntax-disarm expanded code-insp))
+      (kernel-syntax-case disarmed #f
         [(#%expression expr)
          (quasisyntax/loc stx
            (#%expression #,(on-expr #'expr)))]
@@ -49,8 +44,8 @@
                                  ;; Kludge: I'm trying to get at the image-url
                                  ;; function, but in a way that doesn't clash with the
                                  ;; user's existing program.
-                                 (require (rename-in (file image-library-path)
+                                 (require (only-in (file image-library-path)
-                                                     [image-url #,(my-image-url)]))
+                                                   [bitmap/url #,(my-image-url)]))
                                  
                                  #,@(map on-toplevel
                                          (syntax->list #'(module-level-form ...)))))))]

js-assembler/db-cache.rkt

@@ -0,0 +1,140 @@
+#lang racket/base
+
+(require (planet ryanc/db)
+         (prefix-in whalesong: "../version.rkt")
+         racket/file
+         racket/path
+         file/md5
+         file/gzip
+         file/gunzip
+         racket/contract)
+
+
+(provide cached? save-in-cache!)
+
+;; Contracts are off because when I dynamic-require, I can't
+;; dynamic require the syntaxes exposed by the contract.
+#;(provide/contract
+   [cached? (path? . -> . (or/c false/c bytes?))]
+   [save-in-cache! (path? bytes? . -> . any)])
+
+
+(define cache-directory-path
+  (build-path (find-system-path 'pref-dir)
+              "whalesong"))
+
+
+
+;; create-cache-directory!: -> void
+(define (create-cache-directory!)
+  (unless (directory-exists? cache-directory-path)
+    (make-directory* cache-directory-path)))
+  
+
+;; clear-cache-files!: -> void
+;; Remove all the cache files.
+(define (clear-cache-files!)
+  (for ([file (directory-list cache-directory-path)])
+    (when (file-exists? (build-path cache-directory-path file))
+      (with-handlers ([exn:fail? void])
+        (delete-file (build-path cache-directory-path file))))))
+  
+  
+(define (ensure-cache-db-structure!)
+  (when (not (file-exists? whalesong-cache.sqlite3))
+    ;; Clear existing cache files: they're obsolete.
+    (clear-cache-files!)
+    (define conn 
+      (sqlite3-connect #:database whalesong-cache.sqlite3
+                       #:mode 'create))
+    (query-exec conn
+                (string-append
+                 "create table cache(path string not null primary key, "
+                 " md5sum string not null, "
+                 "data blob not null);"))
+    (query-exec conn
+                "CREATE INDEX cache_md5sum_idx ON cache (md5sum);")
+    (disconnect conn)))
+
+
+
+(define whalesong-cache.sqlite3 
+  (build-path cache-directory-path 
+              (format "whalesong-cache-~a.sqlite"
+                      whalesong:version)))
+
+
+(create-cache-directory!)
+(ensure-cache-db-structure!)
+
+(define conn 
+  (sqlite3-connect #:database whalesong-cache.sqlite3))
+
+
+(define lookup-cache-stmt 
+  (prepare conn (string-append "select path, md5sum, data "
+                               "from cache "
+                               "where path=? and md5sum=?")))
+(define delete-cache-stmt 
+  (prepare conn (string-append "delete from cache "
+                               "where path=?")))
+(define insert-cache-stmt 
+  (prepare conn (string-append "insert into cache(path, md5sum, data)"
+                               " values (?, ?, ?);")))
+
+
+;; cached?: path -> (U false bytes)
+;; Returns a true value, (vector path md5-signature data), if we can
+;; find an appropriate entry in the cache, and false otherwise.
+(define (cached? path)
+  (cond
+    [(file-exists? path)
+     (define maybe-row 
+       (query-maybe-row conn 
+                        lookup-cache-stmt 
+                        (path->string path)
+                        (call-with-input-file* path md5)))
+     (cond
+       [maybe-row
+        (vector-ref maybe-row 2) #;(gunzip-content (vector-ref maybe-row 2))]
+       [else
+        #f])]
+    [else
+     #f]))
+
+
+
+;; save-in-cache!: path bytes -> void
+;; Saves a record.
+(define (save-in-cache! path data)
+  (cond
+    [(file-exists? path)
+     (define signature (call-with-input-file* path md5))
+     ;; Make sure there's a unique row/column by deleting
+     ;; any row with the same key.
+     (query-exec conn delete-cache-stmt (path->string path))
+     (query-exec conn insert-cache-stmt
+                 (path->string path)
+                 signature
+                 data #;(gzip-content data))]
+    [else
+     (error 'save-in-cache! "File ~e does not exist" path)]))
+
+
+
+;; gzip-content: bytes -> bytes
+(define (gzip-content content)
+  (define op (open-output-bytes))
+  (gzip-through-ports (open-input-bytes content)
+                      op
+                      #f
+                      0)
+  (get-output-bytes op))
+
+
+;; gunzip-content: bytes -> bytes
+(define (gunzip-content content)
+  (define op (open-output-bytes))
+  (gunzip-through-ports (open-input-bytes content)
+                        op)
+  (get-output-bytes op))

js-assembler/hash-cache.rkt

@@ -0,0 +1,94 @@
+#lang racket/base
+
+;; on-disk hashtable cache.
+
+(require (prefix-in whalesong: "../version.rkt")
+         racket/runtime-path
+         racket/file
+         file/md5)
+
+
+(define cache-directory-path
+  (build-path (find-system-path 'pref-dir)
+              "whalesong"))
+
+(provide cached? save-in-cache!)
+
+
+;; create-cache-directory!: -> void
+(define (create-cache-directory!)
+  (unless (directory-exists? cache-directory-path)
+    (make-directory* cache-directory-path)))
+  
+
+;; clear-cache-files!: -> void
+;; Remove all the cache files.
+(define (clear-cache-files!)
+  (for ([file (directory-list cache-directory-path)])
+    (when (file-exists? (build-path cache-directory-path file))
+      (with-handlers ([exn:fail? void])
+        (delete-file (build-path cache-directory-path file))))))
+
+
+(define whalesong-cache.scm
+  (build-path cache-directory-path 
+              (format "whalesong-cache-~a.scm"
+                      whalesong:version)))
+
+
+(define (ensure-cache-db-structure!)
+  (when (not (file-exists? whalesong-cache.scm))
+    ;; Clear existing cache files: they're obsolete.
+    (clear-cache-files!)
+    (call-with-output-file whalesong-cache.scm
+      (lambda (op)
+        (write (make-hash) op)))))
+    
+
+
+(define (get-db)
+  (hash-copy (call-with-input-file whalesong-cache.scm read)))
+
+
+(define (write-db! hash)
+  (call-with-output-file whalesong-cache.scm
+    (lambda (op) (write hash op))
+    #:exists 'replace))
+
+
+
+
+(create-cache-directory!)
+(ensure-cache-db-structure!)
+(define db (get-db))
+
+
+
+
+;; cached?: path -> (U false bytes)
+;; Returns a true value, (vector path md5-signature data), if we can
+;; find an appropriate entry in the cache, and false otherwise.
+(define (cached? path)
+  (cond
+    [(file-exists? path)
+     (hash-ref db
+               (list (path->string path)
+                     (call-with-input-file* path md5))
+               #f)]
+    [else
+     #f]))
+
+
+;; save-in-cache!: path bytes -> void
+;; Saves a record.
+(define (save-in-cache! path data)
+  (cond
+    [(file-exists? path)
+     (define signature (call-with-input-file* path md5))
+     (hash-set! db
+                (list (path->string path)
+                      signature)
+                data)
+     (write-db! db)]
+    [else
+     (error 'save-in-cache! "File ~e does not exist" path)]))

js-assembler/package.rkt

@@ -10,6 +10,7 @@
          "../parser/path-rewriter.rkt"
          "../parser/parse-bytecode.rkt"
          "../resource/structs.rkt"
+	 "../promise.rkt"
          racket/match
          racket/list
          racket/promise
@@ -20,7 +21,35 @@
          (prefix-in query: "../lang/js/query.rkt")
          (prefix-in resource-query: "../resource/query.rkt")
          (prefix-in runtime: "get-runtime.rkt")
-         (prefix-in racket: racket/base))
+         (prefix-in racket: racket/base)
+         racket/runtime-path)
+
+
+;; Here, I'm trying to dynamically require the db-cache module
+;; because not everyone's going to have Sqlite3 installed.
+;; If this fails, just gracefully fall back to no caching.
+(define-runtime-path db-cache.rkt "db-cache.rkt")
+(define-runtime-path hash-cache.rkt "hash-cache.rkt")
+(define-values (impl-cached? impl-save-in-cache!)
+  (values (dynamic-require `(file ,(path->string hash-cache.rkt)) 
+                           'cached?)
+          (dynamic-require `(file ,(path->string hash-cache.rkt)) 
+                           'save-in-cache!))
+  #;(with-handlers ([exn:fail?
+                   (lambda (exn)
+                     (log-debug "Unable to use Sqlite3 cache.  Falling back to serialized hashtable cache.")
+                     (values (dynamic-require `(file ,(path->string hash-cache.rkt)) 
+                                              'cached?)
+                             (dynamic-require `(file ,(path->string hash-cache.rkt)) 
+                                              'save-in-cache!)))])
+    (parameterize ([current-namespace (make-base-namespace)])
+      (values
+       (dynamic-require `(file ,(path->string db-cache.rkt)) 
+                        'cached?)
+       (dynamic-require `(file ,(path->string db-cache.rkt)) 
+                        'save-in-cache!)))))
+
+
 
 ;; There is a dynamic require for (planet dyoo/closure-compile) that's done
 ;; if compression is turned on.
@@ -30,7 +59,6 @@
 
 
 (provide package
-         ;;package-anonymous
          package-standalone-xhtml
          get-inert-code
          get-standalone-code
@@ -95,8 +123,8 @@
     [(StatementsSource? src)
      #f]
     [(MainModuleSource? src)
-     (source-is-javascript-module?
+     (query:has-javascript-implementation?
-      (MainModuleSource-source src))]
+      `(file ,(path->string (MainModuleSource-path src))))]
     [(ModuleSource? src)
      (query:has-javascript-implementation?
       `(file ,(path->string (ModuleSource-path src))))]
@@ -110,8 +138,8 @@
     [(StatementsSource? src)
      empty]
     [(MainModuleSource? src)
-     (source-resources
+     (resource-query:query
-      (MainModuleSource-source src))]
+      `(file ,(path->string (MainModuleSource-path src))))]
     [(ModuleSource? src)
      (resource-query:query
       `(file ,(path->string (ModuleSource-path src))))]
@@ -136,27 +164,24 @@
                    provides))]
       [else
        ""]))
-  (cond
+
-    [(StatementsSource? src)
+
-     (error 'get-javascript-implementation src)]
+  (define (get-implementation-from-path path)
-    [(MainModuleSource? src)
+    (let* ([name (rewrite-path path)]
-     (get-javascript-implementation (MainModuleSource-source src))]
+	   [paths (query:query `(file ,(path->string path)))]
-    [(ModuleSource? src)
+	   [text (string-join
-     (let* ([name (rewrite-path (ModuleSource-path src))]
+		  (map (lambda (p)
-            [paths (query:query `(file ,(path->string (ModuleSource-path src))))]
+			 (call-with-input-file p port->string))
-            [text (string-join
+		       paths)
-                   (map (lambda (p)
+		  "\n")]
-                          (call-with-input-file p port->string))
+	   [module-requires (query:lookup-module-requires path)]
-                        paths)
+	   [bytecode (parse-bytecode path)])
-                   "\n")]
+      (when (not (empty? module-requires))
-            [module-requires (query:lookup-module-requires (ModuleSource-path src))]
+	    (log-debug "~a requires ~a"
-            [bytecode (parse-bytecode (ModuleSource-path src))])
+		       path
-       (when (not (empty? module-requires))
+		       module-requires))
-         (log-debug "~a requires ~a"
+      (let ([module-body-text
-                    (ModuleSource-path src)
+	     (format "
-                    module-requires))
-       (let ([module-body-text
-              (format "
              if(--M.cbt<0) { throw arguments.callee; }
              var modrec = M.modules[~s];
              var exports = {};
@@ -165,24 +190,34 @@
              ~a
              modrec.privateExports = exports;
              return M.c.pop().label(M);"
-                      (symbol->string name)
+		     (symbol->string name)
-                      text
+		     text
-                      (get-provided-name-code bytecode))])
+		     (get-provided-name-code bytecode))])
-         
+	
-         (make-UninterpretedSource
+	(make-UninterpretedSource
-          (format "
+	 (format "
 M.modules[~s] =
     new plt.runtime.ModuleRecord(~s,
         function(M) {
             ~a
         });
 "
-                  (symbol->string name)
+		 (symbol->string name)
-                  (symbol->string name)
+		 (symbol->string name)
-                  (assemble-modinvokes+body module-requires module-body-text))
+		 (assemble-modinvokes+body module-requires module-body-text))
-          
+	 
-          (map (lambda (p) (make-ModuleSource (normalize-path p)))
+	 (map (lambda (p) (make-ModuleSource (normalize-path p)))
-               module-requires))))]
+	      module-requires)))))
+
+
+
+  (cond
+    [(StatementsSource? src)
+     (error 'get-javascript-implementation src)]
+    [(MainModuleSource? src)
+     (get-implementation-from-path (MainModuleSource-path src))]
+    [(ModuleSource? src)
+     (get-implementation-from-path (ModuleSource-path src))]
     
     
     [(SexpSource? src)
@@ -283,7 +318,7 @@ M.modules[~s] =
          (fprintf op "(function(M) { ~a }(plt.runtime.currentMachine));" (UninterpretedSource-datum src))]
         [else      
          (fprintf op "(")
-         (assemble/write-invoke stmts op)
+         (on-source src stmts op)
          (fprintf op ")(plt.runtime.currentMachine,
                      function() {
                           if (window.console && window.console.log) {
@@ -327,14 +362,69 @@ M.modules[~s] =
      ;; last
      on-last-src))
   
-  (make (list (make-MainModuleSource source-code))
+  (make (list source-code) packaging-configuration)
-        packaging-configuration)
   
   (for ([r resources])
     ((current-on-resource) r)))
 
 
 
+;; on-source: Source (Promise (Listof Statement)) OutputPort -> void
+;; Generates the source for the statements here.
+;; Optimization: if we've seen this source before, we may be able to pull
+;; it from the cache.
+(define (on-source src stmts op)
+  (define (on-path path)
+    (cond
+      [(current-with-cache?)
+       (cond
+         [(cached? path)
+          =>
+          (lambda (bytes)
+            (display bytes op))]
+         [(cacheable? path)
+          (define string-op (open-output-bytes))
+          (assemble/write-invoke (my-force stmts) string-op)
+          (save-in-cache! path (get-output-bytes string-op))
+          (display (get-output-string string-op) op)]
+         [else
+          (assemble/write-invoke (my-force stmts) op)])]
+      [else
+       (assemble/write-invoke (my-force stmts) op)]))
+  (cond
+   [(ModuleSource? src)
+    (on-path (ModuleSource-path src))]
+   [(MainModuleSource? src)
+    (on-path (MainModuleSource-path src))]
+   [else
+    (assemble/write-invoke (my-force stmts) op)]))
+
+
+;; cached?: path -> (U false bytes)
+;; Returns a true value (the cached bytes) if we've seen this path
+;; and know its JavaScript-compiled bytes.
+(define (cached? path)
+  (impl-cached? path))
+
+
+
+;; cacheable?: path -> boolean
+;; Produces true if the file should be cached.
+;; At the current time, only cache modules that are provided
+;; by whalesong itself.
+(define (cacheable? path)
+  (within-whalesong-path? path))
+
+
+;; save-in-cache!: path bytes -> void
+;; Saves the bytes in the cache, associated with that path.
+;; TODO: Needs to sign with the internal version of Whalesong, and
+;; the md5sum of the path's content.
+(define (save-in-cache! path bytes)
+  (impl-save-in-cache! path bytes))
+
+
+
 
 ;; package-standalone-xhtml: X output-port -> void
 (define (package-standalone-xhtml source-code op)
@@ -361,7 +451,7 @@ M.modules[~s] =
           (lambda (src) #t)
           ;; on
           (lambda (src ast stmts)
-            (assemble/write-invoke stmts op)
+            (on-source src stmts op)
             (fprintf op "(M, function() { "))
           
           ;; after

js-assembler/runtime-src/baselib-check.js

@@ -134,6 +134,10 @@
         baselib.ports.isOutputPort,
         'output port');
 
+    var checkInputPort = makeCheckArgumentType(
+        baselib.ports.isInputPort,
+        'input port');
+
     var checkSymbol = makeCheckArgumentType(
         baselib.symbols.isSymbol,
         'symbol');
@@ -239,6 +243,17 @@
         baselib.srclocs.isSrcloc,
         'srcloc');
 
+    var checkContinuationMarkSet = makeCheckArgumentType(
+        baselib.contmarks.isContinuationMarkSet,
+        'continuation mark set');
+
+    var checkContinuationPromptTag = makeCheckArgumentType(
+        baselib.contmarks.isContinuationPromptTag,
+        'continuation prompt tag');
+
+    var checkExn = makeCheckArgumentType(
+        baselib.exceptions.isExn,
+        'exn');
 
     //////////////////////////////////////////////////////////////////////
 
@@ -248,8 +263,8 @@
     exports.makeCheckArgumentType = makeCheckArgumentType;
     exports.makeCheckParameterizedArgumentType = makeCheckParameterizedArgumentType;
     exports.makeCheckListofArgumentType = makeCheckListofArgumentType;
-
     exports.checkOutputPort = checkOutputPort;
+    exports.checkInputPort = checkInputPort;
     exports.checkSymbol = checkSymbol;
     exports.checkString = checkString;
     exports.checkSymbolOrString = checkSymbolOrString;
@@ -275,5 +290,8 @@
     exports.checkBoolean = checkBoolean;
     exports.checkPlaceholder = checkPlaceholder;
     exports.checkSrcloc = checkSrcloc;
+    exports.checkContinuationMarkSet = checkContinuationMarkSet;
+    exports.checkContinuationPromptTag = checkContinuationPromptTag;
+    exports.checkExn = checkExn;
 
 }(this.plt.baselib));

js-assembler/runtime-src/baselib-contmarks.js

@@ -1,5 +1,5 @@
 /*global plt*/
-/*jslint browser: true, unparam: true, vars: true, white: true, maxerr: 50, indent: 4 */
+/*jslint browser: true, unparam: true, vars: true, white: true, maxerr: 50, indent: 4 , plusplus: true */
 
 // Continuation marks
 (function(baselib) {
@@ -12,6 +12,11 @@
         this.kvlists = kvlists;
     };
 
+
+    ContinuationMarkSet.prototype.shift = function() {
+        this.kvlists.shift();
+    };
+
     ContinuationMarkSet.prototype.toDomNode = function(params) {
         var dom = document.createElement("span");
         dom.appendChild(document.createTextNode('#<continuation-mark-set>'));
@@ -41,8 +46,6 @@
         return baselib.lists.makeList.apply(null, result);
     };
 
-
-
     // Returns an approximate stack trace.
     // getContext: MACHINE -> (arrayof (U Procedure (Vector source line column position span)))
     ContinuationMarkSet.prototype.getContext = function(MACHINE) {
@@ -72,20 +75,29 @@
     };
 
 
+    var isContinuationMarkSet = baselib.makeClassPredicate(ContinuationMarkSet);
+
+
 
 
 
     // A continuation prompt tag labels a prompt frame.
     var ContinuationPromptTag = function(name) {
-	this.name = name;
+	this.name = name;         // String
+
     };
 
 
+    var isContinuationPromptTag = baselib.makeClassPredicate(ContinuationPromptTag);
 
-
+    var DEFAULT_CONTINUATION_PROMPT_TAG =
+        new ContinuationPromptTag("default-continuation-prompt-tag");
 
 
     exports.ContinuationMarkSet = ContinuationMarkSet;
+    exports.isContinuationMarkSet = isContinuationMarkSet;
     exports.ContinuationPromptTag = ContinuationPromptTag;
 
+    exports.isContinuationPromptTag = isContinuationPromptTag;
+    exports.DEFAULT_CONTINUATION_PROMPT_TAG = DEFAULT_CONTINUATION_PROMPT_TAG;
 }(this.plt.baselib));

js-assembler/runtime-src/baselib-exceptions.js

@@ -180,16 +180,6 @@
     exceptions.RacketError = RacketError;
     exceptions.isRacketError = isRacketError;
 
-
-    // exceptions.InternalError = InternalError;
-    // exceptions.internalError = function(v, contMarks) { return new InternalError(v, contMarks); };
-    // exceptions.isInternalError = function(x) { return x instanceof InternalError; };
-
-    // exceptions.IncompleteExn = IncompleteExn;
-    // exceptions.makeIncompleteExn = function(constructor, msg, args) { return new IncompleteExn(constructor, msg, args); };
-    // exceptions.isIncompleteExn = function(x) { return x instanceof IncompleteExn; };
-
-
     exceptions.Exn = Exn;
     exceptions.makeExn = Exn.constructor;
     exceptions.isExn = Exn.predicate;

js-assembler/runtime-src/baselib-ports.js

@@ -8,7 +8,6 @@
 
 
     // Output Ports
-
     var OutputPort = function () {};
     var isOutputPort = baselib.makeClassPredicate(OutputPort);
 
@@ -52,6 +51,84 @@
 
 
 
+    // Input ports
+    // Input Ports need to provide two things:
+    //
+    // readByte:
+    // callWhenReady:
+
+    var InputPort = function () {};
+    InputPort.prototype.readByte = function(MACHINE) {
+        return baselib.constants.EOF_VALUE;
+    };
+    InputPort.prototype.callWhenReady = function(MACHINE, k) {
+        throw new Error("unimplemented");
+    };
+    var isInputPort = baselib.makeClassPredicate(InputPort);
+
+
+    var StandardInputPort = function() {
+        this.content = [];
+        this.closed = false;
+    };
+    StandardInputPort.prototype = baselib.heir(InputPort.prototype);
+
+    StandardInputPort.prototype.readByte = function(MACHINE) {
+        if (this.content.length !== 0) {
+            return this.content.shift();
+        }
+        return baselib.constants.EOF_VALUE;
+    };
+
+    StandardInputPort.prototype.callWhenReady = function(MACHINE, k) {
+        if (this.content.length > 0) {
+            return k();
+        }
+        if (this.closed) {
+            return k();
+        }
+        var that = this;
+        var textFieldDiv = $("<div>" +
+                             "  <input class='readline' type='text' size='80%'/>" +
+                             "  <input class='eofread' type='button' value='EOF'/>"+
+                             "</div>");
+        var readLine = textFieldDiv.find(".readline");
+        var eofRead = textFieldDiv.find(".eofread");
+        var cleanupAndContinue = function() {
+            readLine.unbind('keypress');
+            eofRead.unbind('click');
+            textFieldDiv.remove();
+            return k();
+        };
+
+        readLine.keypress(
+            function(e) {
+                var val, i;
+                // On return, send the text content into that.content;
+                if (e.which === 13) {
+                    e.stopPropagation();
+                    e.preventDefault();
+                    val = readLine.val();
+                    for (i = 0; i < val.length; i++) {
+                        that.content.push(val.charCodeAt(i));
+                    }
+                    that.content.push('\n'.charCodeAt(0));
+                    cleanupAndContinue();
+                }
+            });
+        eofRead.click(
+            function(e) {
+                e.stopPropagation();
+                e.preventDefault();
+                that.closed = true;
+                cleanupAndContinue();
+            });
+        MACHINE.params['currentDisplayer'](MACHINE, textFieldDiv.get(0));
+        readLine.focus();
+    };
+
+
+    //////////////////////////////////////////////////////////////////////
     exports.OutputPort = OutputPort;
     exports.isOutputPort = isOutputPort;
     exports.StandardOutputPort = StandardOutputPort;
@@ -59,5 +136,9 @@
     exports.OutputStringPort = OutputStringPort;
     exports.isOutputStringPort = isOutputStringPort;
 
+    exports.InputPort = InputPort;
+    exports.isInputPort = isInputPort;
+    exports.StandardInputPort = StandardInputPort;
+
 
 }(this.plt.baselib, $));

js-assembler/runtime-src/baselib-primitives.js

@@ -1,3 +1,4 @@
+/*global plt*/
 /*jslint unparam: true, sub: true, vars: true, white: true, nomen: true, plusplus: true, maxerr: 50, indent: 4 */
 
 // Arity structure
@@ -60,6 +61,7 @@
     var testArgument = baselib.check.testArgument;
 
     var checkOutputPort = baselib.check.checkOutputPort;
+    var checkInputPort = baselib.check.checkInputPort;
     var checkString = baselib.check.checkString;
     var checkSymbolOrString = baselib.check.checkSymbolOrString;
     var checkMutableString = baselib.check.checkMutableString;
@@ -73,6 +75,17 @@
     var checkNatural = baselib.check.checkNatural;
     var checkNaturalInRange = baselib.check.checkNaturalInRange;
     var checkInteger = baselib.check.checkInteger;
+    var checkIntegerForChar = baselib.check.makeCheckArgumentType(
+        function(x) {
+            return (baselib.numbers.isInteger(x) && 
+                    ((baselib.numbers.lessThanOrEqual(0, x) && 
+                      baselib.numbers.lessThanOrEqual(x, 55295))
+                     ||
+                     (baselib.numbers.lessThanOrEqual(57344, x) && 
+                      baselib.numbers.lessThanOrEqual(x, 1114111))));
+        },
+        'integer'
+    );
     var checkRational = baselib.check.checkRational;
     var checkPair = baselib.check.checkPair;
     var checkList = baselib.check.checkList;
@@ -84,6 +97,9 @@
     var checkInspector = baselib.check.checkInspector;
     var checkPlaceholder = baselib.check.checkPlaceholder;
     var checkSrcloc = baselib.check.checkSrcloc;
+    var checkContinuationPromptTag = baselib.check.checkContinuationPromptTag;
+    var checkContinuationMarkSet = baselib.check.checkContinuationMarkSet;
+    var checkExn = baselib.check.checkExn;
     //////////////////////////////////////////////////////////////////////
 
 
@@ -162,7 +178,7 @@
 
 
     installPrimitiveProcedure(
-        'write-byte', 
+        'write-byte',
         makeList(1, 2),
         function (M) {
             var firstArg = checkByte(M, 'write-byte', 0);
@@ -179,7 +195,7 @@
         'newline', makeList(0, 1),
         function (M) {
             var outputPort = M.params.currentOutputPort;
-            if (M.a === 1) { 
+            if (M.a === 1) {
                 outputPort = checkOutputPort(M, 'newline', 1);
             }
             outputPort.writeDomNode(M, toDomNode("\n", 'display'));
@@ -225,7 +241,7 @@
                 args.push(M.e[M.e.length - 1 - i]);
             }
             result = baselib.format.format(formatString, args, 'format');
-            outputPort = M.params.currentOutputPort;            
+            outputPort = M.params.currentOutputPort;
             outputPort.writeDomNode(M, toDomNode(result, 'display'));
             return VOID;
         });
@@ -248,15 +264,12 @@
 
 
 
-
-
-
     installPrimitiveProcedure(
         'current-print',
         makeList(0, 1),
         function (M) {
             if (M.a === 1) {
-                M.params['currentPrint'] =                 
+                M.params['currentPrint'] =
                     checkProcedure(M, 'current-print', 0);
                 return VOID;
             } else {
@@ -283,7 +296,7 @@
         makeList(0, 1),
         function (M) {
             if (M.a === 1) {
-                M.params['currentOutputPort'] = 
+                M.params['currentOutputPort'] =
                     checkOutputPort(M, 'current-output-port', 0);
                 return VOID;
             } else {
@@ -298,7 +311,7 @@
         makeList(0, 1),
         function (M) {
             if (M.a === 1) {
-                M.params['currentErrorPort'] = 
+                M.params['currentErrorPort'] =
                     checkOutputPort(M, 'current-output-port', 0);
                 return VOID;
             } else {
@@ -308,9 +321,40 @@
 
 
 
+    installPrimitiveProcedure(
+        'current-input-port',
+        makeList(0, 1),
+        function (M) {
+            if (M.a === 1) {
+                M.params['currentInputPort'] =
+                    checkInputPort(M, 'current-input-port', 0);
+                return VOID;
+            } else {
+                return M.params['currentInputPort'];
+            }
+        });
 
 
 
+    installPrimitiveClosure(
+        'read-byte',
+        makeList(0, 1),
+        function(M) {
+            var inputPort = M.params['currentInputPort'];
+            if (M.a === 1) {
+                inputPort = checkInputPort(M, 'read-byte', 0);
+            }
+            plt.runtime.PAUSE(function(restart) {
+                inputPort.callWhenReady(M, function() {
+                    restart(function(MACHINE) {
+                        plt.runtime.finalizeClosureCall(MACHINE,
+                                                        inputPort.readByte(MACHINE));
+                    });
+                });
+            });
+        });
+
+
 
     installPrimitiveProcedure(
         '=',
@@ -321,14 +365,13 @@
             for (i = 1; i < M.a; i++) {
                 secondArg = checkNumber(M, '=', i);
                 if (! (baselib.numbers.equals(firstArg, secondArg))) {
-                    return false; 
+                    return false;
                 }
             }
             return true;
         });
 
 
-    
     installPrimitiveProcedure(
         '=~',
         3,
@@ -337,7 +380,7 @@
             var y = checkReal(M, '=~', 1);
             var range = checkNonNegativeReal(M, '=~', 2);
             return baselib.numbers.lessThanOrEqual(
-                baselib.numbers.abs(baselib.numbers.subtract(x, y)), 
+                baselib.numbers.abs(baselib.numbers.subtract(x, y)),
                 range);
         });
 
@@ -349,7 +392,7 @@
             for (i = 1; i < M.a; i++) {
                 secondArg = checkNumber(M, name, i);
                 if (! (predicate(firstArg, secondArg))) {
-                    return false; 
+                    return false;
                 }
                 firstArg = secondArg;
             }
@@ -379,7 +422,7 @@
         '>=',
         baselib.arity.makeArityAtLeast(2),
         makeChainingBinop(baselib.numbers.greaterThanOrEqual, '>='));
-    
+
 
     installPrimitiveProcedure(
         '+',
@@ -389,12 +432,12 @@
             var i = 0;
             for (i = 0; i < M.a; i++) {
                 result = baselib.numbers.add(
-                    result, 
+                    result,
                     checkNumber(M, '+', i));
             }
             return result;
         });
-    
+
 
     installPrimitiveProcedure(
         '*',
@@ -404,7 +447,7 @@
             var i = 0;
             for (i=0; i < M.a; i++) {
                 result = baselib.numbers.multiply(
-                    result, 
+                    result,
                     checkNumber(M, '*', i));
             }
             return result;
@@ -414,20 +457,20 @@
         '-',
         baselib.arity.makeArityAtLeast(1),
         function (M) {
-            if (M.a === 1) { 
+            if (M.a === 1) {
                 return baselib.numbers.subtract(
-                    0, 
+                    0,
                     checkNumber(M, '-', 0));
             }
             var result = checkNumber(M, '-', 0), i;
             for (i = 1; i < M.a; i++) {
                 result = baselib.numbers.subtract(
-                    result, 
+                    result,
                     checkNumber(M, '-', i));
             }
             return result;
         });
-    
+
     installPrimitiveProcedure(
         '/',
         baselib.arity.makeArityAtLeast(1),
@@ -440,7 +483,6 @@
             }
             return result;
         });
-    
 
     installPrimitiveProcedure(
         'add1',
@@ -571,7 +613,6 @@
             return VOID;
         });
 
-    
     installPrimitiveProcedure(
         'not',
         1,
@@ -621,7 +662,6 @@
             }
             return makeVector(arr.length, arr);
         });
-    
 
     installPrimitiveProcedure(
         'vector->list',
@@ -636,7 +676,6 @@
             return result;
         });
 
-    
     installPrimitiveProcedure(
         'list->vector',
         1,
@@ -1053,6 +1092,15 @@
         });
 
 
+    installPrimitiveProcedure(
+        'integer->char',
+        1,
+        function(M) {
+            var ch = baselib.numbers.toFixnum(checkIntegerForChar(M, 'integer->char', 0));
+            return baselib.chars.makeChar(String.fromCharCode(ch));
+        });
+
+    
     installPrimitiveProcedure(
         'char-upcase',
         1,
@@ -1072,7 +1120,6 @@
 
 
 
-    
     installPrimitiveProcedure(
         'box',
         1,
@@ -1154,7 +1201,7 @@
     // implementation of apply in the boostrapped-primitives.rkt,
     // since it provides nicer error handling.
     var applyImplementation = function (M) {
-        if(--M.callsBeforeTrampoline < 0) { 
+        if(--M.callsBeforeTrampoline < 0) {
             throw applyImplementation;
         }
         var proc = checkProcedure(M, 'apply', 0);
@@ -1193,7 +1240,7 @@
         function (M) {
             return baselib.functions.isProcedure(M.e[M.e.length - 1]);
         });
-    
+
     installPrimitiveProcedure(
         'procedure-arity-includes?',
         2,
@@ -1244,9 +1291,8 @@
                     return lst;
                 }
                 lst = lst.rest;
-            }   
+            }
         });
-    
 
 
     installPrimitiveProcedure(
@@ -1264,7 +1310,12 @@
         });
 
 
-
+    installPrimitiveProcedure(
+        'eof-object?',
+        1,
+        function(M) {
+            return M.e[M.e.length -1] === baselib.constants.EOF_VALUE;
+        });
 
     installPrimitiveProcedure(
 	'number?',
@@ -1383,7 +1434,6 @@
                 checkNumber(M, 'tan', 0));
         });
 
-    
 
     installPrimitiveProcedure(
         'atan',
@@ -1591,7 +1641,7 @@
             return baselib.numbers.floor(
                 checkReal(M, 'floor', 0));
         });
-    
+
 
     installPrimitiveProcedure(
         'ceiling',
@@ -1600,7 +1650,7 @@
             return baselib.numbers.ceiling(
                 checkReal(M, 'ceiling', 0));
         });
-    
+
 
     installPrimitiveProcedure(
         'round',
@@ -1609,7 +1659,7 @@
             return baselib.numbers.round(
                 checkReal(M, 'round', 0));
         });
-    
+
 
     installPrimitiveProcedure(
         'truncate',
@@ -1622,7 +1672,7 @@
                 return baselib.numbers.floor(n);
             }
         });
-    
+
 
     installPrimitiveProcedure(
         'numerator',
@@ -1735,10 +1785,10 @@
 	    var i;
             if (M.a === 1) {
                 var sym = checkSymbol(M, 'error', 1);
-                raise(M, baselib.exceptions.makeExnFail(sym.toString(), 
+                raise(M, baselib.exceptions.makeExnFail(sym.toString(),
                                                         M.captureContinuationMarks()));
-            } 
+            }
-            
+
             if (isString(M.e[M.e.length - 1])) {
                 var vs = [];
                 for (i = 1; i < M.a; i++) {
@@ -1767,6 +1817,18 @@
         });
 
 
+    installPrimitiveProcedure(
+        'raise',
+        makeList(1, 2),
+        function(M) {
+            var v = M.e[M.e.length - 1];
+            // At the moment, not using the continuation barrier yet.
+            // var withBarrier = M.e[M.e.length - 2];
+            raise(M, v);
+        });
+
+
+
     installPrimitiveProcedure(
         'raise-mismatch-error',
         3,
@@ -1790,23 +1852,112 @@
             var name = checkSymbol(M, 'raise-type-error', 0);
             var expected = checkString(M, 'raise-type-error', 1);
             if (M.a === 3) {
-                raiseArgumentTypeError(M, 
+                raiseArgumentTypeError(M,
                                        name,
                                        expected,
                                        undefined,
                                        M.e[M.e.length - 1 - 2]);
             } else {
-                raiseArgumentTypeError(M, 
+                raiseArgumentTypeError(M,
                                        name,
                                        expected,
                                        checkNatural(M, 'raise-type-error', 2),
                                        M.e[M.e.length - 1 - 2]);
             }
         });
-    
 
 
 
+    installPrimitiveProcedure(
+        'make-exn',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn', 1);
+            return baselib.exceptions.makeExn(message, marks);
+        });
+
+
+    installPrimitiveProcedure(
+        'make-exn:fail',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn:fail', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn:fail', 1);
+            return baselib.exceptions.makeExnFail(message, marks);
+        });
+
+
+    installPrimitiveProcedure(
+        'make-exn:fail:contract',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn:fail:contract', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract', 1);
+            return baselib.exceptions.makeExnFailContract(message, marks);
+        });
+
+
+    installPrimitiveProcedure(
+        'make-exn:fail:contract:arity',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn:fail:contract:arity', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:arity', 1);
+            return baselib.exceptions.makeExnFailContractArity(message, marks);
+        });
+
+    installPrimitiveProcedure(
+        'make-exn:fail:contract:variable',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn:fail:contract:variable', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:variable', 1);
+            return baselib.exceptions.makeExnFailContractVariable(message, marks);
+        });
+
+    installPrimitiveProcedure(
+        'make-exn:fail:contract:divide-by-zero',
+        2,
+        function(M) {
+            var message = checkString(M, 'make-exn:fail:contract:divide-by-zero', 0);
+            var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:divide-by-zero', 1);
+            return baselib.exceptions.makeExnFailContractDivisionByZero(message, marks);
+        });
+
+    installPrimitiveProcedure(
+        'exn-message',
+        1,
+        function(M) {
+            var exn = checkExn(M, 'exn-message', 0);
+            return baselib.exceptions.exnMessage(exn);
+        });
+
+    installPrimitiveProcedure(
+        'exn-continuation-marks',
+        1,
+        function(M) {
+            var exn = checkExn(M, 'exn-continuation-marks', 0);
+            return baselib.exceptions.exnContMarks(exn);
+        });
+
+
+    installPrimitiveProcedure(
+        'current-continuation-marks',
+        makeList(0, 1),
+        function(M) {
+            var promptTag;
+            if (M.a === 1) {
+                promptTag = checkContinuationPromptTag(M, 'current-continuation-marks', 0);
+            }
+            var contMarks = M.captureContinuationMarks(promptTag);
+            // The continuation marks shouldn't capture the record of the call to
+            // current-continuation-marks itself.
+            contMarks.shift();
+            return contMarks;
+        });
+
+
     installPrimitiveClosure(
         'make-struct-type',
         makeList(4, 5, 6, 7, 8, 9, 10, 11),
@@ -1814,14 +1965,14 @@
             withArguments(
                 M,
                 4,
-                [false, 
+                [false,
                  NULL,
                  false,
                  false,
                  NULL,
                  false,
                  false],
-                function (name, 
+                function (name,
                           superType,
                           initFieldCount,
                           autoFieldCount,
@@ -1848,7 +1999,7 @@
                         //immutables,
                         guard);
 
-                    var constructorValue = 
+                    var constructorValue =
                         makePrimitiveProcedure(
                             constructorName,
                             baselib.numbers.toFixnum(initFieldCount),
@@ -1861,7 +2012,7 @@
                                 return structType.constructor.apply(null, args);
                             });
 
-                    var predicateValue = 
+                    var predicateValue =
                         makePrimitiveProcedure(
                             name.toString() + "?",
                             1,
@@ -1869,7 +2020,7 @@
                                 return structType.predicate(M.e[M.e.length - 1]);
                             });
 
-                    var accessorValue = 
+                    var accessorValue =
                         makePrimitiveProcedure(
                             name.toString() + "-accessor",
                             2,
@@ -1880,7 +2031,7 @@
                             });
                     accessorValue.structType = structType;
 
-                    var mutatorValue = 
+                    var mutatorValue =
                         makePrimitiveProcedure(
                             name.toString() + "-mutator",
                             3,
@@ -1901,21 +2052,21 @@
                                         mutatorValue);
                 });
         });
-    
+
 
     installPrimitiveProcedure(
         'current-inspector',
         makeList(0, 1),
         function (M) {
             if (M.a === 1) {
-                M.params['currentInspector'] = 
+                M.params['currentInspector'] =
                     checkInspector(M, 'current-inspector', 0);
                 return VOID;
             } else {
                 return M.params['currentInspector'];
             }
         }
-    ); 
+    );
 
 
     installPrimitiveProcedure(
@@ -1941,7 +2092,6 @@
                         aStruct,
                         baselib.numbers.toFixnum(index));
                 });
-            
         });
 
 
@@ -1968,7 +2118,7 @@
                         aStruct,
                         baselib.numbers.toFixnum(index),
                         M.e[M.e.length - 2]);
-                });            
+                });
         });
 
 
@@ -1991,7 +2141,6 @@
             return VOID;
         });
 
-        
 
     installPrimitiveProcedure(
         'make-reader-graph',
@@ -2058,6 +2207,7 @@
             return baselib.srclocs.srclocColumn(checkSrcloc(M, 'srcloc-column', 0));
         });
 
+
     installPrimitiveProcedure(
         'srcloc-position',
         1,
@@ -2065,6 +2215,7 @@
             return baselib.srclocs.srclocPosition(checkSrcloc(M, 'srcloc-position', 0));
         });
 
+
     installPrimitiveProcedure(
         'srcloc-span',
         1,
@@ -2072,9 +2223,45 @@
             return baselib.srclocs.srclocSpan(checkSrcloc(M, 'srcloc-span', 0));
         });
 
+
+
+    installPrimitiveProcedure(
+        'make-continuation-prompt-tag',
+        makeList(0, 1),
+        function(M) {
+            var sym;
+            if (M.a === 1) {
+                sym = checkSymbol(M, "make-continuation-prompt-tag", 0);
+                return new baselib.contmarks.ContinuationPromptTag(sym.toString());
+            }
+            return new baselib.contmarks.ContinuationPromptTag(undefined);
+        });
+
+    installPrimitiveProcedure(
+        'continuation-prompt-tag?',
+        1,
+        function(M) {
+            return baselib.contmarks.isContinuationPromptTag(M.e[M.e.length - 1]);
+        });
+
+
+
+    installPrimitiveProcedure(
+        'default-continuation-prompt-tag',
+        0,
+        function(M) {
+            return baselib.contmarks.DEFAULT_CONTINUATION_PROMPT_TAG;
+        });
+
+
+
+
+
+
+
     exports['Primitives'] = Primitives;
-    exports['installPrimitiveProcedure'] = installPrimitiveProcedure; 
+    exports['installPrimitiveProcedure'] = installPrimitiveProcedure;
-    exports['installPrimitiveClosure'] = installPrimitiveClosure; 
+    exports['installPrimitiveClosure'] = installPrimitiveClosure;
-    exports['installPrimitiveConstant'] = installPrimitiveConstant; 
+    exports['installPrimitiveConstant'] = installPrimitiveConstant;
 
 }(this.plt.baselib));

js-assembler/runtime-src/runtime.js

@@ -93,6 +93,7 @@
     var isOutputPort = baselib.ports.isOutputPort;
     var StandardOutputPort = baselib.ports.StandardOutputPort;
     var StandardErrorPort = baselib.ports.StandardErrorPort;
+    var StandardInputPort = baselib.ports.StandardInputPort;
     var isOutputStringPort = baselib.ports.isOutputStringPort;
 
 
@@ -247,6 +248,7 @@
 	    
 	    'currentOutputPort': new StandardOutputPort(),
 	    'currentErrorPort': new StandardErrorPort(),
+            'currentInputPort': new StandardInputPort(),
 	    'currentSuccessHandler': function(MACHINE) {},
 	    'currentErrorHandler': function(MACHINE, exn) {
                 MACHINE.params.currentErrorDisplayer(
@@ -381,12 +383,16 @@
     };
 
 
-    Machine.prototype.captureContinuationMarks = function() {
+    Machine.prototype.captureContinuationMarks = function(promptTag) {
         var kvLists = [];
         var i;
         var control = this.c;
         var tracedCalleeKey = getTracedCalleeKey(this);
         for (i = control.length-1; i >= 0; i--) {
+            if (promptTag !== null &&
+                control[i] instanceof PromptFrame && control[i].tag === promptTag) {
+                break;
+            }
             if (control[i].marks.length !== 0) {
                 kvLists.push(control[i].marks);
             }
@@ -396,7 +402,7 @@
                 control[i].p !== null) {
                 kvLists.push([[tracedCalleeKey, control[i].p]]);
             }
-        }     
+        }
         return new baselib.contmarks.ContinuationMarkSet(kvLists);
     };
     
@@ -565,8 +571,8 @@
 
     // There is a single, distinguished default continuation prompt tag
     // that's used to wrap around toplevel prompts.
-    var DEFAULT_CONTINUATION_PROMPT_TAG = 
+    var DEFAULT_CONTINUATION_PROMPT_TAG =
-	new ContinuationPromptTag("default-continuation-prompt-tag");
+        baselib.contmarks.DEFAULT_CONTINUATION_PROMPT_TAG;
 
 
 

lang/js/query.rkt

@@ -18,38 +18,44 @@
 (define-runtime-path record.rkt "record.rkt")
 (define ns (make-gui-namespace))
 
+
+(define (my-resolve-module-path a-module-path)
+  (resolve-module-path a-module-path #f))
+
+
+
 ;; query: module-path -> string?
 ;; Given a module, see if it's implemented via Javascript.
 (define (query a-module-path)
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'lookup-javascript-implementation) resolved-path))))
 
 
 ;; has-javascript-implementation?:  module-path -> boolean
 (define (has-javascript-implementation? a-module-path)  
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'has-javascript-implementation?) resolved-path))))
   
 
 
 ;; redirected? path -> boolean
 (define (redirected? a-module-path)
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       (path? ((dynamic-require-for-syntax record.rkt 'follow-redirection)
               resolved-path)))))
 
 
 ;; follow-redirection: module-path -> path
 (define (follow-redirection a-module-path)
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'follow-redirection)
        resolved-path))))
 
@@ -57,15 +63,15 @@
 
 ;; collect-redirections-to: module-path -> (listof path)
 (define (collect-redirections-to a-module-path)
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'collect-redirections-to)
        resolved-path))))
 
 
 (define (lookup-module-requires a-module-path)
-  (let ([resolved-path (resolve-module-path a-module-path #f)])
+  (let ([resolved-path (my-resolve-module-path a-module-path)])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'lookup-module-requires) resolved-path))))

lang/kernel.rkt

@@ -2,6 +2,7 @@
 (require (prefix-in racket: (only-in racket/math pi sinh cosh sqr
                                      sgn conjugate))
          (prefix-in racket: racket/base)
+         racket/provide
 	 racket/local
 	 (for-syntax racket/base)
          racket/stxparam
@@ -123,6 +124,7 @@
 	 begin-for-syntax
 	 prefix-in
 	 only-in
+         rename-in
 	 provide
 	 planet
 	 all-defined-out
@@ -130,6 +132,8 @@
 	 except-out
 	 rename-out
 	 struct-out
+         filtered-out
+         
          define-syntax-rule
 	 define-syntax
 	 define-syntaxes
@@ -207,7 +211,7 @@
  displayln
 
  
-;;  current-continuation-marks
+ current-continuation-marks
 
 ;;  continuation-mark-set?
 ;;  continuation-mark-set->list
@@ -233,21 +237,22 @@
   random
 ;;  sleep
 ;;  (identity -identity)
-;;  raise
+
-  
+raise  
 error
 raise-type-error
 raise-mismatch-error
 
-;;  make-exn
+make-exn
-;;  make-exn:fail
+make-exn:fail
-;;  make-exn:fail:contract
+make-exn:fail:contract
-;;  make-exn:fail:contract:arity
+make-exn:fail:contract:arity
-;;  make-exn:fail:contract:variable
+make-exn:fail:contract:variable
-;;  make-exn:fail:contract:divide-by-zero
+make-exn:fail:contract:divide-by-zero
+
+exn-message
+exn-continuation-marks
 
-;;  exn-message
-;;  exn-continuation-marks
 
 ;;  exn?
 ;;  exn:fail?
@@ -445,23 +450,27 @@ char=?
 ;;  char-upper-case?
 ;;  char-lower-case?
 ;;  char->integer
-;;  integer->char
+  integer->char
   char-upcase
   char-downcase
 
- 
+  
-;;  call-with-current-continuation
+  ;; these are defined in bootstrapped-primitives in Whalesong's compiler package
+  call-with-current-continuation
   call/cc
-;;  call-with-continuation-prompt
+
-;;  abort-current-continuation
+  ;;  call-with-continuation-prompt
-;;  default-continuation-prompt-tag
+  ;;  abort-current-continuation
-;;  make-continuation-prompt-tag
+  default-continuation-prompt-tag
-;;  continuation-prompt-tag?
+  make-continuation-prompt-tag
+  continuation-prompt-tag?
 
   make-reader-graph
   make-placeholder
-  placeholder-set!)
+  placeholder-set!
 
+  eof-object?
+  read-byte)
 
 
 

make/make-structs.rkt

@@ -3,7 +3,8 @@
 (require "../compiler/il-structs.rkt"
          "../compiler/bootstrapped-primitives.rkt"
          "../compiler/expression-structs.rkt"
-         "get-dependencies.rkt")
+         "get-dependencies.rkt"
+	 "../promise.rkt")
 
 
 
@@ -19,7 +20,7 @@
 
 (define-struct: StatementsSource ([stmts : (Listof Statement)])
   #:transparent)
-(define-struct: MainModuleSource ([source : Source])
+(define-struct: MainModuleSource ([path : Path])
   #:transparent)
 (define-struct: ModuleSource ([path : Path])
   #:transparent)
@@ -39,7 +40,7 @@
    [(UninterpretedSource? a-source)
     "<UninterpretedSource>"]
    [(MainModuleSource? a-source)
-    "<MainModuleSource>"]
+    (format "<MainModuleSource ~a>" (MainModuleSource-path a-source))]
    [(SexpSource? a-source)
     "<SexpSource>"]
    [(ModuleSource? a-source)
@@ -51,11 +52,11 @@
 (define-struct: Configuration
   ([wrap-source : (Source -> Source)]
    [should-follow-children? : (Source -> Boolean)]
-   [on-module-statements : (Source
+   [on-source : (Source 
-                            (U Expression #f)
+                 (U Expression #f) 
-                            (Listof Statement)
+                 (MyPromise (Listof Statement)) 
-                            -> Void)]
+                 -> Void)]
-   [after-module-statements : (Source -> Void)]
+   [after-source : (Source -> Void)]
    [after-last : (-> Void)])
   #:mutable)
 

make/make.rkt

@@ -10,7 +10,8 @@
          "get-dependencies.rkt"
          "make-structs.rkt"
          racket/list
-         racket/match)
+         racket/match
+	 "../promise.rkt")
 
 
 (require/typed "../logger.rkt"
@@ -39,36 +40,41 @@
 
    
 (: get-ast-and-statements (Source -> (values (U False Expression)
-                                             (Listof Statement))))
+                                             (MyPromise (Listof Statement)))))
 (define (get-ast-and-statements a-source)
   (cond
    [(StatementsSource? a-source)
-    (values #f (StatementsSource-stmts a-source))]
+    (values #f (my-delay (StatementsSource-stmts a-source)))]
 
    [(UninterpretedSource? a-source)
-    (values #f '())]
+    (values #f (my-delay '()))]
    
    [(MainModuleSource? a-source)
     (let-values ([(ast stmts)
-                  (get-ast-and-statements (MainModuleSource-source a-source))])
+                  (get-ast-and-statements (make-ModuleSource (MainModuleSource-path a-source)))])
-      (let ([maybe-module-locator (find-module-locator ast)])
+      (values ast
-        (cond
+	      (my-delay
-         [(ModuleLocator? maybe-module-locator)
+		(let ([maybe-module-locator (find-module-locator ast)])
-          (values ast (append stmts
+		  (cond
-                             ;; Set the main module name
+		   [(ModuleLocator? maybe-module-locator)
-                              (list (make-PerformStatement
+		    (append (my-force stmts)
-                                     (make-AliasModuleAsMain!
+			    ;; Set the main module name
-                                      maybe-module-locator)))))]
+			    (list (make-PerformStatement
-         [else
+				   (make-AliasModuleAsMain!
-          (values ast stmts)])))]
+				    maybe-module-locator))))]
-
+		   [else
+		    (my-force stmts)])))))]
    [else
     (let ([ast (get-ast a-source)])
-      (define start-time (current-inexact-milliseconds))
+      (values ast
-      (define compiled-code (compile ast 'val next-linkage/drop-multiple))
+	      (my-delay 
-      (define stop-time (current-inexact-milliseconds))
+		(define start-time (current-inexact-milliseconds))
-      (fprintf (current-timing-port) "  compile ast: ~a milliseconds\n" (- stop-time start-time))
+		(define compiled-code (compile ast 'val next-linkage/drop-multiple))
-      (values ast compiled-code))]))
+		(define stop-time (current-inexact-milliseconds))
+		(fprintf (current-timing-port) 
+			 "  compile ast: ~a milliseconds\n" 
+			 (- stop-time start-time))
+		compiled-code)))]))
 
 
 
@@ -122,7 +128,7 @@
     (match config
       [(struct Configuration (wrap-source
                               should-follow-children?
-                              on-module-statements
+                              on-source
                               after-module-statements
                               after-last))
 
@@ -177,7 +183,7 @@
                            [(ast stmts)
                             (get-ast-and-statements this-source)])
                (log-debug (format "visiting ~a\n" (source-name this-source)))
-               (on-module-statements this-source ast stmts)
+               ((Configuration-on-source config) this-source ast stmts)
                (define start-time (current-inexact-milliseconds))
                (define new-dependencies (map wrap-source (collect-new-dependencies this-source ast)))
                (define end-time (current-inexact-milliseconds))

parameters.rkt

@@ -20,6 +20,8 @@
          current-kernel-module-locator?
          current-compress-javascript?
          current-one-module-per-file?
+         current-with-cache?
+         
          
          current-report-port
          current-timing-port
@@ -82,6 +84,11 @@
 (define current-one-module-per-file? (make-parameter #f))
 
 
+;; Turns on caching of compiled programs, so that repeated compilations
+;; will reuse existing work.
+(: current-with-cache? (Parameterof Boolean))
+(define current-with-cache? (make-parameter #t))
+
 
 
 (: current-report-port (Parameterof Output-Port))

parser/parse-bytecode.rkt

@@ -32,10 +32,3 @@
      (parse-bytecode x)]
     [else
      (parse-bytecode x)]))
-
-
-(define cache-dir (build-path (find-system-path 'pref-dir)
-                              "whalesong"
-                              whalesong:version))
-(unless (directory-exists? cache-dir)
-  (make-directory* cache-dir))

parser/path-rewriter.rkt

@@ -9,7 +9,8 @@
 
 
 
-(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))])
+(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
+                  [within-whalesong-path? (complete-path? . -> . boolean?)])
 
 
 
@@ -31,7 +32,7 @@
 (define (rewrite-path a-path)
   (let ([a-path (normalize-path a-path)])
     (cond
-     [(within-this-project-path? a-path)
+     [(within-whalesong-path? a-path)
       (string->symbol
        (string-append "whalesong/"
                       (path->string
@@ -60,7 +61,7 @@
   (within? collects-path a-path))
 
 
-(define (within-this-project-path? a-path)
+(define (within-whalesong-path? a-path)
   (within? normal-whalesong-path a-path))
 
 

promise.rkt

@@ -0,0 +1,39 @@
+#lang typed/racket/base
+(require (for-syntax racket/base))
+
+;; Working around what appears to be a bug in Typed Racket
+;; by implementing my own promises.
+
+(provide my-delay my-force MyPromise)
+
+
+(define-struct: Sentinel ())
+
+
+(define-struct: (a) MyPromise ([forced? : Boolean]
+                               [thunk : (-> a)]
+                               [val : (U Sentinel a)])
+  #:mutable)
+
+
+(define-syntax (my-delay stx)
+  (syntax-case stx ()
+    [(_ expr ...)
+     (syntax/loc stx
+       (make-MyPromise #f
+		       (lambda () expr ...)
+		       (make-Sentinel)))]))
+
+(: my-force (All (a) (MyPromise a) -> a))
+(define (my-force a-promise)
+  (cond
+   [(MyPromise-forced? a-promise)
+    (define val (MyPromise-val a-promise))
+    (if (Sentinel? val)
+	(error 'force "Impossible")
+	val)]
+   [else
+    (define val ((MyPromise-thunk a-promise)))
+    (set-MyPromise-val! a-promise val)
+    (set-MyPromise-forced?! a-promise #t)
+    val]))

resource/query.rkt

@@ -18,5 +18,5 @@
 (define (query a-module-path)
   (let ([resolved-path (normalize-path (resolve-module-path a-module-path #f))])
     (parameterize ([current-namespace ns])
-      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (dynamic-require resolved-path (void)) ;; get the compile-time code running.
       ((dynamic-require-for-syntax record.rkt 'get-records) resolved-path))))

tests/browser-harness.rkt

@@ -78,7 +78,7 @@
   (flush-output (current-output-port))
   (let* ([exp (call-with-input-file expected-file-path port->string)]
          [src-path source-file-path]
-         [result (evaluate (make-MainModuleSource (make-ModuleSource src-path)))]
+         [result (evaluate (make-MainModuleSource src-path))]
          [output (evaluated-stdout result)])
     (cond [(string=? (strip-paths output)
                      (strip-paths exp))

version.rkt

@@ -1,4 +1,9 @@
 #lang typed/racket/base
+
+;; This is an internal version string.  It should have no external meaning.
+;; This file is touched by "bump.version.rkt": do not edit this file manually unless
+;; you really know what you're doing.
+
 (provide version)
 (: version String)
-(define version "1.0")
+(define version "1.41")

whalesong-helpers.rkt

@@ -77,7 +77,8 @@
         (call-with-output-file* (build-path (current-output-dir) output-filename)
                                 (lambda (op)
                                   (package-standalone-xhtml
-                                   (make-ModuleSource (build-path f))
+                                   (make-MainModuleSource 
+                                    (normalize-path (build-path f)))
                                    op))
                                 #:exists 'replace)))))
 
@@ -140,7 +141,8 @@
         (call-with-output-file* (make-output-js-filename)
                                 (lambda (op)
                                   (display (get-runtime) op)
-                                  (display (get-inert-code (make-ModuleSource (build-path f))
+                                  (display (get-inert-code (make-MainModuleSource 
+                                                            (normalize-path (build-path f)))
                                                            make-output-js-filename)
                                            op))
                                 #:exists 'replace)
@@ -170,5 +172,6 @@
 (define (get-javascript-code filename)
   (turn-on-logger!)
   (display (get-standalone-code
-            (make-ModuleSource (build-path filename)))
+            (make-MainModuleSource 
+             (normalize-path (build-path filename))))
            (current-output-port)))

whalesong.rkt

@@ -41,7 +41,7 @@
        (if (with-profiling?)
            (profile expr
                     #:threads #t
-                    #:delay 0.01
+                    #:delay 0.0001
                     #:render (lambda (profile)
                                (render profile
                                        #:truncate-source 500)))
@@ -66,6 +66,9 @@
             [("--enable-profiling")
              ("Enable profiling to standard output")
              (with-profiling? #t)]
+            [("--without-cache")
+             ("Turn off the internal compilation cache")
+             (current-with-cache? #f)]
             [("--compress-javascript")
              ("Compress JavaScript with Google Closure (requires Java)")
              (current-compress-javascript? #t)]
@@ -98,6 +101,9 @@
                   [("--enable-profiling")
                    ("Enable profiling to standard output")
                    (with-profiling? #t)]
+                  [("--without-cache")
+                   ("Turn off the internal compilation cache")
+                   (current-with-cache? #f)]
                   [("--compress-javascript")
                    ("Compress JavaScript with Google Closure (requires Java)")
                    (current-compress-javascript? #t)]
@@ -117,6 +123,9 @@
                      [("--enable-profiling")
                       ("Enable profiling to standard output")
                       (with-profiling? #t)]
+                     [("--without-cache")
+                      ("Turn off the internal compilation cache")
+                      (current-with-cache? #f)]
                      [("--compress-javascript")
                       ("Compress JavaScript with Google Closure (requires Java)")
                       (current-compress-javascript? #t)]