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

Syncing -- nothing to see here.

Browse Source 
svn: r12660
This commit is contained in:
Stevie Strickland 2008-12-01 15:11:00 +00:00
commit e94cadd86d
58 changed files with 5250 additions and 867 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/drscheme/private/unit.ss
View File

@ -1334,6 +1334,7 @@ module browser threading seems wrong.
execute-callback
get-current-tab
open-in-new-tab
close-current-tab
on-tab-change
enable-evaluation
disable-evaluation
@ -1344,6 +1345,7 @@ module browser threading seems wrong.
ensure-rep-hidden
ensure-defs-shown
get-language-menu
register-toolbar-button
get-tabs))
@ -2505,7 +2507,7 @@ module browser threading seems wrong.
(define/private (change-to-delta-tab dt)
(change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs))))
(define/private (close-current-tab)
(define/public-final (close-current-tab)
(cond
[(null? tabs) (void)]
[(null? (cdr tabs)) (void)]
@ -2528,6 +2530,7 @@ module browser threading seems wrong.
[else (last tabs)])))
(loop (cdr l-tabs))))]))]))
;; a helper private method for close-current-tab -- doesn't close an arbitrary tab.
(define/private (close-tab tab)
(cond
[(send tab can-close?)

5
collects/framework/private/scheme.ss
View File

@ -1182,7 +1182,8 @@
(values lexeme type paren start end)))))
(define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "ss"])
(parameterize ([finder:default-extension "ss"]
[finder:default-filters '(("SCM" "*.scm") ("Any" "*.*"))])
;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name)))
@ -1224,8 +1225,6 @@
(define text-mode% (text-mode-mixin color:text-mode%))
(define (setup-keymap keymap)
(let ([add-pos-function
(λ (name call-method)

4
collects/frtime/frtime-lang-only.ss
View File

@ -1,6 +1,5 @@
(module frtime-lang-only "mzscheme-utils.ss"
(require frtime/lang-ext)
(require frtime/ft-qq)
(require (as-is:unchecked frtime/frp-core
event-set? signal-value))
@ -18,5 +17,4 @@
(provide value-nowable? behaviorof
(all-from "mzscheme-utils.ss")
(all-from-except frtime/lang-ext lift)
(all-from frtime/ft-qq)))
(all-from-except frtime/lang-ext lift)))

2
collects/frtime/frtime-opt-lang.ss
View File

@ -166,7 +166,7 @@
raise raise-exceptions raise-type-error error exit let/ec
;; no equiv because I haven't completely thought through these
lambda quote quasiquote unquote unquote-splicing make-parameter parameterize
lambda quote unquote unquote-splicing make-parameter parameterize
procedure-arity-includes? dynamic-require)
(provide #%app #%top #%datum require require-for-syntax provide define)

8
collects/frtime/frtime.ss
View File

@ -1,7 +1,6 @@
(module frtime "mzscheme-utils.ss"
(require "lang-ext.ss")
(require (all-except "lang-ext.ss" lift deep-value-now))
(require "frp-snip.ss")
(require "ft-qq.ss")
(require (as-is:unchecked "frp-core.ss"
event-set? signal-value))
@ -18,7 +17,6 @@
;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list))
(provide value-nowable? behaviorof
(all-from "lang-ext.ss")
(all-from "mzscheme-utils.ss")
(all-from-except "lang-ext.ss" lift)
(all-from "frp-snip.ss")
(all-from "ft-qq.ss")))
(all-from "frp-snip.ss")))

178
collects/frtime/ft-qq.ss
View File

@ -1,178 +0,0 @@
(module ft-qq "mzscheme-core.ss"
(require (as-is:unchecked mzscheme define-values define-syntaxes require-for-syntax
raise-type-error quote unquote unquote-splicing))
;(require-for-syntax frtime/frp)
(require-for-syntax syntax/stx)
(define-values (frp:qq-append)
(lambda (a b)
(if (list? a)
(append a b)
(raise-type-error 'unquote-splicing "proper list" a))))
(define-syntaxes (frp:quasiquote)
(let ([here (quote-syntax here)] ; id with module bindings, but not lexical
[unquote-stx (quote-syntax unquote)]
[unquote-splicing-stx (quote-syntax unquote-splicing)])
(lambda (in-form)
(if (identifier? in-form)
(raise-syntax-error #f "bad syntax" in-form))
(let-values
(((form) (if (stx-pair? (stx-cdr in-form))
(if (stx-null? (stx-cdr (stx-cdr in-form)))
(stx-car (stx-cdr in-form))
(raise-syntax-error #f "bad syntax" in-form))
(raise-syntax-error #f "bad syntax" in-form)))
((normal)
(lambda (x old)
(if (eq? x old)
(if (stx-null? x)
(quote-syntax ())
(list (quote-syntax quote) x))
x)))
((apply-cons)
(lambda (a d)
(if (stx-null? d)
(list (quote-syntax list) a)
(if (if (pair? d)
(module-identifier=? (quote-syntax list) (car d))
#f)
(list* (quote-syntax list) a (cdr d))
(list (quote-syntax cons) a d))))))
(datum->syntax-object
here
(normal
(letrec-values
(((qq)
(lambda (x level)
(let-values
(((qq-list)
(lambda (x level)
(let-values
(((old-first) (stx-car x)))
(let-values
(((old-second) (stx-cdr x)))
(let-values
(((first) (qq old-first level)))
(let-values
(((second) (qq old-second level)))
(let-values
()
(if (if (eq? first old-first)
(eq? second old-second)
#f)
x
(apply-cons
(normal first old-first)
(normal second old-second)))))))))))
(if (stx-pair? x)
(let-values
(((first) (stx-car x)))
(if (if (if (identifier? first)
(module-identifier=? first unquote-stx)
#f)
(stx-list? x)
#f)
(let-values
(((rest) (stx-cdr x)))
(if (let-values
(((g35) (not (stx-pair? rest))))
(if g35 g35 (not (stx-null? (stx-cdr rest)))))
(raise-syntax-error
'unquote
"expects exactly one expression"
in-form
x))
(if (zero? level)
(stx-car rest)
(qq-list x (sub1 level))))
(if (if (if (identifier? first)
(module-identifier=? first (quote-syntax frp:quasiquote))
#f)
(stx-list? x)
#f)
(qq-list x (add1 level))
(if (if (if (identifier? first)
(module-identifier=? first unquote-splicing-stx)
#f)
(stx-list? x)
#f)
(raise-syntax-error
'unquote-splicing
"invalid context within quasiquote"
in-form
x)
(if (if (stx-pair? first)
(if (identifier? (stx-car first))
(if (module-identifier=? (stx-car first)
unquote-splicing-stx)
(stx-list? first)
#F)
#f)
#f)
(let-values
(((rest) (stx-cdr first)))
(if (let-values
(((g34) (not (stx-pair? rest))))
(if g34
g34
(not (stx-null? (stx-cdr rest)))))
(raise-syntax-error
'unquote
"expects exactly one expression"
in-form
x))
(let-values
(((uqsd) (stx-car rest))
((old-l) (stx-cdr x))
((l) (qq (stx-cdr x) level)))
(if (zero? level)
(let-values
(((l) (normal l old-l)))
(let-values
()
(list (quote-syntax frp:qq-append) uqsd l)))
(let-values
(((restx) (qq-list rest (sub1 level))))
(let-values
()
(if (if (eq? l old-l)
(eq? restx rest)
#f)
x
(apply-cons
(apply-cons
(quote-syntax (quote unquote-splicing))
(normal restx rest))
(normal l old-l))))))))
(qq-list x level))))))
(if (if (syntax? x)
(vector? (syntax-e x))
#f)
(let-values
(((l) (vector->list (syntax-e x))))
(let-values
(((l2) (qq l level)))
(let-values
()
(if (eq? l l2)
x
(list (quote-syntax list->vector) l2)))))
(if (if (syntax? x) (box? (syntax-e x)) #f)
(let-values
(((v) (unbox (syntax-e x))))
(let-values
(((qv) (qq v level)))
(let-values
()
(if (eq? v qv)
x
(list (quote-syntax box) qv)))))
x)))))))
(qq form 0))
form)
in-form)))))
(provide ;(rename frp:qq-append qq-append)
(rename frp:quasiquote quasiquote)))

9
collects/frtime/gui/mixin-macros.ss
View File

@ -1,6 +1,5 @@
(module mixin-macros frtime
(require mzlib/class)
(require mzlib/class)
(define-syntax events->callbacks
(lambda (stx)
@ -47,10 +46,14 @@
(define name-e (event-receiver))
(define processed-events (processor name-e))
(super-new)
(define ft-last-evt #f)
;what about when the super call returns an error?
(define/override method-name
(lambda args
(send-event name-e args)
(when (or (< (length args) 2)
(and (not (eq? (cadr args) ft-last-evt))
(set! ft-last-evt (cadr args))))
(send-event name-e args))
(super method-name . args)))
(define/public (g-name) processed-events))))])))

52
collects/frtime/lang-ext.ss
View File

@ -15,9 +15,52 @@
(define name
(let ([val (parameterize ([snap? #f])
expr)])
(lambda () (deep-value-now val))))]))
(lambda () (deep-value-now val empty))))]))
(define deep-value-now
(define (deep-value-now obj table)
(cond
[(assq obj table) => second]
[(behavior? obj)
(deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))]
[(cons? obj)
(let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)]
[car-val (deep-value-now (car obj) new-table)]
[cdr-val (deep-value-now (cdr obj) new-table)])
(if (and (eq? car-val (car obj))
(eq? cdr-val (cdr obj)))
obj
(cons car-val cdr-val)))]
; won't work in the presence of super structs or immutable fields
[(struct? obj)
(let*-values ([(info skipped) (struct-info obj)]
[(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)]
[(indices) (build-list init-k identity)]
[(result) (apply ctor (build-list init-k (lambda (i) #f)))]
[(new-table) (cons (list obj result) table)]
[(elts) (build-list init-k (lambda (i)
(deep-value-now (acc obj i) new-table)))])
(if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts)
obj
(begin
(for-each (lambda (i e) (mut! result i e)) indices elts)
result)))]
[(vector? obj)
(let* ([len (vector-length obj)]
[indices (build-list len identity)]
[result (build-vector len (lambda (_) #f))]
[new-table (cons (list obj result) table)]
[elts (build-list len (lambda (i)
(deep-value-now (vector-ref obj i) new-table)))])
(if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts)
obj
(begin
(for-each (lambda (i e) (vector-set! result i e)) indices elts)
result)))]
[else obj]))
#;(define deep-value-now
(case-lambda
[(obj) (deep-value-now obj empty)]
[(obj table)
@ -166,7 +209,7 @@
(make-events-now
(if first-time
empty
(list (deep-value-now bh))))
(list (deep-value-now bh empty))))
(set! first-time #f))))
b))
@ -389,7 +432,7 @@
[consumer (proc->signal
(lambda ()
(let* ([now (current-inexact-milliseconds)]
[new (deep-value-now beh)]
[new (deep-value-now beh empty)]
[ms (value-now ms-b)])
(when (not (equal? new (car (mcar last))))
(set-mcdr! last (mcons (cons new now)
@ -786,6 +829,7 @@
(provide raise-exceptions
deep-value-now
nothing
nothing?
;general-event-processor

4
collects/frtime/lang.ss
View File

@ -1,6 +1,5 @@
(module lang frtime/mzscheme-utils
(require frtime/lang-ext)
(require frtime/ft-qq)
(require (as-is:unchecked frtime/frp-core
event-set? signal-value))
@ -18,5 +17,4 @@
(provide value-nowable? behaviorof
(all-from frtime/mzscheme-utils)
(all-from-except frtime/lang-ext lift)
(all-from frtime/ft-qq)))
(all-from-except frtime/lang-ext lift)))

149
collects/frtime/mzscheme-core.ss
View File

@ -1,11 +1,9 @@
(module mzscheme-core mzscheme
;(require (all-except mzscheme provide module if require letrec null?)
;mzlib/list)
(require-for-syntax frtime/struct mzlib/list)
(require mzlib/list
frtime/frp-core
(only srfi/43/vector-lib vector-any)
(only frtime/lang-ext lift new-cell switch ==> changes)
(only frtime/lang-ext lift new-cell switch ==> changes deep-value-now)
(only mzlib/etc build-vector rec build-list opt-lambda identity))
;;;;;;;;;;;;;;;;;;;;;;;;
@ -23,10 +21,6 @@
...
expr ...)]))
;(define-syntax frp:match
; (syntax-rules ()
; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
(define (->boolean x)
(if x #t #f))
@ -42,7 +36,6 @@
[(_ test-exp then-exp else-exp undef-exp)
(super-lift
(lambda (b)
;(printf "~n\t******\tIF CONDITION IS ~a~n" b)
(cond
[(undefined? b) undef-exp]
[b then-exp]
@ -93,21 +86,6 @@
(map translate-clause (syntax->list #'(clause ...)))])
#'(case-lambda
new-clause ...))]))
#|
(define (split-list acc lst)
(if (null? (cdr lst))
(values acc lst)
(split-list (append acc (list (car lst))) (cdr lst))))
(define (frp:apply fn . args)
(let-values ([(first-args rest-args) (split-list () args)])
(if (behavior? rest-args)
(super-lift
(lambda (rest-args)
(apply apply fn (append first-args rest-args)))
args)
(apply apply fn (append first-args rest-args)))))
|#
(define any-nested-reactivity?
(opt-lambda (obj [mem empty])
@ -141,7 +119,8 @@
[(absent) (hash-table-put! deps obj 'new)]
[(old) (hash-table-put! deps obj 'alive)]
[(new) (void)])
(deep-value-now/update-deps (signal-value obj) deps table)]
(deep-value-now/update-deps (signal-value obj) deps
(cons (list obj (signal-value obj)) table))]
[(cons? obj)
(let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)]
@ -178,48 +157,9 @@
result)))]
[else obj]))
(define (deep-value-now obj table)
(cond
[(assq obj table) => second]
[(behavior? obj)
(deep-value-now (signal-value obj) table)]
[(cons? obj)
(let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)]
[car-val (deep-value-now (car obj) new-table)]
[cdr-val (deep-value-now (cdr obj) new-table)])
(if (and (eq? car-val (car obj))
(eq? cdr-val (cdr obj)))
obj
(cons car-val cdr-val)))]
; won't work in the presence of super structs or immutable fields
[(struct? obj)
(let*-values ([(info skipped) (struct-info obj)]
[(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)]
[(indices) (build-list init-k identity)]
[(result) (apply ctor (build-list init-k (lambda (i) #f)))]
[(new-table) (cons (list obj result) table)]
[(elts) (build-list init-k (lambda (i)
(deep-value-now (acc obj i) new-table)))])
(if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts)
obj
(begin
(for-each (lambda (i e) (mut! result i e)) indices elts)
result)))]
[(vector? obj)
(let* ([len (vector-length obj)]
[indices (build-list len identity)]
[result (build-vector len (lambda (_) #f))]
[new-table (cons (list obj result) table)]
[elts (build-list len (lambda (i)
(deep-value-now (vector-ref obj i) new-table)))])
(if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts)
obj
(begin
(for-each (lambda (i e) (vector-set! result i e)) indices elts)
result)))]
[else obj]))
(define (public-dvn obj)
(do-in-manager-after
(deep-value-now obj empty)))
(define any-spinal-reactivity?
(opt-lambda (lst [mem empty])
@ -261,8 +201,7 @@
(iq-enqueue rtn))]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
(unregister rtn k)])))
#;(printf "count = ~a~n" (hash-table-count deps))))))
(unregister rtn k)])))))))
(do-in-manager
(iq-enqueue rtn))
rtn)
@ -284,8 +223,7 @@
(register rtn k)]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
(unregister rtn k)])))
#;(printf "count = ~a~n" (hash-table-count deps))))))
(unregister rtn k)])))))))
(do-in-manager
(iq-enqueue rtn))
rtn))
@ -299,7 +237,6 @@
(begin0
(let/ec esc
(begin0
;;(with-handlers ([exn:fail? (lambda (exn) #f)])
(proc (lambda (obj)
(if (behavior? obj)
(begin
@ -320,8 +257,7 @@
(case v
[(new alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
(unregister rtn k)])))
#;(printf "count = ~a~n" (hash-table-count deps))))))))
(unregister rtn k)])))))))))
(iq-enqueue rtn)
rtn))
@ -334,29 +270,14 @@
;; CONS
(define (frp:cons f r)
(cons f r)
#;(lift #f cons f r)
#;(if (or (behavior? f) (behavior? r))
(procs->signal:compound
cons
(lambda (p i)
(if (zero? i)
(lambda (v) (set-car! p v))
(lambda (v) (set-cdr! p v))))
f r)
(cons f r)))
(define frp:cons cons)
(define (make-accessor acc)
(lambda (v)
(let loop ([v v])
(cond
[(signal:compound? v) (acc (signal:compound-content v))]
[(signal? v) #;(printf "access to ~a in ~a~n" acc
(value-now/no-copy v))
#;(lift #t acc v)
#;(switch ((changes v) . ==> . acc) (acc (value-now v)))
(super-lift acc v)]
[(signal? v) (super-lift acc v)]
[(signal:switching? v) (super-lift
(lambda (_)
(loop (unbox (signal:switching-current v))))
@ -390,10 +311,7 @@
[(empty? lst) (ef)]
[else (error "list-match: expected a list, got ~a" lst)]))
lst))
#;(define (frp:append . args)
(apply lift #t append args))
(define frp:append
(case-lambda
[() ()]
@ -401,18 +319,9 @@
[(lst1 lst2 . lsts)
(list-match lst1
(lambda (f r) (cons f (apply frp:append r lst2 lsts)))
(lambda () (apply frp:append lst2 lsts)))
#;(frp:if (frp:empty? lst1)
(apply frp:append lst2 lsts)
(frp:cons (frp:car lst1)
(apply frp:append (frp:cdr lst1) lst2 lsts)))]))
(lambda () (apply frp:append lst2 lsts)))]))
(define frp:list list
#;(lambda elts
(frp:if (frp:empty? elts)
'()
(frp:cons (frp:car elts)
(apply frp:list (frp:cdr elts))))))
(define frp:list list)
(define frp:list*
(lambda elts
@ -426,7 +335,6 @@
(define (frp:list? itm)
(if (signal:compound? itm)
(let ([ctnt (signal:compound-content itm)])
; (let ([ctnt (value-now itm)])
(if (cons? ctnt)
(frp:list? (cdr ctnt))
#f))
@ -442,23 +350,10 @@
(define frp:vector vector)
#;(define (frp:vector . args)
(if (ormap behavior? args)
(apply procs->signal:compound
vector
(lambda (vec idx)
(lambda (x)
(vector-set! vec idx x)))
args)
(apply vector args)))
(define (frp:vector-ref v i)
(cond
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)
#;(switch ((changes v) . ==> . (lambda (vv) (vector-ref vv i)))
(vector-ref (value-now v) i)) ;; rewrite as super-lift
#;(lift #t vector-ref v i)]
#;[(signal:compound? v) (vector-ref (signal:compound-content v) i)]
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)]
[else (lift #t vector-ref v i)]))
@ -472,16 +367,7 @@
args)])
(values
desc
#;(lambda fields
(if (ormap behavior? fields)
(apply procs->signal:compound
ctor
(lambda (strct idx)
(lambda (val)
(mut strct idx val)))
fields)
(apply ctor fields)))
ctor
ctor
(lambda (v) (if (signal:compound? v)
(pred (value-now/no-copy v))
(lift #t pred v)))
@ -646,14 +532,13 @@
#%top-interaction
raise-reactivity
raise-list-for-apply
deep-value-now
(rename public-dvn deep-value-now)
any-nested-reactivity?
compound-lift
list-match
(rename frp:if if)
(rename frp:lambda lambda)
(rename frp:case-lambda case-lambda)
;(rename frp:apply apply)
(rename frp:letrec letrec)
(rename frp:cons cons)
(rename frp:car car)

85
collects/frtime/mzscheme-utils.ss
View File

@ -10,7 +10,6 @@
if
lambda
case-lambda
;apply
reverse
list-ref
require
@ -24,8 +23,6 @@
make-struct-field-mutator
vector
vector-ref
quasiquote
;qq-append
define-struct
list
list*
@ -33,8 +30,7 @@
append
and
or
cond when unless ;case
; else =>
cond when unless
map ormap andmap assoc member)
(rename mzscheme mzscheme:if if)
(rename "lang-ext.ss" lift lift)
@ -59,11 +55,7 @@
(if (lift #t positive? idx)
(list-ref (cdr lst) (lift #t sub1 idx))
(car lst)))
;(define (frp:eq? itm1 itm2)
; (lift #t eq? itm1 itm2))
(define-syntax cond
(syntax-rules (else =>)
[(_ [else result1 result2 ...])
@ -189,14 +181,7 @@
(define (cddddr v)
(cdr (cdddr v)))
#|
(define-syntax frp:case
(syntax-rules ()
[(_ expr clause ...)
(super-lift (lambda (v) (case v clause ...)) expr)]))
|#
(define (split-list acc lst)
(if (null? (cdr lst))
(values acc (car lst))
@ -215,45 +200,7 @@
(lambda (last-args)
(apply apply fn (append first-args (cons last-args empty))))
last-args))))
#|
;; taken from startup.ss
(define-syntax frp:case
(lambda (x)
(syntax-case x (else)
((_ v)
(syntax (begin v (cond))))
((_ v (else e1 e2 ...))
(syntax/loc x (begin v e1 e2 ...)))
((_ v ((k ...) e1 e2 ...))
(syntax/loc x (if (memv v '(k ...)) (begin e1 e2 ...))))
((_ v ((k ...) e1 e2 ...) c1 c2 ...)
(syntax/loc x (let ((x v))
(if (memv x '(k ...))
(begin e1 e2 ...)
(frp:case x c1 c2 ...)))))
((_ v (bad e1 e2 ...) . rest)
(raise-syntax-error
#f
"bad syntax (not a datum sequence)"
x
(syntax bad)))
((_ v clause . rest)
(raise-syntax-error
#f
"bad syntax (missing expression after datum sequence)"
x
(syntax clause)))
((_ . v)
(not (null? (syntax-e (syntax v))))
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
x)))))
|#
(define-syntax frp:case
(syntax-rules ()
[(_ exp clause ...)
@ -274,10 +221,7 @@
(define map
(case-lambda
[(f l) #;(if (pair? l)
(cons (f (car l)) (map f (cdr l)))
null)
(list-match
[(f l) (list-match
l
(lambda (a d) (cons (f a) (map f d)))
(lambda () null))]
@ -292,10 +236,7 @@
(list-match
l2
(lambda (a2 d2) (error "map expected lists of same length but got" l1 l2))
(lambda () null))))
#;(if (and (pair? l1) (pair? l2))
(cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2)))
null)]
(lambda () null))))]
[(f l . ls) (if (and (pair? l) (andmap pair? ls))
(cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls)))
null)]))
@ -323,7 +264,6 @@
(define (dont-optimize x) x)
(provide cond
; else =>
and
or
or-undef
@ -342,7 +282,6 @@
cdddr
cadddr
cddddr
;case
build-path
collection-path
@ -357,7 +296,7 @@
eq?
equal? eqv? < > <= >=
add1 cos sin tan symbol->string symbol?
number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref
number->string string->symbol eof-object? exp expt even? odd? string-append eval
sub1 sqrt not number? string string? zero? min max modulo
string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
string>=? char-upper-case? char-alphabetic?
@ -374,8 +313,7 @@
date-minute date-second make-date char-downcase char>=? char<=? char->integer integer->char boolean?
integer? quotient remainder positive? negative? inexact->exact exact->inexact
make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact?
char-whitespace? assq assv memq memv list-tail ;reverse
;length
char-whitespace? assq assv memq memv list-tail
seconds->date
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
exn:fail? regexp-match
@ -393,12 +331,8 @@
procedure-arity-includes? raise-type-error raise thread
current-continuation-marks
raise-mismatch-error require-for-syntax define-syntax define-syntaxes syntax-rules syntax-case
; set-eventspace
;install-errortrace-key
(lifted:nonstrict format)
print-struct
;lambda
;case-lambda
define
let
let*
@ -409,6 +343,7 @@
begin
begin0
quote
quasiquote
unquote
unquote-splicing
@ -442,8 +377,6 @@
dont-optimize
; null
; make-struct-field-mutator
)
; from core

4
collects/frtime/reactive.ss
View File

@ -1,7 +1,6 @@
(module reactive "mzscheme-utils.ss"
(require "lang-ext.ss")
(require "frp-snip.ss")
(require "ft-qq.ss")
(require frtime/list)
(require frtime/etc)
(require (as-is:unchecked "frp-core.ss"
@ -25,5 +24,4 @@
(all-from frtime/etc)
(all-from "mzscheme-utils.ss")
(all-from-except "lang-ext.ss" lift)
(all-from "frp-snip.ss")
(all-from "ft-qq.ss")))
(all-from "frp-snip.ss")))

9
collects/lang/htdp-langs.ss
View File

@ -1072,6 +1072,7 @@
(send off-sd set-delta-background "darkblue"))
;; picture 5.png
#;
(begin
(send on-sd set-delta-foreground (make-object color% 0 80 0))
(send off-sd set-delta-foreground "orange")
@ -1082,7 +1083,13 @@
(send on-sd set-delta-foreground "black")
(send off-sd set-delta-foreground "orange")
(send off-sd set-delta-background "black"))
])
;; mike's preferred color scheme, but looks just like the selection
#;
(begin
(send on-sd set-delta-foreground "black")
(send off-sd set-delta-background "lightblue")
(send off-sd set-delta-foreground "black"))])
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht

