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

Moving this branch to a better name.

Browse Source 
svn: r12700
This commit is contained in:
Stevie Strickland 2008-12-04 17:31:19 +00:00
commit 2fc429dbda
284 changed files with 11976 additions and 4074 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/compiler/decompile.ss
View File

@ -28,12 +28,12 @@
(hash-set! table n (car b))))) (hash-set! table n (car b)))))
table)) table))
(define (list-ref/protect l pos) (define (list-ref/protect l pos who)
(list-ref l pos) (list-ref l pos)
#; #;
(if (pos . < . (length l)) (if (pos . < . (length l))
(list-ref l pos) (list-ref l pos)
`(OUT-OF-BOUNDS ,pos ,l))) `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
;; ---------------------------------------- ;; ----------------------------------------
@ -44,7 +44,7 @@
(let-values ([(globs defns) (decompile-prefix prefix)]) (let-values ([(globs defns) (decompile-prefix prefix)])
`(begin `(begin
,@defns ,@defns
,(decompile-form form globs '(#%globals))))] ,(decompile-form form globs '(#%globals) (make-hasheq))))]
[else (error 'decompile "unrecognized: ~e" top)])) [else (error 'decompile "unrecognized: ~e" top)]))
(define (decompile-prefix a-prefix) (define (decompile-prefix a-prefix)
@ -76,7 +76,7 @@
lift-ids) lift-ids)
(map (lambda (stx id) (map (lambda (stx id)
`(define ,id ,(if stx `(define ,id ,(if stx
`(#%decode-syntax ,(stx-encoded stx)) `(#%decode-syntax ,stx #;(stx-encoded stx))
#f))) #f)))
stxs stx-ids)))] stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)])) [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -90,18 +90,19 @@
(match mod-form (match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(let-values ([(globs defns) (decompile-prefix prefix)] (let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)]) [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)])
`(module ,name .... `(module ,name ....
,@defns ,@defns
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
syntax-body) syntax-body)
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
body)))] body)))]
[else (error 'decompile-module "huh?: ~e" mod-form)])) [else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack) (define (decompile-form form globs stack closed)
(match form (match form
[(? mod?) [(? mod?)
(decompile-module form stack)] (decompile-module form stack)]
@ -109,31 +110,31 @@
`(define-values ,(map (lambda (tl) `(define-values ,(map (lambda (tl)
(match tl (match tl
[(struct toplevel (depth pos const? mutated?)) [(struct toplevel (depth pos const? mutated?))
(list-ref/protect globs pos)])) (list-ref/protect globs pos 'def-vals)]))
ids) ids)
,(decompile-expr rhs globs stack))] ,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth))
`(define-syntaxes ,ids `(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)]) ,(let-values ([(globs defns) (decompile-prefix prefix)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals)))))] ,(decompile-form rhs globs '(#%globals) closed))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct def-for-syntax (ids rhs prefix max-let-depth))
`(define-values-for-syntax ,ids `(define-values-for-syntax ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)]) ,(let-values ([(globs defns) (decompile-prefix prefix)])
`(let () `(let ()
,@defns ,@defns
,(decompile-expr rhs globs '(#%globals)))))] ,(decompile-expr rhs globs '(#%globals) closed))))]
[(struct sequence (forms)) [(struct sequence (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
forms))] forms))]
[(struct splice (forms)) [(struct splice (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
forms))] forms))]
[else [else
(decompile-expr form globs stack)])) (decompile-expr form globs stack closed)]))
(define (extract-name name) (define (extract-name name)
(if (symbol? name) (if (symbol? name)
@ -168,22 +169,22 @@
(extract-ids! body ids)] (extract-ids! body ids)]
[else #f])) [else #f]))
(define (decompile-expr expr globs stack) (define (decompile-expr expr globs stack closed)
(match expr (match expr
[(struct toplevel (depth pos const? mutated?)) [(struct toplevel (depth pos const? mutated?))
(let ([id (list-ref/protect globs pos)]) (let ([id (list-ref/protect globs pos 'toplevel)])
(if const? (if const?
id id
`(#%checked ,id)))] `(#%checked ,id)))]
[(struct topsyntax (depth pos midpt)) [(struct topsyntax (depth pos midpt))
(list-ref/protect globs (+ midpt pos))] (list-ref/protect globs (+ midpt pos) 'topsyntax)]
[(struct primitive (id)) [(struct primitive (id))
(hash-ref primitive-table id)] (hash-ref primitive-table id)]
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack) `(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack))] ,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear?)) [(struct localref (unbox? offset clear?))
(let ([id (list-ref/protect stack offset)]) (let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox? (let ([e (if unbox?
`(#%unbox ,id) `(#%unbox ,id)
id)]) id)])
@ -191,17 +192,17 @@
`(#%sfs-clear ,e) `(#%sfs-clear ,e)
e)))] e)))]
[(? lam?) [(? lam?)
`(lambda . ,(decompile-lam expr globs stack))] `(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
`(case-lambda `(case-lambda
,@(map (lambda (lam) ,@(map (lambda (lam)
(decompile-lam lam globs stack)) (decompile-lam lam globs stack closed))
lams))] lams))]
[(struct let-one (rhs body)) [(struct let-one (rhs body))
(let ([id (or (extract-id rhs) (let ([id (or (extract-id rhs)
(gensym 'local))]) (gensym 'local))])
`(let ([,id ,(decompile-expr rhs globs (cons id stack))]) `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
,(decompile-expr body globs (cons id stack))))] ,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body)) [(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)]) (let ([ids (make-vector count #f)])
(extract-ids! body ids) (extract-ids! body ids)
@ -210,71 +211,76 @@
(or id (gensym 'localv)))]) (or id (gensym 'localv)))])
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
vars) vars)
,(decompile-expr body globs (append vars stack)))))] ,(decompile-expr body globs (append vars stack) closed))))]
[(struct let-rec (procs body)) [(struct let-rec (procs body))
`(begin `(begin
(#%set!-rec-values ,(for/list ([p (in-list procs)] (#%set!-rec-values ,(for/list ([p (in-list procs)]
[i (in-naturals)]) [i (in-naturals)])
(list-ref/protect stack i)) (list-ref/protect stack i 'let-rec))
,@(map (lambda (proc) ,@(map (lambda (proc)
(decompile-expr proc globs stack)) (decompile-expr proc globs stack closed))
procs)) procs))
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct install-value (count pos boxes? rhs body)) [(struct install-value (count pos boxes? rhs body))
`(begin `(begin
(,(if boxes? '#%set-boxes! 'set!-values) (,(if boxes? '#%set-boxes! 'set!-values)
,(for/list ([i (in-range count)]) ,(for/list ([i (in-range count)])
(list-ref/protect stack (+ i pos))) (list-ref/protect stack (+ i pos) 'install-value))
,(decompile-expr rhs globs stack)) ,(decompile-expr rhs globs stack closed))
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct boxenv (pos body)) [(struct boxenv (pos body))
(let ([id (list-ref/protect stack pos)]) (let ([id (list-ref/protect stack pos 'boxenv)])
`(begin `(begin
(set! ,id (#%box ,id)) (set! ,id (#%box ,id))
,(decompile-expr body globs stack)))] ,(decompile-expr body globs stack closed)))]
[(struct branch (test then else)) [(struct branch (test then else))
`(if ,(decompile-expr test globs stack) `(if ,(decompile-expr test globs stack closed)
,(decompile-expr then globs stack) ,(decompile-expr then globs stack closed)
,(decompile-expr else globs stack))] ,(decompile-expr else globs stack closed))]
[(struct application (rator rands)) [(struct application (rator rands))
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
stack)]) stack)])
(annotate-inline (annotate-inline
`(,(decompile-expr rator globs stack) `(,(decompile-expr rator globs stack closed)
,@(map (lambda (rand) ,@(map (lambda (rand)
(decompile-expr rand globs stack)) (decompile-expr rand globs stack closed))
rands))))] rands))))]
[(struct apply-values (proc args-expr)) [(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack) `(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack))] ,(decompile-expr args-expr globs stack closed))]
[(struct sequence (exprs)) [(struct sequence (exprs))
`(begin ,@(for/list ([expr (in-list exprs)]) `(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))] (decompile-expr expr globs stack closed)))]
[(struct beg0 (exprs)) [(struct beg0 (exprs))
`(begin0 ,@(for/list ([expr (in-list exprs)]) `(begin0 ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))] (decompile-expr expr globs stack closed)))]
[(struct with-cont-mark (key val body)) [(struct with-cont-mark (key val body))
`(with-continuation-mark `(with-continuation-mark
,(decompile-expr key globs stack) ,(decompile-expr key globs stack closed)
,(decompile-expr val globs stack) ,(decompile-expr val globs stack closed)
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct closure (lam gen-id)) [(struct closure (lam gen-id))
`(#%closed ,gen-id ,(decompile-expr lam globs stack))] (if (hash-ref closed gen-id #f)
gen-id
(begin
(hash-set! closed gen-id #t)
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
[(struct indirect (val)) [(struct indirect (val))
(if (closure? val) (if (closure? val)
(closure-gen-id val) (decompile-expr val globs stack closed)
'???)] '???)]
[else `(quote ,expr)])) [else `(quote ,expr)]))
(define (decompile-lam expr globs stack) (define (decompile-lam expr globs stack closed)
(match expr (match expr
[(struct closure (lam gen-id)) (decompile-lam lam globs stack)] [(struct indirect (val)) (decompile-lam val globs stack closed)]
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
[(struct lam (name flags num-params rest? closure-map max-let-depth body)) [(struct lam (name flags num-params rest? closure-map max-let-depth body))
(let ([vars (for/list ([i (in-range num-params)]) (let ([vars (for/list ([i (in-range num-params)])
(gensym (format "arg~a-" i)))] (gensym (format "arg~a-" i)))]
[rest-vars (if rest? (list (gensym 'rest)) null)] [rest-vars (if rest? (list (gensym 'rest)) null)]
[captures (map (lambda (v) [captures (map (lambda (v)
(list-ref/protect stack v)) (list-ref/protect stack v 'lam))
(vector->list closure-map))]) (vector->list closure-map))])
`((,@vars . ,(if rest? `((,@vars . ,(if rest?
(car rest-vars) (car rest-vars)
@ -285,8 +291,10 @@
,@(if (null? captures) ,@(if (null? captures)
null null
`('(captures: ,@captures))) `('(captures: ,@captures)))
,(decompile-expr body globs (append captures ,(decompile-expr body globs
(append vars rest-vars)))))])) (append captures
(append vars rest-vars))
closed)))]))
(define (annotate-inline a) (define (annotate-inline a)
(if (and (symbol? (car a)) (if (and (symbol? (car a))
@ -301,16 +309,16 @@
car cdr caar cadr cdar cddr car cdr caar cadr cdar cddr
mcar mcdr unbox vector-length syntax-e mcar mcdr unbox vector-length syntax-e
add1 sub1 - abs bitwise-not add1 sub1 - abs bitwise-not
list vector box))] list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= > [(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=? bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior + - * / min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons set-mcar! set-mcdr! cons mcons
list vector))] list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set! [(4) (memq (car a) '(vector-set! string-set! bytes-set!
list vector))] list list* vector vector-immutable))]
[else (memq (car a) '(list vector))])) [else (memq (car a) '(list list* vector vector-immutable))]))
(cons '#%in a) (cons '#%in a)
a)) a))

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

@ -661,7 +661,7 @@
;; Main parsing loop ;; Main parsing loop
(define (read-compact cp) (define (read-compact cp)
(let loop ([need-car 0] [proper #f] [last #f] [first #f]) (let loop ([need-car 0] [proper #f])
(begin-with-definitions (begin-with-definitions
(define ch (cp-getc cp)) (define ch (cp-getc cp))
(define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)])
@ -707,7 +707,7 @@
(cons (read-compact cp) (cons (read-compact cp)
(if ppr null (read-compact cp))) (if ppr null (read-compact cp)))
(read-compact-list l ppr cp)) (read-compact-list l ppr cp))
(loop l ppr last first)))] (loop l ppr)))]
[(let-one) [(let-one)
(make-let-one (read-compact cp) (read-compact cp))] (make-let-one (read-compact cp) (read-compact cp))]
[(branch) [(branch)
@ -747,8 +747,10 @@
(read-compact cp))]) (read-compact cp))])
(vector->immutable-vector (list->vector lst)))] (vector->immutable-vector (list->vector lst)))]
[(list) (let* ([n (read-compact-number cp)]) [(list) (let* ([n (read-compact-number cp)])
(for/list ([i (in-range n)]) (append
(read-compact cp)))] (for/list ([i (in-range n)])
(read-compact cp))
(read-compact cp)))]
[(prefab) [(prefab)
(let ([v (read-compact cp)]) (let ([v (read-compact cp)])
(apply make-prefab-struct (apply make-prefab-struct
@ -845,9 +847,8 @@
[(symbol? s) s] [(symbol? s) s]
[(vector? s) (vector-ref s 0)] [(vector? s) (vector-ref s 0)]
[else 'closure]))))]) [else 'closure]))))])
(vector-set! (cport-symtab cp) l cl)
(set-indirect-v! ind cl) (set-indirect-v! ind cl)
cl))] ind))]
[(svector) [(svector)
(read-compact-svector cp (read-compact-number cp))] (read-compact-svector cp (read-compact-number cp))]
[(small-svector) [(small-svector)
@ -858,7 +859,7 @@
[(and proper (= need-car 1)) [(and proper (= need-car 1))
(cons v null)] (cons v null)]
[else [else
(cons v (loop (sub1 need-car) proper last first))])))) (cons v (loop (sub1 need-car) proper))]))))
;; path -> bytes ;; path -> bytes
;; implementes read.c:read_compiled ;; implementes read.c:read_compiled
@ -898,11 +899,13 @@
(define symtab (make-vector symtabsize (make-not-ready))) (define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)]) (for/list ([i (in-range 1 symtabsize)])
(when (not-ready? (vector-ref symtab i)) (when (not-ready? (vector-ref symtab i))
(set-cport-pos! cp (vector-ref so* (sub1 i))) (set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)]) (let ([v (read-compact cp)])
(vector-set! symtab i v)))) (vector-set! symtab i v))))
(set-cport-pos! cp shared-size) (set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp))) (read-marshalled 'compilation-top-type cp)))

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?)

4
collects/framework/private/frame.ss
View File

@ -1952,7 +1952,6 @@
(set! red? r?) (set! red? r?)
(refresh))) (refresh)))
(define/override (on-paint) (define/override (on-paint)
(super on-paint)
(when red? (when red?
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(let-values ([(cw ch) (get-client-size)]) (let-values ([(cw ch) (get-client-size)])
@ -1962,7 +1961,8 @@
(send dc set-brush "pink" 'solid) (send dc set-brush "pink" 'solid)
(send dc draw-rectangle 0 0 cw ch) (send dc draw-rectangle 0 0 cw ch)
(send dc set-pen pen) (send dc set-pen pen)
(send dc set-brush brush)))))) (send dc set-brush brush)))))
(super on-paint))
(super-new))) (super-new)))
(define-local-member-name (define-local-member-name

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)))

