Ignore the extra zo fields added in 6.3, copy updated qq-and-or.rkt
This commit is contained in:
Georges Dupéron
parent
444d773334
commit
84703417d7
|
|
@ -5,19 +5,50 @@
|
|||
(module qq-and-or '#%kernel
|
||||
(#%require (for-syntax "stx.rkt" '#%kernel))
|
||||
|
||||
(define-syntaxes (let let* letrec)
|
||||
(define-syntaxes (let*-values let let* letrec)
|
||||
(let-values ([(lambda-stx) (quote-syntax lambda-stx)]
|
||||
[(letrec-values-stx) (quote-syntax letrec-values)])
|
||||
[(letrec-values-stx) (quote-syntax letrec-values)]
|
||||
[(check-for-duplicates)
|
||||
(lambda (new-bindings sel stx)
|
||||
(define-values (id-in-list?)
|
||||
(lambda (id l)
|
||||
(if (null? l)
|
||||
#f
|
||||
(if (bound-identifier=? id (car l))
|
||||
#t
|
||||
(id-in-list? id (cdr l))))))
|
||||
(if ((length new-bindings) . > . 5)
|
||||
(let-values ([(ht) (make-hasheq)])
|
||||
(letrec-values ([(check) (lambda (l)
|
||||
(if (null? l)
|
||||
(void)
|
||||
(let-values ([(id) (sel (car l))])
|
||||
(let-values ([(idl) (hash-ref ht (syntax-e id) null)])
|
||||
(if (id-in-list? id idl)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
id)
|
||||
(begin
|
||||
(hash-set! ht (syntax-e id) (cons id idl))
|
||||
(check (cdr l))))))))])
|
||||
(check new-bindings)))
|
||||
(letrec-values ([(check) (lambda (l accum)
|
||||
(if (null? l)
|
||||
(void)
|
||||
(let-values ([(id) (sel (car l))])
|
||||
(if (id-in-list? id accum)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
id)
|
||||
(check (cdr l) (cons id accum))))))])
|
||||
(check new-bindings null))))])
|
||||
(let-values ([(go)
|
||||
(lambda (stx named? star? target)
|
||||
(define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
|
||||
(define-values (id-in-list?)
|
||||
(lambda (id l)
|
||||
(if (null? l)
|
||||
#f
|
||||
(if (bound-identifier=? id (car l))
|
||||
#t
|
||||
(id-in-list? id (cdr l))))))
|
||||
(define-values (stx-2list?)
|
||||
(lambda (x)
|
||||
(if (stx-pair? x)
|
||||
|
|
@ -25,20 +56,28 @@
|
|||
(stx-null? (stx-cdr (stx-cdr x)))
|
||||
#f)
|
||||
#f)))
|
||||
(if (if (not (stx-list? stx))
|
||||
#t
|
||||
(let-values ([(tail1) (stx-cdr stx)])
|
||||
(if (stx-null? tail1)
|
||||
#t
|
||||
(if (stx-null? (stx-cdr tail1))
|
||||
#t
|
||||
(if named?
|
||||
(if (symbol? (syntax-e (stx-car tail1)))
|
||||
(stx-null? (stx-cdr (stx-cdr tail1)))
|
||||
#f)
|
||||
#f)))))
|
||||
(raise-syntax-error #f "bad syntax" stx)
|
||||
(void))
|
||||
(let-values ([(maybe-msg)
|
||||
(if (not (stx-list? stx))
|
||||
""
|
||||
(let-values ([(tail1) (stx-cdr stx)])
|
||||
(if (stx-null? tail1)
|
||||
(if named?
|
||||
"(missing name or binding pairs)"
|
||||
"(missing binding pairs)")
|
||||
(if (stx-null? (stx-cdr tail1))
|
||||
(if named?
|
||||
"(missing binding pairs or body)"
|
||||
"(missing body)")
|
||||
(if named?
|
||||
(if (symbol? (syntax-e (stx-car tail1)))
|
||||
(if (stx-null? (stx-cdr (stx-cdr tail1)))
|
||||
"(missing body)"
|
||||
#f)
|
||||
#f)
|
||||
#f)))))])
|
||||
(if maybe-msg
|
||||
(raise-syntax-error #f (string-append "bad syntax " maybe-msg) stx)
|
||||
(void)))
|
||||
(let-values ([(name) (if named?
|
||||
(let-values ([(n) (stx-cadr stx)])
|
||||
(if (symbol? (syntax-e n))
|
||||
|
|
@ -89,39 +128,11 @@
|
|||
(loop bindings))])
|
||||
(if star?
|
||||
(void)
|
||||
(if ((length new-bindings) . > . 5)
|
||||
(let-values ([(ht) (make-hasheq)])
|
||||
(letrec-values ([(check) (lambda (l)
|
||||
(if (null? l)
|
||||
(void)
|
||||
(let*-values ([(id) (if name
|
||||
(caar l)
|
||||
(stx-car (stx-car (car l))))]
|
||||
[(idl) (hash-ref ht (syntax-e id) null)])
|
||||
(if (id-in-list? id idl)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
id)
|
||||
(begin
|
||||
(hash-set! ht (syntax-e id) (cons id idl))
|
||||
(check (cdr l)))))))])
|
||||
(check new-bindings)))
|
||||
(letrec-values ([(check) (lambda (l accum)
|
||||
(if (null? l)
|
||||
(void)
|
||||
(let-values ([(id) (if name
|
||||
(caar l)
|
||||
(stx-car (stx-car (car l))))])
|
||||
(if (id-in-list? id accum)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
id)
|
||||
(check (cdr l) (cons id accum))))))])
|
||||
(check new-bindings null))))
|
||||
(check-for-duplicates new-bindings
|
||||
(if name
|
||||
car
|
||||
(lambda (v) (stx-car (stx-car v))))
|
||||
stx))
|
||||
(datum->syntax
|
||||
lambda-stx
|
||||
(if name
|
||||
|
|
@ -141,6 +152,44 @@
|
|||
body))
|
||||
stx))))))])
|
||||
(values
|
||||
(lambda (stx)
|
||||
(define-values (bad-syntax)
|
||||
(lambda ()
|
||||
(raise-syntax-error #f "bad syntax" stx)))
|
||||
(define-values (l) (syntax->list stx))
|
||||
(if (not l) (bad-syntax) (void))
|
||||
(if ((length l) . < . 3) (bad-syntax) (void))
|
||||
(define-values (bindings) (syntax->list (cadr l)))
|
||||
(if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void))
|
||||
(for-each (lambda (binding)
|
||||
(define-values (l) (syntax->list binding))
|
||||
(if (if (not l)
|
||||
#t
|
||||
(not (= 2 (length l))))
|
||||
(raise-syntax-error #f "bad syntax" stx binding)
|
||||
(void))
|
||||
(define-values (vars) (syntax->list (car l)))
|
||||
(if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void))
|
||||
(for-each (lambda (var)
|
||||
(if (not (symbol? (syntax-e var)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (not an identifier)"
|
||||
stx
|
||||
var)
|
||||
(void)))
|
||||
vars)
|
||||
(check-for-duplicates vars values stx))
|
||||
bindings)
|
||||
(define-values (gen)
|
||||
(lambda (bindings nested?)
|
||||
(if (null? bindings)
|
||||
(if nested?
|
||||
(cddr l)
|
||||
(list* (quote-syntax let-values) '() (cddr l)))
|
||||
((if nested? list values)
|
||||
(list* (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings) #t))))))
|
||||
(datum->syntax #f (gen bindings #f) stx stx))
|
||||
(lambda (stx) (go stx #t #f (quote-syntax let-values)))
|
||||
(lambda (stx) (go stx #f #t (quote-syntax let*-values)))
|
||||
(lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
|
||||
|
|
@ -149,7 +198,7 @@
|
|||
(lambda (a b)
|
||||
(if (list? a)
|
||||
(append a b)
|
||||
(raise-type-error 'unquote-splicing "proper list" a))))
|
||||
(raise-argument-error 'unquote-splicing "list?" a))))
|
||||
|
||||
(define-syntaxes (quasiquote)
|
||||
(let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
|
||||
|
|
@ -372,7 +421,7 @@
|
|||
(list (quote-syntax quote)
|
||||
rest)
|
||||
rest)))))))))
|
||||
(let-values (((l0) (hash-map (syntax-e x) cons)))
|
||||
(let-values (((l0) (hash-map (syntax-e x) cons #t)))
|
||||
(let-values
|
||||
(((l) (qq-hash-assocs l0 level)))
|
||||
(if (eq? l0 l)
|
||||
|
|
@ -450,5 +499,6 @@
|
|||
"bad syntax"
|
||||
x))))))))
|
||||
|
||||
(#%provide let let* letrec
|
||||
(#%provide let*-values
|
||||
let let* letrec
|
||||
quasiquote and or))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
|
||||
|
||||
(version-case
|
||||
[(version>= (version) "5.3.3.7")
|
||||
[(and (version>= (version) "5.3.3.7")
|
||||
(version< (version) "6.3"))
|
||||
|
||||
;; Parsing Racket 5.3 bytecode structures into our own structures.
|
||||
(require "path-rewriter.rkt"
|
||||
|
|
|
|||
763
whalesong/parser/parse-bytecode-6.3.rkt
Normal file
763
whalesong/parser/parse-bytecode-6.3.rkt
Normal file
|
|
@ -0,0 +1,763 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "../version-case/version-case.rkt"
|
||||
(for-syntax racket/base))
|
||||
|
||||
|
||||
|
||||
(version-case
|
||||
[(version>= (version) "5.3.3.7")
|
||||
|
||||
;; Parsing Racket 5.3 bytecode structures into our own structures.
|
||||
(require "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)
|
||||
|
||||
|
||||
|
||||
;; 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 (_ _binding-namess 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)])])
|
||||
(define module-bytecode (get-module-bytecode normal-path))
|
||||
(parse-bytecode (open-input-bytes module-bytecode))))]
|
||||
[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 _binding-namess 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 _src-inspector-desc))
|
||||
(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
|
||||
(displayln (list 'wrap-module-name resolved-path-name rewritten-path))
|
||||
(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
|
||||
;; Explicit check for inline-variant first, since that's the only place
|
||||
;; it apppears
|
||||
[(struct def-values (ids (struct inline-variant (direct inline))))
|
||||
(make-DefValues (map parse-toplevel ids)
|
||||
(parse-expr direct))]
|
||||
|
||||
[(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 _binding-names flags
|
||||
pre-submodules post-submodules))
|
||||
(cond
|
||||
[(symbol? name)
|
||||
;; FIXME: no support for submodules yet.
|
||||
(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)]))]))]
|
||||
[else
|
||||
(error 'parse-bytecode "Whalesong doesn't yet support submodules")])]))
|
||||
|
||||
|
||||
|
||||
;; 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 (make-lam-label)
|
||||
(make-label 'lamEntry))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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
|
||||
const?
|
||||
(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)])
|
||||
|
|
@ -41,12 +41,19 @@
|
|||
(require "parse-bytecode-5.3.rkt")
|
||||
(provide (except-out (all-from-out "parse-bytecode-5.3.rkt")
|
||||
parse-bytecode)))]
|
||||
[(version>= (version) "5.3.3.7")
|
||||
[(and (version>= (version) "5.3.3.7")
|
||||
(version< (version) "6.3"))
|
||||
(begin
|
||||
(log-debug "Using 5.3.3.7 bytecode parser")
|
||||
(require "parse-bytecode-5.3.3.7.rkt")
|
||||
(provide (except-out (all-from-out "parse-bytecode-5.3.3.7.rkt")
|
||||
parse-bytecode)))]
|
||||
[(version>= (version) "6.3")
|
||||
(begin
|
||||
(log-debug "Using 6.3 bytecode parser")
|
||||
(require "parse-bytecode-6.3.rkt")
|
||||
(provide (except-out (all-from-out "parse-bytecode-6.3.rkt")
|
||||
parse-bytecode)))]
|
||||
[else
|
||||
(error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user