3
collects/mred/private/wxtextfield.ss
View File

@ -142,6 +142,7 @@
[p (if horiz?
this
(let ([p (make-object wx-vertical-pane% #f proxy this null)])
(send p skip-subwindow-events? #t)
(send (send p area-parent) add-child p)
p))])
(sequence
@ -166,7 +167,9 @@
'(hide-hscroll))
'(hide-vscroll hide-hscroll))))])
(sequence
(send c skip-subwindow-events? #t)
(when l
(send l skip-subwindow-events? #t)
(send l x-margin 0))
(send c set-x-margin 2)
(send c set-y-margin 2)

49
collects/mred/private/wxwindow.ss
View File

@ -18,29 +18,36 @@
[focus? #f]
[container this]
[visible? #f]
[active? #f])
[active? #f]
[skip-sub-events? #f])
(public
[on-visible
(lambda ()
(let ([vis? (is-shown-to-root?)])
(unless (eq? vis? visible?)
(set! visible? vis?)
(as-exit
(lambda ()
(send (wx->proxy this) on-superwindow-show vis?))))))]
(unless skip-sub-events?
(as-exit
(lambda ()
(send (wx->proxy this) on-superwindow-show vis?)))))))]
[queue-visible
(lambda ()
(parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)])
(wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))])
(wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))]
[skip-subwindow-events?
(case-lambda
[() skip-sub-events?]
[(skip?) (set! skip-sub-events? skip?)])])
(public
[on-active
(lambda ()
(let ([act? (is-enabled-to-root?)])
(unless (eq? act? active?)
(set! active? act?)
(as-exit
(lambda ()
(send (wx->proxy this) on-superwindow-enable act?))))))]
(unless skip-sub-events?
(as-exit
(lambda ()
(send (wx->proxy this) on-superwindow-enable act?)))))))]
[queue-active
(lambda ()
(parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)])
@ -127,7 +134,7 @@
(define (make-window-glue% %) ; implies make-glue%
(class100 (make-glue% %) (mred proxy . args)
(inherit get-x get-y get-width get-height area-parent get-mred get-proxy)
(inherit get-x get-y get-width get-height area-parent get-mred get-proxy skip-subwindow-events?)
(private-field
[pre-wx->proxy (lambda (orig-w e k)
;; MacOS: w may not be something the user knows
@ -211,16 +218,20 @@
(as-exit (lambda () (super on-kill-focus)))))]
[pre-on-char (lambda (w e)
(or (super pre-on-char w e)
(as-entry
(lambda ()
(pre-wx->proxy w e
(lambda (m e)
(as-exit (lambda ()
(send (get-proxy) on-subwindow-char m e)))))))))]
(if (skip-subwindow-events?)
#f
(as-entry
(lambda ()
(pre-wx->proxy w e
(lambda (m e)
(as-exit (lambda ()
(send (get-proxy) on-subwindow-char m e))))))))))]
[pre-on-event (entry-point
(lambda (w e)
(pre-wx->proxy w e
(lambda (m e)
(as-exit (lambda ()
(send (get-proxy) on-subwindow-event m e)))))))])
(if (skip-subwindow-events?)
#f
(pre-wx->proxy w e
(lambda (m e)
(as-exit (lambda ()
(send (get-proxy) on-subwindow-event m e))))))))])
(sequence (apply super-init mred proxy args)))))

18
collects/mrlib/tex-table.ss
View File