147
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,16 +367,7 @@
args)]) args)])
(values (values
desc desc
#;(lambda fields ctor
(if (ormap behavior? fields)
(apply procs->signal:compound
ctor
(lambda (strct idx)
(lambda (val)
(mut strct idx val)))
fields)
(apply ctor fields)))
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))
(lift #t pred v))) (lift #t pred 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")))

134
collects/games/cards/card-class.ss
View File

@ -2,9 +2,11 @@
(module card-class mzscheme (module card-class mzscheme
(require mzlib/class (require mzlib/class
mzlib/class100 mzlib/class100
mzlib/shared
(prefix mred: mred) (prefix mred: mred)
"snipclass.ss" "snipclass.ss"
"region.ss") "region.ss"
(only scheme/base for in-range))
(provide card%) (provide card%)
@ -28,18 +30,43 @@
(thunk) (thunk)
(send dc set-clipping-region r)))) (send dc set-clipping-region r))))
(define (rotate-bm bm cw?)
(let ([w (send bm get-width)]
[h (send bm get-height)])
(let ([bm2 (make-object mred:bitmap% h w)]
[s (make-bytes (* w h 4))]
[s2 (make-bytes (* h w 4))])
(send bm get-argb-pixels 0 0 w h s)
(for ([i (in-range w)])
(for ([j (in-range h)])
(let ([src-pos (* (+ i (* j w)) 4)])
(bytes-copy! s2
(if cw?
(* (+ (- (- h j) 1) (* i h)) 4)
(* (+ j (* (- (- w i) 1) h)) 4))
s src-pos (+ src-pos 4)))))
(let ([dc (make-object mred:bitmap-dc% bm2)])
(send dc set-argb-pixels 0 0 h w s2)
(send dc set-bitmap #f))
bm2)))
(define orientations (shared ([o (list* 'n 'e 's 'w o)]) o))
(define (find-head l s)
(if (eq? (car l) s)
l
(find-head (cdr l) s)))
(define card% (define card%
(class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back) (class100 mred:snip% (-suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms)
(inherit set-snipclass set-count get-admin) (inherit set-snipclass set-count get-admin)
(private-field (private-field
[suit-id -suit-id] [suit-id -suit-id]
[value -value] [value -value]
[width -width] [width -width]
[height -height] [height -height]
[rotated 'n]
[front -front] [front -front]
[back -back] [back -back]
[semi-front -semi-front]
[semi-back -semi-back]
[mk-dim-front -mk-dim-front] [mk-dim-front -mk-dim-front]
[mk-dim-back -mk-dim-back] [mk-dim-back -mk-dim-back]
[dim-front #f] [dim-front #f]
@ -51,13 +78,20 @@
[can-move? #t] [can-move? #t]
[snap-back? #f] [snap-back? #f]
[stay-region #f] [stay-region #f]
[home-reg #f]) [home-reg #f]
[rotated-bms -rotated-bms])
(private (private
[refresh [refresh
(lambda () (lambda ()
(let ([a (get-admin)]) (let ([a (get-admin)])
(when a (when a
(send a needs-update this 0 0 width height))))] (send a needs-update this 0 0 width height))))]
[refresh-size
(lambda ()
(let ([a (get-admin)])
(when a
(send a resized this #f)))
(refresh))]
[check-dim [check-dim
(lambda () (lambda ()
(when is-dim? (when is-dim?
@ -65,7 +99,18 @@
(unless dim-back (unless dim-back
(set! dim-back (mk-dim-back))) (set! dim-back (mk-dim-back)))
(unless dim-front (unless dim-front
(set! dim-front (mk-dim-front))))))]) (set! dim-front (mk-dim-front))))))]
[get-rotated
(lambda (bm dir)
(if (eq? dir 'n)
bm
(or (hash-table-get rotated-bms (cons dir bm) #f)
(let ([rotated-bm (case dir
[(w) (rotate-bm bm #f)]
[(e) (rotate-bm bm #t)]
[(s) (rotate-bm (rotate-bm bm #t) #t)])])
(hash-table-put! rotated-bms (cons dir bm) rotated-bm)
rotated-bm))))])
(public (public
[face-down? (lambda () flipped?)] [face-down? (lambda () flipped?)]
[flip [flip
@ -84,6 +129,25 @@
(unless (eq? is-dim? (and v #t)) (unless (eq? is-dim? (and v #t))
(set! is-dim? (and v #t)) (set! is-dim? (and v #t))
(refresh))])] (refresh))])]
[orientation (lambda () (case rotated
[(n) 0]
[(e) 270]
[(w) 90]
[(s) 180]))]
[rotate (lambda (mode)
(let ([delta (case mode
[(0 360) 0]
[(cw -90 270) 1]
[(ccw 90 -270) 3]
[(180 -180) 2]
[else (error 'rotate "bad mode: ~e" mode)])])
(set! rotated (list-ref (find-head orientations rotated) delta))
(if (odd? delta)
(let ([w width])
(set! width height)
(set! height w)
(refresh-size))
(refresh))))]
[get-suit-id [get-suit-id
(lambda () suit-id)] (lambda () suit-id)]
[get-suit [get-suit
@ -133,26 +197,44 @@
[draw [draw
(lambda (dc x y left top right bottom dx dy draw-caret) (lambda (dc x y left top right bottom dx dy draw-caret)
(check-dim) (check-dim)
(if semi-flipped? (let ([do-draw
(send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y) (lambda (x y)
(with-card-region (with-card-region
dc x y width height dc x y width height
(lambda () (lambda ()
(send dc draw-bitmap (send dc draw-bitmap
(if flipped? (let ([bm (if flipped?
(if is-dim? dim-back back) (if is-dim? dim-back back)
(if is-dim? dim-front front)) (if is-dim? dim-front front))])
x y)))))] (get-rotated bm rotated))
[copy (lambda () (make-object card% suit-id value width height x y))))])
front back semi-front semi-back (if semi-flipped?
(lambda () (let-values ([(sx sy) (send dc get-scale)])
(unless dim-front (case rotated
(set! dim-front (mk-dim-front))) [(n s)
dim-front) (send dc set-scale (/ sx 2) sy)
(lambda () (do-draw (+ (* 2 x) (/ width 2)) y)
(unless dim-back (send dc set-scale sx sy)]
(set! dim-back (mk-dim-back))) [(e w)
dim-back)))]) (send dc set-scale sx (/ sy 2))
(do-draw x (+ (* 2 y) (/ height 2)))
(send dc set-scale sx sy)]))
(do-draw x y))))]
[copy (lambda ()
(let ([rotated? (memq rotated '(e w))])
(make-object card% suit-id value
(if rotated? height width)
(if rotated? width height )
front back
(lambda ()
(unless dim-front
(set! dim-front (mk-dim-front)))
dim-front)
(lambda ()
(unless dim-back
(set! dim-back (mk-dim-back)))
dim-back)
rotated-bms)))])
(private-field (private-field
[save-x (box 0)] [save-x (box 0)]
[save-y (box 0)]) [save-y (box 0)])

51
collects/games/cards/cards.scrbl
View File

@ -17,8 +17,9 @@ module provides a toolbox for creating cards games.}
table<%>]{ table<%>]{
Returns a table. The table is named by @scheme[title], and it is Returns a table. The table is named by @scheme[title], and it is
@scheme[w] cards wide and @scheme[h] cards high. The table is not @scheme[w] cards wide and @scheme[h] cards high (assuming a standard
initially shown; @scheme[(send table show #t)] shows it.} card of 71 by 96 pixels). The table is not initially shown;
@scheme[(send table show #t)] shows it.}
@defproc[(make-deck) @defproc[(make-deck)
(listof card<%>)]{ (listof card<%>)]{
@ -37,7 +38,7 @@ Returns a single card given a bitmap for the front, an optional bitmap
for the back, and arbitrary values for the card's suit and value for the back, and arbitrary values for the card's suit and value
(which are returned by the card's @method[card<%> get-value] and (which are returned by the card's @method[card<%> get-value] and
@method[card<%> get-suit-id] methods). All provided bitmaps should be @method[card<%> get-suit-id] methods). All provided bitmaps should be
71 by 96 pixels.} the same size.}
@defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?]) @defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?])
list?]{ list?]{
@ -171,8 +172,9 @@ Create an instance with @scheme[make-table].
void?]{ void?]{
Adds @scheme[cards] to fill the region @scheme[r], fanning them out Adds @scheme[cards] to fill the region @scheme[r], fanning them out
bottom-right to top-left. The region @scheme[r] does not have to be bottom-right to top-left, assuming that all cards in @scheme[cards]
added to the table.} have the same width and height. The region @scheme[r] does not have
to be added to the table.}
@defmethod[(remove-card [card (is-a?/c card<%>)]) @defmethod[(remove-card [card (is-a?/c card<%>)])
void?]{ void?]{
@ -227,6 +229,19 @@ Removes @scheme[card] from the table.}
Like @method[table<%> flip-cards], but only for @scheme[card] or Like @method[table<%> flip-cards], but only for @scheme[card] or
elements of @scheme[cards] that are currently face down/up.} elements of @scheme[cards] that are currently face down/up.}
@defmethod*[([(rotate-card [card (is-a?/c card<%>)]
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
void?]
[(rotate-cards [cards (listof (is-a?/c card<%>))]
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
void?])]{
Rotates @scheme[card] or all @scheme[cards] (at once, currently
without animation, but animation may be added in the future).
The center of each card is kept in place, except that the card is
moved as necessary to keep it on the table. See @xmethod[card<%>
rotate] for information on @scheme[mode].}
@defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?] @defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?]
[(card-to-back [card (is-a?/c card<%>)]) void?])]{ [(card-to-back [card (is-a?/c card<%>)]) void?])]{
@ -384,13 +399,13 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
@defmethod[(card-width) exact-nonnegative-integer?]{ @defmethod[(card-width) exact-nonnegative-integer?]{
Returns the width of the card in pixels. All cards have the same Returns the width of the card in pixels. If the card is rotated 90 or
width.} 270 degrees, the result is the card's original height.}
@defmethod[(card-height) exact-nonnegative-integer?]{ @defmethod[(card-height) exact-nonnegative-integer?]{
Returns the height of the card in pixels. All cards have the same Returns the height of the card in pixels. If the card is rotated 90 or
height.} 270 degrees, the result is the card's original width.}
@defmethod[(flip) void?]{ @defmethod[(flip) void?]{
@ -409,6 +424,22 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
Returns @scheme[#t] if the card is currently face down.} Returns @scheme[#t] if the card is currently face down.}
@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{
Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method,
the card's top-left position is kept in place.
If @scheme[mode] is @scheme['cw], the card is
rotated clockwise; if @scheme[mode] is @scheme['ccw], the card is
rotated counter-clockwise; if @scheme[mode] is one of the allowed
numbers, the card is rotated the corresponding amount in degrees
counter-clockwise.}
@defmethod[(orientation) (or/c 0 90 180 270)]{
Returns the orientation of the card, where @scheme[0] corresponds to
its initial state, @scheme[90] is rotated 90 degrees counter-clockwise, and so on.}
@defmethod[(get-suit-id) any/c]{ @defmethod[(get-suit-id) any/c]{
Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4] Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4]
@ -476,7 +507,7 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
@defmethod*[([(dim) boolean?] @defmethod*[([(dim) boolean?]
[(dim [can? any/c]) void?])]{ [(dim [can? any/c]) void?])]{
Gets/sets a hilite on the card, whichis rendered by drawing it dimmer Gets/sets a hilite on the card, which is rendered by drawing it dimmer
than normal.} than normal.}
@defmethod[(copy) (is-a?/c card<%>)]{ @defmethod[(copy) (is-a?/c card<%>)]{

64
collects/games/cards/classes.ss
View File

@ -519,6 +519,27 @@
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards)))
(flip-step (lambda () (for-each (lambda (c) (send c flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c flip)) cards)))
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))] (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))]
[rotate-card
(lambda (card mode) (rotate-cards (list card) mode))]
[rotate-cards
(lambda (cards mode)
(begin-card-sequence)
(let ([tw (table-width)]
[th (table-height)])
(map (lambda (c)
(let ([w (send c card-width)]
[h (send c card-height)])
(send c rotate mode)
(let ([w2 (send c card-width)]
[h2 (send c card-height)]
[x (box 0)]
[y (box 0)])
(send pb get-snip-location c x y)
(send pb move-to c
(min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2))
(min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2))))))
cards)
(end-card-sequence)))]
[card-face-up [card-face-up
(lambda (card) (lambda (card)
(cards-face-up (list card)))] (cards-face-up (list card)))]
@ -695,27 +716,28 @@
(send pb only-front-selected)))] (send pb only-front-selected)))]
[position-cards-in-region [position-cards-in-region
(lambda (cards r set) (lambda (cards r set)
(let-values ([(x y w h) (send pb get-region-box r)] (unless (null? cards)
[(len) (sub1 (length cards))] (let-values ([(x y w h) (send pb get-region-box r)]
[(cw ch) (values (send back get-width) [(len) (sub1 (length cards))]
(send back get-height))]) [(cw ch) (values (send (car cards) card-width)
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] (send (car cards) card-height))])
[pw (pretty cw)] (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
[ph (pretty ch)]) [pw (pretty cw)]
(let-values ([(x w) (if (> w pw) [ph (pretty ch)])
(values (+ x (/ (- w pw) 2)) pw) (let-values ([(x w) (if (> w pw)
(values x w))] (values (+ x (/ (- w pw) 2)) pw)
[(y h) (if (> h ph) (values x w))]
(values (+ y (/ (- h ph) 2)) ph) [(y h) (if (> h ph)
(values y h))]) (values (+ y (/ (- h ph) 2)) ph)
(position-cards cards x y (values y h))])
(lambda (p) (position-cards cards x y
(if (zero? len) (lambda (p)
(values (/ (- w cw) 2) (if (zero? len)
(/ (- h ch) 2)) (values (/ (- w cw) 2)
(values (* (- len p) (/ (- w cw) len)) (/ (- h ch) 2))
(* (- len p) (/ (- h ch) len))))) (values (* (- len p) (/ (- w cw) len))
set)))))]) (* (- len p) (/ (- h ch) len)))))
set))))))])
(super-new [label title] [style '(metal no-resize-border)]) (super-new [label title] [style '(metal no-resize-border)])
(begin (begin
(define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll))) (define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll)))

25
collects/games/cards/make-cards.ss
View File

@ -9,15 +9,6 @@
(define (get-bitmap file) (define (get-bitmap file)
(make-object mred:bitmap% file)) (make-object mred:bitmap% file))
(define (make-semi bm-in w h)
(let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)]
[mdc (make-object mred:bitmap-dc%)])
(send mdc set-bitmap bm)
(send mdc set-scale 0.5 1)
(send mdc draw-bitmap bm-in 0 0)
(send mdc set-bitmap #f)
bm))
(define (make-dim bm-in) (define (make-dim bm-in)
(let ([w (send bm-in get-width)] (let ([w (send bm-in get-width)]
[h (send bm-in get-height)]) [h (send bm-in get-height)])
@ -46,11 +37,6 @@
(define back (get-bitmap (here "card-back.png"))) (define back (get-bitmap (here "card-back.png")))
(define semi-back
(let ([w (send back get-width)]
[h (send back get-height)])
(make-semi back w h)))
(define dim-back (define dim-back
(make-dim back)) (make-dim back))
@ -74,9 +60,9 @@
value value
w h w h
front back front back
(make-semi front w h) semi-back
(lambda () (make-dim front)) (lambda () (make-dim front))
(lambda () dim-back)) (lambda () dim-back)
(make-hash-table 'equal))
(vloop (sub1 value)))))))))) (vloop (sub1 value))))))))))
(define (make-card front-bm back-bm suit-id value) (define (make-card front-bm back-bm suit-id value)
@ -87,12 +73,9 @@
value value
w h w h
front-bm (or back-bm back) front-bm (or back-bm back)
(make-semi front-bm w h)
(if back-bm
(make-semi back-bm w h)
semi-back)
(lambda () (make-dim front-bm)) (lambda () (make-dim front-bm))
(lambda () (lambda ()
(if back-bm (if back-bm
(make-dim back) (make-dim back)
dim-back)))))) dim-back))
(make-hash-table 'equal)))))

24
collects/games/chat-noir/chat-noir.ss
View File

@ -1,14 +1,9 @@
#| ;; constants
hint: include the size of the board in your world structure
This enables you to make test cases with different size boards,
making some of the test cases much easier to manage.
|#
(define circle-radius 20) (define circle-radius 20)
(define circle-spacing 22) (define circle-spacing 22)
;; data definitions
;; a world is: ;; a world is:
;; (make-world board posn state number) ;; (make-world board posn state number)
(define-struct world (board cat state size)) (define-struct world (board cat state size))
@ -138,21 +133,20 @@ making some of the test cases much easier to manage.
;; board->image : board number -> image ;; board->image : board number -> image
(define (board->image cs world-size) (define (board->image cs world-size)
(foldl overlay (foldl (lambda (x y) (overlay y x))
(nw:rectangle (world-width world-size) (nw:rectangle (world-width world-size)
(world-height world-size) (world-height world-size)
'outline 'solid
'black) 'white)
(map cell->image cs))) (map cell->image cs)))
(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3) (check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3)
(overlay (overlay
(cell->image
(make-cell (make-posn 0 0) false))
(nw:rectangle (world-width 3) (nw:rectangle (world-width 3)
(world-height 3) (world-height 3)
'outline 'solid
'black))) 'white)
(cell->image (make-cell (make-posn 0 0) false))))
;; cell->image : cell -> image ;; cell->image : cell -> image

4
collects/gui-debugger/debug-tool.ss
View File

@ -1278,7 +1278,9 @@
(new switchable-button% (new switchable-button%
(label (string-constant debug-tool-button-name)) (label (string-constant debug-tool-button-name))
(bitmap debug-bitmap) (bitmap debug-bitmap)
(parent (make-object vertical-pane% (get-button-panel))) (parent (new vertical-pane%
[parent (get-button-panel)]
[alignment '(center center)]))
(callback (λ (button) (debug-callback))))) (callback (λ (button) (debug-callback)))))
(inherit register-toolbar-button) (inherit register-toolbar-button)
(register-toolbar-button debug-button) (register-toolbar-button debug-button)

10
collects/handin-server/checker.ss
View File

@ -78,7 +78,7 @@
(let ([line (bytes->string/utf-8 line)]) (let ([line (bytes->string/utf-8 line)])
(unless (or (< (string-length line) len) (unless (or (< (string-length line) len)
(< (string-width line) len)) (< (string-width line) len))
(error* "~a \"~a\" in \"~a\" is longer than ~a characters" (error* "~a \"~a\" in ~a is longer than ~a characters"
(if n (format "Line #~a" n) "The line") (if n (format "Line #~a" n) "The line")
(regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1") (regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1")
(currently-processed-file-name) (currently-processed-file-name)
@ -148,7 +148,8 @@
(define current-processed-file ; set when processing multi-file submissions (define current-processed-file ; set when processing multi-file submissions
(make-parameter #f)) (make-parameter #f))
(define (currently-processed-file-name) (define (currently-processed-file-name)
(or (current-processed-file) "your code")) (let ([c (current-processed-file)])
(if c (format "\"~a\"" c) "your code")))
(define (input->process->output maxwidth textualize? untabify? bad-re) (define (input->process->output maxwidth textualize? untabify? bad-re)
(let loop ([n 1]) (let loop ([n 1])
@ -164,7 +165,7 @@
[line (if (and untabify? (regexp-match? #rx"\t" line)) [line (if (and untabify? (regexp-match? #rx"\t" line))
(untabify line) line)]) (untabify line) line)])
(when (and bad-re (regexp-match? bad-re line)) (when (and bad-re (regexp-match? bad-re line))
(error* "You cannot use \"~a\" in \"~a\"!~a" (error* "You cannot use \"~a\" in ~a!~a"
(if (regexp? bad-re) (object-name bad-re) bad-re) (if (regexp? bad-re) (object-name bad-re) bad-re)
(currently-processed-file-name) (currently-processed-file-name)
(if textualize? "" (format " (line ~a)" n)))) (if textualize? "" (format " (line ~a)" n))))
@ -650,6 +651,9 @@
(define (procedure/arity? proc arity) (define (procedure/arity? proc arity)
(and (procedure? proc) (procedure-arity-includes? proc arity))) (and (procedure? proc) (procedure-arity-includes? proc arity)))
(define (get-namespace evaluator)
(call-in-sandbox-context evaluator (lambda () (current-namespace))))
(provide !defined) (provide !defined)
(define-syntax-rule (!defined id ...) (define-syntax-rule (!defined id ...)
;; expected to be used only with identifiers ;; expected to be used only with identifiers

6
collects/handin-server/main.ss
View File

@ -10,7 +10,7 @@
"private/run-status.ss" "private/run-status.ss"
"private/reloadable.ss" "private/reloadable.ss"
"private/hooker.ss" "private/hooker.ss"
"web-status-server.ss" (prefix-in web: "web-status-server.ss")
;; this sets some global parameter values, and this needs ;; this sets some global parameter values, and this needs
;; to be done in the main thread, rather than later in a ;; to be done in the main thread, rather than later in a
;; user session thread (that will make the global changes ;; user session thread (that will make the global changes
@ -622,9 +622,7 @@
(log-line "server started ------------------------------") (log-line "server started ------------------------------")
(hook 'server-start `([port ,(get-conf 'port-number)])) (hook 'server-start `([port ,(get-conf 'port-number)]))
(define stop-status (define stop-status (web:run))
(cond [(get-conf 'https-port-number) => serve-status]
[else void]))
(define session-count 0) (define session-count 0)

1
collects/handin-server/private/config.ss
View File

@ -74,7 +74,6 @@
[(allow-new-users) (values #f id )] [(allow-new-users) (values #f id )]
[(allow-change-info) (values #f id )] [(allow-change-info) (values #f id )]
[(master-password) (values #f id )] [(master-password) (values #f id )]
[(web-base-dir) (values #f path/false )]
[(log-output) (values #t id )] [(log-output) (values #t id )]
[(log-file) (values "log" path/false )] [(log-file) (values "log" path/false )]
[(web-log-file) (values #f path/false )] [(web-log-file) (values #f path/false )]

5
collects/handin-server/scribblings/quick-start.scrbl
View File

@ -50,9 +50,8 @@
The submitted file will be @filepath{.../test/tester/handin.scm}.} The submitted file will be @filepath{.../test/tester/handin.scm}.}
@item{Check the status of your submission by pointing a web browser at @item{Check the status of your submission by pointing a web browser at
@tt{https://localhost:7980/servlets/status.ss}. Note the ``s'' in @tt{https://localhost:7980/}. Note the ``s'' in ``https''. Use the
``https''. Use the ``@tt{tester}'' username and ``@tt{pw}'' ``@tt{tester}'' username and ``@tt{pw}'' password, as before.
password, as before.
NOTE: The @scheme[https-port-number] line in the NOTE: The @scheme[https-port-number] line in the
@filepath{config.ss} file enables the embedded secure server. You @filepath{config.ss} file enables the embedded secure server. You

24
collects/handin-server/scribblings/server-setup.scrbl
View File

@ -114,16 +114,6 @@ This directory contains the following files and sub-directories:
option), or @scheme[#f] for no log file; defaults to option), or @scheme[#f] for no log file; defaults to
@filepath{log}.} @filepath{log}.}
@item{@indexed-scheme[web-base-dir] --- if @scheme[#f] (the
default), the built-in web server will use the
@filepath{status-web-root} in the handin collection for its
configuration; to have complete control over the built in server
content, you can copy and edit @filepath{status-web-root}, then
add this configuration entry set to the name of your new copy
(relative to the handin server directory, or absolute). Note that
you must copy the @filepath{servlets} directory if you want the
status servlet.}
@item{@indexed-scheme[web-log-file] --- a path (relative to handin @item{@indexed-scheme[web-log-file] --- a path (relative to handin
server directory or absolute) that specifies a filename for server directory or absolute) that specifies a filename for
logging the internal HTTPS status web server; or @scheme[#f] (the logging the internal HTTPS status web server; or @scheme[#f] (the
@ -218,11 +208,11 @@ This directory contains the following files and sub-directories:
Changes to @filepath{config.ss} are detected, the file will be Changes to @filepath{config.ss} are detected, the file will be
re-read, and options are reloaded. A few options are fixed at re-read, and options are reloaded. A few options are fixed at
startup time: port numbers, log file specs, and the startup time: port numbers and log file specs are fixed as
@scheme[web-base-dir] are fixed as configured at startup. All other configured at startup. All other options will change the behavior
options will change the behavior of the running server (but things of the running server (but things like
like @scheme[username-case-sensitive?] it would be unwise to do @scheme[username-case-sensitive?] it would be unwise to do so).
so). (For safety, options are not reloaded until the file parses (For safety, options are not reloaded until the file parses
correctly, but make sure that you don't save a copy that has correctly, but make sure that you don't save a copy that has
inconsistent options: it is best to create a new configuration file inconsistent options: it is best to create a new configuration file
and move it over the old one, or use an editor that does so and not and move it over the old one, or use an editor that does so and not
@ -482,11 +472,11 @@ the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server A student can download his/her own submissions through a web server
that runs concurrently with the handin server. The starting URL is that runs concurrently with the handin server. The starting URL is
@commandline{https://SERVER:PORT/servlets/status.ss} @commandline{https://SERVER:PORT/}
to obtain a list of all assignments, or to obtain a list of all assignments, or
@commandline{https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT} @commandline{https://SERVER:PORT/?handin=ASSIGNMENT}
to start with a specific assignment (named ASSIGNMENT). The default to start with a specific assignment (named ASSIGNMENT). The default
PORT is 7980. PORT is 7980.

8
collects/handin-server/status-web-root/index.html
View File

@ -1,8 +0,0 @@
<html>
<head><title>Handin Status Web Server</title></head>
<body>
The handin status server is running.
<br>
You can <a href="/status.ss">check your submissions</a> on this server.
</body>
</html>

277
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -1,277 +0,0 @@
(module status mzscheme
(require mzlib/file
mzlib/list
mzlib/string
mzlib/date
web-server/servlet
web-server/servlet/servlet-structs
web-server/managers/timeouts
web-server/private/util
net/uri-codec
net/url
handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker)
(define get-user-data
(let ([users-file (build-path server-dir "users.ss")])
(lambda (user)
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
(define (clean-str s)
(regexp-replace #rx" *$" (regexp-replace #rx"^ *" s "") ""))
(define (aget alist key)
(cond [(assq key alist) => cdr] [else #f]))
(define (make-page title . body)
`(html (head (title ,title))
(body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
(define (relativize-path p)
(path->string (find-relative-path (normalize-path server-dir) p)))
(define (make-k k tag)
(format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(uri-encode tag)))
;; `look-for' can be a username as a string (will find "bar+foo" for "foo"),
;; or a regexp that should match the whole directory name (used with
;; "^solution" below)
(define (find-handin-entry hi look-for)
(let ([dir (assignment<->dir hi)])
(and (directory-exists? dir)
(ormap
(lambda (d)
(let ([d (path->string d)])
(and (cond [(string? look-for)
(member look-for (regexp-split #rx" *[+] *" d))]
[(regexp? look-for) (regexp-match? look-for d)]
[else (error 'find-handin-entry
"internal error: ~e" look-for)])
(build-path dir d))))
(directory-list dir)))))
(define (handin-link k user hi)
(let* ([dir (find-handin-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir])
(sort (filter (lambda (f)
(and (not (equal? f "grade"))
(file-exists? f)))
(map path->string (directory-list)))
string<?))))])
(if (pair? l)
(cdr (apply append
(map (lambda (f)
(let ([hi (build-path dir f)])
`((br)
(a ([href ,(make-k k (relativize-path hi))]) ,f)
" ("
,(date->string
(seconds->date
(file-or-directory-modify-seconds hi))
#t)
")")))
l)))
(list (format "No handins accepted so far for user ~s, assignment ~s"
user hi)))))
(define (solution-link k hi)
(let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
(find-handin-entry hi #rx"^solution"))]
[none `((i "---"))])
(cond [(not soln) none]
[(file-exists? soln)
`((a ((href ,(make-k k (relativize-path soln)))) "Solution"))]
[(directory-exists? soln)
(parameterize ([current-directory soln])
(let ([files (sort (map path->string
(filter file-exists? (directory-list)))
string<?)])
(if (null? files)
none
(apply append
(map (lambda (f)
`((a ([href ,(make-k k (relativize-path
(build-path soln f)))])
(tt ,f))
(br)))
files)))))]
[else none])))
(define (handin-grade user hi)
(let* ([dir (find-handin-entry hi user)]
[grade (and dir
(let ([filename (build-path dir "grade")])
(and (file-exists? filename)
(with-input-from-file filename
(lambda ()
(read-string (file-size filename)))))))])
(or grade "--")))
(define (one-status-page user for-handin)
(let* ([next (send/suspend
(lambda (k)
(make-page (format "User: ~a, Handin: ~a" user for-handin)
`(p ,@(handin-link k user for-handin))
`(p "Grade: " ,(handin-grade user for-handin))
`(p ,@(solution-link k for-handin))
`(p (a ([href ,(make-k k "allofthem")])
,(format "All handins for ~a" user))))))]
[tag (aget (request-bindings next) 'tag)])
(if (string=? tag "allofthem")
(all-status-page user)
(download user tag))))
(define (all-status-page user)
(define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
(define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
(define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
(define ((row k active?) dir)
(let ([hi (assignment<->dir dir)])
`(tr ([valign "top"])
,(apply header hi
(if active? `((br) (small (small "[active]"))) '()))
,(apply cell (handin-link k user hi))
,(rcell (handin-grade user hi))
,(apply cell (solution-link k hi)))))
(let* ([next
(send/suspend
(lambda (k)
(make-page
(format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(append (map (row k #t) (get-conf 'active-dirs))
(map (row k #f) (get-conf 'inactive-dirs)))))))]
[tag (aget (request-bindings next) 'tag)])
(download user tag)))
(define (download who tag)
(define (check path elts allow-active?)
(let loop ([path path] [elts (reverse elts)])
(let*-values ([(base name dir?) (split-path path)]
[(name) (path->string name)]
[(check) (and (pair? elts) (car elts))])
(if (null? elts)
;; must be rooted in a submission directory (why build-path instead
;; of using `path'? -- because path will have a trailing slash)
(member (build-path base name)
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
(and (cond [(eq? '* check) #t]
[(regexp? check) (regexp-match? check name)]
[(string? check)
(or (equal? name check)
(member check (regexp-split #rx" *[+] *" name)))]
[else #f])
(loop base (cdr elts)))))))
(define file (build-path server-dir tag))
(with-handlers ([exn:fail?
(lambda (exn)
(log-line "Status exception: ~a" (exn-message exn))
(make-page "Error" "Illegal file access"))])
;; Make sure the user is allowed to read the requested file:
(or (check file `(,who *) #t)
(check file `(#rx"^solution") #f)
(check file `(#rx"^solution" *) #f)
(error 'download "bad file access for ~s: ~a" who file))
(log-line "Status file-get: ~s ~a" who file)
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
;; Return the downloaded file
(let* ([data (with-input-from-file file
(lambda () (read-bytes (file-size file))))]
[html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match? #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)])
(make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"]
[wxme? #"application/data"]
[else #"text/plain"])
(list
(make-header #"Content-Length"
(string->bytes/latin-1
(number->string (bytes-length data))))
(make-header #"Content-Disposition"
(string->bytes/utf-8
(format "~a; filename=~s"
(if wxme? "attachment" "inline")
(let-values ([(base name dir?) (split-path file)])
(path->string name))))))
(list data)))))
(define (status-page user for-handin)
(log-line "Status access: ~s" user)
(hook 'status-login `([username ,(string->symbol user)]))
(if for-handin
(one-status-page user for-handin)
(all-status-page user)))
(define (login-page status for-handin errmsg)
(let* ([request
(send/suspend
(lambda (k)
(make-page
"Handin Status Login"
`(form ([action ,k] [method "post"])
(table ([align "center"])
(tr (td ([colspan "2"] [align "center"])
(font ([color "red"]) ,(or errmsg 'nbsp))))
(tr (td "Username")
(td (input ([type "text"] [name "user"] [size "20"]
[value ""]))))
(tr (td nbsp))
(tr (td "Password")
(td (input ([type "password"] [name "passwd"]
[size "20"] [value ""]))))
(tr (td ([colspan "2"] [align "center"])
(input ([type "submit"] [name "post"]
[value "Login"])))))))))]
[bindings (request-bindings request)]
[user (aget bindings 'user)]
[passwd (aget bindings 'passwd)]
[user (and user (clean-str user))]
[user-data (get-user-data user)])
(cond [(and user-data
(string? passwd)
(let ([pw (md5 passwd)])
(or (equal? pw (car user-data))
(equal? pw (get-conf 'master-password)))))
(status-page user for-handin)]
[else (login-page status for-handin "Bad username or password")])))
(define web-counter
(let ([sema (make-semaphore 1)]
[count 0])
(lambda ()
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda () (set! count (add1 count)) (format "w~a" count))
(lambda () (semaphore-post sema))))))
(define (start initial-request)
(parameterize ([current-session (web-counter)])
(login-page null (aget (request-bindings initial-request) 'handin) #f)))
(define interface-version 'v2)
(define name "status")
(define (instance-expiration-handler failed-request)
(let* (;; get the current url, and strip off the continuation data
[cont-url (request-uri failed-request)]
[base-url (url-replace-path
(lambda (pl)
(map (lambda (pp)
(make-path/param (path/param-path pp) empty))
pl))
cont-url)]
[base-url-str (url->string base-url)])
`(html (head (meta [(http-equiv "refresh")
(content ,(format "3;URL=~a" base-url-str))]))
(body "Your session has expired, "
(a ([href ,base-url-str]) "restarting") " in 3 seconds."))))
(define manager
(create-timeout-manager instance-expiration-handler 600 600))
(provide interface-version start name manager))

351
collects/handin-server/web-status-server.ss
View File

@ -1,82 +1,283 @@
#lang scheme/base #lang scheme
(require scheme/unit (require scheme/list
net/ssl-tcp-unit scheme/file
net/tcp-sig scheme/date
net/tcp-unit net/uri-codec
(only-in mzlib/etc this-expression-source-directory) web-server/servlet
web-server/web-server-unit web-server/servlet-env
web-server/web-server-sig web-server/managers/lru
web-server/web-config-sig handin-server/private/md5
web-server/web-config-unit handin-server/private/logger
web-server/configuration/namespace handin-server/private/config
"private/config.ss") handin-server/private/hooker)
(provide serve-status) (define (aget alist key)
(cond [(assq key alist) => cdr] [else #f]))
(define (serve-status port-no) (define (clean-str s)
(regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") ""))
(define ((in-dir dir) . paths) (path->string (apply build-path dir paths))) (define (make-page title . body)
(define in-web-dir `(html (head (title ,title))
(in-dir (or (get-conf 'web-base-dir) (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
(build-path (this-expression-source-directory)
"status-web-root"))))
(define in-plt-web-dir
(in-dir (build-path (collection-path "web-server") "default-web-root")))
(define config (define get-user-data
`((port ,port-no) (let ([users-file (build-path server-dir "users.ss")])
(max-waiting 40) (unless (file-exists? users-file)
(initial-connection-timeout 30) (error 'get-user-data "users file missing at: ~a" users-file))
(default-host-table (lambda (user)
(host-table (get-preference (string->symbol user) (lambda () #f) #f users-file))))
(default-indices "index.html")
(log-format parenthesized-default)
(messages
(servlet-message "servlet-error.html")
(authentication-message "forbidden.html")
(servlets-refreshed "servlet-refresh.html")
(passwords-refreshed "passwords-refresh.html")
(file-not-found-message "not-found.html")
(protocol-message "protocol-error.html")
(collect-garbage "collect-garbage.html"))
(timeouts
(default-servlet-timeout 120)
(password-connection-timeout 300)
(servlet-connection-timeout 86400)
(file-per-byte-connection-timeout 1/20)
(file-base-connection-timeout 30))
(paths
(configuration-root ,(in-plt-web-dir "conf"))
(host-root ".")
(log-file-path ,(cond [(get-conf 'web-log-file) => path->string]
[else #f]))
(file-root ".")
(servlet-root ,(in-web-dir "servlets"))
(mime-types ,(in-plt-web-dir "mime.types"))
(password-authentication ,(in-plt-web-dir "passwords")))))
(virtual-host-table)))
(define configuration (define (relativize-path p)
(configuration-table-sexpr->web-config@ (path->string (find-relative-path (normalize-path server-dir) p)))
config
#:web-server-root (in-web-dir)
#:make-servlet-namespace
(make-make-servlet-namespace
#:to-be-copied-module-specs
'(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable))))
(define-unit-binding config@ configuration (import) (export web-config^)) (define (make-k k tag)
(define-unit-binding ssl-tcp@ (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f) (uri-encode tag)))
(import) (export tcp^))
(define-compound-unit/infer status-server@
(import)
(link ssl-tcp@ config@ web-server@)
(export web-server^))
(define-values/invoke-unit/infer status-server@)
(serve)) ;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), or
;; a regexp that should match the whole directory name (used with "^solution"
;; below)
(define (find-handin-entry hi look-for)
(let ([dir (assignment<->dir hi)])
(and (directory-exists? dir)
(ormap
(lambda (d)
(let ([d (path->string d)])
(and (cond [(string? look-for)
(member look-for (regexp-split #rx" *[+] *" d))]
[(regexp? look-for) (regexp-match? look-for d)]
[else (error 'find-handin-entry
"internal error: ~e" look-for)])
(build-path dir d))))
(directory-list dir)))))
(define (handin-link k user hi)
(let* ([dir (find-handin-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir])
(sort (filter (lambda (f)
(and (not (equal? f "grade"))
(file-exists? f)))
(map path->string (directory-list)))
string<?))))])
(if (pair? l)
(cdr (append-map
(lambda (f)
(let ([hi (build-path dir f)])
`((br)
(a ([href ,(make-k k (relativize-path hi))]) ,f)
" ("
,(date->string
(seconds->date (file-or-directory-modify-seconds hi))
#t)
")")))
l))
(list (format "No handins accepted so far for user ~s, assignment ~s"
user hi)))))
(define (solution-link k hi)
(let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
(find-handin-entry hi #rx"^solution"))]
[none `((i "---"))])
(cond [(not soln) none]
[(file-exists? soln)
`((a ((href ,(make-k k (relativize-path soln)))) "Solution"))]
[(directory-exists? soln)
(parameterize ([current-directory soln])
(let ([files (sort (map path->string
(filter file-exists? (directory-list)))
string<?)])
(if (null? files)
none
(apply append
(map (lambda (f)
`((a ([href ,(make-k k (relativize-path
(build-path soln f)))])
(tt ,f))
(br)))
files)))))]
[else none])))
(define (handin-grade user hi)
(let* ([dir (find-handin-entry hi user)]
[grade (and dir
(let ([filename (build-path dir "grade")])
(and (file-exists? filename)
(with-input-from-file filename
(lambda ()
(read-string (file-size filename)))))))])
(or grade "--")))
(define (one-status-page user for-handin)
(let* ([next (send/suspend
(lambda (k)
(make-page (format "User: ~a, Handin: ~a" user for-handin)
`(p ,@(handin-link k user for-handin))
`(p "Grade: " ,(handin-grade user for-handin))
`(p ,@(solution-link k for-handin))
`(p (a ([href ,(make-k k "allofthem")])
,(format "All handins for ~a" user))))))]
[tag (aget (request-bindings next) 'tag)])
(if (string=? tag "allofthem")
(all-status-page user)
(download user tag))))
(define (all-status-page user)
(define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
(define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
(define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
(define ((row k active?) dir)
(let ([hi (assignment<->dir dir)])
`(tr ([valign "top"])
,(apply header hi (if active? `((br) (small (small "[active]"))) '()))
,(apply cell (handin-link k user hi))
,(rcell (handin-grade user hi))
,(apply cell (solution-link k hi)))))
(let* ([next
(send/suspend
(lambda (k)
(make-page
(format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(append (map (row k #t) (get-conf 'active-dirs))
(map (row k #f) (get-conf 'inactive-dirs)))))))]
[tag (aget (request-bindings next) 'tag)])
(download user tag)))
(define (download who tag)
(define (check path elts allow-active?)
(let loop ([path path] [elts (reverse elts)])
(let*-values ([(base name dir?) (split-path path)]
[(name) (path->string name)]
[(check) (and (pair? elts) (car elts))])
(if (null? elts)
;; must be rooted in a submission directory (why build-path instead
;; of using `path'? -- because path will have a trailing slash)
(member (build-path base name)
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
(and (cond [(eq? '* check) #t]
[(regexp? check) (regexp-match? check name)]
[(string? check)
(or (equal? name check)
(member check (regexp-split #rx" *[+] *" name)))]
[else #f])
(loop base (cdr elts)))))))
(define file (build-path server-dir tag))
(with-handlers ([exn:fail?
(lambda (exn)
(log-line "Status exception: ~a" (exn-message exn))
(make-page "Error" "Illegal file access"))])
;; Make sure the user is allowed to read the requested file:
(or (check file `(,who *) #t)
(check file `(#rx"^solution") #f)
(check file `(#rx"^solution" *) #f)
(error 'download "bad file access for ~s: ~a" who file))
(log-line "Status file-get: ~s ~a" who file)
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
;; Return the downloaded file
(let* ([data (file->bytes file)]
[html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match?
#rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)])
(make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"]
[wxme? #"application/data"]
[else #"text/plain"])
(list
(make-header #"Content-Length"
(string->bytes/latin-1
(number->string (bytes-length data))))
(make-header #"Content-Disposition"
(string->bytes/utf-8
(format "~a; filename=~s"
(if wxme? "attachment" "inline")
(let-values ([(base name dir?) (split-path file)])
(path->string name))))))
(list data)))))
(define (status-page user for-handin)
(log-line "Status access: ~s" user)
(hook 'status-login `([username ,(string->symbol user)]))
(if for-handin
(one-status-page user for-handin)
(all-status-page user)))
(define (login-page for-handin errmsg)
(let* ([request
(send/suspend
(lambda (k)
(make-page
"Handin Status Login"
`(form ([action ,k] [method "post"])
(table ([align "center"])
(tr (td ([colspan "2"] [align "center"])
(font ([color "red"]) ,(or errmsg 'nbsp))))
(tr (td "Username")
(td (input ([type "text"] [name "user"] [size "20"]
[value ""]))))
(tr (td nbsp))
(tr (td "Password")
(td (input ([type "password"] [name "passwd"]
[size "20"] [value ""]))))
(tr (td ([colspan "2"] [align "center"])
(input ([type "submit"] [name "post"]
[value "Login"])))))))))]
[bindings (request-bindings request)]
[user (aget bindings 'user)]
[passwd (aget bindings 'passwd)]
[user (and user (clean-str user))]
[user-data (get-user-data user)])
(cond [(and user-data
(string? passwd)
(let ([pw (md5 passwd)])
(or (equal? pw (car user-data))
(equal? pw (get-conf 'master-password)))))
(status-page user for-handin)]
[else (login-page for-handin "Bad username or password")])))
(define web-counter
(let ([sema (make-semaphore 1)] [count 0])
(lambda ()
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda () (set! count (add1 count)) (format "w~a" count))
(lambda () (semaphore-post sema))))))
(define ((send-error msg) req)
`(html (head (meta [(http-equiv "refresh") (content "3;URL=/")])
(title ,msg))
(body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds.")))
(define ((run-servlet port))
(define dir (string->path server-dir))
(serve/servlet
(lambda (request)
(parameterize ([current-session (web-counter)])
(login-page (aget (request-bindings request) 'handin) #f)))
#:port port #:listen-ip #f #:ssl? #t #:command-line? #t
#:servlet-path "/" #:servlet-regexp #rx""
#:server-root-path dir #:servlets-root dir
#:file-not-found-responder (send-error "File not found")
#:servlet-namespace '(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable)
#:manager (make-threshold-LRU-manager
(send-error "Your session has expired") (* 12 1024 1024))
#:log-file (get-conf 'web-log-file)))
(provide run)
(define (run)
(cond [(get-conf 'https-port-number)
=> (lambda (p)
(define t
(thread (lambda ()
(dynamic-wind
(lambda () (log-line "*** starting web server"))
(run-servlet p)
(lambda () (log-line "*** web server died!"))))))
(lambda () (break-thread t)))]
[else void]))

62
collects/honu/main.ss
View File

@ -1295,36 +1295,38 @@
[exprs [exprs
(let ([def-ctx (syntax-local-make-definition-context)] (let ([def-ctx (syntax-local-make-definition-context)]
[ctx (generate-expand-context)]) [ctx (generate-expand-context)])
(let loop ([exprs (cddddr (cdr (syntax->list stx)))]) (begin0
(apply (let loop ([exprs (cddddr (cdr (syntax->list stx)))])
append (apply
(map (lambda (expr) append
(let ([expr (local-expand (map (lambda (expr)
expr (let ([expr (local-expand
ctx expr
block-expand-stop-forms ctx
def-ctx)]) block-expand-stop-forms
(syntax-case expr (begin define-values define-syntaxes) def-ctx)])
[(begin . rest) (syntax-case expr (begin define-values define-syntaxes)
(loop (syntax->list #'rest))] [(begin . rest)
[(define-syntaxes (id ...) rhs) (loop (syntax->list #'rest))]
(andmap identifier? (syntax->list #'(id ...))) [(define-syntaxes (id ...) rhs)
(with-syntax ([rhs (local-transformer-expand (andmap identifier? (syntax->list #'(id ...)))
#'rhs (with-syntax ([rhs (local-transformer-expand
'expression #'rhs
null)]) 'expression
(syntax-local-bind-syntaxes null)])
(syntax->list #'(id ...)) (syntax-local-bind-syntaxes
#'rhs def-ctx) (syntax->list #'(id ...))
(list #'(define-syntaxes (id ...) rhs)))] #'rhs def-ctx)
[(define-values (id ...) rhs) (list #'(define-syntaxes (id ...) rhs)))]
(andmap identifier? (syntax->list #'(id ...))) [(define-values (id ...) rhs)
(let ([ids (syntax->list #'(id ...))]) (andmap identifier? (syntax->list #'(id ...)))
(syntax-local-bind-syntaxes ids #f def-ctx) (let ([ids (syntax->list #'(id ...))])
(list expr))] (syntax-local-bind-syntaxes ids #f def-ctx)
[else (list expr))]
(list expr)]))) [else
exprs))))]) (list expr)])))
exprs)))
(internal-definition-context-seal def-ctx)))])
#`(let () #`(let ()
#,@(let loop ([exprs exprs][prev-defns null][prev-exprs null]) #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
(cond (cond

2
collects/htdch/draw/support.scm
View File

@ -74,7 +74,7 @@
(define (check-arg value method argument) (define (check-arg value method argument)
(or (> value 0) (or (> value 0)
(raise-error (raise-error
(format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value)))) (format "Method ~a expects an int > 0 for ~a argument, given ~a" method argument value))))
(define (to-lower-case s) (define (to-lower-case s)
(letrec ((lower (letrec ((lower

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

10
collects/lang/private/beginner-funs.ss
View File

@ -278,18 +278,18 @@
((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any)) ((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any))
"to create a single list from several, by juxtaposition of the items") "to create a single list from several, by juxtaposition of the items")
(length (list -> number) (length ((listof any) -> number)
"to compute the number of items on a list") "to compute the number of items on a list")
(memq (any list -> (union false list)) (memq (any (listof any) -> (union false list))
"to determine whether some value is on some list" "to determine whether some value is on some list"
" (comparing values with eq?)") " (comparing values with eq?)")
(memv (any list -> (union false list)) (memv (any (listof any) -> (union false list))
"to determine whether some value is on the list" "to determine whether some value is on the list"
" (comparing values with eqv?)") " (comparing values with eqv?)")
((beginner-member member) (any list -> boolean) ((beginner-member member) (any (listof any)-> boolean)
"to determine whether some value is on the list" "to determine whether some value is on the list"
" (comparing values with equal?)") " (comparing values with equal?)")
(reverse (list -> list) (reverse ((listof any) -> list)
"to create a reversed version of a list") "to create a reversed version of a list")
(assq (X (listof (cons X Y)) -> (union false (cons X Y))) (assq (X (listof (cons X Y)) -> (union false (cons X Y)))
"to determine whether some item is the first item of a pair" "to determine whether some item is the first item of a pair"

5
collects/macro-debugger/model/deriv-c.ss
View File

@ -89,6 +89,9 @@
(srenames sbindrhss vrenames vrhss body tag) (srenames sbindrhss vrenames vrhss body tag)
#:transparent) #:transparent)
;; (make-p:provide <Base> (listof Deriv) ?exn)
(define-struct (p:provide prule) (inners ?2) #:transparent)
;; (make-p:stop <Base>) ;; (make-p:stop <Base>)
;; (make-p:unknown <Base>) ;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx) ;; (make-p:#%top <Base> Stx)
@ -98,7 +101,6 @@
;; (make-p:require <Base>) ;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>) ;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>) ;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; (make-p:#%variable-reference <Base>) ;; (make-p:#%variable-reference <Base>)
(define-struct (p::STOP prule) () #:transparent) (define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent) (define-struct (p:stop p::STOP) () #:transparent)
@ -110,7 +112,6 @@
(define-struct (p:require p::STOP) () #:transparent) (define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax p::STOP) () #:transparent) (define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #:transparent) (define-struct (p:require-for-template p::STOP) () #:transparent)
(define-struct (p:provide p::STOP) () #:transparent)
(define-struct (p:#%variable-reference p::STOP) () #:transparent) (define-struct (p:#%variable-reference p::STOP) () #:transparent)
;; A LDeriv is ;; A LDeriv is

2
collects/macro-debugger/model/deriv-find.ss
View File

@ -75,6 +75,8 @@
(join (loops rhss) (loop body))] (join (loops rhss) (loop body))]
[(Wrap p:letrec-syntaxes+values (_ _ _ _ _ srhss _ vrhss body _)) [(Wrap p:letrec-syntaxes+values (_ _ _ _ _ srhss _ vrhss body _))
(join (loops srhss) (loops vrhss) (loop body))] (join (loops srhss) (loops vrhss) (loop body))]
[(Wrap p:provide (_ _ _ _ inners _))
(loops inners)]
[(Wrap p:module (_ _ _ _ _ _ _ check _ _ body _)) [(Wrap p:module (_ _ _ _ _ _ _ check _ _ body _))
(join (loop check) (loop body))] (join (loop check) (loop body))]
[(Wrap p:#%module-begin (_ _ _ _ _ pass1 pass2 _)) [(Wrap p:#%module-begin (_ _ _ _ _ pass1 pass2 _))

14
collects/macro-debugger/model/deriv-parser.ss
View File

@ -288,8 +288,8 @@
[() [()
(make mod:skip)] (make mod:skip)]
;; provide: special ;; provide: special
[(enter-prim prim-provide (? ModuleProvide/Inner) exit-prim) [(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
(make mod:cons (make p:provide $1 $4 null $3))] (make mod:cons (make p:provide $1 $5 null #f $3 $4))]
;; normal: expand completely ;; normal: expand completely
[((? EE)) [((? EE))
(make mod:cons $1)] (make mod:cons $1)]
@ -298,10 +298,10 @@
(make mod:lift $1 #f $2)]) (make mod:lift $1 #f $2)])
(ModuleProvide/Inner (ModuleProvide/Inner
[() #f] (#:skipped null)
[(!!) $1] [() null]
[(EE/Interrupted) $1] [((? EE) (? ModuleProvide/Inner))
[(EE (? ModuleProvide/Inner)) $2]) (cons $1 $2)])
;; Definitions ;; Definitions
(PrimDefineSyntaxes (PrimDefineSyntaxes
@ -442,7 +442,7 @@
(PrimProvide (PrimProvide
(#:args e1 e2 rs) (#:args e1 e2 rs)
[(prim-provide !) (make p:provide e1 e2 rs $2)]) [(prim-provide !) (make p:provide e1 e2 rs $2 null #f)])
(PrimVarRef (PrimVarRef
(#:args e1 e2 rs) (#:args e1 e2 rs)

20
collects/macro-debugger/model/reductions.ss
View File

@ -194,9 +194,23 @@
[#:pattern (?top . ?var)] [#:pattern (?top . ?var)]
[#:learn (list #'?var)])] [#:learn (list #'?var)])]
[(Wrap p:provide (e1 e2 rs ?1)) [(Wrap p:provide (e1 e2 rs ?1 inners ?2))
(R [! ?1] (let ([wrapped-inners
[#:walk e2 'provide])] (for/list ([inner inners])
(match inner
[(Wrap deriv (e1 e2))
(make local-expansion e1 e2
#f e1 inner #f e2 #f)]))])
(R [! ?1]
[#:pattern ?form]
[#:pass1]
[#:left-foot]
[LocalActions ?form wrapped-inners]
[! ?2]
[#:pass2]
[#:set-syntax e2]
[#:step 'provide]
[#:set-syntax e2]))]
[(Wrap p:stop (e1 e2 rs ?1)) [(Wrap p:stop (e1 e2 rs ?1))
(R [! ?1])] (R [! ?1])]

29
collects/macro-debugger/syntax-browser/display.ss
View File

@ -3,7 +3,6 @@
(require scheme/class (require scheme/class
scheme/gui scheme/gui
scheme/match scheme/match
"params.ss"
"pretty-printer.ss" "pretty-printer.ss"
"interfaces.ss" "interfaces.ss"
"util.ss") "util.ss")
@ -11,8 +10,8 @@
code-style) code-style)
;; print-syntax-to-editor : syntax text controller<%> -> display<%> ;; print-syntax-to-editor : syntax text controller<%> -> display<%>
(define (print-syntax-to-editor stx text controller) (define (print-syntax-to-editor stx text controller config)
(new display% (syntax stx) (text text) (controller controller))) (new display% (syntax stx) (text text) (controller controller) (config config)))
;; FIXME: assumes text never moves ;; FIXME: assumes text never moves
@ -22,6 +21,7 @@
(init ((stx syntax))) (init ((stx syntax)))
(init-field text) (init-field text)
(init-field controller) (init-field controller)
(init-field config)
(define start-anchor (new anchor-snip%)) (define start-anchor (new anchor-snip%))
(define end-anchor (new anchor-snip%)) (define end-anchor (new anchor-snip%))
@ -33,7 +33,7 @@
(with-unlock text (with-unlock text
(send text delete (get-start-position) (get-end-position)) (send text delete (get-start-position) (get-end-position))
(set! range (set! range
(print-syntax stx text controller (print-syntax stx text controller config
(lambda () (get-start-position)) (lambda () (get-start-position))
(lambda () (get-end-position)))) (lambda () (get-end-position))))
(apply-primary-partition-styles)) (apply-primary-partition-styles))
@ -131,7 +131,7 @@
(let ([delta (new style-delta%)]) (let ([delta (new style-delta%)])
(send delta set-delta-foreground color) (send delta set-delta-foreground color)
delta)) delta))
(define color-styles (list->vector (map color-style (current-colors)))) (define color-styles (list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray")) (define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition)) (define color-partition (send controller get-primary-partition))
(define offset (get-start-position)) (define offset (get-start-position))
@ -162,16 +162,20 @@
(render-syntax stx) (render-syntax stx)
(send controller add-syntax-display this))) (send controller add-syntax-display this)))
;; print-syntax : syntax controller (-> number) (-> number) ;; print-syntax : syntax text% controller config (-> number) (-> number)
;; -> range% ;; -> range%
(define (print-syntax stx text controller (define (print-syntax stx text controller config
get-start-position get-end-position) get-start-position get-end-position)
(define primary-partition (send controller get-primary-partition)) (define primary-partition (send controller get-primary-partition))
(define real-output-port (make-text-port text get-end-position)) (define real-output-port (make-text-port text get-end-position))
(define output-port (open-output-string)) (define output-port (open-output-string))
(define colors (send config get-colors))
(define suffix-option (send config get-suffix-option))
(define columns (send config get-columns))
(port-count-lines! output-port) (port-count-lines! output-port)
(let ([range (pretty-print-syntax stx output-port primary-partition)]) (let ([range (pretty-print-syntax stx output-port primary-partition
colors suffix-option columns)])
(write-string (get-output-string output-port) real-output-port) (write-string (get-output-string output-port) real-output-port)
(let ([end (get-end-position)]) (let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here. ;; Pretty printer always inserts final newline; we remove it here.
@ -189,7 +193,7 @@
(send range all-ranges))) (send range all-ranges)))
;; Set font to standard ;; Set font to standard
(send text change-style (send text change-style
(code-style text) (code-style text (send config get-syntax-font-size))
(get-start-position) (get-start-position)
(get-end-position)) (get-end-position))
range)) range))
@ -212,11 +216,10 @@
(send text insert char pos (add1 pos))) (send text insert char pos (add1 pos)))
(for-each fixup (send range all-ranges))) (for-each fixup (send range all-ranges)))
;; code-style : text<%> -> style<%> ;; code-style : text<%> number/#f -> style<%>
(define (code-style text) (define (code-style text font-size)
(let* ([style-list (send text get-style-list)] (let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")] [style (send style-list find-named-style "Standard")])
[font-size (current-syntax-font-size)])
(if font-size (if font-size
(send style-list find-or-create-style (send style-list find-or-create-style
style style

2
collects/macro-debugger/syntax-browser/embed.ss
View File

@ -3,11 +3,9 @@
(require "interfaces.ss" (require "interfaces.ss"
"widget.ss" "widget.ss"
"keymap.ss" "keymap.ss"
"params.ss"
"partition.ss") "partition.ss")
(provide (all-from-out "interfaces.ss") (provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss") (all-from-out "widget.ss")
(all-from-out "keymap.ss") (all-from-out "keymap.ss")
(all-from-out "params.ss")
identifier=-choices) identifier=-choices)

8
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -54,8 +54,7 @@
(define syntax-widget/controls% (define syntax-widget/controls%
(class* widget% () (class* widget% ()
(inherit get-main-panel (inherit get-main-panel
get-controller get-controller)
toggle-props)
(super-new) (super-new)
(inherit-field config) (inherit-field config)
@ -85,7 +84,10 @@
(new button% (new button%
(label "Properties") (label "Properties")
(parent -control-panel) (parent -control-panel)
(callback (lambda _ (toggle-props)))) (callback
(lambda _
(send config set-props-shown?
(not (send config get-props-shown?))))))
(send (get-controller) listen-identifier=? (send (get-controller) listen-identifier=?
(lambda (name+func) (lambda (name+func)

83
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
scheme/gui scheme/gui
"../util/notify.ss"
"interfaces.ss" "interfaces.ss"
"partition.ss") "partition.ss")
(provide smart-keymap% (provide smart-keymap%
@ -48,6 +49,7 @@
(set! on-demand-actions (cons p on-demand-actions))) (set! on-demand-actions (cons p on-demand-actions)))
(define/override (on-demand) (define/override (on-demand)
(super on-demand)
(for-each (lambda (p) (p)) on-demand-actions)) (for-each (lambda (p) (p)) on-demand-actions))
(super-new))) (super-new)))
@ -92,28 +94,42 @@
(lambda (i e) (lambda (i e)
(send config set-props-shown? #f))) (send config set-props-shown? #f)))
(define/public (add-edit-items) (define/private (selected-syntax)
(send controller get-selected-syntax))
(define/public (add-menu-items)
(set! copy-menu (set! copy-menu
(new menu-item% (label "Copy") (parent the-context-menu) (new menu-item% (label "Copy") (parent the-context-menu)
(callback (lambda (i e) (demand-callback
(call-function "copy-text" i e))))) (lambda (i)
(void)) (send i enable (and (selected-syntax) #t))))
(callback
(define/public (after-edit-items) (lambda (i e)
(void)) (call-function "copy-text" i e)))))
(add-separator)
(define/public (add-selection-items)
(set! clear-menu (set! clear-menu
(new menu-item% (new menu-item%
(label "Clear selection") (label "Clear selection")
(parent the-context-menu) (parent the-context-menu)
(demand-callback
(lambda (i)
(send i enable (and (selected-syntax) #t))))
(callback (callback
(lambda (i e) (lambda (i e)
(call-function "clear-syntax-selection" i e))))) (call-function "clear-syntax-selection" i e)))))
(set! props-menu (set! props-menu
(menu-option/notify-box the-context-menu
"View syntax properties"
(get-field props-shown? config))
#;
(new menu-item% (new menu-item%
(label "Show syntax properties") (label "Show syntax properties")
(parent the-context-menu) (parent the-context-menu)
(demand-callback
(lambda (i)
(if (send config get-props-shown?)
(send i set-label "Hide syntax properties")
(send i set-label "Show syntax properties"))))
(callback (callback
(lambda (i e) (lambda (i e)
(if (send config get-props-shown?) (if (send config get-props-shown?)
@ -121,55 +137,10 @@
(call-function "show-syntax-properties" i e)))))) (call-function "show-syntax-properties" i e))))))
(void)) (void))
(define/public (after-selection-items)
(void))
(define/public (add-partition-items)
(let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
(for-each
(lambda (name func)
(let ([this-choice
(new checkable-menu-item%
(label name)
(parent secondary)
(callback
(lambda (i e)
(send controller set-identifier=?
(cons name func)))))])
(send controller listen-identifier=?
(lambda (name+proc)
(send this-choice check (eq? name (car name+proc)))))))
(map car (identifier=-choices))
(map cdr (identifier=-choices))))
(void))
(define/public (after-partition-items)
(void))
(define/public (add-separator) (define/public (add-separator)
(new separator-menu-item% (parent the-context-menu))) (new separator-menu-item% (parent the-context-menu)))
;; Initialize menu ;; Initialize menu
(add-edit-items) (add-menu-items)
(after-edit-items) ))
(add-separator)
(add-selection-items)
(after-selection-items)
(add-separator)
(add-partition-items)
(after-partition-items)
(send the-context-menu add-on-demand
(lambda ()
(define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t))))
(send config listen-props-shown?
(lambda (shown?)
(send props-menu set-label
(if shown?
"Hide syntax properties"
"Show syntax properties"))))))

25
collects/macro-debugger/syntax-browser/params.ss
View File

@ -1,25 +0,0 @@
#lang scheme/base
(provide current-syntax-font-size
current-default-columns
current-colors
current-suffix-option)
;; current-syntax-font-size : parameter of number/#f
;; When non-false, overrides the default font size
(define current-syntax-font-size (make-parameter #f))
;; current-default-columns : parameter of number
(define current-default-columns (make-parameter 60))
;; current-suffix-option : parameter of SuffixOption
(define current-suffix-option (make-parameter 'over-limit))
(define current-colors
(make-parameter
(list "black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive")))

36
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -5,13 +5,9 @@
"interfaces.ss" "interfaces.ss"
"../util/notify.ss" "../util/notify.ss"
"../util/misc.ss") "../util/misc.ss")
(provide syntax-prefs% (provide syntax-prefs-base%
syntax-prefs/readonly% syntax-prefs%
syntax-prefs/readonly%)
#;pref:tabify
#;pref:height
#;pref:width
#;pref:props-percentage)
(preferences:set-default 'SyntaxBrowser:Width 700 number?) (preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -22,13 +18,37 @@
(pref:get/set pref:height SyntaxBrowser:Height) (pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-base% (define syntax-prefs-base%
(class object% (class object%
;; columns : number
(field/notify columns (new notify-box% (value 60)))
;; suffix-option : SuffixOption
(field/notify suffix-option (new notify-box% (value 'over-limit)))
;; syntax-font-size : number/#f
;; When non-false, overrides the default font size
(field/notify syntax-font-size (new notify-box% (value #f)))
;; colors : (listof string)
(field/notify colors
(new notify-box%
(value '("black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive"))))
;; width, height : number
(notify-methods width) (notify-methods width)
(notify-methods height) (notify-methods height)
;; props-percentage : ...
(notify-methods props-percentage) (notify-methods props-percentage)
;; props-shown? : boolean
(notify-methods props-shown?) (notify-methods props-shown?)
(super-new))) (super-new)))

11
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
syntax/stx syntax/stx)
"partition.ss")
(provide (all-defined-out)) (provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -27,7 +26,7 @@
;; - 'over-limit -- suffix > limit ;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit ;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption] ;; syntax->datum/tables : stx partition% num SuffixOption
;; -> (values s-expr hashtable hashtable) ;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to ;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true ;; When limit is a number, restarts processing with numbering? set to true
@ -37,10 +36,8 @@
;; - a hashtable mapping S-expressions to syntax objects ;; - a hashtable mapping S-expressions to syntax objects
;; - a hashtable mapping syntax objects to S-expressions ;; - a hashtable mapping syntax objects to S-expressions
;; Syntax objects which are eq? will map to same flat values ;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables (define (syntax->datum/tables stx partition limit suffixopt)
(case-lambda (table stx partition limit suffixopt))
[(stx) (table stx #f #f 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt) (define (table stx partition limit suffixopt)

17
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -7,19 +7,18 @@
scheme/pretty scheme/pretty
scheme/gui scheme/gui
"pretty-helper.ss" "pretty-helper.ss"
"interfaces.ss" "interfaces.ss")
"params.ss"
"prefs.ss")
(provide pretty-print-syntax) (provide pretty-print-syntax)
;; pretty-print-syntax : syntax port partition -> range% ;; pretty-print-syntax :
(define (pretty-print-syntax stx port primary-partition) ;; syntax port partition (listof string) SuffixOption number
;; -> range%
(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
(define range-builder (new range-builder%)) (define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat) (define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition (syntax->datum/tables stx primary-partition
(length (current-colors)) (length colors)
(current-suffix-option))) suffix-option))
(define identifier-list (define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k)))) (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj) (define (flat=>stx obj)
@ -53,7 +52,7 @@
[pretty-print-size-hook pp-size-hook] [pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook] [pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table identifier-list)] [pretty-print-current-style-table (pp-extend-style-table identifier-list)]
[pretty-print-columns (current-default-columns)] [pretty-print-columns columns]
;; Printing parameters (mzscheme manual 7.9.1.4) ;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t] [print-unreadable #t]
[print-graph #f] [print-graph #f]

4
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -60,7 +60,9 @@
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top)) (send text change-style (make-object style-delta% 'change-alignment 'top))
(define display (define display
(print-syntax-to-editor stx text (send host get-controller))) (print-syntax-to-editor stx text
(send host get-controller)
(send host get-config)))
(send text lock #t) (send text lock #t)
(send text end-edit-sequence) (send text end-edit-sequence)
(send text hide-caret #t) (send text hide-caret #t)

60
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -8,7 +8,6 @@
mzlib/kw mzlib/kw
syntax/boundmap syntax/boundmap
"interfaces.ss" "interfaces.ss"
"params.ss"
"controller.ss" "controller.ss"
"display.ss" "display.ss"
"keymap.ss" "keymap.ss"
@ -48,15 +47,10 @@
(send -text set-styles-sticky #f) (send -text set-styles-sticky #f)
(send -text lock #t) (send -text lock #t)
;; syntax-properties-controller<%> methods
(define/public (props-shown?)
(send -props-panel is-shown?))
(define/public (toggle-props)
(show-props (not (send -props-panel is-shown?))))
(define/public (show-props show?) (define/public (show-props show?)
(internal-show-props show?))
(define/private (internal-show-props show?)
(if show? (if show?
(unless (send -props-panel is-shown?) (unless (send -props-panel is-shown?)
(let ([p (send config get-props-percentage)]) (let ([p (send config get-props-percentage)])
@ -67,27 +61,25 @@
(send -split-panel delete-child -props-panel) (send -split-panel delete-child -props-panel)
(send -props-panel show #f)))) (send -props-panel show #f))))
(send config listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(send config listen-props-shown?
(lambda (show?)
(show-props show?)))
(define/private (update-props-percentage p) (define/private (update-props-percentage p)
(send -split-panel set-percentages (send -split-panel set-percentages
(list (- 1 p) p))) (list (- 1 p) p)))
;; (define/private (props-panel-shown?)
(send -props-panel is-shown?))
(define/public (get-controller) controller)
;; ;;
(define/public (get-main-panel) -main-panel) (define/public (get-controller)
controller)
;;
(define/public (get-main-panel)
-main-panel)
(define/public (shutdown) (define/public (shutdown)
(when (props-shown?) (when (props-panel-shown?)
(send config set-props-percentage (send config set-props-percentage
(cadr (send -split-panel get-percentages))))) (cadr (send -split-panel get-percentages)))))
@ -187,23 +179,31 @@
;; internal-add-syntax : syntax -> display ;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx) (define/private (internal-add-syntax stx)
(with-unlock -text (with-unlock -text
(parameterize ((current-default-columns (calculate-columns))) (let ([display (print-syntax-to-editor stx -text controller config)])
(let ([display (print-syntax-to-editor stx -text controller)]) (send* -text
(send* -text (insert "\n")
(insert "\n") ;;(scroll-to-position current-position)
;(scroll-to-position current-position) )
) display)))
display))))
(define/private (calculate-columns) (define/private (calculate-columns)
(define style (code-style -text)) (define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width))))) (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
;; Initialize ;; Initialize
(super-new) (super-new)
(setup-keymap))) (setup-keymap)
(send config listen-props-shown?
(lambda (show?)
(show-props show?)))
(send config listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(internal-show-props (send config get-props-shown?))))
(define clickback-style (define clickback-style
(let ([sd (new style-delta%)]) (let ([sd (new style-delta%)])

69
collects/macro-debugger/tool.ss
View File

@ -99,7 +99,10 @@
get-definitions-text) get-definitions-text)
(define macro-debug-panel (define macro-debug-panel
(new vertical-pane% (parent (get-button-panel)))) (new horizontal-pane%
(parent (get-button-panel))
(stretchable-height #f)
(stretchable-width #f)))
(define macro-debug-button (define macro-debug-button
(new switchable-button% (new switchable-button%
(label "Macro Stepper") (label "Macro Stepper")
@ -198,36 +201,44 @@
(define/private (make-stepper filename) (define/private (make-stepper filename)
(new drscheme-macro-stepper-director% (filename filename))) (new drscheme-macro-stepper-director% (filename filename)))
(define/private (inner-eval original-eval-handler e-expr)
(original-eval-handler e-expr))
(define/private (make-handlers original-eval-handler (define/private (make-handlers original-eval-handler
original-module-name-resolver) original-module-name-resolver)
(let* ([filename (send (send (get-top-level-window) (define filename (send (send (get-top-level-window) get-definitions-text)
get-definitions-text) get-filename/untitled-name))
get-filename/untitled-name)] (define director (make-stepper filename))
[director (make-stepper filename)] (define local-debugging? debugging?)
[debugging? debugging?]) (define (call-without-debugging thunk)
(set! current-stepper-director director) (let ([eo (current-expand-observe)]
(values [saved-debugging? local-debugging?])
(lambda (expr) (dynamic-wind
(if (and debugging? (syntax? expr)) (lambda ()
(let-values ([(e-expr events derivp) (trace* expr expand)]) (set! local-debugging? #f)
(show-deriv director events) (when eo (current-expand-observe void)))
(if (syntax? e-expr) thunk
(parameterize ((current-eval original-eval-handler)) (lambda ()
(original-eval-handler e-expr)) (set! local-debugging? saved-debugging?)
(raise e-expr))) (when eo (current-expand-observe eo))))))
(original-eval-handler expr))) (define (the-eval expr)
(lambda args (if (and local-debugging? (syntax? expr))
(let ([eo (current-expand-observe)] (let-values ([(e-expr events derivp) (trace* expr expand)])
[saved-debugging? debugging?]) (show-deriv director events)
(dynamic-wind (if (syntax? e-expr)
(lambda () (inner-eval e-expr)
(set! debugging? #f) (raise e-expr)))
(when eo (current-expand-observe void))) (original-eval-handler expr)))
(lambda () (define (inner-eval e-expr)
(apply original-module-name-resolver args)) (if #f ;; fixme: turn into parameter/preference???
(lambda () (call-without-debugging (lambda () (original-eval-handler e-expr)))
(set! debugging? saved-debugging?) (original-eval-handler e-expr)))
(when eo (current-expand-observe eo))))))))) (define (the-module-resolver . args)
(call-without-debugging
(lambda () (apply original-module-name-resolver args))))
(set! current-stepper-director director)
(values the-eval
the-module-resolver))
(define/private (show-deriv director events) (define/private (show-deriv director events)
(parameterize ([current-eventspace drscheme-eventspace]) (parameterize ([current-eventspace drscheme-eventspace])

9
collects/macro-debugger/util/notify.ss
View File

@ -151,10 +151,13 @@
(new checkable-menu-item% (new checkable-menu-item%
(label label) (label label)
(parent parent) (parent parent)
(checked (send nb get)) (demand-callback
(lambda (i)
(send i check (send nb get))))
(callback (callback
(lambda _ (send nb set (send menu-item is-checked?)))))) (lambda _
(send nb listen (lambda (value) (send menu-item check value))) #;(send nb set (send menu-item is-checked?))
(send nb set (not (send nb get)))))))
menu-item) menu-item)
(define (check-box/notify-box parent label nb) (define (check-box/notify-box parent label nb)

145
collects/macro-debugger/view/cursor.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base #lang scheme/base
(require scheme/promise) (require scheme/promise)
(provide cursor? (provide cursor?
cursor-position
cursor:new cursor:new
cursor:add-to-end! cursor:add-to-end!
cursor:remove-current! cursor:remove-current!
@ -25,107 +26,109 @@
cursor:prefix->list cursor:prefix->list
cursor:suffix->list) cursor:suffix->list)
(define-syntax stream-cons (define-struct cursor (vector count position)
(syntax-rules () #:mutable)
[(stream-cons x y)
(delay (cons x y))]))
(define (stream-car x) (define (cursor:ensure-capacity c capacity)
(if (promise? x) (define v (cursor-vector c))
(car (force x)) (when (< (vector-length v) capacity)
(car x))) (let* ([new-capacity (ceiling (* capacity 3/2))]
[new-v (make-vector new-capacity)])
(define (stream-cdr x) (vector-copy! new-v 0 v 0)
(if (promise? x) (set-cursor-vector! c new-v))))
(cdr (force x))
(cdr x)))
(define (stream-null? x)
(or (null? x)
(and (promise? x) (null? (force x)))))
(define (stream-append x y)
(if (stream-null? x)
y
(stream-cons (stream-car x)
(stream-append (stream-cdr x) y))))
(define (stream->list s)
(if (stream-null? s)
null
(cons (stream-car s) (stream->list (stream-cdr s)))))
;; Cursors
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
(define-struct cursor (prefix suffixp) #:mutable)
(define (cursor:new items) (define (cursor:new items)
(make-cursor null items)) (define v (list->vector items))
(make-cursor v (vector-length v) 0))
(define (cursor:add-to-end! c items) (define (cursor:add-to-end! c items)
(let ([suffix (cursor-suffixp c)]) (define count0 (cursor-count c))
(set-cursor-suffixp! c (stream-append suffix items)))) (define items-vector (list->vector items))
(cursor:ensure-capacity c (+ (cursor-count c) (length items)))
(vector-copy! (cursor-vector c) count0 items-vector)
(set-cursor-count! c (+ (cursor-count c) (vector-length items-vector))))
(define (cursor:remove-current! c) (define (cursor:remove-current! c)
(when (cursor:has-next? c) (cursor:remove-at! c (cursor-position c)))
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
(define (cursor:remove-at! c p)
(define count (cursor-count c))
(define v (cursor-vector c))
(vector-copy! v p v (add1 p))
(vector-set! v (sub1 count) #f)
(set-cursor-count! c (sub1 count)))
(define (cursor:next c) (define (cursor:next c)
(let ([suffix (cursor-suffixp c)]) (define p (cursor-position c))
(if (stream-null? suffix) (define count (cursor-count c))
#f (and (< p count)
(stream-car suffix)))) (vector-ref (cursor-vector c) p)))
(define (cursor:prev c) (define (cursor:prev c)
(let ([prefix (cursor-prefix c)]) (define p (cursor-position c))
(if (pair? prefix) (define count (cursor-count c))
(car prefix) (and (< 0 p)
#f))) (vector-ref (cursor-vector c) (sub1 p))))
(define (cursor:move-prev c)
(when (pair? (cursor-prefix c))
(let ([old-prefix (cursor-prefix c)])
(set-cursor-prefix! c (cdr old-prefix))
(set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
(define (cursor:move-next c) (define (cursor:move-next c)
(when (cursor:has-next? c) (define p (cursor-position c))
(let* ([old-suffixp (cursor-suffixp c)]) (define count (cursor-count c))
(set-cursor-prefix! c (cons (stream-car old-suffixp) (when (< p count)
(cursor-prefix c))) (set-cursor-position! c (add1 p))))
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
(define (cursor:move-prev c)
(define p (cursor-position c))
(define count (cursor-count c))
(when (< 0 p)
(set-cursor-position! c (sub1 p))))
(define (cursor:at-start? c) (define (cursor:at-start? c)
(null? (cursor-prefix c))) (= (cursor-position c) 0))
(define (cursor:at-end? c) (define (cursor:at-end? c)
(stream-null? (cursor-suffixp c))) (= (cursor-position c) (cursor-count c)))
(define (cursor:has-next? c) (define (cursor:has-next? c)
(not (cursor:at-end? c))) (not (cursor:at-end? c)))
(define (cursor:has-prev? c) (define (cursor:has-prev? c)
(not (cursor:at-start? c))) (not (cursor:at-start? c)))
(define (cursor:move-to-start c) (define (cursor:move-to-start c)
(when (cursor:has-prev? c) (set-cursor-position! c 0))
(cursor:move-prev c)
(cursor:move-to-start c)))
(define (cursor:move-to-end c) (define (cursor:move-to-end c)
(when (cursor:has-next? c) (set-cursor-position! c (cursor-count c)))
(cursor:move-next c)
(cursor:move-to-end c)))
(define (cursor:skip-to c i) (define (cursor:skip-to c i)
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c)) (when (<= 0 i (cursor-count c))
(cursor:move-next c) (set-cursor-position! c i)))
(cursor:skip-to c i)))
(define (cursor->list c) (define (cursor->list c)
(append (cursor:prefix->list c) (define count (cursor-count c))
(cursor:suffix->list c))) (define v (cursor-vector c))
(let loop ([i 0])
(if (< i count)
(cons (vector-ref v i)
(loop (add1 i)))
null)))
(define (cursor:prefix->list c) (define (cursor:prefix->list c)
(reverse (cursor-prefix c))) (define position (cursor-position c))
(define v (cursor-vector c))
(let loop ([i 0])
(if (< i position)
(cons (vector-ref v i)
(loop (add1 i)))
null)))
(define (cursor:suffix->list c) (define (cursor:suffix->list c)
(stream->list (cursor-suffixp c))) (define position (cursor-position c))
(define count (cursor-count c))
(define v (cursor-vector c))
(let loop ([i position])
(if (< i count)
(cons (vector-ref v i)
(loop (add1 i)))
null)))

4
collects/macro-debugger/view/extensions.ss
View File

@ -57,8 +57,8 @@
(inherit add-separator) (inherit add-separator)
(define/override (after-selection-items) (define/override (add-menu-items)
(super after-selection-items) (super add-menu-items)
(add-separator) (add-separator)
(set! show-macro (set! show-macro
(new menu-item% (label "Show selected identifier") (parent the-context-menu) (new menu-item% (label "Show selected identifier") (parent the-context-menu)

13
collects/macro-debugger/view/frame.ss
View File

@ -14,7 +14,6 @@
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss") (prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/trace.ss" "../model/trace.ss"
@ -120,8 +119,8 @@
(callback (lambda _ (send widget show-in-new-frame))))) (callback (lambda _ (send widget show-in-new-frame)))))
(menu-option/notify-box stepper-menu (menu-option/notify-box stepper-menu
"Show syntax properties" "View syntax properties"
(get-field show-syntax-properties? config)) (get-field props-shown? config))
(let ([id-menu (let ([id-menu
(new (get-menu%) (new (get-menu%)
@ -175,10 +174,10 @@
(parent extras-menu) (parent extras-menu)
(callback (callback
(lambda (i e) (lambda (i e)
(sb:current-suffix-option (send config set-suffix-option
(if (send i is-checked?) (if (send i is-checked?)
'always 'always
'over-limit)) 'over-limit))
(send widget update/preserve-view)))) (send widget update/preserve-view))))
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Highlight redex/contractum" "Highlight redex/contractum"

4
collects/macro-debugger/view/interfaces.ss
View File

@ -5,6 +5,7 @@
;; Signatures ;; Signatures
#;
(define-signature view^ (define-signature view^
(macro-stepper-frame% (macro-stepper-frame%
macro-stepper-widget% macro-stepper-widget%
@ -12,12 +13,15 @@
go go
go/deriv)) go/deriv))
#;
(define-signature view-base^ (define-signature view-base^
(base-frame%)) (base-frame%))
#;
(define-signature prefs^ (define-signature prefs^
(pref:width (pref:width
pref:height pref:height
pref:props-shown?
pref:props-percentage pref:props-percentage
pref:macro-hiding-mode pref:macro-hiding-mode
pref:show-syntax-properties? pref:show-syntax-properties?

13
collects/macro-debugger/view/prefs.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
framework/framework framework/framework
"../syntax-browser/prefs.ss"
"../util/notify.ss" "../util/notify.ss"
"../util/misc.ss") "../util/misc.ss")
(provide macro-stepper-config-base% (provide macro-stepper-config-base%
@ -30,7 +31,6 @@
(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?) (pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) (pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
@ -43,13 +43,8 @@
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base% (define macro-stepper-config-base%
(class object% (class syntax-prefs-base%
(notify-methods width)
(notify-methods height)
(notify-methods props-shown?)
(notify-methods props-percentage)
(notify-methods macro-hiding-mode) (notify-methods macro-hiding-mode)
(notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?) (notify-methods show-hiding-panel?)
(notify-methods identifier=?) (notify-methods identifier=?)
(notify-methods highlight-foci?) (notify-methods highlight-foci?)
@ -66,10 +61,9 @@
(class macro-stepper-config-base% (class macro-stepper-config-base%
(connect-to-pref width pref:width) (connect-to-pref width pref:width)
(connect-to-pref height pref:height) (connect-to-pref height pref:height)
(connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref props-percentage pref:props-percentage) (connect-to-pref props-percentage pref:props-percentage)
(connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode) (connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?) (connect-to-pref identifier=? pref:identifier=?)
(connect-to-pref highlight-foci? pref:highlight-foci?) (connect-to-pref highlight-foci? pref:highlight-foci?)
@ -88,7 +82,6 @@
(connect-to-pref/readonly height pref:height) (connect-to-pref/readonly height pref:height)
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode) (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref/readonly props-percentage pref:props-percentage) (connect-to-pref/readonly props-percentage pref:props-percentage)
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref/readonly identifier=? pref:identifier=?) (connect-to-pref/readonly identifier=? pref:identifier=?)
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?) (connect-to-pref/readonly highlight-foci? pref:highlight-foci?)

49
collects/macro-debugger/view/stepper.ss
View File

@ -13,8 +13,6 @@
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
"term-record.ss" "term-record.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/deriv-find.ss" "../model/deriv-find.ss"
@ -49,6 +47,9 @@
(define (focused-term) (define (focused-term)
(cursor:next terms)) (cursor:next terms))
;; current-step-index : notify of number/#f
(field/notify current-step-index (new notify-box% (value #f)))
;; add-deriv : Deriv -> void ;; add-deriv : Deriv -> void
(define/public (add-deriv d) (define/public (add-deriv d)
(let ([trec (new term-record% (stepper this) (raw-deriv d))]) (let ([trec (new term-record% (stepper this) (raw-deriv d))])
@ -135,10 +136,8 @@
(stepper this) (stepper this)
(config config))) (config config)))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel? (send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-prefs show?))) (lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax (send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx))) (lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci? (send config listen-highlight-foci?
@ -173,6 +172,28 @@
(new button% (label "Next term") (parent navigator) (new button% (label "Next term") (parent navigator)
(callback (lambda (b e) (navigate-down))))) (callback (lambda (b e) (navigate-down)))))
(define nav:text
(new text-field%
(label "Step#")
(init-value "00000")
(parent extra-navigator)
(stretchable-width #f)
(stretchable-height #f)
(callback
(lambda (b e)
(when (eq? (send e get-event-type) 'text-field-enter)
(let* ([value (send b get-value)]
[step (string->number value)])
(cond [(exact-positive-integer? step)
(navigate-to (sub1 step))]
[(equal? value "end")
(navigate-to-end)])))))))
(send nav:text set-value "")
(listen-current-step-index
(lambda (n)
(send nav:text set-value
(if (number? n) (number->string (add1 n)) ""))))
(define/private (trim-navigator) (define/private (trim-navigator)
(if (> (length (cursor->list terms)) 1) (if (> (length (cursor->list terms)) 1)
(send navigator change-children (send navigator change-children
@ -190,7 +211,7 @@
nav:next nav:next
nav:end))))) nav:end)))))
(define/public (show-macro-hiding-prefs show?) (define/public (show-macro-hiding-panel show?)
(send area change-children (send area change-children
(lambda (children) (lambda (children)
(if show? (if show?
@ -223,6 +244,9 @@
(define/public-final (navigate-next) (define/public-final (navigate-next)
(send (focused-term) navigate-next) (send (focused-term) navigate-next)
(update/save-position)) (update/save-position))
(define/public-final (navigate-to n)
(send (focused-term) navigate-to n)
(update/save-position))
(define/public-final (navigate-up) (define/public-final (navigate-up)
(when (focused-term) (when (focused-term)
@ -284,6 +308,7 @@
#f #f
(send text last-position) (send text last-position)
'start) 'start)
(update-nav-index)
(enable/disable-buttons)) (enable/disable-buttons))
;; update:show-prefix : -> void ;; update:show-prefix : -> void
@ -305,6 +330,12 @@
(send trec display-initial-term)) (send trec display-initial-term))
(cdr suffix0))))) (cdr suffix0)))))
;; update-nav-index : -> void
(define/private (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send term get-step-index))))
;; enable/disable-buttons : -> void ;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons) (define/private (enable/disable-buttons)
(define term (focused-term)) (define term (focused-term))
@ -312,6 +343,7 @@
(send nav:previous enable (and term (send term has-prev?))) (send nav:previous enable (and term (send term has-prev?)))
(send nav:next enable (and term (send term has-next?))) (send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?))) (send nav:end enable (and term (send term has-next?)))
(send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms)) (send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms))) (send nav:down enable (cursor:has-next? terms)))
@ -343,6 +375,7 @@
(send (focused-term) on-get-focus)) (send (focused-term) on-get-focus))
(update)) (update))
#|
;; delayed-recache-errors : (list-of (cons exn string)) ;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null) (define delayed-recache-errors null)
@ -372,6 +405,7 @@
""))) "")))
(set! delayed-recache-errors null))))) (set! delayed-recache-errors null)))))
(raise exn))) (raise exn)))
|#
(define/private (foci x) (if (list? x) x (list x))) (define/private (foci x) (if (list? x) x (list x)))
@ -387,8 +421,7 @@
;; Initialization ;; Initialization
(super-new) (super-new)
(send sbview show-props (send config get-show-syntax-properties?)) (show-macro-hiding-panel (send config get-show-hiding-panel?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?)) (show-extra-navigation (send config get-extra-navigation?))
(refresh/move) (refresh/move)
)) ))

15
collects/macro-debugger/view/term-record.ss
View File

@ -12,8 +12,6 @@
"extensions.ss" "extensions.ss"
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/deriv-find.ss" "../model/deriv-find.ss"
@ -204,6 +202,9 @@
(define/public-final (has-next?) (define/public-final (has-next?)
(and (get-steps) (not (cursor:at-end? (get-steps))))) (and (get-steps) (not (cursor:at-end? (get-steps)))))
(define/public-final (get-step-index)
(and (get-steps) (cursor-position (get-steps))))
(define/public-final (navigate-to-start) (define/public-final (navigate-to-start)
(cursor:move-to-start (get-steps)) (cursor:move-to-start (get-steps))
(save-position)) (save-position))
@ -216,6 +217,9 @@
(define/public-final (navigate-next) (define/public-final (navigate-next)
(cursor:move-next (get-steps)) (cursor:move-next (get-steps))
(save-position)) (save-position))
(define/public-final (navigate-to n)
(cursor:skip-to (get-steps) n)
(save-position))
;; save-position : -> void ;; save-position : -> void
(define/private (save-position) (define/private (save-position)
@ -271,13 +275,16 @@
;; display-final-term : -> void ;; display-final-term : -> void
(define/public (display-final-term) (define/public (display-final-term)
(recache-synth!) (recache-steps!)
(cond [(syntax? raw-steps-estx) (cond [(syntax? raw-steps-estx)
(add-syntax raw-steps-estx binders definites)] (add-syntax raw-steps-estx binders definites)]
[(exn? error) [(exn? error)
(add-error error)] (add-error error)]
[raw-steps-oops [raw-steps-oops
(add-internal-error "steps" raw-steps-oops #f)])) (add-internal-error "steps" raw-steps-oops #f)]
[else
(error 'term-record::display-final-term
"internal error")]))
;; display-step : -> void ;; display-step : -> void
(define/public (display-step) (define/public (display-step)

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)

49
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?)
(as-exit (unless skip-sub-events?
(lambda () (as-exit
(send (wx->proxy this) on-superwindow-show vis?))))))] (lambda ()
(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?)
(as-exit (unless skip-sub-events?
(lambda () (as-exit
(send (wx->proxy this) on-superwindow-enable act?))))))] (lambda ()
(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)
(as-entry (if (skip-subwindow-events?)
(lambda () #f
(pre-wx->proxy w e (as-entry
(lambda (m e) (lambda ()
(as-exit (lambda () (pre-wx->proxy w e
(send (get-proxy) on-subwindow-char m e)))))))))] (lambda (m e)
(as-exit (lambda ()
(send (get-proxy) on-subwindow-char m e))))))))))]
[pre-on-event (entry-point [pre-on-event (entry-point
(lambda (w e) (lambda (w e)
(pre-wx->proxy w e (if (skip-subwindow-events?)
(lambda (m e) #f
(as-exit (lambda () (pre-wx->proxy w e
(send (get-proxy) on-subwindow-event m e)))))))]) (lambda (m e)
(as-exit (lambda ()
(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" "⊒")

1
collects/mzlib/etc.ss
View File

@ -386,6 +386,7 @@
[else [else
(list expr)]))) (list expr)])))
exprs)))]) exprs)))])
(internal-definition-context-seal def-ctx)
(let loop ([exprs exprs] (let loop ([exprs exprs]
[prev-stx-defns null] [prev-stx-defns null]
[prev-defns null] [prev-defns null]

1
collects/mzlib/private/sigutil.ss
View File

@ -667,6 +667,7 @@
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null]) (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
(cond (cond
[(and (null? pre-lines) (not port) (null? lines)) [(and (null? pre-lines) (not port) (null? lines))
(internal-definition-context-seal def-ctx)
(make-parsed-unit imports (make-parsed-unit imports
renames renames
vars vars

65
collects/mzlib/private/unit-compiletime.ss
View File

@ -18,7 +18,7 @@
(provide (rename build-siginfo make-siginfo) (provide (rename build-siginfo make-siginfo)
siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype
unprocess-link-record-bind unprocess-link-record-use unprocess-link-record-bind unprocess-link-record-use
set!-trans-extract do-identifier set!-trans-extract
process-tagged-import process-tagged-export process-tagged-import process-tagged-export
lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names
map-sig split-requires apply-mac complete-exports complete-imports check-duplicate-subs map-sig split-requires apply-mac complete-exports complete-imports check-duplicate-subs
@ -186,20 +186,17 @@
(lambda (x) x) (lambda (x) x)
sig))) sig)))
;; do-prefix : sig syntax-object -> sig ;; do-prefix : id id -> id
;; ensures that pid is an identifier ;; ensures that pid is an identifier
(define (do-prefix sig pid) (define (do-prefix stx pid)
(check-id pid) (if (identifier? stx)
(let ((p (syntax-e pid))) (datum->syntax-object
(map-sig stx
(lambda (id) (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx)))
(datum->syntax-object stx)
id stx))
(string->symbol (format "~a~a" p (syntax-e id)))))
(lambda (x) x)
sig)))
;; do-only : sig (listof identifier) -> sig ;; do-only/except : sig (listof identifier) -> sig
;; ensures that only-ids are identifiers and are mentioned in the signature ;; ensures that only-ids are identifiers and are mentioned in the signature
(define (do-only/except sig only/except-ids put get) (define (do-only/except sig only/except-ids put get)
(check-module-id-subset only/except-ids (check-module-id-subset only/except-ids
@ -217,22 +214,22 @@
sig))) sig)))
;; do-identifier : identifier (box (cons identifier siginfo)) -> sig ;; do-identifier : identifier (box (cons identifier siginfo)) -> sig
(define (do-identifier spec res bind?) (define (do-identifier spec res bind? add-prefix)
(let* ((sig (lookup-signature spec)) (let* ((sig (lookup-signature spec))
(vars (signature-vars sig)) (vars (signature-vars sig))
(vals (signature-val-defs sig)) (vals (signature-val-defs sig))
(stxs (signature-stx-defs sig)) (stxs (signature-stx-defs sig))
(delta-introduce (if bind? (delta-introduce (if bind?
(let ([f (make-syntax-delta-introducer (let ([f (syntax-local-make-delta-introducer
spec spec)])
(signature-orig-binder sig))])
(lambda (id) (syntax-local-introduce (f id)))) (lambda (id) (syntax-local-introduce (f id))))
values))) values)))
(set-box! res (cons spec (signature-siginfo sig))) (set-box! res (cons spec (signature-siginfo sig)))
(map-sig (lambda (id) (map-sig (lambda (id)
(syntax-local-introduce (syntax-local-introduce
(syntax-local-get-shadower (syntax-local-get-shadower
(delta-introduce id)))) (add-prefix
(delta-introduce id)))))
syntax-local-introduce syntax-local-introduce
(list (map cons vars vars) (list (map cons vars vars)
(map (map
@ -301,43 +298,47 @@
(check-tagged-spec-syntax spec import? identifier?) (check-tagged-spec-syntax spec import? identifier?)
(syntax-case spec (tag) (syntax-case spec (tag)
((tag sym spec) ((tag sym spec)
(let ([s (process-import/export #'spec res bind?)]) (let ([s (process-import/export #'spec res bind? values)])
(list (cons (syntax-e #'sym) (cdr (unbox res))) (list (cons (syntax-e #'sym) (cdr (unbox res)))
(cons (syntax-e #'sym) (car (unbox res))) (cons (syntax-e #'sym) (car (unbox res)))
s))) s)))
((tag . _) ((tag . _)
(raise-stx-err "expected (tag symbol <import/export-spec>)" spec)) (raise-stx-err "expected (tag symbol <import/export-spec>)" spec))
(_ (let ([s (process-import/export spec res bind?)]) (_ (let ([s (process-import/export spec res bind? values)])
(list (cons #f (cdr (unbox res))) (list (cons #f (cdr (unbox res)))
(cons #f (car (unbox res))) (cons #f (car (unbox res)))
s))))) s)))))
(define (add-prefixes add-prefix l)
(map add-prefix (syntax->list l)))
;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig ;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig
(define (process-import/export spec res bind?) (define (process-import/export spec res bind? add-prefix)
(syntax-case spec (only except prefix rename) (syntax-case spec (only except prefix rename)
(_ (_
(identifier? spec) (identifier? spec)
(do-identifier spec res bind?)) (do-identifier spec res bind? add-prefix))
((only sub-spec id ...) ((only sub-spec id ...)
(do-only/except (process-import/export #'sub-spec res bind?) (do-only/except (process-import/export #'sub-spec res bind? add-prefix)
(syntax->list #'(id ...)) (add-prefixes add-prefix #'(id ...))
(lambda (x) x) (lambda (id) id)
(lambda (id) (lambda (id)
(car (generate-temporaries #`(#,id)))))) (car (generate-temporaries #`(#,id))))))
((except sub-spec id ...) ((except sub-spec id ...)
(do-only/except (process-import/export #'sub-spec res bind?) (do-only/except (process-import/export #'sub-spec res bind? add-prefix)
(syntax->list #'(id ...)) (add-prefixes add-prefix #'(id ...))
(lambda (id) (lambda (id)
(car (generate-temporaries #`(#,id)))) (car (generate-temporaries #`(#,id))))
(lambda (x) x))) (lambda (id) id)))
((prefix pid sub-spec) ((prefix pid sub-spec)
(do-prefix (process-import/export #'sub-spec res bind?) #'pid)) (process-import/export #'sub-spec res bind?
(lambda (id)
(do-prefix (add-prefix id) #'pid))))
((rename sub-spec (internal external) ...) ((rename sub-spec (internal external) ...)
(let* ((sig-res (let* ((sig-res
(do-rename (process-import/export #'sub-spec res bind?) (do-rename (process-import/export #'sub-spec res bind? add-prefix)
#'(internal ...) #'(internal ...)
#'(external ...))) (datum->syntax-object #f (add-prefixes add-prefix #'(external ...)))))
(dup (check-duplicate-identifier (sig-int-names sig-res)))) (dup (check-duplicate-identifier (sig-int-names sig-res))))
(when dup (when dup
(raise-stx-err (raise-stx-err
@ -353,7 +354,7 @@
;; process-spec : syntax-object -> sig ;; process-spec : syntax-object -> sig
(define (process-spec spec) (define (process-spec spec)
(check-tagged-spec-syntax spec #f identifier?) (check-tagged-spec-syntax spec #f identifier?)
(process-import/export spec (box #f) #t)) (process-import/export spec (box #f) #t values))
; ;; extract-siginfo : (union import-spec export-spec) -> ??? ; ;; extract-siginfo : (union import-spec export-spec) -> ???

230
collects/mzlib/sandbox.ss
View File

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

11
collects/mzlib/unit.ss
View File

@ -126,8 +126,7 @@
((((int-sid . ext-sid) ...) . sbody) ...)) ((((int-sid . ext-sid) ...) . sbody) ...))
(map-sig (lambda (x) x) (map-sig (lambda (x) x)
(make-syntax-introducer) (make-syntax-introducer)
sig) sig)])
#;(add-context-to-sig sig)])
(list (list
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...) #'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(values (values
@ -330,13 +329,6 @@
(list #'stop) (list #'stop)
def-ctx)))) def-ctx))))
(define-for-syntax (add-context-to-sig sig)
(let ((def-ctx (syntax-local-make-definition-context)))
(syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx)
(map-sig (lambda (x) x)
(lambda (x) (localify x def-ctx))
sig)))
(define-for-syntax (iota n) (define-for-syntax (iota n)
(let loop ((n n) (let loop ((n n)
(acc null)) (acc null))
@ -619,6 +611,7 @@
[_ (void)])) [_ (void)]))
expanded-body) expanded-body)
table)]) table)])
(internal-definition-context-seal def-ctx)
;; Mark exported names and ;; Mark exported names and
;; check that all exported names are defined (as var): ;; check that all exported names are defined (as var):

3
collects/mzlib/unit200.ss
View File

@ -158,7 +158,10 @@
[else (list defn-or-expr)]))) [else (list defn-or-expr)])))
defns&exprs))) defns&exprs)))
values)]) values)])
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
(when def-ctx
(internal-definition-context-seal def-ctx))
;; Get all the defined names, sorting out variable definitions ;; Get all the defined names, sorting out variable definitions
;; from syntax definitions. ;; from syntax definitions.
(let* ([definition? (let* ([definition?

2
collects/net/scribblings/url.scrbl
View File

@ -44,7 +44,7 @@ re-exported by @schememodname[net/url].}
[query (listof (cons/c symbol? (or/c false/c string?)))] [query (listof (cons/c symbol? (or/c false/c string?)))]
[fragment (or/c false/c string?)])]{ [fragment (or/c false/c string?)])]{
The basic structure for all URLs, hich is explained in RFC 3986 The basic structure for all URLs, which is explained in RFC 3986
@cite["RFC3986"]. The following diagram illustrates the parts: @cite["RFC3986"]. The following diagram illustrates the parts:
@verbatim[#:indent 2]|{ @verbatim[#:indent 2]|{

19
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))
@ -506,7 +513,7 @@
;default-settings: -> profj-settings ;default-settings: -> profj-settings
(define/public (default-settings) (define/public (default-settings)
(if (memq level `(beginner intermediate intermediate+access advanced)) (if (memq level `(beginner intermediate intermediate+access advanced))
(make-profj-settings 'field #f #t #f #t #t null) (make-profj-settings 'field #f #t #f #t #f null)
(make-profj-settings 'type #f #t #t #f #f null))) (make-profj-settings 'type #f #t #t #f #f null)))
;default-settings? any -> bool ;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings))) (define/public (default-settings? s) (equal? s (default-settings)))
@ -763,11 +770,12 @@
(send collect-coverage enable #f)) (send collect-coverage enable #f))
(install-classpath (profj-settings-classpath settings))]))) (install-classpath (profj-settings-classpath settings))])))
(define eventspace (current-eventspace))
(define/public (front-end/complete-program port settings) (define/public (front-end/complete-program port settings)
(mred? #t) (mred? #t)
(let ([name (object-name port)] (let ([name (object-name port)]
[rep (drscheme:rep:current-rep)] [rep (drscheme:rep:current-rep)]
[eventspace (current-eventspace)] #;[eventspace (current-eventspace)]
[execute-types (create-type-record)]) [execute-types (create-type-record)])
(let ([name-to-require #f] (let ([name-to-require #f]
[require? #f] [require? #f]
@ -793,6 +801,8 @@
(list (send execute-types get-test-classes) null) (list (send execute-types get-test-classes) null)
(find-examples compilation-units))]) (find-examples compilation-units))])
#;(printf "ProfJ compilation complete~n") #;(printf "ProfJ compilation complete~n")
#;(printf "compilation units- ~a~n" (map syntax->datum
(apply append (map compilation-unit-code compilation-units))))
(set! compiled? #t) (set! compiled? #t)
(set! modules (order compilation-units)) (set! modules (order compilation-units))
(when rep (send rep set-user-types execute-types)) (when rep (send rep set-user-types execute-types))
@ -829,7 +839,6 @@
(send ,test-engine-obj run) (send ,test-engine-obj run)
#;(printf "Test methods run~n") #;(printf "Test methods run~n")
(send ,test-engine-obj setup-display ,rep ,eventspace) (send ,test-engine-obj setup-display ,rep ,eventspace)
(send ,test-engine-obj summarize-results (current-output-port))
(let ([test-objs (send ,test-engine-obj test-objects)]) (let ([test-objs (send ,test-engine-obj test-objects)])
(let inner-loop ((os test-objs)) (let inner-loop ((os test-objs))
(unless (null? os) (unless (null? os)
@ -841,7 +850,9 @@
(write-special (car out)) (write-special (car out))
(loop (cdr out)))) (loop (cdr out))))
(newline)) (newline))
(inner-loop (cdr os))))))) (inner-loop (cdr os)))))
(send ,test-engine-obj summarize-results (current-output-port))
))
#f))] #f))]
[(and (not require?) (null? modules) tests-run?) [(and (not require?) (null? modules) tests-run?)
(begin0 (begin0

1
collects/r5rs/main.ss
View File

@ -410,6 +410,7 @@
(cdr exprs))) (cdr exprs)))
(reverse idss) (reverse rhss) (reverse idss) (reverse rhss)
(reverse stx-idss) (reverse stx-rhss))]))))]) (reverse stx-idss) (reverse stx-rhss))]))))])
(internal-definition-context-seal def-ctx)
(if (and (null? (syntax-e #'(stx-rhs ...))) (if (and (null? (syntax-e #'(stx-rhs ...)))
(andmap (lambda (ids) (andmap (lambda (ids)
(= 1 (length (syntax->list ids)))) (= 1 (length (syntax->list ids))))

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)

77
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))]))
(unit (import) (export decisions^) (λ (lang)
(define next-variable-decision (decision var)) (unit (import) (export decisions^)
(define next-non-terminal-decision (decision nt)) (define next-variable-decision (decision var))
(define next-number-decision (decision num)) (define next-non-terminal-decision
(define next-string-decision (decision str)) (if (procedure? nt)
(define next-any-decision (decision any)) (let ([next (nt lang)])
(define next-sequence-decision (decision seq)))) (λ () next))
(iterator 'nt nt)))
(define next-number-decision (decision num))
(define next-string-decision (decision str))
(define next-any-decision (decision any))
(define next-sequence-decision (decision seq)))))
(let () (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 1 0
lc e 0 0 (decisions #:nt (patterns first)
(decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods))))))) #:var (list (λ _ 'x) (λ _ 'y))))
'(x)) '(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
#:seq (list (λ _ 2)))))) (λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1))
#: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)])])

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

@ -25,10 +25,12 @@ To do a better job of not generating programs with free variables,
(for-syntax "reduction-semantics.ss") (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
(generate* (let ([lang (parse-language lang)])
(parse-language lang) (generate*
(reassign-classes (parse-pattern `pattern lang 'top-level)) lang
decisions@)))])) (reassign-classes (parse-pattern `pattern lang 'top-level))
(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 "14nov2008") #lang scheme/base (provide stamp) (define stamp "3dec2008")

20
collects/rnrs/base-6.ss
View File

@ -76,7 +76,7 @@
[r6rs:string->number string->number]) [r6rs:string->number string->number])
;; 11.8 ;; 11.8
not boolean? boolean=? not boolean? (rename-out [r6rs:boolean=? boolean=?])
;; 11.9 ;; 11.9
(rename-out [r5rs:pair? pair?] (rename-out [r5rs:pair? pair?]
@ -123,7 +123,7 @@
[r5rs:for-each for-each]) [r5rs:for-each for-each])
;; 11.10 ;; 11.10
symbol? symbol=? symbol? (rename-out [r6rs:symbol=? symbol=?])
string->symbol symbol->string string->symbol symbol->string
;; 11.11 ;; 11.11
@ -349,6 +349,22 @@
(and (regexp-match? rx:number s) (and (regexp-match? rx:number s)
(string->number (regexp-replace* #rx"[|][0-9]+" s ""))))) (string->number (regexp-replace* #rx"[|][0-9]+" s "")))))
(define r6rs:symbol=?
(case-lambda
[(a b) (symbol=? a b)]
[(a b . rest) (and (symbol=? a b)
(andmap (lambda (s)
(symbol=? a s))
rest))]))
(define r6rs:boolean=?
(case-lambda
[(a b) (boolean=? a b)]
[(a b . rest) (and (boolean=? a b)
(andmap (lambda (s)
(boolean=? a s))
rest))]))
(define-syntax-rule (make-mapper what for for-each in-val val-length val->list list->result) (define-syntax-rule (make-mapper what for for-each in-val val-length val->list list->result)
(case-lambda (case-lambda
[(proc val) (list->result [(proc val) (list->result

7
collects/rnrs/bytevectors-6.ss
View File

@ -311,16 +311,17 @@
(bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size)) (bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size))
(define (int-list->bytevector who signed? set l endianness size) (define (int-list->bytevector who signed? set l endianness size)
(unless (list? l) (unless (mlist? l)
(raise-type-error who "list" l)) (raise-type-error who "list" l))
(check-endian endianness) (check-endian endianness)
(unless (exact-positive-integer? size) (unless (exact-positive-integer? size)
(raise-type-error who "exact positive integer" size)) (raise-type-error who "exact positive integer" size))
(let* ([len (length l)] (let* ([l (mlist->list l)]
[len (length l)]
[bv (make-bytes (* size len))]) [bv (make-bytes (* size len))])
(for ([v (in-list l)] (for ([v (in-list l)]
[k (in-naturals)]) [k (in-naturals)])
(set l k v endianness size)) (set bv (* k size) v endianness size))
bv)) bv))
(define (uint-list->bytevector l endianness size) (define (uint-list->bytevector l endianness size)

10
collects/scheme/match/compiler.ss
View File

@ -429,10 +429,12 @@
(quote-syntax #,esc))]) (quote-syntax #,esc))])
#,(Row-rhs (car blocks)))]) #,(Row-rhs (car blocks)))])
(if (Row-unmatch (car blocks)) (if (Row-unmatch (car blocks))
#`(let/ec k #`(call-with-continuation-prompt
(let ([#,(Row-unmatch (car blocks)) (lambda () (let ([#,(Row-unmatch (car blocks))
(lambda () (k (#,esc)))]) (lambda () (abort-current-continuation match-prompt-tag))])
rhs)) rhs))
match-prompt-tag
(lambda () (#,esc)))
#'rhs))]) #'rhs))])
;; then compile the rest, with our name as the esc ;; then compile the rest, with our name as the esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))]) (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])

5
collects/scheme/match/runtime.ss
View File

@ -7,7 +7,10 @@
exn:misc:match? exn:misc:match?
match:error match:error
fail fail
matchable?) matchable?
match-prompt-tag)
(define match-prompt-tag (make-continuation-prompt-tag 'match))
(define match-equality-test (make-parameter equal?)) (define match-equality-test (make-parameter equal?))

394
collects/scheme/package.ss Normal file
View File

@ -0,0 +1,394 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/kerncase
syntax/boundmap
syntax/define))
(provide define-package
package-begin
open-package
open*-package
define*
define*-values
define*-syntax
define*-syntaxes)
(define-for-syntax (do-define-* stx define-values-id)
(syntax-case stx ()
[(_ (id ...) rhs)
(let ([ids (syntax->list #'(id ...))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier for definition"
stx
id)))
ids)
(with-syntax ([define-values define-values-id])
(syntax/loc stx
(define-values (id ...) rhs))))]))
(define-syntax (define*-values stx)
(do-define-* stx #'define-values))
(define-syntax (define*-syntaxes stx)
(do-define-* stx #'define-syntaxes))
(define-syntax (define* stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
(quasisyntax/loc stx
(define*-values (#,id) #,rhs))))
(define-syntax (define*-syntax stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
(quasisyntax/loc stx
(define*-syntaxes (#,id) #,rhs))))
(begin-for-syntax
(define-struct package (exports hidden)
#:omit-define-syntaxes
#:property prop:procedure (lambda (r stx)
(raise-syntax-error
#f
"misuse of a package name"
stx)))
(define (reverse-mapping who id exports hidden)
(or (ormap (lambda (m)
(and (free-identifier=? id (cdr m))
(car m)))
exports)
(ormap (lambda (h)
(and (free-identifier=? id h)
;; Not at top level, where free-id=? is unreliable,
;; and re-definition is ok:
(identifier-binding id)
;; Name is inaccessible. Generate a temporary to
;; avoid potential duplicate-definition errors
;; when the name is bound in the same context as
;; the package.
(car (generate-temporaries (list id)))))
hidden)
id)))
(define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx ()
[(_ pack-id mode exports form ...)
(let ([id #'pack-id]
[exports #'exports]
[mode (syntax-e #'mode)])
(unless (eq? mode '#:begin)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier"
stx
id)))
(let ([exports
(cond
[(syntax->list exports)
=> (lambda (l)
(for-each (lambda (i)
(unless (identifier? i)
(raise-syntax-error #f
"expected identifier to export"
stx
i)))
l)
(let ([dup-id (check-duplicate-identifier l)])
(when dup-id
(raise-syntax-error
#f
"duplicate export"
stx
dup-id)))
l)]
[else (raise-syntax-error #f
(format "expected a parenthesized sequence of identifiers ~a"
(case mode
[(#:only) "to export"]
[(#:all-defined-except) "to exclude from export"]
[else (format "for ~a" mode)]))
stx
exports)])])
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (cons (gensym 'intdef)
(let ([orig-ctx (syntax-local-context)])
(if (pair? orig-ctx)
orig-ctx
null)))]
[pre-package-id (lambda (id def-ctxes)
(for/fold ([id id])
([def-ctx (in-list def-ctxes)])
(identifier-remove-from-definition-context
id
def-ctx)))]
[kernel-forms (list*
#'define*-values
#'define*-syntaxes
(kernel-form-identifier-list))]
[init-exprs (syntax->list #'(form ...))]
[new-bindings (make-bound-identifier-mapping)]
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
(lambda (stx)
(syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax
list cons #%plain-lambda)
free-transformer-identifier=?
[(define-syntaxes (pack-id)
(#%plain-app
make-package
(#%plain-lambda ()
(#%plain-app list
(#%plain-app cons
(quote-syntax export)
(quote-syntax renamed))
...))
hidden))
(with-syntax ([(export ...)
(map (lambda (id)
(if (or (ormap (lambda (e-id)
(bound-identifier=? id e-id))
renamed-exports)
(not (ormap (lambda (e-id)
(bound-identifier=? id e-id))
renamed-defines)))
;; Need to preserve the original
(pre-package-id id def-ctxes)
;; It's not accessible, so just hide the name
;; to avoid re-binding errors.
(car (generate-temporaries (list id)))))
(syntax->list #'(export ...)))])
(syntax/loc stx
(define-syntaxes (pack-id)
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
hidden))))]
[_ stx])))]
[complement (lambda (bindings ids)
(let ([tmp (make-bound-identifier-mapping)])
(bound-identifier-mapping-for-each bindings
(lambda (k v)
(bound-identifier-mapping-put! tmp k #t)))
(for-each (lambda (id)
(bound-identifier-mapping-put! tmp id #f))
ids)
(filter
values
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
(let ([register-bindings!
(lambda (ids)
(for-each (lambda (id)
(when (bound-identifier-mapping-get new-bindings id (lambda () #f))
(raise-syntax-error #f
"duplicate binding"
stx
id))
(bound-identifier-mapping-put! new-bindings
id
#t))
ids))]
[add-package-context (lambda (def-ctxes)
(lambda (stx)
(for/fold ([stx stx])
([def-ctx (in-list (reverse def-ctxes))])
(let ([q (local-expand #`(quote #,stx)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ stx) #'stx])))))])
(let loop ([exprs init-exprs]
[rev-forms null]
[defined null]
[def-ctxes (list def-ctx)])
(cond
[(null? exprs)
(for-each (lambda (def-ctx)
(internal-definition-context-seal def-ctx))
def-ctxes)
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
[defined-renamed (bound-identifier-mapping-map new-bindings
(lambda (k v) k))])
(for-each (lambda (ex renamed)
(unless (bound-identifier-mapping-get new-bindings
renamed
(lambda () #f))
(raise-syntax-error #f
(format "no definition for ~a identifier"
(case mode
[(#:only) "exported"]
[(#:all-defined-except) "excluded"]))
stx
ex)))
exports
exports-renamed)
(let-values ([(exports exports-renamed)
(if (memq mode '(#:only #:begin))
(values exports exports-renamed)
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
;; In case of define*, get only the last definition:
(let ([tmp (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put!
tmp
((add-package-context def-ctxes)
(pre-package-id id def-ctxes))
#t))
all-exports-renamed)
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
[exports (map (lambda (id) (pre-package-id id def-ctxes))
exports-renamed)])
(values exports exports-renamed)))))])
(with-syntax ([(export ...) exports]
[(renamed ...) exports-renamed]
[(hidden ...) (complement new-bindings exports-renamed)])
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
(reverse rev-forms))])
(if (eq? mode '#:begin)
(if (eq? 'expression (syntax-local-context))
(quasisyntax/loc stx (let () #,@body))
(quasisyntax/loc stx (begin #,@body)))
(quasisyntax/loc stx
(begin
#,@(if (eq? 'top-level (syntax-local-context))
;; delcare all bindings before they are used:
#`((define-syntaxes #,defined-renamed (values)))
null)
#,@body
(define-syntax pack-id
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
(lambda ()
(list (quote-syntax hidden) ...)))))))))))]
[else
(let ([expr ((add-package-context (cdr def-ctxes))
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
ctx
kernel-forms
(car def-ctxes)))])
(syntax-case expr (begin)
[(begin . rest)
(loop (append (syntax->list #'rest) (cdr exprs))
rev-forms
defined
def-ctxes)]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-syntaxes)
(free-identifier=? #'def #'define*-syntaxes))
(andmap identifier? (syntax->list #'(id ...))))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(let ([star? (free-identifier=? #'def #'define*-syntaxes)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context)
(car def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons #`(define-syntaxes #,ids rhs)
rev-forms)
(cons ids defined)
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-values)
(free-identifier=? #'def #'define*-values))
(andmap identifier? (syntax->list #'(id ...))))
(let ([star? (free-identifier=? #'def #'define*-values)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context)
(car def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])
(syntax-local-bind-syntaxes ids #f def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons #`(define-values #,ids rhs) rev-forms)
(cons ids defined)
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
[else
(loop (cdr exprs)
(cons (if (and (eq? mode '#:begin)
(null? (cdr exprs)))
expr
#`(define-values () (begin #,expr (values))))
rev-forms)
defined
def-ctxes)]))]))))))]))
(define-syntax (define-package stx)
(syntax-case stx ()
[(_ id #:all-defined form ...)
(do-define-package stx #'(define-package id #:all-defined () form ...))]
[(_ id #:all-defined-except ids form ...)
(do-define-package stx stx)]
[(_ id #:only ids form ...)
(do-define-package stx stx)]
[(_ id ids form ...)
(do-define-package stx #'(define-package id #:only ids form ...))]))
(define-syntax (package-begin stx)
(syntax-case stx ()
[(_ form ...)
(do-define-package stx #'(define-package #f #:begin () form ...))]))
(define-for-syntax (do-open stx define-syntaxes-id)
(syntax-case stx ()
[(_ pack-id)
(let ([id #'pack-id])
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for a package"
stx
id))
(let ([v (syntax-local-value id (lambda () #f))])
(unless (package? v)
(raise-syntax-error #f
"identifier is not bound to a package"
stx
id))
(let ([introduce (syntax-local-make-delta-introducer
(syntax-local-introduce id))])
(with-syntax ([(intro ...)
(map (lambda (i)
(syntax-local-introduce
(syntax-local-get-shadower
(introduce i))))
(map car ((package-exports v))))]
[(defined ...)
(map (lambda (v) (syntax-local-introduce (cdr v)))
((package-exports v)))]
[((a . b) ...) (map (lambda (p)
(cons (syntax-local-introduce (car p))
(syntax-local-introduce (cdr p))))
((package-exports v)))]
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
#`(begin
(#,define-syntaxes-id (intro ...)
(let ([rev-map (lambda (x)
(reverse-mapping
'pack-id
x
(list (cons (quote-syntax a)
(quote-syntax b))
...)
(list (quote-syntax h) ...)))])
(values (make-rename-transformer #'defined rev-map)
...))))))))]))
(define-syntax (open-package stx)
(do-open stx #'define-syntaxes))
(define-syntax (open*-package stx)
(do-open stx #'define*-syntaxes))

16
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
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -1215,6 +1229,8 @@
methods)))] methods)))]
[lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))])
(internal-definition-context-seal def-ctx)
;; ---- build final result ---- ;; ---- build final result ----
(with-syntax ([public-names (map lookup-localize-cdr publics)] (with-syntax ([public-names (map lookup-localize-cdr publics)]
[public-final-names (map lookup-localize-cdr public-finals)] [public-final-names (map lookup-localize-cdr public-finals)]

12
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
(binding (private-name-orig-id v) (list validate-local-member-stx
id (list 'quote orig-id)
(private-name-gen-id v)))] (binding (private-name-orig-id v)
id
(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?)))

296
collects/scheme/private/string.ss
View File

@ -32,21 +32,7 @@
s))))))) s)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp helpers ;; Regexp utilities
(define (bstring-length s)
(if (bytes? s) (bytes-length s) (string-length s)))
(define (bstring->regexp name pattern)
(cond [(regexp? pattern) pattern]
[(byte-regexp? pattern) pattern]
[(string? pattern) (regexp pattern)]
[(bytes? pattern) (byte-regexp pattern)]
[else (raise-type-error
name "regexp, byte regexp, string, or byte string" pattern)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp helpers
(define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]") (define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]")
(define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]") (define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]")
@ -69,6 +55,34 @@
[else (raise-type-error 'regexp-replace-quote [else (raise-type-error 'regexp-replace-quote
"string or byte string" s)])) "string or byte string" s)]))
(define (make-regexp-tweaker tweaker)
(let ([t (make-weak-hasheq)])
(lambda (rx)
(define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x))
(define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x)))
(define-syntax-rule (tweak unwrap wrap convert)
(let ([tweaked (tweaker (unwrap rx))])
;; the tweaker is allowed to return a regexp
(if (or (regexp? tweaked) (byte-regexp? tweaked))
tweaked
(wrap (convert tweaked)))))
(define (run-tweak)
(cond [(pregexp? rx) (tweak object-name pregexp ->str)]
[(regexp? rx) (tweak object-name regexp ->str)]
[(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)]
[(byte-regexp? rx) (tweak object-name byte-regexp ->bts)]
;; allow getting a string, so if someone needs to go
;; from a string to a regexp, there's no penalty
;; because of the intermediate regexp being recreated
[(string? rx) (tweak (lambda (x) x) regexp ->str)]
[(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)]
[else (raise-type-error
'regexp-tweaker
"regexp, byte regexp, string, or byte string"
rx)]))
(or (hash-ref t rx #f)
(let ([rx* (run-tweak)]) (hash-set! t rx rx*) rx*)))))
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f]) (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f])
(unless (input-port? input-port) (unless (input-port? input-port)
(raise-type-error 'regexp-try-match (raise-type-error 'regexp-try-match
@ -91,156 +105,111 @@
(and p (subbytes s (- (car p) drop) (- (cdr p) drop)))) (and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
(cdr m)))))))) (cdr m))))))))
;; Helper macro for the regexp functions below. ;; Helper macro for the regexp functions below, with some utilities.
(define-syntax regexp-loop (define (bstring-length s)
(syntax-rules () (if (bytes? s) (bytes-length s) (string-length s)))
[(regexp-loop name loop start end rx string (define no-empty-edge-matches
success-choose failure-k (make-regexp-tweaker (lambda (rx) (format "(?=.)(?:~a)(?<=.)" rx))))
port-success-k port-success-choose port-failure-k (define (bstring->no-edge-regexp name pattern)
need-leftover? peek?) (if (or (regexp? pattern) (byte-regexp? pattern)
(let ([len (cond [(string? string) (string-length string)] (string? pattern) (bytes? pattern))
[(bytes? string) (bytes-length string)] (no-empty-edge-matches pattern)
[else #f])]) (raise-type-error
(if peek? name "regexp, byte regexp, string, or byte string" pattern)))
(unless (input-port? string) (define-syntax-rule (regexp-loop
(raise-type-error 'name "input port" string)) name loop start end rx string
(unless (or len (input-port? string)) success-choose failure-k
(raise-type-error port-success-k port-success-choose port-failure-k
'name "string, byte string or input port" string))) need-leftover? peek?)
(unless (and (number? start) (exact? start) (integer? start) (let ([len (cond [(string? string) (string-length string)]
(start . >= . 0)) [(bytes? string) (bytes-length string)]
(raise-type-error 'name "non-negative exact integer" start)) [else #f])])
(unless (or (not end) (if peek?
(and (number? end) (exact? end) (integer? end) (unless (input-port? string)
(end . >= . 0))) (raise-type-error 'name "input port" string))
(raise-type-error 'name "non-negative exact integer or false" end)) (unless (or len (input-port? string))
(unless (or (input-port? string) (and len (start . <= . len))) (raise-type-error
(raise-mismatch-error 'name "string, byte string or input port" string)))
'name (unless (and (number? start) (exact? start) (integer? start)
(format "starting offset index out of range [0,~a]: " len) (start . >= . 0))
start)) (raise-type-error 'name "non-negative exact integer" start))
(unless (or (not end) (unless (or (not end)
(and (start . <= . end) (and (number? end) (exact? end) (integer? end)
(or (input-port? string) (end . >= . 0)))
(and len (end . <= . len))))) (raise-type-error 'name "non-negative exact integer or false" end))
(raise-mismatch-error (unless (or (input-port? string) (and len (start . <= . len)))
'name (raise-mismatch-error
(format "ending offset index out of range [~a,~a]: " start len) 'name
end)) (format "starting offset index out of range [0,~a]: " len)
(reverse start))
(let loop ([acc '()] [start start] [end end]) (unless (or (not end)
(and (start . <= . end)
(or (input-port? string) (and len (end . <= . len)))))
(raise-mismatch-error
'name
(format "ending offset index out of range [~a,~a]: " start len)
end))
(reverse
(let loop ([acc '()] [start start] [end end])
(if (and port-success-choose (input-port? string)) (if (and port-success-choose (input-port? string))
;; Input port match, get string ;; Input port match, get string
(let* ([_ (when (positive? start) (let* ([_ (when (positive? start)
;; Skip start chars: ;; Skip start chars:
(let ([s (make-bytes 4096)]) (let ([s (make-bytes 4096)])
(let loop ([n 0]) (let loop ([n 0])
(unless (= n start) (unless (= n start)
(let ([m (read-bytes-avail! (let ([m (read-bytes-avail!
s string 0 (min (- start n) 4096))]) s string 0 (min (- start n) 4096))])
(unless (eof-object? m) (loop (+ n m))))))))] (unless (eof-object? m) (loop (+ n m))))))))]
[discarded/leftovers (if need-leftover? #f 0)] [discarded/leftovers (if need-leftover? #f 0)]
[spitout (if need-leftover? [spitout (if need-leftover?
(open-output-bytes) (open-output-bytes)
(make-output-port (make-output-port
'counter always-evt 'counter always-evt
(lambda (s start end flush? breakable?) (lambda (s start end flush? breakable?)
(let ([c (- end start)]) (let ([c (- end start)])
(set! discarded/leftovers (set! discarded/leftovers
(+ c discarded/leftovers)) (+ c discarded/leftovers))
c)) c))
void))] void))]
[end (and end (- end start))] [end (and end (- end start))]
[m (regexp-match rx string 0 end spitout)] [m (regexp-match rx string 0 end spitout)]
;; re-match if we get a zero-length match at the [m (and m (car m))]
;; beginning [discarded/leftovers (if need-leftover?
[m (if (and m ; we have a match (get-output-bytes spitout)
;; and it's an empty one discarded/leftovers)]
(zero? (bstring-length (car m))) [end (and end m
;; and it's at the beginning (- end (if need-leftover?
(zero? (if need-leftover? (bstring-length discarded/leftovers)
(file-position spitout) discarded/leftovers)
discarded/leftovers)) (bstring-length m)))])
;; and we still have stuff to match (if m
(if end (loop (cons (port-success-choose m discarded/leftovers) acc)
(< 0 end) 0 end)
(not (eof-object? (peek-byte string))))) (port-failure-k acc discarded/leftovers)))
(regexp-match rx string 1 end spitout)
m)]
[m (and m (car m))]
[discarded/leftovers (if need-leftover?
(get-output-bytes spitout)
discarded/leftovers)]
[end (and end m
(- end (if need-leftover?
(bstring-length discarded/leftovers)
discarded/leftovers)
(bstring-length m)))])
;; drop matches that are both empty and at the end
(if (and m (or (< 0 (bstring-length m))
(if end
(< 0 end)
(not (eof-object? (peek-byte string))))))
(loop (cons (port-success-choose m discarded/leftovers) acc)
0 end)
(port-failure-k acc discarded/leftovers)))
;; String/port match, get positions ;; String/port match, get positions
(let* ([match (if peek? (let ([m (if peek?
regexp-match-peek-positions (regexp-match-peek-positions rx string start end)
regexp-match-positions)] (regexp-match-positions rx string start end))])
[m (match rx string start end)]) (if (not m)
(if (not m) (failure-k acc start end)
(failure-k acc start end) (let ([mstart (caar m)] [mend (cdar m)])
(let* ([mstart (caar m)] (if port-success-k
[mend (cdar m)] (port-success-k
;; re-match if we get a zero-length match at the (lambda (acc new-start new-end)
;; beginning, and we can continue (loop acc new-start new-end))
[m (if (and (= mstart mend start) acc start end mstart mend)
(cond (loop (cons (success-choose start mstart mend) acc)
[end (< start end)] mend end))))))))))
[len (< start len)]
[(input-port? string)
(not (eof-object? (peek-byte string)))]
[else (error "internal error (str)")]))
(if (or peek? (not (input-port? string)))
(match rx string (add1 start) end)
;; rematching on a port requires adding `start'
;; offsets
(let ([m (match rx string 1 end)])
(if (and m (positive? start))
(list (cons (+ start (caar m))
(+ start (cdar m))))
m)))
m)])
;; fail if rematch failed
(if (not m)
(failure-k acc start end)
(let ([mstart (caar m)]
[mend (cdar m)])
;; or if we have a zero-length match at the end
(if (and (= mstart mend)
(cond [end (= mend end)]
[len (= mend len)]
[(input-port? string)
(eof-object?
(peek-byte string (if peek? mend 0)))]
[else (error "internal error (str)")]))
(failure-k acc start end)
(if port-success-k
(port-success-k
(lambda (acc new-start new-end)
(loop acc new-start new-end))
acc start end mstart mend)
(loop (cons (success-choose start mstart mend) acc)
mend end))))))))))))]))
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-positions* pattern string [start 0] [end #f]) (define (regexp-match-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-positions* pattern)) (regexp-loop
(regexp-loop regexp-match-positions* loop start end rx string regexp-match-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-positions* pattern) string
;; success-choose: ;; success-choose:
(lambda (start mstart mend) (cons mstart mend)) (lambda (start mstart mend) (cons mstart mend))
;; failure-k: ;; failure-k:
@ -262,8 +231,9 @@
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-peek-positions* pattern string [start 0] [end #f]) (define (regexp-match-peek-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-peek-positions* pattern)) (regexp-loop
(regexp-loop regexp-match-peek-positions* loop start end rx string regexp-match-peek-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-peek-positions* pattern) string
;; success-choose: ;; success-choose:
(lambda (start mstart mend) (cons mstart mend)) (lambda (start mstart mend) (cons mstart mend))
;; failure-k: ;; failure-k:
@ -278,7 +248,7 @@
;; Splits a string into a list by removing any piece which matches ;; Splits a string into a list by removing any piece which matches
;; the pattern. ;; the pattern.
(define (regexp-split pattern string [start 0] [end #f]) (define (regexp-split pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-split pattern)) (define rx (bstring->no-edge-regexp 'regexp-split pattern))
(define buf (if (and (string? string) (byte-regexp? rx)) (define buf (if (and (string? string) (byte-regexp? rx))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))
@ -300,7 +270,7 @@
;; Returns all the matches for the pattern in the string. ;; Returns all the matches for the pattern in the string.
(define (regexp-match* pattern string [start 0] [end #f]) (define (regexp-match* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match* pattern)) (define rx (bstring->no-edge-regexp 'regexp-match* pattern))
(define buf (if (and (string? string) (byte-regexp? rx)) (define buf (if (and (string? string) (byte-regexp? rx))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))

49
collects/scheme/private/stxparam.ss Normal file
View File

@ -0,0 +1,49 @@
(module stxparam '#%kernel
(#%require "more-scheme.ss"
"letstx-scheme.ss"
"define.ss"
(for-syntax '#%kernel
"../stxparam-exptime.ss"
"stx.ss" "stxcase-scheme.ss"
"small-scheme.ss"
"stxloc.ss" "stxparamkey.ss"))
(#%provide (for-syntax do-syntax-parameterize))
(define-for-syntax (do-syntax-parameterize stx let-syntaxes-id)
(syntax-case stx ()
[(_ ([id val] ...) body0 body ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(gen-id ...)
(map (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id))
(let* ([rt (syntax-local-value id (lambda () #f))]
[sp (if (set!-transformer? rt)
(set!-transformer-procedure rt)
rt)])
(unless (syntax-parameter? sp)
(raise-syntax-error
#f
"not bound as a syntax parameter"
stx
id))
(syntax-local-get-shadower
(syntax-local-introduce (syntax-parameter-target sp)))))
ids)])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate binding"
stx
dup)))
(with-syntax ([let-syntaxes let-syntaxes-id])
(syntax/loc stx
(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
body0 body ...)))))])))

184
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
@ -28,9 +29,10 @@
get-output get-output
get-error-output get-error-output
get-uncovered-expressions get-uncovered-expressions
get-namespace call-in-sandbox-context
make-evaluator make-evaluator
make-module-evaluator make-module-evaluator
call-in-nested-thread*
call-with-limits call-with-limits
with-limits with-limits
exn:fail:resource? exn:fail:resource?
@ -138,6 +140,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))
@ -206,45 +213,61 @@
(define memory-accounting? (custodian-memory-accounting-available?)) (define memory-accounting? (custodian-memory-accounting-available?))
;; similar to `call-in-nested-thread', but propagates killing the thread,
;; shutting down the custodian or setting parameters and thread cells;
;; optionally with thunks to call for kill/shutdown.
(define (call-in-nested-thread*
thunk
[kill (lambda () (kill-thread (current-thread)))]
[shutdown (lambda () (custodian-shutdown-all (current-custodian)))])
(let* ([p #f]
[c (make-custodian)]
[b (make-custodian-box c #t)])
(with-handlers ([(lambda (_) (not p))
;; if the after thunk was not called, then this error is
;; about the thread dying unnaturally, so propagate
;; whatever it did
(lambda (_) ((if (custodian-box-value b) kill shutdown)))])
(dynamic-wind void
(lambda ()
(parameterize ([current-custodian c])
(call-in-nested-thread
(lambda ()
(dynamic-wind void thunk
;; this should always be called unless the thread is killed or
;; the custodian is shutdown, distinguish the two cases
;; through the above box
(lambda ()
(set! p (current-preserved-thread-cell-values))))))))
(lambda () (when p (current-preserved-thread-cell-values p)))))))
(define (call-with-limits sec mb thunk) (define (call-with-limits sec mb thunk)
(let ([r #f] ;; note that when the thread is killed after using too much memory or time,
[c (make-custodian)] ;; then all thread-local changes (parameters and thread cells) are discarded
;; used to copy parameter changes from the nested thread (let ([r #f])
[p current-preserved-thread-cell-values]) (call-in-nested-thread*
(when (and mb memory-accounting?) (lambda ()
(custodian-limit-memory c (* mb 1024 1024) c)) ;; memory limit
(parameterize ([current-custodian c]) (when (and mb memory-accounting?)
;; The nested-thread can die on a time-out or memory-limit, (custodian-limit-memory (current-custodian) (* mb 1024 1024)))
;; and never throws an exception, so we never throw an error, ;; time limit
;; just assume the a death means the custodian was shut down (when sec
;; due to memory limit. Note: cannot copy the (let ([t (current-thread)])
;; parameterization in this case. (thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
(with-handlers ([exn:fail? (lambda (e) (set! r (with-handlers ([void (lambda (e) (list raise e))])
(unless r (set! r (cons #f 'memory))))]) (call-with-values thunk (lambda vs (list* values vs))))))
(call-in-nested-thread (lambda () (unless r (set! r 'kill)))
(lambda () (lambda () (unless r (set! r 'shut))))
(define this (current-thread)) (case r
(define timer [(kill) (kill-thread (current-thread))]
(and sec [(shut) (custodian-shutdown-all (current-custodian))]
(thread (lambda () [(memory time)
(sleep sec) (raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
;; even in this case there are no parameters (current-continuation-marks)
;; to copy, since it is on a different thread r))]
(set! r (cons #f 'time)) [else (if (pair? r)
(kill-thread this))))) (apply (car r) (cdr r))
(set! r (error 'call-with-limits "internal error in nested: ~e" r))])))
(with-handlers ([void (lambda (e) (list (p) raise e))])
(call-with-values thunk (lambda vs (list* (p) values vs)))))
(when timer (kill-thread timer)))))
(custodian-shutdown-all c)
(unless r (error 'call-with-limits "internal error"))
;; apply parameter changes first
(when (car r) (p (car r)))
(if (pair? (cdr r))
(apply (cadr r) (cddr r))
(raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r))
(current-continuation-marks)
(cdr r)))))))
(define-syntax with-limits (define-syntax with-limits
(syntax-rules () (syntax-rules ()
@ -376,16 +399,14 @@
(lambda (x) (abort-current-continuation deftag x))) (lambda (x) (abort-current-continuation deftag x)))
(loop (car exprs) (cdr exprs)))))))))) (loop (car exprs) (cdr exprs))))))))))
(define (evaluate-program program limits uncovered!) (define (evaluate-program program limit-thunk uncovered!)
(when uncovered! (when uncovered!
(eval `(,#'#%require scheme/private/sandbox-coverage))) (eval `(,#'#%require scheme/private/sandbox-coverage)))
;; the actual evaluation happens under specified limits, if given ;; the actual evaluation happens under the specified limits
(let ([run (if (and (pair? program) (eq? 'begin (car program))) ((limit-thunk (lambda ()
(lambda () (eval* (cdr program))) (if (and (pair? program) (eq? 'begin (car program)))
(lambda () (eval program)))] (eval* (cdr program))
[sec (and limits (car limits))] (eval program)))))
[mb (and limits (cadr limits))])
(if (or sec mb) (call-with-limits sec mb run) (run)))
(let ([ns (syntax-case* program (module) literal-identifier=? (let ([ns (syntax-case* program (module) literal-identifier=?
[(module mod . body) [(module mod . body)
(identifier? #'mod) (identifier? #'mod)
@ -429,15 +450,15 @@
(define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break) (define-evaluator-messenger break-evaluator 'break)
(define-evaluator-messenger (set-eval-limits . xs) 'limits) (define-evaluator-messenger (set-eval-limits secs mb) 'limits)
(define-evaluator-messenger (put-input . xs) 'input) (define-evaluator-messenger (put-input . xs) 'input)
(define-evaluator-messenger get-output 'output) (define-evaluator-messenger get-output 'output)
(define-evaluator-messenger get-error-output 'error-output) (define-evaluator-messenger get-error-output 'error-output)
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered) (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
(define-evaluator-messenger get-namespace 'namespace) (define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
(define (make-evaluator* init-hook require-perms program-maker) (define (make-evaluator* init-hook require-perms program-maker)
(define cust (make-custodian)) (define user-cust (make-custodian))
(define coverage? (sandbox-coverage-enabled)) (define coverage? (sandbox-coverage-enabled))
(define uncovered #f) (define uncovered #f)
(define input-ch (make-channel)) (define input-ch (make-channel))
@ -447,12 +468,17 @@
(define error-output #f) (define error-output #f)
(define limits (sandbox-eval-limits)) (define limits (sandbox-eval-limits))
(define user-thread #t) ; set later to the thread (define user-thread #t) ; set later to the thread
(define orig-cust (current-custodian)) (define user-done-evt #t) ; set in the same place
(define orig-cust (current-custodian))
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))])
(if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
(define (user-kill) (define (user-kill)
(when user-thread (when user-thread
(let ([t user-thread]) (let ([t user-thread])
(set! user-thread #f) (set! user-thread #f)
(custodian-shutdown-all cust) (custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case (kill-thread t))) ; just in case
(void)) (void))
(define (user-break) (define (user-break)
@ -465,7 +491,7 @@
;; now read and evaluate the input program ;; now read and evaluate the input program
(evaluate-program (evaluate-program
(if (procedure? program-maker) (program-maker) program-maker) (if (procedure? program-maker) (program-maker) program-maker)
limits limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get)))) (and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok)) (channel-put result-ch 'ok))
;; finally wait for interaction expressions ;; finally wait for interaction expressions
@ -475,20 +501,15 @@
(when (eof-object? expr) (channel-put result-ch expr) (user-kill)) (when (eof-object? expr) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))]) (channel-put result-ch (cons 'exn exn)))])
(let* ([run (if (evaluator-message? expr) (define run
(lambda () (limit-thunk (if (evaluator-message? expr)
(apply (evaluator-message-msg expr) (lambda ()
(evaluator-message-args expr))) (apply (evaluator-message-msg expr)
(lambda () (evaluator-message-args expr)))
(set! n (add1 n)) (lambda ()
(eval* (input->code (list expr) 'eval n))))] (set! n (add1 n))
[sec (and limits (car limits))] (eval* (input->code (list expr) 'eval n))))))
[mb (and limits (cadr limits))] (channel-put result-ch (cons 'vals (call-with-values run list))))
[run (if (or sec mb)
(lambda () (with-limits sec mb (run)))
run)])
(channel-put result-ch
(cons 'vals (call-with-values run list)))))
(loop))))) (loop)))))
(define (user-eval expr) (define (user-eval expr)
(let ([r (if user-thread (let ([r (if user-thread
@ -500,7 +521,7 @@
(lambda (e) (lambda (e)
(user-break) (user-break)
(loop))]) (loop))])
(channel-get result-ch)))) (sync user-done-evt result-ch))))
eof)]) eof)])
(cond [(eof-object? r) (error 'evaluator "terminated")] (cond [(eof-object? r) (error 'evaluator "terminated")]
[(eq? (car r) 'exn) (raise (cdr r))] [(eq? (car r) 'exn) (raise (cdr r))]
@ -538,30 +559,32 @@
[(output) (output-getter output)] [(output) (output-getter output)]
[(error-output) (output-getter error-output)] [(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))] [(uncovered) (apply get-uncovered (evaluator-message-args expr))]
[(namespace) (user-eval (make-evaluator-message [(thunk) (user-eval (make-evaluator-message
current-namespace '()))] (car (evaluator-message-args expr)) '()))]
[else (error 'evaluator "internal error, bad message: ~e" msg)])) [else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr))) (user-eval expr)))
(define linked-outputs? #f)
(define (make-output what out set-out! allow-link?) (define (make-output what out set-out! allow-link?)
(cond [(not out) (open-output-nowhere)] (cond [(not out) (open-output-nowhere)]
[(and (procedure? out) (procedure-arity-includes? out 0)) (out)] [(and (procedure? out) (procedure-arity-includes? out 0)) (out)]
[(output-port? out) out] [(output-port? out) out]
[(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)] [(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)]
[(memq out '(bytes string)) [(memq out '(bytes string))
(let* ([bytes? (eq? 'bytes out)] (let* ([bytes? (eq? out 'bytes)]
;; the following doesn't really matter: they're the same ;; create the port under the user's custodian
[out ((if bytes? open-output-bytes open-output-string))]) [out (parameterize ([current-custodian user-cust])
(call-in-nested-thread
;; this doesn't really matter: they're the same anyway
(if bytes? open-output-bytes open-output-string)))])
(set-out! (set-out!
(lambda () (lambda ()
(parameterize ([current-custodian orig-cust]) ;; this will run in the user context
(let ([buf (get-output-bytes out #t)]) (let ([buf (get-output-bytes out #t)])
(if bytes? buf (bytes->string/utf-8 buf #\?)))))) (if bytes? buf (bytes->string/utf-8 buf #\?)))))
out)] out)]
[else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)])) [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)]))
(parameterize* ; the order in these matters (parameterize* ; the order in these matters
(;; create a sandbox context first (;; create a sandbox context first
[current-custodian cust] [current-custodian user-cust]
[current-thread-group (make-thread-group)] [current-thread-group (make-thread-group)]
[current-namespace (make-evaluation-namespace)] [current-namespace (make-evaluation-namespace)]
;; set up the IO context ;; set up the IO context
@ -594,7 +617,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
@ -607,6 +630,7 @@
;; it will not use the new namespace. ;; it will not use the new namespace.
[current-eventspace (make-eventspace)]) [current-eventspace (make-eventspace)])
(set! user-thread (bg-run->thread (run-in-bg user-process))) (set! user-thread (bg-run->thread (run-in-bg user-process)))
(set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
(let ([r (channel-get result-ch)]) (let ([r (channel-get result-ch)])
(if (eq? r 'ok) (if (eq? r 'ok)
;; initial program executed ok, so return an evaluator ;; initial program executed ok, so return an evaluator

82
collects/scheme/splicing.ss
View File

@ -1,12 +1,16 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base
syntax/kerncase)
"stxparam.ss"
"private/stxparam.ss")
(provide splicing-let-syntax (provide splicing-let-syntax
splicing-let-syntaxes splicing-let-syntaxes
splicing-letrec-syntax splicing-letrec-syntax
splicing-letrec-syntaxes) splicing-letrec-syntaxes
splicing-syntax-parameterize)
(define-for-syntax (do-let-syntax stx rec? multi?) (define-for-syntax (do-let-syntax stx rec? multi? let-stx-id)
(syntax-case stx () (syntax-case stx ()
[(_ ([ids expr] ...) body ...) [(_ ([ids expr] ...) body ...)
(let ([all-ids (map (lambda (ids-stx) (let ([all-ids (map (lambda (ids-stx)
@ -38,13 +42,7 @@
stx stx
dup-id))) dup-id)))
(if (eq? 'expression (syntax-local-context)) (if (eq? 'expression (syntax-local-context))
(with-syntax ([let-stx (if rec? (with-syntax ([let-stx let-stx-id])
(if multi?
#'letrec-syntaxes
#'letrec-syntax)
(if multi?
#'let-syntaxes
#'let-syntax))])
(syntax/loc stx (syntax/loc stx
(let-stx ([ids expr] ...) (let-stx ([ids expr] ...)
(#%expression body) (#%expression body)
@ -52,6 +50,7 @@
(let ([def-ctx (syntax-local-make-definition-context)] (let ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))]) [ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
(internal-definition-context-seal def-ctx)
(let* ([add-context (let* ([add-context
(lambda (expr) (lambda (expr)
(let ([q (local-expand #`(quote #,expr) (let ([q (local-expand #`(quote #,expr)
@ -77,13 +76,68 @@
body ...))))))])) body ...))))))]))
(define-syntax (splicing-let-syntax stx) (define-syntax (splicing-let-syntax stx)
(do-let-syntax stx #f #f)) (do-let-syntax stx #f #f #'let-syntax))
(define-syntax (splicing-let-syntaxes stx) (define-syntax (splicing-let-syntaxes stx)
(do-let-syntax stx #f #t)) (do-let-syntax stx #f #t #'let-syntaxes))
(define-syntax (splicing-letrec-syntax stx) (define-syntax (splicing-letrec-syntax stx)
(do-let-syntax stx #t #f)) (do-let-syntax stx #t #f #'letrec-syntax))
(define-syntax (splicing-letrec-syntaxes stx) (define-syntax (splicing-letrec-syntaxes stx)
(do-let-syntax stx #t #t)) (do-let-syntax stx #t #t #'letrec-syntaxes))
;; ----------------------------------------
(define-syntax (splicing-syntax-parameterize stx)
(if (eq? 'expression (syntax-local-context))
;; Splicing is no help in an expression context:
(do-syntax-parameterize stx #'let-syntaxes)
;; Let `syntax-parameterize' check syntax, then continue
(do-syntax-parameterize stx #'ssp-let-syntaxes)))
(define-syntax (ssp-let-syntaxes stx)
(syntax-case stx ()
[(_ ([(id) rhs] ...) body ...)
(with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))])
#'(begin
;; Evaluate each RHS only once:
(define-syntax splicing-temp rhs) ...
;; Partially expand `body' to push down `let-syntax':
(expand-ssp-body (id ...) (splicing-temp ...) body)
...))]))
(define-syntax (expand-ssp-body stx)
(syntax-case stx ()
[(_ (sp-id ...) (temp-id ...) body)
(let ([body (local-expand #'(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
...)
(force-expand body))
(syntax-local-context)
null ;; `force-expand' actually determines stopping places
#f)])
;; Extract expanded body out of `body':
(syntax-case body (quote)
[(ls _ _ (quoute body))
(let ([body #'body])
(syntax-case body (begin define-values define-syntaxes define-for-syntaxes)
[(define-values (id ...) rhs)
(syntax/loc body
(define-values (id ...)
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
rhs)))]
[(define-syntaxes . _) body]
[(define-for-syntaxes . _) body]
[expr (syntax/loc body
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
expr))]))]))]))
(define-syntax (force-expand stx)
(syntax-case stx ()
[(_ stx)
;; Expand `stx' to reveal type of form, and then preserve it via
;; `quote':
#`(quote #,(local-expand #'stx
'module
(kernel-form-identifier-list)
#f))]))

35
collects/scheme/stxparam.ss
View File

@ -3,6 +3,7 @@
(#%require "private/more-scheme.ss" (#%require "private/more-scheme.ss"
"private/letstx-scheme.ss" "private/letstx-scheme.ss"
"private/define.ss" "private/define.ss"
"private/stxparam.ss"
(for-syntax '#%kernel (for-syntax '#%kernel
"stxparam-exptime.ss" "stxparam-exptime.ss"
"private/stx.ss" "private/stxcase-scheme.ss" "private/stx.ss" "private/stxcase-scheme.ss"
@ -30,36 +31,4 @@
gen-id))))))])) gen-id))))))]))
(define-syntax (syntax-parameterize stx) (define-syntax (syntax-parameterize stx)
(syntax-case stx () (do-syntax-parameterize stx #'let-syntaxes)))
[(_ ([id val] ...) body0 body ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(gen-id ...)
(map (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id))
(let* ([rt (syntax-local-value id (lambda () #f))]
[sp (if (set!-transformer? rt)
(set!-transformer-procedure rt)
rt)])
(unless (syntax-parameter? sp)
(raise-syntax-error
#f
"not bound as a syntax parameter"
stx
id))
(syntax-local-get-shadower
(syntax-local-introduce (syntax-parameter-target sp)))))
ids)])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate binding"
stx
dup)))
#'(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
body0 body ...)))])))

1
collects/scribble/latex-render.ss
View File

@ -374,6 +374,7 @@
(if (rendering-tt) (format "{\\hbox{\\texttt{~a}}}" c) c)] (if (rendering-tt) (format "{\\hbox{\\texttt{~a}}}" c) c)]
[(#\~) "$\\sim$"] [(#\~) "$\\sim$"]
[(#\{ #\} #\# #\% #\& #\$) (format "\\~a" c)] [(#\{ #\} #\# #\% #\& #\$) (format "\\~a" c)]
[(#\uA0) "~"]
[(#\uDF) "{\\ss}"] [(#\uDF) "{\\ss}"]
[(#\u039A) "K"] ; kappa [(#\u039A) "K"] ; kappa
[(#\u0391) "A"] ; alpha [(#\u0391) "A"] ; alpha

29
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 ...)
#'(with-togetherable-scheme-variables (begin
(lit ...) (for-each (lambda (id)
([form spec]) (unless (identifier? id)
(*defforms #f (raise-syntax-error #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec))) "expected an identifier for a literal"
null null stx
(lambda () (list desc ...))))] id)))
(syntax->list #'(lit ...)))
#'(with-togetherable-scheme-variables
(lit ...)
([form spec])
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
(lambda () (list desc ...)))))]
[(_ spec desc ...) [(_ spec desc ...)
#'(defform/none #:literals () spec desc ...)])) #'(defform/none #:literals () spec desc ...)]))

11
collects/scribble/struct.ss
View File

@ -14,11 +14,12 @@
(define (collect-put! ci key val) (define (collect-put! ci key val)
(let ([ht (collect-info-ht ci)]) (let ([ht (collect-info-ht ci)])
(when (hash-ref ht key #f) (let ([old-val (hash-ref ht key #f)])
(fprintf (current-error-port) (when old-val
"WARNING: collected information for key multiple times: ~e\n" (fprintf (current-error-port)
key)) "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n"
(hash-set! ht key val))) key old-val val))
(hash-set! ht key val))))
(define (resolve-get/where part ri key) (define (resolve-get/where part ri key)
(let ([key (tag-key key ri)]) (let ([key (tag-key key ri)])

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]

6
collects/scribblings/guide/guide.scrbl
View File

@ -92,6 +92,12 @@ downloadable packages contributed by PLT Scheme users.
#:date "2004" #:date "2004"
#:url "http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf") #:url "http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf")
(bib-entry #:key "Flatt02"
#:author "Matthew Flatt"
#:title "Composable and Compilable Macros: You Want it When?"
#:location "International Conference on Functional Programming"
#:date "2002")
(bib-entry #:key "Flatt06" (bib-entry #:key "Flatt06"
#:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen" #:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen"
#:title "Scheme with Classes, Mixins, and Traits (invited tutorial)" #:title "Scheme with Classes, Mixins, and Traits (invited tutorial)"

9
collects/scribblings/guide/modules.scrbl
View File

@ -5,12 +5,9 @@
@title[#:tag "modules" #:style 'toc]{Modules} @title[#:tag "modules" #:style 'toc]{Modules}
Scheme definitions and expressions are normally written inside of a
module. Although a @tech{REPL} evaluates definitions and expressions outside Modules let you organize Scheme code into multiple files and reusable
of a module for exploration and debugging purposes, and although libraries.
@scheme[load] can evaluate definitions and expressions from a file as
if they appeared in a @tech{REPL} interaction, code that is meant to last for
more than a few seconds belongs in a module.
@local-table-of-contents[] @local-table-of-contents[]

132
collects/scribblings/guide/namespaces.scrbl
View File

@ -385,3 +385,135 @@ example, since the enclosing module requires
instance of @schememodname[scheme/class]. Moreover, that instance is instance of @schememodname[scheme/class]. Moreover, that instance is
the same as the one imported into the module, so the class datatype is the same as the one imported into the module, so the class datatype is
shared. shared.
@; ----------------------------------------------------------------------
@section[#:tag "load"]{Scripting Evaluation and Using @scheme[load]}
Historically, Scheme and Lisp systems did not offer module
systems. Instead, large programs were built by essentially scripting
the @tech{REPL} to evaluate program fragments in a particular order.
While @tech{REPL} scripting turns out to be a bad way to structure
programs and libraries, it is still sometimes a useful capability.
@margin-note{Describing a program via @scheme[load] interacts
especially badly with macro-defined language extensions
@cite["Flatt02"].}
The @scheme[load] function runs a @tech{REPL} script by
@scheme[read]ing S-expressions from a file, one by one, and passing
them to @scheme[eval]. If a file @filepath{place.scm} contains
@schemeblock[
(define city "Salt Lake City")
(define state "Utah")
(printf "~a, ~a\n" city state)
]
then it can be loaded in a @tech{REPL}:
@interaction[
(eval:alts (load "place.scm") (begin (define city "Salt Lake City")
(printf "~a, Utah\n" city)))
city
]
Since @scheme[load] uses @scheme[eval], however, a module like the
following generally will not work---for the same reasons described in
@secref["namespaces"]:
@schememod[
scheme
(define there "Utopia")
(load "here.scm")
]
The current namespace for evaluating the content of
@filepath{here.scm} is likely to be empty; in any case, you cannot get
@scheme[there] from @filepath{here.scm}. Also, any definitions in
@filepath{here.scm} will not become visible for use within the module;
after all, the @scheme[load] happens dynamically, while references to
identifiers within the module are resolved lexically, and therefore
statically.
Unlike @scheme[eval], @scheme[load] does not accept a namespace
argument. To supply a namespace to @scheme[load], set the
@scheme[current-namespace] parameter. The following example evaluates
the expressions in @filepath{here.scm} using the bindings of the
@schememodname[scheme/base] module:
@schememod[
scheme
(parameterize ([current-namespace (make-base-namespace)])
(load "here.scm"))
]
You can even use @scheme[namespace-anchor->namespace] to make the
bindings of the enclosing module accessible for dynamic evaluation. In
the following example, when @filepath{here.scm} is @scheme[load]ed, it
can refer to @scheme[there] as well as the bindings of
@schememodname[scheme]:
@schememod[
scheme
(define there "Utopia")
(define-namespace-anchor a)
(parameterize ([current-namespace (namespace-anchor->namespace a)])
(load "here.scm"))
]
Still, if @filepath{here.scm} defines any identifiers, the definitions
cannot be directly (i.e., statically) referenced by in the enclosing
module.
The @schememodname[scheme/load] module language is different from
@schememodname[scheme] or @schememodname[scheme/base]. A module using
@schememodname[scheme/load] treats all of its content as dynamic,
passing each form in the module body to @scheme[eval] (using a
namespace that is initialized with @schememodname[scheme]). As a
result, uses of @scheme[eval] and @scheme[load] in the module body see
the same dynamic namespace as immediate body forms. For example, if
@filepath{here.scm} contains
@schemeblock[
(define here "Morporkia")
(define (go!) (set! here there))
]
then running
@schememod[
scheme/load
(define there "Utopia")
(load "here.scm")
(go!)
(printf "~a\n" here)
]
prints ``Utopia''.
Drawbacks of using @schememodname[scheme/load] include reduced
error checking, tool support, and performance. For example, with the
program
@schememod[
scheme/load
(define good 5)
(printf "running\n")
good
bad
]
DrScheme's @onscreen{Check Syntax} tool cannot tell that the second
@scheme[good] is a reference to the first, and the unbound reference
to @scheme[bad] is reported only at run time instead of rejected
syntactically.

4
collects/scribblings/guide/welcome.scrbl
View File

@ -198,11 +198,11 @@ tempted to put just
(substring str 0 5)) (substring str 0 5))
] ]
into @filepath{piece.ss} and run @exec{mzscheme} with into @filepath{piece.scm} and run @exec{mzscheme} with
@interaction[ @interaction[
#:eval piece-eval #:eval piece-eval
(eval:alts (load "piece.ss") (void)) (eval:alts (load "piece.scm") (void))
(piece "howdy universe") (piece "howdy universe")
] ]

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

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

@ -335,7 +335,7 @@ string.
@defproc[(bytes-open-converter [from-name string?][to-name string?]) @defproc[(bytes-open-converter [from-name string?][to-name string?])
bytes-converter?]{ bytes-converter?]{
Produces a string converter to go from the encoding named by Produces a @deftech{byte converter} to go from the encoding named by
@scheme[from-name] to the encoding named by @scheme[to-name]. If the @scheme[from-name] to the encoding named by @scheme[to-name]. If the
requested conversion pair is not available, @scheme[#f] is returned requested conversion pair is not available, @scheme[#f] is returned
instead of a converter. instead of a converter.
@ -534,8 +534,8 @@ The result of @scheme[bytes-convert-end] is two values:
@defproc[(bytes-converter? [v any/c]) boolean?]{ @defproc[(bytes-converter? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a byte converter produced by Returns @scheme[#t] if @scheme[v] is a @tech{byte converter} produced
@scheme[bytes-open-converter], @scheme[#f] otherwise.} by @scheme[bytes-open-converter], @scheme[#f] otherwise.}
@defproc[(locale-string-encoding) any]{ @defproc[(locale-string-encoding) any]{

8
collects/scribblings/reference/concurrency.scrbl
View File

@ -3,11 +3,9 @@
@title[#:tag "concurrency" #:style 'toc]{Concurrency} @title[#:tag "concurrency" #:style 'toc]{Concurrency}
PLT Scheme supports multiple threads of control within a PLT Scheme supports multiple threads of control within a program,
program. Threads run concurrently, in the sense that one thread can thread-local storage, some primitive synchronization mechanisms, and a
preempt another without its cooperation, but threads currently all run framework for composing synchronization abstractions.
on the same processor (i.e., the same underlying OS process and
thread).
@local-table-of-contents[] @local-table-of-contents[]

79
collects/scribblings/reference/contracts.scrbl
View File

@ -661,80 +661,23 @@ contract on the fields that the sub-struct shares with its parent are
only used in the contract for the sub-struct's maker, and the selector only used in the contract for the sub-struct's maker, and the selector
or mutators for the super-struct are not provided.} or mutators for the super-struct are not provided.}
@defform/subs[ @defform[(define/contract id contract-expr init-value-expr)]{
(with-contract blame-id (wc-export ...) body ...+)
([wc-export
id
(id contract-expr)])]{
Generates a local contract boundary. The @scheme[contract-expr]
form cannot appear in expression position. The @scheme[body] of the
form allows definition/expression interleaving like a @scheme[module]
body. Names bound within the @scheme[body] must be exported to be
accessible from outside the @scheme[with-contract] form. Such
@scheme[id]s can either be paired with a @scheme[contract-expr] or
exported without a contract.
The @scheme[blame-id] is used for the positive positions of Attaches the contract @scheme[contract-expr] to
contracts paired with exported @scheme[id]s. Contracts broken @scheme[init-value-expr] and binds that to @scheme[id].
within the @scheme[with-contract] @scheme[body] will use the
@scheme[blame-id] for their negative position.
@examples[(require scheme/contract)
(with-contract odd-even
([odd? (-> number? boolean?)]
[even? (-> number? boolean?)])
(define (odd? n)
(if (zero? n) #f (even? (sub1 n))))
(define (even? n)
(if (zero? n) #t (odd? (sub1 n)))))
(even? 4)
(odd? "foo")
(with-contract bad-internal-call
([f (-> number? number?)]
[g (-> number? number?)])
(define (f x)
(+ x 1))
(define (g x)
(if (zero? x) #t (f #t))))
(f 4)
(f 'a)
(g "foo")
(g 0)
(g 3)]}
@defform*[[(define/contract id contract-expr init-value-expr)
(define/contract (head args) contract-expr body ...+)]]{
Works like @scheme[define], except that the contract
@scheme[contract-expr] is attached to the bound value.
The @scheme[define/contract] form treats individual definitions as The @scheme[define/contract] form treats individual definitions as
units of blame. The definition itself is responsible for positive units of blame. The definition itself is responsible for positive
(co-variant) positions of the contract and each reference to (co-variant) positions of the contract and each reference to
@scheme[id] outside of the definition must meet the negative positions @scheme[id] (including those in the initial value expression) must
of the contract. It is equivalent to wrapping a single @scheme[define] meet the negative positions of the contract.
with a @scheme[with-contract] form that pairs the @scheme[contract-expr]
with the bound identifier.
@examples[(require scheme/contract) Error messages with @scheme[define/contract] are not as clear as those
(define/contract a number? #t) provided by @scheme[provide/contract], because
a @scheme[define/contract] cannot detect the name of the definition
(define/contract (f x) where the reference to the defined variable occurs. Instead, it uses
(-> number? number?) the source location of the reference to the variable as the name of
(+ x 1)) that definition.}
(f 4)
(f #t)
(define/contract (g #:foo [x 3] . y)
(->* () (#:foo number?) #:rest (listof number?) number?)
(+ x (apply + y)))
(g)
(g #:foo #t)
(g 1 2 3 'a)
(define/contract i
(-> number? number?)
(lambda (x)
(if (number? x) (i #t) 0)))
(i 3)]}
@defform*[[(contract contract-expr to-protect-expr @defform*[[(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr) positive-blame-expr negative-blame-expr)

40
collects/scribblings/reference/custodians.scrbl
View File

@ -1,6 +1,8 @@
#lang scribble/doc #lang scribble/doc
@(require "mz.ss") @(require "mz.ss")
@(define eventspaces @tech[#:doc '(lib "scribblings/gui/gui.scrbl")]{eventspaces})
@title[#:tag "custodians"]{Custodians} @title[#:tag "custodians"]{Custodians}
See @secref["custodian-model"] for basic information on the PLT See @secref["custodian-model"] for basic information on the PLT
@ -22,8 +24,13 @@ automatically directed to shut down its managed values as well.}
@defproc[(custodian-shutdown-all [cust custodian?]) void?]{ @defproc[(custodian-shutdown-all [cust custodian?]) void?]{
Closes all open ports and closes all active TCP listeners and UDP @margin-note{In MrEd, @|eventspaces| managed by @scheme[cust] are also
sockets that are managed by @scheme[cust]. It also removes shut down.}
Closes all @tech{file-stream ports}, @tech{TCP ports}, @tech{TCP
listeners}, and @tech{UDP sockets} that are managed by @scheme[cust]
(and its subordinates), and empties all @tech{custodian box}es
associated with @scheme[cust] (and its subordinates). It also removes
@scheme[cust] (and its subordinates) as managers of all threads; when @scheme[cust] (and its subordinates) as managers of all threads; when
a thread has no managers, it is killed (or suspended; see a thread has no managers, it is killed (or suspended; see
@scheme[thread/suspend-to-kill]) If the current thread is to be @scheme[thread/suspend-to-kill]) If the current thread is to be
@ -33,18 +40,20 @@ thread.}
@defparam[current-custodian cust custodian?]{ @defparam[current-custodian cust custodian?]{
@margin-note{In MrEd, custodians also manage @|eventspaces|.}
A parameter that determines a custodian that assumes responsibility A parameter that determines a custodian that assumes responsibility
for newly created threads, ports, TCP listeners, UDP sockets, and for newly created threads, @tech{file-stream ports}, TCP ports,
byte converters.} @tech{TCP listeners}, @tech{UDP sockets}, and @tech{byte converters}.}
@defproc[(custodian-managed-list [cust custodian?][super custodian?]) list?]{ @defproc[(custodian-managed-list [cust custodian?][super custodian?]) list?]{
Returns a list of immediately managed objects and subordinate Returns a list of immediately managed objects (not including
custodians for @scheme[cust], where @scheme[cust] is itself @tech{custodian box}es) and subordinate custodians for @scheme[cust],
subordinate to @scheme[super] (directly or indirectly). If where @scheme[cust] is itself subordinate to @scheme[super] (directly
@scheme[cust] is not strictly subordinate to @scheme[super], the or indirectly). If @scheme[cust] is not strictly subordinate to
@exnraise[exn:fail:contract].} @scheme[super], the @exnraise[exn:fail:contract].}
@defproc[(custodian-memory-accounting-available?) boolean?]{ @defproc[(custodian-memory-accounting-available?) boolean?]{
@ -66,7 +75,7 @@ per-custodian memory accounting, otherwise the
If a check is registered, and if PLT Scheme later reaches a state after If a check is registered, and if PLT Scheme later reaches a state after
garbage collection (see @secref["gc-model"]) where allocating garbage collection (see @secref["gc-model"]) where allocating
@scheme[need-amt] bytes charged to @scheme[limit-cust] would fail or @scheme[need-amt] bytes charged to @scheme[limit-cust] would fail or
tigger some shutdown, then @scheme[stop-cust] is shut down.} trigger some shutdown, then @scheme[stop-cust] is shut down.}
@defproc[(custodian-limit-memory [limit-cust custodian?] @defproc[(custodian-limit-memory [limit-cust custodian?]
[limit-amt exact-nonnegative-integer?] [limit-amt exact-nonnegative-integer?]
@ -81,11 +90,16 @@ after garbage collection (see @secref["gc-model"]) where
@scheme[limit-cust] owns more than @scheme[limit-amt] bytes, then @scheme[limit-cust] owns more than @scheme[limit-amt] bytes, then
@scheme[stop-cust] is shut down. @scheme[stop-cust] is shut down.
@margin-note{A custodian's limit is checked only after a garbage
collection, except that it may also be checked during
certain large allocations that are individually larger
than the custodian's limit.}
For reliable shutdown, @scheme[limit-amt] for For reliable shutdown, @scheme[limit-amt] for
@scheme[custodian-limit-memory] must be much lower than the total @scheme[custodian-limit-memory] must be much lower than the total
amount of memory available (minus the size of memory that is amount of memory available (minus the size of memory that is
potentially used and not charged to @scheme[limit-cust]). Moreover, if potentially used and not charged to @scheme[limit-cust]). Moreover, if
indvidual allocations that are initially charged to individual allocations that are initially charged to
@scheme[limit-cust] can be arbitrarily large, then @scheme[stop-cust] @scheme[limit-cust] can be arbitrarily large, then @scheme[stop-cust]
must be the same as @scheme[limit-cust], so that excessively large must be the same as @scheme[limit-cust], so that excessively large
immediate allocations can be rejected with an immediate allocations can be rejected with an
@ -93,13 +107,13 @@ immediate allocations can be rejected with an
@defproc[(make-custodian-box [cust custodian?][v any/c]) custodian-box?]{ @defproc[(make-custodian-box [cust custodian?][v any/c]) custodian-box?]{
Returns a @deftech{custodian box} that contains @scheme[v] as long as Returns a @tech{custodian box} that contains @scheme[v] as long as
@scheme[cust] has not been shut down.} @scheme[cust] has not been shut down.}
@defproc[(custodian-box? [v any/c]) boolean?]{Returns @scheme[#t] if @defproc[(custodian-box? [v any/c]) boolean?]{Returns @scheme[#t] if
@scheme[v] is a @tech{custodian box} produced by @scheme[v] is a @tech{custodian box} produced by
@scheme[make-custodian-box], @scheme[#f] otherwise.} @scheme[make-custodian-box], @scheme[#f] otherwise.}
@defproc[(custodian-box-value [cb custodian-box?]) any]{Rturns the @defproc[(custodian-box-value [cb custodian-box?]) any]{Returns the
value in the given @tech{custodian box}, or @scheme[#f] if the value value in the given @tech{custodian box}, or @scheme[#f] if the value
has been removed.} has been removed.}

39
collects/scribblings/reference/eval-model.scrbl
View File

@ -339,6 +339,9 @@ specified with the datatype and its associated procedures.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "gc-model"]{Garbage Collection} @section[#:tag "gc-model"]{Garbage Collection}
@margin-note/ref{See @secref["memory"] for functions related to
garbage collection.}
In the program state In the program state
@prog-steps[ @prog-steps[
@ -504,6 +507,8 @@ access the same @tech{location}.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "module-eval-model"]{Modules and Module-Level Variables} @section[#:tag "module-eval-model"]{Modules and Module-Level Variables}
@margin-note/ref{See @secref["module"] for the syntax of modules.}
Most definitions in PLT Scheme are in modules. In terms of evaluation, Most definitions in PLT Scheme are in modules. In terms of evaluation,
a module is essentially a prefix on a defined name, so that different a module is essentially a prefix on a defined name, so that different
modules can define the name. That is, a @deftech{module-level modules can define the name. That is, a @deftech{module-level
@ -599,6 +604,8 @@ re-declared, each re-declaration of the module is immediately
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "mark-model"]{Continuation Frames and Marks} @section[#:tag "mark-model"]{Continuation Frames and Marks}
@margin-note/ref{See @secref["contmarks"] for continuation-mark forms and functions.}
Every continuation @scheme[_C] can be partitioned into Every continuation @scheme[_C] can be partitioned into
@deftech{continuation frames} @frame[1], @frame[2], ..., @frame["n"] @deftech{continuation frames} @frame[1], @frame[2], ..., @frame["n"]
such that @scheme[_C] = @*sub[@frame[1] @*sub[@frame[2] @*sub["..." such that @scheme[_C] = @*sub[@frame[1] @*sub[@frame[2] @*sub["..."
@ -618,6 +625,8 @@ to implement dynamic scope.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "prompt-model"]{Prompts, Delimited Continuations, and Barriers} @section[#:tag "prompt-model"]{Prompts, Delimited Continuations, and Barriers}
@margin-note/ref{See @secref["cont"] for continuation and prompt functions.}
A @deftech{prompt} is a special kind of continuation frame that is A @deftech{prompt} is a special kind of continuation frame that is
annotated with a specific @deftech{prompt tag} (essentially a annotated with a specific @deftech{prompt tag} (essentially a
continuation mark). Various operations allow the capture of frames in continuation mark). Various operations allow the capture of frames in
@ -650,8 +659,14 @@ escape-continuation aborts can cross continuation barriers.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "thread-model"]{Threads} @section[#:tag "thread-model"]{Threads}
Scheme supports multiple, pre-emptive @deftech{threads} of @margin-note/ref{See @secref["concurrency"] for thread and synchronization functions.}
evaluation. Threads are created explicitly by functions such as @scheme[thread].
Scheme supports multiple @deftech{threads} of evaluation. Threads run
concurrently, in the sense that one thread can preempt another without
its cooperation, but threads currently all run on the same processor
(i.e., the same underlying OS process and thread).
Threads are created explicitly by functions such as @scheme[thread].
In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent
expressions, up to one per thread, rather than a single expression. The expressions all expressions, up to one per thread, rather than a single expression. The expressions all
share the same objects and top-level variables, so that they can share the same objects and top-level variables, so that they can
@ -673,6 +688,8 @@ is created) as all other threads.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "parameter-model"]{Parameters} @section[#:tag "parameter-model"]{Parameters}
@margin-note/ref{See @secref["parameters"] for parameter forms and functions.}
@deftech{Parameters} are essentially a derived concept in Scheme; they @deftech{Parameters} are essentially a derived concept in Scheme; they
are defined in terms of @tech{continuation marks} and @tech{thread are defined in terms of @tech{continuation marks} and @tech{thread
cells}. However, parameters are also built in, in the sense that some cells}. However, parameters are also built in, in the sense that some
@ -701,6 +718,8 @@ the current continuation's frame.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "exn-model"]{Exceptions} @section[#:tag "exn-model"]{Exceptions}
@margin-note/ref{See @secref["exns"] for exception forms, functions, and types.}
@deftech{Exceptions} are essentially a derived concept in Scheme; they @deftech{Exceptions} are essentially a derived concept in Scheme; they
are defined in terms of continuations, prompts, and continuation are defined in terms of continuations, prompts, and continuation
marks. However, exceptions are also built in, in the sense that marks. However, exceptions are also built in, in the sense that
@ -723,12 +742,14 @@ outermost frame of the continuation for any new thread.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "custodian-model"]{Custodians} @section[#:tag "custodian-model"]{Custodians}
A @deftech{custodian} manages a collection of threads, file-stream @margin-note/ref{See @secref["custodians"] for custodian functions.}
ports, TCP ports, TCP listeners, UDP sockets, and byte converters.
Whenever a thread, file-stream port, TCP port, TCP listener, or UDP A @deftech{custodian} manages a collection of threads,
socket is created, it is placed under the management of the @tech{file-stream ports}, TCP ports, @tech{TCP listeners}, @tech{UDP
@deftech{current custodian} as determined by the sockets}, and @tech{byte converters}. Whenever a thread, etc. is
@scheme[current-custodian] @tech{parameter}. created, it is placed under the management of the @deftech{current
custodian} as determined by the @scheme[current-custodian]
@tech{parameter}.
@margin-note{In MrEd, custodians also manage eventspaces.} @margin-note{In MrEd, custodians also manage eventspaces.}
@ -764,7 +785,7 @@ collected, at which point its subordinates become immediately
subordinate to the collected custodian's superordinate custodian. subordinate to the collected custodian's superordinate custodian.
In addition to the other entities managed by a custodian, a In addition to the other entities managed by a custodian, a
@defterm{custodian box} created with @scheme[make-custodian-box] @deftech{custodian box} created with @scheme[make-custodian-box]
strongly holds onto a value placed in the box until the box's strongly holds onto a value placed in the box until the box's
custodian is shut down. The custodian only weakly retains the box custodian is shut down. The custodian only weakly retains the box
itself, however (so the box and its content can be collected if there itself, however (so the box and its content can be collected if there

8
collects/scribblings/reference/eval.scrbl
View File

@ -408,6 +408,14 @@ is not defined at the time the @scheme[set!] is performed. Note that
this parameter is used when an expression is @italic{compiled}, not this parameter is used when an expression is @italic{compiled}, not
when it is @italic{evaluated}.} when it is @italic{evaluated}.}
@defboolparam[compile-context-preservation-enabled on?]{
A parameter that determines whether compilation should avoid
function-call inlining and other optimizations that may cause
information to be lost from stack traces (as reported by
@scheme[continuation-mark-set->context]). The default is @scheme[#f],
which allows such optimizations.}
@defboolparam[eval-jit-enabled on?]{ @defboolparam[eval-jit-enabled on?]{
A parameter that determines whether the native-code just-in-time A parameter that determines whether the native-code just-in-time

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.}

Some files were not shown because too many files have changed in this diff Show More