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

Merge branch 'master' of git.racket-lang.org:plt

Browse Source
This commit is contained in:
Mike Sperber 2012-11-10 08:57:48 +01:00
commit 114f47fad6
592 changed files with 18300 additions and 7232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.mailmap
View File

@ -11,6 +11,7 @@ Matthew Flatt <mflatt@racket-lang.org> <mflatt@debian.cs.utah.edu>
Matthew Flatt <mflatt@racket-lang.org> <mflatt@localhost.(none)> Matthew Flatt <mflatt@racket-lang.org> <mflatt@localhost.(none)>
Matthew Flatt <mflatt@racket-lang.org> <mflatt@mflatt-laptop.(none)> Matthew Flatt <mflatt@racket-lang.org> <mflatt@mflatt-laptop.(none)>
Matthew Flatt <mflatt@racket-lang.org> <mflatt@mflatt-VirtualBox.(none)> Matthew Flatt <mflatt@racket-lang.org> <mflatt@mflatt-VirtualBox.(none)>
Matthew Flatt <mflatt@racket-lang.org> <mflatt@ubuntu-12-64.(none)>
Kathy Gray <kathyg@racket-lang.org> <kathryn.gray@cl.cam.ac.uk> Kathy Gray <kathyg@racket-lang.org> <kathryn.gray@cl.cam.ac.uk>
Kathy Gray <kathyg@racket-lang.org> <kathyg@c0133.aw.cl.cam.ac.uk> Kathy Gray <kathyg@racket-lang.org> <kathyg@c0133.aw.cl.cam.ac.uk>
Matthias Felleisen <matthias@racket-lang.org> <matthias@ccs.neu.edu> Matthias Felleisen <matthias@racket-lang.org> <matthias@ccs.neu.edu>

18
collects/2htdp/batch-io.rkt
View File

