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

Keeping up with trunk.

Browse Source 
svn merge ^/trunk

svn: r18145
This commit is contained in:
Stevie Strickland 2010-02-18 04:34:09 +00:00
commit b18283b626
31 changed files with 1571 additions and 1190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/2htdp/image.ss
View File

@ -76,6 +76,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
circle
ellipse
rectangle
empty-scene
square
rhombus
regular-polygon

5
collects/2htdp/private/image-more.ss
View File

@ -654,6 +654,10 @@
(check-mode/color-combination 'square 3 mode color)
(make-a-polygon (rectangle-points side-length side-length) mode color))
(define/chk (empty-scene width height)
(overlay (rectangle width height 'outline 'black)
(rectangle width height 'solid 'white)))
(define/chk (rhombus side-length angle mode color)
(check-mode/color-combination 'rhombus 3 mode color)
(let* ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
@ -956,6 +960,7 @@
circle
ellipse
rectangle
empty-scene
square
rhombus

9
collects/2htdp/private/img-err.ss
View File

@ -124,12 +124,19 @@
'non-negative-real-number
i arg)
arg]
[(dx dy x1 y1 x2 y2 factor x-factor y-factor pull1 pull2)
[(dx dy x1 y1 x2 y2 pull1 pull2)
(check-arg fn-name
(real? arg)
'real\ number
i arg)
arg]
[(factor x-factor y-factor)
(check-arg fn-name
(and (real? arg)
(positive? arg))
'positive\ real\ number
i arg)
arg]
[(side-count)
(check-arg fn-name
(side-count? arg)

12
collects/2htdp/tests/test-image.ss
View File

@ -630,7 +630,10 @@
(make-bb 100 100 100)
#f))
(test (empty-scene 185 100)
=>
(overlay (rectangle 185 100 'outline 'black)
(rectangle 185 100 'solid 'white)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing normalization
@ -1512,10 +1515,11 @@
(underlay image image)
(underlay/xy image coord coord image)
(crop coord coord size size image)
(scale/xy size size image)
(scale size image)
(scale/xy factor factor image)
(scale factor image)
(rotate angle image))
(factor (+ 1 big-nat) 1/2 1/3 1/4) ;; scaling factors
(size big-nat)
(mode 'outline 'solid "outline" "solid")
(color "red" 'red "blue" "orange" "green" "black")

4
collects/compiler/cm.ss
View File

@ -2,8 +2,8 @@
(require syntax/modcode
syntax/modresolve
setup/main-collects
unstable/file
scheme/file
unstable/file
scheme/list
scheme/path)
@ -140,7 +140,7 @@
(set! ok? #t)))
(lambda ()
(if ok?
(rename-file-or-directory/ignore-exists-exn tmp-path path)
(rename-file-or-directory tmp-path path #t)
(try-delete-file tmp-path))))))
(define (write-deps code mode path external-deps reader-deps)

476
collects/compiler/zo-marshal.ss
View File

@ -1,17 +1,30 @@
#lang scheme/base
(require compiler/zo-parse
scheme/match)
(require compiler/zo-structs
scheme/match
scheme/list
scheme/dict)
(provide zo-marshal)
#| Unresolved Issues
Less sharing occurs than in the C implementation, creating much larger files
encode-all-from-module only handles one case
What is the purpose of protect-quote? It was making it so certain things (like paths) weren't being encoded correctly.
|#
;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compacted, and symbols are not written in short form
(define current-wrapped-ht (make-parameter #f))
(define (zo-marshal top)
(match top
[(struct compilation-top (max-let-depth prefix form))
(let ([encountered (make-hasheq)]
[shared (make-hasheq)])
[shared (make-hasheq)]
[wrapped (make-hasheq)])
(let ([visit (lambda (v)
(if (hash-ref shared v #f)
#f
@ -24,34 +37,37 @@
(when (closure? v)
(hash-set! shared v (add1 (hash-count shared))))
#t))))])
(traverse-prefix prefix visit)
(traverse-form form visit))
(parameterize ([current-wrapped-ht wrapped])
(traverse-prefix prefix visit)
(traverse-form form visit)))
(let* ([s (open-output-bytes)]
[out (make-out s (lambda (v) (hash-ref shared v #f)))]
[out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)]
[offsets
(map (lambda (v)
(let ([v (cdr v)])
(begin0
(file-position s)
(out-anything v (make-out
s
(let ([skip? #t])
(lambda (v2)
(if (and skip? (eq? v v2))
(begin
(set! skip? #f)
#f)
(hash-ref shared v2 #f)))))))))
(file-position s)
(out-anything v (make-out
s
(let ([skip? #t])
(lambda (v2)
(if (and skip? (eq? v v2))
(begin
(set! skip? #f)
#f)
(hash-ref shared v2 #f))))
wrapped)))))
(sort (hash-map shared (lambda (k v) (cons v k)))
<
#:key car))]
[post-shared (file-position s)]
[all-short? (post-shared . < . #xFFFF)])
(out-data (list* max-let-depth prefix (protect-quote form)) out)
(let ([res (get-output-bytes s)])
(let ([res (get-output-bytes s)]
[version-bs (string->bytes/latin-1 (version))])
(bytes-append #"#~"
(bytes (string-length (version)))
(string->bytes/latin-1 (version))
(bytes (bytes-length version-bs))
version-bs
(int->bytes (add1 (hash-count shared)))
(bytes (if all-short?
1
@ -103,8 +119,14 @@
(traverse-data modidx visit)))
(traverse-data sym visit)]))
(define (traverse-stx tl visit)
(error "cannot handle syntax objects, yet"))
(define (traverse-wrapped w visit)
(define ew (hash-ref! (current-wrapped-ht) w (lambda () (encode-wrapped w))))
(traverse-data ew visit))
(define (traverse-stx s visit)
(when s
(traverse-wrapped (stx-encoded s) visit)))
(define (traverse-form form visit)
(match form
@ -166,7 +188,7 @@
(traverse-expr proc visit)
(traverse-expr args-expr visit)]
[(struct seq (exprs))
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)]
(for-each (lambda (expr) (traverse-form expr visit)) exprs)]
[(struct beg0 (exprs))
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)]
[(struct with-cont-mark (key val body))
@ -181,21 +203,31 @@
(define (traverse-data expr visit)
(cond
[(or (symbol? expr)
(keyword? expr)
(string? expr)
(bytes? expr)
(path? expr))
(visit expr)]
[(module-path-index? expr)
(visit expr)
(let-values ([(name base) (module-path-index-split expr)])
(traverse-data name visit)
(traverse-data base visit))]
[(pair? expr)
(traverse-data (car expr) visit)
(traverse-data (cdr expr) visit)]
[else (void)]))
[(or (symbol? expr)
(keyword? expr)
(string? expr)
(bytes? expr)
(path? expr))
(visit expr)]
[(module-path-index? expr)
(visit expr)
(let-values ([(name base) (module-path-index-split expr)])
(traverse-data name visit)
(traverse-data base visit))]
[(pair? expr)
(traverse-data (car expr) visit)
(traverse-data (cdr expr) visit)]
[(vector? expr)
(for ([e (in-vector expr)])
(traverse-data e visit))]
[(box? expr)
(traverse-data (unbox expr) visit)]
[(stx? expr)
(traverse-stx expr visit)]
[(wrapped? expr)
(traverse-wrapped expr visit)]
[else
(void)]))
(define (traverse-lam expr visit)
(match expr
@ -299,7 +331,7 @@
(define CLOS_PRESERVES_MARKS 4)
(define CLOS_IS_METHOD 16)
(define CLOS_SINGLE_RESULT 32)
(define BITS_PER_MZSHORT 32)
(define *dummy* #f)
@ -313,8 +345,7 @@
(define-struct case-seq (name lams))
(define-struct (seq0 seq) ())
(define-struct out (s shared-index))
(define-struct out (s shared-index encoded-wraps))
(define (out-shared v out k)
(let ([v ((out-shared-index out) v)])
(if v
@ -322,6 +353,10 @@
(out-byte CPT_SYMREF out)
(out-number v out))
(k))))
(define (display-byte b)
(if (b . <= . #xf)
(printf "0~x" b)
(printf "~x" b)))
(define (out-byte v out)
(write-byte v (out-s out)))
@ -331,20 +366,20 @@
(define (out-number n out)
(cond
[(n . < . 0)
(if (n . > . -32)
(out-byte (bitwise-ior #xC0 (- n)) out)
(begin
(out-byte #xE0 out)
(out-bytes (int->bytes (- n)) out)))]
[(n . < . 128)
(out-byte n out)]
[(n . < . #x4000)
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
[else
(out-bytes #xF0 out)
(out-bytes (int->bytes n) out)]))
[(n . < . 0)
(if (n . > . -32)
(out-byte (bitwise-ior #xC0 (- n)) out)
(begin
(out-byte #xE0 out)
(out-bytes (int->bytes (- n)) out)))]
[(n . < . 128)
(out-byte n out)]
[(n . < . #x4000)
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
[else
(out-byte #xF0 out)
(out-bytes (int->bytes n) out)]))
(define (out-syntax key val out)
(out-marshaled syntax-type-num (list* key val) out))
@ -356,12 +391,12 @@
(define (out-anything v out)
(cond
[(module-variable? v)
(out-toplevel v out)]
[(closure? v)
(out-expr v out)]
[else
(out-data v out)]))
[(module-variable? v)
(out-toplevel v out)]
[(closure? v)
(out-expr v out)]
[else
(out-data v out)]))
(define (out-prefix a-prefix out)
(match a-prefix
@ -401,7 +436,13 @@
(if (andmap (lambda (x) (equal? x default)) l)
#f
(list->vector l)))]
[l (map cdr other-requires)]
[l
(let loop ([l other-requires])
(match l
[(list)
empty]
[(list-rest (cons phase reqs) rst)
(list* phase reqs (loop rst))]))]
[l (cons (length other-requires) l)]
[l (cons (lookup-req #f) l)] ; dt-requires
[l (cons (lookup-req -1) l)] ; tt-requires
@ -460,18 +501,98 @@
out
(lambda ()
(out-byte CPT_MODULE_VAR out)
(let-values ([(p b) (module-path-index-split modidx)])
(if (symbol? p)
(out-data p out)
(out-data modidx out)))
(out-data modidx out)
(out-data sym out)
(unless (zero? phase)
(out-number -2 out))
(out-number pos out)))]))
(define (out-stx tl out)
(error "cannot handle syntax objects, yet"))
(define (encode-module-bindings module-bindings)
(define encode-nominal-path
(match-lambda
[(struct simple-nominal-path (value))
value]
[(struct imported-nominal-path (value import-phase))
(cons value import-phase)]
[(struct phased-nominal-path (value import-phase phase))
(cons value (cons import-phase phase))]))
(define encoded-bindings (make-vector (* (length module-bindings) 2)))
(for ([i (in-naturals)]
[(k v) (in-dict module-bindings)])
(vector-set! encoded-bindings (* i 2) k)
(vector-set! encoded-bindings (add1 (* i 2))
(match v
[(struct simple-module-binding (path))
path]
[(struct exported-module-binding (path export-name))
(cons path export-name)]
[(struct nominal-module-binding (path nominal-path))
(cons path (encode-nominal-path nominal-path))]
[(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name))
(list* path export-name (encode-nominal-path nominal-path) nominal-export-name)]
[(struct phased-module-binding (path phase export-name nominal-path nominal-export-name))
(list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)])))
encoded-bindings)
(define (encode-all-from-module all)
(match all
[(struct all-from-module (path phase src-phase exceptions prefix))
(list* path phase src-phase)]))
(define (encode-wraps wraps)
(for/list ([wrap (in-list wraps)])
(match wrap
[(struct phase-shift (amt src dest))
(box (vector amt src dest #f))]
[(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define encoded-kind (eq? kind 'marked))
(define encoded-unmarshals (map encode-all-from-module unmarshals))
(define encoded-renames (encode-module-bindings renames))
(define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals)
(values encoded-renames mark-renames)
(values encoded-unmarshals (cons encoded-renames mark-renames))))
(define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames))
(if plus-kern?
(cons #t mod-rename)
mod-rename)]
[(struct lexical-rename (bool1 bool2 alist))
(define len (length alist))
(define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning
(vector-set! vec 0 bool1)
(vector-set! vec 1 bool2)
(for ([(k v) (in-dict alist)]
[i (in-naturals)])
(vector-set! vec (+ 2 i) k)
(vector-set! vec (+ 2 i len) v))
vec]
[(struct prune (syms))
(box syms)]
[(struct wrap-mark (val))
(list val)])))
(define (encode-wrapped w)
(match w
[(struct wrapped (datum wraps certs))
(vector
(cons
datum
(encode-wraps wraps))
certs)]))
(define (lookup-encoded-wrapped w out)
(hash-ref (out-encoded-wraps out) w))
(define (out-wrapped w out)
(out-data (lookup-encoded-wrapped w out) out))
(define (out-stx s out)
(out-shared s out
(lambda ()
(match s
[(struct stx (encoded))
(out-byte CPT_STX out)
(out-wrapped encoded out)]))))
(define (out-form form out)
(match form
[(? mod?)
@ -648,7 +769,7 @@
out)]
[else (out-value expr out)]))
(define (out-lam expr out)
(define (out-lam expr out)
(match expr
[(struct indirect (val)) (out-lam val out)]
[(struct closure (lam gen-id))
@ -704,122 +825,143 @@
l)
out))]))
(define (out-as-bytes expr ->bytes CPT len2 out)
(define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f])
(out-shared expr out (lambda ()
(let ([s (->bytes expr)])
(out-byte CPT out)
(when before-length
(out-number before-length out))
(out-number (bytes-length s) out)
(when len2 (out-number len2 out))
(out-bytes s out)))))
(define (out-data expr out)
(cond
[(prefix? expr) (out-prefix expr out)]
[(global-bucket? expr) (out-toplevel expr out)]
[(module-variable? expr) (out-toplevel expr out)]
[else (out-form expr out)]))
[(prefix? expr) (out-prefix expr out)]
[(global-bucket? expr) (out-toplevel expr out)]
[(module-variable? expr) (out-toplevel expr out)]
[else (out-form expr out)]))
(define (out-value expr out)
(cond
[(symbol? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 symbol->string)
CPT_SYMBOL
#f
out)]
[(keyword? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 keyword->string)
CPT_KEYWORD
#f
out)]
[(string? expr)
(out-as-bytes expr
string->bytes/utf-8
CPT_CHAR_STRING
(string-length expr)
out)]
[(bytes? expr)
(out-as-bytes expr
values
CPT_BYTE_STRING
#f
out)]
[(path? expr)
(out-as-bytes expr
path->bytes
CPT_PATH
#f
out)]
[(char? expr)
(out-byte CPT_CHAR out)
(out-number (char->integer expr) out)]
[(and (exact-integer? expr)
(and (expr . >= . -1073741824) (expr . <= . 1073741823)))
(out-byte CPT_INT out)
(out-number expr out)]
[(null? expr)
(out-byte CPT_NULL out)]
[(eq? expr #t)
(out-byte CPT_TRUE out)]
[(eq? expr #f)
(out-byte CPT_FALSE out)]
[(void? expr)
(out-byte CPT_VOID out)]
[(box? expr)
(out-byte CPT_BOX out)
(out-data (unbox expr) out)]
[(pair? expr)
(out-byte CPT_LIST out)
(out-number 1 out)
(out-data (car expr) out)
(out-data (cdr expr) out)]
[(vector? expr)
(out-byte CPT_VECTOR out)
(out-number (vector-length expr) out)
(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]))
(for ([(k v) (in-hash expr)])
(out-data k out)
(out-data v out))]
[(svector? expr)
(out-byte CPT_SVECTOR out)
(out-number (vector-length (svector-vec expr)) out)
(let ([vec (svector-vec expr)])
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
(out-number (vector-ref vec n) out)))]
[(module-path-index? expr)
(out-shared expr out
(lambda ()
(out-byte CPT_MODULE_INDEX out)
(let-values ([(name base) (module-path-index-split expr)])
(out-data name out)
(out-data base out))))]
[(module-decl? expr)
(out-marshaled module-type-num
(module-decl-content expr)
[(and (symbol? expr) (not (symbol-interned? expr)))
(out-as-bytes expr
#:before-length (if (symbol-unreadable? expr) 0 1)
(compose string->bytes/utf-8 symbol->string)
CPT_WEIRD_SYMBOL
#f
out)]
[(symbol? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 symbol->string)
CPT_SYMBOL
#f
out)]
[else
(out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)])
(write (if (quoted? expr) (quoted-v expr) expr) s)
(out-byte CPT_ESCAPE out)
(let ([bstr (get-output-bytes s)])
(out-number (bytes-length bstr) out)
(out-bytes bstr out)))]))
[(keyword? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 keyword->string)
CPT_KEYWORD
#f
out)]
[(string? expr)
(out-as-bytes expr
string->bytes/utf-8
CPT_CHAR_STRING
(string-length expr)
out)]
[(bytes? expr)
(out-as-bytes expr
values
CPT_BYTE_STRING
#f
out)]
[(path? expr)
(out-as-bytes expr
path->bytes
CPT_PATH
#f
out)]
[(char? expr)
(out-byte CPT_CHAR out)
(out-number (char->integer expr) out)]
[(and (exact-integer? expr)
(and (expr . >= . -1073741824) (expr . <= . 1073741823)))
(out-byte CPT_INT out)
(out-number expr out)]
[(null? expr)
(out-byte CPT_NULL out)]
[(eq? expr #t)
(out-byte CPT_TRUE out)]
[(eq? expr #f)
(out-byte CPT_FALSE out)]
[(void? expr)
(out-byte CPT_VOID out)]
[(box? expr)
(out-byte CPT_BOX out)
(out-data (unbox expr) out)]
[(pair? expr)
(out-byte CPT_LIST out)
(out-number 1 out)
(out-data (car expr) out)
(out-data (cdr expr) out)]
[(vector? expr)
(out-byte CPT_VECTOR out)
(out-number (vector-length expr) out)
(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))]
[(svector? expr)
(out-byte CPT_SVECTOR out)
(out-number (vector-length (svector-vec expr)) out)
(let ([vec (svector-vec expr)])
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
(out-number (vector-ref vec n) out)))]
[(module-path-index? expr)
(out-shared expr out
(lambda ()
(out-byte CPT_MODULE_INDEX out)
(let-values ([(name base) (module-path-index-split expr)])
(out-data name out)
(out-data base out))))]
[(module-decl? expr)
(out-marshaled module-type-num
(module-decl-content expr)
out)]
[(stx? expr)
(out-stx expr out)]
[(wrapped? expr)
(out-wrapped expr out)]
[else
(out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)])
(write (if (quoted? expr)
(quoted-v expr)
expr) s)
(out-byte CPT_ESCAPE out)
(let ([bstr (get-output-bytes s)])
(out-number (bytes-length bstr) out)
(out-bytes bstr out)))]))
(define-struct quoted (v) #:prefab)
(define-struct quoted (v))
(define (protect-quote v)
(if (or (list? v) (vector? v) (box? v) (hash? v))
v
#;(if (or (list? v) (vector? v) (box? v) (hash? v))
(make-quoted v)
v))
(define-struct svector (vec))
;; ----------------------------------------

597
collects/compiler/zo-parse.ss
View File

@ -1,83 +1,33 @@
#lang scheme/base
(require mzlib/etc
scheme/match
scheme/list)
scheme/list
compiler/zo-structs)
(provide zo-parse)
(provide (all-from-out compiler/zo-structs))
;; ----------------------------------------
;; Structures to represent bytecode
#| Unresolved Issues
(define-syntax-rule (define-form-struct* id id+par (field-id ...))
(begin
(define-struct id+par (field-id ...) #:transparent)
(provide (struct-out id))))
The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay?
orig-port of cport struct is never used, is it needed?
(define-syntax define-form-struct
(syntax-rules ()
[(_ (id sup) . rest)
(define-form-struct* id (id sup) . rest)]
[(_ id . rest)
(define-form-struct* id id . rest)]))
Lines 628, 630 seem to be only for debugging and should probably throw errors
(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
unmarshal-stx-get also seems to be for debugging and should probably throw an error
(define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
;; In toplevels of resove prefix:
(define-form-struct global-bucket (name)) ; top-level binding
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
Line 816: This should be an eqv placeholder (but they don't exist)
;; In stxs of prefix:
(define-form-struct stx (encoded))
Line 634: Export registry is always matched as false, but might not be
(define-form-struct form ())
(define-form-struct (expr form) ())
What are the real differences between the module-binding cases?
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context))
(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) ; `lambda'
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
(define-form-struct (let-one expr) (rhs body flonum?)) ; pushes one value onto stack
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
(define-form-struct (localref expr) (unbox? pos clear? other-clears? flonum?)) ; access local via stack
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
(define-form-struct (application expr) (rator rands)) ; function call
(define-form-struct (branch expr) (test then else)) ; `if'
(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark'
(define-form-struct (beg0 expr) (seq)) ; `begin0'
(define-form-struct (seq form) (forms)) ; `begin'
(define-form-struct (splice form) (forms)) ; top-level `begin'
(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference'
(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set!
(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive
;; Definitions (top level or within module):
(define-form-struct (def-values form) (ids rhs))
(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth))
(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth))
;; Top-level `require'
(define-form-struct (req form) (reqs dummy))
;; A static closure can refer directly to itself, creating a cycle
(define-struct indirect ([v #:mutable]) #:prefab)
(provide (struct-out indirect))
;; A provided identifier
(define-form-struct provided (name src src-name nom-src src-phase protected? insp))
I think parse-module-path-index was only used for debugging, so it is short-circuited now
|#
;; ----------------------------------------
;; Bytecode unmarshalers for various forms
@ -236,14 +186,24 @@
(define (read-splice v)
(make-splice (seq-forms v)))
(define (in-list* l n)
(make-do-sequence
(lambda ()
(values (lambda (l) (apply values (take l n)))
(lambda (l) (drop l n))
l
(lambda (l) (>= (length l) n))
(lambda _ #t)
(lambda _ #t)))))
(define (read-module v)
(match v
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy
,prefix
,indirect-provides ,num-indirect-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-et-provides ,num-indirect-et-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-provides ,num-indirect-provides
,protects ,et-protects
,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 9 provide-phase-count))])
@ -288,15 +248,18 @@
(cons 1 syntax-requires)
(cons -1 template-requires)
(cons #f label-requires)
more-requires)
(for/list ([(phase reqs) (in-list* more-requires 2)])
(cons phase reqs)))
(vector->list body)
(map (lambda (sb)
(match sb
[(? def-syntaxes?) sb]
[(? def-for-syntax?) sb]
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
((if for-stx?
make-def-for-syntax
make-def-syntaxes)
ids expr prefix max-let-depth)]))
(if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
(vector->list syntax-body))
(list (vector->list indirect-provides)
(vector->list indirect-syntax-provides)
@ -383,14 +346,17 @@
(let loop ([so so])
(if (zero? (bytes-length so))
null
(cons (integer-bytes->integer (subbytes so 0 n) #f)
(cons (integer-bytes->integer (subbytes so 0 n) #f #f)
(loop (subbytes so n))))))
(define (read-simple-number p)
;; not sure if it's really unsigned
(integer-bytes->integer (read-bytes 4 p) #f #f))
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis))
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis))
(define (cport-rpos cp)
(+ (cport-pos cp) (cport-shared-start cp)))
(define (cp-getc cp)
(begin-with-definitions
@ -453,17 +419,17 @@
(define (cpt-table-lookup i)
(for/or ([ent cpt-table])
(match ent
[(list k sym) (and (= k i) (cons k sym))]
[(list k k* sym)
(and (<= k i)
(< i k*)
(cons k sym))])))
(match ent
[(list k sym) (and (= k i) (cons k sym))]
[(list k k* sym)
(and (<= k i)
(< i k*)
(cons k sym))])))
(define (read-compact-bytes port c)
(begin0
(subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c))
(set-cport-pos! port (+ c (cport-pos port)))))
(subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c))
(set-cport-pos! port (+ c (cport-pos port)))))
(define (read-compact-chars port c)
(bytes->string/utf-8 (read-compact-bytes port c)))
@ -516,18 +482,7 @@
(define-struct not-ready ())
;; ----------------------------------------
;; Synatx unmarshaling
(define-form-struct wrapped (datum wraps certs))
(define-form-struct wrap ())
(define-form-struct (lexical-rename wrap) (alist))
(define-form-struct (phase-shift wrap) (amt src dest))
(define-form-struct (prune wrap) (sym))
(define-form-struct (module-rename wrap) (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define-form-struct all-from-module (path phase src-phase exceptions prefix))
(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id))
;; Syntax unmarshaling
(define (decode-stx cp v)
(if (integer? v)
@ -546,52 +501,55 @@
(let* ([wraps (decode-wraps cp encoded-wraps)]
[add-wrap (lambda (v) (make-wrapped v wraps cert-marks))])
(cond
[(pair? v)
(if (eq? #t (car v))
;; Share decoded wraps with all nested parts.
(let loop ([v (cdr v)])
(cond
[(pair? v)
(let ploop ([v v])
[(pair? v)
(if (eq? #t (car v))
;; Share decoded wraps with all nested parts.
(let loop ([v (cdr v)])
(cond
[(pair? v)
(let ploop ([v v])
(cond
[(null? v) null]
[(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
[else (loop v)]))]
[(box? v) (add-wrap (box (loop (unbox v))))]
[(vector? v)
(add-wrap (list->vector (map loop (vector->list v))))]
[(prefab-struct-key v)
=> (lambda (k)
(add-wrap
(apply
make-prefab-struct
k
(map loop (cdr (vector->list (struct->vector v)))))))]
[else (add-wrap v)]))
;; Decode sub-elements that have their own wraps:
(let-values ([(v counter) (if (exact-integer? (car v))
(values (cdr v) (car v))
(values v -1))])
(add-wrap
(let ploop ([v v][counter counter])
(cond
[(null? v) null]
[(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
[else (loop v)]))]
[(box? v) (add-wrap (box (loop (unbox v))))]
[(vector? v)
(add-wrap (list->vector (map loop (vector->list v))))]
[(prefab-struct-key v)
=> (lambda (k)
(add-wrap
(apply
make-prefab-struct
k
(map loop (cdr (vector->list (struct->vector v)))))))]
[else (add-wrap v)]))
;; Decode sub-elements that have their own wraps:
(let-values ([(v counter) (if (exact-integer? (car v))
(values (cdr v) (car v))
(values v -1))])
[(null? v) null]
[(or (not (pair? v)) (zero? counter)) (loop v)]
[(pair? v) (cons (loop (car v))
(ploop (cdr v) (sub1 counter)))])))))]
[(box? v) (add-wrap (box (loop (unbox v))))]
[(vector? v)
(add-wrap (list->vector (map loop (vector->list v))))]
[(prefab-struct-key v)
=> (lambda (k)
(add-wrap
(let ploop ([v v][counter counter])
(cond
[(null? v) null]
[(or (not (pair? v)) (zero? counter)) (loop v)]
[(pair? v) (cons (loop (car v))
(ploop (cdr v) (sub1 counter)))])))))]
[(box? v) (add-wrap (box (loop (unbox v))))]
[(vector? v)
(add-wrap (list->vector (map loop (vector->list v))))]
[(prefab-struct-key v)
=> (lambda (k)
(add-wrap
(apply
make-prefab-struct
k
(map loop (cdr (vector->list (struct->vector v)))))))]
[else (add-wrap v)]))))))
(apply
make-prefab-struct
k
(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?
@ -601,124 +559,131 @@
w2)))
(map (lambda (a)
(let aloop ([a a])
; A wrap-elem is either
(cond
[(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)))]
[(and (pair? a) (null? (cdr a)) (number? (car a)))
;; a mark
(string->symbol (format "mark~a" (car a)))]
[(vector? a)
(make-lexical-rename
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
(let loop ([i 2])
(if (= i top)
null
(cons (cons (vector-ref a i)
(vector-ref a (+ (- top 2) i)))
(loop (+ i 1)))))))]
[(pair? a)
(let-values ([(plus-kern? a) (if (eq? (car a) #t)
(values #t (cdr a))
(values #f a))])
(match a
[`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
(let-values ([(unmarshals renames mark-renames)
(if (vector? maybe-unmarshals)
(values null maybe-unmarshals renames)
(values maybe-unmarshals
(car renames)
(cdr renames)))])
(make-module-rename phase
(if kind 'marked 'normal)
set-id
(map (lambda (u)
(let ([just-phase? (let ([v (cddr u)])
(or (number? v) (not v)))])
(let-values ([(exns prefix)
(if just-phase?
(values null #f)
(let loop ([u (if just-phase? null (cdddr u))]
[a null])
(if (pair? u)
(loop (cdr u) (cons (car u) a))
(values (reverse a) u))))])
(make-all-from-module
(parse-module-path-index cp (car u))
(cadr u)
(if just-phase?
(cddr u)
(caddr u))
exns
prefix))))
unmarshals)
(let loop ([i 0])
(if (= i (vector-length renames))
null
(cons
(let ([key (vector-ref renames i)]
[make-mapping
(lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id)
(make-module-binding
(parse-module-path-index cp path)
mod-phase
import-phase
id
(parse-module-path-index cp nominal-path)
nominal-phase
(if (eq? id nominal-id) #t nominal-id)))])
(cons key
(let ([m (vector-ref renames (add1 i))]
[parse-nominal-modidx-plus-phase
(lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname)
(match nominal-modidx-plus-phase
[`(,nominal-modidx ,import-phase-plus-nominal-phase)
(match import-phase-plus-nominal-phase
[`(,import-phase ,nom-phase)
(make-mapping modidx mod-phase import-phase exportname
nominal-modidx nom-phase nom-exportname)]
[import-phase
(make-mapping modidx mod-phase import-phase exportname
modidx mod-phase nom-exportname)])]
[nominal-modidx
(make-mapping modidx mod-phase '* exportname
nominal-modidx mod-phase nom-exportname)]))])
(match m
[`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
(parse-nominal-modidx-plus-phase modidx mod-phase exportname
nominal-modidx-plus-phase nominal-exportname)]
[`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
(parse-nominal-modidx-plus-phase modidx '* exportname
nominal-modidx-plus-phase nominal-exportname)]
[`(,modidx ,nominal-modidx)
(make-mapping modidx '* '* key nominal-modidx '* key)]
[`(,modidx ,exportname)
(make-mapping modidx '* '* exportname modidx '* exportname)]
[modidx
(make-mapping modidx '* '* key modidx '* key)]))))
(loop (+ i 2)))))
mark-renames
(and plus-kern? 'plus-kern)))]
[else (error "bad module rename: ~e" a)]))]
[(boolean? a)
`(#%top-level-rename ,a)]
[(symbol? a)
'(#%mark-barrier)]
[(box? a)
(match (unbox a)
[(list (? symbol?) ...) (make-prune (unbox a))]
[`#(,amt ,src ,dest #f)
(make-phase-shift amt
(parse-module-path-index cp src)
(parse-module-path-index cp dest))]
[else (error 'parse "bad phase shift: ~e" a)])]
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
; 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)))]
; 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))]
[(vector? a)
(make-lexical-rename (vector-ref a 0) (vector-ref a 1)
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
(let loop ([i 2])
(if (= i top)
null
(cons (cons (vector-ref a i)
(vector-ref a (+ (- top 2) i)))
(loop (+ i 1)))))))]
[(pair? a)
(let-values ([(plus-kern? a) (if (eq? (car a) #t)
(values #t (cdr a))
(values #f a))])
(match a
[`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
(let-values ([(unmarshals renames mark-renames)
(if (vector? maybe-unmarshals)
(values null maybe-unmarshals renames)
(values maybe-unmarshals
(car renames)
(cdr renames)))])
(make-module-rename phase
(if kind 'marked 'normal)
set-id
(let ([results (map (lambda (u)
(let ([just-phase? (let ([v (cddr u)])
(or (number? v) (not v)))])
(let-values ([(exns prefix)
(if just-phase?
(values null #f)
(let loop ([u (if just-phase? null (cdddr u))]
[a null])
(if (pair? u)
(loop (cdr u) (cons (car u) a))
(values (reverse a) u))))])
(make-all-from-module
(parse-module-path-index cp (car u))
(cadr u)
(if just-phase?
(cddr u)
(caddr u))
exns
prefix))))
unmarshals)])
#;(printf "~nunmarshals: ~S~n" unmarshals)
#;(printf "~nunmarshal results: ~S~n" results)
results)
(decode-renames renames)
mark-renames
(and plus-kern? 'plus-kern)))]
[else (error "bad module rename: ~e" a)]))]
[(boolean? a)
`(#%top-level-rename ,a)]
[(symbol? a)
'(#%mark-barrier)]
[(box? a)
(match (unbox a)
[(list (? symbol?) ...) (make-prune (unbox a))]
[`#(,amt ,src ,dest #f)
(make-phase-shift amt
(parse-module-path-index cp src)
(parse-module-path-index cp dest))]
[else (error 'parse "bad phase shift: ~e" a)])]
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
w)))
(define (in-vector* v n)
(make-do-sequence
(λ ()
(values (λ (i) (vector->values v i (+ i n)))
(λ (i) (+ i n))
0
(λ (i) (>= (vector-length v) (+ i n)))
(λ _ #t)
(λ _ #t)))))
(define (decode-renames renames)
(define decode-nominal-path
(match-lambda
[(cons nominal-path (cons import-phase nominal-phase))
(make-phased-nominal-path nominal-path import-phase nominal-phase)]
[(cons nominal-path import-phase)
(make-imported-nominal-path nominal-path import-phase)]
[nominal-path
(make-simple-nominal-path nominal-path)]))
; XXX Matthew, I'm ashamed
(define (nom_mod_p p)
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
(for/list ([(k v) (in-vector* renames 2)])
(cons k
(match v
[(list-rest path phase export-name nominal-path nominal-export-name)
(make-phased-module-binding path
phase
export-name
(decode-nominal-path nominal-path)
nominal-export-name)]
[(list-rest path export-name nominal-path nominal-export-name)
(make-exported-nominal-module-binding path
export-name
(decode-nominal-path nominal-path)
nominal-export-name)]
[(cons module-path-index (? nom_mod_p nominal-path))
(make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))]
[(cons module-path-index export-name)
(make-exported-module-binding module-path-index export-name)]
[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)
@ -737,19 +702,7 @@
(vector-set! (cport-decoded cp) pos #t))
(define (parse-module-path-index cp s)
(cond
[(not s) #f]
[(module-path-index? s)
(hash-ref (cport-mpis cp) s
(lambda ()
(let-values ([(name base) (module-path-index-split s)])
(let ([v `(module-path-index-join
(quote ,name)
,(parse-module-path-index cp base))])
(hash-set! (cport-mpis cp) s v)
v))))]
[else `(quote ,s)]))
s)
;; ----------------------------------------
;; Main parsing loop
@ -813,8 +766,8 @@
[pos (read-compact-number cp)])
(let-values ([(mod-phase pos)
(if (= pos -2)
(values 1 (read-compact-number cp))
(values 0 pos))])
(values 1 (read-compact-number cp))
(values 0 pos))])
(make-module-variable mod var pos mod-phase)))]
[(local-unbox)
(let* ([p* (read-compact-number cp)]
@ -857,9 +810,10 @@
[(hash-table)
(let ([eq (read-compact-number cp)]
[len (read-compact-number cp)])
((if (zero? eq)
make-hash-placeholder
make-hasheq-placeholder)
((case eq
[(0) make-hasheq-placeholder]
[(1) make-hash-placeholder]
[(2) make-hash-placeholder])
(for/list ([i (in-range len)])
(cons (read-compact cp)
(read-compact cp)))))]
@ -919,12 +873,15 @@
(set-cport-pos! cp pos)
(vector-set! (cport-symtab cp) l v)
v))
v))]
v))]
[(weird-symbol)
(let ([u (read-compact-number cp)]
(let ([uninterned (read-compact-number cp)]
[str (read-compact-chars cp (read-compact-number cp))])
;; FIXME: no way to construct quasi-interned symbols:
(string->uninterned-symbol str))]
(if (= 1 uninterned)
; uninterned is equivalent to weird in the C implementation
(string->uninterned-symbol str)
; unreadable is equivalent to parallel in the C implementation
(string->unreadable-symbol str)))]
[(small-marshalled)
(read-marshalled (- ch cpt-start) cp)]
[(small-application2)
@ -952,9 +909,9 @@
[cl (make-closure v (gensym
(let ([s (lam-name v)])
(cond
[(symbol? s) s]
[(vector? s) (vector-ref s 0)]
[else 'closure]))))])
[(symbol? s) s]
[(vector? s) (vector-ref s 0)]
[else 'closure]))))])
(set-indirect-v! ind cl)
ind))]
[(svector)
@ -973,49 +930,49 @@
;; implementes read.c:read_compiled
(define (zo-parse port)
(begin-with-definitions
;; skip the "#~"
(unless (equal? #"#~" (read-bytes 2 port))
(error 'zo-parse "not a bytecode stream"))
(define version (read-bytes (min 63 (read-byte port)) port))
(define symtabsize (read-simple-number port))
(define all-short (read-byte port))
(define cnt (* (if (not (zero? all-short)) 2 4)
(sub1 symtabsize)))
(define so (read-bytes cnt port))
(define so* (list->vector (split-so all-short so)))
(define shared-size (read-simple-number port))
(define size* (read-simple-number port))
(when (shared-size . >= . size*)
(error 'bad-read))
(define rst (read-bytes size* port))
(unless (eof-object? (read-byte port))
(error 'not-end))
(unless (= size* (bytes-length rst))
(error "wrong number of bytes"))
(define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)])
(when (not-ready? (vector-ref symtab i))
(set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)])
(vector-set! symtab i v))))
(set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp)))
;; skip the "#~"
(unless (equal? #"#~" (read-bytes 2 port))
(error 'zo-parse "not a bytecode stream"))
(define version (read-bytes (min 63 (read-byte port)) port))
(define symtabsize (read-simple-number port))
(define all-short (read-byte port))
(define cnt (* (if (not (zero? all-short)) 2 4)
(sub1 symtabsize)))
(define so (read-bytes cnt port))
(define so* (list->vector (split-so all-short so)))
(define shared-size (read-simple-number port))
(define size* (read-simple-number port))
(when (shared-size . >= . size*)
(error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)"))
(define rst (read-bytes size* port))
(unless (eof-object? (read-byte port))
(error 'not-end))
(unless (= size* (bytes-length rst))
(error "wrong number of bytes"))
(define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 shared-size port size* rst 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))))
(set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp)))
;; ----------------------------------------
@ -1028,12 +985,12 @@
(compile sexp))
s)
(get-output-bytes s))
(define (compile/parse sexp)
(let* ([bs (compile/write sexp)]
[p (open-input-bytes bs)])
(zo-parse p)))
#;(compile/parse #s(foo 10 13))
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo"))
)
)

201
collects/compiler/zo-structs.ss Normal file
View File

@ -0,0 +1,201 @@
#lang scheme/base
(require mzlib/etc
scheme/match
scheme/contract
scheme/list)
#| Unresolved issues
what are the booleans in lexical-rename?
contracts that are probably too generous:
prefix-stxs
provided-nom-src
lam-num-params
lexical-rename-alist
all-from-module
|#
;; ----------------------------------------
;; Structures to represent bytecode
(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...))
(begin
(define-struct id+par (field-id ...) #:transparent)
(provide/contract
[struct id ([field-id field-contract] ...)])))
(define-syntax define-form-struct
(syntax-rules ()
[(_ (id sup) . rest)
(define-form-struct* id (id sup) . rest)]
[(_ id . rest)
(define-form-struct* id id . rest)]))
;; In toplevels of resove prefix:
(define-form-struct global-bucket ([name symbol?])) ; top-level binding
(define-form-struct module-variable ([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase (or/c 0 1)])) ; direct access to exported id
;; Syntax object
(define-form-struct wrap ())
(define-form-struct wrapped ([datum any/c]
[wraps (listof wrap?)]
[certs (or/c list? #f)]))
;; In stxs of prefix:
(define-form-struct stx ([encoded wrapped?]))
(define-form-struct prefix ([num-lifts exact-nonnegative-integer?]
[toplevels (listof (or/c #f symbol? global-bucket? module-variable?))]
[stxs list?])) ; should be (listof stx?) sets up top-level and syntax-object array
(define-form-struct form ())
(define-form-struct (expr form) ())
;; A static closure can refer directly to itself, creating a cycle
(define-struct indirect ([v #:mutable]) #:transparent)
(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
;; A provided identifier
(define-form-struct provided ([name symbol?]
[src (or/c module-path-index? #f)]
[src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)]
[protected? boolean?]
[insp (or/c boolean? void?)]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
[pos exact-nonnegative-integer?]
[const? boolean?]
[ready? boolean?])) ; access binding via prefix array (which is on stack)
(define-form-struct (seq form) ([forms (listof (or/c form? indirect? any/c))])) ; `begin'
;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
[rhs (or/c expr? seq? indirect? any/c)]))
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
[rhs (or/c expr? seq? indirect? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
[rhs (or/c expr? seq? indirect? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
(define-form-struct (mod form) ([name symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof (list/c (or/c exact-integer? #f)
(listof provided?)
(listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? indirect? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))]
[unexported (list/c (listof symbol?) (listof symbol?)
(listof symbol?))]
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t stx?)]))
(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result))]
[num-params integer?] ; should be exact-nonnegative-integer?
[param-types (listof (or/c 'val 'ref 'flonum))]
[rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum))]
[max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? indirect? any/c)])) ; `lambda'
(define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect)
(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?])) ; pushes one value onto stack
(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots
(define-form-struct (install-value expr) ([count exact-nonnegative-integer?]
[pos exact-nonnegative-integer?]
[boxes? boolean?]
[rhs (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])) ; set existing stack slot(s)
(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? indirect? any/c)])) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? indirect? any/c)])) ; box existing stack element
(define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack
(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack)
(define-form-struct (application expr) ([rator (or/c expr? seq? indirect? any/c)] [rands (listof (or/c expr? seq? indirect? any/c))])) ; function call
(define-form-struct (branch expr) ([test (or/c expr? seq? indirect? any/c)] [then (or/c expr? seq? indirect? any/c)] [else (or/c expr? seq? indirect? any/c)])) ; `if'
(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)]
[val (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])) ; `with-continuation-mark'
(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])) ; `begin0'
(define-form-struct (splice form) ([forms (listof (or/c form? indirect? any/c))])) ; top-level `begin'
(define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference'
(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? indirect? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
(define-form-struct (apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] [args-expr (or/c expr? seq? indirect? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive
;; Top-level `require'
(define-form-struct (req form) ([reqs syntax?] [dummy toplevel?]))
(define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name
[bool2 boolean?] ; this needs a name
[alist any/c])) ; should be (listof (cons/c symbol? symbol?))
(define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)]))
(define-form-struct (wrap-mark wrap) ([val exact-integer?]))
(define-form-struct (prune wrap) ([sym any/c]))
(define-form-struct all-from-module ([path module-path-index?]
[phase (or/c exact-integer? #f)]
[src-phase any/c] ; should be (or/c exact-integer? #f)
[exceptions list?] ; should be (listof symbol?)
[prefix any/c])) ; should be (or/c symbol? #f)
(define-form-struct nominal-path ())
(define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?]))
(define-form-struct (imported-nominal-path nominal-path) ([value module-path-index?]
[import-phase exact-integer?]))
(define-form-struct (phased-nominal-path nominal-path) ([value module-path-index?]
[import-phase exact-integer?]
[phase exact-integer?]))
(define-form-struct module-binding ())
(define-form-struct (phased-module-binding module-binding) ([path module-path-index?]
[phase exact-integer?]
[export-name any/c]
[nominal-path nominal-path?]
[nominal-export-name any/c]))
(define-form-struct (exported-nominal-module-binding module-binding) ([path module-path-index?]
[export-name any/c]
[nominal-path nominal-path?]
[nominal-export-name any/c]))
(define-form-struct (nominal-module-binding module-binding) ([path module-path-index?]
[nominal-path nominal-path?]))
(define-form-struct (exported-module-binding module-binding) ([path module-path-index?]
[export-name any/c]))
(define-form-struct (simple-module-binding module-binding) ([path module-path-index?]))
(define-form-struct (module-rename wrap) ([phase (or/c exact-integer? #f)]
[kind (or/c 'marked 'normal)]
[set-id any/c]
[unmarshals (listof all-from-module?)]
[renames (listof (cons/c symbol? module-binding?))]
[mark-renames any/c]
[plus-kern? boolean?]))
(provide/contract (struct indirect ([v (or/c closure? #f)])))

4
collects/drscheme/private/language-configuration.ss
View File

@ -745,6 +745,7 @@
module-language*language)
(module-language-selected)]
[else
(send languages-hier-list focus) ;; only focus when the module language isn't selected
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(let ([language-position (send language-to-show get-language-position)])
@ -893,6 +894,8 @@
(send languages-hier-list stretchable-width #t)
(send languages-hier-list stretchable-height #t)
(send languages-hier-list accept-tab-focus #t)
(send languages-hier-list allow-tab-exit #t)
(send parent reflow-container)
(close-all-languages)
(open-current-language)
@ -903,7 +906,6 @@
(when details-shown?
(do-construct-details))
(update-show/hide-details)
(send languages-hier-list focus)
(size-discussion-canvas in-source-discussion-editor-canvas)
(values
(λ () selected-language)

48
collects/drscheme/private/module-language.ss
View File

@ -60,24 +60,36 @@
(inherit get-language-name)
(define/public (get-users-language-name defs-text)
(let ([defs-port (open-input-text-editor defs-text)])
(with-handlers ((exn:fail? (λ (x) (void))))
(let/ec k
(let ([orig-security (current-security-guard)])
(parameterize ([current-security-guard
(make-security-guard
orig-security
(lambda (what path modes) #t)
(lambda (what host port mode) (k (void))))])
(read-language defs-port (λ () (void)))
(void)))))
(let* ([str (send defs-text get-text 0 (file-position defs-port))]
[pos (regexp-match-positions #rx"#(?:!|lang )" str)])
(cond
[(not pos)
(get-language-name)]
[else
(substring str (cdr (car pos)) (string-length str))]))))
(let* ([defs-port (open-input-text-editor defs-text)]
[read-successfully?
(with-handlers ((exn:fail? (λ (x) #f)))
(let/ec k
(let ([orig-security (current-security-guard)])
(parameterize ([current-security-guard
(make-security-guard
orig-security
(lambda (what path modes) #t)
(lambda (what host port mode) (k #f)))])
(read-language defs-port (λ () (void)))
#t))))])
(cond
[read-successfully?
(let* ([str (send defs-text get-text 0 (file-position defs-port))]
[pos (regexp-match-positions #rx"#(?:!|lang )" str)])
(cond
[(not pos)
(get-language-name)]
[else
;; newlines can break things (ie the language text won't
;; be in the right place in the interactions window, which
;; at least makes the test suites unhappy), so get rid of
;; them from the name. Otherwise, if there is some wierd formatting,
;; so be it.
(regexp-replace* #rx"[\r\n]+"
(substring str (cdr (car pos)) (string-length str))
" ")]))]
[else
(get-language-name)])))
(define/override (use-namespace-require/copy?) #f)

4
collects/drscheme/private/rep.ss
View File

@ -1602,13 +1602,13 @@ TODO
(set-clickback before after (λ args (send-url url))
click-delta)))
(unless (is-default-settings? user-language-settings)
(insert/delta this (string-append " " (string-constant custom)) dark-green-delta))
(insert/delta this (string-append " [" (string-constant custom) "]") dark-green-delta))
(when custodian-limit
(insert/delta this
"; memory limit: "
welcome-delta)
(insert/delta this
(format "~a megabytes" (floor (/ custodian-limit 1024 1024)))
(format "~a MB" (floor (/ custodian-limit 1024 1024)))
dark-green-delta))
(insert/delta this ".\n" welcome-delta)

2
collects/meta/dist-specs.ss
View File

@ -658,4 +658,6 @@ mz-extras :+= (- (package: "unstable")
;; -------------------- plai
plt-extras :+= (package: "plai/")
plt-extras :+= (package: "schemeunit/")
;; ============================================================================

2
collects/mzlib/compile.ss
View File

@ -56,7 +56,7 @@
(close-output-port out)))))
(lambda ()
(if ok?
(rename-file-or-directory/ignore-exists-exn temp-filename dest)
(rename-file-or-directory temp-filename dest #t)
(with-handlers ([exn:fail:filesystem? void])
(delete-file temp-filename))))))
(lambda () (close-input-port in)))

24
collects/mzlib/pconvert.ss
View File

@ -357,15 +357,21 @@
`(mcons ,(recur (mcar expr)) ,(recur (mcdr expr))))]
[(weak-box? expr) `(make-weak-box ,(recur (weak-box-value expr)))]
[(box? expr) `(box ,(recur (unbox expr)))]
[(hash-table? expr) `(,(cond
[(hash-table? expr 'weak 'equal) 'weak-hash]
[(hash-table? expr 'equal) 'hash]
[(hash-table? expr 'weak) 'weak-hasheq]
[else 'hasheq])
,@(hash-table-map
expr
(lambda (k v)
`(,(recur k) ,(recur v)))))]
[(hash-table? expr)
(let ([contents
(hash-table-map
expr
(lambda (k v)
`(cons ,(recur k) ,(recur v))))]
[constructor
(cond
[(hash-table? expr 'weak 'equal) 'weak-hash]
[(hash-table? expr 'equal) 'make-hash]
[(hash-table? expr 'weak) 'weak-hasheq]
[else 'hasheq])])
(if (null? contents)
`(,constructor)
`(,constructor (list ,@contents))))]
[(vector? expr) `(vector ,@(map recur (vector->list expr)))]
[(symbol? expr) `',expr]
[(keyword? expr) `',expr]

8
collects/scheme/private/class-internal.ss
View File

@ -3946,6 +3946,12 @@
cls)))
; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
(define (extract-vtable o) (class-methods (object-ref o)))
; extract-method-ht : object -> hash-table[sym -> number]
(define (extract-method-ht o) (class-method-ht (object-ref o)))
;;--------------------------------------------------------------------
;; misc utils
;;--------------------------------------------------------------------
@ -4134,6 +4140,8 @@
;; Providing normal functionality:
(provide (protect-out make-wrapper-class
wrapper-object-wrapped
extract-vtable
extract-method-ht
get-field/proc)
(rename-out [_class class]) class* class/derived

2
collects/schemeunit/info.ss
View File

@ -14,7 +14,7 @@
(define url "http://schematics.sourceforge.net/")
(define primary-file "main.ss")
(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page user-doc) (tool))))
(define scribblings '(("scribblings/schemeunit.scrbl" (multi-page) (tool))))
(define release-notes
'((p "Correctly handle arbitrary expressions in test suites and fix Scribble errors.")))

71
collects/scribblings/mzc/zo-parse.scrbl
View File

@ -224,7 +224,7 @@ to its depth from before evaluating the form.}
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t syntax?)])]{
[internal-context (or/c #f #t stx?)])]{
Represents a @scheme[module] declaration. The @scheme[body] forms use
@scheme[prefix], rather than any prefix in place for the module
@ -268,7 +268,7 @@ embeds an arbitrary lexical context.}
[nom-mod (or/c module-path-index? #f)]
[src-phase (or/c 0 1)]
[protected? boolean?]
[insp (or #t #f (void))])]{
[insp (or #t #f void?)])]{
Describes an individual provided identifier within a @scheme[mod] instance.}
@ -527,7 +527,7 @@ kernel.}
@defstruct+[wrapped ([datum any/c]
[wraps (listof wrap?)]
[certs list?])]{
[certs (or/c list? #f)])]{
Represents a syntax object, where @scheme[wraps] contain the lexical
information and @scheme[certs] is certificate information. When the
@ -539,7 +539,7 @@ information and @scheme[certs] is certificate information. When the
A supertype for lexical-information elements.}
@defstruct+[(lexical-rename wrap) ([alist (listof (cons/c identifier? identifier?))])]{
@defstruct+[(lexical-rename wrap) ([alist (listof (cons/c symbol? symbol?))])]{
A local-binding mapping from symbols to binding-set names.}
@ -569,13 +569,60 @@ Represents a set of module and import bindings.}
Represents a set of simple imports from one module within a
@scheme[module-rename].}
@defstruct+[module-binding ([path module-path-index?]
[mod-phase (or/c exact-integer? #f)]
[import-phase (or/c exact-integer? #f)]
[id symbol?]
[nominal-path module-path-index?]
[nominal-phase (or/c exact-integer? #f)]
[nominal-id (or/c exact-integer? #f)])]{
@defstruct+[module-binding ()]{
Represents a single identifier import (i.e., the general case) within
A supertype for module bindings.}
@defstruct+[(simple-module-binding module-binding) ([path module-path-index?])]{
Represents a single identifier import within
a @scheme[module-rename].}
@defstruct+[(phased-module-binding module-binding) ([path module-path-index?]
[phase exact-integer?]
[export-name any/c]
[nominal-path nominal-path?]
[nominal-export-name any/c])]{
Represents a single identifier import within
a @scheme[module-rename].}
@defstruct+[(exported-nominal-module-binding module-binding) ([path module-path-index?]
[export-name any/c]
[nominal-path nominal-path?]
[nominal-export-name any/c])]{
Represents a single identifier import within
a @scheme[module-rename].}
@defstruct+[(nominal-module-binding module-binding) ([path module-path-index?]
[nominal-path nominal-path?])]{
Represents a single identifier import within
a @scheme[module-rename].}
@defstruct+[(exported-module-binding module-binding) ([path module-path-index?]
[export-name any/c])]{
Represents a single identifier import within
a @scheme[module-rename].}
@defstruct+[nominal-path ()]{
A supertype for nominal paths.}
@defstruct+[(simple-nominal-path nominal-path) ([value module-path-index?])]{
Represents a simple nominal path.}
@defstruct+[(imported-nominal-path nominal-path) ([value module-path-index?]
[import-phase exact-integer?])]{
Represents an imported nominal path.}
@defstruct+[(phased-nominal-path nominal-path) ([value module-path-index?]
[import-phase exact-integer?]
[phase exact-integer?])]{
Represents a phased nominal path.}

6
collects/scribblings/reference/data.scrbl
View File

@ -72,6 +72,12 @@ used as an ephemeron key (see @secref["ephemerons"]).
(symbol-interned? (gensym))
(symbol-interned? (string->unreadable-symbol "Apple"))]}
@defproc[(symbol-unreadable? [sym symbol?]) boolean?]{Returns @scheme[#t] if @scheme[sym] is
an @tech{unreadable symbol}, @scheme[#f] otherwise.
@examples[(symbol-unreadable? 'Apple)
(symbol-unreadable? (gensym))
(symbol-unreadable? (string->unreadable-symbol "Apple"))]}
@defproc[(symbol->string [sym symbol?]) symbol?]{Returns a freshly
allocated mutable string whose characters are the same as in

1
collects/teachpack/2htdp/scribblings/image-toc.ss
View File

@ -244,6 +244,7 @@
(rectangle 48 48 "solid" "gray"))
'image
"126418b230e.png")
(list '(empty-scene 160 90) 'image "216addb7809.png")
(list
'(above/align
"left"

16
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -621,11 +621,21 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
}
@section{Placing Images}
@section{Placing Images & Scenes}
Placing images into scenes is particularly useful when building worlds
and universes using @scheme[2htdp/universe].
@defproc[(empty-scene [width (and/c real? (not/c negative?))]
[height (and/c real? (not/c negative?))])
image?]{
Creates an empty scene, i.e., a rectangle with a black outline.
@image-examples[(empty-scene 160 90)]
}
@defproc[(place-image [image image?] [x real?] [y real?] [scene image?]) image?]{
Places @scheme[image] onto @scheme[scene] with its center at the coordinates
@ -768,7 +778,7 @@ the parts that fit onto @scheme[scene].
}
@defproc[(scale [factor real?] [image image?]) image?]{
@defproc[(scale [factor (and/c real? positive?)] [image image?]) image?]{
Scales @scheme[image] by @scheme[factor].
@ -788,7 +798,7 @@ the parts that fit onto @scheme[scene].
}
@defproc[(scale/xy [x-factor real?] [y-factor real?] [image image?]) image?]{
@defproc[(scale/xy [x-factor (and/c real? positive?)] [y-factor (and/c real? positive?)] [image image?]) image?]{
Scales @scheme[image] by @scheme[x-factor] horizontally and by
@scheme[y-factor] vertically.

BIN
collects/teachpack/2htdp/scribblings/img/216addb7809.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 306 B

BIN
collects/teachpack/2htdp/scribblings/img/2bed4c99df8.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.1 KiB

6
collects/tests/mzscheme/pconvert.ss
View File

@ -207,13 +207,13 @@
(make-same-test (make-weak-hasheq)
'(weak-hasheq))
(make-same-test (make-hash)
'(hash))
'(make-hash))
(make-same-test (make-weak-hash)
'(weak-hash))
(make-same-test (let ([ht (make-hash)])
(hash-set! ht 'x 1)
ht)
'(hash ('x 1)))
'(make-hash (list (cons 'x 1))))
(make-pctest (list 'a (box (list '())) (cons 1 '()))
'(list (quote a) (box (list empty)) (list 1))
'(list (quote a) (box (list empty)) (list 1))
@ -356,7 +356,7 @@
(test-shared (vector 1 2 3) '(vector 1 2 3))
(let () (define-struct a () #:inspector (make-inspector)) (test-shared (make-a) '(make-a)))
(test-shared (box 1) '(box 1))
(test-shared (make-hash) '(hash)))
(test-shared (make-hash) '(make-hash)))
(arity-test print-convert 1 2)
(arity-test build-share 1 1)

7
collects/unstable/file.ss
View File

@ -15,10 +15,5 @@
(with-handlers ([exn:fail:filesystem:exists? void])
(make-directory dir)))))
(define (rename-file-or-directory/ignore-exists-exn from to)
(with-handlers ([exn:fail:filesystem:exists? void])
(rename-file-or-directory from to)))
(provide/contract
[make-directory*/ignore-exists-exn (path-string? . -> . void)]
[rename-file-or-directory/ignore-exists-exn (path-string? path-string? . -> . void)])
[make-directory*/ignore-exists-exn (path-string? . -> . void)])

5
collects/unstable/scribblings/file.scrbl
View File

@ -16,9 +16,4 @@
@defproc[(make-directory*/ignore-exists-exn [pth path-string?])
void]{
Like @scheme[make-directory*], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create directories.
}
@defproc[(rename-file-or-directory/ignore-exists-exn [from path-string?] [to path-string?])
void]{
Like @scheme[rename-file-or-directory], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create files.
}

10
src/mzscheme/gc2/sighand.c
View File

@ -41,8 +41,14 @@ static void launchgdb() {
void fault_handler(int sn, struct siginfo *si, void *ctx)
{
void *p = si->si_addr;
/* quick access to SIGSEGV info in GDB */
int c = si->si_code;
#ifdef MZ_USE_PLACES
int m = 0;
#endif
if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/
printf("SIGSEGV fault on %p\n", p);
printf("SIGSEGV si_code %i fault on addr %p\n", c, p);
#if WAIT_FOR_GDB
launchgdb();
#endif
@ -54,7 +60,7 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
#ifdef MZ_USE_PLACES
if(pagemap_find_page(MASTERGC->page_maps, p)) {
m = 1;
printf("OWNED BY MASTER %p\n", p);
printf("ADDR %p OWNED BY MASTER %i\n", p, m);
}
#endif
printf("mprotect fault on %p\n", p);

1214
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 964
#define EXPECTED_PRIM_COUNT 965
#define EXPECTED_UNSAFE_COUNT 58
#define EXPECTED_FLFXNUM_COUNT 53

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.4.2"
#define MZSCHEME_VERSION "4.2.4.3"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 4
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

4
src/mzscheme/src/stxobj.c
View File

@ -255,7 +255,7 @@ static int is_rename_inspector_info(Scheme_Object *v)
- A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to
id equivalence)
- A wrap-elem (vector <sym> <ht> <stx> ... <recur-state> ...) is a lexical rename
- A wrap-elem (vector <sym> <ht> <stx> ..._0 <recur-state> ..._0) is a lexical rename
env (sym var <var-resolved>:
->pos) void => not yet computed
or #f sym => var-resolved is answer to replace #f
@ -266,7 +266,7 @@ static int is_rename_inspector_info(Scheme_Object *v)
or:
(cons <var-resolved> (cons <id> <phase>)) =>
free-id=? renaming to <id> on match
- A wrap-elem (vector <free-id-renames?> <ht> <sym> ... <sym> ...) is also a lexical rename
- A wrap-elem (vector <free-id-renames?> <ht> <sym> ..._0 <sym> ..._0) is also a lexical rename
bool var resolved: sym or (cons <sym> <bind-info>),
where <bind-info> is module/lexical binding info:
(cons <sym> #f) => top-level binding

16
src/mzscheme/src/symbol.c
View File

@ -70,6 +70,7 @@ void scheme_set_case_sensitive(int v) { scheme_case_sensitive = v; }
/* locals */
static Scheme_Object *symbol_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *symbol_unreadable_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *symbol_interned_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_to_symbol_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[]);
@ -318,6 +319,9 @@ scheme_init_symbol (Scheme_Env *env)
p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("symbol?", p, env);
p = scheme_make_folding_prim(symbol_unreadable_p_prim, "symbol-unreadable?", 1, 1, 1);
scheme_add_global_constant("symbol-unreadable?", p, env);
p = scheme_make_folding_prim(symbol_interned_p_prim, "symbol-interned?", 1, 1, 1);
scheme_add_global_constant("symbol-interned?", p, env);
@ -688,6 +692,16 @@ symbol_interned_p_prim (int argc, Scheme_Object *argv[])
return NULL;
}
static Scheme_Object *
symbol_unreadable_p_prim (int argc, Scheme_Object *argv[])
{
if (SCHEME_SYMBOLP(argv[0]))
return (SCHEME_SYM_PARALLELP(argv[0]) ? scheme_true : scheme_false);
scheme_wrong_type("symbol-unreadable?", "symbol", 0, argc, argv);
return NULL;
}
static Scheme_Object *
string_to_symbol_prim (int argc, Scheme_Object *argv[])
{
@ -713,7 +727,7 @@ string_to_unreadable_symbol_prim (int argc, Scheme_Object *argv[])
long blen;
if (!SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_type("string->symbol", "string", 0, argc, argv);
scheme_wrong_type("string->unreadable-symbol", "string", 0, argc, argv);
bs = scheme_utf8_encode_to_buffer_len(SCHEME_CHAR_STR_VAL(argv[0]),
SCHEME_CHAR_STRTAG_VAL(argv[0]),