@ -41,7 +41,7 @@
;􏰃→ \mapsto
("aleph" "ℵ")
("aleph" "א")
("prime" "′")
("emptyset" "∅")
("nabla" "∇")
@ -63,22 +63,22 @@
("theta" "θ")
("tau" "τ")
("beta" "β")
("vartheta" "ϑ")
("vartheta" "θ")
("pi" "π")
("upsilon" "υ")
("gamma" "γ")
("varpi" "ϖ")
("varpi" "π")
("phi" "φ")
("delta" "δ")
("kappa" "κ")
("rho" "ρ")
("varphi" "ϕ")
("epsilon" "ϵ")
("varphi" "φ")
("epsilon" "ε")
("lambda" "λ")
("varrho" "ϱ")
("varrho" "ρ")
("chi" "χ")
("varepsilon" "ε")
("mu" "µ")
("mu" "μ")
("sigma" "σ")
("psi" "ψ")
("zeta" "ζ")
@ -94,7 +94,7 @@
("Delta" "∆")
("Xi" "Ξ")
("Upsilon" "Υ")
("Omega" "Ω")
("Omega" "Ω")
("Theta" "Θ")
("Pi" "Π")
("Phi" "Φ")
@ -150,7 +150,7 @@
("cong" "≌")
("sqsubsetb" "⊏")
("sqsupsetb" "⊐")
("neq" #;"≠" "≠")
("neq" #;"≠" "≠")
("smile" "⌣")
("sqsubseteq" "⊑")
("sqsupseteq" "⊒")

232
collects/mzlib/sandbox.ss
View File

@ -1,124 +1,118 @@
(module sandbox scheme/base
(require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace)))
(provide sandbox-init-hook
sandbox-reader
sandbox-input
sandbox-output
sandbox-error-output
sandbox-propagate-breaks
sandbox-coverage-enabled
sandbox-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-network-guard
sandbox-make-inspector
sandbox-eval-limits
kill-evaluator
break-evaluator
set-eval-limits
put-input
get-output
get-error-output
get-uncovered-expressions
call-with-limits
with-limits
exn:fail:resource?
exn:fail:resource-resource
(rename-out [*make-evaluator make-evaluator]
[gui? mred?]))
#lang scheme/base
(define-namespace-anchor anchor)
(require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace)))
;; Compatbility:
;; * recognize 'r5rs, etc, and wrap them as a list.
;; * 'begin form of reqs
;; * more agressively extract requires from lang and reqs
(define *make-evaluator
(case-lambda
[(lang reqs . progs)
(with-ns-params
(lambda ()
(let ([beg-req? (and (list? reqs)
(pair? reqs)
(eq? 'begin (car reqs)))]
[reqs (or reqs '())]
[lang (or lang '(begin))])
(keyword-apply
make-evaluator
'(#:allow-read #:requires)
(list (extract-requires lang reqs)
(if beg-req? null reqs))
(case lang
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced)
(list 'special lang)]
[else lang])
(append
(if beg-req? (cdr reqs) null)
progs)))))]
[(mod)
(with-ns-params
(lambda ()
(make-module-evaluator mod)))]))
(provide sandbox-init-hook
sandbox-reader
sandbox-input
sandbox-output
sandbox-error-output
sandbox-propagate-breaks
sandbox-coverage-enabled
sandbox-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-network-guard
sandbox-make-inspector
sandbox-eval-limits
kill-evaluator
break-evaluator
set-eval-limits
put-input
get-output
get-error-output
get-uncovered-expressions
call-with-limits
with-limits
exn:fail:resource?
exn:fail:resource-resource
(rename-out [*make-evaluator make-evaluator]
[gui? mred?]))
(define (make-mz-namespace)
(let ([ns (mz:make-namespace)])
;; Because scheme/sandbox needs scheme/base:
(namespace-attach-module (namespace-anchor->namespace anchor)
'scheme/base
ns)
ns))
(define-namespace-anchor anchor)
(define (with-ns-params thunk)
(let ([v (sandbox-namespace-specs)])
(cond
[(and (not gui?)
(eq? (car v) make-base-namespace))
(parameterize ([sandbox-namespace-specs
(cons make-mz-namespace
(cdr v))])
(thunk))]
[(and gui?
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
(parameterize ([sandbox-namespace-specs
;; Simulate the old make-namespace-with-mred:
(cons (lambda ()
(let ([ns (make-mz-namespace)]
[ns2 ((dynamic-require 'mred 'make-gui-namespace))])
(namespace-attach-module ns2 'mred ns)
(namespace-attach-module ns2 'scheme/class ns)
(parameterize ([current-namespace ns])
(namespace-require 'mred)
(namespace-require 'scheme/class))
ns))
(cdr v))])
(thunk))]
[else (thunk)])))
(define (literal-identifier=? x y)
(or (free-identifier=? x y)
(eq? (syntax-e x) (syntax-e y))))
;; Compatbility:
;; * recognize 'r5rs, etc, and wrap them as a list.
;; * 'begin form of reqs
;; * more agressively extract requires from lang and reqs
(define *make-evaluator
(case-lambda
[(lang reqs . progs)
(with-ns-params
(lambda ()
(let ([beg-req? (and (list? reqs)
(pair? reqs)
(eq? 'begin (car reqs)))]
[reqs (or reqs '())]
[lang (or lang '(begin))])
(keyword-apply
make-evaluator
'(#:allow-read #:requires)
(list (extract-requires lang reqs)
(if beg-req? null reqs))
(case lang
[(r5rs beginner beginner-abbr intermediate intermediate-lambda
advanced)
(list 'special lang)]
[else lang])
(append (if beg-req? (cdr reqs) null) progs)))))]
[(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
(define (extract-requires language requires)
(define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms)
reqs
(loop (cdr forms)
(syntax-case* (car forms) (require) literal-identifier=?
[(require specs ...)
(append (syntax->datum #'(specs ...)) reqs)]
[_else reqs])))))
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
(find-requires (cdr requires))
null)]
[requires (cond [(string? language) requires]
[(not (pair? language)) requires]
[(memq (car language) '(lib file planet quote))
requires]
[(eq? (car language) 'begin)
(append (find-requires (cdr language)) requires)]
[else (error 'extract-requires
"bad language spec: ~e" language)])])
requires)))
(define (make-mz-namespace)
(let ([ns (mz:make-namespace)])
;; Because scheme/sandbox needs scheme/base:
(namespace-attach-module (namespace-anchor->namespace anchor)
'scheme/base ns)
ns))
(define (with-ns-params thunk)
(let ([v (sandbox-namespace-specs)])
(cond [(and (not gui?) (eq? (car v) make-base-namespace))
(parameterize ([sandbox-namespace-specs
(cons make-mz-namespace (cdr v))])
(thunk))]
[(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
(parameterize
([sandbox-namespace-specs
;; Simulate the old make-namespace-with-mred:
(cons (lambda ()
(let ([ns (make-mz-namespace)]
[ns2 ((dynamic-require
'mred 'make-gui-namespace))])
(namespace-attach-module ns2 'mred ns)
(namespace-attach-module ns2 'scheme/class ns)
(parameterize ([current-namespace ns])
(namespace-require 'mred)
(namespace-require 'scheme/class))
ns))
(cdr v))])
(thunk))]
[else (thunk)])))
(define (literal-identifier=? x y)
(or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y))))
(define (extract-requires language requires)
(define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms)
reqs
(loop (cdr forms)
(syntax-case* (car forms) (require) literal-identifier=?
[(require specs ...)
(append (syntax->datum #'(specs ...)) reqs)]
[_else reqs])))))
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
(find-requires (cdr requires))
null)]
[requires (cond [(string? language) requires]
[(not (pair? language)) requires]
[(memq (car language) '(lib file planet quote))
requires]
[(eq? (car language) 'begin)
(append (find-requires (cdr language)) requires)]
[else (error 'extract-requires
"bad language spec: ~e" language)])])
requires))

7
collects/profj/tool.ss
View File

@ -116,6 +116,13 @@
(define mode-surrogate%
(class color:text-mode%
(define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "java"]
[finder:default-filters '(("Any" "*.*"))])
;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name)))
(define/override (on-disable-surrogate text)
(keymap:remove-chained-keymap text java-keymap)
(super on-disable-surrogate text))

154
collects/redex/examples/contracts.ss Normal file
View File

@ -0,0 +1,154 @@
#lang scheme
#|
A core contract calculus, including blame,
with function contracts, (eager) pair contracts,
and a few numeric predicates
|#
(require redex redex/examples/subst)
(reduction-steps-cutoff 10)
(define-language lang
(e (e e ...)
x
number
(λ (x ...) e)
(if e e e)
#t #f
cons car cdr
-> or/c
ac
pred?
(blame l)
l)
(pred? number?
odd?
positive?)
(E (v ... E e ...)
(if E e e)
hole)
(v number
(λ (x ...) e)
cons car cdr
(cons v v)
pred?
-> or/c ac
(-> v ...)
(or/c v ...)
#t #f
l)
(l + -) ;; blame labels
(x variable-not-otherwise-mentioned))
(define reds
(reduction-relation
lang
(--> (in-hole E ((λ (x ...) e) v ...))
(in-hole E (subst-n ((x v) ... e)))
(side-condition (= (length (term (x ...)))
(length (term (v ...)))))
βv)
(--> (in-hole E (if #t e_1 e_2)) (in-hole E e_1) ift)
(--> (in-hole E (if #f e_1 e_2)) (in-hole E e_2) iff)
(--> (in-hole E (number? number)) (in-hole E #t))
(--> (in-hole E (number? v))
(in-hole E #f)
(side-condition (not (number? (term v)))))
(--> (in-hole E (car (cons v_1 v_2)))
(in-hole E v_1))
(--> (in-hole E (cdr (cons v_1 v_2)))
(in-hole E v_2))
(--> (in-hole E (odd? number))
(in-hole E #t)
(side-condition (odd? (term number))))
(--> (in-hole E (odd? v))
(in-hole E #f)
(side-condition (or (not (number? (term v)))
(not (odd? (term v))))))
(--> (in-hole E (positive? number))
(in-hole E #t)
(side-condition (positive? (term number))))
(--> (in-hole E (positive? v))
(in-hole E #f)
(side-condition (or (not (number? (term v)))
(not (positive? (term v))))))
(--> (in-hole E (blame l))
(blame l)
(side-condition (not (equal? (term E) (term hole)))))
(--> (in-hole E (ac pred? v l))
(in-hole E (if (pred? v) v (blame l))))
(--> (in-hole E (ac (-> v_dom ... v_rng) (λ (x ...) e) l))
(in-hole E (λ (x ...) (ac v_rng ((λ (x ...) e) (ac v_dom x l_2) ...) l)))
(where l_2 (¬ l)))
(--> (in-hole E (ac (cons v_1 v_2) (cons v_3 v_4) l))
(in-hole E (cons (ac v_1 v_3 l) (ac v_2 v_4 l))))
(--> (in-hole E (ac (or/c pred? v_1 v_2 ...) v_3 l))
(in-hole E (if (pred? v_3)
v_3
(ac (or/c v_1 v_2 ...) v_3 l))))
(--> (in-hole E (ac (or/c v_1) v_2 l))
(in-hole E (ac v_1 v_2 l)))
))
(define-metafunction lang
[(¬ +) -]
[(¬ -) +])
(test--> reds (term ((λ (x y) x) 1 2)) 1)
(test--> reds (term ((λ (x y) y) 1 2)) 2)
(test--> reds (term (if (if #t #f #t) #f #t)) (term #t))
(test--> reds (term (positive? 1)) #t)
(test--> reds (term (positive? -1)) #f)
(test--> reds (term (positive? (λ (x) x))) #f)
(test--> reds (term (odd? 1)) #t)
(test--> reds (term (odd? 2)) #f)
(test--> reds (term (odd? (λ (x) x))) #f)
(test--> reds (term (car (cdr (cdr (cons 1 (cons 2 (cons 3 #f))))))) 3)
(test--> reds (term ((λ (x) x) (blame -))) (term (blame -)))
(test--> reds (term (ac number? 1 +)) 1)
(test--> reds (term (ac number? (λ (x) x) +)) (term (blame +)))
(test--> reds (term ((ac (-> number? number?) (λ (x) x) +) 1)) 1)
(test--> reds
(term ((ac (-> number? number?) (λ (x) x) +) #f))
(term (blame -)))
(test--> reds
(term ((ac (-> number? number?) (λ (x) #f) +) 1))
(term (blame +)))
(test--> reds
(term (ac (or/c odd? positive?) 1 +))
1)
(test--> reds
(term (ac (or/c odd? positive?) -1 +))
-1)
(test--> reds
(term (ac (or/c odd? positive?) 2 +))
2)
(test--> reds
(term (ac (or/c odd? positive?) -2 +))
(term (blame +)))
(test--> reds
(term (ac (cons odd? positive?) (cons 3 1) +))
(term (cons 3 1)))
(test-results)

79
collects/redex/private/rg-test.ss
View File

@ -65,12 +65,12 @@
(test (pick-from-list '(a b c) (make-random 1)) 'b)
(test (pick-number 3 (make-random .5)) 2)
(test (pick-number 109 (make-random 0 0 .5)) -6)
(test (pick-number 509 (make-random 0 0 1 .5 .25)) 3/7)
(test (pick-number 1009 (make-random 0 0 0 .5 1 .5)) 6.0)
(test (pick-number 2009 (make-random 0 0 0 0 2 .5 1 .5 0 0 .5))
(make-rectangular 6.0 -6))
(test (pick-number 24 (make-random 1/5)) 3)
(test (pick-number 224 (make-random 0 0 1/5)) -5)
(test (pick-number 524 (make-random 0 0 1 1/5 1/5)) 3/4)
(test (pick-number 1624 (make-random 0 0 0 .5 1 .5)) 3.0)
(test (pick-number 2624 (make-random 0 0 0 0 1 1 1/5 1/5 2 .5 0 .5))
(make-rectangular 7/8 -3.0))
(let* ([lits '("bcd" "cbd")]
[chars (sort (unique-chars lits) char<=?)])
@ -101,7 +101,8 @@
(make-exn-not-raised))))]))
(define (patterns . selectors)
(map (λ (selector) (λ (prods . _) (selector prods))) selectors))
(map (λ (selector) (λ (name prods vars size) (list (selector prods))))
selectors))
(define (iterator name items)
(let ([bi (box items)])
@ -124,13 +125,18 @@
(define-syntax decision
(syntax-rules ()
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
(unit (import) (export decisions^)
(define next-variable-decision (decision var))
(define next-non-terminal-decision (decision nt))
(define next-number-decision (decision num))
(define next-string-decision (decision str))
(define next-any-decision (decision any))
(define next-sequence-decision (decision seq))))
(λ (lang)
(unit (import) (export decisions^)
(define next-variable-decision (decision var))
(define next-non-terminal-decision
(if (procedure? nt)
(let ([next (nt lang)])
(λ () next))
(iterator 'nt nt)))
(define next-number-decision (decision num))
(define next-string-decision (decision str))
(define next-any-decision (decision any))
(define next-sequence-decision (decision seq)))))
(let ()
(define-language lc
@ -152,22 +158,13 @@
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'(x x y y))
;; Minimum rhs is chosen with zero size
(test
(let/ec k
(generate/decisions
lc e 0 0
(decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods)))))))
'(x))
;; Size decremented
(let ([size 5])
(test
(let/ec k
(generate/decisions
lc e size 0
(decisions #:nt (list (λ (prods . _) (cadr prods)) (λ (p b s) (k s))))))
(sub1 size))))
; After choosing (e e), size decremented forces each e to x.
(test
(generate/decisions
lc e 1 0
(decisions #:nt (patterns first)
#:var (list (λ _ 'x) (λ _ 'y))))
'(x y)))
;; #:binds
(let ()
@ -230,7 +227,7 @@
(test (generate/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
'(4 4 4 4 (4 4) (4 4)))
(test (exn:fail-message (generate lang e 5))
#rx"generate: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\)")
#rx"generate: unable to generate pattern e")
(test (generate/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4)
@ -460,6 +457,9 @@
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))
; preferred productions
;; current-error-port-output : (-> (-> any) string)
(define (current-error-port-output thunk)
(let ([p (open-output-string)])
@ -484,7 +484,7 @@
(test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised))))
"failed after 1 attempts:\n5\n"))
;; check-metafunction
;; check-metafunction-contract
(let ()
(define-language empty)
(define-metafunction empty
@ -504,19 +504,22 @@
[(i any ...) (any ...)])
;; Dom(f) < Ctc(f)
(test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 2) (λ _ 5))))))
(test (current-error-port-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5))))))
"failed after 1 attempts:\n(5)\n")
;; Rng(f) > Codom(f)
(test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 3))))))
(test (current-error-port-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3))))))
"failed after 1 attempts:\n(3)\n")
;; LHS matches multiple ways
(test (current-error-port-output (λ () (check-metafunction g (decisions #:num (list (λ _ 1) (λ _ 1))
#:seq (list (λ _ 2))))))
(test (current-error-port-output
(λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1))
#:seq (list (λ _ 2))))))
"failed after 1 attempts:\n(1 1)\n")
;; OK -- generated from Dom(h)
(test (check-metafunction h) #t)
(test (check-metafunction-contract h) #t)
;; OK -- generated from pattern (any ...)
(test (check-metafunction i) #t))
(test (check-metafunction-contract i) #t))
;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])

124
collects/redex/private/rg.ss
View File

@ -25,10 +25,12 @@ To do a better job of not generating programs with free variables,
(for-syntax "reduction-semantics.ss")
mrlib/tex-table)
(define random-numbers '(0 1 -1 17 8))
(define (allow-free-var? [random random]) (= 0 (random 30)))
(define (exotic-choice? [random random]) (= 0 (random 5)))
(define (use-lang-literal? [random random]) (= 0 (random 20)))
(define (preferred-production? attempt [random random])
(and (>= attempt preferred-production-threshold)
(zero? (random 2))))
(define (try-to-introduce-binder?) (= 0 (random 2)) #f)
;; unique-chars : (listof string) -> (listof char)
@ -42,12 +44,13 @@ To do a better job of not generating programs with free variables,
(define generation-retries 100)
(define default-check-attempts 100)
(define check-growth-base 5)
(define ascii-chars-threshold 50)
(define tex-chars-threshold 500)
(define chinese-chars-threshold 2000)
(define preferred-production-threshold 3000)
(define (pick-var lang-chars lang-lits bound-vars attempt [random random])
(if (or (null? bound-vars) (allow-free-var? random))
(let ([length (add1 (random-natural 4/5 random))])
@ -80,11 +83,14 @@ To do a better job of not generating programs with free variables,
(define (pick-string lang-chars lang-lits attempt [random random])
(random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt prods bound-vars size)
(define ((pick-nt pref-prods) nt prods bound-vars attempt)
(let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
[do-intro-binder? (and (not (zero? size)) (null? bound-vars)
(not (null? binders)) (try-to-introduce-binder?))])
(pick-from-list (if do-intro-binder? binders prods))))
[do-intro-binder? (and (null? bound-vars)
(not (null? binders))
(try-to-introduce-binder?))])
(cond [do-intro-binder? binders]
[(preferred-production? attempt) (list (hash-ref pref-prods nt))]
[else prods])))
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
@ -124,19 +130,24 @@ To do a better job of not generating programs with free variables,
;; E = 0 => p = 1, which breaks random-natural
(/ 1 (+ (max 1 E) 1)))
; Determines a size measure for numbers, sequences, etc., using the
; attempt count.
(define (attempt->size n)
(inexact->exact (floor (/ (log (add1 n)) (log 5)))))
(define (pick-number attempt [random random])
(cond [(or (< attempt integer-threshold) (not (exotic-choice? random)))
(random-natural (expected-value->p attempt) random)]
(random-natural (expected-value->p (attempt->size attempt)) random)]
[(or (< attempt rational-threshold) (not (exotic-choice? random)))
(random-integer (expected-value->p (- attempt integer-threshold)) random)]
(random-integer (expected-value->p (attempt->size (- attempt integer-threshold))) random)]
[(or (< attempt real-threshold) (not (exotic-choice? random)))
(random-rational (expected-value->p (- attempt rational-threshold)) random)]
(random-rational (expected-value->p (attempt->size (- attempt rational-threshold))) random)]
[(or (< attempt complex-threshold) (not (exotic-choice? random)))
(random-real (expected-value->p (- attempt real-threshold)) random)]
[else (random-complex (expected-value->p (- attempt complex-threshold)) random)]))
(random-real (expected-value->p (attempt->size (- attempt real-threshold))) random)]
[else (random-complex (expected-value->p (attempt->size (- attempt complex-threshold))) random)]))
(define (pick-sequence-length attempt)
(random-natural (expected-value->p (/ (log (add1 attempt)) (log 2)))))
(random-natural (expected-value->p (attempt->size attempt))))
(define (min-prods nt base-table)
(let* ([sizes (hash-ref base-table (nt-name nt))]
@ -144,11 +155,7 @@ To do a better job of not generating programs with free variables,
[zip (λ (l m) (map cons l m))])
(map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
(define (generation-failure pat)
(error 'generate "unable to generate pattern ~s in ~s attempts"
(unparse-pattern pat) generation-retries))
(define (generate* lang pat [decisions@ random-decisions@])
(define (generate* lang pat decisions@)
(define-values/invoke-unit decisions@
(import) (export decisions^))
@ -161,16 +168,17 @@ To do a better job of not generating programs with free variables,
([(nt) (findf (λ (nt) (eq? name (nt-name nt)))
(append (compiled-lang-lang lang)
(compiled-lang-cclang lang)))]
[(rhs)
((next-non-terminal-decision)
(if (zero? size) (min-prods nt base-table) (nt-rhs nt))
bound-vars size)]
[(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
[(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())]
[(term _)
(generate/pred
(rhs-pattern rhs)
(λ (pat) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) pat in-hole) nt-state))
name
(λ ()
(let ([rhs (pick-from-list
(if (zero? size)
(min-prods nt base-table)
((next-non-terminal-decision) name (nt-rhs nt) bound-vars attempt)))])
(((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole)
(make-state (map fvt-entry (rhs-var-info rhs)) #hash()))))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (extend-found-vars fvt-id term state))))
@ -199,11 +207,12 @@ To do a better job of not generating programs with free variables,
(values (cons term terms) (cons (state-env state) envs) fvt))))])
(values seq (make-state fvt (merge-environments envs)))))
(define (generate/pred pat gen pred)
(define (generate/pred name gen pred)
(let retry ([remaining generation-retries])
(if (zero? remaining)
(generation-failure pat)
(let-values ([(term state) (gen pat)])
(error 'generate "unable to generate pattern ~s in ~s attempts"
name generation-retries)
(let-values ([(term state) (gen)])
(if (pred term (state-env state))
(values term state)
(retry (sub1 remaining)))))))
@ -252,10 +261,14 @@ To do a better job of not generating programs with free variables,
(match pat
[`number (values ((next-number-decision) attempt) state)]
[`(variable-except ,vars ...)
(generate/pred 'variable recur/pat (λ (var _) (not (memq var vars))))]
(generate/pred 'variable
(λ () (recur/pat 'variable))
(λ (var _) (not (memq var vars))))]
[`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable recur/pat (λ (var _) (not (memq var (compiled-lang-literals lang)))))]
(generate/pred 'variable
(λ () (recur/pat 'variable))
(λ (var _) (not (memq var (compiled-lang-literals lang)))))]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
@ -263,7 +276,9 @@ To do a better job of not generating programs with free variables,
(values (symbol-append prefix term) state))]
[`string (values ((next-string-decision) lang-chars lang-lits attempt) state)]
[`(side-condition ,pat ,(? procedure? condition))
(generate/pred pat recur/pat (λ (_ env) (condition (bindings env))))]
(generate/pred (unparse-pattern pat)
(λ () (recur/pat pat))
(λ (_ env) (condition (bindings env))))]
[`(name ,(? symbol? id) ,p)
(let-values ([(term state) (recur/pat p)])
(values term (set-env state (make-binder id) term)))]
@ -343,8 +358,8 @@ To do a better job of not generating programs with free variables,
(λ (size attempt)
(let-values ([(term state)
(generate/pred
pat
(λ (pat)
(unparse-pattern pat)
(λ ()
(((generate-pat null size attempt) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
@ -596,7 +611,7 @@ To do a better job of not generating programs with free variables,
[(name/ellipses ...) names/ellipses])
(syntax/loc stx
(check-property
(term-generator lang pat random-decisions@)
(term-generator lang pat random-decisions)
(λ (_ bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
@ -609,7 +624,7 @@ To do a better job of not generating programs with free variables,
#t
(let ([attempt (add1 (- attempts remaining))])
(let-values ([(term bindings)
(generate (floor (/ (log attempt) (log check-growth-base))) attempt)])
(generate (attempt->size attempt) attempt)])
(if (property term bindings)
(loop (sub1 remaining))
(begin
@ -621,7 +636,7 @@ To do a better job of not generating programs with free variables,
(define-syntax generate
(syntax-rules ()
[(_ lang pat size attempt)
(let-values ([(term _) ((term-generator lang pat random-decisions@) size attempt)])
(let-values ([(term _) ((term-generator lang pat random-decisions) size attempt)])
term)]
[(_ lang pat size) (generate lang pat size 0)]))
@ -633,37 +648,39 @@ To do a better job of not generating programs with free variables,
(define-syntax (term-generator stx)
(syntax-case stx ()
[(_ lang pat decisions@)
[(_ lang pat decisions)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts #'lang 'generate)
'generate #t #'pat)])
(syntax/loc stx
(generate*
(parse-language lang)
(reassign-classes (parse-pattern `pattern lang 'top-level))
decisions@)))]))
(let ([lang (parse-language lang)])
(generate*
lang
(reassign-classes (parse-pattern `pattern lang 'top-level))
(decisions lang)))))]))
(define-syntax (check-metafunction stx)
(define-syntax (check-metafunction-contract stx)
(syntax-case stx ()
[(_ name) (syntax/loc stx (check-metafunction name random-decisions@))]
[(_ name decisions@)
[(_ name)
(syntax/loc stx (check-metafunction-contract name random-decisions))]
[(_ name decisions)
(identifier? #'name)
(with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))])
(if (term-fn? tf)
(term-fn-get-id tf)
(raise-syntax-error #f "not a metafunction" stx #'name)))])
(syntax
(let ([lang (metafunc-proc-lang m)]
(syntax/loc stx
(let ([lang (parse-language (metafunc-proc-lang m))]
[dom (metafunc-proc-dom-pat m)])
(check-property
(generate* (parse-language lang)
(generate* lang
(reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level))
decisions@)
(decisions lang))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
100))))]))
default-check-attempts))))]))
(define-signature decisions^
(next-variable-decision
@ -673,11 +690,16 @@ To do a better job of not generating programs with free variables,
next-any-decision
next-string-decision))
(define random-decisions@
(define (random-decisions lang)
(define preferred-productions
(make-immutable-hasheq
(map (λ (nt) (cons (nt-name nt) (pick-from-list (nt-rhs nt))))
(append (compiled-lang-lang lang)
(compiled-lang-cclang lang)))))
(unit (import) (export decisions^)
(define (next-variable-decision) pick-var)
(define (next-number-decision) pick-number)
(define (next-non-terminal-decision) pick-nt)
(define (next-non-terminal-decision) (pick-nt preferred-productions))
(define (next-sequence-decision) pick-sequence-length)
(define (next-any-decision) pick-any)
(define (next-string-decision) pick-string)))
@ -687,7 +709,7 @@ To do a better job of not generating programs with free variables,
pick-nt unique-chars pick-any sexp generate parse-pattern
class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
(struct-out binder) generate/decisions check-metafunction
(struct-out binder) generate/decisions check-metafunction-contract
pick-number parse-language)
(provide/contract

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "26nov2008")
#lang scheme/base (provide stamp) (define stamp "30nov2008")

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

@ -173,6 +173,20 @@
[super-instantiate super-instantiate-param]
[super-new super-new-param])
;;--------------------------------------------------------------------
;; local member name lookup
;;--------------------------------------------------------------------
(define-for-syntax (localize orig-id)
(do-localize orig-id #'validate-local-member))
(define (validate-local-member orig s)
(if (symbol? s)
s
(error 'local-member-name
"used before its definition: ~a"
orig)))
;;--------------------------------------------------------------------
;; class macros
;;--------------------------------------------------------------------

12
collects/scheme/private/classidmap.ss
View File

@ -293,15 +293,17 @@
(define-struct private-name (orig-id gen-id))
(define (localize orig-id)
(define (do-localize orig-id validate-local-member-stx)
(let loop ([id orig-id])
(let ([v (syntax-local-value id (lambda () #f))])
(cond
[(and v (private-name? v))
(list 'unquote
(binding (private-name-orig-id v)
id
(private-name-gen-id v)))]
(list validate-local-member-stx
(list 'quote orig-id)
(binding (private-name-orig-id v)
id
(private-name-gen-id v))))]
[(and (set!-transformer? v)
(s!t? (set!-transformer-procedure v)))
(s!t-ref (set!-transformer-procedure v) 1)]
@ -353,6 +355,6 @@
make-init-error-map make-init-redirect super-error-map
make-with-method-map
flatten-args make-method-call
make-private-name localize
do-localize make-private-name
generate-super-call generate-inner-call
generate-class-expand-context class-top-level-context?)))

10
collects/scheme/sandbox.ss
View File

@ -15,8 +15,9 @@
sandbox-coverage-enabled
sandbox-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-security-guard
sandbox-exit-handler
sandbox-network-guard
sandbox-make-inspector
sandbox-make-logger
@ -138,6 +139,11 @@
(define sandbox-security-guard (make-parameter default-sandbox-guard))
(define (default-sandbox-exit-handler _)
(error 'exit "sandboxed code cannot exit"))
(define sandbox-exit-handler (make-parameter default-sandbox-exit-handler))
(define sandbox-make-inspector (make-parameter make-inspector))
(define sandbox-make-logger (make-parameter current-logger))
@ -594,7 +600,7 @@
[current-command-line-arguments '#()]
;; restrict the sandbox context from this point
[current-security-guard (sandbox-security-guard)]
[exit-handler (lambda x (error 'exit "user code cannot exit"))]
[exit-handler (sandbox-exit-handler)]
[current-inspector ((sandbox-make-inspector))]
[current-logger ((sandbox-make-logger))]
;; This breaks because we need to load some libraries that are trusted

29
collects/scribble/private/manual-form.ss
View File

@ -45,6 +45,13 @@
spec
spec)]
[_ spec])))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for a literal"
stx
id)))
(syntax->list #'(lit ...)))
#'(with-togetherable-scheme-variables
(lit ...)
([form spec] [form spec1] ...
@ -109,13 +116,21 @@
(define-syntax (defform/none stx)
(syntax-case stx ()
[(_ #:literals (lit ...) spec desc ...)
#'(with-togetherable-scheme-variables
(lit ...)
([form spec])
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
(lambda () (list desc ...))))]
(begin
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for a literal"
stx
id)))
(syntax->list #'(lit ...)))
#'(with-togetherable-scheme-variables
(lit ...)
([form spec])
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
(lambda () (list desc ...)))))]
[(_ spec desc ...)
#'(defform/none #:literals () spec desc ...)]))

30
collects/scribblings/gui/dialog-funcs.scrbl
View File

@ -118,22 +118,30 @@ Under Windows, if @scheme[extension] is not @scheme[#f], the returned path
is @scheme[(string-append "*." extension)], then the result pathname is guaranteed
to have an extension mapping @scheme[extension].
Under Mac OS X, if @scheme[extension] is not @scheme[#f]
and @scheme[filters] contains the single
pattern @scheme[(string-append "*." extension)], then the result pathname is
guaranteed to have an extension mapping @scheme[extension]. Otherwise,
@scheme[extension] and @scheme[filters] are ignored.
Under Mac OS X 10.5 and later, if @scheme[extension] is not
@scheme[#f], the returned path will get a default extension if the
user does not supply one. If @scheme[filters] contains as
@scheme["*.*"] pattern, then the user can supply any extension that
is recognized by the system; otherwise, the extension on the returned
path will be either @scheme[extension] or @scheme[_other-extension]
for any @scheme[(string-append "*." _other-extension)] pattern in
@scheme[filters]. In particular, if the only pattern in
@scheme[filters] is empty or contains only @scheme[(string-append
"*." extension)], then the result pathname is guaranteed to have an
extension mapping @scheme[extension].
The @scheme[extension] argument is ignored under X, and @scheme[filters]
can be used to specify glob-patterns.
Under Mac OS X versions before 10.5, the returned path will get a
default extension only if @scheme[extension] is not @scheme[#f] and
@scheme[filters] contains only @scheme[(string-append "*."
extension)].
The @scheme[style] list is treated as for
@scheme[get-file].
The @scheme[extension] argument is ignored under X, and
@scheme[filters] can be used to specify glob-patterns.
The @scheme[style] list is treated as for @scheme[get-file].
See also @scheme[path-dialog%].
}
@defproc[(get-directory [message (or/c string? false/c) #f]

5
collects/scribblings/main/license.scrbl
View File

@ -128,6 +128,11 @@ PLT software includes or extends the following copyrighted material:
Free Software Foundation, Inc.
}
@copyright{
libunwind
Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P.
}
@copyright{
GNU Classpath
GNU Public License with special exception

2
collects/scribblings/reference/filesystem.scrbl
View File

@ -225,7 +225,7 @@ exception.}
@defproc[(delete-file [path path-string?]) void?]{
Feletes the file with path @scheme[path] if it exists, otherwise the
Deletes the file with path @scheme[path] if it exists, otherwise the
@exnraise[exn:fail:filesystem]. If @scheme[path] is a link, the link
is deleted rather than the destination of the link.}

44
collects/scribblings/reference/module-reflect.scrbl
View File

@ -51,9 +51,7 @@ the grammar for @scheme[_module-path] for @scheme[require],
@defparam[current-module-name-resolver proc
(case->
(resolved-module-path?
. -> .
any)
(resolved-module-path? . -> . any)
((or/c module-path? path?)
(or/c #f resolved-module-path?)
(or/c #f syntax?)
@ -316,35 +314,41 @@ See also @scheme[module->language-info].}
@;------------------------------------------------------------------------
@section[#:tag "dynreq"]{Dynamic Module Access}
@defproc[(dynamic-require [mod module-path?][provided (or/c symbol? #f void?)])
@defproc[(dynamic-require [mod module-path?]
[provided (or/c symbol? #f void?)]
[fail-thunk (-> any) (lambda () ....)])
any]{
Dynamically instantiates the module specified by @scheme[mod] for
@tech{phase} 0 in the current namespace's registry, if it is not yet
@tech{instantiate}d. If @scheme[mod] is not a symbol, the current
@tech{module name resolver} may load a module declaration to resolve
it (see @scheme[current-module-name-resolver]); the path is resolved
relative to @scheme[current-load-relative-directory] and/or
@tech{instantiate}d. The current @tech{module name resolver} may load
a module declaration to resolve @scheme[mod] (see
@scheme[current-module-name-resolver]); the path is resolved relative
to @scheme[current-load-relative-directory] and/or
@scheme[current-directory].
If @scheme[provided] is @scheme[#f], then the result is @|void-const|,
and the module is not @tech{visit}ed (see
@secref["mod-parse"]). Otherwise, when @scheme[provided] is a symbol,
the value of the module's export with the given name is returned, and
still the module is not @tech{visit}ed. If the module exports
@scheme[provide] as syntax, then a use of the binding is expanded and
evaluated in a fresh namespace to which the module is attached, which
means that the module is @tech{visit}ed. If the module has no such
exported variable or syntax, or if the variable is protected (see
@secref["modprotect"]), the @exnraise[exn:fail:contract].
and the module is not @tech{visit}ed (see @secref["mod-parse"]).
When @scheme[provided] is a symbol, the value of the module's export
with the given name is returned, and still the module is not
@tech{visit}ed. If the module exports @scheme[provide] as syntax, then
a use of the binding is expanded and evaluated in a fresh namespace to
which the module is attached, which means that the module is
@tech{visit}ed. If the module has no such exported variable or syntax,
then @scheme[fail-thunk] is called; the default @scheme[fail-thunk]
raises @scheme[exn:fail:contract]. If the variable named by
@scheme[provided] is exported protected (see @secref["modprotect"]),
then the @exnraise[exn:fail:contract].
If @scheme[provided] is @|void-const|, then the module is
@tech{visit}ed but not @tech{instantiate}d (see
@secref["mod-parse"]). The result is @|void-const|.}
@tech{visit}ed but not @tech{instantiate}d (see @secref["mod-parse"]),
and the result is @|void-const|.}
@defproc[(dynamic-require-for-syntax [mod module-path?]
[provided (or/c symbol? #f)])
[provided (or/c symbol? #f)]
[fail-thunk (-> any) (lambda () ....)])
any]{
Like @scheme[dynamic-require], but in @tech{phase} 1.}

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

@ -448,6 +448,12 @@ collection libraries (including
@scheme[make-evalautor] for more information.}
@defparam[sandbox-exit-handler handler (any/c . -> . any)]{
A parameter that determines the initial @scheme[(exit-handler)] for
sandboxed evaluations. The default handler simply throws an error.}
@defparam[sandbox-network-guard proc
(symbol?
(or/c (and/c string? immutable?) #f)

22
collects/scribblings/reference/stx-trans.scrbl
View File

@ -396,14 +396,16 @@ exports of the module.
@defproc[(syntax-local-get-shadower [id-stx identifier?]) identifier?]{
Returns @scheme[id-stx] if no binding in the current expansion context
shadows @scheme[id-stx], if @scheme[id-stx] has no module bindings in
its lexical information, and if the current expansion context is not a
shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition
contexts}), if @scheme[id-stx] has no module bindings in its lexical
information, and if the current expansion context is not a
@tech{module context}.
If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the
result is the same as
@scheme[(syntax-local-get-shadower inner-identifier)], except that it
has the location and properties of @scheme[id-stx].
result is the same as @scheme[(syntax-local-get-shadower
inner-identifier)], except that it has the location and properties of
@scheme[id-stx]. When searching for a shadowing binding, bindings from
unsealed @tech{internal-definition contexts} are ignored.
Otherwise, the result is the same as @scheme[id-stx] with its module
bindings (if any) removed from its lexical information, and the
@ -473,7 +475,7 @@ mark}. Multiple applications of the same
and different result procedures use distinct marks.}
@defproc[(make-syntax-delta-introducer [ext-stx syntax?]
[base-stx syntax?]
[base-stx (or/c syntax? #f)]
[phase-level (or/c #f exact-integer?)
(syntax-local-phase-level)])
(syntax? . -> . syntax?)]{
@ -482,10 +484,10 @@ Produces a procedure that behaves like
@scheme[syntax-local-introduce], but using the @tech{syntax marks} of
@scheme[ext-stx] that are not shared with @scheme[base-stx]. If
@scheme[ext-stx] does not extend the set of marks in @scheme[base-stx]
but @scheme[ext-stx] has a module binding in the @tech{phase level}
indicated by @scheme[phase-level], then any marks of @scheme[ext-stx]
that would be needed to preserve its binding are not transferred in an
introduction.
or if @scheme[base-stx] is @scheme[#f], and if @scheme[ext-stx] has a
module binding in the @tech{phase level} indicated by
@scheme[phase-level], then any marks of @scheme[ext-stx] that would be
needed to preserve its binding are not transferred in an introduction.
This procedure is potentially useful when @scheme[_m-id] has a
transformer binding that records some @scheme[_orig-id], and a use of

5
collects/scribblings/tools/unit.scrbl
View File

@ -575,6 +575,11 @@ Returns the currently active tab.
}
@defmethod[#:mode public-final (close-current-tab) void?]{
Closes the current tab, making some other tab visible.
If there is only one tab open, this method does nothing.
}
@defmethod[(get-definitions-canvas)
(is-a?/c drscheme:unit:definitions-canvas%)]{

5
collects/setup/xref.ss
View File

@ -23,8 +23,9 @@
(path-replace-suffix (file-name-from-path (car d))
#"")))])
(and (not (and (len . >= . 3) (memq 'omit (caddr d))))
(let ([d (doc-path dir name flags 'false-if-missing)])
(and d (build-path d "out.sxref")))))))
(let* ([d (doc-path dir name flags 'false-if-missing)]
[p (and d (build-path d "out.sxref"))])
(and p (file-exists? p) p))))))
(define (get-reader-thunks)
(map (lambda (dest)

10
collects/test-engine/test-display.scm
View File

@ -225,7 +225,7 @@
(super-instantiate ())))
(define test-window%
(class* frame% ()
(class* frame:standard-menus% ()
(super-instantiate
((string-constant test-engine-window-title) #f 400 350))
@ -234,11 +234,13 @@
(define disable-func void)
(define close-cleanup void)
(inherit get-area-container)
(define content
(make-object editor-canvas% this #f '(auto-vscroll)))
(make-object editor-canvas% (get-area-container) #f '(auto-vscroll)))
(define button-panel
(make-object horizontal-panel% this
(make-object horizontal-panel% (get-area-container)
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
(define buttons
@ -260,6 +262,8 @@
(switch-func))))
(make-object grow-box-spacer-pane% button-panel)))
(define/override (edit-menu:between-select-all-and-find menu) (void))
(define/public (update-editor e)
(send content set-editor e))

66
collects/tests/mzscheme/sandbox.ss
View File

@ -3,7 +3,7 @@
(Section 'sandbox)
(require mzlib/sandbox)
(require scheme/sandbox)
(let ([ev void])
(define (run thunk)
@ -44,7 +44,7 @@
;; basic stuff, limits
--top--
(set! ev (make-evaluator 'mzscheme '()
(set! ev (make-evaluator 'scheme/base
(make-prog "(define x 1)"
"(define (id x) x)"
"(define (plus1 x) x)"
@ -112,7 +112,7 @@
(set! ev (parameterize ([sandbox-input "3\n"]
[sandbox-output 'string]
[sandbox-error-output current-output-port])
(make-evaluator 'mzscheme '() '(define x 123))))
(make-evaluator 'scheme/base '(define x 123))))
--eval-- (printf "x = ~s\n" x) => (void)
--top-- (get-output ev) => "x = 123\n"
--eval-- (printf "x = ~s\n" x) => (void)
@ -128,7 +128,7 @@
--top--
(set! ev (parameterize ([sandbox-output 'string]
[sandbox-error-output 'string])
(make-evaluator 'mzscheme '())))
(make-evaluator 'scheme/base)))
--eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
--top-- (get-output ev) => "a\n"
(get-error-output ev) => "b\n"
@ -137,7 +137,7 @@
[sandbox-output 'bytes]
[sandbox-error-output current-output-port]
[sandbox-eval-limits '(0.25 10)])
(make-evaluator 'mzscheme '() '(define x 123))))
(make-evaluator 'scheme/base '(define x 123))))
--eval-- (begin (printf "x = ~s\n" x)
(fprintf (current-error-port) "err\n"))
--top-- (get-output ev) => #"x = 123\nerr\n"
@ -163,7 +163,7 @@
(let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
;; o1 -> i1 -ev-> o2 -> i2
(set! ev (parameterize ([sandbox-input i1] [sandbox-output o2])
(make-evaluator 'mzscheme '() '(define x 123))))
(make-evaluator 'scheme/base '(define x 123))))
(t --eval-- (printf "x = ~s\n" x) => (void)
--top-- (read-line i2) => "x = 123"
--eval-- (printf "x = ~s\n" x) => (void)
@ -179,62 +179,63 @@
;; sexprs as a program
--top--
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x))))
(set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))))
--eval--
(id 123) => 123
--top--
(set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x))
'(define fooo 999)))
(set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))
'(define fooo 999)))
--eval--
(id fooo) => 999
;; test source locations too
--top--
(make-evaluator 'mzscheme '() 0 1 2 '(define foo))
(make-evaluator 'scheme/base 0 1 2 '(define foo))
=err> "program:4:0: define"
;; empty program for clean repls
--top--
(set! ev (make-evaluator '(begin) '()))
(set! ev (make-evaluator '(begin)))
--eval--
(define x (+ 1 2 3)) => (void)
x => 6
(define x (+ x 10)) => (void)
x => 16
--top--
(set! ev (make-evaluator 'mzscheme '()))
(set! ev (make-evaluator 'scheme/base))
--eval--
(define x (+ 1 2 3)) => (void)
x => 6
(define x (+ x 10)) => (void)
x => 16
--top--
(set! ev (make-evaluator 'mzscheme '() '(define x (+ 1 2 3))))
(set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3))))
--eval--
(define x (+ x 10)) =err> "cannot re-define a constant"
;; whole program argument
--top--
(set! ev (make-evaluator '(module foo mzscheme (define x 1))))
(set! ev (make-module-evaluator '(module foo scheme/base (define x 1))))
--eval--
x => 1
--top--
(set! ev (make-evaluator '(module foo mzscheme (provide x) (define x 1))))
(set! ev (make-module-evaluator
'(module foo scheme/base (provide x) (define x 1))))
--eval--
x => 1
(define x 2) =err> "cannot re-define a constant"
;; limited FS access, allowed for requires
--top--
(let* ([tmp (find-system-path 'temp-dir)]
[mzlib (path->string (collection-path "mzlib"))]
[list-lib (path->string (build-path mzlib "list.ss"))]
[test-lib (path->string (build-path tmp "sandbox-test.ss"))])
(let* ([tmp (find-system-path 'temp-dir)]
[schemelib (path->string (collection-path "scheme"))]
[list-lib (path->string (build-path schemelib "list.ss"))]
[test-lib (path->string (build-path tmp "sandbox-test.ss"))])
(t --top--
(set! ev (make-evaluator 'mzscheme '()))
(set! ev (make-evaluator 'scheme/base))
--eval--
;; reading from collects is allowed
(list (directory-list ,mzlib))
(list (directory-list ,schemelib))
(file-exists? ,list-lib) => #t
(input-port? (open-input-file ,list-lib)) => #t
;; writing is forbidden
@ -242,15 +243,16 @@
;; reading from other places is forbidden
(directory-list ,tmp) =err> "`read' access denied"
;; no network too
(require scheme/tcp)
(tcp-listen 12345) =err> "network access denied"
--top--
;; reading from a specified require is fine
(with-output-to-file test-lib
(lambda ()
(printf "~s\n" '(module sandbox-test mzscheme
(printf "~s\n" '(module sandbox-test scheme/base
(define x 123) (provide x))))
#:exists 'replace)
(set! ev (make-evaluator 'mzscheme `(,test-lib)))
(set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
--eval--
x => 123
(length (with-input-from-file ,test-lib read)) => 5
@ -259,7 +261,7 @@
--top--
;; should work also for module evaluators
;; --> NO! Shouldn't make user code require whatever it wants
;; (set! ev (make-evaluator `(module foo mzscheme
;; (set! ev (make-evaluator `(module foo scheme/base
;; (require (file ,test-lib)))))
;; --eval--
;; x => 123
@ -271,7 +273,7 @@
(set! ev (parameterize ([sandbox-path-permissions
`((read ,tmp)
,@(sandbox-path-permissions))])
(make-evaluator 'mzscheme '())))
(make-evaluator 'scheme/base)))
--eval--
(length (with-input-from-file ,test-lib read)) => 5
(list? (directory-list ,tmp))
@ -281,24 +283,24 @@
;; languages and requires
--top--
(set! ev (make-evaluator 'r5rs '() "(define x (eq? 'x 'X))"))
(set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))"))
--eval--
x => #t
--top--
(set! ev (make-evaluator 'mzscheme '() "(define l null)"))
(set! ev (make-evaluator 'scheme/base "(define l null)"))
--eval--
(cond [null? l 0]) => 0
(last-pair l) =err> "reference to an identifier"
--top--
(set! ev (make-evaluator 'beginner '() (make-prog "(define l null)"
"(define x 3.5)")))
(set! ev (make-evaluator '(special beginner)
(make-prog "(define l null)" "(define x 3.5)")))
--eval--
(cond [null? l 0]) =err> "expected an open parenthesis"
--top--
(eq? (ev "6") (ev "(sub1 (* 2 3.5))"))
(eq? (ev "6") (ev "(sub1 (* 2 x))"))
--top--
(set! ev (make-evaluator 'mzscheme '(mzlib/list) '()))
(set! ev (make-evaluator 'scheme/base #:requires '(scheme/list)))
--eval--
(last-pair '(1 2 3)) => '(3)
(last-pair null) =err> "expected argument of type"
@ -306,7 +308,7 @@
;; coverage
--top--
(set! ev (parameterize ([sandbox-coverage-enabled #t])
(make-evaluator 'mzscheme '()
(make-evaluator 'scheme/base
(make-prog "(define (foo x) (+ x 1))"
"(define (bar x) (+ x 2))"
"(equal? (foo 3) 4)"))))
@ -327,7 +329,7 @@
(old)
(compile-enforce-module-constants #f)
(compile-allow-set!-undefined #t)))])
(make-evaluator 'mzscheme '() '(define x 123))))
(make-evaluator 'scheme/base '(define x 123))))
--eval--
(set! x 456) ; would be an error without the `enforce' parameter
x => 456

2
collects/wxme/wxme.ss
View File

@ -594,7 +594,7 @@
(call-with-parameterization
plain-params
(lambda ()
(with-handlers ([exn:fail:read? (lambda () 'no-good)])
(with-handlers ([exn:fail:read? (lambda (x) 'no-good)])
(read port)))))
;; ----------------------------------------

10
doc/release-notes/drscheme/HISTORY.txt
View File

@ -1,11 +1,17 @@
------------------------------
Version 4.3
Version 4.1.4
------------------------------
. improved the way extensions are handled when saving files.
------------------------------
Version 4.1.3
------------------------------
. minor bug fixes
------------------------------
Version 4.2
Version 4.1.2
------------------------------
. contract library's function contract

1
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,5 +1,6 @@
Version 4.1.3.3
Added compile-context-preservation-enabled
Added exception-backtrace support for x86_84+JIT
Added scheme/package, scheme/splicing
Version 4.1.3.2

8
src/mred/gc2/Makefile.in
View File

@ -1333,6 +1333,8 @@ xform: $(XSRCS) xsrc/xcglue.c
wx_font.o : $(srcdir)/../../wxmac/src/mac/wx_font.m
$(CXX) -o wx_font.o -c $(srcdir)/../../wxmac/src/mac/wx_font.m
wx_file_dialog.o : $(srcdir)/../../wxmac/src/mac/wx_file_dialog.m
$(CXX) -o wx_file_dialog.o -c $(srcdir)/../../wxmac/src/mac/wx_file_dialog.m
wx_xt_LIBS = ../../wxxt/contrib/xpm/lib/libXpm.@LTA@ @JPEG_A@ @PNG_A@ @ZLIB_A@
wx_mac_LIBS = -framework Carbon -framework Cocoa -framework QuickTime -framework AGL -framework OpenGL @JPEG_A@ @PNG_A@ -lz @LIBS@
@ -1348,7 +1350,7 @@ FOREIGN_USED_OBJSLIB = $(FOREIGN_OBJSLIB)
FOREIGN_NOT_USED_LIB =
FOREIGN_NOT_USED_OBJSLIB =
EXTRA_MZ_OBJS = ../../mzscheme/src/gmp.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
EXTRA_MZ_OBJS = ../../mzscheme/src/gmp.@LTO@ ../../mzscheme/src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
LIBMREDLIBS_a =
LIBMREDLIBS_la = $(LDFLAGS) $(LDLIBS) $(@WXVARIANT@_LIBS)
@ -1377,8 +1379,8 @@ MRFWRES = PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources/PLT_MrEd.rsrc
cp -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources"
/usr/bin/install_name_tool -change "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "../MrEd@MMM@.app/Contents/MacOS/MrEd@MMM@"
$(MRFW) : $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ wx_font.o $(MRFWRES)
$(MREDLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o
$(MRFW) : $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ wx_font.o wx_file_dialog.o $(MRFWRES)
$(MREDLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o wx_file_dialog.o
$(MRFWRES): $(srcdir)/../../mac/osx_appl.ss $(srcdir)/../../mac/cw/MrEd.r
rm -rf PLT_MrEd.framework/Resources PLT_MrEd.framework/PLT_MrEd

4
src/mzscheme/gc2/Makefile.in
View File

@ -351,8 +351,8 @@ FOREIGN_USED_OBJSLIB = $(FOREIGN_OBJSLIB)
FOREIGN_NOT_USED_LIB =
FOREIGN_NOT_USED_OBJSLIB =
EXTRA_OBJS_T = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_LIB)
EXTRA_OBJS_L = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
EXTRA_OBJS_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB)
EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit.@LTO@ gc2.@LTO@

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

@ -707,8 +707,6 @@ long GC_initial_word(int sizeb)
info.size = (sizeb >> gcLOG_WORD_SIZE);
memcpy(&w, &info, sizeof(struct objhead));
((struct objhead*)&w)->size = (sizeb >> gcLOG_WORD_SIZE);
return w;
}
@ -1247,7 +1245,7 @@ typedef struct MarkSegment {
struct MarkSegment *next;
void **top;
void **end;
void **stop_here; /* this is only used for its address */
void *stop_here; /* this is only used for its address */
} MarkSegment;
static THREAD_LOCAL MarkSegment *mark_stack = NULL;
@ -1255,7 +1253,7 @@ static THREAD_LOCAL MarkSegment *mark_stack = NULL;
inline static MarkSegment* mark_stack_create_frame() {
MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE);
mark_frame->next = NULL;
mark_frame->top = PPTR(&(mark_frame->stop_here));
mark_frame->top = &(mark_frame->stop_here);
mark_frame->end = PPTR(NUM(mark_frame) + STACK_PART_SIZE);
return mark_frame;
}
@ -1274,7 +1272,7 @@ inline static void push_ptr(void *ptr)
if(mark_stack->next) {
/* we do, so just use it */
mark_stack = mark_stack->next;
mark_stack->top = PPTR(&(mark_stack->stop_here));
mark_stack->top = &(mark_stack->stop_here);
} else {
/* we don't, so we need to allocate one */
mark_stack->next = mark_stack_create_frame();
@ -1289,7 +1287,7 @@ inline static void push_ptr(void *ptr)
inline static int pop_ptr(void **ptr)
{
if(mark_stack->top == PPTR(&mark_stack->stop_here)) {
if(mark_stack->top == &mark_stack->stop_here) {
if(mark_stack->prev) {
/* if there is a previous page, go to it */
mark_stack = mark_stack->prev;

1
src/mzscheme/sconfig.h
View File

@ -214,6 +214,7 @@
#if defined(__x86_64__)
# define MZ_USE_JIT_X86_64
# define MZ_JIT_USE_MPROTECT
# define MZ_USE_DWARF_LIBUNWIND
#endif
#if defined(powerpc)
# define MZ_USE_JIT_PPC

4
src/mzscheme/src/Makefile.in
View File

@ -51,6 +51,7 @@ OBJS = salloc.@LTO@ \
syntax.@LTO@ \
thread.@LTO@ \
type.@LTO@ \
unwind.@LTO@ \
vector.@LTO@ @EXTRA_GMP_OBJ@
SRCS = $(srcdir)/salloc.c \
@ -92,6 +93,7 @@ SRCS = $(srcdir)/salloc.c \
$(srcdir)/syntax.c \
$(srcdir)/thread.c \
$(srcdir)/type.c \
$(srcdir)/unwind/libunwind.c \
$(srcdir)/vector.c
wrong:
@ -222,6 +224,8 @@ thread.@LTO@: $(srcdir)/thread.c
$(CC) $(CFLAGS) -c $(srcdir)/thread.c -o thread.@LTO@
type.@LTO@: $(srcdir)/type.c
$(CC) $(CFLAGS) -c $(srcdir)/type.c -o type.@LTO@
unwind.@LTO@: $(srcdir)/unwind/libunwind.c $(srcdir)/unwind/libunwind.h $(srcdir)/unwind/libunwind_i.h
$(CC) $(CFLAGS) -c $(srcdir)/unwind/libunwind.c -o unwind.@LTO@
vector.@LTO@: $(srcdir)/vector.c
$(CC) $(CFLAGS) -c $(srcdir)/vector.c -o vector.@LTO@

236
src/mzscheme/src/jit.c
View File

@ -41,6 +41,9 @@
#include "schpriv.h"
#include "schmach.h"
#ifdef MZ_USE_DWARF_LIBUNWIND
# include "unwind/libunwind.h"
#endif
#ifdef MZ_USE_JIT
@ -2315,6 +2318,24 @@ typedef struct {
int direct_prim, direct_native, nontail_self;
} Generate_Call_Data;
static void register_sub_func(mz_jit_state *jitter, void *code, Scheme_Object *protocol)
{
void *code_end;
code_end = jit_get_ip().ptr;
if (jitter->retain_start)
add_symbol((unsigned long)code, (unsigned long)code_end - 1, protocol, 0);
}
static void register_helper_func(mz_jit_state *jitter, void *code)
{
#ifdef MZ_USE_DWARF_LIBUNWIND
/* Null indicates that there's no function name to report, but the
stack should be unwound manually using the JJIT-generated convention. */
register_sub_func(jitter, code, scheme_null);
#endif
}
int do_generate_shared_call(mz_jit_state *jitter, void *_data)
{
Generate_Call_Data *data = (Generate_Call_Data *)_data;
@ -2324,13 +2345,22 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data)
#endif
if (data->is_tail) {
int ok;
void *code;
code = jit_get_ip().ptr;
if (data->direct_prim)
return generate_direct_prim_tail_call(jitter, data->num_rands);
ok = generate_direct_prim_tail_call(jitter, data->num_rands);
else
return generate_tail_call(jitter, data->num_rands, data->direct_native, 1);
ok = generate_tail_call(jitter, data->num_rands, data->direct_native, 1);
register_helper_func(jitter, code);
return ok;
} else {
int ok;
void *code, *code_end;
void *code;
code = jit_get_ip().ptr;
@ -2339,9 +2369,7 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data)
else
ok = generate_non_tail_call(jitter, data->num_rands, data->direct_native, 1, data->multi_ok, data->nontail_self, 1);
code_end = jit_get_ip().ptr;
if (jitter->retain_start)
add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_false, 0);
register_sub_func(jitter, code, scheme_false);
return ok;
}
@ -3923,22 +3951,22 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
if (steps == 1) {
if (name[1] == 'a') {
(void)jit_jmpi(bad_car_code);
(void)jit_calli(bad_car_code);
} else {
(void)jit_jmpi(bad_cdr_code);
(void)jit_calli(bad_cdr_code);
}
} else {
if (name[1] == 'a') {
if (name[2] == 'a') {
(void)jit_jmpi(bad_caar_code);
(void)jit_calli(bad_caar_code);
} else {
(void)jit_jmpi(bad_cadr_code);
(void)jit_calli(bad_cadr_code);
}
} else {
if (name[2] == 'a') {
(void)jit_jmpi(bad_cdar_code);
(void)jit_calli(bad_cdar_code);
} else {
(void)jit_jmpi(bad_cddr_code);
(void)jit_calli(bad_cddr_code);
}
}
}
@ -3980,9 +4008,9 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
reffail = _jit.x.pc;
__END_TINY_JUMPS__(1);
if (name[2] == 'a') {
(void)jit_jmpi(bad_mcar_code);
(void)jit_calli(bad_mcar_code);
} else {
(void)jit_jmpi(bad_mcdr_code);
(void)jit_calli(bad_mcdr_code);
}
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
@ -4015,7 +4043,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
(void)jit_jmpi(bad_vector_length_code);
(void)jit_calli(bad_vector_length_code);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
@ -4045,7 +4073,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
(void)jit_jmpi(bad_unbox_code);
(void)jit_calli(bad_unbox_code);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
@ -4552,9 +4580,9 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
reffail = _jit.x.pc;
__END_TINY_JUMPS__(1);
if (set_mcar)
(void)jit_jmpi(bad_set_mcar_code);
(void)jit_calli(bad_set_mcar_code);
else
(void)jit_jmpi(bad_set_mcdr_code);
(void)jit_calli(bad_set_mcdr_code);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
@ -6443,32 +6471,36 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* *** bad_[m]{car,cdr,...}_code *** */
/* Bad argument is in R0 for car/cdr, R2 otherwise */
for (i = 0; i < 8; i++) {
void *code;
code = jit_get_ip().ptr;
switch (i) {
case 0:
bad_car_code = jit_get_ip().ptr;
bad_car_code = code;
break;
case 1:
bad_cdr_code = jit_get_ip().ptr;
bad_cdr_code = code;
break;
case 2:
bad_caar_code = jit_get_ip().ptr;
bad_caar_code = code;
break;
case 3:
bad_cadr_code = jit_get_ip().ptr;
bad_cadr_code = code;
break;
case 4:
bad_cdar_code = jit_get_ip().ptr;
bad_cdar_code = code;
break;
case 5:
bad_cddr_code = jit_get_ip().ptr;
bad_cddr_code = code;
break;
case 6:
bad_mcar_code = jit_get_ip().ptr;
bad_mcar_code = code;
break;
case 7:
bad_mcdr_code = jit_get_ip().ptr;
bad_mcdr_code = code;
break;
}
mz_prolog(JIT_R1);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
CHECK_RUNSTACK_OVERFLOW();
if ((i < 2) || (i > 5)) {
@ -6509,19 +6541,24 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
break;
}
CHECK_LIMIT();
register_sub_func(jitter, code, scheme_false);
}
/* *** bad_set_{car,cdr}_code *** */
/* Bad argument is in R0, other is in R1 */
for (i = 0; i < 2; i++) {
void *code;
code = jit_get_ip().ptr;
switch (i) {
case 0:
bad_set_mcar_code = jit_get_ip().ptr;
bad_set_mcar_code = code;
break;
case 1:
bad_set_mcdr_code = jit_get_ip().ptr;
bad_set_mcdr_code = code;
break;
}
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
CHECK_RUNSTACK_OVERFLOW();
jit_str_p(JIT_RUNSTACK, JIT_R0);
@ -6541,29 +6578,34 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
break;
}
CHECK_LIMIT();
register_sub_func(jitter, code, scheme_false);
}
/* *** bad_unbox_code *** */
/* R0 is argument */
bad_unbox_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1);
jit_pusharg_i(JIT_R0);
(void)mz_finish(scheme_unbox);
CHECK_LIMIT();
register_sub_func(jitter, bad_unbox_code, scheme_false);
/* *** bad_vector_length_code *** */
/* R0 is argument */
bad_vector_length_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1);
jit_pusharg_i(JIT_R0);
(void)mz_finish(scheme_vector_length);
CHECK_LIMIT();
register_sub_func(jitter, bad_vector_length_code, scheme_false);
/* *** call_original_unary_arith_code *** */
/* R0 is arg, R2 is code pointer, V1 is return address */
for (i = 0; i < 3; i++) {
int argc, j;
void *code, *code_end;
void *code;
for (j = 0; j < 2; j++) {
code = jit_get_ip().ptr;
if (!i) {
@ -6625,9 +6667,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
CHECK_LIMIT();
code_end = jit_get_ip().ptr;
if (jitter->retain_start)
add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_void, 0);
register_sub_func(jitter, code, scheme_void);
}
}
@ -6699,6 +6739,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
mz_pop_locals();
jit_ret();
CHECK_LIMIT();
register_helper_func(jitter, on_demand_jit_code);
/* *** app_values_tail_slow_code *** */
/* RELIES ON jit_prolog(3) FROM ABOVE */
@ -6720,9 +6761,11 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
finish_tail_call_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 0);
CHECK_LIMIT();
register_helper_func(jitter, finish_tail_call_code);
finish_tail_call_fixup_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 2);
CHECK_LIMIT();
register_helper_func(jitter, finish_tail_call_fixup_code);
/* *** get_stack_pointer_code *** */
get_stack_pointer_code = jit_get_ip().ptr;
@ -7592,6 +7635,10 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
if (data->name) {
add_symbol((unsigned long)code, (unsigned long)gdata.code_end - 1, data->name, 1);
} else {
#ifdef MZ_USE_DWARF_LIBUNWIND
add_symbol((unsigned long)code, (unsigned long)gdata.code_end - 1, scheme_null, 1);
#endif
}
has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0);
@ -8091,9 +8138,17 @@ Scheme_Object *scheme_native_stack_trace(void)
{
void *p, *q;
unsigned long stack_end, stack_start, halfway;
Get_Stack_Proc gs;
Scheme_Object *name, *last = NULL, *first = NULL, *tail;
int set_next_push = 0, prev_had_name = 0;
#ifdef MZ_USE_DWARF_LIBUNWIND
unw_context_t cx;
unw_cursor_t c;
int manual_unw;
unw_word_t stack_addr;
#else
Get_Stack_Proc gs;
#endif
int use_unw = 0;
if (!get_stack_pointer_code)
return NULL;
@ -8102,8 +8157,16 @@ Scheme_Object *scheme_native_stack_trace(void)
check_stack();
#endif
#ifdef MZ_USE_DWARF_LIBUNWIND
unw_getcontext(&cx);
unw_init_local(&c, &cx);
use_unw = 1;
p = NULL;
#else
gs = (Get_Stack_Proc)get_stack_pointer_code;
p = gs();
#endif
stack_start = scheme_approx_sp();
if (stack_cache_stack_pos) {
@ -8115,6 +8178,11 @@ Scheme_Object *scheme_native_stack_trace(void)
tail = scheme_null;
}
#ifdef MZ_USE_DWARF_LIBUNWIND
unw_set_safe_pointer_range(stack_start, stack_end);
unw_reset_bad_ptr_flag();
#endif
halfway = STK_DIFF(stack_end, (unsigned long)p) / 2;
if (halfway < CACHE_STACK_MIN_TRIGGER)
halfway = stack_end;
@ -8126,11 +8194,29 @@ Scheme_Object *scheme_native_stack_trace(void)
#endif
}
while (STK_COMP((unsigned long)p, stack_end)
&& STK_COMP(stack_start, (unsigned long)p)) {
q = ((void **)p)[RETURN_ADDRESS_OFFSET];
while (1) {
#ifdef MZ_USE_DWARF_LIBUNWIND
if (use_unw) {
q = (void *)unw_get_ip(&c);
} else {
q = NULL;
}
#endif
if (!use_unw) {
if (!(STK_COMP((unsigned long)p, stack_end)
&& STK_COMP(stack_start, (unsigned long)p)))
break;
q = ((void **)p)[RETURN_ADDRESS_OFFSET];
/* p is the frame pointer for the function called by q,
not for q. */
}
name = find_symbol((unsigned long)q);
#ifdef MZ_USE_DWARF_LIBUNWIND
if (name) manual_unw = 1;
#endif
if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) {
/* Code uses special calling convention */
#ifdef MZ_USE_JIT_PPC
@ -8138,30 +8224,34 @@ Scheme_Object *scheme_native_stack_trace(void)
q = ((void **)p)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE];
#endif
#ifdef MZ_USE_JIT_I386
if (SCHEME_VOIDP(name)) {
/* JIT_LOCAL2 has the next return address */
q = *(void **)p;
if (STK_COMP((unsigned long)q, stack_end)
&& STK_COMP(stack_start, (unsigned long)q)) {
q = ((void **)q)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE];
} else
q = NULL;
# ifdef MZ_USE_DWARF_LIBUNWIND
if (use_unw) {
q = (void *)unw_get_frame_pointer(&c);
} else
# endif
q = *(void **)p;
/* q is now the frame pointer for the former q,
so we can find the actual q */
if (STK_COMP((unsigned long)q, stack_end)
&& STK_COMP(stack_start, (unsigned long)q)) {
if (SCHEME_VOIDP(name)) {
/* JIT_LOCAL2 has the next return address */
q = ((void **)q)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE];
} else {
/* Push after local stack of return-address proc
has the next return address */
q = ((void **)q)[-(3 + LOCAL_FRAME_SIZE + 1)];
}
} else {
/* Push after local stack of return-address proc
has the next return address */
q = *(void **)p;
if (STK_COMP((unsigned long)q, stack_end)
&& STK_COMP(stack_start, (unsigned long)q)) {
q = ((void **)q)[-(3 + LOCAL_FRAME_SIZE + 1)];
} else {
q = NULL;
}
q = NULL;
}
#endif
name = find_symbol((unsigned long)q);
}
if (name) {
if (name && !SCHEME_NULLP(name)) { /* null is used to help unwind without a true name */
name = scheme_make_pair(name, scheme_null);
if (last)
SCHEME_CDR(last) = name;
@ -8204,10 +8294,36 @@ Scheme_Object *scheme_native_stack_trace(void)
prev_had_name = !!name;
q = *(void **)p;
if (STK_COMP((unsigned long)q, (unsigned long)p))
break;
p = q;
#ifdef MZ_USE_DWARF_LIBUNWIND
if (use_unw) {
if (manual_unw) {
/* A JIT-generated function, so we unwind ourselves... */
void **pp;
pp = (void **)unw_get_frame_pointer(&c);
if (!(STK_COMP((unsigned long)pp, stack_end)
&& STK_COMP(stack_start, (unsigned long)pp)))
break;
stack_addr = (unw_word_t)&(pp[RETURN_ADDRESS_OFFSET+1]);
unw_manual_step(&c, &pp[RETURN_ADDRESS_OFFSET], &pp[0],
&stack_addr, &pp[-1], &pp[-2], &pp[-3]);
manual_unw = 0;
} else {
void *prev_q = q;
unw_step(&c);
q = (void *)unw_get_ip(&c);
if ((q == prev_q)
|| unw_reset_bad_ptr_flag())
break;
}
}
#endif
if (!use_unw) {
q = *(void **)p;
if (STK_COMP((unsigned long)q, (unsigned long)p))
break;
p = q;
}
}
if (last)
@ -8237,9 +8353,7 @@ void scheme_dump_stack_trace(void)
stack_end = (unsigned long)scheme_current_thread->stack_start;
while (STK_COMP((unsigned long)p, stack_end)
&& STK_COMP(stack_start, (unsigned long)p)) {
q = ((void **)p)[RETURN_ADDRESS_OFFSET];
&& STK_COMP(stack_start, (unsigned long)p)) {
name = find_symbol((unsigned long)q);
if (SCHEME_FALSEP(name)) {
/* Code uses special calling convention */

2511
src/mzscheme/src/unwind/libunwind.c Normal file
View File

File diff suppressed because it is too large Load Diff

489
src/mzscheme/src/unwind/libunwind.h Normal file
View File

@ -0,0 +1,489 @@
/* libunwind - a platform-independent unwind library
Copyright (C) 2002-2004 Hewlett-Packard Co
Contributed by David Mosberger-Tang <davidm@hpl.hp.com>
This file is part of libunwind.
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */
#ifndef LIBUNWIND_H
#define LIBUNWIND_H
#if defined(linux)
# define LINUX
#endif
#if defined(i386)
# define PLAIN_X86
#endif
#ifdef PLAIN_X86
# define UNW_IP UNW_X86_EIP
#else
# define UNW_IP UNW_X86_64_RIP
#endif
#if defined(__cplusplus) || defined(c_plusplus)
extern "C" {
#endif
#include <inttypes.h>
#define _XOPEN_SOURCE /* needed for Mac OS X */
#define __USE_GNU
#include <ucontext.h>
#undef __USE_GNU
/* XXXXXXXXXXXXXXXXXXXX x86 Target XXXXXXXXXXXXXXXXXXXX */
#ifdef PLAIN_X86
#define UNW_TARGET x86
#define UNW_TARGET_X86 1
/* This needs to be big enough to accommodate "struct cursor", while
leaving some slack for future expansion. Changing this value will
require recompiling all users of this library. Stack allocation is
relatively cheap and unwind-state copying is relatively rare, so we
want to err on making it rather too big than too small. */
#define UNW_TDEP_CURSOR_LEN 127
typedef unsigned long unw_word_t;
typedef long unw_sword_t;
typedef long double unw_tdep_fpreg_t;
typedef enum
{
/* Note: general registers are expected to start with index 0.
This convention facilitates architecture-independent
implementation of the C++ exception handling ABI. See
_Unwind_SetGR() and _Unwind_GetGR() for details.
The described register usage convention is based on "System V
Application Binary Interface, Intel386 Architecture Processor
Supplement, Fourth Edition" at
http://www.linuxbase.org/spec/refspecs/elf/abi386-4.pdf
It would have been nice to use the same register numbering as
DWARF, but that doesn't work because the libunwind requires
that the exception argument registers be consecutive, which the
wouldn't be with the DWARF numbering. */
UNW_X86_EAX, /* scratch (exception argument 1) */
UNW_X86_EDX, /* scratch (exception argument 2) */
UNW_X86_ECX, /* scratch */
UNW_X86_EBX, /* preserved */
UNW_X86_ESI, /* preserved */
UNW_X86_EDI, /* preserved */
UNW_X86_EBP, /* (optional) frame-register */
UNW_X86_ESP, /* (optional) frame-register */
UNW_X86_EIP, /* frame-register */
UNW_X86_EFLAGS, /* scratch (except for "direction", which is fixed */
UNW_X86_TRAPNO, /* scratch */
/* MMX/stacked-fp registers */
UNW_X86_ST0, /* fp return value */
UNW_X86_ST1, /* scratch */
UNW_X86_ST2, /* scratch */
UNW_X86_ST3, /* scratch */
UNW_X86_ST4, /* scratch */
UNW_X86_ST5, /* scratch */
UNW_X86_ST6, /* scratch */
UNW_X86_ST7, /* scratch */
UNW_X86_FCW, /* scratch */
UNW_X86_FSW, /* scratch */
UNW_X86_FTW, /* scratch */
UNW_X86_FOP, /* scratch */
UNW_X86_FCS, /* scratch */
UNW_X86_FIP, /* scratch */
UNW_X86_FEA, /* scratch */
UNW_X86_FDS, /* scratch */
/* SSE registers */
UNW_X86_XMM0_lo, /* scratch */
UNW_X86_XMM0_hi, /* scratch */
UNW_X86_XMM1_lo, /* scratch */
UNW_X86_XMM1_hi, /* scratch */
UNW_X86_XMM2_lo, /* scratch */
UNW_X86_XMM2_hi, /* scratch */
UNW_X86_XMM3_lo, /* scratch */
UNW_X86_XMM3_hi, /* scratch */
UNW_X86_XMM4_lo, /* scratch */
UNW_X86_XMM4_hi, /* scratch */
UNW_X86_XMM5_lo, /* scratch */
UNW_X86_XMM5_hi, /* scratch */
UNW_X86_XMM6_lo, /* scratch */
UNW_X86_XMM6_hi, /* scratch */
UNW_X86_XMM7_lo, /* scratch */
UNW_X86_XMM7_hi, /* scratch */
UNW_X86_MXCSR, /* scratch */
/* segment registers */
UNW_X86_GS, /* special */
UNW_X86_FS, /* special */
UNW_X86_ES, /* special */
UNW_X86_DS, /* special */
UNW_X86_SS, /* special */
UNW_X86_CS, /* special */
UNW_X86_TSS, /* special */
UNW_X86_LDT, /* special */
/* frame info (read-only) */
UNW_X86_CFA,
UNW_TDEP_LAST_REG = UNW_X86_LDT,
UNW_TDEP_IP = UNW_X86_EIP,
UNW_TDEP_SP = UNW_X86_CFA,
UNW_TDEP_EH = UNW_X86_EAX
}
x86_regnum_t;
#endif
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* XXXXXXXXXXXXXXXXXXXX x86_64 Target XXXXXXXXXXXXXXXXXXXX */
#ifndef PLAIN_X86
#define UNW_TARGET x86_64
#define UNW_TARGET_X86_64 1
#define _U_TDEP_QP_TRUE 0 /* see libunwind-dynamic.h */
/* This needs to be big enough to accommodate "struct cursor", while
leaving some slack for future expansion. Changing this value will
require recompiling all users of this library. Stack allocation is
relatively cheap and unwind-state copying is relatively rare, so we
want to err on making it rather too big than too small. */
#define UNW_TDEP_CURSOR_LEN 127
typedef uint64_t unw_word_t;
typedef int64_t unw_sword_t;
typedef long double unw_tdep_fpreg_t;
typedef enum
{
UNW_X86_64_RAX,
UNW_X86_64_RDX,
UNW_X86_64_RCX,
UNW_X86_64_RBX,
UNW_X86_64_RSI,
UNW_X86_64_RDI,
UNW_X86_64_RBP,
UNW_X86_64_RSP,
UNW_X86_64_R8,
UNW_X86_64_R9,
UNW_X86_64_R10,
UNW_X86_64_R11,
UNW_X86_64_R12,
UNW_X86_64_R13,
UNW_X86_64_R14,
UNW_X86_64_R15,
UNW_X86_64_RIP,
/* XXX Add other regs here */
/* frame info (read-only) */
UNW_X86_64_CFA,
UNW_TDEP_LAST_REG = UNW_X86_64_RIP,
UNW_TDEP_IP = UNW_X86_64_RIP,
UNW_TDEP_SP = UNW_X86_64_RSP,
UNW_TDEP_BP = UNW_X86_64_RBP,
UNW_TDEP_EH = UNW_X86_64_RAX
}
x86_64_regnum_t;
#endif
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
#define UNW_TDEP_NUM_EH_REGS 2 /* eax and edx are exception args */
typedef struct unw_tdep_save_loc
{
/* Additional target-dependent info on a save location. */
}
unw_tdep_save_loc_t;
/* On x86, we can directly use ucontext_t as the unwind context. */
typedef ucontext_t unw_tdep_context_t;
/* XXX this is not ideal: an application should not be prevented from
using the "getcontext" name just because it's using libunwind. We
can't just use __getcontext() either, because that isn't exported
by glibc... */
#define unw_tdep_getcontext(uc) (getcontext (uc), 0)
typedef struct unw_dyn_remote_table_info
{
unw_word_t name_ptr; /* addr. of table name (e.g., library name) */
unw_word_t segbase; /* segment base */
unw_word_t table_len; /* must be a multiple of sizeof(unw_word_t)! */
unw_word_t table_data;
}
unw_dyn_remote_table_info_t;
typedef struct unw_dyn_info
{
/* doubly-linked list of dyn-info structures: */
struct unw_dyn_info *next;
struct unw_dyn_info *prev;
unw_word_t start_ip; /* first IP covered by this entry */
unw_word_t end_ip; /* first IP NOT covered by this entry */
unw_word_t gp; /* global-pointer in effect for this entry */
int32_t format; /* real type: unw_dyn_info_format_t */
int32_t pad;
union
{
unw_dyn_remote_table_info_t rti;
}
u;
}
unw_dyn_info_t;
#define UNW_INFO_FORMAT_TABLE 1
#define UNW_INFO_FORMAT_REMOTE_TABLE 2
typedef struct
{
/* no x86-specific auxiliary proc-info */
}
unw_tdep_proc_info_t;
#define UNW_VERSION_MAJOR 0
#define UNW_VERSION_MINOR 99
#define UNW_VERSION_EXTRA 0
#define UNW_VERSION_CODE(maj,min) (((maj) << 16) | (min))
#define UNW_VERSION UNW_VERSION_CODE(UNW_VERSION_MAJOR, UNW_VERSION_MINOR)
#define UNW_PASTE2(x,y) x##y
#define UNW_PASTE(x,y) UNW_PASTE2(x,y)
#define UNW_OBJ(fn) UNW_PASTE(UNW_PREFIX, fn)
#define UNW_ARCH_OBJ(fn) UNW_PASTE(UNW_PASTE(UNW_PASTE(_U,UNW_TARGET),_), fn)
#define UW_NO_SYNC
#include <sys/types.h>
# define UNW_PREFIX UNW_PASTE(UNW_PASTE(_UL,UNW_TARGET),_)
/* Error codes. The unwind routines return the *negated* values of
these error codes on error and a non-negative value on success. */
typedef enum
{
UNW_ESUCCESS = 0, /* no error */
UNW_EUNSPEC, /* unspecified (general) error */
UNW_ENOMEM, /* out of memory */
UNW_EBADREG, /* bad register number */
UNW_EREADONLYREG, /* attempt to write read-only register */
UNW_ESTOPUNWIND, /* stop unwinding */
UNW_EINVALIDIP, /* invalid IP */
UNW_EBADFRAME, /* bad frame */
UNW_EINVAL, /* unsupported operation or bad value */
UNW_EBADVERSION, /* unwind info has unsupported version */
UNW_ENOINFO /* no unwind info found */
}
unw_error_t;
/* The following enum defines the indices for a couple of
(pseudo-)registers which have the same meaning across all
platforms. (RO) means read-only. (RW) means read-write. General
registers (aka "integer registers") are expected to start with
index 0. The number of such registers is architecture-dependent.
The remaining indices can be used as an architecture sees fit. The
last valid register index is given by UNW_REG_LAST. */
typedef enum
{
UNW_REG_IP = UNW_TDEP_IP, /* (rw) instruction pointer (pc) */
UNW_REG_SP = UNW_TDEP_SP, /* (ro) stack pointer */
UNW_REG_EH = UNW_TDEP_EH, /* (rw) exception-handling reg base */
UNW_REG_LAST = UNW_TDEP_LAST_REG
}
unw_frame_regnum_t;
/* Number of exception-handler argument registers: */
#define UNW_NUM_EH_REGS UNW_TDEP_NUM_EH_REGS
typedef enum
{
UNW_CACHE_NONE, /* no caching */
UNW_CACHE_GLOBAL, /* shared global cache */
UNW_CACHE_PER_THREAD /* per-thread caching */
}
unw_caching_policy_t;
typedef int unw_regnum_t;
/* The unwind cursor starts at the youngest (most deeply nested) frame
and is used to track the frame state as the unwinder steps from
frame to frame. It is safe to make (shallow) copies of variables
of this type. */
typedef struct unw_cursor
{
unw_word_t opaque[UNW_TDEP_CURSOR_LEN];
}
unw_cursor_t;
/* This type encapsulates the entire (preserved) machine-state. */
typedef unw_tdep_context_t unw_context_t;
/* unw_getcontext() fills the unw_context_t pointed to by UC with the
machine state as it exists at the call-site. For implementation
reasons, this needs to be a target-dependent macro. It's easiest
to think of unw_getcontext() as being identical to getcontext(). */
#define unw_getcontext(uc) unw_tdep_getcontext(uc)
/* Return 1 if register number R is a floating-point register, zero
otherwise.
This routine is signal-safe. */
#define unw_is_fpreg(r) unw_tdep_is_fpreg(r)
typedef unw_tdep_fpreg_t unw_fpreg_t;
typedef struct unw_addr_space *unw_addr_space_t;
/* Each target may define it's own set of flags, but bits 0-15 are
reserved for general libunwind-use. */
#define UNW_PI_FLAG_FIRST_TDEP_BIT 16
typedef struct unw_proc_info
{
unw_word_t start_ip; /* first IP covered by this procedure */
unw_word_t end_ip; /* first IP NOT covered by this procedure */
unw_word_t lsda; /* address of lang.-spec. data area (if any) */
unw_word_t handler; /* optional personality routine */
unw_word_t gp; /* global-pointer value for this procedure */
unw_word_t flags; /* misc. flags */
int format; /* unwind-info format (arch-specific) */
int unwind_info_size; /* size of the information (if applicable) */
void *unwind_info; /* unwind-info (arch-specific) */
unw_tdep_proc_info_t extra; /* target-dependent auxiliary proc-info */
}
unw_proc_info_t;
/* These are backend callback routines that provide access to the
state of a "remote" process. This can be used, for example, to
unwind another process through the ptrace() interface. */
typedef struct unw_accessors
{
/* REMOVED */
}
unw_accessors_t;
typedef enum unw_save_loc_type
{
UNW_SLT_NONE, /* register is not saved ("not an l-value") */
UNW_SLT_MEMORY, /* register has been saved in memory */
UNW_SLT_REG /* register has been saved in (another) register */
}
unw_save_loc_type_t;
typedef struct unw_save_loc
{
unw_save_loc_type_t type;
union
{
unw_word_t addr; /* valid if type==UNW_SLT_MEMORY */
unw_regnum_t regnum; /* valid if type==UNW_SLT_REG */
}
u;
unw_tdep_save_loc_t extra; /* target-dependent additional information */
}
unw_save_loc_t;
/* These routines work both for local and remote unwinding. */
#define unw_local_addr_space UNW_OBJ(local_addr_space)
#define unw_create_addr_space UNW_OBJ(create_addr_space)
#define unw_destroy_addr_space UNW_OBJ(destroy_addr_space)
#define unw_get_accessors UNW_ARCH_OBJ(get_accessors)
#define unw_init_local UNW_OBJ(init_local)
#define unw_init_remote UNW_OBJ(init_remote)
#define unw_step UNW_OBJ(step)
#define unw_resume UNW_OBJ(resume)
#define unw_get_proc_info UNW_OBJ(get_proc_info)
#define unw_get_proc_info_by_ip UNW_OBJ(get_proc_info_by_ip)
#define unw_get_reg UNW_OBJ(get_reg)
#define unw_set_reg UNW_OBJ(set_reg)
#define unw_get_fpreg UNW_OBJ(get_fpreg)
#define unw_set_fpreg UNW_OBJ(set_fpreg)
#define unw_get_save_loc UNW_OBJ(get_save_loc)
#define unw_is_signal_frame UNW_OBJ(is_signal_frame)
#define unw_get_proc_name UNW_OBJ(get_proc_name)
#define unw_set_caching_policy UNW_OBJ(set_caching_policy)
#define unw_regname UNW_ARCH_OBJ(regname)
#define unw_flush_cache UNW_ARCH_OBJ(flush_cache)
#define unw_strerror UNW_ARCH_OBJ(strerror)
extern unw_addr_space_t unw_create_addr_space (unw_accessors_t *, int);
extern void unw_destroy_addr_space (unw_addr_space_t);
extern unw_accessors_t *unw_get_accessors (unw_addr_space_t);
extern void unw_flush_cache (unw_addr_space_t, unw_word_t, unw_word_t);
extern int unw_set_caching_policy (unw_addr_space_t, unw_caching_policy_t);
extern const char *unw_regname (unw_regnum_t);
extern int unw_init_local (unw_cursor_t *, unw_context_t *);
extern int unw_init_remote (unw_cursor_t *, unw_addr_space_t, void *);
extern int unw_step (unw_cursor_t *);
extern int unw_resume (unw_cursor_t *);
extern int unw_get_proc_info (unw_cursor_t *, unw_proc_info_t *);
extern int unw_get_proc_info_by_ip (unw_addr_space_t, unw_word_t,
unw_proc_info_t *, void *);
extern int unw_get_reg (unw_cursor_t *, int, unw_word_t *);
extern int unw_set_reg (unw_cursor_t *, int, unw_word_t);
extern int unw_get_fpreg (unw_cursor_t *, int, unw_fpreg_t *);
extern int unw_set_fpreg (unw_cursor_t *, int, unw_fpreg_t);
extern int unw_get_save_loc (unw_cursor_t *, int, unw_save_loc_t *);
extern int unw_is_signal_frame (unw_cursor_t *);
extern int unw_get_proc_name (unw_cursor_t *, char *, size_t, unw_word_t *);
extern unw_word_t unw_get_ip(unw_cursor_t *);
extern unw_word_t unw_get_frame_pointer(unw_cursor_t *);
extern const char *unw_strerror (int);
void unw_manual_step(unw_cursor_t *_c,
void *ip_addr,
void *bp_addr,
void *sp_addr,
void *bx_addr,
void *r12_addr,
void *r13_addr);
extern unw_addr_space_t unw_local_addr_space;
extern int unw_reset_bad_ptr_flag();
extern void unw_set_safe_pointer_range(unw_word_t s, unw_word_t e);
#define unw_tdep_is_fpreg UNW_ARCH_OBJ(is_fpreg)
extern int unw_tdep_is_fpreg (int);
#if defined(__cplusplus) || defined(c_plusplus)
}
#endif
#endif /* LIBUNWIND_H */

1182
src/mzscheme/src/unwind/libunwind_i.h Normal file
View File

File diff suppressed because it is too large Load Diff

2
src/worksp/mred/mred.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="4.1.3.2"
version="4.1.3.3"
processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd"
type="win32"

8
src/worksp/mred/mred.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,2
PRODUCTVERSION 4,1,3,2
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\0"
VALUE "InternalName", "MrEd\0"
VALUE "FileVersion", "4, 1, 3, 2\0"
VALUE "FileVersion", "4, 1, 3, 3\0"
VALUE "LegalCopyright", "Copyright © 1995-2008\0"
VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 2\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,2
PRODUCTVERSION 4,1,3,2
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 1, 3, 2"
VALUE "FileVersion", "4, 1, 3, 3"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 1, 3, 2"
VALUE "ProductVersion", "4, 1, 3, 3"
END
END
BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.4.1.3.2 = s 'MzObj Class'
MzCOM.MzObj.4.1.3.3 = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
}
MzCOM.MzObj = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.4.1.3.2'
CurVer = s 'MzCOM.MzObj.4.1.3.3'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.4.1.3.2'
ProgID = s 'MzCOM.MzObj.4.1.3.3'
VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

8
src/worksp/mzscheme/mzscheme.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,2
PRODUCTVERSION 4,1,3,2
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\0"
VALUE "InternalName", "MzScheme\0"
VALUE "FileVersion", "4, 1, 3, 2\0"
VALUE "FileVersion", "4, 1, 3, 3\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 2\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,2
PRODUCTVERSION 4,1,3,2
FILEVERSION 4,1,3,3
PRODUCTVERSION 4,1,3,3
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif
VALUE "FileVersion", "4, 1, 3, 2\0"
VALUE "FileVersion", "4, 1, 3, 3\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0"
#endif
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 2\0"
VALUE "ProductVersion", "4, 1, 3, 3\0"
END
END
BLOCK "VarFileInfo"

5
src/wxmac/src/Makefile.in
View File

@ -146,6 +146,7 @@ OBJS = \
wx_xbm.o \
\
wx_font.o \
wx_file_dialog.o \
\
$(MIN_OBJS)
@ -385,9 +386,11 @@ ALSelectors.o : $(ALISTDEPS) $(ALISTDIR)/ALSelectors.c
$(CC) $(ALISTCCFLAGS) -o ALSelectors.o -c $(ALISTDIR)/ALSelectors.c
########################################
# Cocoa fonts #
# Cocoa #
########################################
wx_file_dialog.o : $(srcdir)/mac/wx_file_dialog.m
$(CXX) -o wx_file_dialog.o -c $(srcdir)/mac/wx_file_dialog.m
wx_font.o : $(srcdir)/mac/wx_font.m
$(CXX) -o wx_font.o -c $(srcdir)/mac/wx_font.m

119
src/wxmac/src/mac/wx_dialg.cc
View File

@ -585,7 +585,8 @@ static void ExtensionCallback(NavEventCallbackMessage callBackSelector,
}
break;
case kNavCBStart:
{
if (0) {
/* No longer needed */
EventTypeSpec spec[1];
spec[0].eventClass = kEventClassKeyboard;
spec[0].eventKind = kEventRawKeyDown;
@ -638,6 +639,40 @@ static char *GetNthPath(NavReplyRecord *reply, int index)
static NavEventUPP extProc = NewNavEventUPP((NavEventProcPtr)ExtensionCallback);
static WindowPtr extract_sheet_parent(wxWindow *parent)
{
if (parent) {
wxFrame *f;
if (wxSubType(parent->__type, wxTYPE_FRAME)) {
f = (wxFrame *)parent;
} else if (wxSubType(parent->__type, wxTYPE_DIALOG_BOX)) {
f = (wxFrame *)parent->GetParent();
} else
f = NULL;
if (f)
f = f->GetSheetParent();
if (f) {
CGrafPtr graf;
wxMacDC *mdc;
WindowPtr win;
mdc = f->MacDC();
graf = mdc->macGrafPort();
win = GetWindowFromPort(graf);
if (IsWindowVisible(win))
return win;
}
}
return NULL;
}
extern "C" void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext);
char *wxFileSelector(char *message, char *default_path,
char *default_filename, char *default_extension,
char *wildcard, int flags,
@ -652,6 +687,8 @@ char *wxFileSelector(char *message, char *default_path,
NavUserAction action;
NavReplyRecord *reply;
char *temp;
char **acceptable_extensions = NULL;
int num_acceptable = 0, single_type = 0;
if (!navinited) {
if (!NavLoad()) {
@ -691,10 +728,14 @@ char *wxFileSelector(char *message, char *default_path,
if (s2) {
int len, flen;
len = strlen(default_extension);
if ((s1[0] == '*')
if ((s1[0] == '*')
&& (s1[1] == '.')
&& ((s2 - s1) == (len + 2))
&& !strncmp(default_extension, s1+2, len)) {
&& !strncmp(default_extension, s1+2, len)
&& (!s1[len+2]
|| ((s1[len+2] == '|')
&& !s1[len+3]))) {
single_type = 1;
dialogOptions.optionFlags |= kNavPreserveSaveFileExtension;
/* Make sure initial name has specified extension: */
if (!default_filename)
@ -714,6 +755,44 @@ char *wxFileSelector(char *message, char *default_path,
}
}
}
if (!single_type) {
/* Extract defaults */
int cnt = 0;
char **a, *ext;
s1 = wildcard;
while (s1) {
s1 = strchr(s1, '|');
if (s1) {
if ((s1[1] == '*')
&& (s1[2] == '.')) {
cnt++;
s1 = strchr(s1 + 1, '|');
if (s1) s1++;
} else
s1 = 0;
}
}
if (cnt) {
int i;
a = new WXGC_PTRS char*[cnt];
s1 = wildcard;
for (i = 0; i < cnt; i++) {
s1 = strchr(s1, '|');
s1 += 3;
s2 = strchr(s1, '|');
if (!s2)
s2 = s1 + strlen(s1);
ext = new WXGC_ATOMIC char[s2 - s1 + 1];
memcpy(ext, s1, s2 - s1);
ext[s2 - s1] = 0;
a[i] = ext;
s1 = s2 + 1;
}
acceptable_extensions = a;
num_acceptable = cnt;
}
}
}
if (default_filename) {
@ -723,30 +802,13 @@ char *wxFileSelector(char *message, char *default_path,
cbi->has_parent = 1;
if (parent) {
wxFrame *f;
if (wxSubType(parent->__type, wxTYPE_FRAME)) {
f = (wxFrame *)parent;
} else if (wxSubType(parent->__type, wxTYPE_DIALOG_BOX)) {
f = (wxFrame *)parent->GetParent();
} else
f = NULL;
if (f)
f = f->GetSheetParent();
if (f) {
CGrafPtr graf;
wxMacDC *mdc;
WindowPtr win;
mdc = f->MacDC();
graf = mdc->macGrafPort();
win = GetWindowFromPort(graf);
if (IsWindowVisible(win)) {
dialogOptions.parentWindow = win;
dialogOptions.modality = kWindowModalityWindowModal;
cbi->has_parent = 1;
}
WindowPtr win;
win = extract_sheet_parent(parent);
if (win) {
dialogOptions.parentWindow = win;
dialogOptions.modality = kWindowModalityWindowModal;
cbi->has_parent = 1;
}
}
@ -767,6 +829,9 @@ char *wxFileSelector(char *message, char *default_path,
extProc, cbi_sr,
&outDialog);
cbi->is_put = 1;
if (derr == noErr)
wx_set_nav_file_types(outDialog, num_acceptable, acceptable_extensions,
default_extension);
}
cbi->dialog = outDialog;

51
src/wxmac/src/mac/wx_file_dialog.m Normal file
View File

@ -0,0 +1,51 @@
/* Set options for the Cocoa file dialog */
#import <Cocoa/Cocoa.h>
#include <Carbon/Carbon.h>
void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext)
{
SInt32 versionMajor, versionMinor;
Gestalt(gestaltSystemVersionMajor, &versionMajor);
Gestalt(gestaltSystemVersionMinor, &versionMinor);
if ((versionMajor >= 10)
&& (versionMinor >= 5)) {
if (cnt) {
id pool = [[NSAutoreleasePool alloc] init];
id *objs;
int i, j, allow_others = 0;
NSArray *a;
NSSavePanel *sp = (NSSavePanel *)dlg;
for (i = 0; i < cnt; i++) {
if (!strcmp(exts[i], "*"))
allow_others = 1;
}
objs = (id *)malloc(sizeof(id) * (1 + (cnt - allow_others)));
j = 0;
objs[j++] = [[NSString alloc] initWithUTF8String: def_ext];
for (i = 0; i < cnt; i++) {
if (strcmp(exts[i], "*"))
objs[j++] = [[NSString alloc] initWithUTF8String: exts[i]];
}
a = [NSArray arrayWithObjects:objs count:j];
[sp setAllowedFileTypes:a];
[sp setCanSelectHiddenExtension:TRUE];
if (!allow_others)
[sp setAllowsOtherFileTypes:FALSE];
for (i = 0; i < j; i++) {
[objs[i] release];
}
free(objs);
[pool release];
}
}
}

2
src/wxmac/src/mac/wx_font.m
View File

@ -1,6 +1,6 @@
/* The easiest way to find out whether a font is fixed-width is to
jump over the to Coacao world. The ATS and Cocoa worlds are
jump over the to Cocao world. The ATS and Cocoa worlds are
connected through the PostScript name of a font. */
#import <Cocoa/Cocoa.h>