Jay McCarthy
commit
684a88a0e8
|
|
@ -228,6 +228,11 @@
|
|||
(traverse-stx expr visit)]
|
||||
[(wrapped? expr)
|
||||
(traverse-wrapped expr visit)]
|
||||
[(hash? expr)
|
||||
(when (visit expr)
|
||||
(for ([(k v) (in-hash expr)])
|
||||
(traverse-data k visit)
|
||||
(traverse-data v visit)))]
|
||||
[else
|
||||
(void)]))
|
||||
|
||||
|
|
@ -987,16 +992,18 @@
|
|||
(for ([v (in-vector expr)])
|
||||
(out-data v out))]
|
||||
[(hash? expr)
|
||||
(out-byte CPT_HASH_TABLE out)
|
||||
(out-number (cond
|
||||
[(hash-eqv? expr) 2]
|
||||
[(hash-eq? expr) 0]
|
||||
[else 1])
|
||||
out)
|
||||
(out-number (hash-count expr) out)
|
||||
(for ([(k v) (in-hash expr)])
|
||||
(out-data k out)
|
||||
(out-data v out))]
|
||||
(out-shared expr out
|
||||
(lambda ()
|
||||
(out-byte CPT_HASH_TABLE out)
|
||||
(out-number (cond
|
||||
[(hash-eqv? expr) 2]
|
||||
[(hash-eq? expr) 0]
|
||||
[else 1])
|
||||
out)
|
||||
(out-number (hash-count expr) out)
|
||||
(for ([(k v) (in-hash expr)])
|
||||
(out-data k out)
|
||||
(out-data v out))))]
|
||||
[(svector? expr)
|
||||
(let* ([vec (svector-vec expr)]
|
||||
[len (vector-length vec)])
|
||||
|
|
|
|||
|
|
@ -15,8 +15,6 @@
|
|||
|
||||
Lines 628, 630 seem to be only for debugging and should probably throw errors
|
||||
|
||||
unmarshal-stx-get also seems to be for debugging and should probably throw an error
|
||||
|
||||
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
|
||||
|
||||
Line 816: This should be an eqv placeholder (but they don't exist)
|
||||
|
|
@ -29,8 +27,6 @@
|
|||
|
||||
collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (#<module-path-index> 0 (1363072) . #f) --- that doesn't seem to match the spec
|
||||
|
||||
We seem to leave placeholders for hash-tables in the structs
|
||||
|
||||
|#
|
||||
;; ----------------------------------------
|
||||
;; Bytecode unmarshalers for various forms
|
||||
|
|
@ -501,15 +497,9 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
;; Syntax unmarshaling
|
||||
|
||||
(define (decode-stx cp v)
|
||||
(if (integer? v)
|
||||
(let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
|
||||
(if decoded?
|
||||
v2
|
||||
(let ([v2 (decode-stx cp v2)])
|
||||
(unmarshal-stx-set! cp v v2)
|
||||
v2)))
|
||||
(unmarshal-stx-get/decode cp v decode-stx)
|
||||
(let loop ([v v])
|
||||
(let-values ([(cert-marks v encoded-wraps)
|
||||
(match v
|
||||
|
|
@ -564,29 +554,17 @@
|
|||
(map loop (cdr (vector->list (struct->vector v)))))))]
|
||||
[else (add-wrap v)]))))))
|
||||
|
||||
|
||||
|
||||
(define (decode-wraps cp w)
|
||||
; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
|
||||
(if (integer? w)
|
||||
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
|
||||
(if decoded?
|
||||
w2
|
||||
(let ([w2 (decode-wraps cp w2)])
|
||||
(unmarshal-stx-set! cp w w2)
|
||||
w2)))
|
||||
(unmarshal-stx-get/decode cp w decode-wraps)
|
||||
(map (lambda (a)
|
||||
(let aloop ([a a])
|
||||
; A wrap-elem is either
|
||||
(cond
|
||||
; A reference
|
||||
[(integer? a)
|
||||
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
|
||||
(if decoded?
|
||||
a2
|
||||
(let ([a2 (aloop a2)])
|
||||
(unmarshal-stx-set! cp a a2)
|
||||
a2)))]
|
||||
(unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))]
|
||||
; A mark (not actually a number as the C says, but a (list <num>)
|
||||
[(and (pair? a) (null? (cdr a)) (number? (car a)))
|
||||
(make-wrap-mark (car a))]
|
||||
|
|
@ -704,23 +682,6 @@
|
|||
[module-path-index
|
||||
(make-simple-module-binding module-path-index)]))))
|
||||
|
||||
(define (unmarshal-stx-get cp pos)
|
||||
(if (pos . >= . (vector-length (cport-symtab cp)))
|
||||
(values `(#%bad-index ,pos) #t)
|
||||
(let ([v (vector-ref (cport-symtab cp) pos)])
|
||||
(if (not-ready? v)
|
||||
(let ([save-pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(set-cport-pos! cp save-pos)
|
||||
(values v #f)))
|
||||
(values v (vector-ref (cport-decoded cp) pos))))))
|
||||
|
||||
(define (unmarshal-stx-set! cp pos v)
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(vector-set! (cport-decoded cp) pos #t))
|
||||
|
||||
(define (parse-module-path-index cp s)
|
||||
s)
|
||||
;; ----------------------------------------
|
||||
|
|
@ -738,15 +699,7 @@
|
|||
(case cpt-tag
|
||||
[(delayed)
|
||||
(let ([pos (read-compact-number cp)])
|
||||
(let ([v (vector-ref (cport-symtab cp) pos)])
|
||||
(if (not-ready? v)
|
||||
(let ([save-pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! (cport-symtab cp) pos v)
|
||||
(set-cport-pos! cp save-pos)
|
||||
v))
|
||||
v)))]
|
||||
(read-sym cp pos))]
|
||||
[(escape)
|
||||
(let* ([len (read-compact-number cp)]
|
||||
[s (cport-get-bytes cp len)])
|
||||
|
|
@ -841,9 +794,8 @@
|
|||
[len (read-compact-number cp)])
|
||||
((case eq
|
||||
[(0) make-hasheq-placeholder]
|
||||
; XXX One of these should be eqv
|
||||
[(1) make-hash-placeholder]
|
||||
[(2) make-hash-placeholder])
|
||||
[(2) make-hasheqv-placeholder])
|
||||
(for/list ([i (in-range len)])
|
||||
(cons (read-compact cp)
|
||||
(read-compact cp)))))]
|
||||
|
|
@ -894,16 +846,8 @@
|
|||
(read-compact cp))))])
|
||||
(read (open-input-bytes #"x")))))]
|
||||
[(symref)
|
||||
(let* ([l (read-compact-number cp)]
|
||||
[v (vector-ref (cport-symtab cp) l)])
|
||||
(if (not-ready? v)
|
||||
(let ([pos (cport-pos cp)])
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
|
||||
(let ([v (read-compact cp)])
|
||||
(set-cport-pos! cp pos)
|
||||
(vector-set! (cport-symtab cp) l v)
|
||||
v))
|
||||
v))]
|
||||
(let* ([l (read-compact-number cp)])
|
||||
(read-sym cp l))]
|
||||
[(weird-symbol)
|
||||
(let ([uninterned (read-compact-number cp)]
|
||||
[str (read-compact-chars cp (read-compact-number cp))])
|
||||
|
|
@ -934,7 +878,7 @@
|
|||
[(closure)
|
||||
(let* ([l (read-compact-number cp)]
|
||||
[ind (make-indirect #f)])
|
||||
(vector-set! (cport-symtab cp) l ind)
|
||||
(placeholder-set! (vector-ref (cport-symtab cp) l) ind)
|
||||
(let* ([v (read-compact cp)]
|
||||
[cl (make-closure v (gensym
|
||||
(let ([s (lam-name v)])
|
||||
|
|
@ -956,6 +900,36 @@
|
|||
[else
|
||||
(cons v (loop (sub1 need-car) proper))]))))
|
||||
|
||||
(define (unmarshal-stx-get/decode cp pos decode-stx)
|
||||
(define v2 (read-sym cp pos))
|
||||
(define decoded? (vector-ref (cport-decoded cp) pos))
|
||||
(if decoded?
|
||||
v2
|
||||
(let ([dv2 (decode-stx cp v2)])
|
||||
(placeholder-set! (vector-ref (cport-symtab cp) pos) dv2)
|
||||
(vector-set! (cport-decoded cp) pos #t)
|
||||
dv2)))
|
||||
|
||||
(require unstable/markparam)
|
||||
(define read-sym-mark (mark-parameter))
|
||||
(define (read-sym cp i)
|
||||
(define symtab (cport-symtab cp))
|
||||
(define ph (vector-ref symtab i))
|
||||
; We are reading this already, so return the placeholder
|
||||
(if (memq i (mark-parameter-all read-sym-mark))
|
||||
ph
|
||||
; Otherwise, try to read it and return the real thing
|
||||
(local [(define vv (placeholder-get ph))]
|
||||
(when (not-ready? vv)
|
||||
(local [(define save-pos (cport-pos cp))]
|
||||
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
|
||||
(mark-parameterize
|
||||
([read-sym-mark i])
|
||||
(let ([v (read-compact cp)])
|
||||
(placeholder-set! ph v)))
|
||||
(set-cport-pos! cp save-pos)))
|
||||
(placeholder-get ph))))
|
||||
|
||||
;; path -> bytes
|
||||
;; implementes read.c:read_compiled
|
||||
(define (zo-parse port)
|
||||
|
|
@ -990,18 +964,17 @@
|
|||
(unless (eof-object? (read-byte port))
|
||||
(error 'zo-parse "File too big"))
|
||||
|
||||
(define symtab (make-vector symtabsize (make-not-ready)))
|
||||
(define nr (make-not-ready))
|
||||
(define symtab
|
||||
(build-vector symtabsize (λ (i) (make-placeholder nr))))
|
||||
|
||||
(define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
||||
|
||||
(for/list ([i (in-range 1 symtabsize)])
|
||||
(define vv (vector-ref symtab i))
|
||||
(when (not-ready? vv)
|
||||
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! symtab i v))))
|
||||
(read-sym cp i))
|
||||
(set-cport-pos! cp shared-size)
|
||||
(read-marshalled 'compilation-top-type cp)))
|
||||
(make-reader-graph
|
||||
(read-marshalled 'compilation-top-type cp))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
|
||||
(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...))
|
||||
(begin
|
||||
(define-struct id+par (field-id ...) #:transparent)
|
||||
(define-struct id+par (field-id ...) #:prefab)
|
||||
(provide/contract
|
||||
[struct id ([field-id field-contract] ...)])))
|
||||
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
(define-form-struct (expr form) ())
|
||||
|
||||
;; A static closure can refer directly to itself, creating a cycle
|
||||
(define-struct indirect ([v #:mutable]) #:transparent)
|
||||
(define-struct indirect ([v #:mutable]) #:prefab)
|
||||
|
||||
(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this
|
||||
|
||||
|
|
|
|||
22
collects/tests/compiler/zo-exs.rkt
Normal file
22
collects/tests/compiler/zo-exs.rkt
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#lang racket
|
||||
(require compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
tests/eli-tester)
|
||||
|
||||
(define (roundtrip ct)
|
||||
(define bs (zo-marshal ct))
|
||||
(test bs
|
||||
(zo-parse (open-input-bytes bs)) => ct))
|
||||
|
||||
(test
|
||||
(local [(define (hash-test make-hash-placeholder)
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(local [(define ht-ph (make-placeholder #f))
|
||||
(define ht (make-hash-placeholder (list (cons 'g ht-ph))))]
|
||||
(placeholder-set! ht-ph ht)
|
||||
(make-reader-graph ht)))))]
|
||||
(hash-test make-hash-placeholder)
|
||||
(hash-test make-hasheq-placeholder)
|
||||
(hash-test make-hasheqv-placeholder)))
|
||||
52
collects/tests/compiler/zo-test.rkt
Normal file → Executable file
52
collects/tests/compiler/zo-test.rkt
Normal file → Executable file
|
|
@ -1,3 +1,8 @@
|
|||
#!/bin/sh
|
||||
#|
|
||||
exec racket -t "$0" -- -s -t 60 -v -R $*
|
||||
|#
|
||||
|
||||
#lang scheme
|
||||
(require compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
|
|
@ -5,9 +10,40 @@
|
|||
setup/dirs)
|
||||
|
||||
;; Helpers
|
||||
(define (bytes->hex-string bs)
|
||||
(apply string-append
|
||||
(for/list ([b bs])
|
||||
(format "~a~x"
|
||||
(if (b . <= . 15) "0" "")
|
||||
b))))
|
||||
|
||||
(define (show-bytes-side-by-side orig new)
|
||||
(define max-length
|
||||
(max (bytes-length orig) (bytes-length new)))
|
||||
(define BYTES-PER-LINE 38)
|
||||
(define lines
|
||||
(ceiling (/ max-length BYTES-PER-LINE)))
|
||||
(define (subbytes* b s e)
|
||||
(subbytes b (min s (bytes-length b)) (min e (bytes-length b))))
|
||||
(for ([line (in-range lines)])
|
||||
(define start (* line BYTES-PER-LINE))
|
||||
(define end (* (add1 line) BYTES-PER-LINE))
|
||||
(printf "+ ~a\n" (bytes->hex-string (subbytes* orig start end)))
|
||||
(printf "- ~a\n" (bytes->hex-string (subbytes* new start end)))))
|
||||
|
||||
(define (bytes-gulp f)
|
||||
(with-input-from-file f
|
||||
(λ () (port->bytes (current-input-port)))))
|
||||
|
||||
(define (read-compiled-bytes bs)
|
||||
(define ib (open-input-bytes bs))
|
||||
(dynamic-wind void
|
||||
(lambda ()
|
||||
(parameterize ([read-accept-compiled #t])
|
||||
(read ib)))
|
||||
(lambda ()
|
||||
(close-input-port ib))))
|
||||
|
||||
(define (zo-parse/bytes bs)
|
||||
(define ib (open-input-bytes bs))
|
||||
(dynamic-wind void
|
||||
|
|
@ -245,6 +281,13 @@
|
|||
(lambda (file)
|
||||
(run/stages* file [stage serious? e] ...)))))
|
||||
|
||||
(define debugging? (make-parameter #f))
|
||||
|
||||
(define (print-bytes orig new)
|
||||
(when (debugging?)
|
||||
(show-bytes-side-by-side orig new))
|
||||
#t)
|
||||
|
||||
(define-stages (stages run!)
|
||||
file
|
||||
[read-orig
|
||||
|
|
@ -279,6 +322,12 @@
|
|||
[decompile-parsed
|
||||
#t
|
||||
(decompile parse-orig)]
|
||||
[show-orig-and-marshal-parsed
|
||||
#f
|
||||
(print-bytes read-orig marshal-parsed)]
|
||||
[c-parse-marshalled
|
||||
#f
|
||||
(read-compiled-bytes marshal-parsed)]
|
||||
[compare-orig-to-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error read-orig marshal-parsed)])
|
||||
|
|
@ -345,6 +394,9 @@
|
|||
#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo"))
|
||||
(command-line #:program "zo-test"
|
||||
#:once-each
|
||||
[("-D")
|
||||
"Enable debugging output"
|
||||
(debugging? #t)]
|
||||
[("-s" "--stop-on-first-error")
|
||||
"Stop testing when first error is encountered"
|
||||
(stop-on-first-error #t)]
|
||||
|
|
|
|||
|
|
@ -103,10 +103,10 @@
|
|||
(prepare dest filename)
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#t (lib ,filename "tests" "mzscheme")))
|
||||
`((#t (lib ,filename "tests" "racket")))
|
||||
null
|
||||
#f
|
||||
`(,(flags "l") ,(string-append "tests/mzscheme/" filename)))
|
||||
`(,(flags "l") ,(string-append "tests/racket/" filename)))
|
||||
(try-exe dest expect mred?)
|
||||
|
||||
;; Try explicit prefix:
|
||||
|
|
@ -116,7 +116,7 @@
|
|||
(prepare dest filename)
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((,pfx (lib ,filename "tests" "mzscheme"))
|
||||
`((,pfx (lib ,filename "tests" "racket"))
|
||||
(#t (lib "scheme/init")))
|
||||
null
|
||||
#f
|
||||
|
|
@ -133,7 +133,7 @@
|
|||
;; Try full path, and use literal S-exp to start
|
||||
(printf ">>>literal sexp\n")
|
||||
(prepare dest filename)
|
||||
(let ([path (build-path (collection-path "tests" "mzscheme") filename)])
|
||||
(let ([path (build-path (collection-path "tests" "racket") filename)])
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#t ,path))
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
;; Use `file' form:
|
||||
(printf ">>>file\n")
|
||||
(prepare dest filename)
|
||||
(let ([path (build-path (collection-path "tests" "mzscheme") filename)])
|
||||
(let ([path (build-path (collection-path "tests" "racket") filename)])
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#t (file ,(path->string path))))
|
||||
|
|
@ -159,7 +159,7 @@
|
|||
;; Use relative path
|
||||
(printf ">>>relative path\n")
|
||||
(prepare dest filename)
|
||||
(parameterize ([current-directory (collection-path "tests" "mzscheme")])
|
||||
(parameterize ([current-directory (collection-path "tests" "racket")])
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#f ,filename))
|
||||
|
|
@ -174,13 +174,13 @@
|
|||
(prepare dest filename)
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#t (lib ,filename "tests" "mzscheme"))
|
||||
(#t (lib "embed-me3.ss" "tests" "mzscheme")))
|
||||
`((#t (lib ,filename "tests" "racket"))
|
||||
(#t (lib "embed-me3.rkt" "tests" "racket")))
|
||||
null
|
||||
(base-compile
|
||||
`(begin
|
||||
(namespace-require '(lib "embed-me3.ss" "tests" "mzscheme"))
|
||||
(namespace-require '(lib ,filename "tests" "mzscheme"))))
|
||||
(namespace-require '(lib "embed-me3.rkt" "tests" "racket"))
|
||||
(namespace-require '(lib ,filename "tests" "racket"))))
|
||||
`(,(flags "")))
|
||||
(try-exe dest (string-append "3 is here, too? #t\n" expect) mred?)
|
||||
|
||||
|
|
@ -195,14 +195,14 @@
|
|||
'(namespace-require ''#%kernel)))))
|
||||
(make-embedding-executable
|
||||
dest mred? #f
|
||||
`((#t (lib ,filename "tests" "mzscheme")))
|
||||
`((#t (lib ,filename "tests" "racket")))
|
||||
(list
|
||||
tmp
|
||||
(build-path (collection-path "tests" "mzscheme") "embed-me4.ss"))
|
||||
(build-path (collection-path "tests" "racket") "embed-me4.rktl"))
|
||||
`(with-output-to-file "stdout"
|
||||
(lambda () (display "... and more!\n"))
|
||||
'append)
|
||||
`(,(flags "l") ,(string-append "tests/mzscheme/" filename)))
|
||||
`(,(flags "l") ,(string-append "tests/racket/" filename)))
|
||||
(delete-file tmp))
|
||||
(try-exe dest (string-append
|
||||
"This is the literal expression 4.\n"
|
||||
|
|
@ -210,12 +210,12 @@
|
|||
expect)
|
||||
mred?)))
|
||||
|
||||
(one-mz-test "embed-me1.ss" "This is 1\n" #t)
|
||||
(one-mz-test "embed-me1b.ss" "This is 1b\n" #f)
|
||||
(one-mz-test "embed-me1c.ss" "This is 1c\n" #f)
|
||||
(one-mz-test "embed-me1d.ss" "This is 1d\n" #f)
|
||||
(one-mz-test "embed-me1e.ss" "This is 1e\n" #f)
|
||||
(one-mz-test "embed-me2.ss" "This is 1\nThis is 2: #t\n" #t)
|
||||
(one-mz-test "embed-me1.rkt" "This is 1\n" #t)
|
||||
(one-mz-test "embed-me1b.rkt" "This is 1b\n" #f)
|
||||
(one-mz-test "embed-me1c.rkt" "This is 1c\n" #f)
|
||||
(one-mz-test "embed-me1d.rkt" "This is 1d\n" #f)
|
||||
(one-mz-test "embed-me1e.rkt" "This is 1e\n" #f)
|
||||
(one-mz-test "embed-me2.rkt" "This is 1\nThis is 2: #t\n" #t)
|
||||
|
||||
;; Try unicode expr and cmdline:
|
||||
(prepare dest "unicode")
|
||||
|
|
@ -238,13 +238,13 @@
|
|||
(mz-tests #t)
|
||||
|
||||
(begin
|
||||
(prepare mr-dest "embed-me5.ss")
|
||||
(prepare mr-dest "embed-me5.rkt")
|
||||
(make-embedding-executable
|
||||
mr-dest #t #f
|
||||
`((#t (lib "embed-me5.ss" "tests" "mzscheme")))
|
||||
`((#t (lib "embed-me5.rkt" "tests" "racket")))
|
||||
null
|
||||
#f
|
||||
`("-l" "tests/mzscheme/embed-me5.ss"))
|
||||
`("-l" "tests/racket/embed-me5.rkt"))
|
||||
(try-exe mr-dest "This is 5: #<class:button%>\n" #t))
|
||||
|
||||
;; Try the mzc interface:
|
||||
|
|
@ -260,15 +260,15 @@
|
|||
(system* mzc
|
||||
(if mred? "--gui-exe" "--exe")
|
||||
(path->string (mk-dest mred?))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me1.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me1.rkt")))
|
||||
(try-exe (mk-dest mred?) "This is 1\n" mred?)
|
||||
|
||||
;; Check that etc.ss isn't found if it's not included:
|
||||
;; Check that etc.rkt isn't found if it's not included:
|
||||
(printf ">>not included\n")
|
||||
(system* mzc
|
||||
(if mred? "--gui-exe" "--exe")
|
||||
(path->string (mk-dest mred?))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
|
||||
(try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?)
|
||||
|
||||
;; And it is found if it is included:
|
||||
|
|
@ -276,8 +276,8 @@
|
|||
(system* mzc
|
||||
(if mred? "--gui-exe" "--exe")
|
||||
(path->string (mk-dest mred?))
|
||||
"++lib" "mzlib/etc.ss"
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
|
||||
"++lib" "mzlib/etc.rkt"
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
|
||||
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
|
||||
|
||||
;; Or, it's found if we set the collection path:
|
||||
|
|
@ -287,7 +287,7 @@
|
|||
(path->string (mk-dest mred?))
|
||||
"--collects-path"
|
||||
(path->string (find-collects-dir))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
|
||||
;; Don't try a distribution for this one:
|
||||
(try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
|
||||
|
||||
|
|
@ -296,10 +296,10 @@
|
|||
(system* mzc
|
||||
(if mred? "--gui-exe" "--exe")
|
||||
(path->string (mk-dest mred?))
|
||||
"++lib" "mzlib/etc.ss"
|
||||
"++lib" "mzlib/etc.rkt"
|
||||
"--collects-dest" "cts"
|
||||
"--collects-path" "cts"
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me6.rkt")))
|
||||
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution
|
||||
(delete-directory/files "cts")
|
||||
(test #f system* (mk-dest mred?))
|
||||
|
|
@ -326,17 +326,17 @@
|
|||
(system-library-subpath)))
|
||||
|
||||
(define ext-file
|
||||
(build-path ext-dir (append-extension-suffix "embed-me8_ss")))
|
||||
(build-path ext-dir (append-extension-suffix "embed-me8_rkt")))
|
||||
|
||||
(define ss-file
|
||||
(build-path (find-system-path 'temp-dir) "embed-me9.ss"))
|
||||
(build-path (find-system-path 'temp-dir) "embed-me9.rkt"))
|
||||
|
||||
(make-directory* ext-dir)
|
||||
|
||||
(system* mzc
|
||||
"--cc"
|
||||
"-d" (path->string (path-only obj-file))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me8.c")))
|
||||
(system* mzc
|
||||
"--ld"
|
||||
(path->string ext-file)
|
||||
|
|
@ -344,7 +344,7 @@
|
|||
|
||||
(when (file-exists? ss-file)
|
||||
(delete-file ss-file))
|
||||
(copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss")
|
||||
(copy-file (build-path (collection-path "tests" "racket") "embed-me9.rkt")
|
||||
ss-file)
|
||||
|
||||
(system* mzc
|
||||
|
|
@ -361,7 +361,7 @@
|
|||
(system* mzc
|
||||
(if mred? "--gui-exe" "--exe")
|
||||
(path->string (mk-dest mred?))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me10.rkt")))
|
||||
(try-exe (mk-dest mred?) "#t\n" mred?)))
|
||||
|
||||
(extension-test #f)
|
||||
|
|
@ -372,7 +372,7 @@
|
|||
(system* mzc
|
||||
"--gui-exe"
|
||||
(path->string (mk-dest #t))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me5.rkt")))
|
||||
(try-exe (mk-dest #t) "This is 5: #<class:button%>\n" #t))
|
||||
|
||||
;; Another GRacket-specific: try embedding plot, which has extra DLLs and font files:
|
||||
|
|
@ -382,34 +382,34 @@
|
|||
(test #t
|
||||
system* (build-path (find-console-bin-dir) "mred")
|
||||
"-qu"
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt"))
|
||||
(path->string direct))
|
||||
|
||||
(system* mzc
|
||||
"--gui-exe"
|
||||
(path->string (mk-dest #t))
|
||||
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")))
|
||||
(path->string (build-path (collection-path "tests" "racket") "embed-me7.rkt")))
|
||||
(try-exe (mk-dest #t) "plotted\n" #t))
|
||||
|
||||
;; Try including source that needs a reader extension
|
||||
|
||||
(define (try-reader-test mred?)
|
||||
(define dest (mk-dest mred?))
|
||||
(define filename "embed-me11.ss")
|
||||
(define filename "embed-me11.rkt")
|
||||
(define (flags s)
|
||||
(string-append "-" s))
|
||||
|
||||
(create-embedding-executable
|
||||
dest
|
||||
#:modules `((#t (lib ,filename "tests" "mzscheme")))
|
||||
#:cmdline `(,(flags "l") ,(string-append "tests/mzscheme/" filename))
|
||||
#:modules `((#t (lib ,filename "tests" "racket")))
|
||||
#:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename))
|
||||
#:src-filter (lambda (f)
|
||||
(let-values ([(base name dir?) (split-path f)])
|
||||
(equal? name (string->path filename))))
|
||||
#:get-extra-imports (lambda (f code)
|
||||
(let-values ([(base name dir?) (split-path f)])
|
||||
(if (equal? name (string->path filename))
|
||||
'((lib "embed-me11-rd.ss" "tests" "mzscheme"))
|
||||
'((lib "embed-me11-rd.rkt" "tests" "racket"))
|
||||
null)))
|
||||
#:mred? mred?)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user