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

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

@ -1182,7 +1182,8 @@
(values lexeme type paren start end))))) (values lexeme type paren start end)))))
(define/override (put-file text sup directory default-name) (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 ;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name))) (sup directory default-name)))
@ -1224,8 +1225,6 @@
(define text-mode% (text-mode-mixin color:text-mode%)) (define text-mode% (text-mode-mixin color:text-mode%))
(define (setup-keymap keymap) (define (setup-keymap keymap)
(let ([add-pos-function (let ([add-pos-function
(λ (name call-method) (λ (name call-method)

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

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

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

@ -166,7 +166,7 @@
raise raise-exceptions raise-type-error error exit let/ec raise raise-exceptions raise-type-error error exit let/ec
;; no equiv because I haven't completely thought through these ;; 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) procedure-arity-includes? dynamic-require)
(provide #%app #%top #%datum require require-for-syntax provide define) (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" (module frtime "mzscheme-utils.ss"
(require "lang-ext.ss") (require (all-except "lang-ext.ss" lift deep-value-now))
(require "frp-snip.ss") (require "frp-snip.ss")
(require "ft-qq.ss")
(require (as-is:unchecked "frp-core.ss" (require (as-is:unchecked "frp-core.ss"
event-set? signal-value)) event-set? signal-value))
@ -18,7 +17,6 @@
;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list)) ;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list))
(provide value-nowable? behaviorof (provide value-nowable? behaviorof
(all-from "lang-ext.ss")
(all-from "mzscheme-utils.ss") (all-from "mzscheme-utils.ss")
(all-from-except "lang-ext.ss" lift) (all-from "frp-snip.ss")))
(all-from "frp-snip.ss")
(all-from "ft-qq.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)))

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

@ -1,7 +1,6 @@
(module mixin-macros frtime (module mixin-macros frtime
(require mzlib/class) (require mzlib/class)
(define-syntax events->callbacks (define-syntax events->callbacks
(lambda (stx) (lambda (stx)
(syntax-case stx (carries-args-for) (syntax-case stx (carries-args-for)
@ -47,10 +46,14 @@
(define name-e (event-receiver)) (define name-e (event-receiver))
(define processed-events (processor name-e)) (define processed-events (processor name-e))
(super-new) (super-new)
(define ft-last-evt #f)
;what about when the super call returns an error? ;what about when the super call returns an error?
(define/override method-name (define/override method-name
(lambda args (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))) (super method-name . args)))
(define/public (g-name) processed-events))))]))) (define/public (g-name) processed-events))))])))

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

@ -15,9 +15,52 @@
(define name (define name
(let ([val (parameterize ([snap? #f]) (let ([val (parameterize ([snap? #f])
expr)]) 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 (case-lambda
[(obj) (deep-value-now obj empty)] [(obj) (deep-value-now obj empty)]
[(obj table) [(obj table)
@ -166,7 +209,7 @@
(make-events-now (make-events-now
(if first-time (if first-time
empty empty
(list (deep-value-now bh)))) (list (deep-value-now bh empty))))
(set! first-time #f)))) (set! first-time #f))))
b)) b))
@ -389,7 +432,7 @@
[consumer (proc->signal [consumer (proc->signal
(lambda () (lambda ()
(let* ([now (current-inexact-milliseconds)] (let* ([now (current-inexact-milliseconds)]
[new (deep-value-now beh)] [new (deep-value-now beh empty)]
[ms (value-now ms-b)]) [ms (value-now ms-b)])
(when (not (equal? new (car (mcar last)))) (when (not (equal? new (car (mcar last))))
(set-mcdr! last (mcons (cons new now) (set-mcdr! last (mcons (cons new now)
@ -786,6 +829,7 @@
(provide raise-exceptions (provide raise-exceptions
deep-value-now
nothing nothing
nothing? nothing?
;general-event-processor ;general-event-processor

4
collects/frtime/lang.ss
View File

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

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

@ -1,11 +1,9 @@
(module mzscheme-core mzscheme (module mzscheme-core mzscheme
;(require (all-except mzscheme provide module if require letrec null?)
;mzlib/list)
(require-for-syntax frtime/struct mzlib/list) (require-for-syntax frtime/struct mzlib/list)
(require mzlib/list (require mzlib/list
frtime/frp-core frtime/frp-core
(only srfi/43/vector-lib vector-any) (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)) (only mzlib/etc build-vector rec build-list opt-lambda identity))
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
@ -23,10 +21,6 @@
... ...
expr ...)])) expr ...)]))
;(define-syntax frp:match
; (syntax-rules ()
; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
(define (->boolean x) (define (->boolean x)
(if x #t #f)) (if x #t #f))
@ -42,7 +36,6 @@
[(_ test-exp then-exp else-exp undef-exp) [(_ test-exp then-exp else-exp undef-exp)
(super-lift (super-lift
(lambda (b) (lambda (b)
;(printf "~n\t******\tIF CONDITION IS ~a~n" b)
(cond (cond
[(undefined? b) undef-exp] [(undefined? b) undef-exp]
[b then-exp] [b then-exp]
@ -93,21 +86,6 @@
(map translate-clause (syntax->list #'(clause ...)))]) (map translate-clause (syntax->list #'(clause ...)))])
#'(case-lambda #'(case-lambda
new-clause ...))])) 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? (define any-nested-reactivity?
(opt-lambda (obj [mem empty]) (opt-lambda (obj [mem empty])
@ -141,7 +119,8 @@
[(absent) (hash-table-put! deps obj 'new)] [(absent) (hash-table-put! deps obj 'new)]
[(old) (hash-table-put! deps obj 'alive)] [(old) (hash-table-put! deps obj 'alive)]
[(new) (void)]) [(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) [(cons? obj)
(let* ([result (cons #f #f)] (let* ([result (cons #f #f)]
[new-table (cons (list obj result) table)] [new-table (cons (list obj result) table)]
@ -178,48 +157,9 @@
result)))] result)))]
[else obj])) [else obj]))
(define (deep-value-now obj table) (define (public-dvn obj)
(cond (do-in-manager-after
[(assq obj table) => second] (deep-value-now obj empty)))
[(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 any-spinal-reactivity? (define any-spinal-reactivity?
(opt-lambda (lst [mem empty]) (opt-lambda (lst [mem empty])
@ -261,8 +201,7 @@
(iq-enqueue rtn))] (iq-enqueue rtn))]
[(alive) (hash-table-put! deps k 'old)] [(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k) [(old) (hash-table-remove! deps k)
(unregister rtn k)]))) (unregister rtn k)])))))))
#;(printf "count = ~a~n" (hash-table-count deps))))))
(do-in-manager (do-in-manager
(iq-enqueue rtn)) (iq-enqueue rtn))
rtn) rtn)
@ -284,8 +223,7 @@
(register rtn k)] (register rtn k)]
[(alive) (hash-table-put! deps k 'old)] [(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k) [(old) (hash-table-remove! deps k)
(unregister rtn k)]))) (unregister rtn k)])))))))
#;(printf "count = ~a~n" (hash-table-count deps))))))
(do-in-manager (do-in-manager
(iq-enqueue rtn)) (iq-enqueue rtn))
rtn)) rtn))
@ -299,7 +237,6 @@
(begin0 (begin0
(let/ec esc (let/ec esc
(begin0 (begin0
;;(with-handlers ([exn:fail? (lambda (exn) #f)])
(proc (lambda (obj) (proc (lambda (obj)
(if (behavior? obj) (if (behavior? obj)
(begin (begin
@ -320,8 +257,7 @@
(case v (case v
[(new alive) (hash-table-put! deps k 'old)] [(new alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k) [(old) (hash-table-remove! deps k)
(unregister rtn k)]))) (unregister rtn k)])))))))))
#;(printf "count = ~a~n" (hash-table-count deps))))))))
(iq-enqueue rtn) (iq-enqueue rtn)
rtn)) rtn))
@ -334,29 +270,14 @@
;; CONS ;; CONS
(define (frp:cons f r) (define frp:cons cons)
(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 (make-accessor acc) (define (make-accessor acc)
(lambda (v) (lambda (v)
(let loop ([v v]) (let loop ([v v])
(cond (cond
[(signal:compound? v) (acc (signal:compound-content v))] [(signal:compound? v) (acc (signal:compound-content v))]
[(signal? v) #;(printf "access to ~a in ~a~n" acc [(signal? v) (super-lift acc v)]
(value-now/no-copy v))
#;(lift #t acc v)
#;(switch ((changes v) . ==> . acc) (acc (value-now v)))
(super-lift acc v)]
[(signal:switching? v) (super-lift [(signal:switching? v) (super-lift
(lambda (_) (lambda (_)
(loop (unbox (signal:switching-current v)))) (loop (unbox (signal:switching-current v))))
@ -391,9 +312,6 @@
[else (error "list-match: expected a list, got ~a" lst)])) [else (error "list-match: expected a list, got ~a" lst)]))
lst)) lst))
#;(define (frp:append . args)
(apply lift #t append args))
(define frp:append (define frp:append
(case-lambda (case-lambda
[() ()] [() ()]
@ -401,18 +319,9 @@
[(lst1 lst2 . lsts) [(lst1 lst2 . lsts)
(list-match lst1 (list-match lst1
(lambda (f r) (cons f (apply frp:append r lst2 lsts))) (lambda (f r) (cons f (apply frp:append r lst2 lsts)))
(lambda () (apply frp:append 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)))]))
(define frp:list list (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* (define frp:list*
(lambda elts (lambda elts
@ -426,7 +335,6 @@
(define (frp:list? itm) (define (frp:list? itm)
(if (signal:compound? itm) (if (signal:compound? itm)
(let ([ctnt (signal:compound-content itm)]) (let ([ctnt (signal:compound-content itm)])
; (let ([ctnt (value-now itm)])
(if (cons? ctnt) (if (cons? ctnt)
(frp:list? (cdr ctnt)) (frp:list? (cdr ctnt))
#f)) #f))
@ -442,23 +350,10 @@
(define frp:vector vector) (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) (define (frp:vector-ref v i)
(cond (cond
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v) [(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)]
[else (lift #t vector-ref v i)])) [else (lift #t vector-ref v i)]))
@ -472,15 +367,6 @@
args)]) args)])
(values (values
desc 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) (lambda (v) (if (signal:compound? v)
(pred (value-now/no-copy v)) (pred (value-now/no-copy v))
@ -646,14 +532,13 @@
#%top-interaction #%top-interaction
raise-reactivity raise-reactivity
raise-list-for-apply raise-list-for-apply
deep-value-now (rename public-dvn deep-value-now)
any-nested-reactivity? any-nested-reactivity?
compound-lift compound-lift
list-match list-match
(rename frp:if if) (rename frp:if if)
(rename frp:lambda lambda) (rename frp:lambda lambda)
(rename frp:case-lambda case-lambda) (rename frp:case-lambda case-lambda)
;(rename frp:apply apply)
(rename frp:letrec letrec) (rename frp:letrec letrec)
(rename frp:cons cons) (rename frp:cons cons)
(rename frp:car car) (rename frp:car car)

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

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

4
collects/frtime/reactive.ss
View File

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

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

@ -1072,6 +1072,7 @@
(send off-sd set-delta-background "darkblue")) (send off-sd set-delta-background "darkblue"))
;; picture 5.png ;; picture 5.png
#;
(begin (begin
(send on-sd set-delta-foreground (make-object color% 0 80 0)) (send on-sd set-delta-foreground (make-object color% 0 80 0))
(send off-sd set-delta-foreground "orange") (send off-sd set-delta-foreground "orange")
@ -1082,7 +1083,13 @@
(send on-sd set-delta-foreground "black") (send on-sd set-delta-foreground "black")
(send off-sd set-delta-foreground "orange") (send off-sd set-delta-foreground "orange")
(send off-sd set-delta-background "black")) (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))))))))) (send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht (when ht

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

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

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

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

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

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

64
collects/mzlib/sandbox.ss
View File

@ -1,7 +1,9 @@
(module sandbox scheme/base #lang scheme/base
(require scheme/sandbox
(require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace))) (prefix-in mz: (only-in mzscheme make-namespace)))
(provide sandbox-init-hook
(provide sandbox-init-hook
sandbox-reader sandbox-reader
sandbox-input sandbox-input
sandbox-output sandbox-output
@ -29,13 +31,13 @@
(rename-out [*make-evaluator make-evaluator] (rename-out [*make-evaluator make-evaluator]
[gui? mred?])) [gui? mred?]))
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
;; Compatbility: ;; Compatbility:
;; * recognize 'r5rs, etc, and wrap them as a list. ;; * recognize 'r5rs, etc, and wrap them as a list.
;; * 'begin form of reqs ;; * 'begin form of reqs
;; * more agressively extract requires from lang and reqs ;; * more agressively extract requires from lang and reqs
(define *make-evaluator (define *make-evaluator
(case-lambda (case-lambda
[(lang reqs . progs) [(lang reqs . progs)
(with-ns-params (with-ns-params
@ -51,41 +53,34 @@
(list (extract-requires lang reqs) (list (extract-requires lang reqs)
(if beg-req? null reqs)) (if beg-req? null reqs))
(case lang (case lang
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced) [(r5rs beginner beginner-abbr intermediate intermediate-lambda
advanced)
(list 'special lang)] (list 'special lang)]
[else lang]) [else lang])
(append (append (if beg-req? (cdr reqs) null) progs)))))]
(if beg-req? (cdr reqs) null) [(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
progs)))))]
[(mod)
(with-ns-params
(lambda ()
(make-module-evaluator mod)))]))
(define (make-mz-namespace) (define (make-mz-namespace)
(let ([ns (mz:make-namespace)]) (let ([ns (mz:make-namespace)])
;; Because scheme/sandbox needs scheme/base: ;; Because scheme/sandbox needs scheme/base:
(namespace-attach-module (namespace-anchor->namespace anchor) (namespace-attach-module (namespace-anchor->namespace anchor)
'scheme/base 'scheme/base ns)
ns)
ns)) ns))
(define (with-ns-params thunk) (define (with-ns-params thunk)
(let ([v (sandbox-namespace-specs)]) (let ([v (sandbox-namespace-specs)])
(cond (cond [(and (not gui?) (eq? (car v) make-base-namespace))
[(and (not gui?)
(eq? (car v) make-base-namespace))
(parameterize ([sandbox-namespace-specs (parameterize ([sandbox-namespace-specs
(cons make-mz-namespace (cons make-mz-namespace (cdr v))])
(cdr v))])
(thunk))] (thunk))]
[(and gui? [(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace))) (parameterize
(parameterize ([sandbox-namespace-specs ([sandbox-namespace-specs
;; Simulate the old make-namespace-with-mred: ;; Simulate the old make-namespace-with-mred:
(cons (lambda () (cons (lambda ()
(let ([ns (make-mz-namespace)] (let ([ns (make-mz-namespace)]
[ns2 ((dynamic-require 'mred 'make-gui-namespace))]) [ns2 ((dynamic-require
'mred 'make-gui-namespace))])
(namespace-attach-module ns2 'mred ns) (namespace-attach-module ns2 'mred ns)
(namespace-attach-module ns2 'scheme/class ns) (namespace-attach-module ns2 'scheme/class ns)
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
@ -96,11 +91,10 @@
(thunk))] (thunk))]
[else (thunk)]))) [else (thunk)])))
(define (literal-identifier=? x y) (define (literal-identifier=? x y)
(or (free-identifier=? x y) (or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y))))
(eq? (syntax-e x) (syntax-e y))))
(define (extract-requires language requires) (define (extract-requires language requires)
(define (find-requires forms) (define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()]) (let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms) (if (null? forms)
@ -121,4 +115,4 @@
(append (find-requires (cdr language)) requires)] (append (find-requires (cdr language)) requires)]
[else (error 'extract-requires [else (error 'extract-requires
"bad language spec: ~e" language)])]) "bad language spec: ~e" language)])])
requires))) requires))

7
collects/profj/tool.ss
View File

@ -116,6 +116,13 @@
(define mode-surrogate% (define mode-surrogate%
(class color:text-mode% (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) (define/override (on-disable-surrogate text)
(keymap:remove-chained-keymap text java-keymap) (keymap:remove-chained-keymap text java-keymap)
(super on-disable-surrogate text)) (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)

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

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

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

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

10
collects/scheme/sandbox.ss
View File

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

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

@ -45,6 +45,13 @@
spec spec
spec)] 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 #'(with-togetherable-scheme-variables
(lit ...) (lit ...)
([form spec] [form spec1] ... ([form spec] [form spec1] ...
@ -109,13 +116,21 @@
(define-syntax (defform/none stx) (define-syntax (defform/none stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:literals (lit ...) spec desc ...) [(_ #:literals (lit ...) spec 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 #'(with-togetherable-scheme-variables
(lit ...) (lit ...)
([form spec]) ([form spec])
(*defforms #f (*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec))) '(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null null null
(lambda () (list desc ...))))] (lambda () (list desc ...)))))]
[(_ spec desc ...) [(_ spec desc ...)
#'(defform/none #:literals () 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 is @scheme[(string-append "*." extension)], then the result pathname is guaranteed
to have an extension mapping @scheme[extension]. to have an extension mapping @scheme[extension].
Under Mac OS X, if @scheme[extension] is not @scheme[#f] Under Mac OS X 10.5 and later, if @scheme[extension] is not
and @scheme[filters] contains the single @scheme[#f], the returned path will get a default extension if the
pattern @scheme[(string-append "*." extension)], then the result pathname is user does not supply one. If @scheme[filters] contains as
guaranteed to have an extension mapping @scheme[extension]. Otherwise, @scheme["*.*"] pattern, then the user can supply any extension that
@scheme[extension] and @scheme[filters] are ignored. 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] Under Mac OS X versions before 10.5, the returned path will get a
can be used to specify glob-patterns. 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 The @scheme[extension] argument is ignored under X, and
@scheme[get-file]. @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%]. See also @scheme[path-dialog%].
} }
@defproc[(get-directory [message (or/c string? false/c) #f] @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. Free Software Foundation, Inc.
} }
@copyright{
libunwind
Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P.
}
@copyright{ @copyright{
GNU Classpath GNU Classpath
GNU Public License with special exception 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?]{ @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 @exnraise[exn:fail:filesystem]. If @scheme[path] is a link, the link
is deleted rather than the destination of 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 @defparam[current-module-name-resolver proc
(case-> (case->
(resolved-module-path? (resolved-module-path? . -> . any)
. -> .
any)
((or/c module-path? path?) ((or/c module-path? path?)
(or/c #f resolved-module-path?) (or/c #f resolved-module-path?)
(or/c #f syntax?) (or/c #f syntax?)
@ -316,35 +314,41 @@ See also @scheme[module->language-info].}
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "dynreq"]{Dynamic Module Access} @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]{ any]{
Dynamically instantiates the module specified by @scheme[mod] for Dynamically instantiates the module specified by @scheme[mod] for
@tech{phase} 0 in the current namespace's registry, if it is not yet @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{instantiate}d. The current @tech{module name resolver} may load
@tech{module name resolver} may load a module declaration to resolve a module declaration to resolve @scheme[mod] (see
it (see @scheme[current-module-name-resolver]); the path is resolved @scheme[current-module-name-resolver]); the path is resolved relative
relative to @scheme[current-load-relative-directory] and/or to @scheme[current-load-relative-directory] and/or
@scheme[current-directory]. @scheme[current-directory].
If @scheme[provided] is @scheme[#f], then the result is @|void-const|, If @scheme[provided] is @scheme[#f], then the result is @|void-const|,
and the module is not @tech{visit}ed (see and the module is not @tech{visit}ed (see @secref["mod-parse"]).
@secref["mod-parse"]). Otherwise, when @scheme[provided] is a symbol,
the value of the module's export with the given name is returned, and When @scheme[provided] is a symbol, the value of the module's export
still the module is not @tech{visit}ed. If the module exports with the given name is returned, and still the module is not
@scheme[provide] as syntax, then a use of the binding is expanded and @tech{visit}ed. If the module exports @scheme[provide] as syntax, then
evaluated in a fresh namespace to which the module is attached, which a use of the binding is expanded and evaluated in a fresh namespace to
means that the module is @tech{visit}ed. If the module has no such which the module is attached, which means that the module is
exported variable or syntax, or if the variable is protected (see @tech{visit}ed. If the module has no such exported variable or syntax,
@secref["modprotect"]), the @exnraise[exn:fail:contract]. 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 If @scheme[provided] is @|void-const|, then the module is
@tech{visit}ed but not @tech{instantiate}d (see @tech{visit}ed but not @tech{instantiate}d (see @secref["mod-parse"]),
@secref["mod-parse"]). The result is @|void-const|.} and the result is @|void-const|.}
@defproc[(dynamic-require-for-syntax [mod module-path?] @defproc[(dynamic-require-for-syntax [mod module-path?]
[provided (or/c symbol? #f)]) [provided (or/c symbol? #f)]
[fail-thunk (-> any) (lambda () ....)])
any]{ any]{
Like @scheme[dynamic-require], but in @tech{phase} 1.} 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.} @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 @defparam[sandbox-network-guard proc
(symbol? (symbol?
(or/c (and/c string? immutable?) #f) (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?]{ @defproc[(syntax-local-get-shadower [id-stx identifier?]) identifier?]{
Returns @scheme[id-stx] if no binding in the current expansion context 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 shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition
its lexical information, and if the current expansion context is not a 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}. @tech{module context}.
If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the
result is the same as result is the same as @scheme[(syntax-local-get-shadower
@scheme[(syntax-local-get-shadower inner-identifier)], except that it inner-identifier)], except that it has the location and properties of
has the location and properties of @scheme[id-stx]. @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 Otherwise, the result is the same as @scheme[id-stx] with its module
bindings (if any) removed from its lexical information, and the 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.} and different result procedures use distinct marks.}
@defproc[(make-syntax-delta-introducer [ext-stx syntax?] @defproc[(make-syntax-delta-introducer [ext-stx syntax?]
[base-stx syntax?] [base-stx (or/c syntax? #f)]
[phase-level (or/c #f exact-integer?) [phase-level (or/c #f exact-integer?)
(syntax-local-phase-level)]) (syntax-local-phase-level)])
(syntax? . -> . syntax?)]{ (syntax? . -> . syntax?)]{
@ -482,10 +484,10 @@ Produces a procedure that behaves like
@scheme[syntax-local-introduce], but using the @tech{syntax marks} of @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] that are not shared with @scheme[base-stx]. If
@scheme[ext-stx] does not extend the set of marks in @scheme[base-stx] @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} or if @scheme[base-stx] is @scheme[#f], and if @scheme[ext-stx] has a
indicated by @scheme[phase-level], then any marks of @scheme[ext-stx] module binding in the @tech{phase level} indicated by
that would be needed to preserve its binding are not transferred in an @scheme[phase-level], then any marks of @scheme[ext-stx] that would be
introduction. needed to preserve its binding are not transferred in an introduction.
This procedure is potentially useful when @scheme[_m-id] has a This procedure is potentially useful when @scheme[_m-id] has a
transformer binding that records some @scheme[_orig-id], and a use of 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) @defmethod[(get-definitions-canvas)
(is-a?/c drscheme:unit: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)) (path-replace-suffix (file-name-from-path (car d))
#"")))]) #"")))])
(and (not (and (len . >= . 3) (memq 'omit (caddr d)))) (and (not (and (len . >= . 3) (memq 'omit (caddr d))))
(let ([d (doc-path dir name flags 'false-if-missing)]) (let* ([d (doc-path dir name flags 'false-if-missing)]
(and d (build-path d "out.sxref"))))))) [p (and d (build-path d "out.sxref"))])
(and p (file-exists? p) p))))))
(define (get-reader-thunks) (define (get-reader-thunks)
(map (lambda (dest) (map (lambda (dest)

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

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

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

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

2
collects/wxme/wxme.ss
View File

@ -594,7 +594,7 @@
(call-with-parameterization (call-with-parameterization
plain-params plain-params
(lambda () (lambda ()
(with-handlers ([exn:fail:read? (lambda () 'no-good)]) (with-handlers ([exn:fail:read? (lambda (x) 'no-good)])
(read port))))) (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 . minor bug fixes
------------------------------ ------------------------------
Version 4.2 Version 4.1.2
------------------------------ ------------------------------
. contract library's function contract . contract library's function contract

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

@ -1,5 +1,6 @@
Version 4.1.3.3 Version 4.1.3.3
Added compile-context-preservation-enabled Added compile-context-preservation-enabled
Added exception-backtrace support for x86_84+JIT
Added scheme/package, scheme/splicing Added scheme/package, scheme/splicing
Version 4.1.3.2 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 wx_font.o : $(srcdir)/../../wxmac/src/mac/wx_font.m
$(CXX) -o wx_font.o -c $(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_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@ 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_LIB =
FOREIGN_NOT_USED_OBJSLIB = 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_a =
LIBMREDLIBS_la = $(LDFLAGS) $(LDLIBS) $(@WXVARIANT@_LIBS) 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" 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@" /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) $(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 $(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 $(MRFWRES): $(srcdir)/../../mac/osx_appl.ss $(srcdir)/../../mac/cw/MrEd.r
rm -rf PLT_MrEd.framework/Resources PLT_MrEd.framework/PLT_MrEd 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_LIB =
FOREIGN_NOT_USED_OBJSLIB = FOREIGN_NOT_USED_OBJSLIB =
EXTRA_OBJS_T = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_LIB) EXTRA_OBJS_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB)
EXTRA_OBJS_L = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB)
../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@ ../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@
$(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) 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); info.size = (sizeb >> gcLOG_WORD_SIZE);
memcpy(&w, &info, sizeof(struct objhead)); memcpy(&w, &info, sizeof(struct objhead));
((struct objhead*)&w)->size = (sizeb >> gcLOG_WORD_SIZE);
return w; return w;
} }
@ -1247,7 +1245,7 @@ typedef struct MarkSegment {
struct MarkSegment *next; struct MarkSegment *next;
void **top; void **top;
void **end; void **end;
void **stop_here; /* this is only used for its address */ void *stop_here; /* this is only used for its address */
} MarkSegment; } MarkSegment;
static THREAD_LOCAL MarkSegment *mark_stack = NULL; 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() { inline static MarkSegment* mark_stack_create_frame() {
MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE); MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE);
mark_frame->next = NULL; 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); mark_frame->end = PPTR(NUM(mark_frame) + STACK_PART_SIZE);
return mark_frame; return mark_frame;
} }
@ -1274,7 +1272,7 @@ inline static void push_ptr(void *ptr)
if(mark_stack->next) { if(mark_stack->next) {
/* we do, so just use it */ /* we do, so just use it */
mark_stack = mark_stack->next; mark_stack = mark_stack->next;
mark_stack->top = PPTR(&(mark_stack->stop_here)); mark_stack->top = &(mark_stack->stop_here);
} else { } else {
/* we don't, so we need to allocate one */ /* we don't, so we need to allocate one */
mark_stack->next = mark_stack_create_frame(); 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) 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(mark_stack->prev) {
/* if there is a previous page, go to it */ /* if there is a previous page, go to it */
mark_stack = mark_stack->prev; mark_stack = mark_stack->prev;

1
src/mzscheme/sconfig.h
View File

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

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

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

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

@ -41,6 +41,9 @@
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"
#ifdef MZ_USE_DWARF_LIBUNWIND
# include "unwind/libunwind.h"
#endif
#ifdef MZ_USE_JIT #ifdef MZ_USE_JIT
@ -2315,6 +2318,24 @@ typedef struct {
int direct_prim, direct_native, nontail_self; int direct_prim, direct_native, nontail_self;
} Generate_Call_Data; } 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) int do_generate_shared_call(mz_jit_state *jitter, void *_data)
{ {
Generate_Call_Data *data = (Generate_Call_Data *)_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 #endif
if (data->is_tail) { if (data->is_tail) {
int ok;
void *code;
code = jit_get_ip().ptr;
if (data->direct_prim) 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 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 { } else {
int ok; int ok;
void *code, *code_end; void *code;
code = jit_get_ip().ptr; code = jit_get_ip().ptr;
@ -2339,9 +2369,7 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data)
else else
ok = generate_non_tail_call(jitter, data->num_rands, data->direct_native, 1, data->multi_ok, data->nontail_self, 1); 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; register_sub_func(jitter, code, scheme_false);
if (jitter->retain_start)
add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_false, 0);
return ok; return ok;
} }
@ -3923,22 +3951,22 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
if (steps == 1) { if (steps == 1) {
if (name[1] == 'a') { if (name[1] == 'a') {
(void)jit_jmpi(bad_car_code); (void)jit_calli(bad_car_code);
} else { } else {
(void)jit_jmpi(bad_cdr_code); (void)jit_calli(bad_cdr_code);
} }
} else { } else {
if (name[1] == 'a') { if (name[1] == 'a') {
if (name[2] == 'a') { if (name[2] == 'a') {
(void)jit_jmpi(bad_caar_code); (void)jit_calli(bad_caar_code);
} else { } else {
(void)jit_jmpi(bad_cadr_code); (void)jit_calli(bad_cadr_code);
} }
} else { } else {
if (name[2] == 'a') { if (name[2] == 'a') {
(void)jit_jmpi(bad_cdar_code); (void)jit_calli(bad_cdar_code);
} else { } 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; reffail = _jit.x.pc;
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
if (name[2] == 'a') { if (name[2] == 'a') {
(void)jit_jmpi(bad_mcar_code); (void)jit_calli(bad_mcar_code);
} else { } else {
(void)jit_jmpi(bad_mcdr_code); (void)jit_calli(bad_mcdr_code);
} }
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref); 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); __END_TINY_JUMPS__(1);
reffail = _jit.x.pc; reffail = _jit.x.pc;
(void)jit_jmpi(bad_vector_length_code); (void)jit_calli(bad_vector_length_code);
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref); 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); __END_TINY_JUMPS__(1);
reffail = _jit.x.pc; reffail = _jit.x.pc;
(void)jit_jmpi(bad_unbox_code); (void)jit_calli(bad_unbox_code);
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref); 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; reffail = _jit.x.pc;
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
if (set_mcar) if (set_mcar)
(void)jit_jmpi(bad_set_mcar_code); (void)jit_calli(bad_set_mcar_code);
else else
(void)jit_jmpi(bad_set_mcdr_code); (void)jit_calli(bad_set_mcdr_code);
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref); mz_patch_branch(ref);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); 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_[m]{car,cdr,...}_code *** */
/* Bad argument is in R0 for car/cdr, R2 otherwise */ /* Bad argument is in R0 for car/cdr, R2 otherwise */
for (i = 0; i < 8; i++) { for (i = 0; i < 8; i++) {
void *code;
code = jit_get_ip().ptr;
switch (i) { switch (i) {
case 0: case 0:
bad_car_code = jit_get_ip().ptr; bad_car_code = code;
break; break;
case 1: case 1:
bad_cdr_code = jit_get_ip().ptr; bad_cdr_code = code;
break; break;
case 2: case 2:
bad_caar_code = jit_get_ip().ptr; bad_caar_code = code;
break; break;
case 3: case 3:
bad_cadr_code = jit_get_ip().ptr; bad_cadr_code = code;
break; break;
case 4: case 4:
bad_cdar_code = jit_get_ip().ptr; bad_cdar_code = code;
break; break;
case 5: case 5:
bad_cddr_code = jit_get_ip().ptr; bad_cddr_code = code;
break; break;
case 6: case 6:
bad_mcar_code = jit_get_ip().ptr; bad_mcar_code = code;
break; break;
case 7: case 7:
bad_mcdr_code = jit_get_ip().ptr; bad_mcdr_code = code;
break; break;
} }
mz_prolog(JIT_R1);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
CHECK_RUNSTACK_OVERFLOW(); CHECK_RUNSTACK_OVERFLOW();
if ((i < 2) || (i > 5)) { if ((i < 2) || (i > 5)) {
@ -6509,19 +6541,24 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
break; break;
} }
CHECK_LIMIT(); CHECK_LIMIT();
register_sub_func(jitter, code, scheme_false);
} }
/* *** bad_set_{car,cdr}_code *** */ /* *** bad_set_{car,cdr}_code *** */
/* Bad argument is in R0, other is in R1 */ /* Bad argument is in R0, other is in R1 */
for (i = 0; i < 2; i++) { for (i = 0; i < 2; i++) {
void *code;
code = jit_get_ip().ptr;
switch (i) { switch (i) {
case 0: case 0:
bad_set_mcar_code = jit_get_ip().ptr; bad_set_mcar_code = code;
break; break;
case 1: case 1:
bad_set_mcdr_code = jit_get_ip().ptr; bad_set_mcdr_code = code;
break; break;
} }
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
CHECK_RUNSTACK_OVERFLOW(); CHECK_RUNSTACK_OVERFLOW();
jit_str_p(JIT_RUNSTACK, JIT_R0); jit_str_p(JIT_RUNSTACK, JIT_R0);
@ -6541,29 +6578,34 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
break; break;
} }
CHECK_LIMIT(); CHECK_LIMIT();
register_sub_func(jitter, code, scheme_false);
} }
/* *** bad_unbox_code *** */ /* *** bad_unbox_code *** */
/* R0 is argument */ /* R0 is argument */
bad_unbox_code = jit_get_ip().ptr; bad_unbox_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1); jit_prepare(1);
jit_pusharg_i(JIT_R0); jit_pusharg_i(JIT_R0);
(void)mz_finish(scheme_unbox); (void)mz_finish(scheme_unbox);
CHECK_LIMIT(); CHECK_LIMIT();
register_sub_func(jitter, bad_unbox_code, scheme_false);
/* *** bad_vector_length_code *** */ /* *** bad_vector_length_code *** */
/* R0 is argument */ /* R0 is argument */
bad_vector_length_code = jit_get_ip().ptr; bad_vector_length_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1); jit_prepare(1);
jit_pusharg_i(JIT_R0); jit_pusharg_i(JIT_R0);
(void)mz_finish(scheme_vector_length); (void)mz_finish(scheme_vector_length);
CHECK_LIMIT(); CHECK_LIMIT();
register_sub_func(jitter, bad_vector_length_code, scheme_false);
/* *** call_original_unary_arith_code *** */ /* *** call_original_unary_arith_code *** */
/* R0 is arg, R2 is code pointer, V1 is return address */ /* R0 is arg, R2 is code pointer, V1 is return address */
for (i = 0; i < 3; i++) { for (i = 0; i < 3; i++) {
int argc, j; int argc, j;
void *code, *code_end; void *code;
for (j = 0; j < 2; j++) { for (j = 0; j < 2; j++) {
code = jit_get_ip().ptr; code = jit_get_ip().ptr;
if (!i) { if (!i) {
@ -6625,9 +6667,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
} }
CHECK_LIMIT(); CHECK_LIMIT();
code_end = jit_get_ip().ptr; register_sub_func(jitter, code, scheme_void);
if (jitter->retain_start)
add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_void, 0);
} }
} }
@ -6699,6 +6739,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
mz_pop_locals(); mz_pop_locals();
jit_ret(); jit_ret();
CHECK_LIMIT(); CHECK_LIMIT();
register_helper_func(jitter, on_demand_jit_code);
/* *** app_values_tail_slow_code *** */ /* *** app_values_tail_slow_code *** */
/* RELIES ON jit_prolog(3) FROM ABOVE */ /* 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; finish_tail_call_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 0); generate_finish_tail_call(jitter, 0);
CHECK_LIMIT(); CHECK_LIMIT();
register_helper_func(jitter, finish_tail_call_code);
finish_tail_call_fixup_code = jit_get_ip().ptr; finish_tail_call_fixup_code = jit_get_ip().ptr;
generate_finish_tail_call(jitter, 2); generate_finish_tail_call(jitter, 2);
CHECK_LIMIT(); CHECK_LIMIT();
register_helper_func(jitter, finish_tail_call_fixup_code);
/* *** get_stack_pointer_code *** */ /* *** get_stack_pointer_code *** */
get_stack_pointer_code = jit_get_ip().ptr; 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) { if (data->name) {
add_symbol((unsigned long)code, (unsigned long)gdata.code_end - 1, data->name, 1); 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); 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; void *p, *q;
unsigned long stack_end, stack_start, halfway; unsigned long stack_end, stack_start, halfway;
Get_Stack_Proc gs;
Scheme_Object *name, *last = NULL, *first = NULL, *tail; Scheme_Object *name, *last = NULL, *first = NULL, *tail;
int set_next_push = 0, prev_had_name = 0; 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) if (!get_stack_pointer_code)
return NULL; return NULL;
@ -8102,8 +8157,16 @@ Scheme_Object *scheme_native_stack_trace(void)
check_stack(); check_stack();
#endif #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; gs = (Get_Stack_Proc)get_stack_pointer_code;
p = gs(); p = gs();
#endif
stack_start = scheme_approx_sp(); stack_start = scheme_approx_sp();
if (stack_cache_stack_pos) { if (stack_cache_stack_pos) {
@ -8115,6 +8178,11 @@ Scheme_Object *scheme_native_stack_trace(void)
tail = scheme_null; 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; halfway = STK_DIFF(stack_end, (unsigned long)p) / 2;
if (halfway < CACHE_STACK_MIN_TRIGGER) if (halfway < CACHE_STACK_MIN_TRIGGER)
halfway = stack_end; halfway = stack_end;
@ -8126,11 +8194,29 @@ Scheme_Object *scheme_native_stack_trace(void)
#endif #endif
} }
while (STK_COMP((unsigned long)p, stack_end) while (1) {
&& STK_COMP(stack_start, (unsigned long)p)) { #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]; 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); name = find_symbol((unsigned long)q);
#ifdef MZ_USE_DWARF_LIBUNWIND
if (name) manual_unw = 1;
#endif
if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) { if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) {
/* Code uses special calling convention */ /* Code uses special calling convention */
#ifdef MZ_USE_JIT_PPC #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]; q = ((void **)p)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE];
#endif #endif
#ifdef MZ_USE_JIT_I386 #ifdef MZ_USE_JIT_I386
if (SCHEME_VOIDP(name)) {
/* JIT_LOCAL2 has the next return address */ # ifdef MZ_USE_DWARF_LIBUNWIND
if (use_unw) {
q = (void *)unw_get_frame_pointer(&c);
} else
# endif
q = *(void **)p; 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) if (STK_COMP((unsigned long)q, stack_end)
&& STK_COMP(stack_start, (unsigned long)q)) { && 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]; q = ((void **)q)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE];
} else
q = NULL;
} else { } else {
/* Push after local stack of return-address proc /* Push after local stack of return-address proc
has the next return address */ 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)]; q = ((void **)q)[-(3 + LOCAL_FRAME_SIZE + 1)];
}
} else { } else {
q = NULL; q = NULL;
} }
}
#endif #endif
name = find_symbol((unsigned long)q); 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); name = scheme_make_pair(name, scheme_null);
if (last) if (last)
SCHEME_CDR(last) = name; SCHEME_CDR(last) = name;
@ -8204,11 +8294,37 @@ Scheme_Object *scheme_native_stack_trace(void)
prev_had_name = !!name; prev_had_name = !!name;
#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; q = *(void **)p;
if (STK_COMP((unsigned long)q, (unsigned long)p)) if (STK_COMP((unsigned long)q, (unsigned long)p))
break; break;
p = q; p = q;
} }
}
if (last) if (last)
SCHEME_CDR(last) = tail; SCHEME_CDR(last) = tail;
@ -8238,8 +8354,6 @@ void scheme_dump_stack_trace(void)
while (STK_COMP((unsigned long)p, stack_end) while (STK_COMP((unsigned long)p, stack_end)
&& STK_COMP(stack_start, (unsigned long)p)) { && STK_COMP(stack_start, (unsigned long)p)) {
q = ((void **)p)[RETURN_ADDRESS_OFFSET];
name = find_symbol((unsigned long)q); name = find_symbol((unsigned long)q);
if (SCHEME_FALSEP(name)) { if (SCHEME_FALSEP(name)) {
/* Code uses special calling convention */ /* 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"?> <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity <assemblyIdentity
version="4.1.3.2" version="4.1.3.3"
processorArchitecture="X86" processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd" name="Org.PLT-Scheme.MrEd"
type="win32" type="win32"

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

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

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

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

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

@ -1,19 +1,19 @@
HKCR 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}' CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
} }
MzCOM.MzObj = s 'MzObj Class' MzCOM.MzObj = s 'MzObj Class'
{ {
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' 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 NoRemove CLSID
{ {
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' 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' VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable' ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%' LocalServer32 = s '%MODULE%'

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

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

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

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

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

@ -146,6 +146,7 @@ OBJS = \
wx_xbm.o \ wx_xbm.o \
\ \
wx_font.o \ wx_font.o \
wx_file_dialog.o \
\ \
$(MIN_OBJS) $(MIN_OBJS)
@ -385,9 +386,11 @@ ALSelectors.o : $(ALISTDEPS) $(ALISTDIR)/ALSelectors.c
$(CC) $(ALISTCCFLAGS) -o ALSelectors.o -c $(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 wx_font.o : $(srcdir)/mac/wx_font.m
$(CXX) -o wx_font.o -c $(srcdir)/mac/wx_font.m $(CXX) -o wx_font.o -c $(srcdir)/mac/wx_font.m

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

@ -585,7 +585,8 @@ static void ExtensionCallback(NavEventCallbackMessage callBackSelector,
} }
break; break;
case kNavCBStart: case kNavCBStart:
{ if (0) {
/* No longer needed */
EventTypeSpec spec[1]; EventTypeSpec spec[1];
spec[0].eventClass = kEventClassKeyboard; spec[0].eventClass = kEventClassKeyboard;
spec[0].eventKind = kEventRawKeyDown; spec[0].eventKind = kEventRawKeyDown;
@ -638,6 +639,40 @@ static char *GetNthPath(NavReplyRecord *reply, int index)
static NavEventUPP extProc = NewNavEventUPP((NavEventProcPtr)ExtensionCallback); 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 *wxFileSelector(char *message, char *default_path,
char *default_filename, char *default_extension, char *default_filename, char *default_extension,
char *wildcard, int flags, char *wildcard, int flags,
@ -652,6 +687,8 @@ char *wxFileSelector(char *message, char *default_path,
NavUserAction action; NavUserAction action;
NavReplyRecord *reply; NavReplyRecord *reply;
char *temp; char *temp;
char **acceptable_extensions = NULL;
int num_acceptable = 0, single_type = 0;
if (!navinited) { if (!navinited) {
if (!NavLoad()) { if (!NavLoad()) {
@ -694,7 +731,11 @@ char *wxFileSelector(char *message, char *default_path,
if ((s1[0] == '*') if ((s1[0] == '*')
&& (s1[1] == '.') && (s1[1] == '.')
&& ((s2 - s1) == (len + 2)) && ((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; dialogOptions.optionFlags |= kNavPreserveSaveFileExtension;
/* Make sure initial name has specified extension: */ /* Make sure initial name has specified extension: */
if (!default_filename) 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) { if (default_filename) {
@ -723,32 +802,15 @@ char *wxFileSelector(char *message, char *default_path,
cbi->has_parent = 1; cbi->has_parent = 1;
if (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; WindowPtr win;
mdc = f->MacDC(); win = extract_sheet_parent(parent);
graf = mdc->macGrafPort();
win = GetWindowFromPort(graf); if (win) {
if (IsWindowVisible(win)) {
dialogOptions.parentWindow = win; dialogOptions.parentWindow = win;
dialogOptions.modality = kWindowModalityWindowModal; dialogOptions.modality = kWindowModalityWindowModal;
cbi->has_parent = 1; cbi->has_parent = 1;
} }
} }
}
cbi_sr = WRAP_SAFEREF(cbi); cbi_sr = WRAP_SAFEREF(cbi);
cbi->is_put = 0; cbi->is_put = 0;
@ -767,6 +829,9 @@ char *wxFileSelector(char *message, char *default_path,
extProc, cbi_sr, extProc, cbi_sr,
&outDialog); &outDialog);
cbi->is_put = 1; cbi->is_put = 1;
if (derr == noErr)
wx_set_nav_file_types(outDialog, num_acceptable, acceptable_extensions,
default_extension);
} }
cbi->dialog = outDialog; 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 /* 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. */ connected through the PostScript name of a font. */
#import <Cocoa/Cocoa.h> #import <Cocoa/Cocoa.h>