@ -1,7 +1,12 @@
#lang racket #lang racket/base
(require (for-syntax syntax/parse) (require racket/function
srfi/13 htdp/error racket/file
racket/string
racket/local
(for-syntax racket/base
syntax/parse)
htdp/error
(rename-in lang/prim (first-order->higher-order f2h)) (rename-in lang/prim (first-order->higher-order f2h))
"private/csv/csv.rkt") "private/csv/csv.rkt")
@ -163,10 +168,13 @@
;; split : String [Regexp] -> [Listof String] ;; split : String [Regexp] -> [Listof String]
;; splits a string into a list of substrings using the given delimiter ;; splits a string into a list of substrings using the given delimiter
;; (white space by default) ;; (white space by default)
;;ELI: This shouldn't be needed now, it can use `string-split' as is
;; (also, the trimming doesn't make sense if the pattern is not a
;; space--?)
(define (split str [ptn #rx"[ ]+"]) (define (split str [ptn #rx"[ ]+"])
(regexp-split ptn (string-trim-both str))) (regexp-split ptn (string-trim str)))
;; split-lines : String -> Listof[String] ;; split-lines : String -> Listof[String]
;; splits a string with newlines into a list of lines ;; splits a string with newlines into a list of lines
(define (split-lines str) (define (split-lines str)
(map string-trim-both (split str "\r*\n"))) (map string-trim (split str "\r*\n")))

8
collects/2htdp/private/check-aux.rkt
View File

@ -1,6 +1,10 @@
#lang racket #lang racket/base
(require htdp/error) (require racket/class
racket/list
racket/bool
racket/match
htdp/error)
(provide (all-defined-out)) (provide (all-defined-out))

18
collects/2htdp/private/clauses-spec-and-process.rkt
View File

@ -1,9 +1,9 @@
#lang racket #lang racket/base
;; --------------------------------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------------------------------
;; provides functions for specifying the shape of big-bang and universe clauses: ;; provides functions for specifying the shape of big-bang and universe clauses:
(provide function-with-arity expr-with-check except err) (provide function-with-arity expr-with-check err)
;; ... and for checking and processing them ;; ... and for checking and processing them
@ -12,9 +12,13 @@
->args ->args
contains-clause?) contains-clause?)
(require (require racket/function
(for-syntax syntax/parse) racket/list
(for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h)))) racket/bool
(for-syntax racket/base syntax/parse)
(for-template "clauses-spec-aux.rkt"
racket
(rename-in lang/prim (first-order->higher-order f2h))))
;; --------------------------------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------------------------------
;; specifying the shape of clauses ;; specifying the shape of clauses
@ -29,14 +33,14 @@
[_ (err tag p msg)])))])) [_ (err tag p msg)])))]))
(define-syntax function-with-arity (define-syntax function-with-arity
(syntax-rules (except) (syntax-rules ()
[(_ arity) [(_ arity)
(lambda (tag) (lambda (tag)
(lambda (p) (lambda (p)
(syntax-case p () (syntax-case p ()
[(_ x) #`(proc> #,tag (f2h x) arity)] [(_ x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))] [_ (err tag p)])))]
[(_ arity except extra ...) [(_ arity #:except extra ...)
(lambda (tag) (lambda (tag)
(lambda (p) (lambda (p)
(syntax-case p () (syntax-case p ()

2
collects/2htdp/private/clauses-spec-aux.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
;; --------------------------------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------------------------------
;; provides constants and functions for specifying the shape of clauses in big-bang and universe ;; provides constants and functions for specifying the shape of clauses in big-bang and universe

5
collects/2htdp/private/define-keywords.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
;; --------------------------------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------------------------------
;; provide a mechanism for defining the shape of big-bang and universe clauses ;; provide a mechanism for defining the shape of big-bang and universe clauses
@ -6,7 +6,8 @@
(provide define-keywords DEFAULT) (provide define-keywords DEFAULT)
(require (for-syntax syntax/parse)) (require racket/class
(for-syntax racket/base syntax/parse))
(define-syntax (DEFAULT stx) (define-syntax (DEFAULT stx)
(raise-syntax-error 'DEFAULT "used out of context" stx)) (raise-syntax-error 'DEFAULT "used out of context" stx))

2
collects/2htdp/private/design.txt
View File

@ -1,4 +1,3 @@
Files for constructing universe.rkt: Files for constructing universe.rkt:
world.rkt the old world world.rkt the old world
@ -14,4 +13,3 @@ Files for constructing universe.rkt:
image.rkt the world image functions image.rkt the world image functions
clauses-spec-and-process.rkt syntactic auxiliaries clauses-spec-and-process.rkt syntactic auxiliaries
clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries

5
collects/2htdp/private/launch-many-worlds.rkt
View File

@ -1,6 +1,7 @@
#lang racket #lang racket/base
(require mred/mred mzlib/etc htdp/error) (require racket/list racket/function racket/gui
mzlib/etc htdp/error)
(provide (provide
;; (launch-many-worlds e1 ... e2) ;; (launch-many-worlds e1 ... e2)

4
collects/2htdp/private/utilities.rkt
View File

@ -1,4 +1,6 @@
#lang racket #lang racket/base
(require racket/contract)
(provide/contract (provide/contract
;; like the unix debugging facility ;; like the unix debugging facility

4
collects/2htdp/uchat/chatter.rkt
View File

@ -88,11 +88,11 @@
;; World -> Scene ;; World -> Scene
;; render the world as a scene ;; render the world as a scene
(define (render w) (define (render w)
(local ((define fr (line*-render (world-from w))) (local [(define fr (line*-render (world-from w)))
(define t1 (line*-render (world-to w))) (define t1 (line*-render (world-to w)))
(define last-to-line (define last-to-line
(line-render-cursor (world-todraft w) (world-mmdraft w))) (line-render-cursor (world-todraft w) (world-mmdraft w)))
(define tt (image-stack t1 last-to-line))) (define tt (image-stack t1 last-to-line))]
(place-image fr 1 1 (place-image tt 1 MID MT)))) (place-image fr 1 1 (place-image tt 1 MID MT))))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------

6
collects/2htdp/universe.rkt
View File

@ -57,7 +57,7 @@
[on-tick DEFAULT #'#f [on-tick DEFAULT #'#f
(function-with-arity (function-with-arity
1 1
except #:except
[(_ f rate) [(_ f rate)
#'(list #'(list
(proc> 'on-tick (f2h f) 1) (proc> 'on-tick (f2h f) 1)
@ -84,7 +84,7 @@
[on-draw to-draw DEFAULT #'#f [on-draw to-draw DEFAULT #'#f
(function-with-arity (function-with-arity
1 1
except #:except
[(_ f width height) [(_ f width height)
#'(list (proc> 'to-draw (f2h f) 1) #'(list (proc> 'to-draw (f2h f) 1)
(nat> 'to-draw width "width") (nat> 'to-draw width "width")
@ -109,7 +109,7 @@
[stop-when DEFAULT #'False [stop-when DEFAULT #'False
(function-with-arity (function-with-arity
1 1
except #:except
[(_ stop? last-picture) [(_ stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1) #'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])] (proc> 'stop-when (f2h last-picture) 1))])]

15
collects/compiler/decompile.rkt
View File

@ -78,7 +78,20 @@
(let-values ([(n b) (module-path-index-split modidx)]) (let-values ([(n b) (module-path-index-split modidx)])
(and (not n) (not b)))) (and (not n) (not b))))
(string->symbol (format "_~a" sym)) (string->symbol (format "_~a" sym))
(string->symbol (format "_~s@~s~a" sym (mpi->string modidx) (string->symbol (format "_~s~a@~s~a"
sym
(match constantness
['constant ":c"]
['fixed ":f"]
[(function-shape a pm?)
(if pm? ":P" ":p")]
[(struct-type-shape c) ":t"]
[(constructor-shape a) ":mk"]
[(predicate-shape) ":?"]
[(accessor-shape c) ":ref"]
[(mutator-shape c) ":set!"]
[else ""])
(mpi->string modidx)
(if (zero? phase) (if (zero? phase)
"" ""
(format "/~a" phase)))))] (format "/~a" phase)))))]

5
collects/compiler/demodularizer/alpha.rkt
View File

@ -1,5 +1,6 @@
#lang racket #lang racket/base
(require compiler/zo-parse)
(require racket/match racket/contract compiler/zo-parse)
(define (alpha-vary-ctop top) (define (alpha-vary-ctop top)
(match top (match top

4
collects/compiler/demodularizer/batch.rkt
View File

@ -1,4 +1,5 @@
#lang racket #lang racket/base
#| #|
Here's the idea: Here's the idea:
@ -40,6 +41,7 @@ Here's the idea:
(require racket/pretty (require racket/pretty
racket/system racket/system
racket/cmdline
"mpi.rkt" "mpi.rkt"
"util.rkt" "util.rkt"
"nodep.rkt" "nodep.rkt"

16
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -1,5 +1,10 @@
#lang racket #lang racket/base
(require compiler/zo-parse
(require racket/match
racket/list
racket/dict
racket/contract
compiler/zo-parse
"util.rkt") "util.rkt")
; XXX Use efficient set structure ; XXX Use efficient set structure
@ -150,8 +155,7 @@
(match (dict-ref g n) (match (dict-ref g n)
[(struct refs (n-tls n-stxs)) [(struct refs (n-tls n-stxs))
(hash-set! visited? n #t) (hash-set! visited? n #t)
(local (define-values (new-tls1 new-stxs1)
[(define-values (new-tls1 new-stxs1)
(for/fold ([new-tls tls] (for/fold ([new-tls tls]
[new-stxs stxs]) [new-stxs stxs])
([tl (in-list n-tls)]) ([tl (in-list n-tls)])
@ -162,9 +166,9 @@
(define this-stx (visit-stx stx)) (define this-stx (visit-stx stx))
(if this-stx (if this-stx
(list* this-stx new-stxs) (list* this-stx new-stxs)
new-stxs)))] new-stxs)))
(values (list* n new-tls1) (values (list* n new-tls1)
new-stxs2))]))) new-stxs2)])))
(define stx-visited? (make-hasheq)) (define stx-visited? (make-hasheq))
(define (visit-stx n) (define (visit-stx n)
(if (hash-has-key? stx-visited? n) (if (hash-has-key? stx-visited? n)

14
collects/compiler/demodularizer/merge.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require compiler/zo-parse
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt" "util.rkt"
"mpi.rkt" "mpi.rkt"
"nodep.rkt" "nodep.rkt"
@ -156,12 +160,12 @@
(cond (cond
[(mod-lift-start . <= . n) [(mod-lift-start . <= . n)
; This is a lift ; This is a lift
(local [(define which-lift (- n mod-lift-start)) (define which-lift (- n mod-lift-start))
(define lift-tl (+ top-lift-start lift-offset which-lift))] (define lift-tl (+ top-lift-start lift-offset which-lift))
(when (lift-tl . >= . max-toplevel) (when (lift-tl . >= . max-toplevel)
(error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)"
name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
lift-tl)] lift-tl]
[else [else
(list-ref toplevel-remap n)])) (list-ref toplevel-remap n)]))
(lambda (n) (lambda (n)

8
collects/compiler/demodularizer/module.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require compiler/zo-parse
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt") "util.rkt")
(define (->module-path-index s) (define (->module-path-index s)

6
collects/compiler/demodularizer/mpi.rkt
View File

@ -1,5 +1,7 @@
#lang racket #lang racket/base
(require syntax/modresolve)
(require racket/contract
syntax/modresolve)
(define current-module-path (make-parameter #f)) (define current-module-path (make-parameter #f))

11
collects/compiler/demodularizer/nodep.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require compiler/zo-parse
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt" "util.rkt"
"mpi.rkt" "mpi.rkt"
racket/set) racket/set)
@ -92,7 +96,8 @@
(define (nodep-form form phase) (define (nodep-form form phase)
(if (mod? form) (if (mod? form)
(local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] (let-values ([(modvar-rewrite lang-info mods)
(nodep-module form phase)])
(values modvar-rewrite lang-info (make-splice mods))) (values modvar-rewrite lang-info (make-splice mods)))
(error 'nodep-form "Doesn't support non mod forms"))) (error 'nodep-form "Doesn't support non mod forms")))

8
collects/compiler/demodularizer/replace-modidx.rkt
View File

@ -1,6 +1,10 @@
#lang racket #lang racket/base
(require unstable/struct
(require racket/match
racket/vector
unstable/struct
"util.rkt") "util.rkt")
(provide replace-modidx) (provide replace-modidx)
(define (replace-modidx expr self-modidx) (define (replace-modidx expr self-modidx)

7
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -1,5 +1,8 @@
#lang racket #lang racket/base
(require compiler/zo-structs
(require racket/match
racket/contract
compiler/zo-structs
"util.rkt") "util.rkt")
(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)

6
collects/compiler/demodularizer/util.rkt
View File

@ -1,5 +1,7 @@
#lang racket #lang racket/base
(require compiler/zo-parse)
(require racket/contract
compiler/zo-parse)
(define (prefix-syntax-start pre) (define (prefix-syntax-start pre)
(length (prefix-toplevels pre))) (length (prefix-toplevels pre)))

1
collects/compiler/embed.rkt
View File

@ -63,4 +63,3 @@
embedding-executable-is-actually-directory? embedding-executable-is-actually-directory?
embedding-executable-put-file-extension+style+filters embedding-executable-put-file-extension+style+filters
embedding-executable-add-suffix) embedding-executable-add-suffix)

42
collects/compiler/zo-marshal.rkt
View File

@ -604,13 +604,51 @@
[(? void?) [(? void?)
(out-byte CPT_VOID out)] (out-byte CPT_VOID out)]
[(struct module-variable (modidx sym pos phase constantness)) [(struct module-variable (modidx sym pos phase constantness))
(define (to-sym n) (string->symbol (format "struct~a" n)))
(out-byte CPT_MODULE_VAR out) (out-byte CPT_MODULE_VAR out)
(out-anything modidx out) (out-anything modidx out)
(out-anything sym out) (out-anything sym out)
(out-anything (cond
[(function-shape? constantness)
(let ([a (function-shape-arity constantness)])
(cond
[(arity-at-least? a)
(bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1)
(if (function-shape-preserves-marks? constantness) 1 0))]
[(list? a)
(string->symbol (apply
string-append
(add-between
(for/list ([a (in-list a)])
(define n (if (arity-at-least? a)
(- (add1 (arity-at-least-value a)))
a))
(number->string n))
":")))]
[else
(bitwise-ior (arithmetic-shift a 1)
(if (function-shape-preserves-marks? constantness) 1 0))]))]
[(struct-type-shape? constantness)
(to-sym (arithmetic-shift (struct-type-shape-field-count constantness)
4))]
[(constructor-shape? constantness)
(to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness)
4)))]
[(predicate-shape? constantness) (to-sym 2)]
[(accessor-shape? constantness)
(to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness)
4)))]
[(mutator-shape? constantness)
(to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
4)))]
[(struct-other-shape? constantness)
(to-sym 5)]
[else #f])
out)
(case constantness (case constantness
[(constant) (out-number -4 out)] [(#f) (void)]
[(fixed) (out-number -5 out)] [(fixed) (out-number -5 out)]
[else (void)]) [else (out-number -4 out)])
(unless (zero? phase) (unless (zero? phase)
(out-number -2 out) (out-number -2 out)
(out-number phase out)) (out-number phase out))

28
collects/compiler/zo-parse.rkt
View File

@ -856,6 +856,7 @@
[(module-var) [(module-var)
(let ([mod (read-compact cp)] (let ([mod (read-compact cp)]
[var (read-compact cp)] [var (read-compact cp)]
[shape (read-compact cp)]
[pos (read-compact-number cp)]) [pos (read-compact-number cp)])
(let-values ([(flags mod-phase pos) (let-values ([(flags mod-phase pos)
(let loop ([pos pos]) (let loop ([pos pos])
@ -869,6 +870,33 @@
[else (values 0 0 pos)]))]) [else (values 0 0 pos)]))])
(make-module-variable mod var pos mod-phase (make-module-variable mod var pos mod-phase
(cond (cond
[shape
(cond
[(number? shape)
(define n (arithmetic-shift shape -1))
(make-function-shape (if (negative? n)
(make-arity-at-least (sub1 (- n)))
n)
(odd? shape))]
[(and (symbol? shape)
(regexp-match? #rx"^struct" (symbol->string shape)))
(define n (string->number (substring (symbol->string shape) 6)))
(case (bitwise-and n #x7)
[(0) (make-struct-type-shape (arithmetic-shift n -3))]
[(1) (make-constructor-shape (arithmetic-shift n -3))]
[(2) (make-predicate-shape)]
[(3) (make-accessor-shape (arithmetic-shift n -3))]
[(4) (make-mutator-shape (arithmetic-shift n -3))]
[else (make-struct-other-shape)])]
[else
;; parse symbol as ":"-separated sequence of arities
(make-function-shape
(for/list ([s (regexp-split #rx":" (symbol->string shape))])
(define i (string->number s))
(if (negative? i)
(make-arity-at-least (sub1 (- i)))
i))
#f)])]
[(not (zero? (bitwise-and #x1 flags))) 'constant] [(not (zero? (bitwise-and #x1 flags))) 'constant]
[(not (zero? (bitwise-and #x2 flags))) 'fixed] [(not (zero? (bitwise-and #x2 flags))) 'fixed]
[else #f]))))] [else #f]))))]

15
collects/compiler/zo-structs.rkt
View File

@ -38,13 +38,26 @@
[(_ id . rest) [(_ id . rest)
(define-form-struct* id (id zo) . rest)])) (define-form-struct* id (id zo) . rest)]))
(define-form-struct function-shape ([arity procedure-arity?]
[preserves-marks? boolean?]))
(define-form-struct struct-shape ())
(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ())
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-other-shape struct-shape) ())
;; In toplevels of resove prefix: ;; In toplevels of resove prefix:
(define-form-struct global-bucket ([name symbol?])) ; top-level binding (define-form-struct global-bucket ([name symbol?])) ; top-level binding
(define-form-struct module-variable ([modidx module-path-index?] (define-form-struct module-variable ([modidx module-path-index?]
[sym symbol?] [sym symbol?]
[pos exact-integer?] [pos exact-integer?]
[phase exact-nonnegative-integer?] [phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed)])) [constantness (or/c #f 'constant 'fixed
function-shape?
struct-shape?)]))
;; Syntax object ;; Syntax object
(define ((alist/c k? v?) l) (define ((alist/c k? v?) l)

12
collects/data/heap.rkt
View File

@ -160,13 +160,14 @@
(in-heap/consume! (heap-copy h))) (in-heap/consume! (heap-copy h)))
(define (in-heap/consume! h) (define (in-heap/consume! h)
(make-do-sequence
(lambda () (lambda ()
(values (lambda () (heap-min h)) (values (lambda (_) (heap-min h))
(lambda () (heap-remove-min! h) #t) (lambda (_) (heap-remove-min! h) #t)
#t #t
(lambda (_) (> (heap-count h) 0)) (lambda (_) (> (heap-count h) 0))
(lambda _ #t) (lambda _ #t)
(lambda _ #t)))) (lambda _ #t)))))
;; -------- ;; --------
@ -204,4 +205,7 @@
[heap->vector (-> heap? vector?)] [heap->vector (-> heap? vector?)]
[heap-copy (-> heap? heap?)] [heap-copy (-> heap? heap?)]
[heap-sort! (-> procedure? vector? void?)]) [heap-sort! (-> procedure? vector? void?)]
[in-heap (-> heap? sequence?)]
[in-heap/consume! (-> heap? sequence?)])

1
collects/data/order.rkt
View File

@ -16,6 +16,7 @@
;; generated hidden property. ;; generated hidden property.
(define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict? (define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict?
#:defined-table dict-def-table #:defined-table dict-def-table
#:defaults ()
;; private version needs all kw args, in order ;; private version needs all kw args, in order
#:prop-defined-already? #f #:prop-defined-already? #f
#:define-contract #f) #:define-contract #f)

3
collects/data/scribblings/gvector.scrbl
View File

@ -123,3 +123,6 @@ Unlike @racket[for/list], the @racket[body] may return zero or
multiple values; all returned values are added to the gvector, in multiple values; all returned values are added to the gvector, in
order, on each iteration. order, on each iteration.
} }
@close-eval[the-eval]

116
collects/data/scribblings/heap.scrbl
View File

@ -19,62 +19,176 @@ Binary heaps are a simple implementation of priority queues.
heap?]{ heap?]{
Makes a new empty heap using @racket[<=?] to order elements. Makes a new empty heap using @racket[<=?] to order elements.
@examples[#:eval the-eval
(define a-heap-of-strings (make-heap string<=?))
a-heap-of-strings
@code:comment{With structs:}
(struct node (name val))
(define (node<=? x y)
(<= (node-val x) (node-val y)))
(define a-heap-of-nodes (make-heap node<=?))
a-heap-of-nodes]
} }
@defproc[(heap? [x any/c]) boolean?]{ @defproc[(heap? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise. Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise.
@examples[#:eval the-eval
(heap? (make-heap <=))
(heap? "I am not a heap")]
} }
@defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{ @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{
Returns the number of elements in the heap. Returns the number of elements in the heap.
@examples[#:eval the-eval
(define a-heap (make-heap <=))
(heap-add-all! a-heap '(7 3 9 1 13 21 15 31))
(heap-count a-heap)
]
} }
@defproc[(heap-add! [h heap?] [v any/c] ...) void?]{ @defproc[(heap-add! [h heap?] [v any/c] ...) void?]{
Adds each @racket[v] to the heap. Adds each @racket[v] to the heap.
@examples[#:eval the-eval
(define a-heap (make-heap <=))
(heap-add! a-heap 2009 1009)]
} }
@defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{ @defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{
Adds each element contained in @racket[v] to the heap, leaving Adds each element contained in @racket[v] to the heap, leaving
@racket[v] unchanged. @racket[v] unchanged.
@examples[#:eval the-eval
(define heap-1 (make-heap <=))
(define heap-2 (make-heap <=))
(define heap-12 (make-heap <=))
(heap-add-all! heap-1 '(3 1 4 1 5 9 2 6))
(heap-add-all! heap-2 #(2 7 1 8 2 8 1 8))
(heap-add-all! heap-12 heap-1)
(heap-add-all! heap-12 heap-2)
(heap-count heap-12)]
} }
@defproc[(heap-min [h heap?]) any/c]{ @defproc[(heap-min [h heap?]) any/c]{
Returns the least element in the heap @racket[h], according to the Returns the least element in the heap @racket[h], according to the
heap's ordering. If the heap is empty, an exception is raised. heap's ordering. If the heap is empty, an exception is raised.
@examples[#:eval the-eval
(define a-heap (make-heap string<=?))
(heap-add! a-heap "sneezy" "sleepy" "dopey" "doc"
"happy" "bashful" "grumpy")
(heap-min a-heap)
@code:comment{Taking the min of the empty heap is an error:}
(heap-min (make-heap <=))
]
} }
@defproc[(heap-remove-min! [h heap?]) void?]{ @defproc[(heap-remove-min! [h heap?]) void?]{
Removes the least element in the heap @racket[h]. If the heap is Removes the least element in the heap @racket[h]. If the heap is
empty, an exception is raised. empty, an exception is raised.
@examples[#:eval the-eval
(define a-heap (make-heap string<=?))
(heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin"
"dwalin" "balin" "bifur" "bofur"
"bombur" "dori" "nori" "ori")
(heap-min a-heap)
(heap-remove-min! a-heap)
(heap-min a-heap)]
} }
@defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{ @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{
Builds a heap with the elements from @racket[items]. The vector is not Builds a heap with the elements from @racket[items]. The vector is not
modified. modified.
@examples[#:eval the-eval
(struct item (val frequency))
(define (item<=? x y)
(<= (item-frequency x) (item-frequency y)))
(define some-sample-items
(vector (item #\a 17) (item #\b 12) (item #\c 19)))
(define a-heap (vector->heap item<=? some-sample-items))
]
} }
@defproc[(heap->vector [h heap?]) vector?]{ @defproc[(heap->vector [h heap?]) vector?]{
Returns a vector containing the elements of heap @racket[h] in the Returns a vector containing the elements of heap @racket[h] in the
heap's order. The heap is not modified. heap's order. The heap is not modified.
@examples[#:eval the-eval
(define word-heap (make-heap string<=?))
(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation")
(heap->vector word-heap)
]
} }
@defproc[(heap-copy [h heap?]) heap?]{ @defproc[(heap-copy [h heap?]) heap?]{
Makes a copy of heap @racket[h]. Makes a copy of heap @racket[h].
@examples[#:eval the-eval
(define word-heap (make-heap string<=?))
(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation")
(define a-copy (heap-copy word-heap))
(heap-remove-min! a-copy)
(heap-count word-heap)
(heap-count a-copy)
]
} }
@;{--------} @;{--------}
@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v vector?]) void?]{ @defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v (and/c vector? (not/c immutable?))]) void?]{
Sorts vector @racket[v] using the comparison function @racket[<=?]. Sorts vector @racket[v] using the comparison function @racket[<=?].
@examples[#:eval the-eval
(define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot"))
(heap-sort! string<=? terms)
terms
]
} }
@defproc[(in-heap/consume! [heap heap?]) sequence?]{
Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering.
The heap is consumed in the process. Equivalent to repeated calling
@racket[heap-min], then @racket[heap-remove-min!].
@examples[#:eval the-eval
(define h (make-heap <=))
(heap-add-all! h '(50 40 10 20 30))
(for ([x (in-heap/consume! h)])
(displayln x))
(heap-count h)]
}
@defproc[(in-heap [heap heap?]) sequence?]{
Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering.
Equivalent to @racket[in-heap/consume!] except the heap is copied first.
@examples[#:eval the-eval
(define h (make-heap <=))
(heap-add-all! h '(50 40 10 20 30))
(for ([x (in-heap h)])
(displayln x))
(heap-count h)]
}
@close-eval[the-eval]

3
collects/data/scribblings/integer-set.scrbl
View File

@ -151,3 +151,6 @@ Returns the number of integers in the given integer set.}
Returns true if every integer in @racket[x] is also in Returns true if every integer in @racket[x] is also in
@racket[y], otherwise @racket[#f].} @racket[y], otherwise @racket[#f].}
@close-eval[the-eval]

3
collects/data/scribblings/interval-map.scrbl
View File

@ -167,3 +167,6 @@ Implementations of @racket[dict-iterate-first],
Returns @racket[#t] if @racket[v] represents a position in an Returns @racket[#t] if @racket[v] represents a position in an
interval-map, @racket[#f] otherwise. interval-map, @racket[#f] otherwise.
} }
@close-eval[the-eval]

3
collects/data/scribblings/order.scrbl
View File

@ -251,3 +251,6 @@ a single execution of a program:
(datum-order (make-fish 'alewife) (make-fowl 'dodo)) (datum-order (make-fish 'alewife) (make-fowl 'dodo))
] ]
} }
@close-eval[the-eval]

3
collects/data/scribblings/queue.scrbl
View File

@ -94,3 +94,6 @@ Returns a sequence whose elements are the elements of
These contracts recognize queues; the latter requires the queue to These contracts recognize queues; the latter requires the queue to
contain at least one value. contain at least one value.
} }
@close-eval[qeval]

3
collects/data/scribblings/skip-list.scrbl
View File

@ -171,3 +171,6 @@ skip-list, @racket[#f] otherwise.
Returns an association list with the keys and values of Returns an association list with the keys and values of
@racket[skip-list], in order. @racket[skip-list], in order.
} }
@close-eval[the-eval]

3
collects/data/scribblings/splay-tree.scrbl
View File

@ -174,3 +174,6 @@ splay-tree, @racket[#f] otherwise.
Returns an association list with the keys and values of @racket[s], in Returns an association list with the keys and values of @racket[s], in
order. order.
} }
@close-eval[the-eval]

9
collects/db/private/odbc/connection.rkt
View File

@ -656,7 +656,14 @@
#:on-notice add-notice!))) #:on-notice add-notice!)))
(super-new) (super-new)
(register-finalizer this (lambda (obj) (send obj disconnect))))) (register-finalizer this
(lambda (obj)
;; Keep a reference to the class to keep all FFI callout objects
;; (eg, SQLDisconnect) used by its methods from being finalized.
(let ([dont-gc this%])
(send obj disconnect)
;; Dummy result to prevent reference from being optimized away
dont-gc)))))
;; ---------------------------------------- ;; ----------------------------------------

13
collects/db/private/sqlite3/connection.rkt
View File

@ -206,7 +206,7 @@
(let loop () (let loop ()
(let ([stmt (sqlite3_next_stmt db #f)]) (let ([stmt (sqlite3_next_stmt db #f)])
(when stmt (when stmt
(HANDLE 'disconnect (sqlite3_finalize stmt)) (sqlite3_finalize stmt)
(loop)))) (loop))))
(HANDLE 'disconnect (sqlite3_close db)) (HANDLE 'disconnect (sqlite3_close db))
(void)))))) (void))))))
@ -225,7 +225,7 @@
(let ([stmt (send pst get-handle)]) (let ([stmt (send pst get-handle)])
(send pst set-handle #f) (send pst set-handle #f)
(when (and stmt -db) (when (and stmt -db)
(HANDLE fsym (sqlite3_finalize stmt))) (sqlite3_finalize stmt))
(void))))) (void)))))
;; Internal query ;; Internal query
@ -316,7 +316,14 @@
;; ---- ;; ----
(super-new) (super-new)
(register-finalizer this (lambda (obj) (send obj disconnect))))) (register-finalizer this
(lambda (obj)
;; Keep a reference to the class to keep all FFI callout objects
;; (eg, sqlite3_close) used by its methods from being finalized.
(let ([dont-gc this%])
(send obj disconnect)
;; Dummy result to prevent reference from being optimized away
dont-gc)))))
;; ---------------------------------------- ;; ----------------------------------------

5
collects/db/private/sqlite3/ffi.rkt
View File

@ -58,7 +58,10 @@
(define-sqlite sqlite3_finalize (define-sqlite sqlite3_finalize
(_fun _sqlite3_statement (_fun _sqlite3_statement
-> _int)) -> _int
;; sqlite3_finalize returns error code of last stmt execution,
;; not of finalization; so just ignore
-> (void)))
(define-sqlite sqlite3_bind_parameter_count (define-sqlite sqlite3_bind_parameter_count
(_fun _sqlite3_statement (_fun _sqlite3_statement

5
collects/drracket/private/app.rkt
View File

@ -187,11 +187,6 @@
(insert ".\n\nBased on:\n ") (insert ".\n\nBased on:\n ")
(insert (banner))) (insert (banner)))
(when (or (eq? (system-type) 'macos)
(eq? (system-type) 'macosx))
(send* e
(insert " The A List (c) 1997-2001 Kyle Hammond\n")))
(let ([tools (sort (drracket:tools:get-successful-tools) (let ([tools (sort (drracket:tools:get-successful-tools)
(lambda (a b) (lambda (a b)
(string<? (path->string (drracket:tools:successful-tool-spec a)) (string<? (path->string (drracket:tools:successful-tool-spec a))

11
collects/drracket/private/colored-errors.rkt
View File

@ -1,13 +1,18 @@
#lang racket #lang racket/base
(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework (require (for-syntax racket/base)
(require ; gmarceau/test racket/list
racket/string
racket/contract
racket/match
parser-tools/lex parser-tools/lex
(prefix-in : parser-tools/lex-sre) (prefix-in : parser-tools/lex-sre)
(rename-in srfi/26 [cut //]) (rename-in srfi/26 [cut //])
(only-in srfi/1 break) (only-in srfi/1 break)
unstable/contract) unstable/contract)
(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework
;; An error message has many fragments. The fragments will be concatenated ;; An error message has many fragments. The fragments will be concatenated
;; before being presented to the user. Some fragment are simply string. ;; before being presented to the user. Some fragment are simply string.
(struct msg-fragment:str (str) #:transparent) (struct msg-fragment:str (str) #:transparent)

33
collects/drracket/private/drracket-normal.rkt
View File

@ -15,7 +15,8 @@
(define files-to-open (command-line #:args filenames filenames)) (define files-to-open (command-line #:args filenames filenames))
(define the-date (seconds->date (define startup-date
(seconds->date
(let ([ssec (getenv "PLTDREASTERSECONDS")]) (let ([ssec (getenv "PLTDREASTERSECONDS")])
(if ssec (if ssec
(string->number ssec) (string->number ssec)
@ -25,24 +26,24 @@
;; to open. See also main.rkt. ;; to open. See also main.rkt.
(current-command-line-arguments (apply vector files-to-open)) (current-command-line-arguments (apply vector files-to-open))
(define (currently-the-weekend?) (define (weekend-date? date)
(define dow (date-week-day the-date)) (define dow (date-week-day date))
(or (= dow 6) (= dow 0))) (or (= dow 6) (= dow 0)))
(define (valentines-day?) (define (valentines-date? date)
(and (= 2 (date-month the-date)) (and (= 2 (date-month date))
(= 14 (date-day the-date)))) (= 14 (date-day date))))
(define (current-icon-state) (define (icon-state date)
(cond (cond
[(valentines-day?) 'valentines] [(valentines-date? date) 'valentines]
[(currently-the-weekend?) 'weekend] [(weekend-date? date) 'weekend]
[else 'normal])) [else 'normal]))
(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?)
(let* ([month (date-month the-date)] (let* ([month (date-month startup-date)]
[day (date-day the-date)] [day (date-day startup-date)]
[dow (date-week-day the-date)]) [dow (date-week-day startup-date)])
(values (and (= 3 month) (= 2 day)) (values (and (= 3 month) (= 2 day))
(and (= 3 month) (= 26 day)) (and (= 3 month) (= 26 day))
(and (= 6 month) (= 11 day)) (and (= 6 month) (= 11 day))
@ -119,7 +120,7 @@
(define the-bitmap-spec (define the-bitmap-spec
(cond (cond
[(valentines-day?) [(valentines-date? startup-date)
valentines-days-spec] valentines-days-spec]
[(or prince-kuhio-day? kamehameha-day?) [(or prince-kuhio-day? kamehameha-day?)
(set-splash-progress-bar?! #f) (set-splash-progress-bar?! #f)
@ -131,7 +132,7 @@
(collection-file-path "texas-plt-bw.gif" "icons")] (collection-file-path "texas-plt-bw.gif" "icons")]
[halloween? [halloween?
(collection-file-path "PLT-pumpkin.png" "icons")] (collection-file-path "PLT-pumpkin.png" "icons")]
[(currently-the-weekend?) [(weekend-date? startup-date)
weekend-bitmap-spec] weekend-bitmap-spec]
[else normal-bitmap-spec])) [else normal-bitmap-spec]))
@ -139,7 +140,7 @@
(set-splash-char-observer drracket-splash-char-observer) (set-splash-char-observer drracket-splash-char-observer)
(when (eq? (system-type) 'macosx) (when (eq? (system-type) 'macosx)
(define initial-state (current-icon-state)) (define initial-state (icon-state startup-date))
(define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec) (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec)
the-splash-bitmap the-splash-bitmap
#f)) #f))
@ -167,7 +168,7 @@
(λ () (λ ()
(let loop ([last-state initial-state]) (let loop ([last-state initial-state])
(sleep 10) (sleep 10)
(define next-state (current-icon-state)) (define next-state (icon-state (seconds->date (current-seconds))))
(unless (equal? last-state next-state) (unless (equal? last-state next-state)
(set-icon next-state)) (set-icon next-state))
(loop next-state)))))) (loop next-state))))))

19
collects/drracket/private/get-extend.rkt
View File

@ -1,7 +1,8 @@
#lang racket/unit #lang racket/unit
(require racket/class (require racket/class
"drsig.rkt") "drsig.rkt"
framework/private/logging-timer)
(import [prefix drracket:unit: drracket:unit^] (import [prefix drracket:unit: drracket:unit^]
[prefix drracket:frame: drracket:frame^] [prefix drracket:frame: drracket:frame^]
@ -13,7 +14,7 @@
(export drracket:get/extend^) (export drracket:get/extend^)
(define make-extender (define make-extender
(λ (get-base% name) (λ (get-base% name [final-mixin values])
(let ([extensions (λ (x) x)] (let ([extensions (λ (x) x)]
[built-yet? #f] [built-yet? #f]
[built #f] [built #f]
@ -42,7 +43,7 @@
(λ () (λ ()
(unless built-yet? (unless built-yet?
(set! built-yet? #t) (set! built-yet? #t)
(set! built (extensions (get-base%)))) (set! built (final-mixin (extensions (get-base%)))))
built))))) built)))))
(define (get-base-tab%) (define (get-base-tab%)
@ -93,4 +94,14 @@
(drracket:unit:get-definitions-text%))))))) (drracket:unit:get-definitions-text%)))))))
(define-values (extend-definitions-text get-definitions-text) (define-values (extend-definitions-text get-definitions-text)
(make-extender get-base-definitions-text% 'definitions-text%)) (make-extender get-base-definitions-text%
'definitions-text%
(let ([add-on-paint-logging
(λ (%)
(class %
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(log-timeline
(format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top)))
(super on-paint before? dc left top right bottom dx dy draw-caret)))
(super-new)))])
add-on-paint-logging)))

10
collects/drracket/private/insert-large-letters.rkt
View File

@ -7,7 +7,7 @@
(define-type-alias Bitmap-Message% (Class () (define-type-alias Bitmap-Message% (Class ()
([parent Any]) ([parent (Instance Horizontal-Panel%)])
([set-bm ((Instance Bitmap%) -> Void)]))) ([set-bm ((Instance Bitmap%) -> Void)])))
@ -16,7 +16,7 @@
(provide insert-large-letters) (provide insert-large-letters)
(: insert-large-letters (String Char (Instance Racket:Text%) Any -> Void)) (: insert-large-letters (String Char (Instance Text:Basic%) Any -> Void))
(define (insert-large-letters comment-prefix comment-character edit parent) (define (insert-large-letters comment-prefix comment-character edit parent)
(let ([str (make-large-letters-dialog comment-prefix comment-character #f)]) (let ([str (make-large-letters-dialog comment-prefix comment-character #f)])
(when (and str (when (and str
@ -90,7 +90,7 @@
(: pane2 (Instance Horizontal-Pane%)) (: pane2 (Instance Horizontal-Pane%))
(define pane2 (new horizontal-pane% (parent info-bar))) (define pane2 (new horizontal-pane% (parent info-bar)))
(: txt (Instance Racket:Text%)) (: txt (Instance Text:Basic%))
(define txt (new racket:text%)) (define txt (new racket:text%))
(: ec (Instance Editor-Canvas%)) (: ec (Instance Editor-Canvas%))
(define ec (new editor-canvas% [parent dlg] [editor txt])) (define ec (new editor-canvas% [parent dlg] [editor txt]))
@ -145,7 +145,7 @@
(format " (~a)" (floor (inexact->exact w)))))) (format " (~a)" (floor (inexact->exact w))))))
(: get-max-line-width ((Instance Racket:Text%) -> Real)) (: get-max-line-width ((Instance Text:Basic%) -> Real))
(define (get-max-line-width txt) (define (get-max-line-width txt)
(let loop ([i (+ (send txt last-paragraph) 1)] (let loop ([i (+ (send txt last-paragraph) 1)]
[#{m : Integer} 0]) [#{m : Integer} 0])
@ -156,7 +156,7 @@
(send txt paragraph-start-position (- i 1)))))]))) (send txt paragraph-start-position (- i 1)))))])))
(: render-large-letters (String Char (Instance Font%) String (Instance Racket:Text%) -> (Instance Bitmap%))) (: render-large-letters (String Char (Instance Font%) String (Instance Text:Basic%) -> (Instance Bitmap%)))
(define (render-large-letters comment-prefix comment-character the-font str edit) (define (render-large-letters comment-prefix comment-character the-font str edit)
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))) (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
(define-values (tw raw-th td ta) (send bdc get-text-extent str the-font)) (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font))

450
collects/drracket/private/language-configuration.rkt
View File

@ -11,13 +11,17 @@
string-constants string-constants
framework framework
setup/getinfo setup/getinfo
setup/xref
scribble/xref
net/url
syntax/toplevel syntax/toplevel
browser/external
(only-in mzlib/struct make-->vector)) (only-in mzlib/struct make-->vector))
(define original-output (current-output-port)) (define original-output (current-output-port))
(define (oprintf . args) (apply fprintf original-output args)) (define (oprintf . args) (apply fprintf original-output args))
(define-values (sc-use-language-in-source sc-choose-a-language mouse-event-uses-shortcut-prefix?) (define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?)
(let* ([shortcut-prefix (get-default-shortcut-prefix)] (let* ([shortcut-prefix (get-default-shortcut-prefix)]
[menukey-string [menukey-string
(apply string-append (apply string-append
@ -38,14 +42,14 @@
[(shift) (send evt get-shiftdown)] [(shift) (send evt get-shiftdown)]
[(option) (send evt get-alt-down)])) [(option) (send evt get-alt-down)]))
shortcut-prefix)) shortcut-prefix))
(values (string-append (string-constant use-language-in-source) (values (string-append (string-constant the-racket-language)
(format " (~aU)" menukey-string)) (format " (~aR)" menukey-string))
(string-append (string-constant choose-a-language) (string-append (string-constant teaching-languages)
(format " (~aC)" menukey-string)) (format " (~aT)" menukey-string))
(string-append (string-constant other-languages)
(format " (~aO)" menukey-string))
mouse-event-uses-shortcut-prefix?))) mouse-event-uses-shortcut-prefix?)))
(define sc-lang-in-source-discussion (string-constant lang-in-source-discussion))
(provide language-configuration@) (provide language-configuration@)
(define-unit language-configuration@ (define-unit language-configuration@
@ -56,7 +60,8 @@
[prefix drracket:app: drracket:app^] [prefix drracket:app: drracket:app^]
[prefix drracket:tools: drracket:tools^] [prefix drracket:tools: drracket:tools^]
[prefix drracket:help-desk: drracket:help-desk^] [prefix drracket:help-desk: drracket:help-desk^]
[prefix drracket:module-language: drracket:module-language/int^]) [prefix drracket:module-language: drracket:module-language/int^]
[prefix drracket: drracket:interface^])
(export drracket:language-configuration/internal^) (export drracket:language-configuration/internal^)
;; settings-preferences-symbol : symbol ;; settings-preferences-symbol : symbol
@ -242,7 +247,9 @@
button-panel button-panel
language-settings-to-show language-settings-to-show
#f #f
ok-handler)) ok-handler
(and (is-a? parent drracket:unit:frame<%>)
(send parent get-definitions-text))))
;; create ok/cancel buttons ;; create ok/cancel buttons
(make-object horizontal-pane% button-panel) (make-object horizontal-pane% button-panel)
@ -257,7 +264,7 @@
(add-welcome dialog welcome-before-panel welcome-after-panel)) (add-welcome dialog welcome-before-panel welcome-after-panel))
(send dialog stretchable-width #f) (send dialog stretchable-width #f)
(send dialog stretchable-height #t) (send dialog stretchable-height #f)
(unless parent (unless parent
(send dialog center 'both)) (send dialog center 'both))
@ -277,7 +284,8 @@
(define fill-language-dialog (define fill-language-dialog
(λ (parent show-details-parent language-settings-to-show (λ (parent show-details-parent language-settings-to-show
[re-center #f] [re-center #f]
[ok-handler void]) ; en/disable button, execute it [ok-handler void]
[definitions-text #f]) ; en/disable button, execute it
(define-values (language-to-show settings-to-show) (define-values (language-to-show settings-to-show)
(let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
@ -376,9 +384,13 @@
(cond (cond
[(and i (is-a? i hieritem-language<%>)) [(and i (is-a? i hieritem-language<%>))
(define pos (send (send i get-language) get-language-position)) (define pos (send (send i get-language) get-language-position))
(preferences:set 'drracket:language-dialog:hierlist-default pos) (if (eq? this teaching-languages-hier-list)
(set! most-recent-languages-hier-list-selection pos) (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos)
(something-selected i)] (preferences:set 'drracket:language-dialog:hierlist-default pos))
(if (eq? this teaching-languages-hier-list)
(set! most-recent-teaching-languages-hier-list-selection pos)
(set! most-recent-languages-hier-list-selection pos))
(something-selected this i)]
[else [else
(non-language-selected)])) (non-language-selected)]))
;; this is used only because we set `on-click-always' ;; this is used only because we set `on-click-always'
@ -388,7 +400,7 @@
;; double-click selects a language ;; double-click selects a language
(define/override (on-double-select i) (define/override (on-double-select i)
(when (and i (is-a? i hieritem-language<%>)) (when (and i (is-a? i hieritem-language<%>))
(something-selected i) (something-selected this i)
(ok-handler 'execute))) (ok-handler 'execute)))
(super-new [parent parent]) (super-new [parent parent])
;; do this so we can expand/collapse languages on a single click ;; do this so we can expand/collapse languages on a single click
@ -396,9 +408,12 @@
(on-click-always #t) (on-click-always #t)
(allow-deselect #t))) (allow-deselect #t)))
(define outermost-panel (new horizontal-pane% [parent parent])) (define outermost-panel (new horizontal-panel%
[parent parent]
[alignment '(left top)]))
(define languages-choice-panel (new vertical-panel% (define languages-choice-panel (new vertical-panel%
[parent outermost-panel] [parent outermost-panel]
[stretchable-height #f]
[alignment '(left top)])) [alignment '(left top)]))
(define use-language-in-source-rb (define use-language-in-source-rb
@ -411,7 +426,8 @@
(use-language-in-source-rb-callback))])) (use-language-in-source-rb-callback))]))
(define (use-language-in-source-rb-callback) (define (use-language-in-source-rb-callback)
(module-language-selected) (module-language-selected)
(send use-chosen-language-rb set-selection #f)) (send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f))
(define in-source-discussion-panel (new horizontal-panel% (define in-source-discussion-panel (new horizontal-panel%
[parent languages-choice-panel] [parent languages-choice-panel]
[stretchable-height #f])) [stretchable-height #f]))
@ -419,8 +435,41 @@
[parent in-source-discussion-panel] [parent in-source-discussion-panel]
[stretchable-width #f] [stretchable-width #f]
[min-width 32])) [min-width 32]))
(define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback))
(define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default))
(define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default))
(define use-teaching-language-rb
(new radio-box%
[label #f]
[choices (list sc-use-teaching-language)]
[parent languages-choice-panel]
[callback
(λ (rb evt)
(use-teaching-language-rb-callback))]))
(define (use-teaching-language-rb-callback)
(when most-recent-teaching-languages-hier-list-selection
(select-a-language-in-hierlist teaching-languages-hier-list
(cdr most-recent-teaching-languages-hier-list-selection)))
(send use-chosen-language-rb set-selection #f)
(send use-language-in-source-rb set-selection #f)
(send use-teaching-language-rb set-selection 0)
(send other-languages-hier-list select #f)
(send teaching-languages-hier-list focus))
(define teaching-languages-hier-list-panel
(new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f]))
(define teaching-languages-hier-list-spacer
(new horizontal-panel%
[parent teaching-languages-hier-list-panel]
[stretchable-width #f]
[min-width 16]))
(define teaching-languages-hier-list
(new selectable-hierlist%
[parent teaching-languages-hier-list-panel]
[style '(no-border no-hscroll auto-vscroll transparent)]))
(define use-chosen-language-rb (define use-chosen-language-rb
(new radio-box% (new radio-box%
[label #f] [label #f]
@ -430,17 +479,52 @@
(λ (this-rb evt) (λ (this-rb evt)
(use-chosen-language-rb-callback))])) (use-chosen-language-rb-callback))]))
(define (use-chosen-language-rb-callback) (define (use-chosen-language-rb-callback)
(show-other-languages)
(when most-recent-languages-hier-list-selection (when most-recent-languages-hier-list-selection
(select-a-language-in-hierlist most-recent-languages-hier-list-selection)) (select-a-language-in-hierlist other-languages-hier-list
most-recent-languages-hier-list-selection))
(send use-language-in-source-rb set-selection #f) (send use-language-in-source-rb set-selection #f)
(send languages-hier-list focus)) (send use-teaching-language-rb set-selection #f)
(define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) (send teaching-languages-hier-list select #f)
(send other-languages-hier-list focus))
(define (show-other-languages)
(when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children))
(send languages-hier-list-panel change-children
(λ (l)
(list languages-hier-list-spacer other-languages-hier-list)))))
(define languages-hier-list-panel (new horizontal-panel%
[parent languages-choice-panel]
[stretchable-height #f]))
(define ellipsis-spacer-panel (new horizontal-panel%
[parent languages-hier-list-panel]
[stretchable-width #f]
[min-width 32]))
(define ellipsis-message (new (class canvas%
(define/override (on-paint)
(define dc (get-dc))
(send dc set-font normal-control-font)
(send dc draw-text "..." 0 0))
(define/override (on-event evt)
(when (send evt button-up?)
(show-other-languages)))
(inherit get-dc min-width min-height)
(super-new [style '(transparent)]
[parent languages-hier-list-panel]
[stretchable-width #f]
[stretchable-height #t])
(let ()
(define dc (get-dc))
(define-values (w h _1 _2) (send dc get-text-extent "..." normal-control-font))
(min-width (inexact->exact (ceiling w)))
(min-height (inexact->exact (ceiling h)))))))
(define languages-hier-list-spacer (new horizontal-panel% (define languages-hier-list-spacer (new horizontal-panel%
[parent languages-hier-list-panel] [parent languages-hier-list-panel]
[stretchable-width #f] [stretchable-width #f]
[min-width 16])) [min-width 16]))
(define languages-hier-list (new selectable-hierlist% (define other-languages-hier-list (new selectable-hierlist%
[parent languages-hier-list-panel] [parent languages-hier-list-panel]
[style '(no-border no-hscroll auto-vscroll transparent)])) [style '(no-border no-hscroll auto-vscroll transparent)]))
(define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details-outer-panel (make-object vertical-pane% outermost-panel))
@ -493,9 +577,11 @@
(define (module-language-selected) (define (module-language-selected)
;; need to deselect things in the languages-hier-list at this point. ;; need to deselect things in the languages-hier-list at this point.
(send languages-hier-list select #f) (send other-languages-hier-list select #f)
(send use-chosen-language-rb set-selection #f) (send teaching-languages-hier-list select #f)
(send use-language-in-source-rb set-selection 0) (send use-language-in-source-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f)
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(update-gui-based-on-selected-language module-language*language (update-gui-based-on-selected-language module-language*language
@ -504,12 +590,14 @@
;; no-language-selected : -> void ;; no-language-selected : -> void
;; updates the GUI for the situation where no language at all selected, and ;; updates the GUI for the situation where no language at all selected, and
;; and thus neither of the radio buttons should be selected. ;; and thus none of the radio buttons should be selected.
;; this generally happens when there is no preference setting for the language ;; this generally happens when there is no preference setting for the language
;; (ie the user has just started drracket for the first time) ;; (ie the user has just started drracket for the first time)
(define (no-language-selected) (define (no-language-selected)
(non-language-selected) (non-language-selected)
(send use-chosen-language-rb set-selection #f)) (send use-language-in-source-rb set-selection #f)
(send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f))
(define module-language*language 'module-language*-not-yet-set) (define module-language*language 'module-language*-not-yet-set)
(define module-language*get-language-details-panel 'module-language*-not-yet-set) (define module-language*get-language-details-panel 'module-language*-not-yet-set)
@ -519,8 +607,6 @@
;; updates the GUI and selected-language and get/set-selected-language-settings ;; updates the GUI and selected-language and get/set-selected-language-settings
;; for when some non-language is selected in the hierlist ;; for when some non-language is selected in the hierlist
(define (non-language-selected) (define (non-language-selected)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(send revert-to-defaults-button enable #f) (send revert-to-defaults-button enable #f)
(send details-panel active-child no-details-panel) (send details-panel active-child no-details-panel)
(send one-line-summary-message set-label "") (send one-line-summary-message set-label "")
@ -530,9 +616,17 @@
(send details-button enable #f)) (send details-button enable #f))
;; something-selected : item -> void ;; something-selected : item -> void
(define (something-selected item) (define (something-selected hierlist item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f) (send use-language-in-source-rb set-selection #f)
(cond
[(eq? hierlist other-languages-hier-list)
(send use-teaching-language-rb set-selection #f)
(send use-chosen-language-rb set-selection 0)
(send teaching-languages-hier-list select #f)]
[else
(send use-teaching-language-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send other-languages-hier-list select #f)])
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(send item selected)) (send item selected))
@ -546,8 +640,11 @@
;; when `language' matches language-to-show, update the settings ;; when `language' matches language-to-show, update the settings
;; panel to match language-to-show, otherwise set to defaults. ;; panel to match language-to-show, otherwise set to defaults.
(define (add-language-to-dialog language) (define (add-language-to-dialog language)
(let ([positions (send language get-language-position)] (define positions (send language get-language-position))
[numbers (send language get-language-numbers)]) (define numbers (send language get-language-numbers))
(define teaching-language? (and (pair? positions)
(equal? (car positions)
(string-constant teaching-languages))))
;; don't show the initial language ... ;; don't show the initial language ...
(unless (equal? positions initial-language-position) (unless (equal? positions initial-language-position)
@ -571,7 +668,8 @@
(error 'drracket:language (error 'drracket:language
"Only the module language may be at the top level. Other languages must have at least two levels"))) "Only the module language may be at the top level. Other languages must have at least two levels")))
(send languages-hier-list clear-fringe-cache) (send other-languages-hier-list clear-fringe-cache)
(send teaching-languages-hier-list clear-fringe-cache)
#| #|
@ -581,11 +679,16 @@
what the sorting number is for its level above (in the second-number mixin) what the sorting number is for its level above (in the second-number mixin)
|# |#
(let add-sub-language ([ht languages-table] (let add-sub-language ([ht languages-table]
[hier-list languages-hier-list] [hier-list (if teaching-language?
[positions positions] teaching-languages-hier-list
[numbers numbers] other-languages-hier-list)]
[positions (if teaching-language?
(cdr positions)
positions)]
[numbers (if teaching-language?
(cdr numbers)
numbers)]
[first? #t] [first? #t]
[second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
(cond (cond
@ -671,7 +774,8 @@
(send language get-style-delta) (send language get-style-delta)
0 0
(send text last-position))])))]))] (send text last-position))])))]))]
[else (let* ([position (car positions)] [else
(let* ([position (car positions)]
[number (car numbers)] [number (car numbers)]
[sub-ht/sub-hier-list [sub-ht/sub-hier-list
(hash-ref (hash-ref
@ -725,7 +829,7 @@
(cdr positions) (cdr positions)
(cdr numbers) (cdr numbers)
#f #f
(if first? number #f)))]))))) (if first? number #f)))]))))
(define number<%> (define number<%>
(interface () (interface ()
@ -779,35 +883,59 @@
(send item close) (send item close)
(close-children item)] (close-children item)]
[else (void)])) [else (void)]))
(close-children languages-hier-list)) (close-children other-languages-hier-list)
(close-children teaching-languages-hier-list))
;; open-current-language : -> void ;; open-current-language : -> void
;; opens the tabs that lead to the current language ;; opens the tabs that lead to the current language
;; and selects the current language ;; and selects the current language
(define (open-current-language) (define (open-current-language)
;; set the initial selection in the hierlists
(let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
(when hier-default
(select-a-language-in-hierlist other-languages-hier-list hier-default)))
(let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)])
(when hier-default
(select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default))))
(send languages-hier-list-panel change-children
(λ (l)
(list ellipsis-spacer-panel ellipsis-message)))
(cond (cond
[(not (and language-to-show settings-to-show)) [(not (and language-to-show settings-to-show))
(no-language-selected)] (no-language-selected)]
[(is-a? language-to-show drracket:module-language:module-language<%>) [(is-a? language-to-show drracket:module-language:module-language<%>)
(let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
(when hier-default
(select-a-language-in-hierlist hier-default)))
;; the above changes the radio button selections, so do it before calling module-language-selected ;; the above changes the radio button selections, so do it before calling module-language-selected
(module-language-selected)] (module-language-selected)]
[else [else
(send languages-hier-list focus) ;; only focus when the module language isn't selected (define position (send language-to-show get-language-position))
(cond
[(and (pair? position)
(equal? (car position)
(string-constant teaching-languages)))
(select-a-language-in-hierlist teaching-languages-hier-list (cdr position))
(send use-teaching-language-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send teaching-languages-hier-list focus)]
[else
(send languages-hier-list-panel change-children
(λ (l)
(list languages-hier-list-spacer other-languages-hier-list)))
(select-a-language-in-hierlist other-languages-hier-list position)
(send use-teaching-language-rb set-selection #f)
(send use-chosen-language-rb set-selection 0) (send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f) (send other-languages-hier-list focus)])
(select-a-language-in-hierlist (send language-to-show get-language-position))])) (send use-language-in-source-rb set-selection #f)]))
(define (select-a-language-in-hierlist language-position) (define (select-a-language-in-hierlist hier-list language-position)
(cond (cond
[(null? (cdr language-position)) [(null? (cdr language-position))
;; nothing to open here ;; nothing to open here
(send (car (send languages-hier-list get-items)) select #t) (send (car (send hier-list get-items)) select #t)]
(void)]
[else [else
(let loop ([hi languages-hier-list] (let loop ([hi hier-list]
;; skip the first position, since it is flattened into the dialog ;; skip the first position, since it is flattened into the dialog
[first-pos (cadr language-position)] [first-pos (cadr language-position)]
@ -819,8 +947,6 @@
(send hi get-items))]) (send hi get-items))])
(cond (cond
[(null? matching-children) [(null? matching-children)
;; just give up here. probably this means that a bad preference was saved
;; and we're being called from the module-language case in 'open-current-language'
(void)] (void)]
[else [else
(let ([child (car matching-children)]) (let ([child (car matching-children)])
@ -828,8 +954,9 @@
[(null? position) [(null? position)
(send child select #t)] (send child select #t)]
[else [else
(when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad
(send child open) (send child open)
(loop child (car position) (cdr position))]))])))])) (loop child (car position) (cdr position)))]))])))]))
;; docs-callback : -> void ;; docs-callback : -> void
(define (docs-callback) (define (docs-callback)
@ -901,11 +1028,9 @@
(send revert-to-defaults-outer-panel stretchable-width #f) (send revert-to-defaults-outer-panel stretchable-width #f)
(send revert-to-defaults-outer-panel stretchable-height #f) (send revert-to-defaults-outer-panel stretchable-height #f)
(send outermost-panel set-alignment 'center 'center)
(for-each add-language-to-dialog languages) (for-each add-language-to-dialog languages)
(send languages-hier-list sort (define (hier-list-sort-predicate x y)
(λ (x y)
(cond (cond
[(and (x . is-a? . second-number<%>) [(and (x . is-a? . second-number<%>)
(y . is-a? . second-number<%>)) (y . is-a? . second-number<%>))
@ -936,11 +1061,14 @@
[(and (x . is-a? . number<%>) [(and (x . is-a? . number<%>)
(y . is-a? . number<%>)) (y . is-a? . number<%>))
(< (send x get-number) (send y get-number))] (< (send x get-number) (send y get-number))]
[else #f]))) [else #f]))
(send other-languages-hier-list sort hier-list-sort-predicate)
(send teaching-languages-hier-list sort hier-list-sort-predicate)
;; remove the newline at the front of the first inlined category (if there) ;; remove the newline at the front of the first inlined category (if there)
;; it won't be there if the module language is at the top. ;; it won't be there if the module language is at the top.
(let ([t (send (car (send languages-hier-list get-items)) get-editor)]) (for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))])
(define t (send (car (send hier-list get-items)) get-editor))
(when (equal? "\n" (send t get-text 0 1)) (when (equal? "\n" (send t get-text 0 1))
(send t delete 0 1))) (send t delete 0 1)))
@ -949,15 +1077,21 @@
(λ (l) (λ (l)
(list details-panel))) (list details-panel)))
(send languages-hier-list stretchable-width #t) (define (config-hier-list hier-list)
(send languages-hier-list stretchable-height #t) (send hier-list stretchable-width #t)
(send languages-hier-list accept-tab-focus #t) (send hier-list stretchable-height #t)
(send languages-hier-list allow-tab-exit #t) (send hier-list accept-tab-focus #t)
(send hier-list allow-tab-exit #t))
(config-hier-list other-languages-hier-list)
(config-hier-list teaching-languages-hier-list)
(send parent reflow-container) (send parent reflow-container)
(close-all-languages) (close-all-languages)
(open-current-language) (open-current-language)
(send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) (define (set-min-sizes hier-list)
(send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) (send hier-list min-client-width (text-width (send hier-list get-editor)))
(send hier-list min-client-height (text-height (send hier-list get-editor))))
(set-min-sizes other-languages-hier-list)
(set-min-sizes teaching-languages-hier-list)
(when details-shown? (when details-shown?
(do-construct-details)) (do-construct-details))
(update-show/hide-details) (update-show/hide-details)
@ -979,7 +1113,14 @@
(use-language-in-source-rb-callback) (use-language-in-source-rb-callback)
#t) #t)
#f)] #f)]
[(#\c) [(#\t)
(if (mouse-event-uses-shortcut-prefix? evt)
(begin
(send use-teaching-language-rb set-selection 0)
(use-teaching-language-rb-callback)
#t)
#f)]
[(#\o)
(if (mouse-event-uses-shortcut-prefix? evt) (if (mouse-event-uses-shortcut-prefix? evt)
(begin (begin
(send use-chosen-language-rb set-selection 0) (send use-chosen-language-rb set-selection 0)
@ -988,21 +1129,20 @@
#f)] #f)]
[else #f]))))) [else #f])))))
(define (add-discussion p) (define (add-discussion p definitions-text use-language-in-source-rb-callback)
(let* ([t (new text:standard-style-list%)] (define t (new (text:hide-caret/selection-mixin text:standard-style-list%)))
[c (new editor-canvas% (define c (new editor-canvas%
[stretchable-width #t] [stretchable-width #t]
[horizontal-inset 0] [horizontal-inset 0]
[vertical-inset 0] [vertical-inset 0]
[parent p] [parent p]
[style '(no-border no-vscroll no-hscroll transparent)] [style '(no-border no-vscroll no-hscroll transparent)]
[editor t])]) [editor t]))
(send t set-styles-sticky #f) (send t set-styles-sticky #f)
(send t set-autowrap-bitmap #f) (send t set-autowrap-bitmap #f)
(let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] (define size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size)))
[do-insert (define (do-insert str tt-style?)
(λ (str tt-style?) (define before (send t last-position))
(let ([before (send t last-position)])
(send t insert str before before) (send t insert str before before)
(cond (cond
[tt-style? [tt-style?
@ -1013,31 +1153,175 @@
(send t change-style (send t change-style
(send (send t get-style-list) basic-style) (send (send t get-style-list) basic-style)
before (send t last-position))]) before (send t last-position))])
(send t change-style size-sd before (send t last-position))))]) (send t change-style size-sd before (send t last-position)))
(when (send normal-control-font get-size-in-pixels) (when (send normal-control-font get-size-in-pixels)
(send size-sd set-size-in-pixels-on #t)) (send size-sd set-size-in-pixels-on #t))
(let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)]) (let loop ([strs (regexp-split #rx"#lang" (string-constant racket-language-discussion))])
(do-insert (car strs) #f) (do-insert (car strs) #f)
(unless (null? (cdr strs)) (unless (null? (cdr strs))
(do-insert "#lang" #t) (do-insert "#lang" #t)
(loop (cdr strs))))) (loop (cdr strs))))
(send t hide-caret #t)
(define xref-chan (make-channel))
(thread
(λ ()
(define xref (load-collections-xref))
(let loop ()
(channel-put xref-chan xref)
(loop))))
(define spacer-snips '())
(define spacer-poses '())
(for ([lang (in-list '(racket racket/base typed/racket scribble/base))])
(define the-lang-line (format "#lang ~a" lang))
(do-insert " " #t)
(define before-lang (send t last-position))
(do-insert the-lang-line #t)
(define after-lang (send t last-position))
(define spacer (new spacer-snip%))
(define spacer-pos (send t last-position))
(set! spacer-snips (cons spacer spacer-snips))
(set! spacer-poses (cons spacer-pos spacer-poses))
(send t insert spacer spacer-pos spacer-pos)
(do-insert " [" #f)
(define before-docs (send t last-position))
(do-insert "docs" #f)
(define after-docs (send t last-position))
(do-insert "]\n" #f)
(send t set-clickback before-lang after-lang
(λ (t start end)
(use-language-in-source-rb-callback)
(define-values (current-line-start current-line-end)
(if definitions-text
(find-language-position definitions-text)
(values #f #f)))
(define existing-lang-line (and current-line-start
(send definitions-text get-text current-line-start current-line-end)))
(case (message-box/custom
(string-constant drscheme)
(string-append
(string-constant racket-dialect-in-buffer-message)
"\n\n"
(cond
[(and existing-lang-line
(equal? existing-lang-line the-lang-line))
(format (string-constant racket-dialect-already-same-#lang-line)
existing-lang-line)]
[existing-lang-line
(format (string-constant racket-dialect-replace-#lang-line)
existing-lang-line
the-lang-line)]
[else
(format (string-constant racket-dialect-add-new-#lang-line) the-lang-line)]))
(cond
[(and existing-lang-line
(equal? existing-lang-line the-lang-line))
(string-constant ok)]
[existing-lang-line
(string-constant replace-#lang-line)]
[else
(string-constant add-#lang-line)])
(and (not (equal? existing-lang-line the-lang-line))
(string-constant cancel))
#f #f
'(default=1))
[(1)
(cond
[current-line-start
(send definitions-text begin-edit-sequence)
(send definitions-text delete current-line-start current-line-end)
(send definitions-text insert the-lang-line current-line-start current-line-start)
(send definitions-text end-edit-sequence)]
[else
(send definitions-text begin-edit-sequence)
(send definitions-text insert "\n" 0 0)
(send definitions-text insert the-lang-line 0 0)
(send definitions-text end-edit-sequence)])]
[else (void)])))
(send t set-clickback before-docs after-docs
(λ (t start end)
(define-values (path tag) (xref-tag->path+anchor (channel-get xref-chan) `(mod-path ,(symbol->string lang))))
(define url (path->url path))
(define url2 (if tag
(make-url (url-scheme url)
(url-user url)
(url-host url)
(url-port url)
(url-path-absolute? url)
(url-path url)
(url-query url)
tag)
url))
(send-url (url->string url2)))))
(do-insert (string-constant racket-language-discussion-end) #f)
(define kmp (send t set-keymap (keymap:get-editor)))
(send (send c get-parent) reflow-container)
(define xb (box 0))
(define max-spacer-pos
(for/fold ([m 0]) ([spacer-pos (in-list spacer-poses)])
(send t position-location spacer-pos xb #f)
(max m (unbox xb))))
(for ([spacer-pos (in-list spacer-poses)]
[spacer-snip (in-list spacer-snips)])
(send t position-location spacer-pos xb #f)
(send spacer-snip set-width (- max-spacer-pos (unbox xb))))
(send t hide-caret #t)
(send t auto-wrap #t) (send t auto-wrap #t)
(send t lock #t) (send t lock #t)
(send c accept-tab-focus #f) (send c accept-tab-focus #f)
(send c allow-tab-exit #t) (send c allow-tab-exit #t)
c))
c)
(define (find-language-position definitions-text)
(define prt (open-input-text-editor definitions-text))
(port-count-lines! prt)
(define l (with-handlers ((exn:fail? (λ (x) #f)))
(read-language prt)))
(cond
[l
(define-values (line col pos) (port-next-location prt))
(define hash-lang-start (send definitions-text find-string "#lang" 'backward pos 0 #f))
(if hash-lang-start
(values hash-lang-start (- pos 1))
(values #f #f))]
[else
(values #f #f)]))
(define spacer-snip%
(class snip%
(inherit get-admin)
(define width 0)
(define/public (set-width w)
(set! width w)
(define admin (get-admin))
(when admin
(send admin resized this #t)))
(define/override (get-text [start 0] [end 'eof] [flattened? #f] [force-cr? #f])
"")
(define/override (get-extent dc x y wb hb db ab lb sp)
(super get-extent dc x y wb hb db ab lb sp)
(when (box? wb) (set-box! wb width)))
(super-new)))
(define spacer-sc (new snip-class%))
(send spacer-sc set-classname "drracket:spacer-snipclass")
(send spacer-sc set-version 0)
(send (get-the-snip-class-list) add spacer-sc)
(define (size-discussion-canvas canvas) (define (size-discussion-canvas canvas)
(let ([t (send canvas get-editor)]) (define t (send canvas get-editor))
(define by (box 0))
(let ([by (box 0)])
(send t position-location (send t position-location
(send t line-end-position (send t last-line)) (send t line-end-position (send t last-line))
#f #f
by) by)
(send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))))) (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24)))
(define section-style-delta (make-object style-delta% 'change-bold)) (define section-style-delta (make-object style-delta% 'change-bold))
(send section-style-delta set-delta-foreground "medium blue") (send section-style-delta set-delta-foreground "medium blue")
@ -1178,7 +1462,7 @@
#f #f
#f #f
#t) #t)
(+ 10 ;; upper bound on some platform specific space I don't know how to get. (+ 16 ;; upper bound on some space I don't know how to get.
(floor (inexact->exact (unbox y-box)))))) (floor (inexact->exact (unbox y-box))))))

5
collects/drracket/private/local-member-names.rkt
View File

@ -24,3 +24,8 @@
;; defined in module-language.rkt ;; defined in module-language.rkt
(define-local-member-name (define-local-member-name
set-lang-wants-big-defs/ints-labels?) set-lang-wants-big-defs/ints-labels?)
;; used by the test suite to tell when the
;; online check syntax has finished
(define-local-member-name
get-online-expansion-colors)

1
collects/drracket/private/main.rkt
View File

@ -72,6 +72,7 @@
(preferences:set-default 'drracket:defs/ints-labels #t boolean?) (preferences:set-default 'drracket:defs/ints-labels #t boolean?)
(drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
(drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution))))
(drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket)))) (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket))))

5
collects/drracket/private/module-language-tools.rkt
View File

@ -8,7 +8,8 @@
racket/class racket/class
racket/gui/base racket/gui/base
"drsig.rkt" "drsig.rkt"
"local-member-names.rkt") "local-member-names.rkt"
framework/private/logging-timer)
(define op (current-output-port)) (define op (current-output-port))
(define (oprintf . args) (apply fprintf op args)) (define (oprintf . args) (apply fprintf op args))
@ -136,7 +137,7 @@
(<= start hash-lang-last-location)) (<= start hash-lang-last-location))
(unless timer (unless timer
(set! timer (new timer% (set! timer (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
(when in-module-language? (when in-module-language?

43
collects/drracket/private/module-language.rkt
View File

@ -25,7 +25,9 @@
"rep.rkt" "rep.rkt"
"eval-helpers.rkt" "eval-helpers.rkt"
"local-member-names.rkt" "local-member-names.rkt"
"rectangle-intersect.rkt") "rectangle-intersect.rkt"
framework/private/logging-timer)
(define-runtime-path expanding-place.rkt "expanding-place.rkt") (define-runtime-path expanding-place.rkt "expanding-place.rkt")
@ -145,15 +147,17 @@
(inherit get-language-name) (inherit get-language-name)
(define/public (get-users-language-name defs-text) (define/public (get-users-language-name defs-text)
(let* ([defs-port (open-input-text-editor defs-text)] (define defs-port (open-input-text-editor defs-text))
[read-successfully? (port-count-lines! defs-port)
(define read-successfully?
(with-handlers ((exn:fail? (λ (x) #f))) (with-handlers ((exn:fail? (λ (x) #f)))
(read-language defs-port (λ () #f)) (read-language defs-port (λ () #f))
#t)]) #t))
(cond (cond
[read-successfully? [read-successfully?
(let* ([str (send defs-text get-text 0 (file-position defs-port))] (define-values (_line _col port-pos) (port-next-location defs-port))
[pos (regexp-match-positions #rx"#(?:!|lang )" str)]) (define str (send defs-text get-text 0 (- port-pos 1)))
(define pos (regexp-match-positions #rx"#(?:!|lang )" str))
(cond (cond
[(not pos) [(not pos)
(get-language-name)] (get-language-name)]
@ -165,9 +169,9 @@
;; so be it. ;; so be it.
(regexp-replace* #rx"[\r\n]+" (regexp-replace* #rx"[\r\n]+"
(substring str (cdr (car pos)) (string-length str)) (substring str (cdr (car pos)) (string-length str))
" ")]))] " ")])]
[else [else
(get-language-name)]))) (get-language-name)]))
(define/override (use-namespace-require/copy?) #f) (define/override (use-namespace-require/copy?) #f)
@ -933,6 +937,7 @@
;; colors : (or/c #f (listof string?) 'parens) ;; colors : (or/c #f (listof string?) 'parens)
(define colors #f) (define colors #f)
(define tooltip-labels #f) (define tooltip-labels #f)
(define/public (get-online-expansion-colors) colors)
(super-new) (super-new)
@ -1310,11 +1315,12 @@
(inherit last-position find-first-snip get-top-level-window get-filename (inherit last-position find-first-snip get-top-level-window get-filename
get-tab get-canvas invalidate-bitmap-cache get-tab get-canvas invalidate-bitmap-cache
set-position get-start-position get-end-position set-position get-start-position get-end-position
highlight-range dc-location-to-editor-location) highlight-range dc-location-to-editor-location
begin-edit-sequence end-edit-sequence)
(define compilation-out-of-date? #f) (define compilation-out-of-date? #f)
(define tmr (new timer% [notify-callback (lambda () (send-off))])) (define tmr (new logging-timer% [notify-callback (lambda () (send-off))]))
(define cb-proc (λ (sym new-val) (define cb-proc (λ (sym new-val)
(when new-val (when new-val
@ -1502,6 +1508,7 @@
(reset-frame-expand-error #f)) (reset-frame-expand-error #f))
(define/private (show-error-in-margin res) (define/private (show-error-in-margin res)
(begin-edit-sequence #f #f)
(define tlw (send (get-tab) get-frame)) (define tlw (send (get-tab) get-frame))
(send (get-tab) show-bkg-running 'nothing #f) (send (get-tab) show-bkg-running 'nothing #f)
(set! error/status-message-str (vector-ref res 1)) (set! error/status-message-str (vector-ref res 1))
@ -1516,7 +1523,8 @@
(set-error-ranges-from-online-error-ranges (vector-ref res 2)) (set-error-ranges-from-online-error-ranges (vector-ref res 2))
(invalidate-online-error-ranges) (invalidate-online-error-ranges)
(set! error/status-message-hidden? #f) (set! error/status-message-hidden? #f)
(update-frame-expand-error)) (update-frame-expand-error)
(end-edit-sequence))
(define/private (show-error-as-highlighted-regions res) (define/private (show-error-as-highlighted-regions res)
(define tlw (send (get-tab) get-frame)) (define tlw (send (get-tab) get-frame))
@ -1551,6 +1559,7 @@
(send (send (get-tab) get-ints) set-error-ranges srclocs)) (send (send (get-tab) get-ints) set-error-ranges srclocs))
(define/private (clear-old-error) (define/private (clear-old-error)
(begin-edit-sequence #f #f)
(for ([cleanup-thunk (in-list online-highlighted-errors)]) (for ([cleanup-thunk (in-list online-highlighted-errors)])
(cleanup-thunk)) (cleanup-thunk))
(for ([an-error-range (in-list online-error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
@ -1558,7 +1567,8 @@
((error-range-clear-highlight an-error-range)) ((error-range-clear-highlight an-error-range))
(set-error-range-clear-highlight! an-error-range #f))) (set-error-range-clear-highlight! an-error-range #f)))
(invalidate-online-error-ranges) (invalidate-online-error-ranges)
(set-online-error-ranges '())) (set-online-error-ranges '())
(end-edit-sequence))
(define/private (invalidate-online-error-ranges) (define/private (invalidate-online-error-ranges)
(when (get-admin) (when (get-admin)
@ -1781,7 +1791,7 @@
(define lang-wants-big-defs/ints-labels? #f) (define lang-wants-big-defs/ints-labels? #f)
(define recently-typed-timer (define recently-typed-timer
(new timer% (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
(update-recently-typed #f) (update-recently-typed #f)
@ -1809,7 +1819,9 @@
(update-recently-typed #t) (update-recently-typed #t)
(set! fade-amount 0) (set! fade-amount 0)
(send recently-typed-timer stop) (send recently-typed-timer stop)
(send recently-typed-timer start 10000 #t)) (when (and lang-wants-big-defs/ints-labels?
(preferences:get 'drracket:defs/ints-labels))
(send recently-typed-timer start 10000 #t)))
(super on-char evt)) (super on-char evt))
(define/private (update-recently-typed nv) (define/private (update-recently-typed nv)
@ -1824,7 +1836,8 @@
[else (preferences:get 'drracket:defs/ints-labels)])) [else (preferences:get 'drracket:defs/ints-labels)]))
(unless (equal? new-inside? inside?) (unless (equal? new-inside? inside?)
(set! inside? new-inside?) (set! inside? new-inside?)
(invalidate-bitmap-cache 0 0 'display-end 'display-end)) (when lang-wants-big-defs/ints-labels?
(invalidate-bitmap-cache 0 0 'display-end 'display-end)))
(cond (cond
[(and lang-wants-big-defs/ints-labels? [(and lang-wants-big-defs/ints-labels?
(preferences:get 'drracket:defs/ints-labels) (preferences:get 'drracket:defs/ints-labels)

8
collects/drracket/private/rep.rkt
View File

@ -434,7 +434,6 @@ TODO
insert insert
insert-before insert-before
insert-between insert-between
invalidate-bitmap-cache
is-locked? is-locked?
last-position last-position
line-location line-location
@ -1265,6 +1264,7 @@ TODO
(thread (thread
(λ () (λ ()
(struct gui-event (start? msec name) #:prefab)
;; forward system events the user's logger, and record any ;; forward system events the user's logger, and record any
;; events that happen on the user's logger to show in the GUI ;; events that happen on the user's logger to show in the GUI
(let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)] (let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)]
@ -1274,16 +1274,18 @@ TODO
(handle-evt (handle-evt
sys-evt sys-evt
(λ (logged) (λ (logged)
(unless (gui-event? (vector-ref logged 2))
(log-message user-logger (log-message user-logger
(vector-ref logged 0) (vector-ref logged 0)
(vector-ref logged 1) (vector-ref logged 1)
(vector-ref logged 2)) (vector-ref logged 2)))
(loop))) (loop)))
(handle-evt (handle-evt
user-evt user-evt
(λ (vec) (λ (vec)
(unless (gui-event? (vector-ref vec 2))
(parameterize ([current-eventspace drracket:init:system-eventspace]) (parameterize ([current-eventspace drracket:init:system-eventspace])
(queue-callback (λ () (new-log-message vec)))) (queue-callback (λ () (new-log-message vec)))))
(loop)))))))) (loop))))))))
(initialize-parameters snip-classes) (initialize-parameters snip-classes)

5
collects/drracket/private/syncheck/blueboxes-gui.rkt
View File

@ -8,7 +8,8 @@
setup/dirs setup/dirs
images/icons/misc images/icons/misc
"../rectangle-intersect.rkt" "../rectangle-intersect.rkt"
string-constants) string-constants
framework/private/logging-timer)
(provide docs-text-mixin (provide docs-text-mixin
docs-editor-canvas-mixin docs-editor-canvas-mixin
syncheck:add-docs-range syncheck:add-docs-range
@ -376,7 +377,7 @@
[else [else
(super on-event evt)])) (super on-event evt)]))
(define timer (new timer% (define timer (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
(set! timer-running? #f) (set! timer-running? #f)

41
collects/drracket/private/syncheck/gui.rkt
View File

@ -48,7 +48,8 @@ If the namespace does not, they are colored the unbound color.
"traversals.rkt" "traversals.rkt"
"annotate.rkt" "annotate.rkt"
"../tooltip.rkt" "../tooltip.rkt"
"blueboxes-gui.rkt") "blueboxes-gui.rkt"
framework/private/logging-timer)
(provide tool@) (provide tool@)
(define orig-output-port (current-output-port)) (define orig-output-port (current-output-port))
@ -969,7 +970,7 @@ If the namespace does not, they are colored the unbound color.
;; Starts or restarts a one-shot arrow draw timer ;; Starts or restarts a one-shot arrow draw timer
(define/private (start-arrow-draw-timer delay-ms) (define/private (start-arrow-draw-timer delay-ms)
(unless arrow-draw-timer (unless arrow-draw-timer
(set! arrow-draw-timer (make-object timer% (λ () (maybe-update-drawn-arrows))))) (set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows)))))
(send arrow-draw-timer start delay-ms #t)) (send arrow-draw-timer start delay-ms #t))
;; this will be set to a time in the future if arrows shouldn't be drawn until then ;; this will be set to a time in the future if arrows shouldn't be drawn until then
@ -1581,6 +1582,7 @@ If the namespace does not, they are colored the unbound color.
(send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running) (send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running)
(send defs-text syncheck:init-arrows) (send defs-text syncheck:init-arrows)
(let loop ([val val] (let loop ([val val]
[start-time (current-inexact-milliseconds)]
[i 0]) [i 0])
(cond (cond
[(null? val) [(null? val)
@ -1588,40 +1590,42 @@ If the namespace does not, they are colored the unbound color.
(send defs-text syncheck:update-drawn-arrows) (send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(set-syncheck-running-mode #f)] (set-syncheck-running-mode #f)]
[(= i 500) [(and (i . > . 0) ;; check i just in case things are really strange
(20 . <= . (- (current-inexact-milliseconds) start-time)))
(queue-callback (queue-callback
(λ () (λ ()
(when (unbox bx) (when (unbox bx)
(loop val 0))) (log-timeline "continuing replay-compile-comp-trace"
(loop val (current-inexact-milliseconds) 0))))
#f)] #f)]
[else [else
(process-trace-element defs-text (car val)) (process-trace-element defs-text (car val))
(loop (cdr val) (+ i 1))])))) (loop (cdr val) start-time (+ i 1))]))))
(define/private (process-trace-element defs-text x) (define/private (process-trace-element defs-text x)
;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; using 'defs-text' all the time is wrong in the case of embedded editors,
;; but they already don't work and we've arranged for them to not appear here .... ;; but they already don't work and we've arranged for them to not appear here ....
(match x (match x
[`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right
,end-text ,end-pos-left ,end-pos-right ,end-pos-left ,end-pos-right
,actual? ,level) ,actual? ,level)
(send defs-text syncheck:add-arrow (send defs-text syncheck:add-arrow
defs-text start-pos-left start-pos-right defs-text start-pos-left start-pos-right
defs-text end-pos-left end-pos-right defs-text end-pos-left end-pos-right
actual? level)] actual? level)]
[`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos) [`#(syncheck:add-tail-arrow ,from-pos ,to-pos)
(send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)]
[`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str) [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str)
(send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)] (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)]
[`(syncheck:add-background-color ,text ,color ,start ,fin) [`#(syncheck:add-background-color ,color ,start ,fin)
(send defs-text syncheck:add-background-color defs-text color start fin)] (send defs-text syncheck:add-background-color defs-text color start fin)]
[`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename) [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename)
(send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)]
[`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file)
(send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
[`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
(send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)]
[`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
(define other-side-dead? #f) (define other-side-dead? #f)
(define (name-dup? name) (define (name-dup? name)
(cond (cond
@ -1639,7 +1643,7 @@ If the namespace does not, they are colored the unbound color.
#f])])) #f])]))
(define to-be-renamed/poss/fixed (define to-be-renamed/poss/fixed
(for/list ([lst (in-list to-be-renamed/poss)]) (for/list ([lst (in-list to-be-renamed/poss)])
(list defs-text (list-ref lst 1) (list-ref lst 2)))) (list defs-text (list-ref lst 0) (list-ref lst 1))))
(send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed
name-dup?)])) name-dup?)]))
@ -2066,9 +2070,12 @@ If the namespace does not, they are colored the unbound color.
(drracket:module-language-tools:add-online-expansion-handler (drracket:module-language-tools:add-online-expansion-handler
online-comp.rkt online-comp.rkt
'go 'go
(λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) (λ (defs-text val)
(log-timeline
"replace-compile-comp-trace"
(send (send (send defs-text get-canvas) get-top-level-window)
replay-compile-comp-trace replay-compile-comp-trace
defs-text defs-text
val))))) val))))))
(define-runtime-path online-comp.rkt "online-comp.rkt") (define-runtime-path online-comp.rkt "online-comp.rkt")

38
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/place racket/place
(for-syntax racket/base)
"../../private/eval-helpers.rkt" "../../private/eval-helpers.rkt"
"traversals.rkt" "traversals.rkt"
"local-member-names.rkt" "local-member-names.rkt"
@ -34,26 +35,35 @@
(define/override (syncheck:find-source-object stx) (define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx)) (and (equal? src (syntax-source stx))
src)) src))
(define-syntax-rule
(log name)
(define/override (name . args)
(set! trace (cons (cons 'name args) trace))))
; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up ;; send over the non _ variables in the message to the main drracket place
(log syncheck:add-mouse-over-status) (define-syntax (log stx)
(log syncheck:add-arrow) (syntax-case stx ()
(log syncheck:add-tail-arrow) [(_ name args ...)
(log syncheck:add-background-color) (with-syntax ([(wanted-args ...)
(log syncheck:add-require-open-menu) (filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x)))))
(log syncheck:add-docs-menu) (syntax->list #'(args ...)))])
(log syncheck:add-jump-to-definition) #'(define/override (name args ...)
(add-to-trace (vector 'name wanted-args ...))))]))
(log syncheck:add-arrow
_start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right
actual? level)
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin)
(log syncheck:add-jump-to-definition _text start end id filename)
(log syncheck:add-require-open-menu _text start-pos end-pos file)
(log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
(define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?) (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
(define id (hash-count table)) (define id (hash-count table))
(hash-set! table id dup-name?) (hash-set! table id dup-name?)
(set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id) (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
trace)))
(define/public (get-trace) (reverse trace)) (define/public (get-trace) (reverse trace))
(define/private (add-to-trace thing)
(set! trace (cons thing trace)))
(super-new))) (super-new)))
(define (go expanded path the-source orig-cust) (define (go expanded path the-source orig-cust)

14
collects/drracket/private/syncheck/traversals.rkt
View File

@ -1134,10 +1134,22 @@
(for/or ([(level id-set) (in-hash phase-to-map)]) (for/or ([(level id-set) (in-hash phase-to-map)])
(get-ids id-set new-id)))))))) (get-ids id-set new-id))))))))
#t)) #t))
(define max-to-send-at-once 30)
(let loop ([loc-lst loc-lst]
[len (length loc-lst)])
(cond
[(<= len max-to-send-at-once)
(send defs-text syncheck:add-rename-menu (send defs-text syncheck:add-rename-menu
id-as-sym id-as-sym
loc-lst loc-lst
name-dup?))))))) name-dup?)]
[else
(send defs-text syncheck:add-rename-menu
id-as-sym
(take loc-lst max-to-send-at-once)
name-dup?)
(loop (drop loc-lst max-to-send-at-once)
(- len max-to-send-at-once))]))))))))
;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
;; removes duplicates, based on the source locations of the identifiers ;; removes duplicates, based on the source locations of the identifiers

5
collects/drracket/private/unit.rkt
View File

@ -44,7 +44,8 @@ module browser threading seems wrong.
mzlib/date mzlib/date
framework/private/aspell) framework/private/aspell
framework/private/logging-timer)
(provide unit@) (provide unit@)
@ -4544,7 +4545,7 @@ module browser threading seems wrong.
(define num-running-frames (vector-length running-frames)) (define num-running-frames (vector-length running-frames))
(define is-running? #f) (define is-running? #f)
(define frame 0) (define frame 0)
(define timer (make-object timer% (λ () (refresh) (yield)) #f)) (define timer (make-object logging-timer% (λ () (refresh) (yield)) #f))
(define/public (set-running r?) (define/public (set-running r?)
(cond [r? (unless is-running? (set! frame 4)) (cond [r? (unless is-running? (set! frame 4))

6
collects/eopl/eopl.rkt
View File

@ -1,10 +1,12 @@
#lang racket #lang racket/base
(require "datatype.rkt" (require "datatype.rkt"
"private/sllgen.rkt" "private/sllgen.rkt"
racket/promise
mzlib/trace mzlib/trace
mzlib/pretty) mzlib/pretty)
(require (for-syntax "private/slldef.rkt")) (require (for-syntax racket/base
"private/slldef.rkt"))
(provide define-datatype (provide define-datatype
cases) cases)

1
collects/ffi/unsafe.rkt
View File

@ -1702,6 +1702,7 @@
(cweh (cweh
(lambda (exn) (lambda (exn)
(log-message logger (log-message logger
'error
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "~s" exn)) (format "~s" exn))

3
collects/file/scribblings/md5.scrbl
View File

@ -20,3 +20,6 @@ that is the MD5 hash of the given input stream or byte string.
(md5 #"abc") (md5 #"abc")
(md5 #"abc" #f) (md5 #"abc" #f)
]} ]}
@close-eval[md5-eval]

3
collects/file/scribblings/sha1.scrbl
View File

@ -40,3 +40,6 @@ until an end-of-file.
Converts the given byte string to a string representation, where each Converts the given byte string to a string representation, where each
byte in @racket[bstr] is converted to its two-digit hexadecimal byte in @racket[bstr] is converted to its two-digit hexadecimal
representation in the resulting string.} representation in the resulting string.}
@close-eval[sha1-eval]

6
collects/framework/main.rkt
View File

@ -72,6 +72,12 @@
in a GUI, and the color to use. The colors are used to show the nesting in a GUI, and the color to use. The colors are used to show the nesting
structure in the parens.}) structure in the parens.})
(thing-doc
color:misspelled-text-color-style-name
string?
@{The name of the style used to color misspelled words. See also
@method[color:text<%> get-spell-check-strings].})
(proc-doc/names (proc-doc/names
text:range? (-> any/c boolean?) (arg) text:range? (-> any/c boolean?) (arg)
@{Determines if @racket[arg] is an instance of the @tt{range} struct.}) @{Determines if @racket[arg] is an instance of the @tt{range} struct.})

152
collects/framework/private/color.rkt
View File

@ -6,9 +6,8 @@ added reset-regions
added get-regions added get-regions
|# |#
(require mzlib/class (require racket/class
mzlib/thread racket/gui/base
mred
syntax-color/token-tree syntax-color/token-tree
syntax-color/paren-tree syntax-color/paren-tree
syntax-color/default-lexer syntax-color/default-lexer
@ -237,13 +236,11 @@ added get-regions
(start-colorer token-sym->style get-token pairs))) (start-colorer token-sym->style get-token pairs)))
;; ---------------------- Multi-threading --------------------------- ;; ---------------------- Multi-threading ---------------------------
;; A list of (vector style number number) that indicate how to color the buffer ;; The editor revision when the last coloring was started
(define colorings null) (define revision-when-started-parsing #f)
;; The coroutine object for tokenizing the buffer
(define tok-cor #f)
;; The editor revision when tok-cor was created
(define rev #f)
;; The editor revision when after the last edit to the buffer
(define revision-after-last-edit #f)
(inherit change-style begin-edit-sequence end-edit-sequence highlight-range (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
get-style-list in-edit-sequence? get-start-position get-end-position get-style-list in-edit-sequence? get-start-position get-end-position
@ -275,17 +272,7 @@ added get-regions
(update-lexer-state-observers) (update-lexer-state-observers)
(set! restart-callback #f) (set! restart-callback #f)
(set! force-recolor-after-freeze #f) (set! force-recolor-after-freeze #f)
(set! colorings null) (set! revision-when-started-parsing #f))
(when tok-cor
(coroutine-kill tok-cor))
(set! tok-cor #f)
(set! rev #f))
;; Actually color the buffer.
(define/private (color)
(for ([clr (in-list colorings)])
(change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f))
(set! colorings '()))
;; Discard extra tokens at the first of invalid-tokens ;; Discard extra tokens at the first of invalid-tokens
(define/private (sync-invalid ls) (define/private (sync-invalid ls)
@ -302,25 +289,49 @@ added get-regions
(set-lexer-state-invalid-tokens-mode! ls mode)) (set-lexer-state-invalid-tokens-mode! ls mode))
(sync-invalid ls)))) (sync-invalid ls))))
(define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) (define/private (re-tokenize-move-to-next-ls start-time did-something?)
(enable-suspend #f) (cond
[(null? re-tokenize-lses)
;; done: return #t
#t]
[else
(define ls (car re-tokenize-lses))
(set! re-tokenize-lses (cdr re-tokenize-lses))
(define in
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f)))
(port-count-lines! in)
(continue-re-tokenize start-time did-something? ls in
(lexer-state-current-pos ls)
(lexer-state-current-lexer-mode ls))]))
(define re-tokenize-lses #f)
(define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode)
(cond
[(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds)))
#f]
[else
;(define-values (_line1 _col1 pos-before) (port-next-location in)) ;(define-values (_line1 _col1 pos-before) (port-next-location in))
(define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode)
(get-token in in-start-pos in-lexer-mode)) (get-token in in-start-pos lexer-mode))
;(define-values (_line2 _col2 pos-after) (port-next-location in)) ;(define-values (_line2 _col2 pos-after) (port-next-location in))
(enable-suspend #t) (cond
(unless (eq? 'eof type) [(eq? 'eof type)
(re-tokenize-move-to-next-ls start-time #t)]
[else
(unless (exact-nonnegative-integer? new-token-start) (unless (exact-nonnegative-integer? new-token-start)
(error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
(unless (exact-nonnegative-integer? new-token-end) (unless (exact-nonnegative-integer? new-token-end)
(error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
(unless (exact-nonnegative-integer? backup-delta) (unless (exact-nonnegative-integer? backup-delta)
(error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
(unless (0 . < . (- new-token-end new-token-start)) (unless (new-token-start . < . new-token-end)
(error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) (error 'color:text<%>
(enable-suspend #f) "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e"
#; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) new-token-start new-token-end))
(+ in-start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
#; #;
(unless (= len (- pos-after pos-before)) (unless (= len (- pos-after pos-before))
@ -352,10 +363,9 @@ added get-regions
(insert-last! (lexer-state-tokens ls) (insert-last! (lexer-state-tokens ls)
(lexer-state-invalid-tokens ls)) (lexer-state-invalid-tokens ls))
(set-lexer-state-invalid-tokens-start! ls +inf.0) (set-lexer-state-invalid-tokens-start! ls +inf.0)
(enable-suspend #t)] (re-tokenize-move-to-next-ls start-time #t)]
[else [else
(enable-suspend #t) (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])]))
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
(define/private (add-colorings type in-start-pos new-token-start new-token-end) (define/private (add-colorings type in-start-pos new-token-start new-token-end)
(define sp (+ in-start-pos (sub1 new-token-start))) (define sp (+ in-start-pos (sub1 new-token-start)))
@ -376,22 +386,23 @@ added get-regions
[lp 0]) [lp 0])
(cond (cond
[(null? spellos) [(null? spellos)
(set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) (add-coloring color (+ sp lp) (+ sp (string-length str)))]
colorings))]
[else [else
(define err (car spellos)) (define err (car spellos))
(define err-start (list-ref err 0)) (define err-start (list-ref err 0))
(define err-len (list-ref err 1)) (define err-len (list-ref err 1))
(set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len))
(vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) (add-coloring color (+ pos lp) (+ pos err-start))
colorings))
(loop (cdr spellos) (+ err-start err-len))])) (loop (cdr spellos) (+ err-start err-len))]))
(loop (cdr strs) (loop (cdr strs)
(+ pos (string-length str) 1))))] (+ pos (string-length str) 1))))]
[else [else
(set! colorings (cons (vector color sp ep) colorings))])] (add-coloring color sp ep)])]
[else [else
(set! colorings (cons (vector color sp ep) colorings))])) (add-coloring color sp ep)]))
(define/private (add-coloring color sp ep)
(change-style color sp ep #f))
(define/private (show-tree t) (define/private (show-tree t)
(printf "Tree:\n") (printf "Tree:\n")
@ -486,52 +497,19 @@ added get-regions
(define/private (colorer-driver) (define/private (colorer-driver)
(unless (andmap lexer-state-up-to-date? lexer-states) (unless (andmap lexer-state-up-to-date? lexer-states)
#;(printf "revision ~a\n" (get-revision-number))
(unless (and tok-cor (= rev (get-revision-number)))
(when tok-cor
(coroutine-kill tok-cor))
#;(printf "new coroutine\n")
(set! tok-cor
(coroutine
(λ (enable-suspend)
(parameterize ((port-count-lines-enabled #t))
(for-each
(lambda (ls)
(re-tokenize ls
(begin
(enable-suspend #f)
(begin0
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(enable-suspend #t)))
(lexer-state-current-pos ls)
(lexer-state-current-lexer-mode ls)
enable-suspend))
lexer-states)))))
(set! rev (get-revision-number)))
(with-handlers ((exn:fail?
(λ (exn)
(parameterize ((print-struct #t))
((error-display-handler)
(format "exception in colorer thread: ~s" exn)
exn))
(set! tok-cor #f))))
#;(printf "begin lexing\n")
(when (coroutine-run 10 tok-cor)
(for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t))
lexer-states)
(update-lexer-state-observers)))
#;(printf "end lexing\n")
#;(printf "begin coloring\n")
;; This edit sequence needs to happen even when colors is null
;; for the paren highlighter.
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(color) (c-log "starting to color")
(set! re-tokenize-lses lexer-states)
(define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f))
(c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do")))
(when finished?
(for ([ls (in-list lexer-states)])
(set-lexer-state-up-to-date?! ls #t))
(update-lexer-state-observers)
(c-log "updated observers"))
(c-log "starting end-edit-sequence")
(end-edit-sequence) (end-edit-sequence)
#;(printf "end coloring\n"))) (c-log "finished end-edit-sequence")))
(define/private (colorer-callback) (define/private (colorer-callback)
(cond (cond
@ -1148,3 +1126,9 @@ added get-regions
(define text-mode% (text-mode-mixin mode:surrogate-text%)) (define text-mode% (text-mode-mixin mode:surrogate-text%))
(define misspelled-text-color-style-name "Misspelled Text") (define misspelled-text-color-style-name "Misspelled Text")
(define logger (make-logger 'framework/colorer (current-logger)))
(define-syntax-rule
(c-log exp)
(when (log-level? logger 'debug)
(log-message logger 'debug exp (current-inexact-milliseconds))))

225
collects/framework/private/follow-log.rkt Normal file
View File

@ -0,0 +1,225 @@
#lang racket/base
(require racket/list
racket/class
racket/match
racket/pretty
racket/gui/base
framework/private/logging-timer)
#|
This file sets up a log receiver and then
starts up DrRacket. It catches log messages and
organizes them on event boundaries, printing
out the ones that take the longest
(possibly dropping those where a gc occurs)
The result shows, for each gui event, the
log messages that occured during its dynamic
extent as well as the number of milliseconds
from the start of the gui event before the
log message was reported.
|#
(define lr (make-log-receiver (current-logger)
'debug 'racket/engine
'debug 'GC
'debug 'gui-event
'debug 'framework/colorer
'debug 'timeline))
(define top-n-events 50)
(define drop-gc? #t)
(define start-right-away? #f)
(define log-done-chan (make-channel))
(define bt-done-chan (make-channel))
(define start-log-chan (make-channel))
(void
(thread
(λ ()
(let loop ()
(sync start-log-chan)
(let loop ([events '()])
(sync
(handle-evt
lr
(λ (info)
(loop (cons info events))))
(handle-evt
log-done-chan
(λ (resp-chan)
(channel-put resp-chan events)))))
(loop)))))
(define thread-to-watch (current-thread))
(let ([win (get-top-level-windows)])
(unless (null? win)
(define fr-thd (eventspace-handler-thread (send (car win) get-eventspace)))
(unless (eq? thread-to-watch fr-thd)
(eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n"))))
(define start-bt-chan (make-channel))
(void
(thread
(λ ()
(let loop ()
(sync start-bt-chan)
(let loop ([marks '()])
(sync
(handle-evt
(alarm-evt (+ (current-inexact-milliseconds) 10))
(λ (_)
(loop (cons (continuation-marks thread-to-watch)
marks))))
(handle-evt
bt-done-chan
(λ (resp-chan)
(define stacks (map continuation-mark-set->context marks))
(channel-put resp-chan stacks)))))
(loop)))))
(define controller-frame-eventspace (make-eventspace))
(define f (parameterize ([current-eventspace controller-frame-eventspace])
(new frame% [label "Log Follower"])))
(define sb (new button% [label "Start Following Log"] [parent f]
[callback
(λ (_1 _2)
(sb-callback))]))
(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f]
[callback
(λ (_1 _2)
(start-bt-callback))]))
(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f]
[callback
(λ (_1 _2)
(cond
[following-log?
(define resp (make-channel))
(channel-put log-done-chan resp)
(show-results (channel-get resp))
(send db enable #f)
(send sb enable #t)
(send sb2 enable #t)
(set! following-log? #f)]
[following-bt?
(define resp (make-channel))
(channel-put bt-done-chan resp)
(define stacks (channel-get resp))
(show-bt-results stacks)
(send db enable #f)
(send sb enable #t)
(send sb2 enable #t)
(set! following-bt? #f)]))]))
(define following-log? #f)
(define following-bt? #f)
(define (sb-callback)
(set! following-log? #t)
(send sb enable #f)
(send sb2 enable #f)
(send db enable #t)
(channel-put start-log-chan #t))
(define (start-bt-callback)
(set! following-bt? #t)
(send sb enable #f)
(send sb2 enable #f)
(send db enable #t)
(channel-put start-bt-chan #t))
(send f show #t)
(define (show-bt-results stacks)
(define top-frame (make-hash))
(for ([stack (in-list stacks)])
(unless (null? stack)
(define k (car stack))
(hash-set! top-frame k (cons stack (hash-ref top-frame k '())))))
(define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length))
(printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10))))
(define most-popular (cadr sorted))
(for ([x (in-range 10)])
(printf "---- next stack\n")
(pretty-print (list-ref most-popular (random (length most-popular))))
(printf "\n"))
(void))
(struct gui-event (start end name) #:prefab)
(define (show-results evts)
(define gui-events (filter (λ (x)
(define i (vector-ref x 2))
(and (gui-event? i)
(number? (gui-event-end i))))
evts))
(define interesting-gui-events
(take (sort gui-events > #:key (λ (x)
(define i (vector-ref x 2))
(- (gui-event-end i)
(gui-event-start i))))
top-n-events))
(define with-other-events
(for/list ([gui-evt (in-list interesting-gui-events)])
(match (vector-ref gui-evt 2)
[(gui-event start end name)
(define in-the-middle
(append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x))
(sort
(filter (λ (x) (and (not (gui-event? (vector-ref x 2)))
(<= start (get-start-time x) end)))
evts)
<
#:key get-start-time))
(list (list (list 'δ (- end start)) 'end-of-gui-event))))
(list* (- end start)
gui-evt
in-the-middle)])))
(define (has-a-gc-event? x)
(define in-the-middle (cddr x))
(ormap (λ (x)
(and (vector? (list-ref x 1))
(gc-info? (vector-ref (list-ref x 1) 2))))
in-the-middle))
(pretty-print
(if drop-gc?
(filter (λ (x) (not (has-a-gc-event? x)))
with-other-events)
with-other-events)))
(struct gc-info (major? pre-amount pre-admin-amount code-amount
post-amount post-admin-amount
start-process-time end-process-time
start-time end-time)
#:prefab)
(struct engine-info (msec name) #:prefab)
(define (get-start-time x)
(cond
[(gc-info? (vector-ref x 2))
(gc-info-start-time (vector-ref x 2))]
[(engine-info? (vector-ref x 2))
(engine-info-msec (vector-ref x 2))]
[(regexp-match #rx"framework" (vector-ref x 1))
(vector-ref x 2)]
[(timeline-info? (vector-ref x 2))
(timeline-info-milliseconds (vector-ref x 2))]
[else
(unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1))
(eprintf "unk: ~s\n" x))
0]))
(module+ main
(when start-right-away?
(parameterize ([current-eventspace controller-frame-eventspace])
(queue-callback sb-callback)))
(dynamic-require 'drracket #f))

16
collects/framework/private/frame.rkt
View File

@ -796,9 +796,14 @@
[ec (new position-canvas% [ec (new position-canvas%
[parent panel] [parent panel]
[button-up [button-up
(λ () (λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'framework/private/follow-log #f)]
[else
(collect-garbage) (collect-garbage)
(update-memory-text))] (update-memory-text)]))]
[init-width "99.99 MB"])]) [init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases)) (set! memory-canvases (cons ec memory-canvases))
(update-memory-text) (update-memory-text)
@ -890,6 +895,7 @@
(inherit min-client-height min-client-width get-dc get-client-size refresh) (inherit min-client-height min-client-width get-dc get-client-size refresh)
(init init-width) (init init-width)
(init-field [button-up #f]) (init-field [button-up #f])
(init-field [char-typed void])
(define str "") (define str "")
(define/public (set-str _str) (define/public (set-str _str)
(set! str _str) (set! str _str)
@ -913,7 +919,11 @@
(let-values ([(cw ch) (get-client-size)]) (let-values ([(cw ch) (get-client-size)])
(when (and (<= (send evt get-x) cw) (when (and (<= (send evt get-x) cw)
(<= (send evt get-y) ch)) (<= (send evt get-y) ch))
(button-up)))))) (if (procedure-arity-includes? button-up 1)
(button-up evt)
(button-up)))))))
(define/override (on-char evt)
(char-typed evt))
(super-new (style '(transparent no-focus))) (super-new (style '(transparent no-focus)))
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])

2
collects/framework/private/keymap.rkt
View File

@ -337,7 +337,7 @@
[mouse-popup-menu [mouse-popup-menu
(λ (edit event) (λ (edit event)
(when (send event button-down?) (when (send event button-up?)
(let ([a (send edit get-admin)]) (let ([a (send edit get-admin)])
(when a (when a
(let ([m (make-object popup-menu%)]) (let ([m (make-object popup-menu%)])

66
collects/framework/private/logging-timer.rkt Normal file
View File

@ -0,0 +1,66 @@
#lang racket/base
(require racket/gui/base
racket/class
(for-syntax racket/base))
(define timeline-logger (make-logger 'timeline (current-logger)))
(provide logging-timer%
(struct-out timeline-info)
log-timeline)
(define logging-timer%
(class timer%
(init notify-callback)
(define name (object-name notify-callback))
(define wrapped-notify-callback
(λ ()
(log-timeline
(format "~a timer fired" name)
(notify-callback))))
(super-new [notify-callback wrapped-notify-callback])
(define/override (start msec [just-once? #f])
(log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?))
(super start msec just-once?))))
(define-syntax (log-timeline stx)
(syntax-case stx ()
[(_ info-string expr)
#'(log-timeline/proc
(and (log-level? timeline-logger 'debug)
info-string)
(λ () expr))]
[(_ info-string)
#'(log-timeline/proc
(and (log-level? timeline-logger 'debug)
info-string)
#f)]))
(define (log-timeline/proc info expr)
(define start-time (current-inexact-milliseconds))
(when info
(log-message timeline-logger 'debug
(format "~a start" info)
(timeline-info (if expr 'start 'once)
(current-process-milliseconds)
start-time)))
(when expr
(begin0
(expr)
(when info
(define end-time (current-inexact-milliseconds))
(log-message timeline-logger 'debug
(format "~a end; delta ms ~a" info (- end-time start-time))
(timeline-info start-time
end-time
(current-inexact-milliseconds)))))))
;; what : (or/c 'start 'once flonum)
;; flonum means that this is an 'end' event and there should be
;; a start event corresponding to it with that milliseconds
;; process-milliseconds : fixnum
;; milliseconds : flonum -- time of this event
(struct timeline-info (what process-milliseconds milliseconds) #:transparent)

15
collects/framework/private/text.rkt
View File

@ -11,7 +11,8 @@
"autocomplete.rkt" "autocomplete.rkt"
mred/mred-sig mred/mred-sig
mrlib/interactive-value-port mrlib/interactive-value-port
racket/list) racket/list
"logging-timer.rkt")
(require setup/xref (require setup/xref
scribble/xref scribble/xref
scribble/manual-struct) scribble/manual-struct)
@ -1063,7 +1064,7 @@
(when searching-str (when searching-str
(unless timer (unless timer
(set! timer (set! timer
(new timer% (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
(run-after-edit-sequence (run-after-edit-sequence
@ -1536,7 +1537,7 @@
;; have not yet been propogated to the delegate ;; have not yet been propogated to the delegate
(define todo '()) (define todo '())
(define timer (new timer% (define timer (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
;; it should be the case that todo is always '() when the delegate is #f ;; it should be the case that todo is always '() when the delegate is #f
@ -3854,7 +3855,9 @@ designates the character that triggers autocompletion
;; draws line numbers on the left hand side of a text% object ;; draws line numbers on the left hand side of a text% object
(define line-numbers-mixin (define line-numbers-mixin
(mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>)
(inherit get-visible-line-range (inherit begin-edit-sequence
end-edit-sequence
get-visible-line-range
get-visible-position-range get-visible-position-range
last-line last-line
line-location line-location
@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion
(when (showing-line-numbers?) (when (showing-line-numbers?)
(define dc (get-dc)) (define dc (get-dc))
(when dc (when dc
(begin-edit-sequence #f #f)
(define bx (box 0)) (define bx (box 0))
(define by (box 0)) (define by (box 0))
(define tw (text-width dc (number-space+1))) (define tw (text-width dc (number-space+1)))
@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion
tw tw
th) th)
(unless (= line (last-line)) (unless (= line (last-line))
(loop (+ line 1)))))))) (loop (+ line 1)))))
(end-edit-sequence))))
(super-new) (super-new)
(setup-padding))) (setup-padding)))

22
collects/framework/test.rkt
View File

@ -253,22 +253,26 @@
(define object-tag 'test:find-object) (define object-tag 'test:find-object)
;; find-object : class (union string (object -> boolean)) -> object ;; find-object : class (union string regexp (object -> boolean)) -> object
(define (find-object obj-class b-desc) (define (find-object obj-class b-desc)
(λ () (λ ()
(cond (cond
[(or (string? b-desc) [(or (string? b-desc)
(regexp? b-desc)
(procedure? b-desc)) (procedure? b-desc))
(let* ([active-frame (test:get-active-top-level-window)] (let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame [_ (unless active-frame
(error object-tag (error object-tag
"could not find object: ~a, no active frame" "could not find object: ~e, no active frame"
b-desc))] b-desc))]
[child-matches? [child-matches?
(λ (child) (λ (child)
(cond (cond
[(string? b-desc) [(string? b-desc)
(equal? (send child get-label) b-desc)] (equal? (send child get-label) b-desc)]
[(regexp? b-desc)
(and (send child get-label)
(regexp-match? b-desc (send child get-label)))]
[(procedure? b-desc) [(procedure? b-desc)
(b-desc child)]))] (b-desc child)]))]
[found [found
@ -287,13 +291,13 @@
(send panel get-children)))]) (send panel get-children)))])
(or found (or found
(error object-tag (error object-tag
"no object of class ~a named ~e in active frame" "no object of class ~e named ~e in active frame"
obj-class obj-class
b-desc)))] b-desc)))]
[(is-a? b-desc obj-class) b-desc] [(is-a? b-desc obj-class) b-desc]
[else (error [else (error
object-tag object-tag
"expected either a string or an object of class ~a as input, received: ~a" "expected either a string or an object of class ~e as input, received: ~e"
obj-class b-desc)]))) obj-class b-desc)])))
@ -936,7 +940,8 @@
(proc-doc/names (proc-doc/names
test:keystroke test:keystroke
(->* ((or/c char? symbol?)) (->* ((or/c char? symbol?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift))) ((listof (or/c 'alt 'control 'meta 'shift
'noalt 'nocontrol 'nometea 'noshift)))
void?) void?)
((key) ((key)
((modifier-list null))) ((modifier-list null)))
@ -973,10 +978,11 @@
(proc-doc/names (proc-doc/names
test:mouse-click test:mouse-click
(->* (->*
((symbols 'left 'middle 'right) ((or/c 'left 'middle 'right)
(and/c exact? integer?) (and/c exact? integer?)
(and/c exact? integer?)) (and/c exact? integer?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))) ((listof (or/c 'alt 'control 'meta 'shift 'noalt
'nocontrol 'nometa 'noshift)))
void?) void?)
((button x y) ((button x y)
((modifiers null))) ((modifiers null)))
@ -985,7 +991,7 @@
@method[canvas<%> on-event] method. @method[canvas<%> on-event] method.
Use @racket[test:button-push] to click on a button. Use @racket[test:button-push] to click on a button.
On the Macintosh, @racket['right] corresponds to holding down the command Under Mac OS X, @racket['right] corresponds to holding down the command
modifier key while clicking and @racket['middle] cannot be generated. modifier key while clicking and @racket['middle] cannot be generated.
Under Windows, @racket['middle] can only be generated if the user has a Under Windows, @racket['middle] can only be generated if the user has a

3
collects/frtime/animation/graphics-sig.rkt
View File

@ -1,4 +1,5 @@
#lang racket #lang racket/base
(require racket/unit) (require racket/unit)
(provide graphics^ graphics:posn-less^ graphics:posn^) (provide graphics^ graphics:posn-less^ graphics:posn^)

3
collects/frtime/animation/graphics-unit.rkt
View File

@ -1,4 +1,5 @@
#lang racket #lang racket/base
(require racket/unit (require racket/unit
mred/mred-sig mred/mred-sig
"graphics-sig.rkt" "graphics-sig.rkt"

3
collects/frtime/animation/graphics.rkt
View File

@ -1,4 +1,5 @@
#lang racket #lang racket/base
(require racket/unit (require racket/unit
mred/mred-sig mred/mred-sig
mred mred

7
collects/frtime/core/contract.rkt
View File

@ -1,8 +1,9 @@
#lang racket #lang racket/base
#;(require (for-syntax racket/contract))
(define-syntax-rule (provide/contract* [id ctrct] ...) (define-syntax-rule (provide/contract* [id ctrct] ...)
#;(provide/contract [id ctrct] ...) #;(provide/contract [id ctrct] ...)
(provide id ...)) (provide id ...))
(provide (provide provide/contract*)
provide/contract*)

6
collects/frtime/core/dv.rkt
View File

@ -1,5 +1,7 @@
#lang racket #lang racket/base
(require "contract.rkt")
(require racket/match
"contract.rkt")
(define-struct dv (vec-length next-avail-pos vec) #:mutable) (define-struct dv (vec-length next-avail-pos vec) #:mutable)

7
collects/frtime/core/erl.rkt
View File

@ -1,5 +1,8 @@
#lang racket #lang racket/base
(require "match.rkt"
(require racket/bool
racket/match
"match.rkt"
"contract.rkt" "contract.rkt"
#;"sema-mailbox.rkt" #;"sema-mailbox.rkt"
"mailbox.rkt") "mailbox.rkt")

9
collects/frtime/core/frp.rkt
View File

@ -1,5 +1,10 @@
#lang racket #lang racket/base
(require "contract.rkt"
(require racket/function
racket/list
racket/match
racket/contract
"contract.rkt"
"erl.rkt" "erl.rkt"
"heap.rkt") "heap.rkt")

8
collects/frtime/core/heap.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require "dv.rkt"
(require racket/bool
racket/match
racket/contract
"dv.rkt"
"contract.rkt") "contract.rkt")
(define-struct t (sorter equality data)) (define-struct t (sorter equality data))

8
collects/frtime/core/mailbox.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require "contract.rkt"
(require racket/bool
racket/list
racket/match
"contract.rkt"
"match.rkt" "match.rkt"
racket/async-channel) racket/async-channel)

2
collects/frtime/core/match.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
(define-struct a-match-fail ()) (define-struct a-match-fail ())
(define match-fail (make-a-match-fail)) (define match-fail (make-a-match-fail))

8
collects/frtime/core/sema-mailbox.rkt
View File

@ -1,5 +1,9 @@
#lang racket #lang racket/base
(require "match.rkt"
(require racket/list
racket/bool
racket/match
"match.rkt"
"contract.rkt") "contract.rkt")
(define (call-with-semaphore s thunk) (define (call-with-semaphore s thunk)

24
collects/frtime/develop-frtime.rkt
View File

@ -1,6 +1,6 @@
#lang racket #lang racket/base
(require setup/link)
(require setup/link)
#|Update this to point to your racket installation directory|# #|Update this to point to your racket installation directory|#
(define install-path "C:/Program Files/Racket/collects/frtime") (define install-path "C:/Program Files/Racket/collects/frtime")
@ -9,20 +9,16 @@
(define dev-path "C:/Users/user/Documents/GitHub/racket/collects/frtime") (define dev-path "C:/Users/user/Documents/GitHub/racket/collects/frtime")
#|Then call one of these functions to begin developing frtime, or to halt development.|# #|Then call one of these functions to begin developing frtime, or to halt development.|#
(define start-developing-frtime (define (start-developing-frtime)
(lambda () (start-developing-collection dev-path install-path))
(start-developing-collection dev-path install-path)))
(define stop-developing-frtime (define (stop-developing-frtime)
(lambda () (stop-developing-collection dev-path install-path))
(stop-developing-collection dev-path install-path)))
(define start-developing-collection (define (start-developing-collection dev-coll-path install-coll-path)
(lambda (dev-coll-path install-coll-path)
(links install-coll-path #:remove? #t) (links install-coll-path #:remove? #t)
(links dev-coll-path))) (links dev-coll-path))
(define stop-developing-collection (define (stop-developing-collection dev-coll-path install-coll-path)
(lambda (dev-coll-path install-coll-path) (start-developing-collection install-coll-path dev-coll-path))
(start-developing-collection install-coll-path dev-coll-path)))

7
collects/frtime/frlibs/date.rkt
View File

@ -1,6 +1,7 @@
#lang racket #lang racket/base
(require (rename-in (only-in frtime/frtime provide)
[provide frtime:provide])) (require racket/promise
(only-in frtime/frtime [provide frtime:provide]))
(frtime:provide (lifted date->string (frtime:provide (lifted date->string
date-display-format date-display-format

4
collects/frtime/opt/lowered-equivs.rkt
View File

@ -1,10 +1,10 @@
;; This module defines all the logic necessary for working with lowered ;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply ;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers. ;; as syntactic identifiers.
#lang racket #lang racket/base
(provide (except-out (all-defined-out) (provide (except-out (all-defined-out)
module-identifier=?)) module-identifier=?))
(require (only-in srfi/1 any))
(define module-identifier=? free-identifier=?) (define module-identifier=? free-identifier=?)

8
collects/future-visualizer/private/graph-drawing.rkt
View File

@ -1,6 +1,10 @@
#lang racket #lang racket/base
(require rackunit
(require racket/list
racket/contract
;; rackunit
"constants.rkt") "constants.rkt")
(provide (struct-out point) (provide (struct-out point)
(struct-out node) (struct-out node)
(struct-out drawable-node) (struct-out drawable-node)

2
collects/future-visualizer/scribblings/common.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
(require (for-label racket/base) (require (for-label racket/base)
scribble/manual scribble/manual

25
collects/future-visualizer/scribblings/futures-trace.scrbl
View File

@ -1,5 +1,7 @@
#lang scribble/doc #lang scribble/doc
@(require "common.rkt" (for-label racket/future future-visualizer/trace)) @(require "common.rkt"
(for-label racket/future
future-visualizer/trace))
@title[#:tag "futures-trace"]{Futures Tracing} @title[#:tag "futures-trace"]{Futures Tracing}
@ -63,10 +65,11 @@ the execution of parallel programs written using @racket[future].
} }
@defstruct[indexed-future-event ([index exact-nonnegative-integer?] @defstruct[indexed-future-event ([index exact-nonnegative-integer?]
[event (or future-event? gc-info?)])]{ [event any])]{
Represents an individual log message in a program trace. In addition to Represents an individual log message in a program trace. In addition to
future events, the tracing code also records garbage collection events; hence future events, the tracing code also records garbage collection events; hence
the @racket[event] field may contain either a @racket[future-event] or @racket[gc-info], the @racket[event] field may contain either a @racket[future-event] or gc-info
@(tech "prefab" #:doc '(lib "scribblings/reference/reference.scrbl")) struct (see @refsecref["garbagecollection"]),
where the latter describes a GC operation. Because multiple where the latter describes a GC operation. Because multiple
@racket[future-event] structures may contain identical timestamps, the @racket[future-event] structures may contain identical timestamps, the
@racket[index] field ranks them in the order in which they were recorded @racket[index] field ranks them in the order in which they were recorded
@ -82,19 +85,3 @@ the execution of parallel programs written using @racket[future].
#:prefab]{ #:prefab]{
Represents a future event as logged by the run-time system. See Represents a future event as logged by the run-time system. See
@refsecref["future-logging"] for more information.} @refsecref["future-logging"] for more information.}
@defstruct[gc-info ([major? boolean?]
[pre-used integer?]
[pre-admin integer?]
[code-page-total integer?]
[post-used integer?]
[post-admin integer?]
[start-time integer?]
[end-time integer?]
[start-real-time real?]
[end-real-time real?])
#:prefab]{
Represents a garbage collection. The only fields used by the visualizer
are @racket[start-real-time] and @racket[end-real-time], which are inexact
numbers representing time in the same way as @racket[current-inexact-milliseconds].
}

6
collects/games/paint-by-numbers/solve.rkt
View File

@ -1,5 +1,3 @@
(module solve mzscheme (module solve mzscheme
(require mzlib/list (require mzlib/list
@ -14,7 +12,7 @@
void)]) void)])
(define (solve row-info col-info set-entry setup-progress) (define (solve row-info col-info set-entry setup-progress)
(local ( (local [
(define (pause) '(sleep 1/16)) (define (pause) '(sleep 1/16))
; all test cases are commented out. ; all test cases are commented out.
@ -668,7 +666,7 @@
(outer-loop board (next-threshold skip-threshold) row-tries col-tries) (outer-loop board (next-threshold skip-threshold) row-tries col-tries)
(outer-loop board skip-threshold row-tries col-tries))))))))) (outer-loop board skip-threshold row-tries col-tries)))))))))
) ]
(local-solve row-info col-info) (local-solve row-info col-info)
))) )))

27
collects/gui-debugger/debug-tool.rkt
View File

@ -1,14 +1,14 @@
#lang racket #lang racket/base
;; DrRacket's debugging tool ;; DrRacket's debugging tool
(require mzlib/etc (require racket/function
mzlib/list racket/list
mzlib/class racket/class
mzlib/unit racket/unit
mzlib/contract racket/contract
mred racket/match
mzlib/match racket/gui
drscheme/tool drscheme/tool
"marks.rkt" "marks.rkt"
mrlib/switchable-button mrlib/switchable-button
@ -20,7 +20,8 @@
string-constants string-constants
lang/debugger-language-interface lang/debugger-language-interface
images/compile-time images/compile-time
(for-syntax racket/class (for-syntax racket/base
racket/class
racket/draw racket/draw
images/icons/arrow images/icons/arrow
images/icons/control images/icons/control
@ -112,7 +113,7 @@
;; (<form>) => (<form>) ;; (<form>) => (<form>)
;; (<form> <arg1> ... <argn>) => (<form> ...) ;; (<form> <arg1> ... <argn>) => (<form> ...)
(define trim-expr-str (define trim-expr-str
(opt-lambda (str [len 10]) (lambda (str [len 10])
(let* ([strlen (string-length str)] (let* ([strlen (string-length str)]
[starts-with-paren (and (> strlen 0) [starts-with-paren (and (> strlen 0)
(char=? (string-ref str 0) #\())] (char=? (string-ref str 0) #\())]
@ -157,7 +158,7 @@
[else v])) [else v]))
(define filename->defs (define filename->defs
(opt-lambda (source [default #f]) (lambda (source [default #f])
(let/ec k (let/ec k
(cond (cond
[(is-a? source editor<%>) source] [(is-a? source editor<%>) source]
@ -985,7 +986,7 @@
(rest frames)))))) (rest frames))))))
(define/public suspend-gui (define/public suspend-gui
(opt-lambda (frames status [switch-tabs? #f] [already-stopped? #f]) (lambda (frames status [switch-tabs? #f] [already-stopped? #f])
(let ([top-of-stack? (zero? (get-frame-num))] (let ([top-of-stack? (zero? (get-frame-num))]
[status-message (send (get-frame) get-status-message)]) [status-message (send (get-frame) get-status-message)])
(set! want-suspend-on-break? #f) (set! want-suspend-on-break? #f)
@ -1052,7 +1053,7 @@
(define/public suspend (define/public suspend
;; ==called from user thread== ;; ==called from user thread==
(opt-lambda (break-handler frames [status #f]) (lambda (break-handler frames [status #f])
;; suspend-sema ensures that we allow only one suspended thread ;; suspend-sema ensures that we allow only one suspended thread
;; at a time ;; at a time
(cond (cond

2
collects/honu/core/api.rkt
View File

@ -5,10 +5,12 @@
(require "private/syntax.rkt" (require "private/syntax.rkt"
"private/literals.rkt" "private/literals.rkt"
(for-syntax "private/compile.rkt" (for-syntax "private/compile.rkt"
"private/syntax.rkt"
"private/parse2.rkt")) "private/parse2.rkt"))
(provide define-honu-syntax (provide define-honu-syntax
define-literal define-literal
(for-syntax racket-syntax (for-syntax racket-syntax
honu-expression honu-expression
honu-syntax
honu-body honu-body
parse-all)) parse-all))

2
collects/honu/core/main.rkt
View File

@ -9,6 +9,7 @@
"private/macro2.rkt" "private/macro2.rkt"
"private/class.rkt" "private/class.rkt"
"private/operator.rkt" "private/operator.rkt"
"private/syntax.rkt"
(prefix-in literal: "private/literals.rkt") (prefix-in literal: "private/literals.rkt")
(prefix-in syntax-parse: syntax/parse) (prefix-in syntax-parse: syntax/parse)
(prefix-in racket: racket/base) (prefix-in racket: racket/base)
@ -35,6 +36,7 @@
[honu-while while] [honu-while while]
[honu-macro macro] [honu-macro macro]
[honu-phase phase] [honu-phase phase]
[honu-racket racket]
[honu-primitive-macro primitive_macro] [honu-primitive-macro primitive_macro]
[honu-pattern pattern] [honu-pattern pattern]
[racket:read-line readLine] [racket:read-line readLine]

285
collects/honu/core/private/macro2.rkt
View File

@ -7,11 +7,11 @@
racket/syntax racket/syntax
"template.rkt" "template.rkt"
"literals.rkt" "literals.rkt"
"syntax.rkt"
(prefix-in phase1: "parse2.rkt") (prefix-in phase1: "parse2.rkt")
"debug.rkt" "debug.rkt"
(prefix-in phase1: "compile.rkt") (prefix-in phase1: "compile.rkt")
"util.rkt" "util.rkt"
(prefix-in syntax: syntax/parse/private/residual-ct)
racket/base) racket/base)
(for-meta 2 syntax/parse (for-meta 2 syntax/parse
racket/base racket/base
@ -28,6 +28,9 @@
"literals.rkt" "literals.rkt"
"syntax.rkt" "syntax.rkt"
"debug.rkt" "debug.rkt"
(for-meta 0 "template.rkt" syntax/stx)
(for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt") (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt")
#; #;
(for-syntax "honu-typed-scheme.rkt") (for-syntax "honu-typed-scheme.rkt")
@ -37,14 +40,30 @@
(require syntax/parse (require syntax/parse
"literals.rkt" "literals.rkt"
"debug.rkt" "debug.rkt"
"util.rkt"
(prefix-in syntax: syntax/parse/private/residual-ct)
racket/syntax racket/syntax
racket/set racket/set
racket/match
(for-syntax syntax/parse
racket/base
racket/syntax)
(for-template racket/base (for-template racket/base
syntax/parse)) syntax/parse))
(provide (all-defined-out)) (provide (all-defined-out))
(struct pattern-variable [name original depth class] #:transparent) (struct pattern-variable [name original depth class] #:transparent)
;; given the name of an object and some fields this macro defines
;; name.field for each of the fields
(define-syntax (define-struct-fields stx)
(syntax-parse stx
[(_ name type (field ...))
(with-syntax ([(field* ...)
(for/list ([field (syntax->list #'(field ...))])
(format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))])
#'(match-define (struct type (field* ...)) name))]))
;; makes a syntax object with the right number of nested ellipses patterns ;; makes a syntax object with the right number of nested ellipses patterns
(define (pattern-variable->syntax variable) (define (pattern-variable->syntax variable)
(debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable)) (debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable))
@ -126,6 +145,83 @@
(define variables (find (reverse-syntax original-pattern))) (define variables (find (reverse-syntax original-pattern)))
(debug 2 "Found variables ~a\n" variables) (debug 2 "Found variables ~a\n" variables)
(for/list ([x variables]) x)) (for/list ([x variables]) x))
;; variable is the original pattern variable, like 'foo'
;; and new-name is the new generated name, 'temp1'
;; we want to bind all the attributes from temp1 to foo, so if temp1 has
;; temp1_a
;; temp1_b ...
;;
;; we want to bind
;; foo_a temp_a
;; (foo_b ...) (temp_b ...)
(define (bind-attributes variable new-name)
(debug "Syntax class of ~a is ~a at ~a\n"
(pattern-variable-class variable)
(syntax-local-value (pattern-variable-class variable) (lambda () #f))
(syntax-local-phase-level))
(define attributes
(let ([syntax-class (syntax-local-value (pattern-variable-class variable))])
(for/list ([attribute (syntax:stxclass-attrs syntax-class)])
(pattern-variable (syntax:attr-name attribute)
(pattern-variable-original variable)
(+ (pattern-variable-depth variable)
(syntax:attr-depth attribute))
#f))))
(define (mirror-attribute attribute)
(debug "Mirror attribute ~a\n" attribute)
(define-struct-fields attribute pattern-variable
(name original depth class))
;; create a new pattern variable with a syntax object that uses
;; the given lexical context and whose name is prefix_suffix
(define (create lexical prefix suffix)
(pattern-variable->syntax
(pattern-variable (format-id lexical "~a_~a" prefix suffix)
attribute.original attribute.depth attribute.class)))
(define-struct-fields variable pattern-variable
(name original depth class))
(debug "Bind attributes ~a ~a\n" variable.name attribute.name)
(with-syntax ([bind-attribute
#;
(create name (syntax-e name) name)
(pattern-variable->syntax
(pattern-variable (format-id variable.name "~a_~a"
(syntax-e variable.name)
attribute.name)
attribute.original
attribute.depth
attribute.class))]
[new-attribute
#;
(create new-name new-name name)
(pattern-variable->syntax
(pattern-variable
(format-id new-name "~a_~a"
new-name
attribute.name)
attribute.original attribute.depth #f))])
(debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
#'(#:with bind-attribute #'new-attribute)))
(for/set ([attribute attributes])
(mirror-attribute attribute)))
;; returns a set of #:with clauses for syntax-parse that
;; bind all the old variables and their attributes to some new names
;; taking care of ellipses depth
(define (pattern-variables+attributes variables use)
(for/union ([old variables]
[new use])
(define-struct-fields old pattern-variable (name original depth class))
(with-syntax ([old-syntax (pattern-variable->syntax old)]
[new.result (pattern-variable->syntax
(pattern-variable (format-id new "~a_result" new)
old.original
old.depth
old.class))])
(set-union (set #'(#:with old-syntax #'new.result))
(bind-attributes old new)))))
) )
(require (for-meta 2 (submod "." analysis))) (require (for-meta 2 (submod "." analysis)))
@ -238,34 +334,6 @@
(syntax #'stuff*))]))) (syntax #'stuff*))])))
|# |#
(provide honu-syntax)
;; Do any honu-specific expansion here
(define-honu-syntax honu-syntax
(lambda (code)
(syntax-parse code #:literal-sets (cruft)
#;
[(_ (#%parens single) . rest)
(define context #'single)
(define compressed (compress-dollars #'single))
(values
(with-syntax ([stuff* (datum->syntax context compressed context context)])
(phase1:racket-syntax #'stuff*))
#'rest
#f)]
[(_ (#%parens stuff ...) . rest)
(define context (stx-car #'(stuff ...)))
(define compressed (compress-dollars #'(stuff ...)))
(values
(with-syntax ([stuff* (datum->syntax context
(syntax->list compressed)
context context)])
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
(with-syntax ([(out ...) #'stuff*])
(phase1:racket-syntax #'stuff*)))
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))
;; combine syntax objects ;; combine syntax objects
;; #'(a b) + #'(c d) = #'(a b c d) ;; #'(a b) + #'(c d) = #'(a b c d)
@ -301,20 +369,11 @@
(begin-for-syntax (begin-for-syntax
(define-syntax (generate-pattern stx) (define-syntax (generate-pattern stx)
;; given the name of an object and some fields this macro defines
;; name.field for each of the fields
(define-syntax (define-struct-fields stx)
(syntax-parse stx (syntax-parse stx
[(_ name type (field ...)) [(_ name literals (pattern-stx out-stx) ...)
(with-syntax ([(field* ...)
(for/list ([field (syntax->list #'(field ...))])
(format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))])
#'(match-define (struct type (field* ...)) name))]))
(syntax-parse stx (define (make-syntax-class-pattern honu-pattern maybe-out)
[(_ name literals original-pattern maybe-out) (define variables (find-pattern-variables honu-pattern))
(define variables (find-pattern-variables #'original-pattern))
(define use (generate-temporaries variables)) (define use (generate-temporaries variables))
(define mapping (make-hash)) (define mapping (make-hash))
(for ([old variables] (for ([old variables]
@ -327,98 +386,43 @@
(pattern-variable-depth old) (pattern-variable-depth old)
(pattern-variable-class old)))) (pattern-variable-class old))))
;; variable is the original pattern variable, like 'foo' (define withs (pattern-variables+attributes variables use))
;; and new-name is the new generated name, 'temp1'
;; we want to bind all the attributes from temp1 to foo, so if temp1 has (with-syntax ([(new-pattern ...) (convert-pattern honu-pattern mapping)]
;; temp1_a [((withs ...) ...) (set->list withs)]
;; temp1_b ... [(result-with ...) (if (syntax-e maybe-out)
;; (with-syntax ([(out ...) maybe-out])
;; we want to bind #'(#:with result (parse-stuff honu-syntax (#%parens out ...))))
;; foo_a temp_a #'(#:with result #'()))])
;; (foo_b ...) (temp_b ...) (syntax/loc honu-pattern
(define (bind-attributes variable new-name) [pattern (~seq new-pattern ...)
(debug "Syntax class of ~a is ~a at ~a\n" withs ... ...
(pattern-variable-class variable) result-with ...
(syntax-local-value (pattern-variable-class variable) (lambda () #f)) ])))
(syntax-local-phase-level))
(define attributes (define pattern-stuff
(let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) (for/list ([pattern (syntax->list #'(pattern-stx ...))]
(for/list ([attribute (syntax:stxclass-attrs syntax-class)]) [out (syntax->list #'(out-stx ...))])
(pattern-variable (syntax:attr-name attribute) (make-syntax-class-pattern pattern out)))
(pattern-variable-original variable)
(+ (pattern-variable-depth variable)
(syntax:attr-depth attribute))
#f))))
(define (mirror-attribute attribute)
(debug "Mirror attribute ~a\n" attribute)
;; create a new pattern variable with a syntax object that uses
;; the given lexical context and whose name is prefix_suffix
(define-struct-fields attribute pattern-variable
(name original depth class))
(define (create lexical prefix suffix)
(pattern-variable->syntax
(pattern-variable (format-id lexical "~a_~a" prefix suffix)
attribute.original attribute.depth attribute.class)))
(define-struct-fields variable pattern-variable
(name original depth class))
(debug "Bind attributes ~a ~a\n" variable.name attribute.name)
(with-syntax ([bind-attribute
#; #;
(create name (syntax-e name) name)
(pattern-variable->syntax
(pattern-variable (format-id variable.name "~a_~a"
(syntax-e variable.name)
attribute.name)
attribute.original
attribute.depth
attribute.class))]
[new-attribute
#;
(create new-name new-name name)
(pattern-variable->syntax
(pattern-variable
(format-id new-name "~a_~a"
new-name
attribute.name)
attribute.original attribute.depth #f))])
(debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
#'(#:with bind-attribute #'new-attribute)))
(for/set ([attribute attributes])
(mirror-attribute attribute)))
(define withs
(for/union ([old variables]
[new use])
(define-struct-fields old pattern-variable (name original depth class))
(with-syntax ([old-syntax (pattern-variable->syntax old)]
[new.result (pattern-variable->syntax
(pattern-variable (format-id new "~a_result" new)
old.original
old.depth
old.class))])
(set-union (set #'(#:with old-syntax #'new.result))
(bind-attributes old new)))))
(debug "With bindings ~a\n" withs) (debug "With bindings ~a\n" withs)
(with-syntax ([(literal ...) #'literals] (with-syntax ([(literal ...) #'literals]
[(new-pattern ...) (convert-pattern #'original-pattern mapping)] [(new-pattern ...) pattern-stuff])
[((withs ...) ...) (set->list withs)] #;
[(result-with ...) (if (syntax-e #'maybe-out)
(with-syntax ([(out ...) #'maybe-out])
#'(#:with result (out ...)))
#'(#:with result #'()))])
(debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...)))) (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...))))
(define output (define output
#'(quote-syntax #'(quote-syntax
(begin (begin
;; define at phase1 so we can use it ;; define at phase1 so we can use it in a macro
(begin-for-syntax (begin-for-syntax
(define-literal-set local-literals (literal ...)) (define-literal-set local-literals (literal ...))
(define-splicing-syntax-class name (define-splicing-syntax-class name
#:literal-sets ([cruft #:at name] #:literal-sets ([cruft #:at name]
[local-literals #:at name]) [local-literals #:at name])
new-pattern ...
#;
[pattern (~seq new-pattern ...) [pattern (~seq new-pattern ...)
withs ... ... withs ... ...
result-with ... result-with ...
@ -432,10 +436,12 @@
(lambda (code) (lambda (code)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens literal ...) [(_ name (#%parens literal ...)
(#%braces pattern ...) (~seq (#%braces original-pattern ...)
(~optional (#%braces out ...)) (~optional (~seq honu-comma maybe-out)
#:defaults ([maybe-out #'#f])))
...
. rest) . rest)
(values (with-syntax ([out* (attribute out)]) (values
(phase1:racket-syntax (phase1:racket-syntax
(splicing-let-syntax (splicing-let-syntax
([make (lambda (stx) ([make (lambda (stx)
@ -444,9 +450,9 @@
(syntax-local-introduce (syntax-local-introduce
(generate-pattern name (generate-pattern name
(literal ...) (literal ...)
(pattern ...) ((original-pattern ...) maybe-out)
out*))]))]) ...))]))])
(make name)))) (make name)))
#'rest #'rest
#f)]))) #f)])))
@ -459,3 +465,30 @@
(define out (define out
(phase1:racket-syntax (begin-for-syntax (parse-stuff body ...)))) (phase1:racket-syntax (begin-for-syntax (parse-stuff body ...))))
(values out #'rest #t)]))) (values out #'rest #t)])))
;; not sure this is useful but it lets you write racket syntax expressions
;; from inside honu. the main issue is all the bindings available
;; are honu bindings so things like (+ 1 x) wont work.
(provide honu-racket)
(define-honu-syntax honu-racket
(lambda (code)
(define (remove-cruft stx)
(syntax-parse stx #:literal-sets (cruft)
[(#%parens inside ...)
(remove-cruft #'(inside ...))]
[(#%braces inside ...)
(remove-cruft #'(inside ...))]
[(#%brackets inside ...)
(remove-cruft #'(inside ...))]
[(head rest ...)
(with-syntax ([head* (remove-cruft #'head)]
[(rest* ...) (remove-cruft #'(rest ...))])
#'(head* rest* ...))]
[x #'x]))
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens stx ...) . rest)
(define out
(with-syntax ([(stx* ...) (remove-cruft #'(stx ...))])
(phase1:racket-syntax (phase0:racket-syntax (stx* ...)))))
(values out #'rest #t)])))

5
collects/honu/core/private/parse2.rkt
View File

@ -316,7 +316,10 @@
(do-parse #'(parsed ... rest ...) (do-parse #'(parsed ... rest ...)
precedence left current) precedence left current)
;; (debug "Remove repeats from ~a\n" #'parsed) ;; (debug "Remove repeats from ~a\n" #'parsed)
(define re-parse (remove-repeats #'parsed) (define re-parse
#'parsed
#;
(remove-repeats #'parsed)
#; #;
(with-syntax ([(x ...) #'parsed]) (with-syntax ([(x ...) #'parsed])
(debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed)) (debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed))

49
collects/honu/core/private/syntax.rkt
View File

@ -1,8 +1,9 @@
#lang racket #lang racket/base
(provide (all-defined-out)) (provide (all-defined-out))
(require (for-syntax syntax/define (require (for-syntax racket/base
syntax/define
"transformer.rkt")) "transformer.rkt"))
#| #|
@ -22,3 +23,47 @@
[rhs rhs]) [rhs rhs])
(syntax/loc stx (syntax/loc stx
(define-syntax id (make-honu-transformer rhs)))))) (define-syntax id (make-honu-transformer rhs))))))
;; Do any honu-specific expansion here
(require (for-syntax
"template.rkt" ;; for compress-dollars at phase 1
"compile.rkt"
"literals.rkt"
syntax/stx
syntax/parse)
"template.rkt") ;; for remove-repeats at phase 0
(define-honu-syntax honu-syntax
(lambda (code)
(syntax-parse code #:literal-sets (cruft)
#;
[(_ (#%parens single) . rest)
(define context #'single)
(define compressed (compress-dollars #'single))
(values
(with-syntax ([stuff* (datum->syntax context compressed context context)])
(phase1:racket-syntax #'stuff*))
#'rest
#f)]
[(_ (#%parens stuff ...) . rest)
(define context (stx-car #'(stuff ...)))
(define compressed (compress-dollars #'(stuff ...)))
(values
(with-syntax ([stuff* (datum->syntax context
(syntax->list compressed)
context context)])
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
;; stuff* will be expanded when this syntax is returned because
;; the whole thing will be
;; (remove-repeats #'((repeat$ 1) (repeat$ 2)))
;; so remove-repeats will be executed later
(racket-syntax
(remove-repeats #'stuff*))
#;
(with-syntax ([(out ...) #'stuff*])
(phase1:racket-syntax #'stuff*)))
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))

10
collects/honu/syntax.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang honu
/* Standard syntax-rules but as a macro-defining form */
provide macro_rules;
macro macro_rules(){
name:identifier (literal ...){ pattern ... }{ template ... }
} {
syntax(macro name (literal ...){ pattern ... }{ syntax(template ...) })
}

2
collects/htdp/convert.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
(require racket/gui) (require racket/gui)

2
collects/htdp/dir.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
(provide (provide
;; map the directory tree at the given path into a data representation according to model 3 of ;; map the directory tree at the given path into a data representation according to model 3 of

6
collects/images/icons/style.rkt
View File

@ -1,10 +1,10 @@
#lang racket #lang racket/base
(require racket/draw unstable/parameter-group (require racket/class racket/draw unstable/parameter-group
racket/contract unstable/latent-contract unstable/latent-contract/defthing racket/contract unstable/latent-contract unstable/latent-contract/defthing
"../private/flomap.rkt" "../private/flomap.rkt"
"../private/deep-flomap.rkt" "../private/deep-flomap.rkt"
(for-syntax syntax/parse)) (for-syntax racket/base syntax/parse))
(provide light-metal-icon-color (provide light-metal-icon-color
metal-icon-color metal-icon-color

3
collects/images/scribblings/icons.scrbl
View File

@ -475,3 +475,6 @@ Icons for the Debugger. The @racket[small-debugger-icon] is used when the toolba
@doc-apply[small-macro-stepper-hash-color]{ @doc-apply[small-macro-stepper-hash-color]{
Constants used within @racketmodname[images/icons/tool]. Constants used within @racketmodname[images/icons/tool].
} }
@close-eval[icons-eval]

3
collects/images/scribblings/logos.scrbl
View File

@ -38,3 +38,6 @@ Returns the algebraic stepper logo.
Returns the macro stepper logo. Returns the macro stepper logo.
@examples[#:eval logos-eval (macro-stepper-logo)] @examples[#:eval logos-eval (macro-stepper-logo)]
} }
@close-eval[logos-eval]

2
collects/lang/private/intermediate-funs.rkt
View File

@ -173,7 +173,7 @@
(apply max a-list) (apply max a-list)
] ]
} }
@defproc[(compose [f (X -> Y)] [g (Y -> Z)]) (X -> Z)]{ @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{
Composes a sequence of procedures into a single procedure: Composes a sequence of procedures into a single procedure:
@codeblock{(compose f g) = (lambda (x) (f (g x)))} @codeblock{(compose f g) = (lambda (x) (f (g x)))}
@interaction[#:eval (isl) @interaction[#:eval (isl)

3
collects/lang/private/sl-eval.rkt
View File

@ -1,6 +1,7 @@
#lang racket #lang racket/base
(require teachpack/2htdp/scribblings/img-eval (require teachpack/2htdp/scribblings/img-eval
racket/pretty
racket/sandbox racket/sandbox
mzlib/pconvert mzlib/pconvert
file/convertible file/convertible

8
collects/lazy/lazy-tool.rkt
View File

@ -1,6 +1,8 @@
#lang racket #lang racket/base
(require string-constants (require racket/unit
racket/class
string-constants
drracket/tool drracket/tool
lang/stepper-language-interface) lang/stepper-language-interface)
@ -11,7 +13,6 @@
(import drracket:tool^) (import drracket:tool^)
(export drracket:tool-exports^) (export drracket:tool-exports^)
(define (stepper-settings-language %) (define (stepper-settings-language %)
(if (implementation? % stepper-language<%>) (if (implementation? % stepper-language<%>)
(class* % (stepper-language<%>) (class* % (stepper-language<%>)
@ -51,7 +52,6 @@
; (drracket:language:simple-settings->vector (default-settings)))) ; (drracket:language:simple-settings->vector (default-settings))))
(super-new))) (super-new)))
(define (phase1) (void)) (define (phase1) (void))
;; phase2 : -> void ;; phase2 : -> void

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