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

Fix lots of indentation mistakes.

Browse Source 
(Found by my ayatollah script...)
This commit is contained in:
Eli Barzilay 2013-03-14 07:15:43 -04:00
parent 71d6189132
commit af6be85ff5
140 changed files with 2040 additions and 2223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/algol60/compile.rkt
View File

@ -433,10 +433,10 @@
(car spec))) (car spec)))
arg-specs) arg-specs)
#'unknown)]) #'unknown)])
(cons var (cons var
(if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars) (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars)
spec spec
(list 'by-name spec))))) (list 'by-name spec)))))
arg-vars) arg-vars)
context)) context))

18
collects/algol60/simplify.rkt
View File

@ -146,22 +146,22 @@
(map (lambda (extra) (map (lambda (extra)
(if (identifier? extra) (if (identifier? extra)
(make-a60:type-decl (->stx 'integer) (list extra)) (make-a60:type-decl (->stx 'integer) (list extra))
(make-a60:switch-decl (car extra) (map (lambda (x) (make-a60:switch-decl
(make-a60:variable (datum->syntax-object #f x) null)) (car extra)
(cdr extra))))) (map (lambda (x)
(make-a60:variable (datum->syntax-object #f x)
null))
(cdr extra)))))
extra-decls)) extra-decls))
(if (null? new-statements) (if (null? new-statements)
(list (cons (gensym 'other) (make-a60:dummy))) (list (cons (gensym 'other) (make-a60:dummy)))
new-statements))) new-statements)))
(define (simplify stmt ctx) (define (simplify stmt ctx)
(simplify-statement stmt (lambda (x) (simplify-statement stmt (lambda (x) (datum->syntax-object ctx x))))
(datum->syntax-object
ctx
x))))
(define (simplify-statement stmt ->stx) (define (simplify-statement stmt ->stx)
(match stmt (match stmt
[($ a60:block decls statements) [($ a60:block decls statements)
(flatten/label-block decls statements ->stx)] (flatten/label-block decls statements ->stx)]
[($ a60:compound statements) [($ a60:compound statements)

82
collects/compiler/compiler-unit.rkt
View File

@ -114,46 +114,48 @@
#f)))) #f))))
(unless (eq? 'all omit-paths) (unless (eq? 'all omit-paths)
(let ([init (parameterize ([current-directory dir] (let ([init (parameterize ([current-directory dir]
[current-load-relative-directory dir] [current-load-relative-directory dir]
;; Verbose compilation manager: ;; Verbose compilation manager:
[manager-trace-handler (if verbose? [manager-trace-handler
(let ([op (current-output-port)]) (if verbose?
(lambda (s) (fprintf op "~a\n" s))) (let ([op (current-output-port)])
(manager-trace-handler))] (lambda (s) (fprintf op "~a\n" s)))
[manager-compile-notify-handler (manager-trace-handler))]
(lambda (path) ((compile-notify-handler) path))] [manager-compile-notify-handler
[manager-skip-file-handler (lambda (path) ((compile-notify-handler) path))]
(lambda (path) (and skip-path [manager-skip-file-handler
(let ([b (path->bytes (simplify-path path #f))] (lambda (path)
[len (bytes-length skip-path)]) (and skip-path
(and ((bytes-length b) . > . len) (let ([b (path->bytes (simplify-path path #f))]
(bytes=? (subbytes b 0 len) skip-path))) [len (bytes-length skip-path)])
(list -inf.0 "")))]) (and ((bytes-length b) . > . len)
(let* ([sses (append (bytes=? (subbytes b 0 len) skip-path)))
;; Find all .rkt/.ss/.scm files: (list -inf.0 "")))])
(filter extract-base-filename/ss (directory-list)) (let* ([sses (append
;; Add specified doc sources: ;; Find all .rkt/.ss/.scm files:
(if skip-docs? (filter extract-base-filename/ss (directory-list))
null ;; Add specified doc sources:
(map (lambda (s) (if (string? s) (string->path s) s)) (if skip-docs?
(map car (info* 'scribblings (lambda () null))))))] null
[sses (remove* omit-paths sses)]) (map (lambda (s) (if (string? s) (string->path s) s))
(worker null sses)))]) (map car (info* 'scribblings (lambda () null))))))]
[sses (remove* omit-paths sses)])
(if (compile-subcollections) (worker null sses)))])
(begin
(when (info* 'compile-subcollections (lambda () #f)) (if (compile-subcollections)
(printf "Warning: ignoring `compile-subcollections' entry in info ~a\n" (begin
dir)) (when (info* 'compile-subcollections (lambda () #f))
(for/fold ([init init]) ([p (directory-list dir)]) (printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
(let ([p* (build-path dir p)]) dir))
(if (and (directory-exists? p*) (not (member p omit-paths))) (for/fold ([init init]) ([p (directory-list dir)])
(compile-directory-visitor p* (c-get-info/full p*) worker omit-root (let ([p* (build-path dir p)])
#:verbose verbose? (if (and (directory-exists? p*) (not (member p omit-paths)))
#:skip-path skip-path (compile-directory-visitor p* (c-get-info/full p*) worker omit-root
#:skip-doc-sources? skip-docs?) #:verbose verbose?
init)))) #:skip-path skip-path
init)))) #:skip-doc-sources? skip-docs?)
init))))
init))))
(define (compile-directory dir info (define (compile-directory dir info
#:verbose [verbose? #t] #:verbose [verbose? #t]
#:skip-path [orig-skip-path #f] #:skip-path [orig-skip-path #f]

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

@ -134,18 +134,18 @@
(list-ref toplevel-remap n))) (list-ref toplevel-remap n)))
(unless (= (length toplevel-remap) (unless (= (length toplevel-remap)
(length mod-toplevels)) (length mod-toplevels))
(error 'merge-module "Not remapping everything: ~S ~S" (error 'merge-module "Not remapping everything: ~S ~S"
mod-toplevels toplevel-remap)) mod-toplevels toplevel-remap))
(log-debug (format "[~S] Incrementing toplevels by ~a" (log-debug (format "[~S] Incrementing toplevels by ~a"
name name
toplevel-offset)) toplevel-offset))
(log-debug (format "[~S] Incrementing lifts by ~a" (log-debug (format "[~S] Incrementing lifts by ~a"
name name
lift-offset)) lift-offset))
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a" (log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
name name
(length mod-toplevels) (length mod-toplevels)
(length new-mod-toplevels))) (length new-mod-toplevels)))
(values (max max-let-depth mod-max-let-depth) (values (max max-let-depth mod-max-let-depth)
(merge-prefix top-prefix new-mod-prefix) (merge-prefix top-prefix new-mod-prefix)
(lambda (top-prefix) (lambda (top-prefix)

12
collects/data/integer-set.rkt
View File

@ -416,13 +416,13 @@
(cons i (cons s2 rest))))))))))) (cons i (cons s2 rest)))))))))))
(test-block ((->is (lambda (str) (test-block ((->is (lambda (str)
(foldr (lambda (c cs) (foldr (lambda (c cs)
(merge (make-range (char->integer c)) (merge (make-range (char->integer c))
cs)) cs))
(make-range) (make-range)
(string->list str)))) (string->list str))))
(->is2 (lambda (str) (->is2 (lambda (str)
(integer-set-contents (->is str))))) (integer-set-contents (->is str)))))
((partition null) null) ((partition null) null)
((map integer-set-contents (partition (list (->is "1234")))) (list (->is2 "1234"))) ((map integer-set-contents (partition (list (->is "1234")))) (list (->is2 "1234")))
((map integer-set-contents (partition (list (->is "1234") (->is "0235")))) ((map integer-set-contents (partition (list (->is "1234") (->is "0235"))))

22
collects/data/queue.rkt
View File

@ -100,17 +100,17 @@
([(var) (in-queue* queue-expression)] ([(var) (in-queue* queue-expression)]
(with-syntax ([queue-expression/c (wrap-expr/c #'queue? #'queue-expression (with-syntax ([queue-expression/c (wrap-expr/c #'queue? #'queue-expression
#:macro #'in-queue*)]) #:macro #'in-queue*)])
#'[(var) #'[(var)
(:do-in ([(queue) queue-expression/c]) (:do-in ([(queue) queue-expression/c])
(void) ;; handled by contract (void) ;; handled by contract
([link (queue-head queue)]) ([link (queue-head queue)])
link link
([(var) (link-value link)]) ([(var) (link-value link)])
#t #t
#t #t
((link-tail link)))])) ((link-tail link)))]))
([(var ...) (in-queue* queue-expression)] ([(var ...) (in-queue* queue-expression)]
#f)))) #f))))
;; --- contracts --- ;; --- contracts ---
(define queue/c queue?) (define queue/c queue?)

6
collects/deinprogramm/deinprogramm-langs.rkt
View File

@ -1084,12 +1084,12 @@
[(send pre-installed-lb get-selection) [(send pre-installed-lb get-selection)
=> =>
(lambda (i) `(lib ,(send pre-installed-lb get-string i) (lambda (i) `(lib ,(send pre-installed-lb get-string i)
"teachpack" "teachpack"
"deinprogramm"))] "deinprogramm"))]
[(send user-installed-lb get-selection) [(send user-installed-lb get-selection)
=> =>
(lambda (i) `(lib ,(send user-installed-lb get-string i) (lambda (i) `(lib ,(send user-installed-lb get-string i)
,user-installed-teachpacks-collection))] ,user-installed-teachpacks-collection))]
[else (error 'figure-out-answer "no selection!")])) [else (error 'figure-out-answer "no selection!")]))

6
collects/deinprogramm/signature/signature-syntax.rkt
View File

@ -47,9 +47,9 @@
#'(when (signature? ?temp) #'(when (signature? ?temp)
?raise)))) ?raise))))
(syntax->list #'((?temp ?exp) ...))))) (syntax->list #'((?temp ?exp) ...)))))
#'(let ((?temp ?exp) ...) #'(let ((?temp ?exp) ...)
?check ... ?check ...
(make-case-signature '?name (list ?temp ...) equal? ?stx))))) (make-case-signature '?name (list ?temp ...) equal? ?stx)))))
((predicate ?exp) ((predicate ?exp)
(with-syntax ((?stx (phase-lift stx)) (with-syntax ((?stx (phase-lift stx))
(?name name)) (?name name))

4
collects/deinprogramm/signature/signature.rkt
View File

@ -65,8 +65,8 @@
(lambda (this-info other-info) (lambda (this-info other-info)
#f)) #f))
#:=?-proc (=?-proc #:=?-proc (=?-proc
(lambda (this-info other-info) (lambda (this-info other-info)
#f))) #f)))
(really-make-signature name enforcer syntax-promise arbitrary-promise info-promise <=?-proc =?-proc)) (really-make-signature name enforcer syntax-promise arbitrary-promise info-promise <=?-proc =?-proc))
(define (signature-syntax sig) (define (signature-syntax sig)

20
collects/deinprogramm/turtle.rkt
View File

@ -150,16 +150,16 @@
(lambda (length) (lambda (length)
(lambda (t) (lambda (t)
(let* ((h (get-h t)) (let* ((h (get-h t))
(w (get-w t)) (w (get-w t))
(x (get-x t)) (x (get-x t))
(y (get-y t)) (y (get-y t))
(angle (get-angle t)) (angle (get-angle t))
(image (get-image t)) (image (get-image t))
(color (get-color t)) (color (get-color t))
(state (get-state t)) (state (get-state t))
; Compute new coordinats ; Compute new coordinats
(newx (+ x (* length (cos (grad->rad angle))))) (newx (+ x (* length (cos (grad->rad angle)))))
(newy (+ y (* length (sin (grad->rad angle)))))) (newy (+ y (* length (sin (grad->rad angle))))))
(new-turtle-priv (new-turtle-priv
h w h w
newx newy angle newx newy angle

2
collects/drracket/private/debug.rkt
View File

@ -651,7 +651,7 @@ profile todo:
(let ([dis (if (exn? dis/exn) (let ([dis (if (exn? dis/exn)
(cms->srclocs (exn-continuation-marks dis/exn)) (cms->srclocs (exn-continuation-marks dis/exn))
dis/exn)]) dis/exn)])
(show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep))) (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep)))
(define (show-backtrace-window/edition-pairs error-text dis editions defs ints) (define (show-backtrace-window/edition-pairs error-text dis editions defs ints)
(show-backtrace-window/edition-pairs/two error-text dis editions '() '() defs ints)) (show-backtrace-window/edition-pairs/two error-text dis editions '() '() defs ints))

8
collects/drracket/private/embedded-snip-utils.rkt
View File

@ -14,10 +14,10 @@
(if (and admin (is-a? admin editor-snip-editor-admin<%>)) (if (and admin (is-a? admin editor-snip-editor-admin<%>))
(let ([enclosing-editor-snip (send admin get-snip)]) (let ([enclosing-editor-snip (send admin get-snip)])
(if (get-snip-outer-editor enclosing-editor-snip) (if (get-snip-outer-editor enclosing-editor-snip)
(get-enclosing-editor-frame (get-snip-outer-editor (get-enclosing-editor-frame (get-snip-outer-editor
enclosing-editor-snip)) enclosing-editor-snip))
(topwin))) (topwin)))
(topwin)))) (topwin))))
;; get-snip-outer-editor: snip% -> (or/c editor<%> #f) ;; get-snip-outer-editor: snip% -> (or/c editor<%> #f)
;; Returns the immediate outer editor enclosing the snip, or false if we ;; Returns the immediate outer editor enclosing the snip, or false if we

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

@ -44,13 +44,13 @@
[(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 the-racket-language) (values (string-append (string-constant the-racket-language)
(format " (~aR)" menukey-string)) (format " (~aR)" menukey-string))
(string-append (string-constant teaching-languages) (string-append (string-constant teaching-languages)
(format " (~aT)" menukey-string)) (format " (~aT)" menukey-string))
(string-append (string-constant other-languages) (string-append (string-constant other-languages)
(format " (~aO)" menukey-string)) (format " (~aO)" menukey-string))
mouse-event-uses-shortcut-prefix?))) mouse-event-uses-shortcut-prefix?)))
(provide language-configuration@) (provide language-configuration@)

4
collects/drracket/private/profile-drs.rkt
View File

@ -59,9 +59,7 @@ itself.
(define (update-buttons) (define (update-buttons)
(send resume-b enable (and current-sampler (not running?))) (send resume-b enable (and current-sampler (not running?)))
(send pause-b enable (and current-sampler running?)) (send pause-b enable (and current-sampler running?))
(send start-stop-b set-label (if current-sampler (send start-stop-b set-label (if current-sampler "Stop" "Start")))
"Stop"
"Start")))
(define running? #f) (define running? #f)
(define current-sampler #f) (define current-sampler #f)

4
collects/embedded-gui/embedded-gui.rkt
View File

@ -3,8 +3,8 @@
(define-syntax (require/provide stx) (define-syntax (require/provide stx)
(syntax-case stx () (syntax-case stx ()
[(_ filename ...) [(_ filename ...)
#'(begin (require filename ...) #'(begin (require filename ...)
(provide (all-from filename) ...))])) (provide (all-from filename) ...))]))
(require/provide (require/provide
"private/interface.rkt" "private/interface.rkt"

10
collects/embedded-gui/private/lines.rkt
View File

@ -96,11 +96,11 @@
(super-new) (super-new)
(inherit set-snipclass) (inherit set-snipclass)
(set-snipclass sc))] (set-snipclass sc))]
[sc (new [sc (new
(class snip-class% (class snip-class%
(define/override (read f) (define/override (read f)
(new c)) (new c))
(super-new)))]) (super-new)))])
(send sc set-classname classname) (send sc set-classname classname)
(send sc set-version 1) (send sc set-version 1)
(send (get-the-snip-class-list) add sc) (send (get-the-snip-class-list) add sc)

6
collects/framework/main.rkt
View File

@ -238,9 +238,9 @@
((sym) ((sym)
((default (λ () (error 'get-preference/gui "unknown pref ~s" sym))))) ((default (λ () (error 'get-preference/gui "unknown pref ~s" sym)))))
@{Like @racket[get-preference], but has more sophisticated error handling. @{Like @racket[get-preference], but has more sophisticated error handling.
In particular, it passes a @racket[#:timeout-lock-there] argument that In particular, it passes a @racket[#:timeout-lock-there] argument that
informs the user that the preferences file is locked (and offers the alternative informs the user that the preferences file is locked (and offers the alternative
of not showing the message again).}) of not showing the message again).})
(proc-doc/names (proc-doc/names

6
collects/framework/private/icon.rkt
View File

@ -31,9 +31,9 @@
(export framework:icon^) (export framework:icon^)
(define eof-bitmap (delay/sync (let ([bm (make-object bitmap% eof-bitmap-path)]) (define eof-bitmap (delay/sync (let ([bm (make-object bitmap% eof-bitmap-path)])
(unless (send bm ok?) (unless (send bm ok?)
(error 'eof-bitmap "not ok ~s\n" eof-bitmap-path)) (error 'eof-bitmap "not ok ~s\n" eof-bitmap-path))
bm))) bm)))
(define (get-eof-bitmap) (force eof-bitmap)) (define (get-eof-bitmap) (force eof-bitmap))
(define anchor-bitmap (delay/sync (make-object bitmap% anchor-bitmap-path))) (define anchor-bitmap (delay/sync (make-object bitmap% anchor-bitmap-path)))

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

@ -25,9 +25,9 @@
[-get-file get-file])) [-get-file get-file]))
(init-depend mred^) (init-depend mred^)
;; if I put this in main.rkt with the others, it doesn't happen ;; if I put this in main.rkt with the others, it doesn't happen
;; early enough... ? JBC, 2011-07-12 ;; early enough... ? JBC, 2011-07-12
(preferences:set-default 'framework:automatic-parens #f boolean?) (preferences:set-default 'framework:automatic-parens #f boolean?)
(define user-keybindings-files (make-hash)) (define user-keybindings-files (make-hash))
@ -931,8 +931,8 @@
(λ (adjust) (λ (adjust)
(λ (text event) (λ (text event)
(when (is-a? text editor:basic<%>) (when (is-a? text editor:basic<%>)
(let ([frame (send text get-top-level-window)]) (let ([frame (send text get-top-level-window)]
(let ([found-one? #f]) [found-one? #f])
(let/ec k (let/ec k
(let ([go (let ([go
(λ () (λ ()
@ -952,7 +952,7 @@
;;; or the last editor-canvas had the focus. either way, ;;; or the last editor-canvas had the focus. either way,
;;; the next thing should get the focus ;;; the next thing should get the focus
(set! found-one? #t) (set! found-one? #t)
(go))))))))] (go)))))))]
[TeX-compress [TeX-compress
(let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))])

12
collects/framework/private/panel.rkt
View File

@ -525,13 +525,13 @@
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%)))
(define splitter<%> (interface () split-horizontal split-vertical collapse)) (define splitter<%> (interface () split-horizontal split-vertical collapse))
;; we need a private interface so we can use `generic' because `generic' ;; we need a private interface so we can use `generic' because `generic'
;; doesn't work on mixins ;; doesn't work on mixins
(define splitter-private<%> (interface () self-vertical? self-horizontal?)) (define splitter-private<%> (interface () self-vertical? self-horizontal?))
(define splitter-mixin (define splitter-mixin
(mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>)
(super-new) (super-new)
(inherit get-children add-child (inherit get-children add-child
delete-child delete-child

372
collects/framework/private/racket.rkt
View File

@ -152,7 +152,7 @@
;; old snips (from old versions of drracket) use this snipclass ;; old snips (from old versions of drracket) use this snipclass
(define 2lib-snip-class (make-object sexp-snipclass%)) (define 2lib-snip-class (make-object sexp-snipclass%))
(send 2lib-snip-class set-classname (format "~s" '((lib "collapsed-snipclass.ss" "framework") (send 2lib-snip-class set-classname (format "~s" '((lib "collapsed-snipclass.ss" "framework")
(lib "collapsed-snipclass-wxme.ss" "framework")))) (lib "collapsed-snipclass-wxme.ss" "framework"))))
(send 2lib-snip-class set-version 0) (send 2lib-snip-class set-version 0)
(send (get-the-snip-class-list) add 2lib-snip-class) (send (get-the-snip-class-list) add 2lib-snip-class)
@ -517,194 +517,194 @@
(define/public (tabify-on-return?) #t) (define/public (tabify-on-return?) #t)
(define/public (tabify [pos (get-start-position)]) (define/public (tabify [pos (get-start-position)])
(unless (is-stopped?) (unless (is-stopped?)
(let* ([tabify-prefs (preferences:get 'framework:tabify)] (let* ([tabify-prefs (preferences:get 'framework:tabify)]
[last-pos (last-position)] [last-pos (last-position)]
[para (position-paragraph pos)] [para (position-paragraph pos)]
[is-tabbable? (and (> para 0) [is-tabbable? (and (> para 0)
(not (memq (classify-position (sub1 (paragraph-start-position para))) (not (memq (classify-position (sub1 (paragraph-start-position para)))
'(comment string error))))] '(comment string error))))]
[end (if is-tabbable? (paragraph-start-position para) 0)] [end (if is-tabbable? (paragraph-start-position para) 0)]
[limit (get-limit pos)] [limit (get-limit pos)]
;; "contains" is the start of the initial sub-S-exp ;; "contains" is the start of the initial sub-S-exp
;; in the S-exp that contains "pos". If pos is outside ;; in the S-exp that contains "pos". If pos is outside
;; all S-exps, this will be the start of the initial ;; all S-exps, this will be the start of the initial
;; S-exp ;; S-exp
[contains [contains
(if is-tabbable? (if is-tabbable?
(backward-containing-sexp end limit) (backward-containing-sexp end limit)
#f)] #f)]
[contain-para (and contains [contain-para (and contains
(position-paragraph contains))] (position-paragraph contains))]
;; "last" is the start of the S-exp just before "pos" ;; "last" is the start of the S-exp just before "pos"
[last [last
(if contains (if contains
(let ([p (get-backward-sexp end)]) (let ([p (get-backward-sexp end)])
(if (and p (p . >= . limit)) (if (and p (p . >= . limit))
p p
(backward-match end limit))) (backward-match end limit)))
#f)] #f)]
[last-para (and last [last-para (and last
(position-paragraph last))]) (position-paragraph last))])
(letrec (letrec
([find-offset ([find-offset
(λ (start-pos) (λ (start-pos)
(define tab-char? #f) (define tab-char? #f)
(define end-pos (define end-pos
(let loop ([p start-pos]) (let loop ([p start-pos])
(let ([c (get-character p)])
(cond
[(char=? c #\tab)
(set! tab-char? #t)
(loop (add1 p))]
[(char=? c #\newline)
p]
[(char-whitespace? c)
(loop (add1 p))]
[else
p]))))
(define start-x (box 0))
(define end-x (box 0))
(position-location start-pos start-x #f #t #t)
(position-location end-pos end-x #f #t #t)
(define-values (w _1 _2 _3)
(send (get-dc) get-text-extent "x"
(send (send (get-style-list)
find-named-style "Standard")
get-font)))
(values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
end-pos
tab-char?))]
[visual-offset
(λ (pos)
(let loop ([p (sub1 pos)])
(if (= p -1)
0
(let ([c (get-character p)]) (let ([c (get-character p)])
(cond (cond
[(char=? c #\null) 0]
[(char=? c #\tab) [(char=? c #\tab)
(let ([o (loop (sub1 p))]) (set! tab-char? #t)
(+ o (- 8 (modulo o 8))))] (loop (add1 p))]
[(char=? c #\newline) 0] [(char=? c #\newline)
[else (add1 (loop (sub1 p)))])))))] p]
[do-indent [(char-whitespace? c)
(λ (amt) (loop (add1 p))]
(define pos-start end) [else
(define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) p]))))
(unless (and (not tab-char?) (= amt (- curr-offset pos-start))) (define start-x (box 0))
(delete pos-start curr-offset) (define end-x (box 0))
(insert (make-string amt #\space) pos-start)))] (position-location start-pos start-x #f #t #t)
[get-proc (position-location end-pos end-x #f #t #t)
(λ () (define-values (w _1 _2 _3)
(let ([id-end (get-forward-sexp contains)]) (send (get-dc) get-text-extent "x"
(and (and id-end (> id-end contains)) (send (send (get-style-list)
(let* ([text (get-text contains id-end)]) find-named-style "Standard")
(or (get-keyword-type text tabify-prefs) get-font)))
'other)))))] (values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
[procedure-indent end-pos
(λ () tab-char?))]
(case (get-proc)
[(begin define) 1] [visual-offset
[(lambda) 3] (λ (pos)
[else 0]))] (let loop ([p (sub1 pos)])
[special-check (if (= p -1)
(λ () 0
(let* ([proc-name (get-proc)]) (let ([c (get-character p)])
(or (eq? proc-name 'define) (cond
(eq? proc-name 'lambda))))] [(char=? c #\null) 0]
[curley-brace-sexp? [(char=? c #\tab)
(λ () (let ([o (loop (sub1 p))])
(define up-p (find-up-sexp pos)) (+ o (- 8 (modulo o 8))))]
(and up-p [(char=? c #\newline) 0]
(equal? #\{ (get-character up-p))))] [else (add1 (loop (sub1 p)))])))))]
[do-indent
[indent-first-arg (λ (start) (λ (amt)
(define-values (gwidth curr-offset tab-char?) (find-offset start)) (define pos-start end)
gwidth)]) (define-values (gwidth curr-offset tab-char?) (find-offset pos-start))
(when (and is-tabbable? (unless (and (not tab-char?) (= amt (- curr-offset pos-start)))
(not (char=? (get-character (sub1 end)) (delete pos-start curr-offset)
#\newline))) (insert (make-string amt #\space) pos-start)))]
(insert #\newline (paragraph-start-position para))) [get-proc
(cond (λ ()
[(not is-tabbable?) (let ([id-end (get-forward-sexp contains)])
(when (= para 0) (and (and id-end (> id-end contains))
(do-indent 0))] (let* ([text (get-text contains id-end)])
[(let-values ([(gwidth real-start tab-char?) (find-offset end)]) (or (get-keyword-type text tabify-prefs)
(and (<= (+ 3 real-start) (last-position)) 'other)))))]
(string=? ";;;" [procedure-indent
(get-text real-start (λ ()
(+ 2 real-start))))) (case (get-proc)
(void)] [(begin define) 1]
[(not contains) [(lambda) 3]
;; Something went wrong matching. Should we get here? [else 0]))]
(do-indent 0)] [special-check
#; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. (λ ()
[(curley-brace-sexp?) (let* ([proc-name (get-proc)])
;; when we are directly inside an sexp that uses {}s, (or (eq? proc-name 'define)
;; we indent in a more C-like fashion (to help Scribble) (eq? proc-name 'lambda))))]
(define first-curley (find-up-sexp pos)) [curley-brace-sexp?
(define containing-curleys (λ ()
(let loop ([pos first-curley]) (define up-p (find-up-sexp pos))
(let ([next (find-up-sexp pos)]) (and up-p
(if (and next (equal? #\{ (get-character up-p))))]
(equal? (get-character next) #\{))
(+ (loop next) 1) [indent-first-arg (λ (start)
1)))) (define-values (gwidth curr-offset tab-char?) (find-offset start))
(define close-first-curley (get-forward-sexp first-curley)) gwidth)])
(define para (position-paragraph pos)) (when (and is-tabbable?
(when (and close-first-curley (not (char=? (get-character (sub1 end))
(<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) #\newline)))
(set! containing-curleys (max 0 (- containing-curleys 1)))) (insert #\newline (paragraph-start-position para)))
(do-indent (* containing-curleys 2))] (cond
[(not last) [(not is-tabbable?)
;; We can't find a match backward from pos, (when (= para 0)
;; but we seem to be inside an S-exp, so (do-indent 0))]
;; go "up" an S-exp, and move forward past [(let-values ([(gwidth real-start tab-char?) (find-offset end)])
;; the associated paren (and (<= (+ 3 real-start) (last-position))
(let ([enclosing (find-up-sexp pos)]) (string=? ";;;"
(if enclosing (get-text real-start
(do-indent (+ (visual-offset enclosing) 1)) (+ 2 real-start)))))
(do-indent 0)))] (void)]
[(= contains last) [(not contains)
;; There's only one S-expr in the S-expr ;; Something went wrong matching. Should we get here?
;; containing "pos" (do-indent 0)]
(do-indent (+ (visual-offset contains) #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up.
(procedure-indent)))] [(curley-brace-sexp?)
[(special-check) ;; when we are directly inside an sexp that uses {}s,
;; In case of "define", etc., ignore the position of last ;; we indent in a more C-like fashion (to help Scribble)
;; and just indent under the "define" (define first-curley (find-up-sexp pos))
(do-indent (add1 (visual-offset contains)))] (define containing-curleys
[(= contain-para last-para) (let loop ([pos first-curley])
;; So far, the S-exp containing "pos" was all on (let ([next (find-up-sexp pos)])
;; one line (possibly not counting the opening paren), (if (and next
;; so indent to follow the first S-exp's end (equal? (get-character next) #\{))
;; unless there are just two sexps and the second is an ellipsis. (+ (loop next) 1)
;; in that case, we just ignore the ellipsis 1))))
(let ([name-length (let ([id-end (get-forward-sexp contains)]) (define close-first-curley (get-forward-sexp first-curley))
(if id-end (define para (position-paragraph pos))
(- id-end contains) (when (and close-first-curley
0))]) (<= (paragraph-start-position para) close-first-curley (paragraph-end-position para)))
(cond (set! containing-curleys (max 0 (- containing-curleys 1))))
[(second-sexp-is-ellipsis? contains) (do-indent (* containing-curleys 2))]
(do-indent (visual-offset contains))] [(not last)
[(not (find-up-sexp pos)) ;; We can't find a match backward from pos,
(do-indent (visual-offset contains))] ;; but we seem to be inside an S-exp, so
[else ;; go "up" an S-exp, and move forward past
(do-indent (+ (visual-offset contains) ;; the associated paren
name-length (let ([enclosing (find-up-sexp pos)])
(indent-first-arg (+ contains (if enclosing
name-length))))]))] (do-indent (+ (visual-offset enclosing) 1))
[else (do-indent 0)))]
;; No particular special case, so indent to match first [(= contains last)
;; S-expr that start on the previous line ;; There's only one S-expr in the S-expr
(let loop ([last last][last-para last-para]) ;; containing "pos"
(let* ([next-to-last (backward-match last limit)] (do-indent (+ (visual-offset contains)
[next-to-last-para (and next-to-last (procedure-indent)))]
(position-paragraph next-to-last))]) [(special-check)
(if (equal? last-para next-to-last-para) ;; In case of "define", etc., ignore the position of last
(loop next-to-last next-to-last-para) ;; and just indent under the "define"
(do-indent (visual-offset last)))))]))))) (do-indent (add1 (visual-offset contains)))]
[(= contain-para last-para)
;; So far, the S-exp containing "pos" was all on
;; one line (possibly not counting the opening paren),
;; so indent to follow the first S-exp's end
;; unless there are just two sexps and the second is an ellipsis.
;; in that case, we just ignore the ellipsis
(let ([name-length (let ([id-end (get-forward-sexp contains)])
(if id-end
(- id-end contains)
0))])
(cond
[(second-sexp-is-ellipsis? contains)
(do-indent (visual-offset contains))]
[(not (find-up-sexp pos))
(do-indent (visual-offset contains))]
[else
(do-indent (+ (visual-offset contains)
name-length
(indent-first-arg (+ contains
name-length))))]))]
[else
;; No particular special case, so indent to match first
;; S-expr that start on the previous line
(let loop ([last last][last-para last-para])
(let* ([next-to-last (backward-match last limit)]
[next-to-last-para (and next-to-last
(position-paragraph next-to-last))])
(if (equal? last-para next-to-last-para)
(loop next-to-last next-to-last-para)
(do-indent (visual-offset last)))))])))))
;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
;; otherwise, returns #f ;; otherwise, returns #f

2
collects/frtime/demos/pong.rkt
View File

@ -92,7 +92,7 @@
. =#=> . . =#=> .
(match-lambda (match-lambda
[(list _ y) (when (and (> y 150) (< y 250)) [(list _ y) (when (and (> y 150) (< y 250))
add1)]))) add1)])))
0)) 0))
(define p1-score (mk-score (lambda (x) (< x 10)))) (define p1-score (mk-score (lambda (x) (< x 10))))

14
collects/frtime/demos/push-pull-ball.rkt
View File

@ -17,13 +17,13 @@
(define pos2 (define pos2
(rec pos (rec pos
(until (make-posn 100 100) (until (make-posn 100 100)
(inf-delay (inf-delay
(let ([brnch (posn+ pos (let ([brnch (posn+ pos
(posn* (normalize (posn- pos1 pos)) (posn* (normalize (posn- pos1 pos))
(- (posn-diff pos pos1) (add1 (* 2 radius)))))]) (- (posn-diff pos pos1) (add1 (* 2 radius)))))])
(if (< (posn-diff pos pos1) (* 2 radius)) (if (< (posn-diff pos pos1) (* 2 radius))
brnch brnch
pos)))))) pos))))))
(display-shapes (display-shapes
(list (list

5
collects/frtime/frlibs/math.rkt
View File

@ -6,10 +6,7 @@
(module math frtime/frtime-lang-only (module math frtime/frtime-lang-only
(require (only-in racket/math pi sqr sgn conjugate sinh cosh)) (require (only-in racket/math pi sqr sgn conjugate sinh cosh))
(provide (lifted (provide (lifted sqr sgn conjugate sinh cosh))
sqr
sgn conjugate
sinh cosh))
(provide pi e) (provide pi e)

2
collects/frtime/gui/mixin-macros.rkt
View File

@ -19,7 +19,7 @@
[getting-name (string->symbol [getting-name (string->symbol
(format "get-~a-e" (syntax-e s-field-name)))] (format "get-~a-e" (syntax-e s-field-name)))]
[renamed-update (string->symbol [renamed-update (string->symbol
(format "renamed-~a" (syntax-e (syntax update-call))))]) (format "renamed-~a" (syntax-e (syntax update-call))))])
(syntax (syntax
(lambda (super) (lambda (super)
(class super (class super

2
collects/frtime/opt/frtime-opt.rkt
View File

@ -559,7 +559,7 @@
(map list (syntax->list #'(IDS ...)) optimized-vals)] (map list (syntax->list #'(IDS ...)) optimized-vals)]
[body #`(begin EXPR ...)] [body #`(begin EXPR ...)]
[optimized-body (recursively-optimize-expr body equiv-map #f)]) [optimized-body (recursively-optimize-expr body equiv-map #f)])
#`(letrec-syntaxes+values SYNTAX-STUFF #,optimized-bindings #,optimized-body))] #`(letrec-syntaxes+values SYNTAX-STUFF #,optimized-bindings #,optimized-body))]
[(if . ARGS) [(if . ARGS)
(let* ([optimized-args (map (lambda (expr) (let* ([optimized-args (map (lambda (expr)

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

@ -121,11 +121,11 @@
(if (empty? (node-children parent)) (if (empty? (node-children parent))
(attributed-node parent 'leaf 0 depth '()) (attributed-node parent 'leaf 0 depth '())
(let-values ([(leaves achn) (let-values ([(leaves achn)
(for/fold ([l 0] [achildren '()]) ([child (in-list (node-children parent))]) (for/fold ([l 0] [achildren '()]) ([child (in-list (node-children parent))])
(let ([anode (build-attr-tree child (add1 depth))]) (let ([anode (build-attr-tree child (add1 depth))])
(if (leaf? anode) (if (leaf? anode)
(values (add1 l) (cons anode achildren)) (values (add1 l) (cons anode achildren))
(values (+ l (attributed-node-num-leaves anode)) (cons anode achildren)))))]) (values (+ l (attributed-node-num-leaves anode)) (cons anode achildren)))))])
(attributed-node parent (attributed-node parent
'interior 'interior
leaves leaves

2
collects/future-visualizer/private/gui-helpers.rkt
View File

@ -65,7 +65,7 @@
[parent par] [parent par]
[redraw-on-resize #t] [redraw-on-resize #t]
[pict-builder (λ (vregion) [pict-builder (λ (vregion)
(rotate (lc-superimpose (colorize (filled-rectangle (viewable-region-height vregion) (rotate (lc-superimpose (colorize (filled-rectangle (viewable-region-height vregion)
HEADER-HEIGHT) HEADER-HEIGHT)
(header-backcolor)) (header-backcolor))
text-container) text-container)

18
collects/future-visualizer/private/visualizer-data.rkt
View File

@ -84,8 +84,8 @@
creation-tree)) creation-tree))
(struct rtcall-info (fid (struct rtcall-info (fid
block-hash ; prim name --o--> number of blocks block-hash ; prim name --o--> number of blocks
sync-hash) ; op name --o--> number of syncs sync-hash) ; op name --o--> number of syncs
#:transparent) #:transparent)
;(struct process-timeline timeline (proc-index)) ;(struct process-timeline timeline (proc-index))
@ -319,8 +319,8 @@
(define (event-pos-description index timeline-len) (define (event-pos-description index timeline-len)
(cond (cond
[(zero? index) (if (= index (sub1 timeline-len)) [(zero? index) (if (= index (sub1 timeline-len))
'singleton 'singleton
'start)] 'start)]
[(= index (sub1 timeline-len)) 'end] [(= index (sub1 timeline-len)) 'end]
[else 'interior])) [else 'interior]))
@ -425,11 +425,11 @@
<)) <))
(define non-gc-evts (filter (λ (e) (not (gc-event? e))) all-evts)) (define non-gc-evts (filter (λ (e) (not (gc-event? e))) all-evts))
(define future-tl-hash (let ([h (make-hash)]) (define future-tl-hash (let ([h (make-hash)])
(for ([evt (in-list non-gc-evts)]) (for ([evt (in-list non-gc-evts)])
(let* ([fid (event-future-id evt)] (let* ([fid (event-future-id evt)]
[existing (hash-ref h fid '())]) [existing (hash-ref h fid '())])
(hash-set! h fid (cons evt existing)))) (hash-set! h fid (cons evt existing))))
h)) h))
(for ([fid (in-list (hash-keys future-tl-hash))]) (for ([fid (in-list (hash-keys future-tl-hash))])
(hash-set! future-tl-hash fid (reverse (hash-ref future-tl-hash fid)))) (hash-set! future-tl-hash fid (reverse (hash-ref future-tl-hash fid))))
(define-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts)) (define-values (block-hash sync-hash rtcalls-per-future-hash) (build-rtcall-hashes all-evts))

7
collects/future-visualizer/private/visualizer-drawing.rkt
View File

@ -211,9 +211,10 @@
[last-x 0] [last-x 0]
[ticks '()] [ticks '()]
[last-label-x-extent 0] [last-label-x-extent 0]
[remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) [remain-segs segs])
trace-start) ([i (in-range 0 (floor (/ (- (trace-end-time tr)
DEFAULT-TIME-INTERVAL)))]) trace-start)
DEFAULT-TIME-INTERVAL)))])
(define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL))
(define tick-time (+ trace-start tick-rel-time)) (define tick-time (+ trace-start tick-rel-time))
(define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod))) (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod)))

2
collects/games/paint-by-numbers/main.rkt
View File

@ -162,7 +162,7 @@
(caddr state) (caddr state)
(cadddr state) (cadddr state)
(list->vector (map list->vector (car (cddddr state)))))]) (list->vector (map list->vector (car (cddddr state)))))])
(editor problem))] (editor problem))]
[(player) [(player)
(let ([name (cadr state)] (let ([name (cadr state)]
[problem [problem

8
collects/games/paint-by-numbers/raw-problems/build-hattori.rkt
View File

@ -31,10 +31,10 @@
[new-bitmap-height (floor (/ (- puzzle-height 1) pixel-size))]) [new-bitmap-height (floor (/ (- puzzle-height 1) pixel-size))])
(begin (begin
(eprintf "size of picture: ~a x ~a\n" raw-width raw-height) (eprintf "size of picture: ~a x ~a\n" raw-width raw-height)
(eprintf " size of image: ~a x ~a\n" image-width image-height) (eprintf " size of image: ~a x ~a\n" image-width image-height)
(eprintf "grid-start (~a, ~a)\n" grid-x-start grid-y-start) (eprintf "grid-start (~a, ~a)\n" grid-x-start grid-y-start)
(eprintf "size of puzzle: ~a x ~a\n" puzzle-width puzzle-height)) (eprintf "size of puzzle: ~a x ~a\n" puzzle-width puzzle-height))
(reverse (reverse
(let loop ([j new-bitmap-height]) (let loop ([j new-bitmap-height])
(cond (cond

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

@ -624,8 +624,8 @@
(board-width final-board) (board-width final-board)
(board-height final-board)))]) (board-height final-board)))])
(values final-board new-row-tries new-col-tries (or row-changed col-changed)))) (values final-board new-row-tries new-col-tries (or row-changed col-changed))))
'full-set 'full-set
'caller)) 'caller))
; on 2002-10-17, I wrapped another layer of looping around the inner loop. ; on 2002-10-17, I wrapped another layer of looping around the inner loop.
; the purpose of this outer loop is to allow the solver to ignore rows (or ; the purpose of this outer loop is to allow the solver to ignore rows (or

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

@ -465,13 +465,13 @@
id (list-tail frames (send (get-tab) get-frame-num)) id (list-tail frames (send (get-tab) get-frame-num))
;; id found ;; id found
(lambda (val _) (lambda (val _)
(cond (cond
[(render val) => (lambda (str) [(render val) => (lambda (str)
(string-append (string-append
(symbol->string (syntax-e id)) " = " str))] (symbol->string (syntax-e id)) " = " str))]
[else ""])) [else ""]))
;; id not found ;; id not found
(lambda () ""))]) (lambda () ""))])
(send (get-tab) set-mouse-over-msg (clean-status rendered)))))) (send (get-tab) set-mouse-over-msg (clean-status rendered))))))
(super on-event event)] (super on-event event)]
[(send event button-down? 'right) [(send event button-down? 'right)

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

@ -228,13 +228,13 @@
(require (for-meta 2 (submod "." analysis))) (require (for-meta 2 (submod "." analysis)))
(begin-for-syntax (begin-for-syntax
(define-syntax (parse-stuff stx) (define-syntax (parse-stuff stx)
(syntax-parse stx (syntax-parse stx
[(_ stuff ...) [(_ stuff ...)
(emit-remark "Parse stuff ~a\n" #'(stuff ...)) (emit-remark "Parse stuff ~a\n" #'(stuff ...))
(phase2:parse-all #'(stuff ...)) (phase2:parse-all #'(stuff ...))
#; #;
(honu->racket (parse-all #'(stuff ...)))]))) (honu->racket (parse-all #'(stuff ...)))])))
(begin-for-syntax (begin-for-syntax
(define-syntax (create-honu-macro stx) (define-syntax (create-honu-macro stx)

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

@ -373,58 +373,58 @@
(define final (if current current (racket-syntax (void)))) (define final (if current current (racket-syntax (void))))
(if (parsed-syntax? stream) (if (parsed-syntax? stream)
(values (left stream) #'()) (values (left stream) #'())
(syntax-parse stream #:literal-sets (cruft) (syntax-parse stream #:literal-sets (cruft)
#; #;
[x:id (values #'x #'())] [x:id (values #'x #'())]
[((semicolon inner ...) rest ...) [((semicolon inner ...) rest ...)
;; nothing on the left side should interact with a semicolon ;; nothing on the left side should interact with a semicolon
(if current (if current
(values (left current) (values (left current)
stream) stream)
(begin (begin
(with-syntax ( (with-syntax (
#; #;
[inner* (parse-all #'(inner ...))]) [inner* (parse-all #'(inner ...))])
(values (left (parse-delayed inner ...)) (values (left (parse-delayed inner ...))
#'(rest ...)))))] #'(rest ...)))))]
[() [()
(debug "Empty input out: left ~a ~a\n" left (left final)) (debug "Empty input out: left ~a ~a\n" left (left final))
(values (left final) #'())] (values (left final) #'())]
[(head rest ...) [(head rest ...)
(debug 2 "Not a special expression..\n") (debug 2 "Not a special expression..\n")
(cond (cond
[(honu-macro? #'head) [(honu-macro? #'head)
(debug "Macro ~a\n" #'head) (debug "Macro ~a\n" #'head)
(do-macro #'head #'(rest ...) precedence left current stream)] (do-macro #'head #'(rest ...) precedence left current stream)]
[(parsed-syntax? #'head) [(parsed-syntax? #'head)
(debug "Parsed syntax ~a\n" #'head) (debug "Parsed syntax ~a\n" #'head)
(emit-local-step #'head #'head #:id #'do-parse) (emit-local-step #'head #'head #:id #'do-parse)
(if current (if current
(values current stream) (values current stream)
(do-parse #'(rest ...) precedence left #'head))] (do-parse #'(rest ...) precedence left #'head))]
[(honu-fixture? #'head) [(honu-fixture? #'head)
(debug 2 "Fixture ~a\n" #'head) (debug 2 "Fixture ~a\n" #'head)
(define transformer (fixture:fixture-ref (syntax-local-value #'head) 0)) (define transformer (fixture:fixture-ref (syntax-local-value #'head) 0))
(define-values (output rest) (transformer current stream)) (define-values (output rest) (transformer current stream))
(do-parse rest precedence left output)] (do-parse rest precedence left output)]
[(honu-operator? #'head) [(honu-operator? #'head)
(define operator (syntax-local-value #'head)) (define operator (syntax-local-value #'head))
(define new-precedence (transformer:operator-precedence operator)) (define new-precedence (transformer:operator-precedence operator))
(define association (transformer:operator-association operator)) (define association (transformer:operator-association operator))
(define binary-transformer (transformer:operator-binary-transformer operator)) (define binary-transformer (transformer:operator-binary-transformer operator))
(define unary-transformer (transformer:operator-unary-transformer operator)) (define unary-transformer (transformer:operator-unary-transformer operator))
(define postfix? (transformer:operator-postfix? operator)) (define postfix? (transformer:operator-postfix? operator))
(define higher (define higher
(case association (case association
[(left) >] [(left) >]
[(right) >=] [(right) >=]
[else (raise-syntax-error 'parse "invalid associativity. must be either 'left or 'right" association)])) [else (raise-syntax-error 'parse "invalid associativity. must be either 'left or 'right" association)]))
(debug "precedence old ~a new ~a higher? ~a\n" precedence new-precedence (higher new-precedence precedence)) (debug "precedence old ~a new ~a higher? ~a\n" precedence new-precedence (higher new-precedence precedence))
(if (higher new-precedence precedence) (if (higher new-precedence precedence)
(let-values ([(parsed unparsed) (let-values ([(parsed unparsed)
(do-parse #'(rest ...) new-precedence (do-parse #'(rest ...) new-precedence
(lambda (stuff) (lambda (stuff)
(define right (parse-all stuff)) (define right (parse-all stuff))
(define output (define output
@ -445,162 +445,162 @@
(with-syntax ([out (parse-all output)]) (with-syntax ([out (parse-all output)])
#'out)) #'out))
#f)]) #f)])
(do-parse unparsed precedence left parsed)) (do-parse unparsed precedence left parsed))
;; if we have a unary transformer then we have to keep parsing ;; if we have a unary transformer then we have to keep parsing
(if unary-transformer (if unary-transformer
(if current (if current
(if postfix? (if postfix?
(do-parse #'(rest ...) (do-parse #'(rest ...)
precedence precedence
left left
(unary-transformer current)) (unary-transformer current))
(values (left current) stream)) (values (left current) stream))
(do-parse #'(rest ...) new-precedence (do-parse #'(rest ...) new-precedence
(lambda (stuff) (lambda (stuff)
(define right (parse-all stuff)) (define right (parse-all stuff))
(define output (unary-transformer right)) (define output (unary-transformer right))
;; apply the left function because ;; apply the left function because
;; we just went ahead with parsing without ;; we just went ahead with parsing without
;; caring about precedence ;; caring about precedence
(with-syntax ([out (left (parse-all output))]) (with-syntax ([out (left (parse-all output))])
#'out)) #'out))
#f)) #f))
;; otherwise we have a binary transformer (or no transformer..??) ;; otherwise we have a binary transformer (or no transformer..??)
;; so we must have made a recursive call to parse, just return the ;; so we must have made a recursive call to parse, just return the
;; left hand ;; left hand
(values (left current) stream)) (values (left current) stream))
)] )]
#; #;
[(stopper? #'head) [(stopper? #'head)
(debug "Parse a stopper ~a\n" #'head) (debug "Parse a stopper ~a\n" #'head)
(values (left final) (values (left final)
stream)] stream)]
[else [else
(define-splicing-syntax-class no-left (define-splicing-syntax-class no-left
[pattern (~seq) #:when (and (= precedence 0) (not current))]) [pattern (~seq) #:when (and (= precedence 0) (not current))])
(syntax-parse #'(head rest ...) #:literal-sets (cruft) (syntax-parse #'(head rest ...) #:literal-sets (cruft)
#; #;
[(semicolon . rest) [(semicolon . rest)
(debug "Parsed a semicolon, finishing up with ~a\n" current) (debug "Parsed a semicolon, finishing up with ~a\n" current)
(values (left current) #'rest)] (values (left current) #'rest)]
[body:honu-body [body:honu-body
(if current (if current
(values (left current) stream) (values (left current) stream)
(values (left #'body.result) #'()) (values (left #'body.result) #'())
#; #;
(do-parse #'(rest ...) precedence left #'body.result))] (do-parse #'(rest ...) precedence left #'body.result))]
#;
[((semicolon more ...) . rest)
#; #;
(define-values (parsed unparsed) [((semicolon more ...) . rest)
(do-parse #'(more ...) #;
0 (define-values (parsed unparsed)
(lambda (x) x) (do-parse #'(more ...)
#f)) 0
(lambda (x) x)
#f))
#;
(when (not (stx-null? unparsed))
(raise-syntax-error 'parse "found unparsed input" unparsed))
(values (parse-all #'(more ...)) #'rest)]
#; #;
(when (not (stx-null? unparsed)) [(left:no-left function:honu-function . rest)
(raise-syntax-error 'parse "found unparsed input" unparsed)) (values #'function.result #'rest)]
(values (parse-all #'(more ...)) #'rest)] [else
#;
[(left:no-left function:honu-function . rest)
(values #'function.result #'rest)]
[else
(debug "Parse a single thing ~a\n" (syntax->datum #'head)) (debug "Parse a single thing ~a\n" (syntax->datum #'head))
(syntax-parse #'head (syntax-parse #'head
#:literal-sets (cruft) #:literal-sets (cruft)
[x:atom [x:atom
(debug 2 "atom ~a current ~a\n" #'x current) (debug 2 "atom ~a current ~a\n" #'x current)
(if current (if current
(values (left current) stream) (values (left current) stream)
(do-parse #'(rest ...) precedence left (racket-syntax x)))] (do-parse #'(rest ...) precedence left (racket-syntax x)))]
;; [1, 2, 3] -> (list 1 2 3) ;; [1, 2, 3] -> (list 1 2 3)
[(#%brackets stuff ...) [(#%brackets stuff ...)
(define-literal-set wheres (honu-where)) (define-literal-set wheres (honu-where))
(define-literal-set equals (honu-equal)) (define-literal-set equals (honu-equal))
(syntax-parse #'(stuff ...) #:literal-sets (cruft wheres equals) (syntax-parse #'(stuff ...) #:literal-sets (cruft wheres equals)
[(work:honu-expression [(work:honu-expression
colon (~seq variable:id honu-equal list:honu-expression (~optional honu-comma)) ... colon (~seq variable:id honu-equal list:honu-expression (~optional honu-comma)) ...
(~seq honu-where where:honu-expression (~optional honu-comma)) ...) (~seq honu-where where:honu-expression (~optional honu-comma)) ...)
(define filter (if (attribute where) (define filter (if (attribute where)
#'((#:when where.result) ...) #'((#:when where.result) ...)
#'())) #'()))
(define comprehension (define comprehension
(with-syntax ([((filter ...) ...) filter]) (with-syntax ([((filter ...) ...) filter])
(racket-syntax (for/list ([variable list.result] (racket-syntax (for/list ([variable list.result]
... ...
filter ... ...) filter ... ...)
work.result)))) work.result))))
(if current (if current
(values (left current) stream) (values (left current) stream)
(do-parse #'(rest ...) precedence left comprehension))] (do-parse #'(rest ...) precedence left comprehension))]
[else [else
(debug "Current is ~a\n" current) (debug "Current is ~a\n" current)
(define value (with-syntax ([(data ...) (define value (with-syntax ([(data ...)
(parse-comma-expression #'(stuff ...))]) (parse-comma-expression #'(stuff ...))])
(debug "Create list from ~a\n" #'(data ...)) (debug "Create list from ~a\n" #'(data ...))
(racket-syntax (list data ...)))) (racket-syntax (list data ...))))
(define lookup (with-syntax ([(data ...) (define lookup (with-syntax ([(data ...)
(parse-comma-expression #'(stuff ...))] (parse-comma-expression #'(stuff ...))]
[current current]) [current current])
(racket-syntax (do-lookup current data ...)))) (racket-syntax (do-lookup current data ...))))
(if current (if current
;; (values (left current) stream) ;; (values (left current) stream)
(do-parse #'(rest ...) precedence left lookup) (do-parse #'(rest ...) precedence left lookup)
(do-parse #'(rest ...) precedence left value))])] (do-parse #'(rest ...) precedence left value))])]
;; block of code ;; block of code
[body:honu-body [body:honu-body
(if current (if current
(values (left current) stream) (values (left current) stream)
(do-parse #'(rest ...) precedence left #'body.result))] (do-parse #'(rest ...) precedence left #'body.result))]
;; expression or function application ;; expression or function application
[(#%parens args ...) [(#%parens args ...)
(debug "Maybe function call with ~a\n" #'(args ...)) (debug "Maybe function call with ~a\n" #'(args ...))
(if current (if current
;; FIXME: 9000 is an arbitrary precedence level for ;; FIXME: 9000 is an arbitrary precedence level for
;; function calls ;; function calls
(if (> precedence 9000) (if (> precedence 9000)
(let () (let ()
(debug 2 "higher precedence call ~a\n" current) (debug 2 "higher precedence call ~a\n" current)
(define call (with-syntax ([current (left current)] (define call (with-syntax ([current (left current)]
[(parsed-args ...) [(parsed-args ...)
(parse-comma-expression #'(args ...)) ]) (parse-comma-expression #'(args ...)) ])
(racket-syntax (current parsed-args ...)))) (racket-syntax (current parsed-args ...))))
(do-parse #'(rest ...) 9000 (lambda (x) x) call)) (do-parse #'(rest ...) 9000 (lambda (x) x) call))
(let () (let ()
(debug 2 "function call ~a\n" left) (debug 2 "function call ~a\n" left)
(define call (with-syntax ([current current] (define call (with-syntax ([current current]
[(parsed-args ...) [(parsed-args ...)
(parse-comma-expression #'(args ...)) ]) (parse-comma-expression #'(args ...)) ])
(debug "Parsed args ~a\n" #'(parsed-args ...)) (debug "Parsed args ~a\n" #'(parsed-args ...))
(racket-syntax (current parsed-args ...)))) (racket-syntax (current parsed-args ...))))
(do-parse #'(rest ...) precedence left call))) (do-parse #'(rest ...) precedence left call)))
(let () (let ()
(debug "inner expression ~a\n" #'(args ...)) (debug "inner expression ~a\n" #'(args ...))
(define-values (inner-expression unparsed) (parse #'(args ...))) (define-values (inner-expression unparsed) (parse #'(args ...)))
(when (not (empty-syntax? unparsed)) (when (not (empty-syntax? unparsed))
(error 'parse "expression had unparsed elements ~a" unparsed)) (error 'parse "expression had unparsed elements ~a" unparsed))
(do-parse #'(rest ...) precedence left inner-expression))) (do-parse #'(rest ...) precedence left inner-expression)))
#; #;
(do-parse #'(rest ...) (do-parse #'(rest ...)
0 0
(lambda (x) x) (lambda (x) x)
(left (with-syntax ([current current] (left (with-syntax ([current current]
[(parsed-args ...) [(parsed-args ...)
(if (null? (syntax->list #'(args ...))) (if (null? (syntax->list #'(args ...)))
'() '()
(list (parse #'(args ...))))]) (list (parse #'(args ...))))])
#'(current parsed-args ...)))) #'(current parsed-args ...))))
#; #;
(error 'parse "function call")] (error 'parse "function call")]
#; #;
[else (if (not current) [else (if (not current)
(error 'what "don't know how to parse ~a" #'head) (error 'what "don't know how to parse ~a" #'head)
(values (left current) stream))] (values (left current) stream))]
[else (error 'parser "don't know how to parse ~a" #'head)])])])]))) [else (error 'parser "don't know how to parse ~a" #'head)])])])])))
(emit-remark "Honu parse" input) (emit-remark "Honu parse" input)
(define-values (parsed unparsed) (define-values (parsed unparsed)
@ -635,8 +635,7 @@
(parse (strip-stops code))) (parse (strip-stops code)))
(define parsed (if (parsed-syntax? parsed-original) (define parsed (if (parsed-syntax? parsed-original)
parsed-original parsed-original
(let-values ([(out rest) (let-values ([(out rest) (parse parsed-original)])
(parse parsed-original)])
(when (not (empty-syntax? rest)) (when (not (empty-syntax? rest))
(raise-syntax-error 'parse-all "expected no more syntax" parsed-original)) (raise-syntax-error 'parse-all "expected no more syntax" parsed-original))
out))) out)))

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

@ -399,7 +399,7 @@
(lambda (current tokens table) (lambda (current tokens table)
(define added (add-dispatch-rule (define added (add-dispatch-rule
(add-dispatch-rule dispatch-table [list next do-end-encloser]) (add-dispatch-rule dispatch-table [list next do-end-encloser])
[list null? (do-fail failure-name)])) [list null? (do-fail failure-name)]))
(define-values (sub-tree unparsed) (define-values (sub-tree unparsed)
(do-parse (list (make-syntax head (car tokens) source)) (do-parse (list (make-syntax head (car tokens) source))
(cdr tokens) added)) (cdr tokens) added))

6
collects/lang/private/signature-syntax.rkt
View File

@ -47,9 +47,9 @@
#'(when (signature? ?temp) #'(when (signature? ?temp)
?raise)))) ?raise))))
(syntax->list #'((?temp ?exp) ...))))) (syntax->list #'((?temp ?exp) ...)))))
#'(let ((?temp ?exp) ...) #'(let ((?temp ?exp) ...)
?check ... ?check ...
(make-case-signature '?name (list ?temp ...) equal? ?stx))))) (make-case-signature '?name (list ?temp ...) equal? ?stx)))))
((predicate ?exp) ((predicate ?exp)
(with-syntax ((?stx (phase-lift stx)) (with-syntax ((?stx (phase-lift stx))
(?name name)) (?name name))

2
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -130,7 +130,7 @@
[(enter-check (? CheckImmediateMacro/Inner) exit-check) [(enter-check (? CheckImmediateMacro/Inner) exit-check)
($2 $1 $3)]) ($2 $1 $3)])
(CheckImmediateMacro/Inner (CheckImmediateMacro/Inner
(#:args le1 e2) (#:args le1 e2)
[(!) [(!)
(make p:stop le1 e2 null $1)] (make p:stop le1 e2 null $1)]
[(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner)) [(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))

14
collects/macro-debugger/syntax-browser/display.rkt
View File

@ -106,12 +106,12 @@
(define lazy-interval-map-init (define lazy-interval-map-init
(delay (delay
(with-log-time "forcing clickback mapping" (with-log-time "forcing clickback mapping"
(uninterruptible (uninterruptible
(for ([range (send/i range range<%> all-ranges)]) (for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)] (let ([stx (range-obj range)]
[start (range-start range)] [start (range-start range)]
[end (range-end range)]) [end (range-end range)])
(interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) (interval-map-set! mapping (+ start-position start) (+ start-position end) stx)))))))
(define (the-callback position) (define (the-callback position)
(force lazy-interval-map-init) (force lazy-interval-map-init)
(send/i controller selection-manager<%> set-selected-syntax (send/i controller selection-manager<%> set-selected-syntax
@ -123,7 +123,7 @@
;; Clears all highlighting and reapplies all non-foreground styles. ;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh) (define/public (refresh)
(with-log-time "refresh" (with-log-time "refresh"
(with-unlock text (with-unlock text
(uninterruptible (uninterruptible
(let ([undo-select/highlight-d (get-undo-select/highlight-d)]) (let ([undo-select/highlight-d (get-undo-select/highlight-d)])
(for ([r (in-list to-undo-styles)]) (for ([r (in-list to-undo-styles)])

36
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -134,32 +134,32 @@
(define range (send/i display display<%> get-range)) (define range (send/i display display<%> get-range))
(define offset (send/i display display<%> get-start-position)) (define offset (send/i display display<%> get-start-position))
(with-log-time "substitutions" (with-log-time "substitutions"
(for ([subst (in-list substitutions)]) (for ([subst (in-list substitutions)])
(for ([r (in-list (send/i range range<%> get-ranges (car subst)))]) (for ([r (in-list (send/i range range<%> get-ranges (car subst)))])
(send -text insert (cdr subst) (send -text insert (cdr subst)
(+ offset (car r)) (+ offset (car r))
(+ offset (cdr r)) (+ offset (cdr r))
#f) #f)
(send -text change-style (send -text change-style
(code-style -text (send/i config config<%> get-syntax-font-size)) (code-style -text (send/i config config<%> get-syntax-font-size))
(+ offset (car r)) (+ offset (car r))
(+ offset (cdr r)) (+ offset (cdr r))
#f)))) #f))))
;; Apply highlighting ;; Apply highlighting
(with-log-time "highlights" (with-log-time "highlights"
(for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)]) (for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)])
(send/i display display<%> highlight-syntaxes hi-stxs hi-color))) (send/i display display<%> highlight-syntaxes hi-stxs hi-color)))
;; Underline binders (and shifted binders) ;; Underline binders (and shifted binders)
(with-log-time "underline binders" (with-log-time "underline binders"
(send/i display display<%> underline-syntaxes (send/i display display<%> underline-syntaxes
(let ([binder-list (hash-map binders (lambda (k v) k))]) (let ([binder-list (hash-map binders (lambda (k v) k))])
(append (apply append (map get-shifted binder-list)) (append (apply append (map get-shifted binder-list))
binder-list)))) binder-list))))
(send display refresh) (send display refresh)
;; Make arrows (& billboards, when enabled) ;; Make arrows (& billboards, when enabled)
(with-log-time "add arrows" (with-log-time "add arrows"
(when (send config get-draw-arrows?) (when (send config get-draw-arrows?)
(define (definite-phase id) (define (definite-phase id)
(and definites (and definites
(or (eomap-ref definites id #f) (or (eomap-ref definites id #f)

2
collects/math/private/distributions/exponential-dist.rkt
View File

@ -48,7 +48,7 @@
(begin-encourage-inline (begin-encourage-inline
(: exponential-dist (case-> (-> Exponential-Dist) (: exponential-dist (case-> (-> Exponential-Dist)
(Real -> Exponential-Dist))) (Real -> Exponential-Dist)))
(define (exponential-dist [s 1.0]) (define (exponential-dist [s 1.0])
(let ([s (fl s)]) (let ([s (fl s)])
(define pdf (opt-lambda: ([x : Real] [log? : Any #f]) (define pdf (opt-lambda: ([x : Real] [log? : Any #f])

8
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -78,10 +78,10 @@
[w (NSSize-width (NSRect-size f))] [w (NSSize-width (NSRect-size f))]
[y (+ (NSPoint-y (NSRect-origin f)) [y (+ (NSPoint-y (NSRect-origin f))
(NSSize-height (NSRect-size f)))]) (NSSize-height (NSRect-size f)))])
(lambda (p) (lambda (p)
(let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)])
(and (<= x (NSPoint-x p) (+ x w)) (and (<= x (NSPoint-x p) (+ x w))
(<= (- y h) (NSPoint-y p) y))))))) (<= (- y h) (NSPoint-y p) y)))))))
(set-menu-bar-hooks! in-menu-bar-range) (set-menu-bar-hooks! in-menu-bar-range)

11
collects/mred/private/wx/gtk/frame.rkt
View File

@ -381,12 +381,11 @@
(if big-icon (if big-icon
(list (bitmap->pixbuf big-icon)) (list (bitmap->pixbuf big-icon))
(cdr (car (force icon-pixbufs+glist))))]) (cdr (car (force icon-pixbufs+glist))))])
(atomically (atomically
(let ([l (for/fold ([l #f]) ([i (cons small-pixbuf (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf big-pixbufs)])
big-pixbufs)]) (g_list_insert l i -1))])
(g_list_insert l i -1))]) (gtk_window_set_icon_list gtk l)
(gtk_window_set_icon_list gtk l) (g_list_free l))))))
(g_list_free l))))))
(define child-has-focus? #f) (define child-has-focus? #f)
(define reported-activate #f) (define reported-activate #f)

103
collects/mred/private/wx/gtk/window.rkt
View File

@ -327,57 +327,58 @@
(if crossing? (if crossing?
(GdkEventCrossing-state event) (GdkEventCrossing-state event)
(GdkEventButton-state event)))] (GdkEventButton-state event)))]
[bit? (lambda (m v) (positive? (bitwise-and m v)))] [bit? (lambda (m v) (positive? (bitwise-and m v)))]
[type (cond [type (cond
[(= type GDK_MOTION_NOTIFY) [(= type GDK_MOTION_NOTIFY)
'motion] 'motion]
[(= type GDK_ENTER_NOTIFY) [(= type GDK_ENTER_NOTIFY)
'enter] 'enter]
[(= type GDK_LEAVE_NOTIFY) [(= type GDK_LEAVE_NOTIFY)
'leave] 'leave]
[(= type GDK_BUTTON_PRESS) [(= type GDK_BUTTON_PRESS)
(case (GdkEventButton-button event) (case (GdkEventButton-button event)
[(1) 'left-down] [(1) 'left-down]
[(3) 'right-down] [(3) 'right-down]
[else 'middle-down])] [else 'middle-down])]
[else [else
(case (GdkEventButton-button event) (case (GdkEventButton-button event)
[(1) 'left-up] [(1) 'left-up]
[(3) 'right-up] [(3) 'right-up]
[else 'middle-up])])] [else 'middle-up])])]
[m (let-values ([(x y) (send wx [m (let-values ([(x y)
adjust-event-position (send wx
(->long ((if motion? adjust-event-position
GdkEventMotion-x (->long ((if motion?
(if crossing? GdkEventCrossing-x GdkEventButton-x)) GdkEventMotion-x
event)) (if crossing? GdkEventCrossing-x GdkEventButton-x))
(->long ((if motion? GdkEventMotion-y event))
(if crossing? GdkEventCrossing-y GdkEventButton-y)) (->long ((if motion? GdkEventMotion-y
event)))]) (if crossing? GdkEventCrossing-y GdkEventButton-y))
(new mouse-event% event)))])
[event-type type] (new mouse-event%
[left-down (case type [event-type type]
[(left-down) #t] [left-down (case type
[(left-up) #f] [(left-down) #t]
[else (bit? modifiers GDK_BUTTON1_MASK)])] [(left-up) #f]
[middle-down (case type [else (bit? modifiers GDK_BUTTON1_MASK)])]
[(middle-down) #t] [middle-down (case type
[(middle-up) #f] [(middle-down) #t]
[else (bit? modifiers GDK_BUTTON2_MASK)])] [(middle-up) #f]
[right-down (case type [else (bit? modifiers GDK_BUTTON2_MASK)])]
[(right-down) #t] [right-down (case type
[(right-up) #f] [(right-down) #t]
[else (bit? modifiers GDK_BUTTON3_MASK)])] [(right-up) #f]
[x x] [else (bit? modifiers GDK_BUTTON3_MASK)])]
[y y] [x x]
[shift-down (bit? modifiers GDK_SHIFT_MASK)] [y y]
[control-down (bit? modifiers GDK_CONTROL_MASK)] [shift-down (bit? modifiers GDK_SHIFT_MASK)]
[meta-down (bit? modifiers GDK_META_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)]
[alt-down (bit? modifiers GDK_MOD1_MASK)] [meta-down (bit? modifiers GDK_META_MASK)]
[time-stamp ((if motion? GdkEventMotion-time [alt-down (bit? modifiers GDK_MOD1_MASK)]
(if crossing? GdkEventCrossing-time GdkEventButton-time)) [time-stamp ((if motion? GdkEventMotion-time
event)] (if crossing? GdkEventCrossing-time GdkEventButton-time))
[caps-down (bit? modifiers GDK_LOCK_MASK)]))]) event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)]))])
(if (send wx handles-events? gtk) (if (send wx handles-events? gtk)
(begin (begin
(queue-window-event wx (lambda () (queue-window-event wx (lambda ()

190
collects/mred/private/wxme/text.rkt
View File

@ -1376,10 +1376,10 @@
(set! flow-locked? #f) (set! flow-locked? #f)
(when deleted? (when deleted?
(end-edit-sequence)))]) (end-edit-sequence)))])
(cond (cond
[(or isnip snipsl) [(or isnip snipsl)
(insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)] (insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)]
[else (insert-string str start success-finish fail-finish)]))))) [else (insert-string str start success-finish fail-finish)])))))
(assert (consistent-snip-lines 'post-do-insert)))) (assert (consistent-snip-lines 'post-do-insert))))
(define/private (insert-snips snipsl start success-finish fail-finish) (define/private (insert-snips snipsl start success-finish fail-finish)
@ -2609,15 +2609,15 @@
(= current v) (= current v)
(and (v . <= . 0) (current . <= . 0)) (and (v . <= . 0) (current . <= . 0))
(not (can-set-size-constraint?))) (not (can-set-size-constraint?)))
(on-set-size-constraint) (on-set-size-constraint)
(set! graphic-maybe-invalid? #t) (set! graphic-maybe-invalid? #t)
(set! graphic-maybe-invalid-force? #t) (set! graphic-maybe-invalid-force? #t)
(setter v) (setter v)
(set! changed? #t) (set! changed? #t)
(need-refresh -1 -1) (need-refresh -1 -1)
(after-set-size-constraint)))) (after-set-size-constraint))))
(def/override (set-min-width [(make-alts nonnegative-real? (symbol-in none)) w]) (def/override (set-min-width [(make-alts nonnegative-real? (symbol-in none)) w])
(set-m-x w min-width (lambda (w) (set! min-width w)))) (set-m-x w min-width (lambda (w) (set! min-width w))))
@ -5658,93 +5658,93 @@
(get-default-print-size W H)) (get-default-print-size W H))
(when (not (zero? page)) (when (not (zero? page))
(send (current-ps-setup) get-editor-margin hm vm))) (send (current-ps-setup) get-editor-margin hm vm)))
(let ([H (- H (* 2 vm))] (let ([H (- H (* 2 vm))]
[W (- W (* 2 hm))]) [W (- W (* 2 hm))])
;; H is the total page height; ;; H is the total page height;
;; line is the line that we haven't finished printing; ;; line is the line that we haven't finished printing;
;; y is the starting location to print for this page; ;; y is the starting location to print for this page;
;; h is the height that we're hoping to fit into the page ;; h is the height that we're hoping to fit into the page
;; i is the line number ;; i is the line number
(let ploop ([this-page 1] (let ploop ([this-page 1]
[line first-line] [line first-line]
[y 0.0] [y 0.0]
[next-h 0.0] [next-h 0.0]
[i 0]) [i 0])
(and (and
line line
(let ([h next-h] (let ([h next-h]
[next-h 0.0]) [next-h 0.0])
(let loop ([h h] (let loop ([h h]
[i i] [i i]
[line line] [line line]
[can-continue? #t] [can-continue? #t]
[unline 0.0]) [unline 0.0])
(cond (cond
[(or (zero? h) [(or (zero? h)
(and (i . < . num-valid-lines) (and (i . < . num-valid-lines)
(or (zero? page) (or (zero? page)
((mline-h line) . < . (- H h))) ((mline-h line) . < . (- H h)))
can-continue?)) can-continue?))
(let ([lh (mline-h line)] (let ([lh (mline-h line)]
[new-page? (new-page-line? line)]) [new-page? (new-page-line? line)])
(loop (+ h lh) (loop (+ h lh)
(add1 i) (add1 i)
(mline-next line) (mline-next line)
(not new-page?) (not new-page?)
(if new-page? lh unline)))] (if new-page? lh unline)))]
[else [else
(let-values ([(h i line) (let-values ([(h i line)
(cond (cond
[(and (not (zero? page)) [(and (not (zero? page))
(h . < . H) (h . < . H)
(i . < . num-valid-lines) (i . < . num-valid-lines)
((mline-h line) . > . H)) ((mline-h line) . > . H))
;; we'll have to break it up anyway; start now? ;; we'll have to break it up anyway; start now?
(let* ([pos (find-scroll-line (+ y H))]
[py (scroll-line-location pos)])
(if (py . > . (+ y h))
;; yes, at least one line will fit
(values (+ h (mline-h line))
(add1 i)
(mline-next line))
(values h i line)))]
[else
(values h i line)])])
(let-values ([(next-h h)
(if (and (not (zero? page))
(h . > . H))
;; only happens if we have something that's too big to fit on a page;
;; look for internal scroll positions
(let* ([pos (find-scroll-line (+ y H))] (let* ([pos (find-scroll-line (+ y H))]
[py (scroll-line-location pos)]) [py (scroll-line-location pos)])
(if (py . > . y) (if (py . > . (+ y h))
(let ([new-h (- py y)]) ;; yes, at least one line will fit
(values (- h new-h) (values (+ h (mline-h line))
new-h)) (add1 i)
(values next-h h))) (mline-next line))
(values next-h h))]) (values h i line)))]
(or (if print? [else
(begin (values h i line)])])
(when (or (page . <= . 0) (let-values ([(next-h h)
(= this-page page)) (if (and (not (zero? page))
(begin (h . > . H))
(when (page . <= . 0) ;; only happens if we have something that's too big to fit on a page;
(send dc start-page)) ;; look for internal scroll positions
(do-redraw dc (let* ([pos (find-scroll-line (+ y H))]
(+ y (if (zero? i) 0 1)) [py (scroll-line-location pos)])
(+ y (- h 1 unline)) (if (py . > . y)
0 W (+ (- y) vm) hm (let ([new-h (- py y)])
'no-caret #f #f) (values (- h new-h)
(when (page . <= . 0) new-h))
(send dc end-page)))) (values next-h h)))
#f) (values next-h h))])
(= this-page page)) (or (if print?
(ploop (add1 this-page) (begin
line (when (or (page . <= . 0)
(+ y h) (= this-page page))
next-h (begin
i))))]))))))))))) (when (page . <= . 0)
(send dc start-page))
(do-redraw dc
(+ y (if (zero? i) 0 1))
(+ y (- h 1 unline))
0 W (+ (- y) vm) hm
'no-caret #f #f)
(when (page . <= . 0)
(send dc end-page))))
#f)
(= this-page page))
(ploop (add1 this-page)
line
(+ y h)
next-h
i))))])))))))))))
(define/override (do-has-print-page? dc page) (define/override (do-has-print-page? dc page)
(has/print-page dc page #f)) (has/print-page dc page #f))

12
collects/mzlib/include.rkt
View File

@ -90,13 +90,13 @@
(if (regexp-match? #rx#"[.]rkt$" b) (if (regexp-match? #rx#"[.]rkt$" b)
(path-replace-suffix p #".ss") (path-replace-suffix p #".ss")
p)))]) p)))])
(let ([c-file (if (file-exists? orig-c-file) (let ([c-file (if (file-exists? orig-c-file)
orig-c-file orig-c-file
(let ([p2 (rkt->ss orig-c-file)]) (let ([p2 (rkt->ss orig-c-file)])
(if (file-exists? p2) (if (file-exists? p2)
p2 p2
orig-c-file)))]) orig-c-file)))])
(register-external-file c-file) (register-external-file c-file)
(let ([read-syntax (if (syntax-e reader) (let ([read-syntax (if (syntax-e reader)

4
collects/openssl/mzssl.rkt
View File

@ -372,9 +372,7 @@ TO DO:
(define-syntax with-failure (define-syntax with-failure
(syntax-rules () (syntax-rules ()
[(_ thunk body ...) [(_ thunk body ...)
(with-handlers ([exn? (lambda (exn) (with-handlers ([exn? (lambda (exn) (thunk) (raise exn))])
(thunk)
(raise exn))])
body ...)])) body ...)]))
(define (get-error-message id) (define (get-error-message id)

10
collects/parser-tools/private-yacc/input-file-parser.rkt
View File

@ -46,11 +46,11 @@
(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)] (datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)]
[end-pos-id [end-pos-id
(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)]) (datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)])
(set! biggest-pos (cons start-pos-id end-pos-id)) (set! biggest-pos (cons start-pos-id end-pos-id))
`(,(datum->syntax-object b name b stx-for-original-property) `(,(datum->syntax-object b name b stx-for-original-property)
,start-pos-id ,start-pos-id
,end-pos-id ,end-pos-id
,@(get-args (add1 i) (cdr rhs))))) ,@(get-args (add1 i) (cdr rhs)))))
(else (else
`(,(datum->syntax-object b name b stx-for-original-property) `(,(datum->syntax-object b name b stx-for-original-property)
,@(get-args (add1 i) (cdr rhs)))))))))]) ,@(get-args (add1 i) (cdr rhs)))))))))])

8
collects/parser-tools/private-yacc/lr0.rkt
View File

@ -22,10 +22,10 @@
(define (trans-key<? a b) (define (trans-key<? a b)
(let ((kia (kernel-index (trans-key-st a))) (let ((kia (kernel-index (trans-key-st a)))
(kib (kernel-index (trans-key-st b)))) (kib (kernel-index (trans-key-st b))))
(or (< kia kib) (or (< kia kib)
(and (= kia kib) (and (= kia kib)
(< (non-term-index (trans-key-gs a)) (< (non-term-index (trans-key-gs a))
(non-term-index (trans-key-gs b))))))) (non-term-index (trans-key-gs b)))))))
(define (trans-key-list-remove-dups tkl) (define (trans-key-list-remove-dups tkl)
(let loop ((sorted (sort tkl trans-key<?))) (let loop ((sorted (sort tkl trans-key<?)))

5
collects/parser-tools/private-yacc/parser-builder.rkt
View File

@ -9,8 +9,9 @@
(provide/contract (provide/contract
(build-parser ((string? any/c any/c (listof identifier?) (listof identifier?) (build-parser ((string? any/c any/c (listof identifier?) (listof identifier?)
(listof identifier?) (union syntax? false/c) syntax?) . ->* . (listof identifier?) (union syntax? false/c) syntax?)
(any/c any/c any/c any/c)))) . ->* .
(any/c any/c any/c any/c))))
;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?) ;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?)
;; (union syntax? false/c) syntax?) -> syntax? ;; (union syntax? false/c) syntax?) -> syntax?

2
collects/picturing-programs/main.rkt
View File

@ -15,7 +15,7 @@
show-it) show-it)
(provide provide all-defined-out all-from-out rename-out except-out (provide provide all-defined-out all-from-out rename-out except-out
prefix-out struct-out) prefix-out struct-out)
(define (show-it img) (define (show-it img)
(check-arg 'show-it (image? img) "image" "first" img) (check-arg 'show-it (image? img) "image" "first" img)

2
collects/plai/private/gc-transformer.rkt
View File

@ -14,7 +14,7 @@
[id (identifier? stx) [id (identifier? stx)
(begin (begin
(unless (dict-ref id-hash stx false) (unless (dict-ref id-hash stx false)
(dict-set! id-hash stx true)))] (dict-set! id-hash stx true)))]
[_ (void)])]) [_ (void)])])
(find stx) (find stx)
(filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids))) (filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids)))

12
collects/plai/test-harness.rkt
View File

@ -111,12 +111,12 @@
(with-handlers (with-handlers
; Applying the predicate shouldn't raise an exception. ; Applying the predicate shouldn't raise an exception.
([exn+catching? (λ (exn) ([exn+catching? (λ (exn)
(print-error (print-error
'pred-exception 'pred-exception
test-sexp test-sexp
(exn-message exn) (exn-message exn)
'<no-expected-value> '<no-expected-value>
loc))]) loc))])
(let ([test-result (return-exception (test-thunk))]) (let ([test-result (return-exception (test-thunk))])
(if (or (exn:plai? test-result) (if (or (exn:plai? test-result)
(not (exn? test-result))) (not (exn? test-result)))

2
collects/planet2/lib.rkt
View File

@ -956,7 +956,7 @@
(report-mismatch update-deps)] (report-mismatch update-deps)]
[x [x
(eprintf "Invalid input: ~e\n" x) (eprintf "Invalid input: ~e\n" x)
(loop)]))]))] (loop)]))]))]
[else [else
(λ () (λ ()
(define final-pkg-dir (define final-pkg-dir

52
collects/r6rs/private/find-version.rkt
View File

@ -16,40 +16,40 @@
(lambda (file) (lambda (file)
(let ([s (path-element->bytes file)]) (let ([s (path-element->bytes file)])
(and (and
(and (len . < . (bytes-length s)) (and (len . < . (bytes-length s))
(bytes=? p (subbytes s 0 len))) (bytes=? p (subbytes s 0 len)))
(let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$" (let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$"
(subbytes s len))]) (subbytes s len))])
(and m (and m
(or (not (cadr m)) (or (not (cadr m))
(bytes=? (cadr m) #".mzscheme")) (bytes=? (cadr m) #".mzscheme"))
(car m)))]) (car m)))])
(and ext (and ext
(or (and (= (bytes-length s) (+ len (bytes-length ext))) (or (and (= (bytes-length s) (+ len (bytes-length ext)))
(cons null ext)) (cons null ext))
(let ([vers (subbytes s len (- (bytes-length s) (bytes-length ext)))]) (let ([vers (subbytes s len (- (bytes-length s) (bytes-length ext)))])
(and (regexp-match #rx#"^(-[0-9]+)+$" vers) (and (regexp-match #rx#"^(-[0-9]+)+$" vers)
(cons (cons
(map string->number (map string->number
(cdr (cdr
(map bytes->string/latin-1 (map bytes->string/latin-1
(regexp-split #rx#"-" vers)))) (regexp-split #rx#"-" vers))))
ext))))))))) ext)))))))))
files))] files))]
[versions [versions
(let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls" #".rkt")] (let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls" #".rkt")]
[ext< (lambda (a b) [ext< (lambda (a b)
(> (length (member a eo)) (length (member b eo))))]) (> (length (member a eo)) (length (member b eo))))])
(sort candidate-versions (sort candidate-versions
(lambda (a b) (lambda (a b)
(if (equal? (car a) (car b)) (if (equal? (car a) (car b))
(ext< (cdr a) (cdr b)) (ext< (cdr a) (cdr b))
(let loop ([a (car a)] [b (car b)]) (let loop ([a (car a)] [b (car b)])
(cond (cond
[(null? a) #t] [(null? a) #t]
[(null? b) #f] [(null? b) #f]
[(> (car a) (car b)) #t] [(> (car a) (car b)) #t]
[(< (car a) (car b)) #f] [(< (car a) (car b)) #f]
[else (loop (cdr a) (cdr b))]))))))]) [else (loop (cdr a) (cdr b))]))))))])
(ormap (lambda (candidate-version) (ormap (lambda (candidate-version)
(and (version-match? (car candidate-version) vers) (and (version-match? (car candidate-version) vers)

17
collects/racket/contract/private/exists.rkt
View File

@ -12,16 +12,13 @@
[out (∀∃/c-out ctc)] [out (∀∃/c-out ctc)]
[pred? (∀∃/c-pred? ctc)] [pred? (∀∃/c-pred? ctc)]
[neg? (∀∃/c-neg? ctc)]) [neg? (∀∃/c-neg? ctc)])
(λ (blame) (λ (blame)
(if (eq? neg? (blame-swapped? blame)) (if (eq? neg? (blame-swapped? blame))
(λ (val) (λ (val)
(if (pred? val) (if (pred? val)
(out val) (out val)
(raise-blame-error blame (raise-blame-error blame val "non-polymorphic value: ~e" val)))
val in))))
"non-polymorphic value: ~e"
val)))
in))))
(define-struct ∀∃/c (in out pred? name neg?) (define-struct ∀∃/c (in out pred? name neg?)
#:omit-define-syntaxes #:omit-define-syntaxes

19
collects/racket/contract/private/generate-base.rkt
View File

@ -72,16 +72,15 @@
(λ (fuel) (λ (fuel)
(rand 256)) (rand 256))
bytes? bytes?
(λ (fuel) (λ (fuel)
(let* ([len (rand-choice (let* ([len (rand-choice
[1/10 0] [1/10 0]
[1/10 1] [1/10 1]
[else (+ 2 (rand 260))])] [else (+ 2 (rand 260))])]
[bstr (build-list len [bstr (build-list len
(λ (x) (λ (x) (rand 256)))])
(rand 256)))]) (apply bytes bstr)))))
(apply bytes bstr)))))
;; thread-cell ;; thread-cell

2
collects/racket/contract/private/struct-dc.rkt
View File

@ -535,7 +535,7 @@
#t] #t]
[(#:selector sel-id) [(#:selector sel-id)
(identifier? #'sel-id) (identifier? #'sel-id)
#t] #t]
[(sel-id #:parent struct-id) [(sel-id #:parent struct-id)
(and (identifier? #'sel-id) (and (identifier? #'sel-id)
(identifier? #'struct-id)) (identifier? #'struct-id))

2
collects/racket/draw/bmp.rkt
View File

@ -185,7 +185,7 @@
[height (int2 in)] [height (int2 in)]
[planes (int2 in)] [planes (int2 in)]
[bits-per-pixel (int2 in)]) [bits-per-pixel (int2 in)])
(values width height bits-per-pixel BI_RGB 0 #f))])]) (values width height bits-per-pixel BI_RGB 0 #f))])])
(let* ([color-count (if (zero? color-count) (let* ([color-count (if (zero? color-count)
(arithmetic-shift 1 bits-per-pixel) (arithmetic-shift 1 bits-per-pixel)
color-count)] color-count)]

20
collects/racket/draw/private/lzw.rkt
View File

@ -111,16 +111,16 @@
(lambda (code) (lambda (code)
(let ([j pos]) (let ([j pos])
(let ([i (+ pos (code-depth code))]) (let ([i (+ pos (code-depth code))])
(set! pos (add1 i)) (set! pos (add1 i))
(if (>= i (bytes-length result-bstr)) (if (>= i (bytes-length result-bstr))
(log-warning "Too much input data for image, ignoring extra") (log-warning "Too much input data for image, ignoring extra")
(let loop ([code code] (let loop ([code code]
[i i]) [i i])
;; (printf "set ~a\n" (vector-ref entries code)) ;; (printf "set ~a\n" (vector-ref entries code))
(bytes-set! result-bstr i (vector-ref entries code)) (bytes-set! result-bstr i (vector-ref entries code))
(when (i . > . j) (when (i . > . j)
(loop (vector-ref preds code) (loop (vector-ref preds code)
(sub1 i))))))))]) (sub1 i))))))))])
(let loop ([last-code -1]) (let loop ([last-code -1])
(let ([code (read-bits compression-size bitstream)]) (let ([code (read-bits compression-size bitstream)])
;; (printf "~s: ~s ~s ~s\n" compression-size code clear-code end-of-input) ;; (printf "~s: ~s ~s ~s\n" compression-size code clear-code end-of-input)

2
collects/racket/draw/private/region.rkt
View File

@ -100,7 +100,7 @@
[t (ty l t)] [t (ty l t)]
[r (tx r b)] [r (tx r b)]
[b (ty r b)]) [b (ty r b)])
(values l t (- r l) (- b t)))))))) (values l t (- r l) (- b t))))))))
;; no dc un-transformation needed ;; no dc un-transformation needed
(values l t (- r l) (- b t))) (values l t (- r l) (- b t)))
(let-values ([(l2 t2 w2 h2) (send (caar paths) get-bounding-box)]) (let-values ([(l2 t2 w2 h2) (send (caar paths) get-bounding-box)])

2
collects/racket/match/compiler.rkt
View File

@ -436,7 +436,7 @@
(if (Row-unmatch (car blocks)) (if (Row-unmatch (car blocks))
#`(call-with-continuation-prompt #`(call-with-continuation-prompt
(lambda () (let ([#,(Row-unmatch (car blocks)) (lambda () (let ([#,(Row-unmatch (car blocks))
(lambda () (abort-current-continuation match-prompt-tag))]) (lambda () (abort-current-continuation match-prompt-tag))])
rhs)) rhs))
match-prompt-tag match-prompt-tag
(lambda () (#,esc))) (lambda () (#,esc)))

90
collects/racket/place/define-remote-server.rkt
View File

@ -48,20 +48,20 @@
#;(printf "FORM_NAME ~a ~a ~a\n" #'form-name (syntax->datum #'form-name) #;(printf "FORM_NAME ~a ~a ~a\n" #'form-name (syntax->datum #'form-name)
(equal? (syntax->datum #'form-name) 'define-named-remote-server)) (equal? (syntax->datum #'form-name) 'define-named-remote-server))
(with-syntax ([receive-line (with-syntax ([receive-line
(cond (cond
[(eq? (syntax->datum #'form-name) 'define-named-remote-server) [(eq? (syntax->datum #'form-name) 'define-named-remote-server)
#'(list (list fname-symbol args (... ...)) src)] #'(list (list fname-symbol args (... ...)) src)]
[else [else
#'(list fname-symbol args (... ...))])] #'(list fname-symbol args (... ...))])]
[send-dest [send-dest
(cond (cond
[(eq? (syntax->datum #'form-name) 'define-named-remote-server) [(eq? (syntax->datum #'form-name) 'define-named-remote-server)
#'src] #'src]
[else [else
#'ch])]) #'ch])])
(define x (define x
#'(define-syntax (form-name stx) #'(define-syntax (form-name stx)
(syntax-case stx () (syntax-case stx ()
[(_ name forms (... ...)) [(_ name forms (... ...))
(let () (let ()
@ -111,41 +111,39 @@
(syntax-case r () (syntax-case r ()
[(define-type (fname args (... ...)) body (... ...)) [(define-type (fname args (... ...)) body (... ...))
(let () (let ()
(with-syntax ([fname-symbol #'(quote fname)] (with-syntax ([fname-symbol #'(quote fname)]
[(send-line (... ...)) [(send-line (... ...))
(cond (cond
[(is-id? 'define-rpc #'define-type) #'((dplace/place-channel-put send-dest result))] [(is-id? 'define-rpc #'define-type) #'((dplace/place-channel-put send-dest result))]
[(is-id? 'define-cast #'define-type) #'()] [(is-id? 'define-cast #'define-type) #'()]
[else (raise "Bad define in define-remote-server")])]) [else (raise "Bad define in define-remote-server")])])
#'[receive-line #'[receive-line
(define result (define result
(let () (let ()
body (... ...))) body (... ...)))
send-line (... ...) send-line (... ...)
(loop)]))]))]) (loop)]))]))])
#`(lambda (ch) #`(lambda (ch)
(let () (let ()
states2 (... ...) states2 (... ...)
(let loop () (let loop ()
(define msg (dplace/place-channel-get ch)) (define msg (dplace/place-channel-get ch))
(define (log-to-parent-real msg #:severity [severity 'info]) (define (log-to-parent-real msg #:severity [severity 'info])
(dplace/place-channel-put ch (log-message severity msg))) (dplace/place-channel-put ch (log-message severity msg)))
(syntax-parameterize ([log-to-parent (make-rename-transformer #'log-to-parent-real)]) (syntax-parameterize ([log-to-parent (make-rename-transformer #'log-to-parent-real)])
(match msg (match msg
cases (... ...) cases (... ...)))
)) loop)))))
loop) (with-syntax ([mkname (string->id stx (format "make-~a" (id->string #'name)))])
)))) (define x
(with-syntax ([mkname (string->id stx (format "make-~a" (id->string #'name)))]) #`(begin
(define x (require racket/place
#`(begin racket/match)
(require racket/place #,@trans-rpcs
racket/match) (define/provide mkname #,trans-place)
#,@trans-rpcs (void)))
(define/provide mkname #,trans-place) ;(pretty-print (syntax->datum x))
(void))) x))]))
;(pretty-print (syntax->datum x))
x))]))
) )
;(pretty-print (syntax->datum x)) ;(pretty-print (syntax->datum x))
x)])) x)]))
@ -156,5 +154,3 @@ x)]))
(provide define-remote-server (provide define-remote-server
define-named-remote-server define-named-remote-server
log-to-parent) log-to-parent)

29
collects/racket/place/distributed.rkt
View File

@ -143,10 +143,11 @@
(define (which cmd) (define (which cmd)
(define path (getenv "PATH")) (define path (getenv "PATH"))
(and path (and path
(exists? (map (lambda (x) (build-path x cmd)) (regexp-split (case (system-type 'os) (exists? (map (lambda (x) (build-path x cmd))
[(unix macosx) ":"] (regexp-split (case (system-type 'os)
[(windows) "#:;"]) [(unix macosx) ":"]
path))))) [(windows) "#:;"])
path)))))
(or (which "ssh") (or (which "ssh")
(fallback-paths) (fallback-paths)
(raise "ssh binary not found"))) (raise "ssh binary not found")))
@ -173,21 +174,21 @@
(let loop ([t 0] (let loop ([t 0]
[wait-time start-seconds]) [wait-time start-seconds])
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (e)
(cond [(t . < . times) (cond [(t . < . times)
(klogger (format "backing off ~a sec to ~a:~a" (expt 2 t) rname rport)) (klogger (format "backing off ~a sec to ~a:~a" (expt 2 t) rname rport))
(sleep wait-time) (sleep wait-time)
(loop (add1 t) (* 2 wait-time))] (loop (add1 t) (* 2 wait-time))]
[else (raise e)]))]) [else (raise e)]))])
(tcp-connect rname (->number rport))))) (tcp-connect rname (->number rport)))))
(define (tcp-connect/retry rname rport #:times [times 10] #:delay [delay 1]) (define (tcp-connect/retry rname rport #:times [times 10] #:delay [delay 1])
(let loop ([t 0]) (let loop ([t 0])
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (e)
(cond [(t . < . times) (cond [(t . < . times)
(klogger (format "waiting ~a sec to retry connection to ~a:~a" delay rname rport)) (klogger (format "waiting ~a sec to retry connection to ~a:~a" delay rname rport))
(sleep delay) (sleep delay)
(loop (add1 t))] (loop (add1 t))]
[else (raise e)]))]) [else (raise e)]))])
(tcp-connect rname (->number rport))))) (tcp-connect rname (->number rport)))))
(define (format-log-message severity msg) (define (format-log-message severity msg)

19
collects/racket/place/distributed/examples/multiple/place-worker.rkt
View File

@ -18,13 +18,14 @@
;(place-worker p1) ;(place-worker p1)
(define (main . argv) (define (main . argv)
(define p (place ch (define p
(random-seed (current-seconds)) (place ch
;(define id (place-channel-get ch)) (random-seed (current-seconds))
(define id "HI") ;; (define id (place-channel-get ch))
(for ([i (in-range (+ 5 (random 5)))]) (define id "HI")
(displayln (list (current-seconds) id i)) (for ([i (in-range (+ 5 (random 5)))])
(flush-output) (displayln (list (current-seconds) id i))
;(place-channel-put ch (list (current-seconds) id i)) (flush-output)
#;(sleep 3)))) ;; (place-channel-put ch (list (current-seconds) id i))
#;(sleep 3))))
(sync (handle-evt (place-dead-evt p) (lambda (e) (printf "DEAD\n"))))) (sync (handle-evt (place-dead-evt p) (lambda (e) (printf "DEAD\n")))))

62
collects/racket/place/distributed/map-reduce.rkt
View File

@ -128,39 +128,35 @@
(define result (define result
(let loop ([ts tasks] (let loop ([ts tasks]
[idle-mappers connections] [idle-mappers connections]
[mapping null] [mapping null]
[ready-to-reduce null] [ready-to-reduce null]
[reducing null]) [reducing null])
;(printf "STATE\n") ;; (printf "STATE\n")
;(pretty-print (list ts idle-mappers mapping ready-to-reduce reducing)) ;; (pretty-print (list ts idle-mappers mapping ready-to-reduce reducing))
;(flush-output) ;; (flush-output)
(match (list ts idle-mappers mapping ready-to-reduce reducing) (match (list ts idle-mappers mapping ready-to-reduce reducing)
[(list (cons tsh tst) (cons imh imt) mapping rtr r) [(list (cons tsh tst) (cons imh imt) mapping rtr r)
(*channel-put (second imh) (list 'map mapper sorter (list tsh))) (*channel-put (second imh) (list 'map mapper sorter (list tsh)))
(loop tst imt (cons imh mapping) rtr r)] (loop tst imt (cons imh mapping) rtr r)]
[(list ts im m (cons rtr1 (cons rtr2 rtrt)) r) [(list ts im m (cons rtr1 (cons rtr2 rtrt)) r)
(*channel-put (second rtr1) (list 'reduce-to reducer sorter (first rtr2))) (*channel-put (second rtr1) (list 'reduce-to reducer sorter (first rtr2)))
(loop ts im m rtrt (cons rtr1 (cons rtr2 r)))] (loop ts im m rtrt (cons rtr1 (cons rtr2 r)))]
[(list (list) im (list) (list rtr) (list)) [(list (list) im (list) (list rtr) (list))
(*channel-put (second rtr) (list 'get-results)) (*channel-put (second rtr) (list 'get-results))
(second (*channel-get (second rtr)))] (second (*channel-get (second rtr)))]
[else ; wait [else ; wait
(apply sync/enable-break (for/list ([m (append mapping reducing)]) (apply sync/enable-break
(wrap-evt (second m) (for/list ([m (append mapping reducing)])
(lambda (e) (wrap-evt (second m)
(match e (lambda (e)
[(list 'reduce-ready) (match e
(loop ts idle-mappers (remove m mapping) (cons m ready-to-reduce) (remove m reducing))] [(list 'reduce-ready)
[(list 'reduce-done) (loop ts idle-mappers (remove m mapping) (cons m ready-to-reduce) (remove m reducing))]
(loop ts (cons m idle-mappers) mapping ready-to-reduce (remove m reducing))] [(list 'reduce-done)
[else (loop ts (cons m idle-mappers) mapping ready-to-reduce (remove m reducing))]
(raise (format "Unknown response message ~a" e))])))))]))) [else
(raise (format "Unknown response message ~a" e))])))))])))
(or (and outputer ((apply-dynamic-require outputer) result)) (or (and outputer ((apply-dynamic-require outputer) result))
result)) result))

11
collects/racket/place/distributed/rmpi.rkt
View File

@ -258,11 +258,12 @@
(partit num cnt id)) (partit num cnt id))
(define rmpi-build-default-config (define rmpi-build-default-config
(make-keyword-procedure (lambda (kws kw-args . rest) (make-keyword-procedure
(for/hash ([kw kws] (lambda (kws kw-args . rest)
[kwa kw-args]) (for/hash ([kw kws]
; (displayln (keyword? kw)) [kwa kw-args])
(values kw kwa))))) ;; (displayln (keyword? kw))
(values kw kwa)))))
(define (rmpi-launch default config #:no-wait [no-wait #f]) (define (rmpi-launch default config #:no-wait [no-wait #f])
(define (lookup-config-value rest key-str) (define (lookup-config-value rest key-str)

48
collects/racket/pretty.rkt
View File

@ -1092,39 +1092,39 @@
(pp-list vecl extra pp-expr #f depth (pp-list vecl extra pp-expr #f depth
pair? car cdr pair-open pair-close pair? car cdr pair-open pair-close
qd))))] qd))))]
[(flvector? obj) [(flvector? obj)
(let ([vecl (flvector->repeatless-list obj)]) (let ([vecl (flvector->repeatless-list obj)])
(if (and qd (zero? qd)) (if (and qd (zero? qd))
(pp-pair (cons (make-unquoted 'flvector) vecl) (pp-pair (cons (make-unquoted 'flvector) vecl)
extra depth extra depth
pair? car cdr pair-open pair-close pair? car cdr pair-open pair-close
qd) qd)
(begin (begin
(out "#fl") (out "#fl")
(when print-vec-length? (when print-vec-length?
(out (number->string (flvector-length obj)))) (out (number->string (flvector-length obj))))
(pp-list vecl extra pp-expr #f depth (pp-list vecl extra pp-expr #f depth
pair? car cdr pair-open pair-close pair? car cdr pair-open pair-close
qd))))] qd))))]
[(fxvector? obj) [(fxvector? obj)
(let ([vecl (fxvector->repeatless-list obj)]) (let ([vecl (fxvector->repeatless-list obj)])
(if (and qd (zero? qd)) (if (and qd (zero? qd))
(pp-pair (cons (make-unquoted 'fxvector) vecl) (pp-pair (cons (make-unquoted 'fxvector) vecl)
extra depth extra depth
pair? car cdr pair-open pair-close pair? car cdr pair-open pair-close
qd) qd)
(begin (begin
(out "#fx") (out "#fx")
(when print-vec-length? (when print-vec-length?
(out (number->string (fxvector-length obj)))) (out (number->string (fxvector-length obj))))
(pp-list vecl extra pp-expr #f depth (pp-list vecl extra pp-expr #f depth
pair? car cdr pair-open pair-close pair? car cdr pair-open pair-close
qd))))] qd))))]
[(and (custom-write? obj) [(and (custom-write? obj)
(not (struct-type? obj))) (not (struct-type? obj)))
(let ([qd (let ([kind (if (custom-print-quotable? obj) (let ([qd (let ([kind (if (custom-print-quotable? obj)
(custom-print-quotable-accessor obj) (custom-print-quotable-accessor obj)
'self)]) 'self)])
(if (memq kind '(self never)) (if (memq kind '(self never))
qd qd
(to-quoted out qd obj)))]) (to-quoted out qd obj)))])

2
collects/racket/private/sc.rkt
View File

@ -890,7 +890,7 @@
(+ s1 (stx-size (cdr stx) (- up-to s1))))] (+ s1 (stx-size (cdr stx) (- up-to s1))))]
[(vector? stx) (stx-size (vector->list stx) up-to)] [(vector? stx) (stx-size (vector->list stx) up-to)]
[(struct? stx) (stx-size (struct->vector stx) up-to)] [(struct? stx) (stx-size (struct->vector stx) up-to)]
[(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))] [(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))]
[else 1])) [else 1]))
;; Generates a list-ref expression; if use-tail-pos ;; Generates a list-ref expression; if use-tail-pos

6
collects/racket/private/vector-wraps.rkt
View File

@ -117,9 +117,9 @@
(fXvector-set! v i (let () last-body ...)) (fXvector-set! v i (let () last-body ...))
(add1 i))) (add1 i)))
v)))))] v)))))]
[(_ #:length length-expr (for-clause ...) body ...) [(_ #:length length-expr (for-clause ...) body ...)
(for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...) (for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...)
orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)])) orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)]))
(define-syntax (for/fXvector stx) (define-syntax (for/fXvector stx)
(for_/fXvector stx stx #'for/fXvector #'for/fold/derived #f)) (for_/fXvector stx stx #'for/fXvector #'for/fold/derived #f))

34
collects/racket/runtime-path.rkt
View File

@ -94,21 +94,21 @@
(path->complete-path p base)] (path->complete-path p base)]
[(string? p) (string->path p)] [(string? p) (string->path p)]
[(path? p) p] [(path? p) p]
[(and (list? p) [(and (list? p)
(= 2 (length p)) (= 2 (length p))
(eq? 'so (car p)) (eq? 'so (car p))
(string? (cadr p))) (string? (cadr p)))
(let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))]) (let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))])
(or (ormap (lambda (p) (or (ormap (lambda (p)
(let ([p (build-path p f)]) (let ([p (build-path p f)])
(and (file-exists? p) (and (file-exists? p)
p))) p)))
(get-lib-search-dirs)) (get-lib-search-dirs))
(cadr p)))] (cadr p)))]
[(and (list? p) [(and (list? p)
((length p) . > . 1) ((length p) . > . 1)
(eq? 'lib (car p)) (eq? 'lib (car p))
(andmap string? (cdr p))) (andmap string? (cdr p)))
(let* ([strs (regexp-split #rx"/" (let* ([strs (regexp-split #rx"/"
(let ([s (cadr p)]) (let ([s (cadr p)])
(if (regexp-match? #rx"[./]" s) (if (regexp-match? #rx"[./]" s)
@ -121,8 +121,8 @@
(list "mzlib") (list "mzlib")
(append (cddr p) (drop-right strs 1)))))] (append (cddr p) (drop-right strs 1)))))]
[(and (list? p) [(and (list? p)
((length p) . = . 3) ((length p) . = . 3)
(eq? 'module (car p)) (eq? 'module (car p))
(or (not (caddr p)) (or (not (caddr p))
(variable-reference? (caddr p)))) (variable-reference? (caddr p))))
(let ([p (cadr p)] (let ([p (cadr p)]

5
collects/rackunit/private/test-suite.rkt
View File

@ -133,8 +133,7 @@
(define (tests->test-suite-action tests) (define (tests->test-suite-action tests)
(lambda (fdown fup fhere seed) (lambda (fdown fup fhere seed)
(parameterize (parameterize ([current-seed seed])
([current-seed seed])
(for-each (for-each
(lambda (t) (lambda (t)
(cond (cond
@ -152,7 +151,7 @@
(format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests) (format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests)
(current-continuation-marks)))])) (current-continuation-marks)))]))
tests) tests)
(current-seed)))) (current-seed))))
;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite? ;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite?
;; ;;

4
collects/redex/examples/pi-calculus.rkt
View File

@ -354,8 +354,8 @@
[(encode-as-π (lam x e) a) (in a x (in a v (encode-as-π e v)))] [(encode-as-π (lam x e) a) (in a x (in a v (encode-as-π e v)))]
[(encode-as-π x a) (out x a zero)] [(encode-as-π x a) (out x a zero)]
[(encode-as-π (e_1 e_2) a) (nu v ((encode-as-π e_1 v) [(encode-as-π (e_1 e_2) a) (nu v ((encode-as-π e_1 v)
(nu a_x (out v a_x (out v a (binding-encode a_x e_2)))))) (nu a_x (out v a_x (out v a (binding-encode a_x e_2))))))
(where a_x ,(variable-not-in (term e_2) (term x)))]) (where a_x ,(variable-not-in (term e_2) (term x)))])
;; binding-encode : represent a binding. This is the key idea: represent a binding ;; binding-encode : represent a binding. This is the key idea: represent a binding
;; as a replicating agent that listens on a channel and delivers a channel corresponding ;; as a replicating agent that listens on a channel and delivers a channel corresponding

39
collects/redex/examples/r6rs/r6rs.rkt
View File

@ -689,26 +689,25 @@
(--> (store (sf_1 ... (x_1 #f) sf_2 ...) (in-hole E_1 (reinit x_1))) (--> (store (sf_1 ... (x_1 #f) sf_2 ...) (in-hole E_1 (reinit x_1)))
(store (sf_1 ... (x_1 #t) sf_2 ...) (in-hole E_1 'ignore)) (store (sf_1 ... (x_1 #t) sf_2 ...) (in-hole E_1 'ignore))
"6init") "6init")
(--> (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (reinit x_1))) (--> (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (reinit x_1)))
(store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 'ignore)) (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 'ignore))
"6reinit" "6reinit"
(side-condition (term b))) (side-condition (term b)))
(--> (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (reinit x_1))) (--> (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (reinit x_1)))
(store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (raise (make-cond "reinvoked continuation of letrec init")))) (store (sf_1 ... (x_1 b) sf_2 ...) (in-hole E_1 (raise (make-cond "reinvoked continuation of letrec init"))))
"6reinite" "6reinite"
(side-condition (term b))) (side-condition (term b)))
(--> (store (sf_1 ...) (in-hole E_1 (letrec ([x_1 e_1] ...) e_2 e_3 ...))) (--> (store (sf_1 ...) (in-hole E_1 (letrec ([x_1 e_1] ...) e_2 e_3 ...)))
(store (sf_1 ... (lx bh) ... (ri #f) ...) (store (sf_1 ... (lx bh) ... (ri #f) ...)
(in-hole E_1 (in-hole E_1
((lambda (x_1 ...) ((lambda (x_1 ...)
(l! lx x_1) ... (l! lx x_1) ...
(r6rs-subst-many ((x_1 lx) ... e_2)) (r6rs-subst-many ((x_1 lx) ... e_2))
(r6rs-subst-many ((x_1 lx) ... e_3)) ...) (r6rs-subst-many ((x_1 lx) ... e_3)) ...)
(begin0 (begin0 (r6rs-subst-many ((x_1 lx) ... e_1))
(r6rs-subst-many ((x_1 lx) ... e_1)) (reinit ri))
(reinit ri)) ...)))
...)))
"6letrec" "6letrec"
(side-condition (unique? (term (x_1 ...)))) (side-condition (unique? (term (x_1 ...))))
(fresh ((lx ...) (fresh ((lx ...)

9
collects/redex/examples/racket-machine/randomized-tests.rkt
View File

@ -74,7 +74,8 @@
; the reduction graph produces a cutoff result; with it ; the reduction graph produces a cutoff result; with it
; a cylce produces a pending, which is treated identically. ; a cylce produces a pending, which is treated identically.
(hash-set! cache s (cons c 'pending)) (hash-set! cache s (cons c 'pending))
(let ([r (cond [(term (halted? ,s)) (let ([r
(cond [(term (halted? ,s))
(make-answer (make-answer
(if (eq? s 'error) (if (eq? s 'error)
'error 'error
@ -98,9 +99,9 @@
(make-non-conf (make-non-conf
(list (answer-value (car answers)) (list (answer-value (car answers))
(answer-value (car others))))))))))))])]) (answer-value (car others))))))))))))])])
(begin (begin
(hash-set! cache s (cons c r)) (hash-set! cache s (cons c r))
r)))))))) r))))))))
(define (verified/cycles? expr cycles verified?) (define (verified/cycles? expr cycles verified?)
(and (verified? expr) (and (verified? expr)

20
collects/redex/private/gen-trace.rkt
View File

@ -422,10 +422,11 @@
(define (ybase-sum) (/ yscale-base (- 1 yscale-base))) (define (ybase-sum) (/ yscale-base (- 1 yscale-base)))
(define (find-ybase-center) (define (find-ybase-center)
(define mid (/ (ybase-sum) 2)) (define mid (/ (ybase-sum) 2))
(define sums (for/hash ([i 10]) (values (abs (- mid (define sums (for/hash ([i 10])
(apply + (for/list ([k i]) (values (abs (- mid
(expt yscale-base i))))) (apply + (for/list ([k i])
i))) (expt yscale-base i)))))
i)))
(hash-ref sums (apply min (hash-keys sums)))) (hash-ref sums (apply min (hash-keys sums))))
@ -679,11 +680,12 @@
(define/private (map-y-int y) (define/private (map-y-int y)
(hash-ref map-y-int-memo y (hash-ref map-y-int-memo y
(λ () (λ ()
(define res (if (< 0 y) (define res
(+ Y-SHIFT (* (apply + (for/list ([i (in-range 1 y)]) (if (< 0 y)
(expt yscale-base i))) (+ Y-SHIFT (* (apply + (for/list ([i (in-range 1 y)])
y-scale)) (expt yscale-base i)))
(- Y-SHIFT (* (+ (abs y) 1) y-scale)))) y-scale))
(- Y-SHIFT (* (+ (abs y) 1) y-scale))))
(hash-set! map-y-int-memo y res) (hash-set! map-y-int-memo y res)
res))) res)))
(define/private (map-y y) (define/private (map-y y)

36
collects/redex/private/search.rkt
View File

@ -199,14 +199,14 @@
(define (trim-dqs e pat) (define (trim-dqs e pat)
(define p-vars (define p-vars
(let loop ([p pat]) (let loop ([p pat])
(match p (match p
[`(name ,id ,pat) [`(name ,id ,pat)
(set-union (set id) (set-union (set id)
(loop pat))] (loop pat))]
[`(list ,pats ...) [`(list ,pats ...)
(apply set-union (for/list ([p pats]) (apply set-union (for/list ([p pats])
(loop p)))] (loop p)))]
[_ (set)]))) [_ (set)])))
(struct-copy env e (struct-copy env e
[dqs (for/list ([dq (env-dqs e)]) [dqs (for/list ([dq (env-dqs e)])
(trim-dq-vars dq p-vars))])) (trim-dq-vars dq p-vars))]))
@ -243,8 +243,8 @@
(values l r)] (values l r)]
[else [else
(for/fold ([l1 l] [r1 r]) (for/fold ([l1 l] [r1 r])
([a-pair (in-list (for*/list ([a vals] [b (set-remove vals a)]) ([a-pair (in-list (for*/list ([a vals] [b (set-remove vals a)])
(list a b)))]) (list a b)))])
(values (cons (first a-pair) l1) (values (cons (first a-pair) l1)
(cons (second a-pair) r1)))]))) (cons (second a-pair) r1)))])))
(let loop ([ps dqps] (let loop ([ps dqps]
@ -386,14 +386,14 @@
(let/ec fail (let/ec fail
(define new-f (define new-f
(for/list ([a-p-rule (in-list fringe)]) (for/list ([a-p-rule (in-list fringe)])
(define new-cs (for/list ([c (in-list (partial-rule-clauses a-p-rule))] (define new-cs (for/list ([c (in-list (partial-rule-clauses a-p-rule))]
#:when (do-unification (fresh-clause-vars c) (partial-rule-pat a-p-rule) env)) #:when (do-unification (fresh-clause-vars c) (partial-rule-pat a-p-rule) env))
c)) c))
(when (empty? new-cs) (when (empty? new-cs)
(fail #f)) (fail #f))
(struct-copy partial-rule (struct-copy partial-rule
a-p-rule a-p-rule
[clauses new-cs]))) [clauses new-cs])))
(define candidate-length (length (partial-rule-clauses (car new-f)))) (define candidate-length (length (partial-rule-clauses (car new-f))))
(if (< candidate-length 2) (if (< candidate-length 2)
new-f new-f

16
collects/redex/tests/unify-tests.rkt
View File

@ -183,16 +183,16 @@
(check-equal? (all-resolutions (p*e 'number (env (hash) '()))) (check-equal? (all-resolutions (p*e 'number (env (hash) '())))
(set 'number)) (set 'number))
(check-equal? (all-resolutions (p*e `(name a ,(bound)) (check-equal? (all-resolutions (p*e `(name a ,(bound))
(env (hash (lvar 'a) 5) '()))) (env (hash (lvar 'a) 5) '())))
(set 5 `(name a ,(bound)))) (set 5 `(name a ,(bound))))
(check-equal? (all-resolutions (p*e `(name a ,(bound)) (check-equal? (all-resolutions (p*e `(name a ,(bound))
(env (hash (lvar 'a) (lvar 'b) (env (hash (lvar 'a) (lvar 'b)
(lvar 'b) 7) '()))) (lvar 'b) 7) '())))
(set 7 `(name a ,(bound)) `(name b ,(bound)))) (set 7 `(name a ,(bound)) `(name b ,(bound))))
(check-equal? (all-resolutions (p*e `(list 1 2 3) (env (hash) '()))) (check-equal? (all-resolutions (p*e `(list 1 2 3) (env (hash) '())))
(set '(list 1 2 3))) (set '(list 1 2 3)))
(check-equal? (all-resolutions (p*e `(list 1 (name q ,(bound)) 3) (check-equal? (all-resolutions (p*e `(list 1 (name q ,(bound)) 3)
(env (hash (lvar 'q) 2) '()))) (env (hash (lvar 'q) 2) '())))
(set '(list 1 2 3) `(list 1 (name q ,(bound)) 3))) (set '(list 1 2 3) `(list 1 (name q ,(bound)) 3)))
(check-equal? (all-resolutions (p*e `(list (name a ,(bound)) (name b ,(bound))) (check-equal? (all-resolutions (p*e `(list (name a ,(bound)) (name b ,(bound)))
(env (hash (lvar 'a) 1 (lvar 'b) 2) '()))) (env (hash (lvar 'a) 1 (lvar 'b) 2) '())))
@ -664,10 +664,10 @@
(lvar 'x7) (lvar 'x1) (lvar 'x7) (lvar 'x1)
(lvar 'Γ2) (lvar 'Γ2)
`(cstr `(cstr
(Γ) (Γ)
(list (list
(list (name x1 ,(bound)) (name t_1 ,(bound))) (list (name x1 ,(bound)) (name t_1 ,(bound)))
(name Γ1 ,(bound))))))) (name Γ1 ,(bound)))))))
(check-false (unify/format `(name x (list x x)) (check-false (unify/format `(name x (list x x))
`(name x (list x)) `(name x (list x))
(m-hash (lvar 'x) (m-hash (lvar 'x)

66
collects/rnrs/enums-6.rkt
View File

@ -28,16 +28,16 @@
'make-enumeration 'make-enumeration
"list of symbols" "list of symbols"
enum))]) enum))])
(unless (mlist? enum) (bad)) (unless (mlist? enum) (bad))
(let ([enum (mlist->list enum)]) (let ([enum (mlist->list enum)])
(unless (andmap symbol? enum) (bad)) (unless (andmap symbol? enum) (bad))
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(make-universe (make-universe
ht ht
(for/list ([s (in-list enum)] (for/list ([s (in-list enum)]
#:when (not (hash-ref ht s #f))) #:when (not (hash-ref ht s #f)))
(hash-set! ht s (arithmetic-shift 1 (hash-count ht))) (hash-set! ht s (arithmetic-shift 1 (hash-count ht)))
s)))))) s))))))
(define (make-enumeration enum) (define (make-enumeration enum)
(let ([uni (make-enumeration-universe enum)]) (let ([uni (make-enumeration-universe enum)])
@ -236,26 +236,26 @@
(arithmetic-shift 1 (hash-count ht))))) (arithmetic-shift 1 (hash-count ht)))))
(with-syntax ([(val ...) (with-syntax ([(val ...)
(map (lambda (s) (hash-ref ht (syntax-e s))) syms)]) (map (lambda (s) (hash-ref ht (syntax-e s))) syms)])
#'(begin #'(begin
(define enum-universe (make-enumeration-universe (mlist 'sym ...))) (define enum-universe (make-enumeration-universe (mlist 'sym ...)))
(define-syntax (type-name stx) (define-syntax (type-name stx)
(syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ sym) #''sym] [(_ sym) #''sym]
... ...
[(_ other) [(_ other)
(identifier? #'other) (identifier? #'other)
(raise-syntax-error #f "not in enumeration" stx #'other)])) (raise-syntax-error #f "not in enumeration" stx #'other)]))
(define-syntax (bit-value stx) (define-syntax (bit-value stx)
(syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ orig sym) #'val] [(_ orig sym) #'val]
... ...
[(_ orig s) [(_ orig s)
(raise-syntax-error #f "not in enumeration" #'orig #'s)])) (raise-syntax-error #f "not in enumeration" #'orig #'s)]))
(... (...
(define-syntax (constructor stx) (define-syntax (constructor stx)
(syntax-case stx () (syntax-case stx ()
[(_ s ...) [(_ s ...)
(andmap identifier? (syntax->list #'(s ...))) (andmap identifier? (syntax->list #'(s ...)))
(with-syntax ([orig stx]) (with-syntax ([orig stx])
#'(make-enum-set (bitwise-ior (bit-value orig s) ...) #'(make-enum-set (bitwise-ior (bit-value orig s) ...)
enum-universe))]))))))])) enum-universe))]))))))]))

2
collects/scribble/core.rkt
View File

@ -19,7 +19,7 @@
(when old-val (when old-val
(eprintf "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n" (eprintf "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n"
key old-val val)) key old-val val))
(hash-set! ht key val)))) (hash-set! ht key val))))
(define (resolve-get/where part ri key) (define (resolve-get/where part ri key)
(let ([key (tag-key key ri)]) (let ([key (tag-key key ri)])

6
collects/scribble/private/manual-vars.rkt
View File

@ -112,9 +112,9 @@
(bound-identifier-mapping-put! ht #'arg #t)] (bound-identifier-mapping-put! ht #'arg #t)]
[else (void)]))) [else (void)])))
(cdr s-exp)) (cdr s-exp))
(unless (identifier? (car s-exp)) (unless (identifier? (car s-exp))
;; Curried: ;; Curried:
(do-proc (car s-exp)))))]) (do-proc (car s-exp)))))])
(do-proc s-exp))] (do-proc s-exp))]
[(form form/none form/maybe non-term) [(form form/none form/maybe non-term)
(define skip-id (case (syntax-e kind) (define skip-id (case (syntax-e kind)

5
collects/scribblings/framework/mode-helpers.rkt
View File

@ -19,10 +19,9 @@
(syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y))) (syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(override method (x ...) ...) [(override method (x ...) ...)
#'@defmethod*[(((method (orig (is-a?/c text%)) (call-super (-> any)) (x any/c) ...) any) ...)]{ #'@defmethod*[(((method (orig (is-a?/c text%)) (call-super (-> any)) (x any/c) ...) any) ...)]{
Returns the result of invoking @racket[call-super]. Returns the result of invoking @racket[call-super].
}] }]
[(augment default method (x ...) ...) [(augment default method (x ...) ...)
#'@defmethod*[(((method (orig (is-a?/c text%)) (call-inner (-> any)) (x any/c) ...) any) ...)]{ #'@defmethod*[(((method (orig (is-a?/c text%)) (call-inner (-> any)) (x any/c) ...) any) ...)]{
Returns the result of invoking @racket[call-super]. Returns the result of invoking @racket[call-super].
}])) }]))

63
collects/scribblings/gui/blurbs.rkt
View File

@ -25,25 +25,25 @@
(define (labelsimplestripped where what) (define (labelsimplestripped where what)
@elem{If @litchar{&} occurs in @|where|, it is specially parsed; @elem{If @litchar{&} occurs in @|where|, it is specially parsed;
under Windows and X, the character under Windows and X, the character
following @litchar{&} is underlined in the displayed control to following @litchar{&} is underlined in the displayed control to
indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are
not shown.) The mnemonic is meaningless for a @|what| (as far as not shown.) The mnemonic is meaningless for a @|what| (as far as
@xmethod[top-level-window<%> on-traverse-char] is concerned), @xmethod[top-level-window<%> on-traverse-char] is concerned),
but it is supported for consistency with other control types. A but it is supported for consistency with other control types. A
programmer may assign a meaning to the mnemonic (e.g., by overriding programmer may assign a meaning to the mnemonic (e.g., by overriding
@method[top-level-window<%> on-traverse-char]).}) @method[top-level-window<%> on-traverse-char]).})
(define (labelstripped where detail what) (define (labelstripped where detail what)
@elem{If @litchar{&} occurs in @|where|@|detail|, it @elem{If @litchar{&} occurs in @|where|@|detail|, it
is specially parsed as for @racket[button%].}) is specially parsed as for @racket[button%].})
(define (bitmapuseinfo pre what thing and the) (define (bitmapuseinfo pre what thing and the)
@elem{@|pre| @|what| is @|thing|,@|and| if @|the| @elem{@|pre| @|what| is @|thing|,@|and| if @|the|
bitmap has a mask (see @xmethod[bitmap% get-loaded-mask]) bitmap has a mask (see @xmethod[bitmap% get-loaded-mask])
that is the same size as the bitmap, then the mask is used for the that is the same size as the bitmap, then the mask is used for the
label. Modifying a bitmap while it is used as a label has label. Modifying a bitmap while it is used as a label has
an unspecified effect on the displayed label.}) an unspecified effect on the displayed label.})
(define-syntax bitmaplabeluse (define-syntax bitmaplabeluse
(syntax-rules () (syntax-rules ()
@ -79,20 +79,21 @@
(define insertcharundos (define insertcharundos
@elem{Multiple calls to the character-inserting method are grouped together @elem{Multiple calls to the character-inserting method are grouped together
for undo purposes, since this case of the method is typically used for undo purposes, since this case of the method is typically used
for handling user keystrokes. However, this undo-grouping feature for handling user keystrokes. However, this undo-grouping feature
interferes with the undo grouping performed by interferes with the undo grouping performed by
@method[editor<%> begin-edit-sequence] and @method[editor<%> begin-edit-sequence] and
@method[editor<%> end-edit-sequence], so the string-inserting @method[editor<%> end-edit-sequence], so the string-inserting
method should be used instead during undoable edit sequences.}) method should be used instead during undoable edit sequences.})
(define (insertscrolldetails what) (define (insertscrolldetails what)
@elem{@|what| editor's display is scrolled to show the new selection @techlink{position}.}) @elem{@|what| editor's display is scrolled to show the new selection
@techlink{position}.})
(define (insertmovedetails what) (define (insertmovedetails what)
@elem{If the insertion @techlink{position} is before @elem{If the insertion @techlink{position} is before
or equal to the selection's start/end @techlink{position}, then the selection's or equal to the selection's start/end @techlink{position}, then the
start/end @techlink{position} is incremented by @|what|.}) selection's start/end @techlink{position} is incremented by @|what|.})
(define OVD (define OVD
@elem{The result is only valid when the editor is displayed @elem{The result is only valid when the editor is displayed
@ -100,9 +101,10 @@ start/end @techlink{position} is incremented by @|what|.})
@method[editor<%> get-admin] returns an administrator (not @racket[#f]).}) @method[editor<%> get-admin] returns an administrator (not @racket[#f]).})
(define (FCAX c details) (define (FCAX c details)
@elem{@|c|alling this method may force the recalculation of @techlink{location} @elem{
information@|details|, even if the editor currently has delayed refreshing (see @|c|alling this method may force the recalculation of @techlink{location}
@method[editor<%> refresh-delayed?]).}) information@|details|, even if the editor currently has delayed
refreshing (see @method[editor<%> refresh-delayed?]).})
(define FCA (FCAX "C" "")) (define FCA (FCAX "C" ""))
(define FCAMW (FCAX "C" " if a maximum width is set for the editor")) (define FCAMW (FCAX "C" " if a maximum width is set for the editor"))
@ -180,11 +182,14 @@ information@|details|, even if the editor currently has delayed refreshing (see
@elem{The editor's style list must contain @style, otherwise @elem{The editor's style list must contain @style, otherwise
the style is not changed. See also @xmethod[style-list% convert].}) the style is not changed. See also @xmethod[style-list% convert].})
(define (FontKWs font) @elem{The @|font| argument determines the font for the control.}) (define (FontKWs font)
(define (FontLabelKWs font label-font) @elem{The @|font| argument determines the font for the control content, @elem{The @|font| argument determines the font for the control.})
and @|label-font| determines the font for the control label.}) (define (FontLabelKWs font label-font)
@elem{The @|font| argument determines the font for the control content,
and @|label-font| determines the font for the control label.})
(define (WindowKWs enabled) @elem{For information about the @|enabled| argument, see @racket[window<%>].}) (define (WindowKWs enabled)
@elem{For information about the @|enabled| argument, see @racket[window<%>].})
(define-inline (SubareaKWs) (define-inline (SubareaKWs)
@elem{For information about the @racket[horiz-margin] and @racket[vert-margin] @elem{For information about the @racket[horiz-margin] and @racket[vert-margin]
arguments, see @racket[subarea<%>].}) arguments, see @racket[subarea<%>].})

9
collects/scribblings/htdp-langs/prim-ops.rkt
View File

@ -63,16 +63,13 @@
@section[#:tag (string-append section-prefix " Pre-Defined Variables")]{Pre-Defined Variables} @section[#:tag (string-append section-prefix " Pre-Defined Variables")]{Pre-Defined Variables}
@defthing[empty empty?]{ @defthing[empty empty?]{
The empty list.}
The empty list.}
@defthing[true boolean?]{ @defthing[true boolean?]{
The true value.}
The true value.}
@defthing[false boolean?]{ @defthing[false boolean?]{
The false value.}
The false value.}
@section[#:tag (string-append section-prefix " Template Variables")]{Template Variables} @section[#:tag (string-append section-prefix " Template Variables")]{Template Variables}
@; MF: I tried abstracting but I failed @; MF: I tried abstracting but I failed

6
collects/scribblings/htdp-langs/std-grammar.rkt
View File

@ -66,8 +66,8 @@
@t{An @racket[_name] or a @racket[_variable] is a sequence of characters @t{An @racket[_name] or a @racket[_variable] is a sequence of characters
not including a space or one of the following:} not including a space or one of the following:}
@t{@hspace[2] @litchar{"} @litchar{,} @litchar{'} @litchar{`} @t{@hspace[2] @litchar{"} @litchar{,} @litchar{'} @litchar{`}
@litchar{(} @litchar{)} @litchar{[} @litchar{]} @litchar{(} @litchar{)} @litchar{[} @litchar{]}
@litchar["{"] @litchar["}"] @litchar{|} @litchar{;} @litchar["{"] @litchar["}"] @litchar{|} @litchar{;}
@litchar{#}} @litchar{#}}
@ -85,7 +85,7 @@ symbols, strings may be split into characters and manipulated by a
variety of functions. For example, @racket["abcdef"], variety of functions. For example, @racket["abcdef"],
@racket["This is a string"], and @racket[#,ex-str] are all strings.} @racket["This is a string"], and @racket[#,ex-str] are all strings.}
@t{A @racket[_character] begins with @litchar{#\} and has the @t{A @racket[_character] begins with @litchar{#\} and has the
name of the character. For example, @racket[#\a], @racket[#\b], name of the character. For example, @racket[#\a], @racket[#\b],
and @racket[#\space] are characters.} and @racket[#\space] are characters.}

2
collects/scriblib/autobib.rkt
View File

@ -157,7 +157,7 @@
(add-cite group (car v) 'autobib-author #f #f style) (add-cite group (car v) 'autobib-author #f #f style)
(add-date-cites group v (send style get-item-sep) style sort? bib-date<? bib-date=?))))) (add-date-cites group v (send style get-item-sep) style sort? bib-date<? bib-date=?)))))
(send style get-group-sep)) (send style get-group-sep))
(list (send style get-cite-close))))) (list (send style get-cite-close)))))
(define (extract-bib-author b) (define (extract-bib-author b)
(or (auto-bib-author b) (or (auto-bib-author b)

24
collects/setup/parallel-do.rkt
View File

@ -84,19 +84,21 @@
(when initialmsg (send/msg (initialmsg id))))) (when initialmsg (send/msg (initialmsg id)))))
(define/public (send/msg msg) (define/public (send/msg msg)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(eprintf "While sending message to parallel-do worker: ~a ~a\n" id (exn-message x)) (eprintf "While sending message to parallel-do worker: ~a ~a\n"
(exit 1))]) id (exn-message x))
(DEBUG_COMM (eprintf "CSENDING ~v ~v\n" id msg)) (exit 1))])
(write msg in) (flush-output in))) (DEBUG_COMM (eprintf "CSENDING ~v ~v\n" id msg))
(write msg in) (flush-output in)))
(define/public (recv/msg) (define/public (recv/msg)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(eprintf "While receiving message from parallel-do worker ~a ~a\n" id (exn-message x)) (eprintf "While receiving message from parallel-do worker ~a ~a\n"
(exit 1))]) id (exn-message x))
(define r (read out)) (exit 1))])
(DEBUG_COMM (eprintf "CRECEIVNG ~v ~v\n" id r)) (define r (read out))
r)) (DEBUG_COMM (eprintf "CRECEIVNG ~v ~v\n" id r))
r))
(define/public (read-all) (port->string out)) (define/public (read-all) (port->string out))
(define/public (get-id) id) (define/public (get-id) id)
(define/public (get-out) out) (define/public (get-out) out)

14
collects/setup/setup-cmdline.rkt
View File

@ -102,13 +102,13 @@
(cdr (car collections/archives)) (cdr (car collections/archives))
'())]) '())])
(cond (cond
[raco? [raco?
(check-collections short-name rest) (check-collections short-name rest)
(values (append pre-collections (map list rest)) (values (append pre-collections (map list rest))
pre-archives)] pre-archives)]
[else [else
(values pre-collections (values pre-collections
(append pre-archives rest))]))) (append pre-archives rest))])))
(if raco? '("collection") '("archive")) (if raco? '("collection") '("archive"))
(lambda (s) (lambda (s)
(display s) (display s)

8
collects/sgl/bitmap.rkt
View File

@ -34,9 +34,9 @@
#:key #:key
[with-gl (lambda (f) (f))] [with-gl (lambda (f) (f))]
[mask (send bm get-loaded-mask)]) [mask (send bm get-loaded-mask)])
(let ([w (send bm get-width)] (define w (send bm get-width))
[h (send bm get-height)] (define h (send bm get-height))
[rgba (argb->rgba (bitmap->argb bm mask))]) (define rgba (argb->rgba (bitmap->argb bm mask)))
(with-gl (with-gl
(lambda () (lambda ()
(let ((tex (gl-vector-ref (glGenTextures 1) 0)) (let ((tex (gl-vector-ref (glGenTextures 1) 0))
@ -67,4 +67,4 @@
(gl-disable 'texture-2d) (gl-disable 'texture-2d)
(gl-end-list) (gl-end-list)
list-id)))))) list-id)))))

160
collects/srfi/41/derived.rkt
View File

@ -61,26 +61,26 @@
(define (stream->list . args) (define (stream->list . args)
(let ((n (if (= 1 (length args)) #f (car args))) (let ((n (if (= 1 (length args)) #f (car args)))
(strm (if (= 1 (length args)) (car args) (cadr args)))) (strm (if (= 1 (length args)) (car args) (cadr args))))
(cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) (cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
((and n (not (integer? n))) (error 'stream->list "non-integer count")) ((and n (not (integer? n))) (error 'stream->list "non-integer count"))
((and n (negative? n)) (error 'stream->list "negative count")) ((and n (negative? n)) (error 'stream->list "negative count"))
(else (let loop ((n (if n n -1)) (strm strm)) (else (let loop ((n (if n n -1)) (strm strm))
(if (or (zero? n) (stream-null? strm)) (if (or (zero? n) (stream-null? strm))
'() '()
(cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) (cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
(define (stream-append . strms) (define (stream-append . strms)
(define stream-append (define stream-append
(stream-lambda (strms) (stream-lambda (strms)
(cond ((null? (cdr strms)) (car strms)) (cond ((null? (cdr strms)) (car strms))
((stream-null? (car strms)) (stream-append (cdr strms))) ((stream-null? (car strms)) (stream-append (cdr strms)))
(else (stream-cons (stream-car (car strms)) (else (stream-cons (stream-car (car strms))
(stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) (stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
(cond ((null? strms) stream-null) (cond ((null? strms) stream-null)
((ormap (lambda (x) (not (stream? x))) strms) ((ormap (lambda (x) (not (stream? x))) strms)
(error 'stream-append "non-stream argument")) (error 'stream-append "non-stream argument"))
(else (stream-append strms)))) (else (stream-append strms))))
(define (stream-concat strms) (define (stream-concat strms)
(define stream-concat (define stream-concat
@ -91,9 +91,9 @@
((stream-null? (stream-car strms)) ((stream-null? (stream-car strms))
(stream-concat (stream-cdr strms))) (stream-concat (stream-cdr strms)))
(else (stream-cons (else (stream-cons
(stream-car (stream-car strms)) (stream-car (stream-car strms))
(stream-concat (stream-concat
(stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
(if (not (stream? strms)) (if (not (stream? strms))
(error 'stream-concat "non-stream argument") (error 'stream-concat "non-stream argument")
(stream-concat strms))) (stream-concat strms)))
@ -101,9 +101,9 @@
(define stream-constant (define stream-constant
(stream-lambda objs (stream-lambda objs
(cond ((null? objs) stream-null) (cond ((null? objs) stream-null)
((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
(else (stream-cons (car objs) (else (stream-cons (car objs)
(apply stream-constant (append (cdr objs) (list (car objs))))))))) (apply stream-constant (append (cdr objs) (list (car objs)))))))))
(define (stream-drop n strm) (define (stream-drop n strm)
(define stream-drop (define stream-drop
@ -112,9 +112,9 @@
strm strm
(stream-drop (- n 1) (stream-cdr strm))))) (stream-drop (- n 1) (stream-cdr strm)))))
(cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) (cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
((negative? n) (error 'stream-drop "negative argument")) ((negative? n) (error 'stream-drop "negative argument"))
((not (stream? strm)) (error 'stream-drop "non-stream argument")) ((not (stream? strm)) (error 'stream-drop "non-stream argument"))
(else (stream-drop n strm)))) (else (stream-drop n strm))))
(define (stream-drop-while pred? strm) (define (stream-drop-while pred? strm)
(define stream-drop-while (define stream-drop-while
@ -123,27 +123,27 @@
(stream-drop-while (stream-cdr strm)) (stream-drop-while (stream-cdr strm))
strm))) strm)))
(cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) ((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
(else (stream-drop-while strm)))) (else (stream-drop-while strm))))
(define (stream-filter pred? strm) (define (stream-filter pred? strm)
(define stream-filter (define stream-filter
(stream-lambda (strm) (stream-lambda (strm)
(cond ((stream-null? strm) stream-null) (cond ((stream-null? strm) stream-null)
((pred? (stream-car strm)) ((pred? (stream-car strm))
(stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
(else (stream-filter (stream-cdr strm)))))) (else (stream-filter (stream-cdr strm))))))
(cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
((not (stream? strm)) (error 'stream-filter "non-stream argument")) ((not (stream? strm)) (error 'stream-filter "non-stream argument"))
(else (stream-filter strm)))) (else (stream-filter strm))))
(define (stream-fold proc base strm) (define (stream-fold proc base strm)
(cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
((not (stream? strm)) (error 'stream-fold "non-stream argument")) ((not (stream? strm)) (error 'stream-fold "non-stream argument"))
(else (let loop ((base base) (strm strm)) (else (let loop ((base base) (strm strm))
(if (stream-null? strm) (if (stream-null? strm)
base base
(loop (proc base (stream-car strm)) (stream-cdr strm))))))) (loop (proc base (stream-car strm)) (stream-cdr strm)))))))
(define (stream-for-each proc . strms) (define (stream-for-each proc . strms)
(define (stream-for-each strms) (define (stream-for-each strms)
@ -151,19 +151,19 @@
(begin (apply proc (map stream-car strms)) (begin (apply proc (map stream-car strms))
(stream-for-each (map stream-cdr strms))))) (stream-for-each (map stream-cdr strms)))))
(cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
((null? strms) (error 'stream-for-each "no stream arguments")) ((null? strms) (error 'stream-for-each "no stream arguments"))
((ormap (lambda (x) (not (stream? x))) strms) ((ormap (lambda (x) (not (stream? x))) strms)
(error 'stream-for-each "non-stream argument")) (error 'stream-for-each "non-stream argument"))
(else (stream-for-each strms)))) (else (stream-for-each strms))))
(define (stream-from first . step) (define (stream-from first . step)
(define stream-from (define stream-from
(stream-lambda (first delta) (stream-lambda (first delta)
(stream-cons first (stream-from (+ first delta) delta)))) (stream-cons first (stream-from (+ first delta) delta))))
(let ((delta (if (null? step) 1 (car step)))) (let ((delta (if (null? step) 1 (car step))))
(cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) (cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
((not (number? delta)) (error 'stream-from "non-numeric step size")) ((not (number? delta)) (error 'stream-from "non-numeric step size"))
(else (stream-from first delta))))) (else (stream-from first delta)))))
(define (stream-iterate proc base) (define (stream-iterate proc base)
(define stream-iterate (define stream-iterate
@ -194,10 +194,10 @@
(stream-cons (apply proc (map stream-car strms)) (stream-cons (apply proc (map stream-car strms))
(stream-map (map stream-cdr strms)))))) (stream-map (map stream-cdr strms))))))
(cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
((null? strms) (error 'stream-map "no stream arguments")) ((null? strms) (error 'stream-map "no stream arguments"))
((ormap (lambda (x) (not (stream? x))) strms) ((ormap (lambda (x) (not (stream? x))) strms)
(error 'stream-map "non-stream argument")) (error 'stream-map "non-stream argument"))
(else (stream-map strms)))) (else (stream-map strms))))
(define-syntax stream-match (define-syntax stream-match
(syntax-rules () (syntax-rules ()
@ -265,21 +265,21 @@
(stream-cons first (stream-range (+ first delta) past delta lt?)) (stream-cons first (stream-range (+ first delta) past delta lt?))
stream-null))) stream-null)))
(cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) (cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
((not (number? past)) (error 'stream-range "non-numeric ending number")) ((not (number? past)) (error 'stream-range "non-numeric ending number"))
(else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
(if (not (number? delta)) (if (not (number? delta))
(error 'stream-range "non-numeric step size") (error 'stream-range "non-numeric step size")
(let ((lt? (if (< 0 delta) < >))) (let ((lt? (if (< 0 delta) < >)))
(stream-range first past delta lt?))))))) (stream-range first past delta lt?)))))))
(define (stream-ref strm n) (define (stream-ref strm n)
(cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
((not (integer? n)) (error 'stream-ref "non-integer argument")) ((not (integer? n)) (error 'stream-ref "non-integer argument"))
((negative? n) (error 'stream-ref "negative argument")) ((negative? n) (error 'stream-ref "negative argument"))
(else (let loop ((strm strm) (n n)) (else (let loop ((strm strm) (n n))
(cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
((zero? n) (stream-car strm)) ((zero? n) (stream-car strm))
(else (loop (stream-cdr strm) (- n 1)))))))) (else (loop (stream-cdr strm) (- n 1))))))))
(define (stream-reverse strm) (define (stream-reverse strm)
(define stream-reverse (define stream-reverse
@ -298,8 +298,8 @@
(stream base) (stream base)
(stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
(cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
((not (stream? strm)) (error 'stream-scan "non-stream argument")) ((not (stream? strm)) (error 'stream-scan "non-stream argument"))
(else (stream-scan base strm)))) (else (stream-scan base strm))))
(define (stream-take n strm) (define (stream-take n strm)
(define stream-take (define stream-take
@ -308,20 +308,20 @@
stream-null stream-null
(stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
(cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) (cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
((not (integer? n)) (error 'stream-take "non-integer argument")) ((not (integer? n)) (error 'stream-take "non-integer argument"))
((negative? n) (error 'stream-take "negative argument")) ((negative? n) (error 'stream-take "negative argument"))
(else (stream-take n strm)))) (else (stream-take n strm))))
(define (stream-take-while pred? strm) (define (stream-take-while pred? strm)
(define stream-take-while (define stream-take-while
(stream-lambda (strm) (stream-lambda (strm)
(cond ((stream-null? strm) stream-null) (cond ((stream-null? strm) stream-null)
((pred? (stream-car strm)) ((pred? (stream-car strm))
(stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
(else stream-null)))) (else stream-null))))
(cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
(else (stream-take-while strm)))) (else (stream-take-while strm))))
(define (stream-unfold mapper pred? generator base) (define (stream-unfold mapper pred? generator base)
(define stream-unfold (define stream-unfold
@ -330,9 +330,9 @@
(stream-cons (mapper base) (stream-unfold (generator base))) (stream-cons (mapper base) (stream-unfold (generator base)))
stream-null))) stream-null)))
(cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
(else (stream-unfold base)))) (else (stream-unfold base))))
(define (stream-unfolds gen seed) (define (stream-unfolds gen seed)
(define (len-values gen seed) (define (len-values gen seed)
@ -349,13 +349,13 @@
(stream-lambda (result-stream i) (stream-lambda (result-stream i)
(let ((result (list-ref (stream-car result-stream) (- i 1)))) (let ((result (list-ref (stream-car result-stream) (- i 1))))
(cond ((pair? result) (cond ((pair? result)
(stream-cons (stream-cons
(car result) (car result)
(result-stream->output-stream (stream-cdr result-stream) i))) (result-stream->output-stream (stream-cdr result-stream) i)))
((not result) ((not result)
(result-stream->output-stream (stream-cdr result-stream) i)) (result-stream->output-stream (stream-cdr result-stream) i))
((null? result) stream-null) ((null? result) stream-null)
(else (error 'stream-unfolds "can't happen")))))) (else (error 'stream-unfolds "can't happen"))))))
(define (result-stream->output-streams result-stream) (define (result-stream->output-streams result-stream)
(let loop ((i (len-values gen seed)) (outputs '())) (let loop ((i (len-values gen seed)) (outputs '()))
(if (zero? i) (if (zero? i)
@ -372,6 +372,6 @@
stream-null stream-null
(stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
(cond ((null? strms) (error 'stream-zip "no stream arguments")) (cond ((null? strms) (error 'stream-zip "no stream arguments"))
((ormap (lambda (x) (not (stream? x))) strms) ((ormap (lambda (x) (not (stream? x))) strms)
(error 'stream-zip "non-stream argument")) (error 'stream-zip "non-stream argument"))
(else (stream-zip strms)))) (else (stream-zip strms))))

4
collects/stepper/private/model.rkt
View File

@ -70,8 +70,8 @@
(provide/contract (provide/contract
[go (->* [go (->*
(program-expander-contract ; program-expander (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result (step-result? . -> . void?) ; receive-result
(or/c render-settings? false/c)) ; render-settings (or/c render-settings? false/c)) ; render-settings
(#:raw-step-receiver (#:raw-step-receiver
(-> continuation-mark-set? symbol? void?) (-> continuation-mark-set? symbol? void?)
#:disable-error-handling? boolean?) #:disable-error-handling? boolean?)

9
collects/stepper/private/shared.rkt
View File

@ -570,9 +570,12 @@
attached)) attached))
(define (values-map fn . lsts) (define (values-map fn . lsts)
(apply values (apply map list (apply values
(apply map (lambda args (call-with-values (lambda () (apply fn args)) list)) (apply map list
lsts)))) (apply map (lambda args
(call-with-values (lambda () (apply fn args))
list))
lsts))))
; produces the list of numbers from a to b (inclusive) ; produces the list of numbers from a to b (inclusive)
(define (a...b a b) (define (a...b a b)

9
collects/string-constants/private/english-string-constants.rkt
View File

@ -174,9 +174,10 @@ please adhere to these guidelines:
(saved-unsubmitted-bug-reports "Saved, unsubmitted bug reports:") (saved-unsubmitted-bug-reports "Saved, unsubmitted bug reports:")
;; the above string constant is next to previous line in same dialog, followed by list of bug report subjects (as buttons) ;; the above string constant is next to previous line in same dialog, followed by list of bug report subjects (as buttons)
(error-sending-bug-report "Error Sending Bug Report") (error-sending-bug-report "Error Sending Bug Report")
(error-sending-bug-report-expln "An error occurred when sending this bug report." (error-sending-bug-report-expln
" If your internet connection is otherwise working fine, please visit:\n\n http://bugs.racket-lang.org/\n\nand" "An error occurred when sending this bug report."
" submit the bug via our online web-form. Sorry for the difficulties.\n\nThe error message is:\n~a") " If your internet connection is otherwise working fine, please visit:\n\n http://bugs.racket-lang.org/\n\nand"
" submit the bug via our online web-form. Sorry for the difficulties.\n\nThe error message is:\n~a")
(illegal-bug-report "Illegal Bug Report") (illegal-bug-report "Illegal Bug Report")
(pls-fill-in-field "Please fill in the \"~a\" field") (pls-fill-in-field "Please fill in the \"~a\" field")
(malformed-email-address "Malformed email address") (malformed-email-address "Malformed email address")
@ -1382,7 +1383,7 @@ please adhere to these guidelines:
(module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window. (module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window.
(module-browser-highlight "Highlight") ;; used to search in the graph; the label on a text-field% object (module-browser-highlight "Highlight") ;; used to search in the graph; the label on a text-field% object
(module-browser-only-in-plt-and-module-langs (module-browser-only-in-plt-and-module-langs
"The module browser is only available for module-based programs.") "The module browser is only available for module-based programs.")
(module-browser-name-length "Name length") (module-browser-name-length "Name length")
(module-browser-name-short "Short") (module-browser-name-short "Short")
(module-browser-name-medium "Medium") (module-browser-name-medium "Medium")

33
collects/syntax-color/scribble-lexer.rkt
View File

@ -27,22 +27,21 @@
(hash-set! rx-keys rx (make-ephemeron rx bstr)) (hash-set! rx-keys rx (make-ephemeron rx bstr))
rx)))) rx))))
(define (scribble-inside-lexer orig-in offset mode) (define (scribble-inside-lexer orig-in offset orig-mode)
(let ([mode (or mode (define mode (or orig-mode
(list (list
(make-text #rx"^@" (make-text #rx"^@"
#f #f
#f #f
#rx".*?(?:(?=[@\r\n])|$)" #rx".*?(?:(?=[@\r\n])|$)"
#f #f
#f)))] #f))))
[in (special-filter-input-port orig-in (define in (special-filter-input-port
(lambda (v s) orig-in
(bytes-set! s 0 (char->integer #\.)) (lambda (v s) (bytes-set! s 0 (char->integer #\.)) 1)))
1))]) (let-values ([(line col pos) (port-next-location orig-in)])
(let-values ([(line col pos) (port-next-location orig-in)]) (when line
(when line (port-count-lines! in)))
(port-count-lines! in)))
(let-values ([(line col pos) (port-next-location in)] (let-values ([(line col pos) (port-next-location in)]
[(l) (car mode)]) [(l) (car mode)])
@ -362,7 +361,7 @@
(enter-simple-opener (cdr mode))] (enter-simple-opener (cdr mode))]
[else [else
(scribble-inside-lexer in offset (cdr mode))])] (scribble-inside-lexer in offset (cdr mode))])]
[else (error "bad mode")]))))) [else (error "bad mode")]))))
(define (scribble-lexer in offset mode) (define (scribble-lexer in offset mode)
(scribble-inside-lexer in offset (or mode (list (make-scheme 'many #f))))) (scribble-inside-lexer in offset (or mode (list (make-scheme 'many #f)))))

35
collects/tests/algol60/test.rkt
View File

@ -25,10 +25,10 @@
(check-equal? (check-equal?
(capture-output (capture-output
@literal-algol{ @literal-algol{
begin begin
printsln (`hello world') printsln (`hello world')
end end
}) })
'(run "hello world\n" "")) '(run "hello world\n" ""))
(check-pred (check-pred
@ -37,8 +37,8 @@ end
(list-ref x 1)))) (list-ref x 1))))
(capture-output (capture-output
@literal-algol{ @literal-algol{
begin begin
})) }))
(check-pred (check-pred
@ -47,14 +47,15 @@ begin
(list-ref x 1)))) (list-ref x 1))))
(capture-output (capture-output
@literal-algol{ @literal-algol{
procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k); procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k);
value n, m; array a; integer n, m, i, k; real y; value n, m; array a; integer n, m, i, k; real y;
begin integer p, q; begin integer p, q;
y := 0; i := k := 1; y := 0; i := k := 1;
for p:=1 step 1 until n do for p:=1 step 1 until n do
for q:=1 step 1 until m do for q:=1 step 1 until m do
if abs(a[p, q]) > y then if abs(a[p, q]) > y then
begin y := abs(a[p, q]); begin y := abs(a[p, q]);
i := p; k := q i := p; k := q
end end
end Absmax})) end Absmax
}))

6
collects/tests/datalog/pretty.rkt
View File

@ -9,9 +9,9 @@
"Pretty" "Pretty"
(test-equal? "program" (test-equal? "program"
(format-program (format-program
(parse-program (parse-program
(open-input-string #<<END (open-input-string #<<END
parent(john, douglas). parent(john, douglas).
parent(john, douglas)? parent(john, douglas)?
parent(john, ebbon)? parent(john, ebbon)?

39
collects/tests/db/db/concurrent.rkt
View File

@ -55,26 +55,27 @@
(define (kill-safe-test proxy?) (define (kill-safe-test proxy?)
(unless (ANYFLAGS 'isora 'isdb2) (unless (ANYFLAGS 'isora 'isdb2)
(test-case (format "kill-safe test~a" (if proxy? " (proxy)" "")) (test-case
(call-with-connection (format "kill-safe test~a" (if proxy? " (proxy)" ""))
(lambda (c0) (call-with-connection
(let ([c (if proxy? (lambda (c0)
(kill-safe-connection c0) (let ([c (if proxy?
c0)]) (kill-safe-connection c0)
(query-exec c "create temporary table ks_numbers (n integer)") c0)])
(for ([i (in-range 1000)]) (query-exec c "create temporary table ks_numbers (n integer)")
(query-exec c (sql "insert into ks_numbers (n) values ($1)") i)) (for ([i (in-range 1000)])
(define (do-interactions) (query-exec c (sql "insert into ks_numbers (n) values ($1)") i))
(for ([i (in-range 10)]) (define (do-interactions)
(query-list c "select n from ks_numbers"))) (for ([i (in-range 10)])
(define threads (make-hasheq)) (query-list c "select n from ks_numbers")))
(define threads (make-hasheq))
(for ([i (in-range 20)]) (for ([i (in-range 20)])
(let ([t (thread do-interactions)]) (let ([t (thread do-interactions)])
(hash-set! threads (thread do-interactions) #t) (hash-set! threads (thread do-interactions) #t)
(kill-thread t))) (kill-thread t)))
(for ([t (in-hash-keys threads)]) (for ([t (in-hash-keys threads)])
(sync t)))))))) (sync t))))))))
(define (async-test) (define (async-test)
(unless (ANYFLAGS 'isora 'isdb2) (unless (ANYFLAGS 'isora 'isdb2)

18
collects/tests/deinprogramm/image.rkt
View File

@ -170,16 +170,16 @@
(name . args)))])) (name . args)))]))
(define all-image-tests (define all-image-tests
(test-suite (test-suite
"Tests for images" "Tests for images"
(test-case (test-case
"image?" "image?"
(check-pred image? (rectangle 10 10 'solid 'blue)) (check-pred image? (rectangle 10 10 'solid 'blue))
(check-pred image? (rectangle 10 10 "solid" 'blue)) (check-pred image? (rectangle 10 10 "solid" 'blue))
(check-pred image? (rectangle 10 10 'outline 'blue)) (check-pred image? (rectangle 10 10 'outline 'blue))
(check-pred image? (rectangle 10 10 "outline" 'blue)) (check-pred image? (rectangle 10 10 "outline" 'blue))
(check-false (image? 5))) (check-false (image? 5)))
(test-case (test-case
"color-list" "color-list"

23
collects/tests/drracket/sample-solutions-one-window.rkt
View File

@ -230,17 +230,18 @@
(define toc (call-with-input-file (build-path sample-solutions-dir "toc.rkt") read)) (define toc (call-with-input-file (build-path sample-solutions-dir "toc.rkt") read))
(define labels (define labels
(let* ([all-info (call-with-input-file (build-path (collection-path "solutions") (let* ([all-info (call-with-input-file (build-path (collection-path "solutions")
'up 'up "proj" "book" "solutions" 'up 'up "proj" "book" "solutions"
"labels.scm") read)] "labels.scm")
[ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:") read)]
(> (string-length (car x)) 3))) [ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:")
all-info)]) (> (string-length (car x)) 3)))
(map (lambda (x) all-info)])
(cons (string-append (substring (car x) 3 (string-length (car x))) ".scm") (map (lambda (x)
(cdr x))) (cons (string-append (substring (car x) 3 (string-length (car x))) ".scm")
ex-labels))) (cdr x)))
ex-labels)))
(define sample-solutions (define sample-solutions
(sort (sort

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