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-07-22 18:40:26 -04:00
commit 8ae063b3f4
18 changed files with 2474 additions and 798 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/compiler.rkt
View File

@ -505,16 +505,17 @@
(end-with-linkage linkage
cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-Comment (format "Checking the prefix of length ~s"
(length (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp)))))))
,(make-PerformStatement (make-CheckToplevelBound!
(if (ToplevelRef-check-defined? exp)
(make-PerformStatement (make-CheckToplevelBound!
(ToplevelRef-depth exp)
(ToplevelRef-pos exp)))
,(make-AssignImmediateStatement
empty-instruction-sequence)
(make-AssignImmediateStatement
target
(make-EnvPrefixReference (ToplevelRef-depth exp)
(ToplevelRef-pos exp)))))
(ToplevelRef-pos exp)))
singular-context-check))))
@ -2200,7 +2201,8 @@
(if (< (ToplevelRef-depth exp) skip)
exp
(make-ToplevelRef (ensure-natural (- (ToplevelRef-depth exp) n))
(ToplevelRef-pos exp)))]
(ToplevelRef-pos exp)
(ToplevelRef-check-defined? exp)))]
[(LocalRef? exp)
(if (< (LocalRef-depth exp) skip)

3
compiler/expression-structs.rkt
View File

@ -55,7 +55,8 @@
(define-struct: Constant ([v : Any]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural]
[pos : Natural]) #:transparent)
[pos : Natural]
[check-defined? : Boolean]) #:transparent)
(define-struct: LocalRef ([depth : Natural]
[unbox? : Boolean]) #:transparent)

3
compiler/optimize-il.rkt
View File

@ -154,7 +154,8 @@
(let ([t (VariableReference-toplevel oparg)])
(make-VariableReference
(make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t)))
(ToplevelRef-pos t))))]))
(ToplevelRef-pos t)
(ToplevelRef-check-defined? t))))]))
(define-predicate natural? Natural)

67
notes/racket-days-abstract.txt
View File

@ -49,3 +49,70 @@ What were some of the technical challenges?
What needs to be done next?
Adding enough primitives to run racket/base
----------------------------------------------------------------------
The story for the presentation:
What's Whalesong? It's a Racket to JavaScript compiler. Whalesong
will be used to support World programming for the web. It will be the
evaluator for the upcoming versions of Moby Scheme, as well as
WeScheme.
We can support simple animations, as you'd expect:
(Show a world program: the falling rain drops program.)
We can do programs that have interactivity, such as:
(Show another world program: pacman.)
A core idea behind Whalesong is to reuse Racket's infrastructure as
much as possible. I'm not a compiler person, so I cheat, by
piggibacking on Matthew's work. Whalesong reuses the bytecode
compiler, and translates the bytecode to JavaScript.
I really am reusing the linguistic features of Racket. For example,
let's look at the less-than-impressive program output below.
(Show the hello world program)
This is trivial, right? Let's look at the source code.
(Reveal that the program was written in BF)
Yes, this is unholy, but it works. We really are using Racket's
underlying language features to handle reading, macro expansion, and
optimization.
Because we're on the web, we may even want to use functions that we've
written in Racket as a part of regular web pages. Whalesong lets us
do this.
(Show the factorial example, and how it can be used by external
JavaScript on a web page.)
There's quite a bit that's missing: we don't yet have all of the
primitives necessary to compile racket/base, so all Whalesong programs
currently have to be in a language that ultimately bottoms to (planet
dyoo/whalesong/lang/base).
I'm going to get a release out in the following month, and the new
versions of Moby Scheme for Smartphones, as well as the WeScheme
environment, will be using the underlying evaluator of Whalesong.
If you're interested, please talk to me during the break. Thanks!

3
parser/baby-parser.rkt
View File

