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

Merge remote-tracking branch 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-09-25 20:34:44 -04:00
commit 54d8dd1c1c
27 changed files with 1383 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

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

20
bump-version.rkt Normal file
View File

@ -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)

449
cs019/cs019.rkt
View File

@ -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]))

9
examples/read-bytes.rkt Normal file
View File

@ -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))]))

17
expand-out-images.rkt
View File

@ -1,15 +1,9 @@
#lang racket/base
(require racket/runtime-path
planet/version
syntax/kerncase
net/base64
(for-template (this-package-in lang/kernel)
#;(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))
(for-template "lang/kernel.rkt"))
@ -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)
[image-url #,(my-image-url)]))
(require (only-in (file image-library-path)
[bitmap/url #,(my-image-url)]))
#,@(map on-toplevel
(syntax->list #'(module-level-form ...)))))))]

140
js-assembler/db-cache.rkt Normal file
View File

@ -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))

94
js-assembler/hash-cache.rkt Normal file
View File

@ -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)]))

176
js-assembler/package.rkt
View File

@ -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?
(MainModuleSource-source src))]
(query:has-javascript-implementation?
`(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
(MainModuleSource-source src))]
(resource-query:query
`(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)]
[(MainModuleSource? src)
(get-javascript-implementation (MainModuleSource-source src))]
[(ModuleSource? src)
(let* ([name (rewrite-path (ModuleSource-path src))]
[paths (query:query `(file ,(path->string (ModuleSource-path src))))]
[text (string-join
(map (lambda (p)
(call-with-input-file p port->string))
paths)
"\n")]
[module-requires (query:lookup-module-requires (ModuleSource-path src))]
[bytecode (parse-bytecode (ModuleSource-path src))])
(when (not (empty? module-requires))
(log-debug "~a requires ~a"
(ModuleSource-path src)
module-requires))
(let ([module-body-text
(format "
(define (get-implementation-from-path path)
(let* ([name (rewrite-path path)]
[paths (query:query `(file ,(path->string path)))]
[text (string-join
(map (lambda (p)
(call-with-input-file p port->string))
paths)
"\n")]
[module-requires (query:lookup-module-requires path)]
[bytecode (parse-bytecode path)])
(when (not (empty? module-requires))
(log-debug "~a requires ~a"
path
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)
text
(get-provided-name-code bytecode))])
(make-UninterpretedSource
(format "
(symbol->string name)
text
(get-provided-name-code bytecode))])
(make-UninterpretedSource
(format "
M.modules[~s] =
new plt.runtime.ModuleRecord(~s,
function(M) {
~a
});
"
(symbol->string name)
(symbol->string name)
(assemble-modinvokes+body module-requires module-body-text))
(map (lambda (p) (make-ModuleSource (normalize-path p)))
module-requires))))]
(symbol->string name)
(symbol->string name)
(assemble-modinvokes+body module-requires module-body-text))
(map (lambda (p) (make-ModuleSource (normalize-path p)))
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))
packaging-configuration)
(make (list source-code) 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

20
js-assembler/runtime-src/baselib-check.js
View File

@ -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));

22
js-assembler/runtime-src/baselib-contmarks.js
View File

@ -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));

10
js-assembler/runtime-src/baselib-exceptions.js
View File

@ -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;

83
js-assembler/runtime-src/baselib-ports.js
View File

@ -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, $));

301
js-assembler/runtime-src/baselib-primitives.js
View File

@ -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['installPrimitiveClosure'] = installPrimitiveClosure;
exports['installPrimitiveConstant'] = installPrimitiveConstant;
exports['installPrimitiveProcedure'] = installPrimitiveProcedure;
exports['installPrimitiveClosure'] = installPrimitiveClosure;
exports['installPrimitiveConstant'] = installPrimitiveConstant;
}(this.plt.baselib));

14
js-assembler/runtime-src/runtime.js
View File

@ -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 =
new ContinuationPromptTag("default-continuation-prompt-tag");
var DEFAULT_CONTINUATION_PROMPT_TAG =
baselib.contmarks.DEFAULT_CONTINUATION_PROMPT_TAG;

30
lang/js/query.rkt
View File

@ -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))))

49
lang/kernel.rkt
View File

@ -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:fail
;; make-exn:fail:contract
;; make-exn:fail:contract:arity
;; make-exn:fail:contract:variable
;; make-exn:fail:contract:divide-by-zero
make-exn
make-exn:fail
make-exn:fail:contract
make-exn:fail:contract:arity
make-exn:fail:contract:variable
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
;; default-continuation-prompt-tag
;; make-continuation-prompt-tag
;; continuation-prompt-tag?
;; call-with-continuation-prompt
;; abort-current-continuation
default-continuation-prompt-tag
make-continuation-prompt-tag
continuation-prompt-tag?
make-reader-graph
make-placeholder
placeholder-set!)
placeholder-set!
eof-object?
read-byte)

17
make/make-structs.rkt
View File

@ -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
(U Expression #f)
(Listof Statement)
-> Void)]
[after-module-statements : (Source -> Void)]
[on-source : (Source
(U Expression #f)
(MyPromise (Listof Statement))
-> Void)]
[after-source : (Source -> Void)]
[after-last : (-> Void)])
#:mutable)

52
make/make.rkt
View File

@ -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))])
(let ([maybe-module-locator (find-module-locator ast)])
(cond
[(ModuleLocator? maybe-module-locator)
(values ast (append stmts
;; Set the main module name
(list (make-PerformStatement
(make-AliasModuleAsMain!
maybe-module-locator)))))]
[else
(values ast stmts)])))]
(get-ast-and-statements (make-ModuleSource (MainModuleSource-path a-source)))])
(values ast
(my-delay
(let ([maybe-module-locator (find-module-locator ast)])
(cond
[(ModuleLocator? maybe-module-locator)
(append (my-force stmts)
;; Set the main module name
(list (make-PerformStatement
(make-AliasModuleAsMain!
maybe-module-locator))))]
[else
(my-force stmts)])))))]
[else
(let ([ast (get-ast a-source)])
(define start-time (current-inexact-milliseconds))
(define compiled-code (compile ast 'val next-linkage/drop-multiple))
(define stop-time (current-inexact-milliseconds))
(fprintf (current-timing-port) " compile ast: ~a milliseconds\n" (- stop-time start-time))
(values ast compiled-code))]))
(values ast
(my-delay
(define start-time (current-inexact-milliseconds))
(define compiled-code (compile ast 'val next-linkage/drop-multiple))
(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))

7
parameters.rkt
View File

@ -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))

7
parser/parse-bytecode.rkt
View File

@ -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))

7
parser/path-rewriter.rkt
View File

@ -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))

39
promise.rkt Normal file
View File

@ -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]))

2
resource/query.rkt
View File

@ -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))))

2
tests/browser-harness.rkt
View File

@ -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))

7
version.rkt
View File

@ -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")

9
whalesong-helpers.rkt
View File

@ -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)))

11
whalesong.rkt
View File

@ -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)]