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

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

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

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

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

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

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

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

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

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

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

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

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

8
collects/frtime/frtime.ss
View File

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

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

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

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

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

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

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

4
collects/frtime/lang.ss
View File

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

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

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

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

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

4
collects/frtime/reactive.ss
View File

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

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

@ -2,9 +2,11 @@
(module card-class mzscheme
(require mzlib/class
mzlib/class100
mzlib/shared
(prefix mred: mred)
"snipclass.ss"
"region.ss")
"region.ss"
(only scheme/base for in-range))
(provide card%)
@ -28,18 +30,43 @@
(thunk)
(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%
(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)
(private-field
[suit-id -suit-id]
[value -value]
[width -width]
[height -height]
[rotated 'n]
[front -front]
[back -back]
[semi-front -semi-front]
[semi-back -semi-back]
[mk-dim-front -mk-dim-front]
[mk-dim-back -mk-dim-back]
[dim-front #f]
@ -51,13 +78,20 @@
[can-move? #t]
[snap-back? #f]
[stay-region #f]
[home-reg #f])
[home-reg #f]
[rotated-bms -rotated-bms])
(private
[refresh
(lambda ()
(let ([a (get-admin)])
(when a
(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
(lambda ()
(when is-dim?
@ -65,7 +99,18 @@
(unless dim-back
(set! dim-back (mk-dim-back)))
(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
[face-down? (lambda () flipped?)]
[flip
@ -84,6 +129,25 @@
(unless (eq? is-dim? (and v #t))
(set! is-dim? (and v #t))
(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
(lambda () suit-id)]
[get-suit
@ -133,26 +197,44 @@
[draw
(lambda (dc x y left top right bottom dx dy draw-caret)
(check-dim)
(if semi-flipped?
(send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y)
(with-card-region
dc x y width height
(lambda ()
(send dc draw-bitmap
(if flipped?
(if is-dim? dim-back back)
(if is-dim? dim-front front))
x y)))))]
[copy (lambda () (make-object card% suit-id value width height
front back semi-front semi-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)))])
(let ([do-draw
(lambda (x y)
(with-card-region
dc x y width height
(lambda ()
(send dc draw-bitmap
(let ([bm (if flipped?
(if is-dim? dim-back back)
(if is-dim? dim-front front))])
(get-rotated bm rotated))
x y))))])
(if semi-flipped?
(let-values ([(sx sy) (send dc get-scale)])
(case rotated
[(n s)
(send dc set-scale (/ sx 2) sy)
(do-draw (+ (* 2 x) (/ width 2)) y)
(send dc set-scale sx sy)]
[(e w)
(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
[save-x (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<%>]{
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
initially shown; @scheme[(send table show #t)] shows it.}
@scheme[w] cards wide and @scheme[h] cards high (assuming a standard
card of 71 by 96 pixels). The table is not initially shown;
@scheme[(send table show #t)] shows it.}
@defproc[(make-deck)
(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
(which are returned by the card's @method[card<%> get-value] and
@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?])
list?]{
@ -171,8 +172,9 @@ Create an instance with @scheme[make-table].
void?]{
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
added to the table.}
bottom-right to top-left, assuming that all cards in @scheme[cards]
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<%>)])
void?]{
@ -227,6 +229,19 @@ Removes @scheme[card] from the table.}
Like @method[table<%> flip-cards], but only for @scheme[card] or
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?]
[(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?]{
Returns the width of the card in pixels. All cards have the same
width.}
Returns the width of the card in pixels. If the card is rotated 90 or
270 degrees, the result is the card's original height.}
@defmethod[(card-height) exact-nonnegative-integer?]{
Returns the height of the card in pixels. All cards have the same
height.}
Returns the height of the card in pixels. If the card is rotated 90 or
270 degrees, the result is the card's original width.}
@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.}
@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]{
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?]
[(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.}
@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 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
(lambda (card)
(cards-face-up (list card)))]
@ -695,27 +716,28 @@
(send pb only-front-selected)))]
[position-cards-in-region
(lambda (cards r set)
(let-values ([(x y w h) (send pb get-region-box r)]
[(len) (sub1 (length cards))]
[(cw ch) (values (send back get-width)
(send back get-height))])
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
[pw (pretty cw)]
[ph (pretty ch)])
(let-values ([(x w) (if (> w pw)
(values (+ x (/ (- w pw) 2)) pw)
(values x w))]
[(y h) (if (> h ph)
(values (+ y (/ (- h ph) 2)) ph)
(values y h))])
(position-cards cards x y
(lambda (p)
(if (zero? len)
(values (/ (- w cw) 2)
(/ (- h ch) 2))
(values (* (- len p) (/ (- w cw) len))
(* (- len p) (/ (- h ch) len)))))
set)))))])
(unless (null? cards)
(let-values ([(x y w h) (send pb get-region-box r)]
[(len) (sub1 (length cards))]
[(cw ch) (values (send (car cards) card-width)
(send (car cards) card-height))])
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
[pw (pretty cw)]
[ph (pretty ch)])
(let-values ([(x w) (if (> w pw)
(values (+ x (/ (- w pw) 2)) pw)
(values x w))]
[(y h) (if (> h ph)
(values (+ y (/ (- h ph) 2)) ph)
(values y h))])
(position-cards cards x y
(lambda (p)
(if (zero? len)
(values (/ (- w cw) 2)
(/ (- h ch) 2))
(values (* (- len p) (/ (- w cw) len))
(* (- len p) (/ (- h ch) len)))))
set))))))])
(super-new [label title] [style '(metal no-resize-border)])
(begin
(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)
(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)
(let ([w (send bm-in get-width)]
[h (send bm-in get-height)])
@ -46,11 +37,6 @@
(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
(make-dim back))
@ -74,9 +60,9 @@
value
w h
front back
(make-semi front w h) semi-back
(lambda () (make-dim front))
(lambda () dim-back))
(lambda () dim-back)
(make-hash-table 'equal))
(vloop (sub1 value))))))))))
(define (make-card front-bm back-bm suit-id value)
@ -87,12 +73,9 @@
value
w h
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 ()
(if back-bm
(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 @@
#|
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.
|#
;; constants
(define circle-radius 20)
(define circle-spacing 22)
;; data definitions
;; a world is:
;; (make-world board posn state number)
(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
(define (board->image cs world-size)
(foldl overlay
(foldl (lambda (x y) (overlay y x))
(nw:rectangle (world-width world-size)
(world-height world-size)
'outline
'black)
'solid
'white)
(map cell->image cs)))
(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3)
(overlay
(cell->image
(make-cell (make-posn 0 0) false))
(nw:rectangle (world-width 3)
(world-height 3)
'outline
'black)))
'solid
'white)
(cell->image (make-cell (make-posn 0 0) false))))
;; cell->image : cell -> image

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

@ -1278,7 +1278,9 @@
(new switchable-button%
(label (string-constant debug-tool-button-name))
(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)))))
(inherit register-toolbar-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)])
(unless (or (< (string-length 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")
(regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1")
(currently-processed-file-name)
@ -148,7 +148,8 @@
(define current-processed-file ; set when processing multi-file submissions
(make-parameter #f))
(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)
(let loop ([n 1])
@ -164,7 +165,7 @@
[line (if (and untabify? (regexp-match? #rx"\t" line))
(untabify line) 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)
(currently-processed-file-name)
(if textualize? "" (format " (line ~a)" n))))
@ -650,6 +651,9 @@
(define (procedure/arity? proc arity)
(and (procedure? proc) (procedure-arity-includes? proc arity)))
(define (get-namespace evaluator)
(call-in-sandbox-context evaluator (lambda () (current-namespace))))
(provide !defined)
(define-syntax-rule (!defined id ...)
;; expected to be used only with identifiers

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

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

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

@ -74,7 +74,6 @@
[(allow-new-users) (values #f id )]
[(allow-change-info) (values #f id )]
[(master-password) (values #f id )]
[(web-base-dir) (values #f path/false )]
[(log-output) (values #t id )]
[(log-file) (values "log" 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}.}
@item{Check the status of your submission by pointing a web browser at
@tt{https://localhost:7980/servlets/status.ss}. Note the ``s'' in
``https''. Use the ``@tt{tester}'' username and ``@tt{pw}''
password, as before.
@tt{https://localhost:7980/}. Note the ``s'' in ``https''. Use the
``@tt{tester}'' username and ``@tt{pw}'' password, as before.
NOTE: The @scheme[https-port-number] line in the
@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
@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
server directory or absolute) that specifies a filename for
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
re-read, and options are reloaded. A few options are fixed at
startup time: port numbers, log file specs, and the
@scheme[web-base-dir] are fixed as configured at startup. All other
options will change the behavior of the running server (but things
like @scheme[username-case-sensitive?] it would be unwise to do
so). (For safety, options are not reloaded until the file parses
startup time: port numbers and log file specs are fixed as
configured at startup. All other options will change the behavior
of the running server (but things like
@scheme[username-case-sensitive?] it would be unwise to do so).
(For safety, options are not reloaded until the file parses
correctly, but make sure that you don't save a copy that has
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
@ -482,11 +472,11 @@ the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server
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
@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
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
(require scheme/unit
net/ssl-tcp-unit
net/tcp-sig
net/tcp-unit
(only-in mzlib/etc this-expression-source-directory)
web-server/web-server-unit
web-server/web-server-sig
web-server/web-config-sig
web-server/web-config-unit
web-server/configuration/namespace
"private/config.ss")
#lang scheme
(require scheme/list
scheme/file
scheme/date
net/uri-codec
web-server/servlet
web-server/servlet-env
web-server/managers/lru
handin-server/private/md5
handin-server/private/logger
handin-server/private/config
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 in-web-dir
(in-dir (or (get-conf 'web-base-dir)
(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 (make-page title . body)
`(html (head (title ,title))
(body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
(define config
`((port ,port-no)
(max-waiting 40)
(initial-connection-timeout 30)
(default-host-table
(host-table
(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 get-user-data
(let ([users-file (build-path server-dir "users.ss")])
(unless (file-exists? users-file)
(error 'get-user-data "users file missing at: ~a" users-file))
(lambda (user)
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
(define configuration
(configuration-table-sexpr->web-config@
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 (relativize-path p)
(path->string (find-relative-path (normalize-path server-dir) p)))
(define-unit-binding config@ configuration (import) (export web-config^))
(define-unit-binding ssl-tcp@
(make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f)
(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@)
(define (make-k k tag)
(format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(uri-encode tag)))
(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
(let ([def-ctx (syntax-local-make-definition-context)]
[ctx (generate-expand-context)])
(let loop ([exprs (cddddr (cdr (syntax->list stx)))])
(apply
append
(map (lambda (expr)
(let ([expr (local-expand
expr
ctx
block-expand-stop-forms
def-ctx)])
(syntax-case expr (begin define-values define-syntaxes)
[(begin . rest)
(loop (syntax->list #'rest))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(list expr))]
[else
(list expr)])))
exprs))))])
(begin0
(let loop ([exprs (cddddr (cdr (syntax->list stx)))])
(apply
append
(map (lambda (expr)
(let ([expr (local-expand
expr
ctx
block-expand-stop-forms
def-ctx)])
(syntax-case expr (begin define-values define-syntaxes)
[(begin . rest)
(loop (syntax->list #'rest))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(list expr))]
[else
(list expr)])))
exprs)))
(internal-definition-context-seal def-ctx)))])
#`(let ()
#,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
(cond

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

@ -74,7 +74,7 @@
(define (check-arg value method argument)
(or (> value 0)
(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)
(letrec ((lower

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

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

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

@ -278,18 +278,18 @@
((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any))
"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")
(memq (any list -> (union false list))
(memq (any (listof any) -> (union false list))
"to determine whether some value is on some list"
" (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"
" (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"
" (comparing values with equal?)")
(reverse (list -> list)
(reverse ((listof any) -> list)
"to create a reversed version of a list")
(assq (X (listof (cons X Y)) -> (union false (cons X Y)))
"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)
#:transparent)
;; (make-p:provide <Base> (listof Deriv) ?exn)
(define-struct (p:provide prule) (inners ?2) #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)
@ -98,7 +101,6 @@
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; (make-p:#%variable-reference <Base>)
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
@ -110,7 +112,6 @@
(define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax 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)
;; A LDeriv is

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

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

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

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

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

@ -194,9 +194,23 @@
[#:pattern (?top . ?var)]
[#:learn (list #'?var)])]
[(Wrap p:provide (e1 e2 rs ?1))
(R [! ?1]
[#:walk e2 'provide])]
[(Wrap p:provide (e1 e2 rs ?1 inners ?2))
(let ([wrapped-inners
(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))
(R [! ?1])]

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

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

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

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

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

@ -54,8 +54,7 @@
(define syntax-widget/controls%
(class* widget% ()
(inherit get-main-panel
get-controller
toggle-props)
get-controller)
(super-new)
(inherit-field config)
@ -85,7 +84,10 @@
(new button%
(label "Properties")
(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=?
(lambda (name+func)

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

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
"../util/notify.ss"
"interfaces.ss"
"partition.ss")
(provide smart-keymap%
@ -48,6 +49,7 @@
(set! on-demand-actions (cons p on-demand-actions)))
(define/override (on-demand)
(super on-demand)
(for-each (lambda (p) (p)) on-demand-actions))
(super-new)))
@ -92,28 +94,42 @@
(lambda (i e)
(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
(new menu-item% (label "Copy") (parent the-context-menu)
(callback (lambda (i e)
(call-function "copy-text" i e)))))
(void))
(define/public (after-edit-items)
(void))
(define/public (add-selection-items)
(demand-callback
(lambda (i)
(send i enable (and (selected-syntax) #t))))
(callback
(lambda (i e)
(call-function "copy-text" i e)))))
(add-separator)
(set! clear-menu
(new menu-item%
(label "Clear selection")
(parent the-context-menu)
(demand-callback
(lambda (i)
(send i enable (and (selected-syntax) #t))))
(callback
(lambda (i e)
(call-function "clear-syntax-selection" i e)))))
(set! props-menu
(menu-option/notify-box the-context-menu
"View syntax properties"
(get-field props-shown? config))
#;
(new menu-item%
(label "Show syntax properties")
(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
(lambda (i e)
(if (send config get-props-shown?)
@ -121,55 +137,10 @@
(call-function "show-syntax-properties" i e))))))
(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)
(new separator-menu-item% (parent the-context-menu)))
;; Initialize menu
(add-edit-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"))))))
(add-menu-items)
))

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"
"../util/notify.ss"
"../util/misc.ss")
(provide syntax-prefs%
syntax-prefs/readonly%
#;pref:tabify
#;pref:height
#;pref:width
#;pref:props-percentage)
(provide syntax-prefs-base%
syntax-prefs%
syntax-prefs/readonly%)
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -22,13 +18,37 @@
(pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-base%
(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 height)
;; props-percentage : ...
(notify-methods props-percentage)
;; props-shown? : boolean
(notify-methods props-shown?)
(super-new)))

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

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

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

@ -7,19 +7,18 @@
scheme/pretty
scheme/gui
"pretty-helper.ss"
"interfaces.ss"
"params.ss"
"prefs.ss")
"interfaces.ss")
(provide pretty-print-syntax)
;; pretty-print-syntax : syntax port partition -> range%
(define (pretty-print-syntax stx port primary-partition)
;; pretty-print-syntax :
;; 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-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition
(length (current-colors))
(current-suffix-option)))
(length colors)
suffix-option))
(define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj)
@ -53,7 +52,7 @@
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[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)
[print-unreadable #t]
[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 change-style (make-object style-delta% 'change-alignment 'top))
(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 end-edit-sequence)
(send text hide-caret #t)

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

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

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

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

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

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

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

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/promise)
(provide cursor?
cursor-position
cursor:new
cursor:add-to-end!
cursor:remove-current!
@ -25,107 +26,109 @@
cursor:prefix->list
cursor:suffix->list)
(define-syntax stream-cons
(syntax-rules ()
[(stream-cons x y)
(delay (cons x y))]))
(define-struct cursor (vector count position)
#:mutable)
(define (stream-car x)
(if (promise? x)
(car (force x))
(car x)))
(define (stream-cdr x)
(if (promise? x)
(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:ensure-capacity c capacity)
(define v (cursor-vector c))
(when (< (vector-length v) capacity)
(let* ([new-capacity (ceiling (* capacity 3/2))]
[new-v (make-vector new-capacity)])
(vector-copy! new-v 0 v 0)
(set-cursor-vector! c new-v))))
(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)
(let ([suffix (cursor-suffixp c)])
(set-cursor-suffixp! c (stream-append suffix items))))
(define count0 (cursor-count c))
(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)
(when (cursor:has-next? c)
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
(cursor:remove-at! c (cursor-position 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)
(let ([suffix (cursor-suffixp c)])
(if (stream-null? suffix)
#f
(stream-car suffix))))
(define p (cursor-position c))
(define count (cursor-count c))
(and (< p count)
(vector-ref (cursor-vector c) p)))
(define (cursor:prev c)
(let ([prefix (cursor-prefix c)])
(if (pair? prefix)
(car prefix)
#f)))
(define p (cursor-position c))
(define count (cursor-count c))
(and (< 0 p)
(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)
(when (cursor:has-next? c)
(let* ([old-suffixp (cursor-suffixp c)])
(set-cursor-prefix! c (cons (stream-car old-suffixp)
(cursor-prefix c)))
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
(define p (cursor-position c))
(define count (cursor-count c))
(when (< p count)
(set-cursor-position! c (add1 p))))
(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)
(null? (cursor-prefix c)))
(= (cursor-position c) 0))
(define (cursor:at-end? c)
(stream-null? (cursor-suffixp c)))
(= (cursor-position c) (cursor-count c)))
(define (cursor:has-next? c)
(not (cursor:at-end? c)))
(define (cursor:has-prev? c)
(not (cursor:at-start? c)))
(define (cursor:move-to-start c)
(when (cursor:has-prev? c)
(cursor:move-prev c)
(cursor:move-to-start c)))
(set-cursor-position! c 0))
(define (cursor:move-to-end c)
(when (cursor:has-next? c)
(cursor:move-next c)
(cursor:move-to-end c)))
(set-cursor-position! c (cursor-count c)))
(define (cursor:skip-to c i)
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
(cursor:move-next c)
(cursor:skip-to c i)))
(when (<= 0 i (cursor-count c))
(set-cursor-position! c i)))
(define (cursor->list c)
(append (cursor:prefix->list c)
(cursor:suffix->list c)))
(define count (cursor-count 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)
(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)
(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)
(define/override (after-selection-items)
(super after-selection-items)
(define/override (add-menu-items)
(super add-menu-items)
(add-separator)
(set! show-macro
(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"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -120,8 +119,8 @@
(callback (lambda _ (send widget show-in-new-frame)))))
(menu-option/notify-box stepper-menu
"Show syntax properties"
(get-field show-syntax-properties? config))
"View syntax properties"
(get-field props-shown? config))
(let ([id-menu
(new (get-menu%)
@ -175,10 +174,10 @@
(parent extras-menu)
(callback
(lambda (i e)
(sb:current-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send config set-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"

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

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

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

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

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

@ -13,8 +13,6 @@
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -49,6 +47,9 @@
(define (focused-term)
(cursor:next terms))
;; current-step-index : notify of number/#f
(field/notify current-step-index (new notify-box% (value #f)))
;; add-deriv : Deriv -> void
(define/public (add-deriv d)
(let ([trec (new term-record% (stepper this) (raw-deriv d))])
@ -135,10 +136,8 @@
(stepper this)
(config config)))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(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
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
@ -173,6 +172,28 @@
(new button% (label "Next term") (parent navigator)
(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)
(if (> (length (cursor->list terms)) 1)
(send navigator change-children
@ -190,7 +211,7 @@
nav:next
nav:end)))))
(define/public (show-macro-hiding-prefs show?)
(define/public (show-macro-hiding-panel show?)
(send area change-children
(lambda (children)
(if show?
@ -223,6 +244,9 @@
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(update/save-position))
(define/public-final (navigate-to n)
(send (focused-term) navigate-to n)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
@ -253,7 +277,7 @@
#f
(send text line-start-position (unbox end-box))
'start))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
@ -271,7 +295,7 @@
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
@ -284,6 +308,7 @@
#f
(send text last-position)
'start)
(update-nav-index)
(enable/disable-buttons))
;; update:show-prefix : -> void
@ -305,6 +330,12 @@
(send trec display-initial-term))
(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
(define/private (enable/disable-buttons)
(define term (focused-term))
@ -312,6 +343,7 @@
(send nav:previous enable (and term (send term has-prev?)))
(send nav:next 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:down enable (cursor:has-next? terms)))
@ -343,6 +375,7 @@
(send (focused-term) on-get-focus))
(update))
#|
;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
@ -372,6 +405,7 @@
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
|#
(define/private (foci x) (if (list? x) x (list x)))
@ -387,8 +421,7 @@
;; Initialization
(super-new)
(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
(show-macro-hiding-panel (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(refresh/move)
))

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

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

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

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

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

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

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

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

1
collects/mzlib/etc.ss
View File

@ -386,6 +386,7 @@
[else
(list expr)])))
exprs)))])
(internal-definition-context-seal def-ctx)
(let loop ([exprs exprs]
[prev-stx-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])
(cond
[(and (null? pre-lines) (not port) (null? lines))
(internal-definition-context-seal def-ctx)
(make-parsed-unit imports
renames
vars

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

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

232
collects/mzlib/sandbox.ss
View File

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

11
collects/mzlib/unit.ss
View File

@ -126,8 +126,7 @@
((((int-sid . ext-sid) ...) . sbody) ...))
(map-sig (lambda (x) x)
(make-syntax-introducer)
sig)
#;(add-context-to-sig sig)])
sig)])
(list
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(values
@ -329,13 +328,6 @@
'expression
(list #'stop)
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)
(let loop ((n n)
@ -619,6 +611,7 @@
[_ (void)]))
expanded-body)
table)])
(internal-definition-context-seal def-ctx)
;; Mark exported names and
;; 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)])))
defns&exprs)))
values)])
(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
;; from syntax definitions.
(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?)))]
[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:
@verbatim[#:indent 2]|{

21
collects/profj/tool.ss
View File

@ -28,7 +28,7 @@
(dynamic-require the-file 'id))])
(apply orig-fn x)))
...)]))
(dr "compile.ss"
compile-java compile-interactions compile-files compile-ast compile-interactions-ast
compilation-unit-code compilation-unit-contains set-compilation-unit-code!
@ -116,6 +116,13 @@
(define mode-surrogate%
(class color:text-mode%
(define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "java"]
[finder:default-filters '(("Any" "*.*"))])
;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name)))
(define/override (on-disable-surrogate text)
(keymap:remove-chained-keymap text java-keymap)
(super on-disable-surrogate text))
@ -506,7 +513,7 @@
;default-settings: -> profj-settings
(define/public (default-settings)
(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)))
;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings)))
@ -763,11 +770,12 @@
(send collect-coverage enable #f))
(install-classpath (profj-settings-classpath settings))])))
(define eventspace (current-eventspace))
(define/public (front-end/complete-program port settings)
(mred? #t)
(let ([name (object-name port)]
[rep (drscheme:rep:current-rep)]
[eventspace (current-eventspace)]
#;[eventspace (current-eventspace)]
[execute-types (create-type-record)])
(let ([name-to-require #f]
[require? #f]
@ -793,6 +801,8 @@
(list (send execute-types get-test-classes) null)
(find-examples compilation-units))])
#;(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! modules (order compilation-units))
(when rep (send rep set-user-types execute-types))
@ -829,7 +839,6 @@
(send ,test-engine-obj run)
#;(printf "Test methods run~n")
(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 inner-loop ((os test-objs))
(unless (null? os)
@ -841,7 +850,9 @@
(write-special (car out))
(loop (cdr out))))
(newline))
(inner-loop (cdr os)))))))
(inner-loop (cdr os)))))
(send ,test-engine-obj summarize-results (current-output-port))
))
#f))]
[(and (not require?) (null? modules) tests-run?)
(begin0

1
collects/r5rs/main.ss
View File

@ -410,6 +410,7 @@
(cdr exprs)))
(reverse idss) (reverse rhss)
(reverse stx-idss) (reverse stx-rhss))]))))])
(internal-definition-context-seal def-ctx)
(if (and (null? (syntax-e #'(stx-rhs ...)))
(andmap (lambda (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)

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

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

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

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

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "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])
;; 11.8
not boolean? boolean=?
not boolean? (rename-out [r6rs:boolean=? boolean=?])
;; 11.9
(rename-out [r5rs:pair? pair?]
@ -123,7 +123,7 @@
[r5rs:for-each for-each])
;; 11.10
symbol? symbol=?
symbol? (rename-out [r6rs:symbol=? symbol=?])
string->symbol symbol->string
;; 11.11
@ -349,6 +349,22 @@
(and (regexp-match? rx:number 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)
(case-lambda
[(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))
(define (int-list->bytevector who signed? set l endianness size)
(unless (list? l)
(unless (mlist? l)
(raise-type-error who "list" l))
(check-endian endianness)
(unless (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))])
(for ([v (in-list l)]
[k (in-naturals)])
(set l k v endianness size))
(set bv (* k size) v endianness size))
bv))
(define (uint-list->bytevector l endianness size)

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

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

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

@ -7,7 +7,10 @@
exn:misc:match?
match:error
fail
matchable?)
matchable?
match-prompt-tag)
(define match-prompt-tag (make-continuation-prompt-tag 'match))
(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-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
;;--------------------------------------------------------------------
@ -1214,6 +1228,8 @@
proc))))))
methods)))]
[lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))])
(internal-definition-context-seal def-ctx)
;; ---- build final result ----
(with-syntax ([public-names (map lookup-localize-cdr publics)]

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

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

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

@ -32,21 +32,7 @@
s)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp helpers
(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
;; Regexp utilities
(define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]")
(define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]")
@ -69,6 +55,34 @@
[else (raise-type-error 'regexp-replace-quote
"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])
(unless (input-port? input-port)
(raise-type-error 'regexp-try-match
@ -91,156 +105,111 @@
(and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
(cdr m))))))))
;; Helper macro for the regexp functions below.
(define-syntax regexp-loop
(syntax-rules ()
[(regexp-loop name loop start end rx string
success-choose failure-k
port-success-k port-success-choose port-failure-k
need-leftover? peek?)
(let ([len (cond [(string? string) (string-length string)]
[(bytes? string) (bytes-length string)]
[else #f])])
(if peek?
(unless (input-port? string)
(raise-type-error 'name "input port" string))
(unless (or len (input-port? string))
(raise-type-error
'name "string, byte string or input port" string)))
(unless (and (number? start) (exact? start) (integer? start)
(start . >= . 0))
(raise-type-error 'name "non-negative exact integer" start))
(unless (or (not end)
(and (number? end) (exact? end) (integer? end)
(end . >= . 0)))
(raise-type-error 'name "non-negative exact integer or false" end))
(unless (or (input-port? string) (and len (start . <= . len)))
(raise-mismatch-error
'name
(format "starting offset index out of range [0,~a]: " len)
start))
(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])
;; Helper macro for the regexp functions below, with some utilities.
(define (bstring-length s)
(if (bytes? s) (bytes-length s) (string-length s)))
(define no-empty-edge-matches
(make-regexp-tweaker (lambda (rx) (format "(?=.)(?:~a)(?<=.)" rx))))
(define (bstring->no-edge-regexp name pattern)
(if (or (regexp? pattern) (byte-regexp? pattern)
(string? pattern) (bytes? pattern))
(no-empty-edge-matches pattern)
(raise-type-error
name "regexp, byte regexp, string, or byte string" pattern)))
(define-syntax-rule (regexp-loop
name loop start end rx string
success-choose failure-k
port-success-k port-success-choose port-failure-k
need-leftover? peek?)
(let ([len (cond [(string? string) (string-length string)]
[(bytes? string) (bytes-length string)]
[else #f])])
(if peek?
(unless (input-port? string)
(raise-type-error 'name "input port" string))
(unless (or len (input-port? string))
(raise-type-error
'name "string, byte string or input port" string)))
(unless (and (number? start) (exact? start) (integer? start)
(start . >= . 0))
(raise-type-error 'name "non-negative exact integer" start))
(unless (or (not end)
(and (number? end) (exact? end) (integer? end)
(end . >= . 0)))
(raise-type-error 'name "non-negative exact integer or false" end))
(unless (or (input-port? string) (and len (start . <= . len)))
(raise-mismatch-error
'name
(format "starting offset index out of range [0,~a]: " len)
start))
(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
(let* ([_ (when (positive? start)
;; Skip start chars:
(let ([s (make-bytes 4096)])
(let loop ([n 0])
(unless (= n start)
(let ([m (read-bytes-avail!
s string 0 (min (- start n) 4096))])
(unless (eof-object? m) (loop (+ n m))))))))]
[discarded/leftovers (if need-leftover? #f 0)]
[spitout (if need-leftover?
(open-output-bytes)
(make-output-port
'counter always-evt
(lambda (s start end flush? breakable?)
(let ([c (- end start)])
(set! discarded/leftovers
(+ c discarded/leftovers))
c))
void))]
[end (and end (- end start))]
[m (regexp-match rx string 0 end spitout)]
;; re-match if we get a zero-length match at the
;; beginning
[m (if (and m ; we have a match
;; and it's an empty one
(zero? (bstring-length (car m)))
;; and it's at the beginning
(zero? (if need-leftover?
(file-position spitout)
discarded/leftovers))
;; and we still have stuff to match
(if end
(< 0 end)
(not (eof-object? (peek-byte string)))))
(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)))
;; Input port match, get string
(let* ([_ (when (positive? start)
;; Skip start chars:
(let ([s (make-bytes 4096)])
(let loop ([n 0])
(unless (= n start)
(let ([m (read-bytes-avail!
s string 0 (min (- start n) 4096))])
(unless (eof-object? m) (loop (+ n m))))))))]
[discarded/leftovers (if need-leftover? #f 0)]
[spitout (if need-leftover?
(open-output-bytes)
(make-output-port
'counter always-evt
(lambda (s start end flush? breakable?)
(let ([c (- end start)])
(set! discarded/leftovers
(+ c discarded/leftovers))
c))
void))]
[end (and end (- end start))]
[m (regexp-match rx string 0 end spitout)]
[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)))])
(if m
(loop (cons (port-success-choose m discarded/leftovers) acc)
0 end)
(port-failure-k acc discarded/leftovers)))
;; String/port match, get positions
(let* ([match (if peek?
regexp-match-peek-positions
regexp-match-positions)]
[m (match rx string start end)])
(if (not m)
(failure-k acc start end)
(let* ([mstart (caar m)]
[mend (cdar m)]
;; re-match if we get a zero-length match at the
;; beginning, and we can continue
[m (if (and (= mstart mend start)
(cond
[end (< start 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))))))))))))]))
;; String/port match, get positions
(let ([m (if peek?
(regexp-match-peek-positions rx string start end)
(regexp-match-positions rx string start end))])
(if (not m)
(failure-k acc start end)
(let ([mstart (caar m)] [mend (cdar m)])
(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.
(define (regexp-match-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-positions* pattern))
(regexp-loop regexp-match-positions* loop start end rx string
(regexp-loop
regexp-match-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-positions* pattern) string
;; success-choose:
(lambda (start mstart mend) (cons mstart mend))
;; failure-k:
@ -262,8 +231,9 @@
;; Returns all the positions at which the pattern matched.
(define (regexp-match-peek-positions* pattern string [start 0] [end #f])
(define rx (bstring->regexp 'regexp-match-peek-positions* pattern))
(regexp-loop regexp-match-peek-positions* loop start end rx string
(regexp-loop
regexp-match-peek-positions* loop start end
(bstring->no-edge-regexp 'regexp-match-peek-positions* pattern) string
;; success-choose:
(lambda (start mstart mend) (cons mstart mend))
;; failure-k:
@ -278,7 +248,7 @@
;; Splits a string into a list by removing any piece which matches
;; the pattern.
(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))
(string->bytes/utf-8 string (char->integer #\?))
string))
@ -300,7 +270,7 @@
;; Returns all the matches for the pattern in the string.
(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))
(string->bytes/utf-8 string (char->integer #\?))
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-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-security-guard
sandbox-exit-handler
sandbox-network-guard
sandbox-make-inspector
sandbox-make-logger
@ -28,9 +29,10 @@
get-output
get-error-output
get-uncovered-expressions
get-namespace
call-in-sandbox-context
make-evaluator
make-module-evaluator
call-in-nested-thread*
call-with-limits
with-limits
exn:fail:resource?
@ -138,6 +140,11 @@
(define sandbox-security-guard (make-parameter default-sandbox-guard))
(define (default-sandbox-exit-handler _)
(error 'exit "sandboxed code cannot exit"))
(define sandbox-exit-handler (make-parameter default-sandbox-exit-handler))
(define sandbox-make-inspector (make-parameter make-inspector))
(define sandbox-make-logger (make-parameter current-logger))
@ -206,45 +213,61 @@
(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)
(let ([r #f]
[c (make-custodian)]
;; used to copy parameter changes from the nested thread
[p current-preserved-thread-cell-values])
(when (and mb memory-accounting?)
(custodian-limit-memory c (* mb 1024 1024) c))
(parameterize ([current-custodian c])
;; The nested-thread can die on a time-out or memory-limit,
;; and never throws an exception, so we never throw an error,
;; just assume the a death means the custodian was shut down
;; due to memory limit. Note: cannot copy the
;; parameterization in this case.
(with-handlers ([exn:fail? (lambda (e)
(unless r (set! r (cons #f 'memory))))])
(call-in-nested-thread
(lambda ()
(define this (current-thread))
(define timer
(and sec
(thread (lambda ()
(sleep sec)
;; even in this case there are no parameters
;; to copy, since it is on a different thread
(set! r (cons #f 'time))
(kill-thread this)))))
(set! 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)))))))
;; note that when the thread is killed after using too much memory or time,
;; then all thread-local changes (parameters and thread cells) are discarded
(let ([r #f])
(call-in-nested-thread*
(lambda ()
;; memory limit
(when (and mb memory-accounting?)
(custodian-limit-memory (current-custodian) (* mb 1024 1024)))
;; time limit
(when sec
(let ([t (current-thread)])
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs))))))
(lambda () (unless r (set! r 'kill)))
(lambda () (unless r (set! r 'shut))))
(case r
[(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))]
[(memory time)
(raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
(current-continuation-marks)
r))]
[else (if (pair? r)
(apply (car r) (cdr r))
(error 'call-with-limits "internal error in nested: ~e" r))])))
(define-syntax with-limits
(syntax-rules ()
@ -376,16 +399,14 @@
(lambda (x) (abort-current-continuation deftag x)))
(loop (car exprs) (cdr exprs))))))))))
(define (evaluate-program program limits uncovered!)
(define (evaluate-program program limit-thunk uncovered!)
(when uncovered!
(eval `(,#'#%require scheme/private/sandbox-coverage)))
;; the actual evaluation happens under specified limits, if given
(let ([run (if (and (pair? program) (eq? 'begin (car program)))
(lambda () (eval* (cdr program)))
(lambda () (eval program)))]
[sec (and limits (car limits))]
[mb (and limits (cadr limits))])
(if (or sec mb) (call-with-limits sec mb run) (run)))
;; the actual evaluation happens under the specified limits
((limit-thunk (lambda ()
(if (and (pair? program) (eq? 'begin (car program)))
(eval* (cdr program))
(eval program)))))
(let ([ns (syntax-case* program (module) literal-identifier=?
[(module mod . body)
(identifier? #'mod)
@ -429,15 +450,15 @@
(define-evaluator-messenger kill-evaluator 'kill)
(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 get-output 'output)
(define-evaluator-messenger get-error-output 'error-output)
(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 cust (make-custodian))
(define user-cust (make-custodian))
(define coverage? (sandbox-coverage-enabled))
(define uncovered #f)
(define input-ch (make-channel))
@ -447,12 +468,17 @@
(define error-output #f)
(define limits (sandbox-eval-limits))
(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)
(when user-thread
(let ([t user-thread])
(set! user-thread #f)
(custodian-shutdown-all cust)
(custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case
(void))
(define (user-break)
@ -465,7 +491,7 @@
;; now read and evaluate the input program
(evaluate-program
(if (procedure? program-maker) (program-maker) program-maker)
limits
limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok))
;; finally wait for interaction expressions
@ -475,20 +501,15 @@
(when (eof-object? expr) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(let* ([run (if (evaluator-message? expr)
(lambda ()
(apply (evaluator-message-msg expr)
(evaluator-message-args expr)))
(lambda ()
(set! n (add1 n))
(eval* (input->code (list expr) 'eval n))))]
[sec (and limits (car limits))]
[mb (and limits (cadr limits))]
[run (if (or sec mb)
(lambda () (with-limits sec mb (run)))
run)])
(channel-put result-ch
(cons 'vals (call-with-values run list)))))
(define run
(limit-thunk (if (evaluator-message? expr)
(lambda ()
(apply (evaluator-message-msg expr)
(evaluator-message-args expr)))
(lambda ()
(set! n (add1 n))
(eval* (input->code (list expr) 'eval n))))))
(channel-put result-ch (cons 'vals (call-with-values run list))))
(loop)))))
(define (user-eval expr)
(let ([r (if user-thread
@ -500,7 +521,7 @@
(lambda (e)
(user-break)
(loop))])
(channel-get result-ch))))
(sync user-done-evt result-ch))))
eof)])
(cond [(eof-object? r) (error 'evaluator "terminated")]
[(eq? (car r) 'exn) (raise (cdr r))]
@ -538,30 +559,32 @@
[(output) (output-getter output)]
[(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))]
[(namespace) (user-eval (make-evaluator-message
current-namespace '()))]
[(thunk) (user-eval (make-evaluator-message
(car (evaluator-message-args expr)) '()))]
[else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr)))
(define linked-outputs? #f)
(define (make-output what out set-out! allow-link?)
(cond [(not out) (open-output-nowhere)]
[(and (procedure? out) (procedure-arity-includes? out 0)) (out)]
[(output-port? out) out]
[(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)]
[(memq out '(bytes string))
(let* ([bytes? (eq? 'bytes out)]
;; the following doesn't really matter: they're the same
[out ((if bytes? open-output-bytes open-output-string))])
(let* ([bytes? (eq? out 'bytes)]
;; create the port under the user's custodian
[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!
(lambda ()
(parameterize ([current-custodian orig-cust])
(let ([buf (get-output-bytes out #t)])
(if bytes? buf (bytes->string/utf-8 buf #\?))))))
;; this will run in the user context
(let ([buf (get-output-bytes out #t)])
(if bytes? buf (bytes->string/utf-8 buf #\?)))))
out)]
[else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)]))
(parameterize* ; the order in these matters
(;; create a sandbox context first
[current-custodian cust]
[current-custodian user-cust]
[current-thread-group (make-thread-group)]
[current-namespace (make-evaluation-namespace)]
;; set up the IO context
@ -594,7 +617,7 @@
[current-command-line-arguments '#()]
;; restrict the sandbox context from this point
[current-security-guard (sandbox-security-guard)]
[exit-handler (lambda x (error 'exit "user code cannot exit"))]
[exit-handler (sandbox-exit-handler)]
[current-inspector ((sandbox-make-inspector))]
[current-logger ((sandbox-make-logger))]
;; This breaks because we need to load some libraries that are trusted
@ -607,6 +630,7 @@
;; it will not use the new namespace.
[current-eventspace (make-eventspace)])
(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)])
(if (eq? r 'ok)
;; initial program executed ok, so return an evaluator

82
collects/scheme/splicing.ss
View File

@ -1,12 +1,16 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require (for-syntax scheme/base
syntax/kerncase)
"stxparam.ss"
"private/stxparam.ss")
(provide splicing-let-syntax
splicing-let-syntaxes
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 ()
[(_ ([ids expr] ...) body ...)
(let ([all-ids (map (lambda (ids-stx)
@ -38,13 +42,7 @@
stx
dup-id)))
(if (eq? 'expression (syntax-local-context))
(with-syntax ([let-stx (if rec?
(if multi?
#'letrec-syntaxes
#'letrec-syntax)
(if multi?
#'let-syntaxes
#'let-syntax))])
(with-syntax ([let-stx let-stx-id])
(syntax/loc stx
(let-stx ([ids expr] ...)
(#%expression body)
@ -52,6 +50,7 @@
(let ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
(internal-definition-context-seal def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
@ -77,13 +76,68 @@
body ...))))))]))
(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)
(do-let-syntax stx #f #t))
(do-let-syntax stx #f #t #'let-syntaxes))
(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)
(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"
"private/letstx-scheme.ss"
"private/define.ss"
"private/stxparam.ss"
(for-syntax '#%kernel
"stxparam-exptime.ss"
"private/stx.ss" "private/stxcase-scheme.ss"
@ -30,36 +31,4 @@
gen-id))))))]))
(define-syntax (syntax-parameterize stx)
(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)))
#'(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
body0 body ...)))])))
(do-syntax-parameterize stx #'let-syntaxes)))

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

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

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

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

11
collects/scribble/struct.ss
View File

@ -14,11 +14,12 @@
(define (collect-put! ci key val)
(let ([ht (collect-info-ht ci)])
(when (hash-ref ht key #f)
(fprintf (current-error-port)
"WARNING: collected information for key multiple times: ~e\n"
key))
(hash-set! ht key val)))
(let ([old-val (hash-ref ht key #f)])
(when old-val
(fprintf (current-error-port)
"WARNING: collected information for key multiple times: ~e; values: ~e ~e\n"
key old-val val))
(hash-set! ht key val))))
(define (resolve-get/where part ri key)
(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
to have an extension mapping @scheme[extension].
Under Mac OS X, if @scheme[extension] is not @scheme[#f]
and @scheme[filters] contains the single
pattern @scheme[(string-append "*." extension)], then the result pathname is
guaranteed to have an extension mapping @scheme[extension]. Otherwise,
@scheme[extension] and @scheme[filters] are ignored.
Under Mac OS X 10.5 and later, if @scheme[extension] is not
@scheme[#f], the returned path will get a default extension if the
user does not supply one. If @scheme[filters] contains as
@scheme["*.*"] pattern, then the user can supply any extension that
is recognized by the system; otherwise, the extension on the returned
path will be either @scheme[extension] or @scheme[_other-extension]
for any @scheme[(string-append "*." _other-extension)] pattern in
@scheme[filters]. In particular, if the only pattern in
@scheme[filters] is empty or contains only @scheme[(string-append
"*." extension)], then the result pathname is guaranteed to have an
extension mapping @scheme[extension].
The @scheme[extension] argument is ignored under X, and @scheme[filters]
can be used to specify glob-patterns.
Under Mac OS X versions before 10.5, the returned path will get a
default extension only if @scheme[extension] is not @scheme[#f] and
@scheme[filters] contains only @scheme[(string-append "*."
extension)].
The @scheme[style] list is treated as for
@scheme[get-file].
The @scheme[extension] argument is ignored under X, and
@scheme[filters] can be used to specify glob-patterns.
The @scheme[style] list is treated as for @scheme[get-file].
See also @scheme[path-dialog%].
}
@defproc[(get-directory [message (or/c string? false/c) #f]

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

@ -92,6 +92,12 @@ downloadable packages contributed by PLT Scheme users.
#:date "2004"
#: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"
#:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen"
#: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}
Scheme definitions and expressions are normally written inside of a
module. Although a @tech{REPL} evaluates definitions and expressions outside
of a module for exploration and debugging purposes, and although
@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.
Modules let you organize Scheme code into multiple files and reusable
libraries.
@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
the same as the one imported into the module, so the class datatype is
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))
]
into @filepath{piece.ss} and run @exec{mzscheme} with
into @filepath{piece.scm} and run @exec{mzscheme} with
@interaction[
#:eval piece-eval
(eval:alts (load "piece.ss") (void))
(eval:alts (load "piece.scm") (void))
(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.
}
@copyright{
libunwind
Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P.
}
@copyright{
GNU Classpath
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?])
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
requested conversion pair is not available, @scheme[#f] is returned
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?]{
Returns @scheme[#t] if @scheme[v] is a byte converter produced by
@scheme[bytes-open-converter], @scheme[#f] otherwise.}
Returns @scheme[#t] if @scheme[v] is a @tech{byte converter} produced
by @scheme[bytes-open-converter], @scheme[#f] otherwise.}
@defproc[(locale-string-encoding) any]{

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

@ -3,11 +3,9 @@
@title[#:tag "concurrency" #:style 'toc]{Concurrency}
PLT Scheme supports multiple threads of control within a
program. 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).
PLT Scheme supports multiple threads of control within a program,
thread-local storage, some primitive synchronization mechanisms, and a
framework for composing synchronization abstractions.
@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
or mutators for the super-struct are not provided.}
@defform/subs[
(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.
@defform[(define/contract id contract-expr init-value-expr)]{
The @scheme[blame-id] is used for the positive positions of
contracts paired with exported @scheme[id]s. Contracts broken
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.
Attaches the contract @scheme[contract-expr] to
@scheme[init-value-expr] and binds that to @scheme[id].
The @scheme[define/contract] form treats individual definitions as
units of blame. The definition itself is responsible for positive
(co-variant) positions of the contract and each reference to
@scheme[id] outside of the definition must meet the negative positions
of the contract. It is equivalent to wrapping a single @scheme[define]
with a @scheme[with-contract] form that pairs the @scheme[contract-expr]
with the bound identifier.
@scheme[id] (including those in the initial value expression) must
meet the negative positions of the contract.
@examples[(require scheme/contract)
(define/contract a number? #t)
a
(define/contract (f x)
(-> number? number?)
(+ x 1))
(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)]}
Error messages with @scheme[define/contract] are not as clear as those
provided by @scheme[provide/contract], because
@scheme[define/contract] cannot detect the name of the definition
where the reference to the defined variable occurs. Instead, it uses
the source location of the reference to the variable as the name of
that definition.}
@defform*[[(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr)

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

@ -1,6 +1,8 @@
#lang scribble/doc
@(require "mz.ss")
@(define eventspaces @tech[#:doc '(lib "scribblings/gui/gui.scrbl")]{eventspaces})
@title[#:tag "custodians"]{Custodians}
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?]{
Closes all open ports and closes all active TCP listeners and UDP
sockets that are managed by @scheme[cust]. It also removes
@margin-note{In MrEd, @|eventspaces| managed by @scheme[cust] are also
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
a thread has no managers, it is killed (or suspended; see
@scheme[thread/suspend-to-kill]) If the current thread is to be
@ -33,18 +40,20 @@ thread.}
@defparam[current-custodian cust custodian?]{
@margin-note{In MrEd, custodians also manage @|eventspaces|.}
A parameter that determines a custodian that assumes responsibility
for newly created threads, ports, TCP listeners, UDP sockets, and
byte converters.}
for newly created threads, @tech{file-stream ports}, TCP ports,
@tech{TCP listeners}, @tech{UDP sockets}, and @tech{byte converters}.}
@defproc[(custodian-managed-list [cust custodian?][super custodian?]) list?]{
Returns a list of immediately managed objects and subordinate
custodians for @scheme[cust], where @scheme[cust] is itself
subordinate to @scheme[super] (directly or indirectly). If
@scheme[cust] is not strictly subordinate to @scheme[super], the
@exnraise[exn:fail:contract].}
Returns a list of immediately managed objects (not including
@tech{custodian box}es) and subordinate custodians for @scheme[cust],
where @scheme[cust] is itself subordinate to @scheme[super] (directly
or indirectly). If @scheme[cust] is not strictly subordinate to
@scheme[super], the @exnraise[exn:fail:contract].}
@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
garbage collection (see @secref["gc-model"]) where allocating
@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?]
[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[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
@scheme[custodian-limit-memory] must be much lower than the total
amount of memory available (minus the size of memory that is
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]
must be the same as @scheme[limit-cust], so that excessively large
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?]{
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.}
@defproc[(custodian-box? [v any/c]) boolean?]{Returns @scheme[#t] if
@scheme[v] is a @tech{custodian box} produced by
@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
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}
@margin-note/ref{See @secref["memory"] for functions related to
garbage collection.}
In the program state
@prog-steps[
@ -504,6 +507,8 @@ access the same @tech{location}.
@;------------------------------------------------------------------------
@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,
a module is essentially a prefix on a defined name, so that different
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}
@margin-note/ref{See @secref["contmarks"] for continuation-mark forms and functions.}
Every continuation @scheme[_C] can be partitioned into
@deftech{continuation frames} @frame[1], @frame[2], ..., @frame["n"]
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}
@margin-note/ref{See @secref["cont"] for continuation and prompt functions.}
A @deftech{prompt} is a special kind of continuation frame that is
annotated with a specific @deftech{prompt tag} (essentially a
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}
Scheme supports multiple, pre-emptive @deftech{threads} of
evaluation. Threads are created explicitly by functions such as @scheme[thread].
@margin-note/ref{See @secref["concurrency"] for thread and synchronization functions.}
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
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
@ -673,6 +688,8 @@ is created) as all other threads.
@;------------------------------------------------------------------------
@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
are defined in terms of @tech{continuation marks} and @tech{thread
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}
@margin-note/ref{See @secref["exns"] for exception forms, functions, and types.}
@deftech{Exceptions} are essentially a derived concept in Scheme; they
are defined in terms of continuations, prompts, and continuation
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}
A @deftech{custodian} manages a collection of threads, file-stream
ports, TCP ports, TCP listeners, UDP sockets, and byte converters.
Whenever a thread, file-stream port, TCP port, TCP listener, or UDP
socket is created, it is placed under the management of the
@deftech{current custodian} as determined by the
@scheme[current-custodian] @tech{parameter}.
@margin-note/ref{See @secref["custodians"] for custodian functions.}
A @deftech{custodian} manages a collection of threads,
@tech{file-stream ports}, TCP ports, @tech{TCP listeners}, @tech{UDP
sockets}, and @tech{byte converters}. Whenever a thread, etc. is
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.}
@ -764,7 +785,7 @@ collected, at which point its subordinates become immediately
subordinate to the collected custodian's superordinate custodian.
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
custodian is shut down. The custodian only weakly retains the box
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
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?]{
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?]{
Feletes the file with path @scheme[path] if it exists, otherwise the
Deletes the file with path @scheme[path] if it exists, otherwise the
@exnraise[exn:fail:filesystem]. If @scheme[path] is a link, the link
is deleted rather than the destination of the link.}

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