@ -87,7 +87,8 @@
(EnvLexicalReference-unbox? address))]
[(EnvPrefixReference? address)
(make-ToplevelRef (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address))]))]
(EnvPrefixReference-pos address)
#t)]))]
[(define-values? exp)
(make-DefValues (map (lambda (id)

19
parser/parse-bytecode-5.1.1.rkt
View File

@ -1,5 +1,14 @@
#lang racket/base
(require "../version-case/version-case.rkt"
(for-syntax racket/base))
(version-case
[(and (version<= "5.1.1" (version))
(version< (version) "5.1.1.900"))
;; Parsing Racket 5.1.1 bytecode structures into our own structures.
(require "typed-module-path.rkt"
"lam-entry-gensym.rkt"
@ -652,7 +661,10 @@
;; FIXME: we should also keep track of const? and ready? to produce better code, and to
;; do the required runtime checks when necessary (const?=#f, ready?=#f)
[(struct toplevel (depth pos const? ready?))
(make-ToplevelRef depth pos)]))
(make-ToplevelRef depth pos (if (and (not const?)
(not ready?))
#t
#f))]))
(define (parse-topsyntax expr)
@ -729,4 +741,7 @@
(match expr
[(struct primval (id))
(let ([name (hash-ref primitive-table id)])
(make-PrimitiveKernelValue name))]))
(make-PrimitiveKernelValue name))]))]
[else
(void)])

751
parser/parse-bytecode-5.1.2.rkt Normal file
View File

@ -0,0 +1,751 @@
#lang racket/base
(require "../version-case/version-case.rkt"
(for-syntax racket/base))
(version-case
[(version<= "5.1.1.900" (version))
;; Parsing Racket 5.1.2 bytecode structures into our own structures.
(require "typed-module-path.rkt"
"lam-entry-gensym.rkt"
"path-rewriter.rkt"
"../compiler/expression-structs.rkt"
"../compiler/lexical-structs.rkt"
"../parameters.rkt"
"../get-module-bytecode.rkt"
syntax/modresolve
compiler/zo-parse
racket/path
racket/match
racket/list)
(provide parse-bytecode
reset-lam-label-counter!/unit-testing)
;; current-module-path-index-resolver: (module-path-index (U Path #f) -> (U Symbol Path)) -> void
;; The module path index resolver figures out how to translate module path indices to module names.
(define current-module-path-index-resolver
(make-parameter
(lambda (mpi relative-to)
(cond
[(eq? mpi #f)
(current-module-path)]
[(self-module-path-index? mpi)
(current-module-path)]
[else
(resolve-module-path-index mpi relative-to)]))))
(define current-module-path-resolver
(make-parameter
(lambda (module-path relative-to)
(resolve-module-path module-path relative-to))))
(define (self-module-path-index? mpi)
(let-values ([(x y) (module-path-index-split mpi)])
(and (eq? x #f)
(eq? y #f))))
(define (explode-module-path-index mpi)
(let-values ([(x y) (module-path-index-split mpi)])
(cond
[(module-path-index? y)
(cons x (explode-module-path-index y))]
[else
(list x y)])))
;; seen-closures: (hashof symbol -> symbol)
;; As we're parsing, we watch for closure cycles. On any subsequent time where
;; we see a closure cycle, we break the cycle by generating an EmptyClosureReference.
;; The map is from the gen-id to the entry-point label of the lambda.
(define seen-closures (make-parameter (make-hasheq)))
;; Code is copied-and-pasted from compiler/decompile. Maps the primval ids to their respective
;; symbolic names.
(define primitive-table
;; Figure out number-to-id mapping for kernel functions in `primitive'
(let ([bindings
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(namespace-require ''#%flfxnum)
(namespace-require ''#%futures)
(for/list ([l (namespace-mapped-symbols)])
(cons l (with-handlers ([exn:fail? (lambda (x)
#f)])
(compile l))))))]
[table (make-hash)])
(for ([b (in-list bindings)])
(let ([v (and (cdr b)
(zo-parse (let ([out (open-output-bytes)])
(write (cdr b) out)
(close-output-port out)
(open-input-bytes (get-output-bytes out)))))])
(let ([n (match v
[(struct compilation-top (_ prefix (struct primval (n)))) n]
[else #f])])
(hash-set! table n (car b)))))
table))
;; parse-bytecode: (U Input-Port Path) -> Expression
;;
;; Given an input port, assumes the input is the byte representation of compiled-code.
;;
;; Given a path, assumes the path is for a module. It gets the module bytecode, and parses
;; that.
;;
;; TODO: this may be doing too much work. It doesn't quite feel like the right elements
;; are being manipulated here.
(define (parse-bytecode in)
(cond
[(input-port? in)
(parameterize ([seen-closures (make-hasheq)])
(let ([compilation-top (zo-parse in)])
(parse-top compilation-top)))]
[(compiled-expression? in)
(let ([op (open-output-bytes)])
(write in op)
(parse-bytecode (open-input-bytes (get-output-bytes op))))]
[(path? in)
(let*-values ([(normal-path) (normalize-path in)]
[(base file-path dir?) (split-path normal-path)])
(parameterize ([current-module-path normal-path]
[current-directory (cond [(path? base)
base]
[else
(error 'parse-bytecode)])])
(parse-bytecode
(open-input-bytes (get-module-bytecode normal-path)))))]
[else
(error 'parse-bytecode "Don't know how to parse from ~e" in)]))
(define (parse-top a-top)
(match a-top
[(struct compilation-top (max-let-depth prefix code))
(maybe-fix-module-name
(make-Top (parse-prefix prefix)
(parse-top-code code)))]))
;; maybe-fix-module-name: expression -> expression
;; When we're compiling a module directly from memory, it doesn't have a file path.
;; We rewrite the ModuleLocator to its given name.
(define (maybe-fix-module-name exp)
(match exp
[(struct Top (top-prefix
(struct Module ((and name (? symbol?))
(struct ModuleLocator ('self 'self))
module-prefix
module-requires
module-provides
module-code))))
(make-Top top-prefix
(make-Module name
(make-ModuleLocator name name) (current-module-path)
module-prefix
module-requires
module-provides
module-code))]
[else
exp]))
(define (parse-prefix a-prefix)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs))
(make-Prefix
(append (map parse-prefix-toplevel toplevels)
(map (lambda (x) #f) stxs)
(if (empty? stxs) empty (list #f))
(build-list num-lifts (lambda (i) #f))))]))
;; parse-top-code: (U form Any -> Expression)
(define (parse-top-code code)
(cond
[(form? code)
(parse-form code)]
[else
(make-Constant code)]))
;; parse-prefix-toplevel: (U #f symbol global-bucket module-variable) -> (U False Symbol GlobalBucket ModuleVariable)
(define (parse-prefix-toplevel a-toplevel)
(cond
[(eq? a-toplevel #f)
#f]
[(symbol? a-toplevel)
a-toplevel]
[(global-bucket? a-toplevel)
(make-GlobalBucket (global-bucket-name a-toplevel))]
[(module-variable? a-toplevel)
(let ([resolver (current-module-path-index-resolver)])
(make-ModuleVariable (module-variable-sym a-toplevel)
(let ([resolved-path-name
(resolver (module-variable-modidx a-toplevel) (current-module-path))])
(wrap-module-name resolved-path-name))))]))
(define (wrap-module-name resolved-path-name)
(cond
[(symbol? resolved-path-name)
(make-ModuleLocator resolved-path-name resolved-path-name)]
[(path? resolved-path-name)
(let ([rewritten-path (rewrite-path resolved-path-name)])
(cond
[(symbol? rewritten-path)
(make-ModuleLocator (rewrite-path resolved-path-name)
(normalize-path resolved-path-name))]
[else
(error 'wrap-module-name "Unable to resolve module path ~s."
resolved-path-name)]))]))
;; parse-form: form -> (U Expression)
(define (parse-form a-form)
(cond
[(def-values? a-form)
(parse-def-values a-form)]
[(def-syntaxes? a-form)
(parse-def-syntaxes a-form)]
[(req? a-form)
(parse-req a-form)]
[(seq? a-form)
(parse-seq a-form)]
[(splice? a-form)
(parse-splice a-form)]
[(mod? a-form)
(parse-mod a-form)]
[(expr? a-form)
(parse-expr a-form)]
[else
(error 'parse-form "~s" a-form)]))
;; parse-def-values: def-values -> Expression
(define (parse-def-values form)
(match form
[(struct def-values (ids rhs))
(make-DefValues (map parse-toplevel ids)
(parse-expr-seq-constant rhs))]))
(define (parse-def-syntaxes form)
;; Currently, treat def-syntaxes as a no-op. The compiler will not produce
;; syntax transformers.
(make-Constant (void)))
(define (parse-req form)
(let ([resolver (current-module-path-resolver)])
(match form
[(struct req (reqs dummy))
(let ([require-statement (parse-req-reqs reqs)])
(match require-statement
[(list '#%require (and (? module-path?) path))
(let ([resolved-path ((current-module-path-resolver) path (current-module-path))])
(cond
[(symbol? resolved-path)
(make-Require (make-ModuleLocator resolved-path resolved-path))]
[(path? resolved-path)
(let ([rewritten-path (rewrite-path resolved-path)])
(cond
[(symbol? rewritten-path)
(make-Require (make-ModuleLocator rewritten-path
(normalize-path resolved-path)))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))])))
;; parse-req-reqs: (stx -> (listof ModuleLocator))
(define (parse-req-reqs reqs)
(match reqs
[(struct stx (encoded))
(unwrap-wrapped encoded)]))
(define (unwrap-wrapped encoded)
(cond [(wrapped? encoded)
(match encoded
[(struct wrapped (datum wraps certs))
(unwrap-wrapped datum)])]
[(pair? encoded)
(cons (unwrap-wrapped (car encoded))
(unwrap-wrapped (cdr encoded)))]
[(null? encoded)
null]
[else
encoded]))
;; parse-seq: seq -> Expression
(define (parse-seq form)
(match form
[(struct seq (forms))
(make-Seq (map parse-form-item forms))]))
;; parse-form-item: (U form Any) -> Expression
(define (parse-form-item item)
(cond
[(form? item)
(parse-form item)]
[else
(make-Constant item)]))
;; parse-splice: splice -> Expression
(define (parse-splice form)
(match form
[(struct splice (forms))
(make-Splice (map parse-splice-item forms))]))
;; parse-splice-item: (U form Any) -> Expression
(define (parse-splice-item item)
(cond
[(form? item)
(parse-form item)]
[else
(make-Constant item)]))
;; parse-mod: mod -> Expression
(define (parse-mod form)
(match form
[(struct mod (name srcname self-modidx prefix provides requires
body syntax-body unexported max-let-depth dummy lang-info
internal-context))
(let ([self-path
((current-module-path-index-resolver)
self-modidx
(current-module-path))])
(cond
[(symbol? self-path)
(make-Module name
(make-ModuleLocator self-path self-path)
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides self-modidx provides)
(parse-mod-body body))]
[else
(let ([rewritten-path (rewrite-path self-path)])
(cond
[(symbol? rewritten-path)
(make-Module name
(make-ModuleLocator rewritten-path
(normalize-path self-path))
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides self-modidx provides)
(parse-mod-body body))]
[else
(error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleLocator)
(define (parse-mod-requires enclosing-module-path-index requires)
;; We only care about phase 0 --- the runtime.
(let ([resolver (current-module-path-index-resolver)])
(let loop ([requires requires])
(cond
[(empty? requires)
empty]
[(= (car (first requires))
0)
(map (lambda (m)
(let ([enclosing-path (resolver enclosing-module-path-index (current-module-path))])
(cond
[(symbol? enclosing-path)
(wrap-module-name (resolver m (current-module-path)))]
[(path? enclosing-path)
(wrap-module-name (resolver m enclosing-path))])))
(cdr (first requires)))]
[else
(loop (rest requires))]))))
(define (parse-mod-provides enclosing-module-path-index provides)
(let* ([resolver
(current-module-path-index-resolver)]
[enclosing-path
(resolver enclosing-module-path-index (current-module-path))]
[subresolver
(lambda (p)
(cond
[(symbol? enclosing-path)
(wrap-module-name (resolver p (current-module-path)))]
[(path? enclosing-path)
(wrap-module-name (resolver p enclosing-path))]))])
(let loop ([provides provides])
(cond
[(empty? provides)
empty]
[(= (first (first provides)) 0)
(let ([provided-values (second (first provides))])
(for/list ([v provided-values])
(match v
[(struct provided (name src src-name nom-mod
src-phase protected?))
(make-ModuleProvide src-name name (subresolver src))])))]
[else
(loop (rest provides))]))))
;; parse-mod-body: (listof (or/c form? any/c)) -> Expression
(define (parse-mod-body body)
(let ([parse-item (lambda (item)
(cond
[(form? item)
(parse-form item)]
[else
(make-Constant item)]))])
(make-Splice (map parse-item body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-expr expr)
(cond
[(lam? expr)
(parse-lam expr (make-lam-label))]
[(closure? expr)
(parse-closure expr)]
[(case-lam? expr)
(parse-case-lam expr)]
[(let-one? expr)
(parse-let-one expr)]
[(let-void? expr)
(parse-let-void expr)]
[(install-value? expr)
(parse-install-value expr)]
[(let-rec? expr)
(parse-let-rec expr)]
[(boxenv? expr)
(parse-boxenv expr)]
[(localref? expr)
(parse-localref expr)]
[(toplevel? expr)
(parse-toplevel expr)]
[(topsyntax? expr)
(parse-topsyntax expr)]
[(application? expr)
(parse-application expr)]
[(branch? expr)
(parse-branch expr)]
[(with-cont-mark? expr)
(parse-with-cont-mark expr)]
[(beg0? expr)
(parse-beg0 expr)]
[(varref? expr)
(parse-varref expr)]
[(assign? expr)
(parse-assign expr)]
[(apply-values? expr)
(parse-apply-values expr)]
[(primval? expr)
(parse-primval expr)]))
(define (parse-lam expr entry-point-label)
(match expr
[(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body))
(let ([lam-name (extract-lam-name name)])
(make-Lam lam-name
num-params
rest?
(parse-expr-seq-constant body)
(vector->list closure-map)
entry-point-label))]))
;; parse-closure: closure -> (U Lam EmptyClosureReference)
;; Either parses as a regular lambda, or if we come across the same closure twice,
;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda
;; entry point.
(define (parse-closure expr)
(match expr
[(struct closure (code gen-id))
(let ([seen (seen-closures)])
(cond
[(hash-has-key? seen gen-id)
(match code
[(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body))
(let ([lam-name (extract-lam-name name)])
(make-EmptyClosureReference lam-name
num-params
rest?
(hash-ref seen gen-id)))])]
[else
(let ([fresh-entry-point (make-lam-label)])
(hash-set! seen gen-id fresh-entry-point)
(parse-lam code fresh-entry-point))]))]))
;; extract-lam-name: (U Symbol Vector) -> (U Symbol LamPositionalName)
(define (extract-lam-name name)
(cond
[(symbol? name)
name]
[(vector? name)
(match name
[(vector (and (? symbol?) sym)
(and (? path?) source)
(and (? number?) line)
(and (? number?) column)
(and (? number?) offset)
(and (? number?) span)
_)
(let ([try-to-rewrite (rewrite-path source)])
(make-LamPositionalName sym
(if try-to-rewrite
(symbol->string try-to-rewrite)
(path->string source))
line
column
offset
span))]
[(vector (and (? symbol?) sym)
(and (? symbol?) source)
(and (? number?) line)
(and (? number?) column)
(and (? number?) offset)
(and (? number?) span)
_)
(make-LamPositionalName sym
(symbol->string source)
line
column
offset
span)]
[else
(string->symbol (format "~s" name))])]
[else
'unknown
;; The documentation says that the name must be a symbol or vector, but I'm seeing cases
;; where it returns the empty list when there's no information available.
]))
(define (parse-case-lam exp)
(match exp
[(struct case-lam (name clauses))
(let ([case-lam-label (make-lam-label)])
(make-CaseLam (extract-lam-name name)
(map (lambda (l)
(cond
[(closure? l)
(parse-closure l)]
[else
(parse-lam l (make-lam-label))]))
clauses)
case-lam-label))]))
(define (parse-let-one expr)
(match expr
[(struct let-one (rhs body flonum? unused?))
;; fixme: use flonum? and unused? to generate better code.
(make-Let1 (parse-expr-seq-constant rhs)
(parse-expr-seq-constant body))]))
;; parse-expr-seq-constant: (U expr seq Any) -> Expression
(define (parse-expr-seq-constant x)
(cond
[(expr? x) (parse-expr x)]
[(seq? x) (parse-seq x)]
[else (make-Constant x)]))
(define (parse-let-void expr)
(match expr
[(struct let-void (count boxes? body))
(make-LetVoid count (parse-expr-seq-constant body) boxes?)]))
(define (parse-install-value expr)
(match expr
[(struct install-value (count pos boxes? rhs body))
(make-Seq (list (make-InstallValue count pos (parse-expr-seq-constant rhs) boxes?)
(parse-expr-seq-constant body)))]))
(define (parse-let-rec expr)
(match expr
[(struct let-rec (procs body))
(make-LetRec (map (lambda (p) (parse-lam p (make-lam-label)))
procs)
(parse-expr-seq-constant body))]))
(define (parse-boxenv expr)
(match expr
[(struct boxenv (pos body))
(make-BoxEnv pos (parse-expr-seq-constant body))]))
(define (parse-localref expr)
(match expr
[(struct localref (unbox? pos clear? other-clears? flonum?))
;; FIXME: we should use clear? at the very least: as I understand it,
;; this is here to maintain safe-for-space behavior.
;; We should also make use of flonum information to generate better code.
(make-LocalRef pos unbox?)]))
(define (parse-toplevel expr)
(match expr
;; FIXME: we should also keep track of const? and ready? to produce better code, and to
;; do the required runtime checks when necessary (const?=#f, ready?=#f)
[(struct toplevel (depth pos const? ready?))
(make-ToplevelRef depth pos (if (and (not const?)
(not ready?))
#t
#f))]))
(define (parse-topsyntax expr)
;; We should not get into this because we're only parsing the runtime part of
;; the bytecode. Treated as a no-op.
(make-Constant (void)))
(define (parse-application expr)
(match expr
[(struct application (rator rands))
(make-App (parse-application-rator rator)
(map parse-application-rand rands))]))
(define (parse-application-rator rator)
(cond
[(expr? rator)
(parse-expr rator)]
[(seq? rator)
(parse-seq rator)]
[else
(make-Constant rator)]))
(define (parse-application-rand rand)
(cond
[(expr? rand)
(parse-expr rand)]
[(seq? rand)
(parse-seq rand)]
[else
(make-Constant rand)]))
(define (parse-branch expr)
(match expr
[(struct branch (test then else))
(make-Branch (parse-expr-seq-constant test)
(parse-expr-seq-constant then)
(parse-expr-seq-constant else))]))
(define (parse-with-cont-mark expr)
(match expr
[(struct with-cont-mark (key val body))
(make-WithContMark (parse-expr-seq-constant key)
(parse-expr-seq-constant val)
(parse-expr-seq-constant body))]))
(define (parse-beg0 expr)
(match expr
[(struct beg0 (seq))
(make-Begin0 (map parse-expr-seq-constant seq))]))
(define (parse-varref expr)
(match expr
[(struct varref (toplevel dummy))
(make-VariableReference (parse-toplevel toplevel))]))
(define (parse-assign expr)
(match expr
[(struct assign ((struct toplevel (depth pos const? ready?)) rhs undef-ok?))
(make-ToplevelSet depth pos (parse-expr-seq-constant rhs))]))
(define (parse-apply-values expr)
(match expr
[(struct apply-values (proc args-expr))
(make-ApplyValues (parse-expr-seq-constant proc)
(parse-expr-seq-constant args-expr))]))
(define (parse-primval expr)
(match expr
[(struct primval (id))
(let ([name (hash-ref primitive-table id)])
(make-PrimitiveKernelValue name))]))]
[else
(void)])

11
parser/parse-bytecode.rkt
View File

@ -1,15 +1,24 @@
#lang racket/base
(require "../version-case/version-case.rkt"
"../logger.rkt"
racket/file
(prefix-in whalesong: "../version.rkt")
(for-syntax racket/base))
(version-case
[(version>= (version) "5.1.1")
[(and (version<= "5.1.1" (version))
(version< (version) "5.1.1.900"))
(begin
(log-debug "Using 5.1.1 bytecode parser")
(require "parse-bytecode-5.1.1.rkt")
(provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt")
parse-bytecode)))]
[(version<= "5.1.1.900" (version))
(begin
(log-debug "Using 5.1.2 bytecode parser")
(require "parse-bytecode-5.1.2.rkt")
(provide (except-out (all-from-out "parse-bytecode-5.1.2.rkt")
parse-bytecode)))]
[else
(error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])

1
tests/more-tests/earley.expected Normal file
View File

@ -0,0 +1 @@
58786

826
tests/more-tests/earley.rkt Normal file
View File

@ -0,0 +1,826 @@
#lang planet dyoo/whalesong
(begin
(define make-parser
(lambda (grammar lexer)
(letrec ((non-terminals
(lambda (grammar)
(letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts)))))
((letrec ((def-loop
(lambda (defs nts)
(if (pair? defs)
(let ((def (car defs)))
(let ((head (car def)))
((letrec ((rule-loop
(lambda (rules nts)
(if (pair? rules)
(let ((rule (car rules)))
((letrec ((loop
(lambda (l nts)
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts)))))
loop)
rule
nts))
(def-loop (cdr defs) nts)))))
rule-loop)
(cdr def)
(add-nt head nts))))
(list->vector (reverse nts))))))
def-loop)
grammar
'()))))
(ind
(lambda (nt nts)
((letrec ((loop
(lambda (i)
(if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f))))
loop)
(- (vector-length nts) '1))))
(nb-configurations
(lambda (grammar)
((letrec ((def-loop
(lambda (defs nb-confs)
(if (pair? defs)
(let ((def (car defs)))
((letrec ((rule-loop
(lambda (rules nb-confs)
(if (pair? rules)
(let ((rule (car rules)))
((letrec ((loop
(lambda (l nb-confs)
(if (pair? l)
(loop (cdr l) (+ nb-confs '1))
(rule-loop (cdr rules) (+ nb-confs '1))))))
loop)
rule
nb-confs))
(def-loop (cdr defs) nb-confs)))))
rule-loop)
(cdr def)
nb-confs))
nb-confs))))
def-loop)
grammar
'0))))
(let ((nts (non-terminals grammar)))
(let ((nb-nts (vector-length nts)))
(let ((nb-confs (+ (nb-configurations grammar) nb-nts)))
(let ((starters (make-vector nb-nts '())))
(let ((enders (make-vector nb-nts '())))
(let ((predictors (make-vector nb-nts '())))
(let ((steps (make-vector nb-confs '#f)))
(let ((names (make-vector nb-confs '#f)))
(letrec ((setup-tables
(lambda (grammar nts starters enders predictors steps names)
(letrec ((add-conf
(lambda (conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))))
(let ((nb-nts (vector-length nts)))
((letrec ((nt-loop
(lambda (i)
(if (>= i '0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) '0))
(vector-set! enders i (list i))
(nt-loop (- i '1)))
'#f))))
nt-loop)
(- nb-nts '1))
((letrec ((def-loop
(lambda (defs conf)
(if (pair? defs)
(let ((def (car defs)))
(let ((head (car def)))
((letrec ((rule-loop
(lambda (rules conf rule-num)
(if (pair? rules)
(let ((rule (car rules)))
(vector-set!
names
conf
(list head rule-num))
(add-conf conf head nts starters)
((letrec ((loop
(lambda (l conf)
(if (pair? l)
(let ((nt (car l)))
(vector-set!
steps
conf
(ind nt nts))
(add-conf
conf
nt
nts
predictors)
(loop
(cdr l)
(+ conf '1)))
(begin
(vector-set!
steps
conf
(-
(ind head nts)
nb-nts))
(add-conf
conf
head
nts
enders)
(rule-loop
(cdr rules)
(+ conf '1)
(+ rule-num '1)))))))
loop)
rule
conf))
(def-loop (cdr defs) conf)))))
rule-loop)
(cdr def)
conf
'1)))
'#f))))
def-loop)
grammar
(vector-length nts)))))))
(setup-tables grammar nts starters enders predictors steps names)
(let ((parser-descr (vector lexer nts starters enders predictors steps names)))
(lambda (input)
(letrec ((ind
(lambda (nt nts)
((letrec ((loop
(lambda (i)
(if (>= i '0)
(if (equal? (vector-ref nts i) nt) i (loop (- i '1)))
'#f))))
loop)
(- (vector-length nts) '1))))
(comp-tok
(lambda (tok nts)
((letrec ((loop
(lambda (l1 l2)
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2)))
(cons (car tok) (reverse l2))))))
loop)
(cdr tok)
'())))
(input->tokens
(lambda (input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input)))))
(make-states
(lambda (nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks '1) '#f)))
((letrec ((loop
(lambda (i)
(if (>= i '0)
(let ((v (make-vector (+ nb-confs '1) '#f)))
(vector-set! v '0 '-1)
(vector-set! states i v)
(loop (- i '1)))
states))))
loop)
nb-toks))))
(conf-set-get (lambda (state conf) (vector-ref state (+ conf '1))))
(conf-set-get*
(lambda (state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num '6) '#f)))
(vector-set! conf-set '1 '-3)
(vector-set! conf-set '2 '-1)
(vector-set! conf-set '3 '-1)
(vector-set! conf-set '4 '-1)
(vector-set! state (+ conf '1) conf-set)
conf-set)))))
(conf-set-merge-new!
(lambda (conf-set)
(vector-set!
conf-set
(+ (vector-ref conf-set '1) '5)
(vector-ref conf-set '4))
(vector-set! conf-set '1 (vector-ref conf-set '3))
(vector-set! conf-set '3 '-1)
(vector-set! conf-set '4 '-1)))
(conf-set-head (lambda (conf-set) (vector-ref conf-set '2)))
(conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5))))
(conf-set-member?
(lambda (state conf i)
(let ((conf-set (vector-ref state (+ conf '1))))
(if conf-set (conf-set-next conf-set i) '#f))))
(conf-set-adjoin
(lambda (state conf-set conf i)
(let ((tail (vector-ref conf-set '3)))
(vector-set! conf-set (+ i '5) '-1)
(vector-set! conf-set (+ tail '5) i)
(vector-set! conf-set '3 i)
(if (< tail '0)
(begin
(vector-set! conf-set '0 (vector-ref state '0))
(vector-set! state '0 conf))
'#f))))
(conf-set-adjoin*
(lambda (states state-num l i)
(let ((state (vector-ref states state-num)))
((letrec ((loop
(lambda (l1)
(if (pair? l1)
(let ((conf (car l1)))
(let ((conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1)))))
'#f))))
loop)
l))))
(conf-set-adjoin**
(lambda (states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let ((state* (vector-ref states* state-num)))
(let ((conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i)
'#f)
'#t))
'#f))))
(conf-set-union
(lambda (state conf-set conf other-set)
((letrec ((loop
(lambda (i)
(if (>= i '0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i)))
'#f))))
loop)
(conf-set-head other-set))))
(forw
(lambda (states state-num starters enders predictors steps nts)
(letrec ((predict
(lambda (state state-num conf-set conf nt starters enders)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((starter (car l)))
(let ((starter-set
(conf-set-get*
state
state-num
starter)))
(if (not
(conf-set-next
starter-set
state-num))
(begin
(conf-set-adjoin
state
starter-set
starter
state-num)
(loop1 (cdr l)))
(loop1 (cdr l)))))
'#f))))
loop1)
(vector-ref starters nt))
((letrec ((loop2
(lambda (l)
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let ((next (+ conf '1)))
(let ((next-set
(conf-set-get*
state
state-num
next)))
(conf-set-union
state
next-set
next
conf-set)
(loop2 (cdr l))))
(loop2 (cdr l))))
'#f))))
loop2)
(vector-ref enders nt))))
(reduce
(lambda (states state state-num conf-set head preds)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((pred (car l)))
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(let ((pred-set
(conf-set-get
(vector-ref states i)
pred)))
(if pred-set
(let ((next (+ pred '1)))
(let ((next-set
(conf-set-get*
state
state-num
next)))
(conf-set-union
state
next-set
next
pred-set)))
'#f)
(loop2
(conf-set-next
conf-set
i)))
(loop1 (cdr l))))))
loop2)
head))
'#f))))
loop1)
preds))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
((letrec ((loop
(lambda ()
(let ((conf (vector-ref state '0)))
(if (>= conf '0)
(let ((step (vector-ref steps conf)))
(let ((conf-set (vector-ref state (+ conf '1))))
(let ((head (vector-ref conf-set '4)))
(vector-set!
state
'0
(vector-ref conf-set '0))
(conf-set-merge-new! conf-set)
(if (>= step '0)
(predict
state
state-num
conf-set
conf
step
starters
enders)
(let ((preds
(vector-ref
predictors
(+ step nb-nts))))
(reduce
states
state
state-num
conf-set
head
preds)))
(loop))))
'#f)))))
loop))))))
(forward
(lambda (starters enders predictors steps nts toks)
(let ((nb-toks (vector-length toks)))
(let ((nb-confs (vector-length steps)))
(let ((states (make-states nb-toks nb-confs)))
(let ((goal-starters (vector-ref starters '0)))
(conf-set-adjoin* states '0 goal-starters '0)
(forw states '0 starters enders predictors steps nts)
((letrec ((loop
(lambda (i)
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i '1) tok-nts i)
(forw
states
(+ i '1)
starters
enders
predictors
steps
nts)
(loop (+ i '1)))
'#f))))
loop)
'0)
states))))))
(produce
(lambda (conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf '1)))
(if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f)
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((ender (car l)))
(let ((ender-set
(conf-set-get (vector-ref states j) ender)))
(if ender-set
((letrec ((loop2
(lambda (k)
(if (>= k '0)
(begin
(if (>= k i)
(if (conf-set-adjoin**
states
states*
k
prev
i)
(conf-set-adjoin**
states
states*
j
ender
k)
'#f)
'#f)
(loop2
(conf-set-next ender-set k)))
(loop1 (cdr l))))))
loop2)
(conf-set-head ender-set))
(loop1 (cdr l)))))
'#f))))
loop1)
(vector-ref enders (vector-ref steps prev)))
'#f))))
(back
(lambda (states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
((letrec ((loop1
(lambda ()
(let ((conf (vector-ref state* '0)))
(if (>= conf '0)
(let ((conf-set (vector-ref state* (+ conf '1))))
(let ((head (vector-ref conf-set '4)))
(vector-set! state* '0 (vector-ref conf-set '0))
(conf-set-merge-new! conf-set)
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(begin
(produce
conf
i
state-num
enders
steps
toks
states
states*
nb-nts)
(loop2
(conf-set-next conf-set i)))
(loop1)))))
loop2)
head)))
'#f)))))
loop1)))))
(backward
(lambda (states enders steps nts toks)
(let ((nb-toks (vector-length toks)))
(let ((nb-confs (vector-length steps)))
(let ((nb-nts (vector-length nts)))
(let ((states* (make-states nb-toks nb-confs)))
(let ((goal-enders (vector-ref enders '0)))
((letrec ((loop1
(lambda (l)
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin**
states
states*
nb-toks
conf
'0)
(loop1 (cdr l)))
'#f))))
loop1)
goal-enders)
((letrec ((loop2
(lambda (i)
(if (>= i '0)
(begin
(back
states
states*
i
enders
steps
nb-nts
toks)
(loop2 (- i '1)))
'#f))))
loop2)
nb-toks)
states*)))))))
(parsed?
(lambda (nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
'#t
(loop (cdr l))))
'#f))))
loop)
(vector-ref enders nt*)))
'#f))))
(deriv-trees
(lambda (conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf '1)))
((letrec ((loop1
(lambda (l1 l2)
(if (pair? l1)
(let ((ender (car l1)))
(let ((ender-set
(conf-set-get
(vector-ref states j)
ender)))
(if ender-set
((letrec ((loop2
(lambda (k l2)
(if (>= k '0)
(if (if (>= k i)
(conf-set-member?
(vector-ref states k)
prev
i)
'#f)
(let ((prev-trees
(deriv-trees
prev
i
k
enders
steps
names
toks
states
nb-nts))
(ender-trees
(deriv-trees
ender
k
j
enders
steps
names
toks
states
nb-nts)))
((letrec ((loop3
(lambda (l3 l2)
(if (pair? l3)
(let ((ender-tree
(list
(car
l3))))
((letrec ((loop4
(lambda (l4
l2)
(if (pair?
l4)
(loop4
(cdr
l4)
(cons
(append
(car
l4)
ender-tree)
l2))
(loop3
(cdr
l3)
l2)))))
loop4)
prev-trees
l2))
(loop2
(conf-set-next
ender-set
k)
l2)))))
loop3)
ender-trees
l2))
(loop2
(conf-set-next ender-set k)
l2))
(loop1 (cdr l1) l2)))))
loop2)
(conf-set-head ender-set)
l2)
(loop1 (cdr l1) l2))))
l2))))
loop1)
(vector-ref enders (vector-ref steps prev))
'()))))))
(deriv-trees*
(lambda (nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l trees)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
(loop
(cdr l)
(append
(deriv-trees
conf
i
j
enders
steps
names
toks
states
nb-nts)
trees))
(loop (cdr l) trees)))
trees))))
loop)
(vector-ref enders nt*)
'()))
'#f))))
(nb-deriv-trees
(lambda (conf i j enders steps toks states nb-nts)
(let ((prev (- conf '1)))
(if (let ((or-part (< conf nb-nts)))
(if or-part or-part (< (vector-ref steps prev) '0)))
'1
((letrec ((loop1
(lambda (l n)
(if (pair? l)
(let ((ender (car l)))
(let ((ender-set
(conf-set-get (vector-ref states j) ender)))
(if ender-set
((letrec ((loop2
(lambda (k n)
(if (>= k '0)
(if (if (>= k i)
(conf-set-member?
(vector-ref states k)
prev
i)
'#f)
(let ((nb-prev-trees
(nb-deriv-trees
prev
i
k
enders
steps
toks
states
nb-nts))
(nb-ender-trees
(nb-deriv-trees
ender
k
j
enders
steps
toks
states
nb-nts)))
(loop2
(conf-set-next ender-set k)
(+
n
(*
nb-prev-trees
nb-ender-trees))))
(loop2
(conf-set-next ender-set k)
n))
(loop1 (cdr l) n)))))
loop2)
(conf-set-head ender-set)
n)
(loop1 (cdr l) n))))
n))))
loop1)
(vector-ref enders (vector-ref steps prev))
'0)))))
(nb-deriv-trees*
(lambda (nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
((letrec ((loop
(lambda (l nb-trees)
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member?
(vector-ref states j)
conf
i)
(loop
(cdr l)
(+
(nb-deriv-trees
conf
i
j
enders
steps
toks
states
nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees))))
loop)
(vector-ref enders nt*)
'0))
'#f)))))
(let ((lexer (vector-ref parser-descr '0)))
(let ((nts (vector-ref parser-descr '1)))
(let ((starters (vector-ref parser-descr '2)))
(let ((enders (vector-ref parser-descr '3)))
(let ((predictors (vector-ref parser-descr '4)))
(let ((steps (vector-ref parser-descr '5)))
(let ((names (vector-ref parser-descr '6)))
(let ((toks (input->tokens input lexer nts)))
(vector
nts
starters
enders
predictors
steps
names
toks
(backward
(forward starters enders predictors steps nts toks)
enders
steps
nts
toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))))))))))))))))))))
(define parse->parsed?
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((states (vector-ref parse '7)))
(let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states)))))))
(define parse->trees
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((steps (vector-ref parse '4)))
(let ((names (vector-ref parse '5)))
(let ((toks (vector-ref parse '6)))
(let ((states (vector-ref parse '7)))
(let ((deriv-trees* (vector-ref parse '9)))
(deriv-trees* nt i j nts enders steps names toks states))))))))))
(define parse->nb-trees
(lambda (parse nt i j)
(let ((nts (vector-ref parse '0)))
(let ((enders (vector-ref parse '2)))
(let ((steps (vector-ref parse '4)))
(let ((toks (vector-ref parse '6)))
(let ((states (vector-ref parse '7)))
(let ((nb-deriv-trees* (vector-ref parse '10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))))))))
(define test
(lambda (k)
(let ((p (make-parser '((s (a) (s s)))
(lambda (l)
(map (lambda (x) (list x x)) l)))))
(let ((x (p (vector->list (make-vector k 'a)))))
(display (length (parse->trees x 's '0 k)))
(newline)))))
(test '12))

1
tests/run-more-tests.rkt
View File

@ -15,3 +15,4 @@
(test "more-tests/colors.rkt")
(test "more-tests/images.rkt")
(test "more-tests/lists.rkt")
(test "more-tests/earley.rkt")

6
tests/test-all.rkt
View File

@ -8,11 +8,5 @@
"test-assemble.rkt"
"test-browser-evaluate.rkt"
"test-package.rkt"
"test-conform-browser.rkt"
"test-earley-browser.rkt"
"test-get-dependencies.rkt"
"run-more-tests.rkt")
;; This test takes a bit too much time.
#;"test-conform.rkt"

44
tests/test-browser-evaluate.rkt
View File

@ -229,7 +229,7 @@ EOF
(test '(begin (define (f x)
(test '(let () (define (f x)
(if (= x 0)
0
(+ x (f (- x 1)))))
@ -240,7 +240,7 @@ EOF
(display (f 10000)))
"6\n10\n50005000")
(test '(begin (define (length l)
(test '(let () (define (length l)
(if (null? l)
0
(+ 1 (length (cdr l)))))
@ -251,7 +251,7 @@ EOF
"6\n2\n")
(test '(begin (define (tak x y z)
(test '(let () (define (tak x y z)
(if (< y x)
(tak (tak (- x 1) y z)
(tak (- y 1) z x)
@ -261,7 +261,7 @@ EOF
"7")
(test '(begin (define (fib x)
(test '(let () (define (fib x)
(if (< x 2)
x
(+ (fib (- x 1))
@ -278,7 +278,7 @@ EOF
"true\n")
(test '(begin (define (tak x y z)
(test '(let () (define (tak x y z)
(if (>= y x)
z
(tak (tak (- x 1) y z)
@ -289,18 +289,18 @@ EOF
(test '(begin (displayln (+ 42 (call/cc (lambda (k) 3)))) )
(test '(let () (displayln (+ 42 (call/cc (lambda (k) 3)))) )
"45\n")
(test '(begin (displayln (+ 42 (call/cc (lambda (k) (k 100) 3)))) )
(test '(let () (displayln (+ 42 (call/cc (lambda (k) (k 100) 3)))) )
"142\n")
(test '(begin (displayln (+ 42 (call/cc (lambda (k) 100 (k 3))))) )
(test '(let () (displayln (+ 42 (call/cc (lambda (k) 100 (k 3))))) )
"45\n")
(test '(begin (define program (lambda ()
(test '(let () (define program (lambda ()
(let ((y (call/cc (lambda (c) c))))
(display 1)
(call/cc (lambda (c) (y c)))
@ -311,7 +311,7 @@ EOF
"11213")
(test '(begin (define (f return)
(test '(let () (define (f return)
(return 2)
3)
(display (f (lambda (x) x))) ; displays 3
@ -319,7 +319,7 @@ EOF
)
"32")
(test '(begin
(test '(let ()
(define (ctak x y z)
(call-with-current-continuation
(lambda (k)
@ -371,12 +371,12 @@ EOF
(test '(begin (define counter 0)
(test '(let () (define counter 0)
(set! counter (add1 counter))
(displayln counter))
"1\n")
(test '(begin (define x 16)
(test '(let () (define x 16)
(define (f x)
(set! x (add1 x))
x)
@ -420,34 +420,34 @@ EOF
"x\n")
(test '(begin (displayln (vector-length (vector))))
(test '(let () (displayln (vector-length (vector))))
"0\n")
(test '(begin (displayln (vector-length (vector 3 1 4))))
(test '(let () (displayln (vector-length (vector 3 1 4))))
"3\n")
(test '(begin (displayln (vector-ref (vector 3 1 4) 0)))
(test '(let () (displayln (vector-ref (vector 3 1 4) 0)))
"3\n")
(test '(begin (displayln (vector-ref (vector 3 1 4) 1)))
(test '(let () (displayln (vector-ref (vector 3 1 4) 1)))
"1\n")
(test '(begin (displayln (vector-ref (vector 3 1 4) 2)))
(test '(let () (displayln (vector-ref (vector 3 1 4) 2)))
"4\n")
(test '(begin (define v (vector "hello" "world"))
(test '(let ()(define v (vector "hello" "world"))
(vector-set! v 0 'hola)
(displayln (vector-ref v 0)))
"hola\n")
(test '(begin (define v (vector "hello" "world"))
(test '(let () (define v (vector "hello" "world"))
(vector-set! v 0 'hola)
(displayln (vector-ref v 1)))
"world\n")
(test '(begin (define l (vector->list (vector "hello" "world")))
(test '(let () (define l (vector->list (vector "hello" "world")))
(displayln (length l))
(displayln (car l))
(displayln (car (cdr l))))
@ -648,7 +648,7 @@ EOF
;; Knuth's Man-or-boy-test.
;; http://rosettacode.org/wiki/Man_or_boy_test
(test '(begin (define (A k x1 x2 x3 x4 x5)
(test '(let () (define (A k x1 x2 x3 x4 x5)
(letrec ([B (lambda ()
(set! k (- k 1))
(A k B x1 x2 x3 x4))])

4
tests/test-compiler-2.rkt
View File

@ -44,7 +44,7 @@
[(_ code exp options ...)
(with-syntax ([stx stx])
(syntax/loc #'stx
(begin
(let ()
(printf "Running ~s ...\n" code)
(let*-values([(a-machine num-steps)
(run code options ...)]
@ -67,7 +67,7 @@
[(_ code options ...)
(with-syntax ([stx stx])
(syntax/loc #'stx
(begin
(let ()
(printf "Running/exn ~s ...\n" code)
(let/ec return
(with-handlers ([exn:fail? (lambda (exn)

82
tests/test-compiler.rkt
View File

@ -138,7 +138,7 @@
;; Square
(test '(begin (define (f x)
(test '(let() (define (f x)
(* x x))
(f 3))
9)
@ -443,7 +443,7 @@
;; iterating, with some crazy expressions
(test '(begin (define (iterate f x n)
(test '(let () (define (iterate f x n)
(if (= n 0)
x
(iterate f (f x) (sub1 n))))
@ -459,7 +459,7 @@
(list 160000 1001 42))
;; Trying out closures
(test '(begin
(test '(let ()
(define delta 1)
(define (diff f)
(lambda (x)
@ -474,13 +474,13 @@
(test '(begin (define (square x)
(test '(let () (define (square x)
(* x x))
(square (square 3)))
81)
(test '(begin (define (square x)
(test '(let () (define (square x)
(* x x))
(define (sum-of-squares x y)
(+ (square x) (square y)))
@ -644,7 +644,7 @@
2)
(test '(begin
(test '(let ()
(define (sum-iter x acc)
(if (= x 0)
acc
@ -735,12 +735,12 @@
(test '(begin (define counter 0)
(test '(let () (define counter 0)
(set! counter (add1 counter))
counter)
1)
(test '(begin (define x 16)
(test '(let () (define x 16)
(define (f x)
(set! x (add1 x))
x)
@ -751,7 +751,7 @@
(test '(begin (define a '(hello))
(test '(let () (define a '(hello))
(define b '(world))
(define reset!
(lambda ()
@ -761,7 +761,7 @@
'(() (world)))
(test '(begin (define a '(hello))
(test '(let () (define a '(hello))
(define b '(world))
(define reset!
(lambda ()
@ -770,7 +770,7 @@
(list a b))
'((hello) ()))
(test '(begin (define a '(hello))
(test '(let () (define a '(hello))
(define b '(world))
(define reset!
(lambda ()
@ -779,7 +779,7 @@
(list a b (reset!) a b))
'((hello) (world) ok () (world)))
(test '(begin (define a '(hello))
(test '(let () (define a '(hello))
(define b '(world))
(define reset!
(lambda ()
@ -790,7 +790,7 @@
'((hello)()))
(test '(begin (define a '(hello))
(test '(let () (define a '(hello))
(define b '(world))
(define reset!
(lambda ()
@ -902,7 +902,7 @@
#:control-limit 3)
(test '(begin (define counter
(test '(let () (define counter
(let ([x 0])
(lambda ()
(set! x (add1 x))
@ -913,7 +913,7 @@
(test '(begin
(test '(let ()
(define (make-gen gen)
(let ([cont (box #f)])
(lambda ()
@ -940,7 +940,7 @@
(test '(begin (define (f)
(test '(let () (define (f)
(define cont #f)
(define n 0)
(call/cc (lambda (x) (set! cont x)))
@ -955,7 +955,8 @@
;; This should produce 1 because there's a continuation prompt around each evaluation,
;; and the call/cc cuts off at the prompt.
(test '(begin
;; FIXME: Test currently disabled until the 5.1.2 parser is fixed.
#;(test '(begin
(define cont #f)
(define n 0)
(call/cc (lambda (x) (set! cont x)))
@ -967,8 +968,8 @@
#:with-bootstrapping? #t)
(test '(begin
;; test disabled until the 5.1.2 parser is fixed
#;(test '(begin
(define (make-gen gen)
(let ([cont (box #f)])
(lambda ()
@ -992,8 +993,8 @@
#:with-bootstrapping? #t)
(let ([op (open-output-string)])
;; test disabled until the 5.1.2 parser is fixed
#;(let ([op (open-output-string)])
(parameterize ([current-simulated-output-port op])
(test '(begin
(define (make-gen gen)
@ -1022,7 +1023,8 @@
(error 'failure)))
(test '(begin (define K #f)
;; test disabled until the 5.1.2 parser is fixed
#;(test '(begin (define K #f)
(let ([x 3]
[y 4]
[z 5])
@ -1037,12 +1039,12 @@
(test '(begin (define (m f x y)
(test '(let () (define (m f x y)
(f (f x y) y))
(m + 7 4))
15)
(test '(begin (define (m f x y)
(test '(let () (define (m f x y)
(f (f x y) y))
(m - 7 4))
-1)
@ -1059,7 +1061,7 @@
"thisisatest"
#:with-bootstrapping? #t)
(test '(begin (define (f x y z)
(test '(let () (define (f x y z)
(cons x (cons y z)))
(apply f (list "shiny" "happy" "monsters")))
(cons "shiny" (cons "happy" "monsters"))
@ -1067,11 +1069,11 @@
;; Some tests with vararity functions
(test `(begin (define mylist (lambda args args))
(test `(let () (define mylist (lambda args args))
(mylist 3 4 5))
(list 3 4 5))
(test `(begin (define mylist (lambda args args))
(test `(let () (define mylist (lambda args args))
(apply mylist 3 4 5 '(6 7)))
(list 3 4 5 6 7)
#:with-bootstrapping? #t)
@ -1102,18 +1104,18 @@
#:with-bootstrapping? #t)
(test '(begin (values "hi" "there")
(test '(let () (values "hi" "there")
(string-append "hello " "world"))
"hello world"
#:with-bootstrapping? #t)
(test '(begin (values "hi" "there")
(test '(let () (values "hi" "there")
(string-append (values "hello ") "world"))
"hello world"
#:with-bootstrapping? #t)
(test '(begin (values 3 4 5)
(test '(let () (values 3 4 5)
17)
17
#:with-bootstrapping? #t)
@ -1131,8 +1133,10 @@
(syntax-case stx ()
[(_ code expected options ...)
(syntax/loc stx
(let ([code-val code])
(test `(begin (define (extract-current-continuation-marks key)
(void)
;; disabled until 5.1.2 parser is fixed
#;(let ([code-val code])
(test `(let () (define (extract-current-continuation-marks key)
(continuation-mark-set->list
(current-continuation-marks)
key))
@ -1254,41 +1258,41 @@
(test '(begin (define-values () (values))
(test '(let () (define-values () (values))
'ok)
'ok
#:with-bootstrapping? #t)
(test '(begin (define-values (x y z) (values 3 4 5))
(test '(let () (define-values (x y z) (values 3 4 5))
x)
3
#:with-bootstrapping? #t)
(test '(begin (define-values (x y z) (values 3 4 5))
(test '(let () (define-values (x y z) (values 3 4 5))
y)
4
#:with-bootstrapping? #t)
(test '(begin (define-values (x y z) (values 3 4 5))
(test '(let () (define-values (x y z) (values 3 4 5))
z)
5
#:with-bootstrapping? #t)
(test '(begin (define-values (x) "hello")
(test '(let () (define-values (x) "hello")
x)
"hello"
#:with-bootstrapping? #t)
(test '(begin (define-values (x) (values "hello"))
(test '(let () (define-values (x) (values "hello"))
x)
"hello"
#:with-bootstrapping? #t)
(test '(begin (define (f x)
(test '(let () (define (f x)
(values (* x 2)
(/ x 2)))
(define-values (a b) (f 16))

5
tests/test-package.rkt
View File

@ -20,13 +20,14 @@
1
(* (factorial (- n 1))
n))))
(test '(begin
(test '(let ()
(define (factorial n)
(fact-iter n 1))
(define (fact-iter n acc)
(if (= n 0)
acc
(fact-iter (- n 1) (* acc n))))))
(fact-iter (- n 1) (* acc n))))
'ok))
(test '(define (gauss n)
(if (= n 0)

70
tests/test-parse-bytecode.rkt
View File

@ -65,16 +65,16 @@
;; global variables
(check-equal? (run-my-parse #'x)
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-ToplevelRef 0 0)))
(make-ToplevelRef 0 0 #t)))
(check-equal? (run-my-parse #'(begin (define x 3)
x))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-Splice (list (make-DefValues (list (make-ToplevelRef 0 0))
(make-Splice (list (make-DefValues (list (make-ToplevelRef 0 0 #t))
(make-Constant 3))
(make-ToplevelRef 0 0)))))
(make-ToplevelRef 0 0 #t)))))
;; Lambdas
@ -119,15 +119,15 @@
(check-equal? (run-my-parse #'(let ([y (f)])
'ok))
(make-Top (make-Prefix (list (make-GlobalBucket 'f)))
(make-Let1 (make-App (make-ToplevelRef 1 0) (list))
(make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list))
(make-Constant 'ok))))
(check-equal? (run-my-parse #'(let ([y (f)]
[z (g)])
'ok))
(make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g)))
(make-Let1 (make-App (make-ToplevelRef 1 0) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1) (list))
(make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list))
(make-Constant 'ok)))))
(check-equal? (run-my-parse #'(let* ([y (f)]
@ -135,8 +135,8 @@
y
z))
(make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g)))
(make-Let1 (make-App (make-ToplevelRef 1 0) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1) (list))
(make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list))
;; racket's compiler optimizes away the sequence and lookup to y.
#;(make-Seq (list (make-LocalRef 1 #f)
(make-LocalRef 0 #f)))
@ -149,8 +149,8 @@
y
z))
(make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g)))
(make-Let1 (make-App (make-ToplevelRef 1 0) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1) (list))
(make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list))
(make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list))
(make-LocalRef 0 #f)))))
@ -161,15 +161,15 @@
(make-Top (make-Prefix (list (make-GlobalBucket 'f)
(make-GlobalBucket 'g)
(make-GlobalBucket 'h)))
(make-Branch (make-App (make-ToplevelRef 0 0) '())
(make-App (make-ToplevelRef 0 1) '())
(make-App (make-ToplevelRef 0 2) '()))))
(make-Branch (make-App (make-ToplevelRef 0 0 #t) '())
(make-App (make-ToplevelRef 0 1 #t) '())
(make-App (make-ToplevelRef 0 2 #t) '()))))
;; Another example where Racket's compiler is helping: constant propagation, dead code removal.
(check-equal? (run-my-parse #'(if 3 (g) (h)))
(make-Top (make-Prefix (list (make-GlobalBucket 'g)))
(make-App (make-ToplevelRef 0 0) '())))
(make-App (make-ToplevelRef 0 0 #t) '())))
@ -178,9 +178,9 @@
(make-Top (make-Prefix (list (make-GlobalBucket 'x)
(make-GlobalBucket 'y)
(make-GlobalBucket 'z)))
(make-Branch (make-ToplevelRef 0 0)
(make-Branch (make-ToplevelRef 0 1)
(make-ToplevelRef 0 2)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-Branch (make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 2 #t)
(make-Constant 1))
(make-Constant #t))))
@ -188,8 +188,8 @@
(check-equal? (run-my-parse #'(cond [x y]))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)
(make-GlobalBucket 'y)))
(make-Branch (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-Constant (void)))))
@ -204,9 +204,9 @@
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-App (make-PrimitiveKernelValue '+)
(list (make-App (make-PrimitiveKernelValue '*)
(list (make-ToplevelRef 4 0)
(make-ToplevelRef 4 0)))
(make-ToplevelRef 2 0)))))
(list (make-ToplevelRef 4 0 #t)
(make-ToplevelRef 4 0 #t)))
(make-ToplevelRef 2 0 #t)))))
(check-equal? (run-my-parse #'list)
(make-Top (make-Prefix (list))
@ -219,7 +219,7 @@
(check-equal? (run-my-parse #'(let () x))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-ToplevelRef 0 0)))
(make-ToplevelRef 0 0 #t)))
@ -276,8 +276,8 @@
(check-equal? (run-my-parse #'(call-with-values (lambda () (f)) g))
(make-Top (make-Prefix (list (make-GlobalBucket 'f)
(make-GlobalBucket 'g)))
(make-ApplyValues (make-ToplevelRef 0 1)
(make-App (make-ToplevelRef 0 0) '()))))
(make-ApplyValues (make-ToplevelRef 0 1 #t)
(make-App (make-ToplevelRef 0 0 #t) '()))))
@ -325,18 +325,18 @@
(check-equal? (run-my-parse #'(begin0 (f)))
(make-Top (make-Prefix (list (make-GlobalBucket 'f)))
(make-App (make-ToplevelRef 0 0) '())))
(make-App (make-ToplevelRef 0 0 #t) '())))
(check-equal? (run-my-parse #'(begin0 (f) (g)))
(make-Top (make-Prefix (list (make-GlobalBucket 'f)
(make-GlobalBucket 'g)))
(make-Begin0 (list (make-App (make-ToplevelRef 0 0) '())
(make-App (make-ToplevelRef 0 1) '())))))
(make-Begin0 (list (make-App (make-ToplevelRef 0 0 #t) '())
(make-App (make-ToplevelRef 0 1 #t) '())))))
;; Compiling modules
(check-true
(match (run-my-parse #'(module foo racket/base
(match (run-my-parse #'(module foo1 racket/base
42))
[(struct Top ((struct Prefix (list))
(struct Module ((? symbol?)
@ -345,12 +345,12 @@
_ ;; requires
_ ;; provides
(struct Splice ((list (struct ApplyValues
((struct ToplevelRef ('0 '0)) (struct Constant ('42)))))))))))
((struct ToplevelRef ('0 '0 _)) (struct Constant ('42)))))))))))
#t]))
(check-true
(match (run-my-parse #'(module foo racket/base
(match (run-my-parse #'(module foo2 racket/base
(provide x)
(define x "x")))
[(struct Top ((struct Prefix ((? list?)))
@ -360,7 +360,7 @@
_ ;; requires
_ ;; provides
(struct Splice ((list (struct DefValues
((list (struct ToplevelRef ('0 '0)))
((list (struct ToplevelRef ('0 '0 _)))
(struct Constant ("x")))))))))))
#t]))
@ -370,7 +370,7 @@
;; Variable reference
(check-equal? (run-my-parse #'(#%variable-reference x))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-VariableReference (make-ToplevelRef 0 0))))
(make-VariableReference (make-ToplevelRef 0 0 #t))))
;; todo: see what it would take to run a typed/racket/base language.
(void
@ -441,7 +441,7 @@
(struct Prefix ((list 'f)))
(list (struct ModuleLocator ('#%kernel '#%kernel)))
_
(struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0)))
(struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0 #t)))
(struct Constant ('ok)))))))))))
'#t]))
@ -452,6 +452,8 @@
;(run-my-parse/file "/home/dyoo/work/whalesong/tests/earley/earley.sch")
;(run-zo-parse #'(lambda (x) (* x x)))
;(run-my-parse #'(lambda (x) (* x x)))

92
tests/test-parse.rkt
View File

@ -41,58 +41,58 @@
(test (parse 'hello)
(make-Top (make-Prefix '(hello))
(make-ToplevelRef 0 0)))
(make-ToplevelRef 0 0 #t)))
(test (parse '(begin hello world))
(make-Top (make-Prefix '(hello world))
(make-Splice (list (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)))))
(make-Splice (list (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)))))
(test (parse '(define x y))
(make-Top (make-Prefix '(x y))
(make-ToplevelSet 0 0 (make-ToplevelRef 0 1))))
(make-ToplevelSet 0 0 (make-ToplevelRef 0 1 #t))))
(test (parse '(begin (define x 42)
(define y x)))
(make-Top (make-Prefix '(x y))
(make-Splice (list (make-ToplevelSet 0 0 (make-Constant 42))
(make-ToplevelSet 0 1 (make-ToplevelRef 0 0))))))
(make-ToplevelSet 0 1 (make-ToplevelRef 0 0 #t))))))
(test (parse '(if x y z))
(make-Top (make-Prefix '(x y z))
(make-Branch (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-ToplevelRef 0 2))))
(make-Branch (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 2 #t))))
(test (parse '(if x (if y z 1) #t))
(make-Top (make-Prefix '(x y z))
(make-Branch (make-ToplevelRef 0 0)
(make-Branch (make-ToplevelRef 0 1)
(make-ToplevelRef 0 2)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-Branch (make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 2 #t)
(make-Constant 1))
(make-Constant #t))))
(test (parse '(if x y))
(make-Top (make-Prefix '(x y))
(make-Branch (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-Constant (void)))))
(test (parse '(cond [x y]))
(make-Top (make-Prefix '(x y))
(make-Branch (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-Constant (void)))))
(test (parse '(cond [x y] [else "ok"]))
(make-Top (make-Prefix '(x y))
(make-Branch (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-Branch (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-Constant "ok"))))
(test (parse '(lambda () x))
(make-Top (make-Prefix '(x))
(make-Lam 'unknown 0 #f (make-ToplevelRef 0 0)
(make-Lam 'unknown 0 #f (make-ToplevelRef 0 0 #t)
'(0) 'lamEntry1)))
(test (parse '(lambda args args))
@ -146,7 +146,7 @@
(make-Lam 'unknown
3
#f
(make-ToplevelRef 0 0 )
(make-ToplevelRef 0 0 #t)
'(0)
'lamEntry1)))
@ -155,7 +155,7 @@
(make-Lam 'unknown
3
#f
(make-Seq (list (make-ToplevelRef 0 0 )
(make-Seq (list (make-ToplevelRef 0 0 #t)
(make-LocalRef 1 #f)
(make-LocalRef 2 #f)
(make-LocalRef 3 #f)))
@ -177,7 +177,7 @@
(make-LocalRef 1 #f)
(make-LocalRef 2 #f)
(make-LocalRef 3 #f)
(make-ToplevelRef 0 0)))
(make-ToplevelRef 0 0 #t)))
'(0 1 2) ;; w x y
'lamEntry1)
@ -213,15 +213,15 @@
(test (parse '(+ x x))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))
x))
(make-App (make-ToplevelRef 2 0)
(list (make-ToplevelRef 2 1)
(make-ToplevelRef 2 1)))))
(make-App (make-ToplevelRef 2 0 #t)
(list (make-ToplevelRef 2 1 #t)
(make-ToplevelRef 2 1 #t)))))
(test (parse '(lambda (x) (+ x x)))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))))
(make-Lam 'unknown 1 #f
(make-App (make-ToplevelRef 2 0)
(make-App (make-ToplevelRef 2 0 #t)
(list (make-LocalRef 3 #f)
(make-LocalRef 3 #f)))
'(0)
@ -233,10 +233,10 @@
,(make-ModuleVariable '+ (make-ModuleLocator '#%kernel '#%kernel))))
(make-Lam 'unknown 1 #f
;; stack layout: [???, ???, prefix, x]
(make-App (make-ToplevelRef 2 1)
(make-App (make-ToplevelRef 2 1 #t)
(list
;; stack layout: [???, ???, ???, ???, prefix, x]
(make-App (make-ToplevelRef 4 0)
(make-App (make-ToplevelRef 4 0 #t)
(list (make-LocalRef 5 #f)
(make-LocalRef 5 #f)))
(make-LocalRef 3 #f)))
@ -246,7 +246,7 @@
(test (parse '(let ()
x))
(make-Top (make-Prefix '(x))
(make-ToplevelRef 0 0)))
(make-ToplevelRef 0 0 #t)))
(test (parse '(let ([x 3])
x))
@ -304,10 +304,10 @@
(make-App
;; stack layout: [???, ???, x_0, prefix]
(make-ToplevelRef 3 0) (list (make-LocalRef 2 #f)))
(make-ToplevelRef 3 0 #t) (list (make-LocalRef 2 #f)))
;; stack layout [???, x_1, x_0, prefix]
(make-App (make-ToplevelRef 3 0)
(make-App (make-ToplevelRef 3 0 #t)
(list (make-LocalRef 1 #f)))))))
@ -424,7 +424,7 @@
(make-Lam 'unknown 0 #f
(make-Seq (list (make-InstallValue
1 1
(make-App (make-ToplevelRef 1 0)
(make-App (make-ToplevelRef 1 0 #t)
(list (make-LocalRef 2 #t)))
#t)
(make-Constant (void))))
@ -446,7 +446,7 @@
(make-Seq
(list (make-InstallValue
1 1
(make-App (make-ToplevelRef 1 0)
(make-App (make-ToplevelRef 1 0 #t)
(list (make-LocalRef 2 #t)))
#t)
(make-Constant (void))))
@ -483,42 +483,42 @@
(make-Seq (list (make-ToplevelSet 0 1 (make-Constant '())) (make-Constant (void))))))
'(0)
'lamEntry1))
(make-App (make-ToplevelRef 0 3) '())
(make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1)))))))
(make-App (make-ToplevelRef 0 3 #t) '())
(make-App (make-ToplevelRef 2 2 #t) (list (make-ToplevelRef 2 0 #t) (make-ToplevelRef 2 1 #t)))))))
(test (parse '(with-continuation-mark x y z))
(make-Top (make-Prefix '(x y z))
(make-WithContMark (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)
(make-ToplevelRef 0 2))))
(make-WithContMark (make-ToplevelRef 0 0 #t)
(make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 2 #t))))
(test (parse '(call-with-values x y))
(make-Top (make-Prefix '(x y))
(make-ApplyValues (make-ToplevelRef 0 1)
(make-App (make-ToplevelRef 0 0) (list)))))
(make-ApplyValues (make-ToplevelRef 0 1 #t)
(make-App (make-ToplevelRef 0 0 #t) (list)))))
(test (parse '(call-with-values (lambda () x) y))
(make-Top (make-Prefix '(x y))
(make-ApplyValues (make-ToplevelRef 0 1)
(make-ToplevelRef 0 0))))
(make-ApplyValues (make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 0 #t))))
(test (parse '(define-values () (values)))
(make-Top (make-Prefix '(values))
(make-DefValues '()
(make-App (make-ToplevelRef 0 0) '()))))
(make-App (make-ToplevelRef 0 0 #t) '()))))
(test (parse '(define-values (x y z) (values 'hello 'world 'testing)))
(make-Top (make-Prefix '(values x y z))
(make-DefValues (list (make-ToplevelRef 0 1)
(make-ToplevelRef 0 2)
(make-ToplevelRef 0 3))
(make-App (make-ToplevelRef 3 0)
(make-DefValues (list (make-ToplevelRef 0 1 #t)
(make-ToplevelRef 0 2 #t)
(make-ToplevelRef 0 3 #t))
(make-App (make-ToplevelRef 3 0 #t)
(list (make-Constant 'hello)
(make-Constant 'world)
(make-Constant 'testing))))))