From af6be85ff576e475753a46bd3f1690eb8bf88a28 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 Mar 2013 07:15:43 -0400 Subject: [PATCH] Fix lots of indentation mistakes. (Found by my ayatollah script...) --- collects/algol60/compile.rkt | 8 +- collects/algol60/simplify.rkt | 18 +- collects/compiler/compiler-unit.rkt | 82 +- collects/compiler/demodularizer/merge.rkt | 18 +- collects/data/integer-set.rkt | 12 +- collects/data/queue.rkt | 22 +- collects/deinprogramm/deinprogramm-langs.rkt | 6 +- .../signature/signature-syntax.rkt | 6 +- collects/deinprogramm/signature/signature.rkt | 4 +- collects/deinprogramm/turtle.rkt | 20 +- collects/drracket/private/debug.rkt | 2 +- .../drracket/private/embedded-snip-utils.rkt | 8 +- .../private/language-configuration.rkt | 14 +- collects/drracket/private/profile-drs.rkt | 4 +- collects/embedded-gui/embedded-gui.rkt | 4 +- collects/embedded-gui/private/lines.rkt | 10 +- collects/framework/main.rkt | 6 +- collects/framework/private/icon.rkt | 6 +- collects/framework/private/keymap.rkt | 12 +- collects/framework/private/panel.rkt | 12 +- collects/framework/private/racket.rkt | 372 +++---- collects/frtime/demos/pong.rkt | 2 +- collects/frtime/demos/push-pull-ball.rkt | 14 +- collects/frtime/frlibs/math.rkt | 5 +- collects/frtime/gui/mixin-macros.rkt | 2 +- collects/frtime/opt/frtime-opt.rkt | 2 +- .../private/graph-drawing.rkt | 10 +- .../future-visualizer/private/gui-helpers.rkt | 2 +- .../private/visualizer-data.rkt | 18 +- .../private/visualizer-drawing.rkt | 7 +- collects/games/paint-by-numbers/main.rkt | 2 +- .../raw-problems/build-hattori.rkt | 8 +- collects/games/paint-by-numbers/solve.rkt | 4 +- collects/gui-debugger/debug-tool.rkt | 12 +- collects/honu/core/private/macro2.rkt | 14 +- collects/honu/core/private/parse2.rkt | 393 ++++---- collects/honu/core/read.rkt | 2 +- collects/lang/private/signature-syntax.rkt | 6 +- .../macro-debugger/model/deriv-parser.rkt | 2 +- .../macro-debugger/syntax-browser/display.rkt | 14 +- .../macro-debugger/syntax-browser/widget.rkt | 36 +- .../distributions/exponential-dist.rkt | 2 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 8 +- collects/mred/private/wx/gtk/frame.rkt | 11 +- collects/mred/private/wx/gtk/window.rkt | 103 +- collects/mred/private/wxme/text.rkt | 190 ++-- collects/mzlib/include.rkt | 12 +- collects/openssl/mzssl.rkt | 4 +- .../private-yacc/input-file-parser.rkt | 10 +- collects/parser-tools/private-yacc/lr0.rkt | 8 +- .../private-yacc/parser-builder.rkt | 5 +- collects/picturing-programs/main.rkt | 2 +- collects/plai/private/gc-transformer.rkt | 2 +- collects/plai/test-harness.rkt | 12 +- collects/planet2/lib.rkt | 2 +- collects/r6rs/private/find-version.rkt | 52 +- collects/racket/contract/private/exists.rkt | 17 +- .../racket/contract/private/generate-base.rkt | 19 +- .../racket/contract/private/struct-dc.rkt | 2 +- collects/racket/draw/bmp.rkt | 2 +- collects/racket/draw/private/lzw.rkt | 20 +- collects/racket/draw/private/region.rkt | 2 +- collects/racket/match/compiler.rkt | 2 +- .../racket/place/define-remote-server.rkt | 90 +- collects/racket/place/distributed.rkt | 29 +- .../examples/multiple/place-worker.rkt | 19 +- .../racket/place/distributed/map-reduce.rkt | 62 +- collects/racket/place/distributed/rmpi.rkt | 11 +- collects/racket/pretty.rkt | 48 +- collects/racket/private/sc.rkt | 2 +- collects/racket/private/vector-wraps.rkt | 6 +- collects/racket/runtime-path.rkt | 34 +- collects/rackunit/private/test-suite.rkt | 5 +- collects/redex/examples/pi-calculus.rkt | 4 +- collects/redex/examples/r6rs/r6rs.rkt | 39 +- .../racket-machine/randomized-tests.rkt | 9 +- collects/redex/private/gen-trace.rkt | 20 +- collects/redex/private/search.rkt | 36 +- collects/redex/tests/unify-tests.rkt | 16 +- collects/rnrs/enums-6.rkt | 66 +- collects/scribble/core.rkt | 2 +- collects/scribble/private/manual-vars.rkt | 6 +- .../scribblings/framework/mode-helpers.rkt | 5 +- collects/scribblings/gui/blurbs.rkt | 63 +- collects/scribblings/htdp-langs/prim-ops.rkt | 9 +- .../scribblings/htdp-langs/std-grammar.rkt | 6 +- collects/scriblib/autobib.rkt | 2 +- collects/setup/parallel-do.rkt | 24 +- collects/setup/setup-cmdline.rkt | 14 +- collects/sgl/bitmap.rkt | 8 +- collects/srfi/41/derived.rkt | 160 +-- collects/stepper/private/model.rkt | 4 +- collects/stepper/private/shared.rkt | 9 +- .../private/english-string-constants.rkt | 9 +- collects/syntax-color/scribble-lexer.rkt | 33 +- collects/tests/algol60/test.rkt | 35 +- collects/tests/datalog/pretty.rkt | 6 +- collects/tests/db/db/concurrent.rkt | 39 +- collects/tests/deinprogramm/image.rkt | 18 +- .../drracket/sample-solutions-one-window.rkt | 23 +- collects/tests/framework/text.rkt | 20 +- collects/tests/future/visualizer.rkt | 38 +- collects/tests/honu/xml.rkt | 8 +- collects/tests/match/other-tests.rkt | 939 +++++++----------- .../tests/plai/gc/good-mutators/bindings.rkt | 6 +- .../tests/plai/gc2/good-mutators/bindings.rkt | 6 +- .../benchmarks/places/place-channel.rkt | 60 +- .../benchmarks/places/place-processes.rkt | 23 +- .../racket/benchmarks/places/place-utils.rkt | 7 +- collects/tests/racket/contract-helpers.rkt | 44 +- collects/tests/racket/place-channel-fd.rkt | 10 +- collects/tests/racket/place-channel.rkt | 8 +- collects/tests/stepper/test-cases.rkt | 26 +- collects/tests/typed-racket/fail/pr10350.rkt | 4 +- .../fail/require-typed-missing.rkt | 20 +- .../typed-racket/fail/subtype-int-err.rkt | 14 +- collects/tests/typed-racket/main.rkt | 2 +- .../tests/typed-racket/succeed/exceptions.rkt | 4 +- collects/tests/typed-racket/succeed/foldo.rkt | 10 +- .../tests/typed-racket/succeed/for-seq.rkt | 2 +- .../tests/typed-racket/succeed/for-vector.rkt | 42 +- .../typed-racket/succeed/infer-funargs.rkt | 6 +- .../typed-racket/succeed/random-bits.rkt | 6 +- .../succeed/threads-and-channels.rkt | 8 +- .../tests/unstable/temp-c/ttt-players.rkt | 2 +- .../tests/web-server/http/cookies-test.rkt | 12 +- collects/tests/web-server/http/xexpr.rkt | 2 +- .../web-server/servlet/bindings-test.rkt | 2 +- collects/tests/xml/test.rkt | 50 +- collects/texpict/private/mrpict-extra.rkt | 2 +- collects/typed-racket/base-env/base-env.rkt | 110 +- collects/typed-racket/optimizer/apply.rkt | 32 +- collects/typed-racket/types/base-abbrev.rkt | 16 +- .../typed-racket/utils/require-contract.rkt | 9 +- .../unstable/latent-contract/defthing.rkt | 10 +- collects/unstable/temp-c/dsl.rkt | 9 +- .../web-server/dispatchers/dispatch-log.rkt | 8 +- .../web-server/dispatchers/filesystem-map.rkt | 8 +- collects/web-server/http/cookie.rkt | 15 +- collects/web-server/http/response.rkt | 4 +- 140 files changed, 2040 insertions(+), 2223 deletions(-) diff --git a/collects/algol60/compile.rkt b/collects/algol60/compile.rkt index 5c2429c148..c7677ba2d8 100644 --- a/collects/algol60/compile.rkt +++ b/collects/algol60/compile.rkt @@ -433,10 +433,10 @@ (car spec))) arg-specs) #'unknown)]) - (cons var - (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars) - spec - (list 'by-name spec))))) + (cons var + (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars) + spec + (list 'by-name spec))))) arg-vars) context)) diff --git a/collects/algol60/simplify.rkt b/collects/algol60/simplify.rkt index 098f0afea5..19c434545e 100644 --- a/collects/algol60/simplify.rkt +++ b/collects/algol60/simplify.rkt @@ -146,22 +146,22 @@ (map (lambda (extra) (if (identifier? extra) (make-a60:type-decl (->stx 'integer) (list extra)) - (make-a60:switch-decl (car extra) (map (lambda (x) - (make-a60:variable (datum->syntax-object #f x) null)) - (cdr extra))))) + (make-a60:switch-decl + (car extra) + (map (lambda (x) + (make-a60:variable (datum->syntax-object #f x) + null)) + (cdr extra))))) extra-decls)) (if (null? new-statements) (list (cons (gensym 'other) (make-a60:dummy))) new-statements))) (define (simplify stmt ctx) - (simplify-statement stmt (lambda (x) - (datum->syntax-object - ctx - x)))) - + (simplify-statement stmt (lambda (x) (datum->syntax-object ctx x)))) + (define (simplify-statement stmt ->stx) - (match stmt + (match stmt [($ a60:block decls statements) (flatten/label-block decls statements ->stx)] [($ a60:compound statements) diff --git a/collects/compiler/compiler-unit.rkt b/collects/compiler/compiler-unit.rkt index d09cdf6350..4adb03853d 100644 --- a/collects/compiler/compiler-unit.rkt +++ b/collects/compiler/compiler-unit.rkt @@ -114,46 +114,48 @@ #f)))) (unless (eq? 'all omit-paths) (let ([init (parameterize ([current-directory dir] - [current-load-relative-directory dir] - ;; Verbose compilation manager: - [manager-trace-handler (if verbose? - (let ([op (current-output-port)]) - (lambda (s) (fprintf op "~a\n" s))) - (manager-trace-handler))] - [manager-compile-notify-handler - (lambda (path) ((compile-notify-handler) path))] - [manager-skip-file-handler - (lambda (path) (and skip-path - (let ([b (path->bytes (simplify-path path #f))] - [len (bytes-length skip-path)]) - (and ((bytes-length b) . > . len) - (bytes=? (subbytes b 0 len) skip-path))) - (list -inf.0 "")))]) - (let* ([sses (append - ;; Find all .rkt/.ss/.scm files: - (filter extract-base-filename/ss (directory-list)) - ;; Add specified doc sources: - (if skip-docs? - null - (map (lambda (s) (if (string? s) (string->path s) s)) - (map car (info* 'scribblings (lambda () null))))))] - [sses (remove* omit-paths sses)]) - (worker null sses)))]) - - (if (compile-subcollections) - (begin - (when (info* 'compile-subcollections (lambda () #f)) - (printf "Warning: ignoring `compile-subcollections' entry in info ~a\n" - dir)) - (for/fold ([init init]) ([p (directory-list dir)]) - (let ([p* (build-path dir p)]) - (if (and (directory-exists? p*) (not (member p omit-paths))) - (compile-directory-visitor p* (c-get-info/full p*) worker omit-root - #:verbose verbose? - #:skip-path skip-path - #:skip-doc-sources? skip-docs?) - init)))) - init)))) + [current-load-relative-directory dir] + ;; Verbose compilation manager: + [manager-trace-handler + (if verbose? + (let ([op (current-output-port)]) + (lambda (s) (fprintf op "~a\n" s))) + (manager-trace-handler))] + [manager-compile-notify-handler + (lambda (path) ((compile-notify-handler) path))] + [manager-skip-file-handler + (lambda (path) + (and skip-path + (let ([b (path->bytes (simplify-path path #f))] + [len (bytes-length skip-path)]) + (and ((bytes-length b) . > . len) + (bytes=? (subbytes b 0 len) skip-path))) + (list -inf.0 "")))]) + (let* ([sses (append + ;; Find all .rkt/.ss/.scm files: + (filter extract-base-filename/ss (directory-list)) + ;; Add specified doc sources: + (if skip-docs? + null + (map (lambda (s) (if (string? s) (string->path s) s)) + (map car (info* 'scribblings (lambda () null))))))] + [sses (remove* omit-paths sses)]) + (worker null sses)))]) + + (if (compile-subcollections) + (begin + (when (info* 'compile-subcollections (lambda () #f)) + (printf "Warning: ignoring `compile-subcollections' entry in info ~a\n" + dir)) + (for/fold ([init init]) ([p (directory-list dir)]) + (let ([p* (build-path dir p)]) + (if (and (directory-exists? p*) (not (member p omit-paths))) + (compile-directory-visitor p* (c-get-info/full p*) worker omit-root + #:verbose verbose? + #:skip-path skip-path + #:skip-doc-sources? skip-docs?) + init)))) + init)))) (define (compile-directory dir info #:verbose [verbose? #t] #:skip-path [orig-skip-path #f] diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 4ca7184e59..6edd751cb7 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -134,18 +134,18 @@ (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S" - mod-toplevels toplevel-remap)) + (error 'merge-module "Not remapping everything: ~S ~S" + mod-toplevels toplevel-remap)) (log-debug (format "[~S] Incrementing toplevels by ~a" - name - toplevel-offset)) + name + toplevel-offset)) (log-debug (format "[~S] Incrementing lifts by ~a" - name - lift-offset)) + name + lift-offset)) (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" - name - (length mod-toplevels) - (length new-mod-toplevels))) + name + (length mod-toplevels) + (length new-mod-toplevels))) (values (max max-let-depth mod-max-let-depth) (merge-prefix top-prefix new-mod-prefix) (lambda (top-prefix) diff --git a/collects/data/integer-set.rkt b/collects/data/integer-set.rkt index a468588347..eb098e82c1 100644 --- a/collects/data/integer-set.rkt +++ b/collects/data/integer-set.rkt @@ -416,13 +416,13 @@ (cons i (cons s2 rest))))))))))) (test-block ((->is (lambda (str) - (foldr (lambda (c cs) - (merge (make-range (char->integer c)) - cs)) - (make-range) - (string->list str)))) + (foldr (lambda (c cs) + (merge (make-range (char->integer c)) + cs)) + (make-range) + (string->list str)))) (->is2 (lambda (str) - (integer-set-contents (->is str))))) + (integer-set-contents (->is str))))) ((partition null) null) ((map integer-set-contents (partition (list (->is "1234")))) (list (->is2 "1234"))) ((map integer-set-contents (partition (list (->is "1234") (->is "0235")))) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index 1d3935e42f..3320bd6af6 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -100,17 +100,17 @@ ([(var) (in-queue* queue-expression)] (with-syntax ([queue-expression/c (wrap-expr/c #'queue? #'queue-expression #:macro #'in-queue*)]) - #'[(var) - (:do-in ([(queue) queue-expression/c]) - (void) ;; handled by contract - ([link (queue-head queue)]) - link - ([(var) (link-value link)]) - #t - #t - ((link-tail link)))])) - ([(var ...) (in-queue* queue-expression)] - #f)))) + #'[(var) + (:do-in ([(queue) queue-expression/c]) + (void) ;; handled by contract + ([link (queue-head queue)]) + link + ([(var) (link-value link)]) + #t + #t + ((link-tail link)))])) + ([(var ...) (in-queue* queue-expression)] + #f)))) ;; --- contracts --- (define queue/c queue?) diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index 8d76eb8f3b..3b874da1ce 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -1084,12 +1084,12 @@ [(send pre-installed-lb get-selection) => (lambda (i) `(lib ,(send pre-installed-lb get-string i) - "teachpack" - "deinprogramm"))] + "teachpack" + "deinprogramm"))] [(send user-installed-lb get-selection) => (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!")])) diff --git a/collects/deinprogramm/signature/signature-syntax.rkt b/collects/deinprogramm/signature/signature-syntax.rkt index 3566f76982..1adbd9e1cc 100644 --- a/collects/deinprogramm/signature/signature-syntax.rkt +++ b/collects/deinprogramm/signature/signature-syntax.rkt @@ -47,9 +47,9 @@ #'(when (signature? ?temp) ?raise)))) (syntax->list #'((?temp ?exp) ...))))) - #'(let ((?temp ?exp) ...) - ?check ... - (make-case-signature '?name (list ?temp ...) equal? ?stx))))) + #'(let ((?temp ?exp) ...) + ?check ... + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/deinprogramm/signature/signature.rkt b/collects/deinprogramm/signature/signature.rkt index f77b05a761..5849a87449 100644 --- a/collects/deinprogramm/signature/signature.rkt +++ b/collects/deinprogramm/signature/signature.rkt @@ -65,8 +65,8 @@ (lambda (this-info other-info) #f)) #:=?-proc (=?-proc - (lambda (this-info other-info) - #f))) + (lambda (this-info other-info) + #f))) (really-make-signature name enforcer syntax-promise arbitrary-promise info-promise <=?-proc =?-proc)) (define (signature-syntax sig) diff --git a/collects/deinprogramm/turtle.rkt b/collects/deinprogramm/turtle.rkt index 5220166c3f..52ef073d17 100644 --- a/collects/deinprogramm/turtle.rkt +++ b/collects/deinprogramm/turtle.rkt @@ -150,16 +150,16 @@ (lambda (length) (lambda (t) (let* ((h (get-h t)) - (w (get-w t)) - (x (get-x t)) - (y (get-y t)) - (angle (get-angle t)) - (image (get-image t)) - (color (get-color t)) - (state (get-state t)) - ; Compute new coordinats - (newx (+ x (* length (cos (grad->rad angle))))) - (newy (+ y (* length (sin (grad->rad angle)))))) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t)) + ; Compute new coordinats + (newx (+ x (* length (cos (grad->rad angle))))) + (newy (+ y (* length (sin (grad->rad angle)))))) (new-turtle-priv h w newx newy angle diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index b4f7af05e7..6c0e4b9f2d 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -651,7 +651,7 @@ profile todo: (let ([dis (if (exn? dis/exn) (cms->srclocs (exn-continuation-marks 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) (show-backtrace-window/edition-pairs/two error-text dis editions '() '() defs ints)) diff --git a/collects/drracket/private/embedded-snip-utils.rkt b/collects/drracket/private/embedded-snip-utils.rkt index 3c3dcf55a5..45d7636383 100644 --- a/collects/drracket/private/embedded-snip-utils.rkt +++ b/collects/drracket/private/embedded-snip-utils.rkt @@ -14,10 +14,10 @@ (if (and admin (is-a? admin editor-snip-editor-admin<%>)) (let ([enclosing-editor-snip (send admin get-snip)]) (if (get-snip-outer-editor enclosing-editor-snip) - (get-enclosing-editor-frame (get-snip-outer-editor - enclosing-editor-snip)) - (topwin))) - (topwin)))) + (get-enclosing-editor-frame (get-snip-outer-editor + enclosing-editor-snip)) + (topwin))) + (topwin)))) ;; get-snip-outer-editor: snip% -> (or/c editor<%> #f) ;; Returns the immediate outer editor enclosing the snip, or false if we diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index aa2dda4483..82264f9438 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -44,13 +44,13 @@ [(shift) (send evt get-shiftdown)] [(option) (send evt get-alt-down)])) shortcut-prefix)) - (values (string-append (string-constant the-racket-language) - (format " (~aR)" menukey-string)) - (string-append (string-constant teaching-languages) - (format " (~aT)" menukey-string)) - (string-append (string-constant other-languages) - (format " (~aO)" menukey-string)) - mouse-event-uses-shortcut-prefix?))) + (values (string-append (string-constant the-racket-language) + (format " (~aR)" menukey-string)) + (string-append (string-constant teaching-languages) + (format " (~aT)" menukey-string)) + (string-append (string-constant other-languages) + (format " (~aO)" menukey-string)) + mouse-event-uses-shortcut-prefix?))) (provide language-configuration@) diff --git a/collects/drracket/private/profile-drs.rkt b/collects/drracket/private/profile-drs.rkt index d765ef2c01..acc03aaea3 100644 --- a/collects/drracket/private/profile-drs.rkt +++ b/collects/drracket/private/profile-drs.rkt @@ -59,9 +59,7 @@ itself. (define (update-buttons) (send resume-b enable (and current-sampler (not running?))) (send pause-b enable (and current-sampler running?)) - (send start-stop-b set-label (if current-sampler - "Stop" - "Start"))) + (send start-stop-b set-label (if current-sampler "Stop" "Start"))) (define running? #f) (define current-sampler #f) diff --git a/collects/embedded-gui/embedded-gui.rkt b/collects/embedded-gui/embedded-gui.rkt index fd786a43e2..2953298b67 100644 --- a/collects/embedded-gui/embedded-gui.rkt +++ b/collects/embedded-gui/embedded-gui.rkt @@ -3,8 +3,8 @@ (define-syntax (require/provide stx) (syntax-case stx () [(_ filename ...) - #'(begin (require filename ...) - (provide (all-from filename) ...))])) + #'(begin (require filename ...) + (provide (all-from filename) ...))])) (require/provide "private/interface.rkt" diff --git a/collects/embedded-gui/private/lines.rkt b/collects/embedded-gui/private/lines.rkt index 0805be6eeb..67147d27cc 100644 --- a/collects/embedded-gui/private/lines.rkt +++ b/collects/embedded-gui/private/lines.rkt @@ -96,11 +96,11 @@ (super-new) (inherit set-snipclass) (set-snipclass sc))] - [sc (new - (class snip-class% - (define/override (read f) - (new c)) - (super-new)))]) + [sc (new + (class snip-class% + (define/override (read f) + (new c)) + (super-new)))]) (send sc set-classname classname) (send sc set-version 1) (send (get-the-snip-class-list) add sc) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 3b113ea964..04526ccfb4 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -238,9 +238,9 @@ ((sym) ((default (λ () (error 'get-preference/gui "unknown pref ~s" sym))))) @{Like @racket[get-preference], but has more sophisticated error handling. - In particular, it passes a @racket[#:timeout-lock-there] argument that - informs the user that the preferences file is locked (and offers the alternative - of not showing the message again).}) + In particular, it passes a @racket[#:timeout-lock-there] argument that + informs the user that the preferences file is locked (and offers the alternative + of not showing the message again).}) (proc-doc/names diff --git a/collects/framework/private/icon.rkt b/collects/framework/private/icon.rkt index 162c5cd937..1d5b4fedef 100644 --- a/collects/framework/private/icon.rkt +++ b/collects/framework/private/icon.rkt @@ -31,9 +31,9 @@ (export framework:icon^) (define eof-bitmap (delay/sync (let ([bm (make-object bitmap% eof-bitmap-path)]) - (unless (send bm ok?) - (error 'eof-bitmap "not ok ~s\n" eof-bitmap-path)) - bm))) + (unless (send bm ok?) + (error 'eof-bitmap "not ok ~s\n" eof-bitmap-path)) + bm))) (define (get-eof-bitmap) (force eof-bitmap)) (define anchor-bitmap (delay/sync (make-object bitmap% anchor-bitmap-path))) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 5a537e5e45..e5601705c1 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -25,9 +25,9 @@ [-get-file get-file])) (init-depend mred^) -;; if I put this in main.rkt with the others, it doesn't happen -;; early enough... ? JBC, 2011-07-12 -(preferences:set-default 'framework:automatic-parens #f boolean?) + ;; if I put this in main.rkt with the others, it doesn't happen + ;; early enough... ? JBC, 2011-07-12 + (preferences:set-default 'framework:automatic-parens #f boolean?) (define user-keybindings-files (make-hash)) @@ -931,8 +931,8 @@ (λ (adjust) (λ (text event) (when (is-a? text editor:basic<%>) - (let ([frame (send text get-top-level-window)]) - (let ([found-one? #f]) + (let ([frame (send text get-top-level-window)] + [found-one? #f]) (let/ec k (let ([go (λ () @@ -952,7 +952,7 @@ ;;; or the last editor-canvas had the focus. either way, ;;; the next thing should get the focus (set! found-one? #t) - (go))))))))] + (go)))))))] [TeX-compress (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index 055b14eae4..9b4893baa5 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -525,13 +525,13 @@ (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) -(define splitter<%> (interface () split-horizontal split-vertical collapse)) -;; we need a private interface so we can use `generic' because `generic' -;; doesn't work on mixins -(define splitter-private<%> (interface () self-vertical? self-horizontal?)) + (define splitter<%> (interface () split-horizontal split-vertical collapse)) + ;; we need a private interface so we can use `generic' because `generic' + ;; doesn't work on mixins + (define splitter-private<%> (interface () self-vertical? self-horizontal?)) -(define splitter-mixin - (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) + (define splitter-mixin + (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) (super-new) (inherit get-children add-child delete-child diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index c9886eaeb0..2fc6e41357 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -152,7 +152,7 @@ ;; old snips (from old versions of drracket) use this snipclass (define 2lib-snip-class (make-object sexp-snipclass%)) (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 (get-the-snip-class-list) add 2lib-snip-class) @@ -517,194 +517,194 @@ (define/public (tabify-on-return?) #t) (define/public (tabify [pos (get-start-position)]) (unless (is-stopped?) - (let* ([tabify-prefs (preferences:get 'framework:tabify)] - [last-pos (last-position)] - [para (position-paragraph pos)] - [is-tabbable? (and (> para 0) - (not (memq (classify-position (sub1 (paragraph-start-position para))) - '(comment string error))))] - [end (if is-tabbable? (paragraph-start-position para) 0)] - [limit (get-limit pos)] - ;; "contains" is the start of the initial sub-S-exp - ;; in the S-exp that contains "pos". If pos is outside - ;; all S-exps, this will be the start of the initial - ;; S-exp - [contains - (if is-tabbable? - (backward-containing-sexp end limit) - #f)] - [contain-para (and contains - (position-paragraph contains))] - ;; "last" is the start of the S-exp just before "pos" - [last - (if contains - (let ([p (get-backward-sexp end)]) - (if (and p (p . >= . limit)) - p - (backward-match end limit))) - #f)] - [last-para (and last - (position-paragraph last))]) - (letrec - ([find-offset - (λ (start-pos) - (define tab-char? #f) - (define end-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* ([tabify-prefs (preferences:get 'framework:tabify)] + [last-pos (last-position)] + [para (position-paragraph pos)] + [is-tabbable? (and (> para 0) + (not (memq (classify-position (sub1 (paragraph-start-position para))) + '(comment string error))))] + [end (if is-tabbable? (paragraph-start-position para) 0)] + [limit (get-limit pos)] + ;; "contains" is the start of the initial sub-S-exp + ;; in the S-exp that contains "pos". If pos is outside + ;; all S-exps, this will be the start of the initial + ;; S-exp + [contains + (if is-tabbable? + (backward-containing-sexp end limit) + #f)] + [contain-para (and contains + (position-paragraph contains))] + ;; "last" is the start of the S-exp just before "pos" + [last + (if contains + (let ([p (get-backward-sexp end)]) + (if (and p (p . >= . limit)) + p + (backward-match end limit))) + #f)] + [last-para (and last + (position-paragraph last))]) + (letrec + ([find-offset + (λ (start-pos) + (define tab-char? #f) + (define end-pos + (let loop ([p start-pos]) (let ([c (get-character p)]) (cond - [(char=? c #\null) 0] [(char=? c #\tab) - (let ([o (loop (sub1 p))]) - (+ o (- 8 (modulo o 8))))] - [(char=? c #\newline) 0] - [else (add1 (loop (sub1 p)))])))))] - [do-indent - (λ (amt) - (define pos-start end) - (define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) - (unless (and (not tab-char?) (= amt (- curr-offset pos-start))) - (delete pos-start curr-offset) - (insert (make-string amt #\space) pos-start)))] - [get-proc - (λ () - (let ([id-end (get-forward-sexp contains)]) - (and (and id-end (> id-end contains)) - (let* ([text (get-text contains id-end)]) - (or (get-keyword-type text tabify-prefs) - 'other)))))] - [procedure-indent - (λ () - (case (get-proc) - [(begin define) 1] - [(lambda) 3] - [else 0]))] - [special-check - (λ () - (let* ([proc-name (get-proc)]) - (or (eq? proc-name 'define) - (eq? proc-name 'lambda))))] - [curley-brace-sexp? - (λ () - (define up-p (find-up-sexp pos)) - (and up-p - (equal? #\{ (get-character up-p))))] - - [indent-first-arg (λ (start) - (define-values (gwidth curr-offset tab-char?) (find-offset start)) - gwidth)]) - (when (and is-tabbable? - (not (char=? (get-character (sub1 end)) - #\newline))) - (insert #\newline (paragraph-start-position para))) - (cond - [(not is-tabbable?) - (when (= para 0) - (do-indent 0))] - [(let-values ([(gwidth real-start tab-char?) (find-offset end)]) - (and (<= (+ 3 real-start) (last-position)) - (string=? ";;;" - (get-text real-start - (+ 2 real-start))))) - (void)] - [(not contains) - ;; Something went wrong matching. Should we get here? - (do-indent 0)] - #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. - [(curley-brace-sexp?) - ;; when we are directly inside an sexp that uses {}s, - ;; we indent in a more C-like fashion (to help Scribble) - (define first-curley (find-up-sexp pos)) - (define containing-curleys - (let loop ([pos first-curley]) - (let ([next (find-up-sexp pos)]) - (if (and next - (equal? (get-character next) #\{)) - (+ (loop next) 1) - 1)))) - (define close-first-curley (get-forward-sexp first-curley)) - (define para (position-paragraph pos)) - (when (and close-first-curley - (<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) - (set! containing-curleys (max 0 (- containing-curleys 1)))) - (do-indent (* containing-curleys 2))] - [(not last) - ;; We can't find a match backward from pos, - ;; but we seem to be inside an S-exp, so - ;; go "up" an S-exp, and move forward past - ;; the associated paren - (let ([enclosing (find-up-sexp pos)]) - (if enclosing - (do-indent (+ (visual-offset enclosing) 1)) - (do-indent 0)))] - [(= contains last) - ;; There's only one S-expr in the S-expr - ;; containing "pos" - (do-indent (+ (visual-offset contains) - (procedure-indent)))] - [(special-check) - ;; In case of "define", etc., ignore the position of last - ;; and just indent under the "define" - (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)))))]))))) + (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)]) + (cond + [(char=? c #\null) 0] + [(char=? c #\tab) + (let ([o (loop (sub1 p))]) + (+ o (- 8 (modulo o 8))))] + [(char=? c #\newline) 0] + [else (add1 (loop (sub1 p)))])))))] + [do-indent + (λ (amt) + (define pos-start end) + (define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) + (unless (and (not tab-char?) (= amt (- curr-offset pos-start))) + (delete pos-start curr-offset) + (insert (make-string amt #\space) pos-start)))] + [get-proc + (λ () + (let ([id-end (get-forward-sexp contains)]) + (and (and id-end (> id-end contains)) + (let* ([text (get-text contains id-end)]) + (or (get-keyword-type text tabify-prefs) + 'other)))))] + [procedure-indent + (λ () + (case (get-proc) + [(begin define) 1] + [(lambda) 3] + [else 0]))] + [special-check + (λ () + (let* ([proc-name (get-proc)]) + (or (eq? proc-name 'define) + (eq? proc-name 'lambda))))] + [curley-brace-sexp? + (λ () + (define up-p (find-up-sexp pos)) + (and up-p + (equal? #\{ (get-character up-p))))] + + [indent-first-arg (λ (start) + (define-values (gwidth curr-offset tab-char?) (find-offset start)) + gwidth)]) + (when (and is-tabbable? + (not (char=? (get-character (sub1 end)) + #\newline))) + (insert #\newline (paragraph-start-position para))) + (cond + [(not is-tabbable?) + (when (= para 0) + (do-indent 0))] + [(let-values ([(gwidth real-start tab-char?) (find-offset end)]) + (and (<= (+ 3 real-start) (last-position)) + (string=? ";;;" + (get-text real-start + (+ 2 real-start))))) + (void)] + [(not contains) + ;; Something went wrong matching. Should we get here? + (do-indent 0)] + #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. + [(curley-brace-sexp?) + ;; when we are directly inside an sexp that uses {}s, + ;; we indent in a more C-like fashion (to help Scribble) + (define first-curley (find-up-sexp pos)) + (define containing-curleys + (let loop ([pos first-curley]) + (let ([next (find-up-sexp pos)]) + (if (and next + (equal? (get-character next) #\{)) + (+ (loop next) 1) + 1)))) + (define close-first-curley (get-forward-sexp first-curley)) + (define para (position-paragraph pos)) + (when (and close-first-curley + (<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) + (set! containing-curleys (max 0 (- containing-curleys 1)))) + (do-indent (* containing-curleys 2))] + [(not last) + ;; We can't find a match backward from pos, + ;; but we seem to be inside an S-exp, so + ;; go "up" an S-exp, and move forward past + ;; the associated paren + (let ([enclosing (find-up-sexp pos)]) + (if enclosing + (do-indent (+ (visual-offset enclosing) 1)) + (do-indent 0)))] + [(= contains last) + ;; There's only one S-expr in the S-expr + ;; containing "pos" + (do-indent (+ (visual-offset contains) + (procedure-indent)))] + [(special-check) + ;; In case of "define", etc., ignore the position of last + ;; and just indent under the "define" + (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. ;; otherwise, returns #f diff --git a/collects/frtime/demos/pong.rkt b/collects/frtime/demos/pong.rkt index 250c2db9e6..844d1109fc 100644 --- a/collects/frtime/demos/pong.rkt +++ b/collects/frtime/demos/pong.rkt @@ -92,7 +92,7 @@ . =#=> . (match-lambda [(list _ y) (when (and (> y 150) (< y 250)) - add1)]))) + add1)]))) 0)) (define p1-score (mk-score (lambda (x) (< x 10)))) diff --git a/collects/frtime/demos/push-pull-ball.rkt b/collects/frtime/demos/push-pull-ball.rkt index 28436fd06d..e9a0962bf3 100644 --- a/collects/frtime/demos/push-pull-ball.rkt +++ b/collects/frtime/demos/push-pull-ball.rkt @@ -17,13 +17,13 @@ (define pos2 (rec pos (until (make-posn 100 100) - (inf-delay - (let ([brnch (posn+ pos - (posn* (normalize (posn- pos1 pos)) - (- (posn-diff pos pos1) (add1 (* 2 radius)))))]) - (if (< (posn-diff pos pos1) (* 2 radius)) - brnch - pos)))))) + (inf-delay + (let ([brnch (posn+ pos + (posn* (normalize (posn- pos1 pos)) + (- (posn-diff pos pos1) (add1 (* 2 radius)))))]) + (if (< (posn-diff pos pos1) (* 2 radius)) + brnch + pos)))))) (display-shapes (list diff --git a/collects/frtime/frlibs/math.rkt b/collects/frtime/frlibs/math.rkt index 153ea3a1f0..feb9be7684 100644 --- a/collects/frtime/frlibs/math.rkt +++ b/collects/frtime/frlibs/math.rkt @@ -6,10 +6,7 @@ (module math frtime/frtime-lang-only (require (only-in racket/math pi sqr sgn conjugate sinh cosh)) - (provide (lifted - sqr - sgn conjugate - sinh cosh)) + (provide (lifted sqr sgn conjugate sinh cosh)) (provide pi e) diff --git a/collects/frtime/gui/mixin-macros.rkt b/collects/frtime/gui/mixin-macros.rkt index f5789e20e2..0cae8ead37 100644 --- a/collects/frtime/gui/mixin-macros.rkt +++ b/collects/frtime/gui/mixin-macros.rkt @@ -19,7 +19,7 @@ [getting-name (string->symbol (format "get-~a-e" (syntax-e s-field-name)))] [renamed-update (string->symbol - (format "renamed-~a" (syntax-e (syntax update-call))))]) + (format "renamed-~a" (syntax-e (syntax update-call))))]) (syntax (lambda (super) (class super diff --git a/collects/frtime/opt/frtime-opt.rkt b/collects/frtime/opt/frtime-opt.rkt index 3967740214..a805c49cee 100644 --- a/collects/frtime/opt/frtime-opt.rkt +++ b/collects/frtime/opt/frtime-opt.rkt @@ -559,7 +559,7 @@ (map list (syntax->list #'(IDS ...)) optimized-vals)] [body #`(begin EXPR ...)] [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) (let* ([optimized-args (map (lambda (expr) diff --git a/collects/future-visualizer/private/graph-drawing.rkt b/collects/future-visualizer/private/graph-drawing.rkt index a95662ad16..b967c75a4b 100644 --- a/collects/future-visualizer/private/graph-drawing.rkt +++ b/collects/future-visualizer/private/graph-drawing.rkt @@ -121,11 +121,11 @@ (if (empty? (node-children parent)) (attributed-node parent 'leaf 0 depth '()) (let-values ([(leaves achn) - (for/fold ([l 0] [achildren '()]) ([child (in-list (node-children parent))]) - (let ([anode (build-attr-tree child (add1 depth))]) - (if (leaf? anode) - (values (add1 l) (cons anode achildren)) - (values (+ l (attributed-node-num-leaves anode)) (cons anode achildren)))))]) + (for/fold ([l 0] [achildren '()]) ([child (in-list (node-children parent))]) + (let ([anode (build-attr-tree child (add1 depth))]) + (if (leaf? anode) + (values (add1 l) (cons anode achildren)) + (values (+ l (attributed-node-num-leaves anode)) (cons anode achildren)))))]) (attributed-node parent 'interior leaves diff --git a/collects/future-visualizer/private/gui-helpers.rkt b/collects/future-visualizer/private/gui-helpers.rkt index cb27e617e1..60a85aac30 100644 --- a/collects/future-visualizer/private/gui-helpers.rkt +++ b/collects/future-visualizer/private/gui-helpers.rkt @@ -65,7 +65,7 @@ [parent par] [redraw-on-resize #t] [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-backcolor)) text-container) diff --git a/collects/future-visualizer/private/visualizer-data.rkt b/collects/future-visualizer/private/visualizer-data.rkt index e74ffa2c57..cc8fe7487d 100644 --- a/collects/future-visualizer/private/visualizer-data.rkt +++ b/collects/future-visualizer/private/visualizer-data.rkt @@ -84,8 +84,8 @@ creation-tree)) (struct rtcall-info (fid - block-hash ; prim name --o--> number of blocks - sync-hash) ; op name --o--> number of syncs + block-hash ; prim name --o--> number of blocks + sync-hash) ; op name --o--> number of syncs #:transparent) ;(struct process-timeline timeline (proc-index)) @@ -319,8 +319,8 @@ (define (event-pos-description index timeline-len) (cond [(zero? index) (if (= index (sub1 timeline-len)) - 'singleton - 'start)] + 'singleton + 'start)] [(= index (sub1 timeline-len)) 'end] [else 'interior])) @@ -425,11 +425,11 @@ <)) (define non-gc-evts (filter (λ (e) (not (gc-event? e))) all-evts)) (define future-tl-hash (let ([h (make-hash)]) - (for ([evt (in-list non-gc-evts)]) - (let* ([fid (event-future-id evt)] - [existing (hash-ref h fid '())]) - (hash-set! h fid (cons evt existing)))) - h)) + (for ([evt (in-list non-gc-evts)]) + (let* ([fid (event-future-id evt)] + [existing (hash-ref h fid '())]) + (hash-set! h fid (cons evt existing)))) + h)) (for ([fid (in-list (hash-keys future-tl-hash))]) (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)) diff --git a/collects/future-visualizer/private/visualizer-drawing.rkt b/collects/future-visualizer/private/visualizer-drawing.rkt index 5d293bc7bd..8706c2bbab 100644 --- a/collects/future-visualizer/private/visualizer-drawing.rkt +++ b/collects/future-visualizer/private/visualizer-drawing.rkt @@ -211,9 +211,10 @@ [last-x 0] [ticks '()] [last-label-x-extent 0] - [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) - trace-start) - DEFAULT-TIME-INTERVAL)))]) + [remain-segs segs]) + ([i (in-range 0 (floor (/ (- (trace-end-time tr) + trace-start) + DEFAULT-TIME-INTERVAL)))]) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define tick-time (+ trace-start tick-rel-time)) (define want-x (+ last-x (* DEFAULT-TIME-INTERVAL timeToPixMod))) diff --git a/collects/games/paint-by-numbers/main.rkt b/collects/games/paint-by-numbers/main.rkt index 2e9ebf76e3..8656895c73 100644 --- a/collects/games/paint-by-numbers/main.rkt +++ b/collects/games/paint-by-numbers/main.rkt @@ -162,7 +162,7 @@ (caddr state) (cadddr state) (list->vector (map list->vector (car (cddddr state)))))]) - (editor problem))] + (editor problem))] [(player) (let ([name (cadr state)] [problem diff --git a/collects/games/paint-by-numbers/raw-problems/build-hattori.rkt b/collects/games/paint-by-numbers/raw-problems/build-hattori.rkt index 662d7d28ff..f6d12cd8ab 100644 --- a/collects/games/paint-by-numbers/raw-problems/build-hattori.rkt +++ b/collects/games/paint-by-numbers/raw-problems/build-hattori.rkt @@ -31,10 +31,10 @@ [new-bitmap-height (floor (/ (- puzzle-height 1) pixel-size))]) (begin - (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 "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 picture: ~a x ~a\n" raw-width raw-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 "size of puzzle: ~a x ~a\n" puzzle-width puzzle-height)) (reverse (let loop ([j new-bitmap-height]) (cond diff --git a/collects/games/paint-by-numbers/solve.rkt b/collects/games/paint-by-numbers/solve.rkt index 6bcc612c8d..1cd42247fa 100644 --- a/collects/games/paint-by-numbers/solve.rkt +++ b/collects/games/paint-by-numbers/solve.rkt @@ -624,8 +624,8 @@ (board-width final-board) (board-height final-board)))]) (values final-board new-row-tries new-col-tries (or row-changed col-changed)))) - 'full-set - 'caller)) + 'full-set + 'caller)) ; 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 diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index ad73535f14..f6312c0fad 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -465,13 +465,13 @@ id (list-tail frames (send (get-tab) get-frame-num)) ;; id found (lambda (val _) - (cond - [(render val) => (lambda (str) - (string-append - (symbol->string (syntax-e id)) " = " str))] - [else ""])) + (cond + [(render val) => (lambda (str) + (string-append + (symbol->string (syntax-e id)) " = " str))] + [else ""])) ;; id not found - (lambda () ""))]) + (lambda () ""))]) (send (get-tab) set-mouse-over-msg (clean-status rendered)))))) (super on-event event)] [(send event button-down? 'right) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index f0b5a81133..d0dbd6e914 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -228,13 +228,13 @@ (require (for-meta 2 (submod "." analysis))) (begin-for-syntax -(define-syntax (parse-stuff stx) - (syntax-parse stx - [(_ stuff ...) - (emit-remark "Parse stuff ~a\n" #'(stuff ...)) - (phase2:parse-all #'(stuff ...)) - #; - (honu->racket (parse-all #'(stuff ...)))]))) + (define-syntax (parse-stuff stx) + (syntax-parse stx + [(_ stuff ...) + (emit-remark "Parse stuff ~a\n" #'(stuff ...)) + (phase2:parse-all #'(stuff ...)) + #; + (honu->racket (parse-all #'(stuff ...)))]))) (begin-for-syntax (define-syntax (create-honu-macro stx) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 01d5ab4f6e..b695ab1617 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -373,58 +373,58 @@ (define final (if current current (racket-syntax (void)))) (if (parsed-syntax? stream) (values (left stream) #'()) - (syntax-parse stream #:literal-sets (cruft) - #; - [x:id (values #'x #'())] - [((semicolon inner ...) rest ...) - ;; nothing on the left side should interact with a semicolon - (if current - (values (left current) - stream) - (begin - (with-syntax ( - #; - [inner* (parse-all #'(inner ...))]) - (values (left (parse-delayed inner ...)) - #'(rest ...)))))] - [() - (debug "Empty input out: left ~a ~a\n" left (left final)) - (values (left final) #'())] - [(head rest ...) - (debug 2 "Not a special expression..\n") - (cond - [(honu-macro? #'head) - (debug "Macro ~a\n" #'head) - (do-macro #'head #'(rest ...) precedence left current stream)] - [(parsed-syntax? #'head) - (debug "Parsed syntax ~a\n" #'head) - (emit-local-step #'head #'head #:id #'do-parse) - (if current - (values current stream) - (do-parse #'(rest ...) precedence left #'head))] - [(honu-fixture? #'head) - (debug 2 "Fixture ~a\n" #'head) - (define transformer (fixture:fixture-ref (syntax-local-value #'head) 0)) - (define-values (output rest) (transformer current stream)) - (do-parse rest precedence left output)] - [(honu-operator? #'head) - (define operator (syntax-local-value #'head)) + (syntax-parse stream #:literal-sets (cruft) + #; + [x:id (values #'x #'())] + [((semicolon inner ...) rest ...) + ;; nothing on the left side should interact with a semicolon + (if current + (values (left current) + stream) + (begin + (with-syntax ( + #; + [inner* (parse-all #'(inner ...))]) + (values (left (parse-delayed inner ...)) + #'(rest ...)))))] + [() + (debug "Empty input out: left ~a ~a\n" left (left final)) + (values (left final) #'())] + [(head rest ...) + (debug 2 "Not a special expression..\n") + (cond + [(honu-macro? #'head) + (debug "Macro ~a\n" #'head) + (do-macro #'head #'(rest ...) precedence left current stream)] + [(parsed-syntax? #'head) + (debug "Parsed syntax ~a\n" #'head) + (emit-local-step #'head #'head #:id #'do-parse) + (if current + (values current stream) + (do-parse #'(rest ...) precedence left #'head))] + [(honu-fixture? #'head) + (debug 2 "Fixture ~a\n" #'head) + (define transformer (fixture:fixture-ref (syntax-local-value #'head) 0)) + (define-values (output rest) (transformer current stream)) + (do-parse rest precedence left output)] + [(honu-operator? #'head) + (define operator (syntax-local-value #'head)) - (define new-precedence (transformer:operator-precedence operator)) - (define association (transformer:operator-association operator)) - (define binary-transformer (transformer:operator-binary-transformer operator)) - (define unary-transformer (transformer:operator-unary-transformer operator)) - (define postfix? (transformer:operator-postfix? operator)) + (define new-precedence (transformer:operator-precedence operator)) + (define association (transformer:operator-association operator)) + (define binary-transformer (transformer:operator-binary-transformer operator)) + (define unary-transformer (transformer:operator-unary-transformer operator)) + (define postfix? (transformer:operator-postfix? operator)) - (define higher - (case association - [(left) >] - [(right) >=] - [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)) - (if (higher new-precedence precedence) - (let-values ([(parsed unparsed) - (do-parse #'(rest ...) new-precedence + (define higher + (case association + [(left) >] + [(right) >=] + [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)) + (if (higher new-precedence precedence) + (let-values ([(parsed unparsed) + (do-parse #'(rest ...) new-precedence (lambda (stuff) (define right (parse-all stuff)) (define output @@ -445,162 +445,162 @@ (with-syntax ([out (parse-all output)]) #'out)) - #f)]) - (do-parse unparsed precedence left parsed)) - ;; if we have a unary transformer then we have to keep parsing - (if unary-transformer - (if current - (if postfix? - (do-parse #'(rest ...) - precedence - left - (unary-transformer current)) - (values (left current) stream)) + #f)]) + (do-parse unparsed precedence left parsed)) + ;; if we have a unary transformer then we have to keep parsing + (if unary-transformer + (if current + (if postfix? + (do-parse #'(rest ...) + precedence + left + (unary-transformer current)) + (values (left current) stream)) - (do-parse #'(rest ...) new-precedence - (lambda (stuff) - (define right (parse-all stuff)) - (define output (unary-transformer right)) - ;; apply the left function because - ;; we just went ahead with parsing without - ;; caring about precedence - (with-syntax ([out (left (parse-all output))]) - #'out)) - #f)) - ;; otherwise we have a binary transformer (or no transformer..??) - ;; so we must have made a recursive call to parse, just return the - ;; left hand - (values (left current) stream)) - )] - - #; - [(stopper? #'head) - (debug "Parse a stopper ~a\n" #'head) - (values (left final) - stream)] - [else - (define-splicing-syntax-class no-left - [pattern (~seq) #:when (and (= precedence 0) (not current))]) - (syntax-parse #'(head rest ...) #:literal-sets (cruft) - #; - [(semicolon . rest) - (debug "Parsed a semicolon, finishing up with ~a\n" current) - (values (left current) #'rest)] - [body:honu-body + (do-parse #'(rest ...) new-precedence + (lambda (stuff) + (define right (parse-all stuff)) + (define output (unary-transformer right)) + ;; apply the left function because + ;; we just went ahead with parsing without + ;; caring about precedence + (with-syntax ([out (left (parse-all output))]) + #'out)) + #f)) + ;; otherwise we have a binary transformer (or no transformer..??) + ;; so we must have made a recursive call to parse, just return the + ;; left hand + (values (left current) stream)) + )] + + #; + [(stopper? #'head) + (debug "Parse a stopper ~a\n" #'head) + (values (left final) + stream)] + [else + (define-splicing-syntax-class no-left + [pattern (~seq) #:when (and (= precedence 0) (not current))]) + (syntax-parse #'(head rest ...) #:literal-sets (cruft) + #; + [(semicolon . rest) + (debug "Parsed a semicolon, finishing up with ~a\n" current) + (values (left current) #'rest)] + [body:honu-body (if current (values (left current) stream) (values (left #'body.result) #'()) #; (do-parse #'(rest ...) precedence left #'body.result))] - #; - [((semicolon more ...) . rest) #; - (define-values (parsed unparsed) - (do-parse #'(more ...) - 0 - (lambda (x) x) - #f)) + [((semicolon more ...) . rest) + #; + (define-values (parsed unparsed) + (do-parse #'(more ...) + 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)) - (raise-syntax-error 'parse "found unparsed input" unparsed)) - (values (parse-all #'(more ...)) #'rest)] - #; - [(left:no-left function:honu-function . rest) - (values #'function.result #'rest)] - [else + [(left:no-left function:honu-function . rest) + (values #'function.result #'rest)] + [else (debug "Parse a single thing ~a\n" (syntax->datum #'head)) (syntax-parse #'head - #:literal-sets (cruft) - [x:atom - (debug 2 "atom ~a current ~a\n" #'x current) - (if current - (values (left current) stream) - (do-parse #'(rest ...) precedence left (racket-syntax x)))] - ;; [1, 2, 3] -> (list 1 2 3) - [(#%brackets stuff ...) - (define-literal-set wheres (honu-where)) - (define-literal-set equals (honu-equal)) - (syntax-parse #'(stuff ...) #:literal-sets (cruft wheres equals) - [(work:honu-expression - colon (~seq variable:id honu-equal list:honu-expression (~optional honu-comma)) ... - (~seq honu-where where:honu-expression (~optional honu-comma)) ...) - (define filter (if (attribute where) - #'((#:when where.result) ...) - #'())) - (define comprehension - (with-syntax ([((filter ...) ...) filter]) - (racket-syntax (for/list ([variable list.result] - ... - filter ... ...) - work.result)))) - (if current - (values (left current) stream) - (do-parse #'(rest ...) precedence left comprehension))] - [else - (debug "Current is ~a\n" current) - (define value (with-syntax ([(data ...) - (parse-comma-expression #'(stuff ...))]) - (debug "Create list from ~a\n" #'(data ...)) - (racket-syntax (list data ...)))) - (define lookup (with-syntax ([(data ...) - (parse-comma-expression #'(stuff ...))] - [current current]) - (racket-syntax (do-lookup current data ...)))) - (if current - ;; (values (left current) stream) - (do-parse #'(rest ...) precedence left lookup) - (do-parse #'(rest ...) precedence left value))])] - ;; block of code - [body:honu-body - (if current - (values (left current) stream) - (do-parse #'(rest ...) precedence left #'body.result))] - ;; expression or function application - [(#%parens args ...) - (debug "Maybe function call with ~a\n" #'(args ...)) - (if current - ;; FIXME: 9000 is an arbitrary precedence level for - ;; function calls - (if (> precedence 9000) - (let () - (debug 2 "higher precedence call ~a\n" current) - (define call (with-syntax ([current (left current)] - [(parsed-args ...) - (parse-comma-expression #'(args ...)) ]) - (racket-syntax (current parsed-args ...)))) - (do-parse #'(rest ...) 9000 (lambda (x) x) call)) - (let () - (debug 2 "function call ~a\n" left) - (define call (with-syntax ([current current] - [(parsed-args ...) - (parse-comma-expression #'(args ...)) ]) - (debug "Parsed args ~a\n" #'(parsed-args ...)) - (racket-syntax (current parsed-args ...)))) - (do-parse #'(rest ...) precedence left call))) - (let () - (debug "inner expression ~a\n" #'(args ...)) - (define-values (inner-expression unparsed) (parse #'(args ...))) - (when (not (empty-syntax? unparsed)) - (error 'parse "expression had unparsed elements ~a" unparsed)) - (do-parse #'(rest ...) precedence left inner-expression))) + #:literal-sets (cruft) + [x:atom + (debug 2 "atom ~a current ~a\n" #'x current) + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left (racket-syntax x)))] + ;; [1, 2, 3] -> (list 1 2 3) + [(#%brackets stuff ...) + (define-literal-set wheres (honu-where)) + (define-literal-set equals (honu-equal)) + (syntax-parse #'(stuff ...) #:literal-sets (cruft wheres equals) + [(work:honu-expression + colon (~seq variable:id honu-equal list:honu-expression (~optional honu-comma)) ... + (~seq honu-where where:honu-expression (~optional honu-comma)) ...) + (define filter (if (attribute where) + #'((#:when where.result) ...) + #'())) + (define comprehension + (with-syntax ([((filter ...) ...) filter]) + (racket-syntax (for/list ([variable list.result] + ... + filter ... ...) + work.result)))) + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left comprehension))] + [else + (debug "Current is ~a\n" current) + (define value (with-syntax ([(data ...) + (parse-comma-expression #'(stuff ...))]) + (debug "Create list from ~a\n" #'(data ...)) + (racket-syntax (list data ...)))) + (define lookup (with-syntax ([(data ...) + (parse-comma-expression #'(stuff ...))] + [current current]) + (racket-syntax (do-lookup current data ...)))) + (if current + ;; (values (left current) stream) + (do-parse #'(rest ...) precedence left lookup) + (do-parse #'(rest ...) precedence left value))])] + ;; block of code + [body:honu-body + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left #'body.result))] + ;; expression or function application + [(#%parens args ...) + (debug "Maybe function call with ~a\n" #'(args ...)) + (if current + ;; FIXME: 9000 is an arbitrary precedence level for + ;; function calls + (if (> precedence 9000) + (let () + (debug 2 "higher precedence call ~a\n" current) + (define call (with-syntax ([current (left current)] + [(parsed-args ...) + (parse-comma-expression #'(args ...)) ]) + (racket-syntax (current parsed-args ...)))) + (do-parse #'(rest ...) 9000 (lambda (x) x) call)) + (let () + (debug 2 "function call ~a\n" left) + (define call (with-syntax ([current current] + [(parsed-args ...) + (parse-comma-expression #'(args ...)) ]) + (debug "Parsed args ~a\n" #'(parsed-args ...)) + (racket-syntax (current parsed-args ...)))) + (do-parse #'(rest ...) precedence left call))) + (let () + (debug "inner expression ~a\n" #'(args ...)) + (define-values (inner-expression unparsed) (parse #'(args ...))) + (when (not (empty-syntax? unparsed)) + (error 'parse "expression had unparsed elements ~a" unparsed)) + (do-parse #'(rest ...) precedence left inner-expression))) - #; - (do-parse #'(rest ...) - 0 - (lambda (x) x) - (left (with-syntax ([current current] - [(parsed-args ...) - (if (null? (syntax->list #'(args ...))) - '() - (list (parse #'(args ...))))]) - #'(current parsed-args ...)))) - #; - (error 'parse "function call")] - #; - [else (if (not current) - (error 'what "don't know how to parse ~a" #'head) - (values (left current) stream))] - [else (error 'parser "don't know how to parse ~a" #'head)])])])]))) + #; + (do-parse #'(rest ...) + 0 + (lambda (x) x) + (left (with-syntax ([current current] + [(parsed-args ...) + (if (null? (syntax->list #'(args ...))) + '() + (list (parse #'(args ...))))]) + #'(current parsed-args ...)))) + #; + (error 'parse "function call")] + #; + [else (if (not current) + (error 'what "don't know how to parse ~a" #'head) + (values (left current) stream))] + [else (error 'parser "don't know how to parse ~a" #'head)])])])]))) (emit-remark "Honu parse" input) (define-values (parsed unparsed) @@ -635,8 +635,7 @@ (parse (strip-stops code))) (define parsed (if (parsed-syntax? parsed-original) parsed-original - (let-values ([(out rest) - (parse parsed-original)]) + (let-values ([(out rest) (parse parsed-original)]) (when (not (empty-syntax? rest)) (raise-syntax-error 'parse-all "expected no more syntax" parsed-original)) out))) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index 1b9eafbe89..a0329683e9 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -399,7 +399,7 @@ (lambda (current tokens table) (define added (add-dispatch-rule (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) (do-parse (list (make-syntax head (car tokens) source)) (cdr tokens) added)) diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt index dffc0d5bb7..2851737299 100644 --- a/collects/lang/private/signature-syntax.rkt +++ b/collects/lang/private/signature-syntax.rkt @@ -47,9 +47,9 @@ #'(when (signature? ?temp) ?raise)))) (syntax->list #'((?temp ?exp) ...))))) - #'(let ((?temp ?exp) ...) - ?check ... - (make-case-signature '?name (list ?temp ...) equal? ?stx))))) + #'(let ((?temp ?exp) ...) + ?check ... + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index 7b7a36cd3c..4eed82b804 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -130,7 +130,7 @@ [(enter-check (? CheckImmediateMacro/Inner) exit-check) ($2 $1 $3)]) (CheckImmediateMacro/Inner - (#:args le1 e2) + (#:args le1 e2) [(!) (make p:stop le1 e2 null $1)] [(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner)) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index 6232a1ec24..948e89119b 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -106,12 +106,12 @@ (define lazy-interval-map-init (delay (with-log-time "forcing clickback mapping" - (uninterruptible - (for ([range (send/i range range<%> all-ranges)]) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) + (uninterruptible + (for ([range (send/i range range<%> all-ranges)]) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) (define (the-callback position) (force lazy-interval-map-init) (send/i controller selection-manager<%> set-selected-syntax @@ -123,7 +123,7 @@ ;; Clears all highlighting and reapplies all non-foreground styles. (define/public (refresh) (with-log-time "refresh" - (with-unlock text + (with-unlock text (uninterruptible (let ([undo-select/highlight-d (get-undo-select/highlight-d)]) (for ([r (in-list to-undo-styles)]) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 2a1bda364a..ebda9aca69 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/collects/macro-debugger/syntax-browser/widget.rkt @@ -134,32 +134,32 @@ (define range (send/i display display<%> get-range)) (define offset (send/i display display<%> get-start-position)) (with-log-time "substitutions" - (for ([subst (in-list substitutions)]) - (for ([r (in-list (send/i range range<%> get-ranges (car subst)))]) - (send -text insert (cdr subst) - (+ offset (car r)) - (+ offset (cdr r)) - #f) - (send -text change-style - (code-style -text (send/i config config<%> get-syntax-font-size)) - (+ offset (car r)) - (+ offset (cdr r)) - #f)))) + (for ([subst (in-list substitutions)]) + (for ([r (in-list (send/i range range<%> get-ranges (car subst)))]) + (send -text insert (cdr subst) + (+ offset (car r)) + (+ offset (cdr r)) + #f) + (send -text change-style + (code-style -text (send/i config config<%> get-syntax-font-size)) + (+ offset (car r)) + (+ offset (cdr r)) + #f)))) ;; Apply highlighting (with-log-time "highlights" - (for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)]) - (send/i display display<%> highlight-syntaxes hi-stxs hi-color))) + (for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)]) + (send/i display display<%> highlight-syntaxes hi-stxs hi-color))) ;; Underline binders (and shifted binders) (with-log-time "underline binders" - (send/i display display<%> underline-syntaxes - (let ([binder-list (hash-map binders (lambda (k v) k))]) - (append (apply append (map get-shifted binder-list)) - binder-list)))) + (send/i display display<%> underline-syntaxes + (let ([binder-list (hash-map binders (lambda (k v) k))]) + (append (apply append (map get-shifted binder-list)) + binder-list)))) (send display refresh) ;; Make arrows (& billboards, when enabled) (with-log-time "add arrows" - (when (send config get-draw-arrows?) + (when (send config get-draw-arrows?) (define (definite-phase id) (and definites (or (eomap-ref definites id #f) diff --git a/collects/math/private/distributions/exponential-dist.rkt b/collects/math/private/distributions/exponential-dist.rkt index f4e9c48383..c66f5503a6 100644 --- a/collects/math/private/distributions/exponential-dist.rkt +++ b/collects/math/private/distributions/exponential-dist.rkt @@ -48,7 +48,7 @@ (begin-encourage-inline (: exponential-dist (case-> (-> Exponential-Dist) - (Real -> Exponential-Dist))) + (Real -> Exponential-Dist))) (define (exponential-dist [s 1.0]) (let ([s (fl s)]) (define pdf (opt-lambda: ([x : Real] [log? : Any #f]) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index c509f04202..d6ebaf2f7f 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -78,10 +78,10 @@ [w (NSSize-width (NSRect-size f))] [y (+ (NSPoint-y (NSRect-origin f)) (NSSize-height (NSRect-size f)))]) - (lambda (p) - (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) - (and (<= x (NSPoint-x p) (+ x w)) - (<= (- y h) (NSPoint-y p) y))))))) + (lambda (p) + (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) + (and (<= x (NSPoint-x p) (+ x w)) + (<= (- y h) (NSPoint-y p) y))))))) (set-menu-bar-hooks! in-menu-bar-range) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d4e14124c0..b3b1d3fa65 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -381,12 +381,11 @@ (if big-icon (list (bitmap->pixbuf big-icon)) (cdr (car (force icon-pixbufs+glist))))]) - (atomically - (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf - big-pixbufs)]) - (g_list_insert l i -1))]) - (gtk_window_set_icon_list gtk l) - (g_list_free l)))))) + (atomically + (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf big-pixbufs)]) + (g_list_insert l i -1))]) + (gtk_window_set_icon_list gtk l) + (g_list_free l)))))) (define child-has-focus? #f) (define reported-activate #f) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 8ee9903361..ff6df8618d 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -327,57 +327,58 @@ (if crossing? (GdkEventCrossing-state event) (GdkEventButton-state event)))] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [type (cond - [(= type GDK_MOTION_NOTIFY) - 'motion] - [(= type GDK_ENTER_NOTIFY) - 'enter] - [(= type GDK_LEAVE_NOTIFY) - 'leave] - [(= type GDK_BUTTON_PRESS) - (case (GdkEventButton-button event) - [(1) 'left-down] - [(3) 'right-down] - [else 'middle-down])] - [else - (case (GdkEventButton-button event) - [(1) 'left-up] - [(3) 'right-up] - [else 'middle-up])])] - [m (let-values ([(x y) (send wx - adjust-event-position - (->long ((if motion? - GdkEventMotion-x - (if crossing? GdkEventCrossing-x GdkEventButton-x)) - event)) - (->long ((if motion? GdkEventMotion-y - (if crossing? GdkEventCrossing-y GdkEventButton-y)) - event)))]) - (new mouse-event% - [event-type type] - [left-down (case type - [(left-down) #t] - [(left-up) #f] - [else (bit? modifiers GDK_BUTTON1_MASK)])] - [middle-down (case type - [(middle-down) #t] - [(middle-up) #f] - [else (bit? modifiers GDK_BUTTON2_MASK)])] - [right-down (case type - [(right-down) #t] - [(right-up) #f] - [else (bit? modifiers GDK_BUTTON3_MASK)])] - [x x] - [y y] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_META_MASK)] - [alt-down (bit? modifiers GDK_MOD1_MASK)] - [time-stamp ((if motion? GdkEventMotion-time - (if crossing? GdkEventCrossing-time GdkEventButton-time)) - event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [type (cond + [(= type GDK_MOTION_NOTIFY) + 'motion] + [(= type GDK_ENTER_NOTIFY) + 'enter] + [(= type GDK_LEAVE_NOTIFY) + 'leave] + [(= type GDK_BUTTON_PRESS) + (case (GdkEventButton-button event) + [(1) 'left-down] + [(3) 'right-down] + [else 'middle-down])] + [else + (case (GdkEventButton-button event) + [(1) 'left-up] + [(3) 'right-up] + [else 'middle-up])])] + [m (let-values ([(x y) + (send wx + adjust-event-position + (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event)) + (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event)))]) + (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? modifiers GDK_BUTTON1_MASK)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? modifiers GDK_BUTTON2_MASK)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? modifiers GDK_BUTTON3_MASK)])] + [x x] + [y y] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [time-stamp ((if motion? GdkEventMotion-time + (if crossing? GdkEventCrossing-time GdkEventButton-time)) + event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 61e803929f..fdc0204779 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -1376,10 +1376,10 @@ (set! flow-locked? #f) (when deleted? (end-edit-sequence)))]) - (cond - [(or isnip snipsl) - (insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)] - [else (insert-string str start success-finish fail-finish)]))))) + (cond + [(or isnip snipsl) + (insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)] + [else (insert-string str start success-finish fail-finish)]))))) (assert (consistent-snip-lines 'post-do-insert)))) (define/private (insert-snips snipsl start success-finish fail-finish) @@ -2609,15 +2609,15 @@ (= current v) (and (v . <= . 0) (current . <= . 0)) (not (can-set-size-constraint?))) - (on-set-size-constraint) + (on-set-size-constraint) - (set! graphic-maybe-invalid? #t) - (set! graphic-maybe-invalid-force? #t) - (setter v) - (set! changed? #t) - (need-refresh -1 -1) + (set! graphic-maybe-invalid? #t) + (set! graphic-maybe-invalid-force? #t) + (setter v) + (set! changed? #t) + (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]) (set-m-x w min-width (lambda (w) (set! min-width w)))) @@ -5658,93 +5658,93 @@ (get-default-print-size W H)) (when (not (zero? page)) (send (current-ps-setup) get-editor-margin hm vm))) - (let ([H (- H (* 2 vm))] - [W (- W (* 2 hm))]) + (let ([H (- H (* 2 vm))] + [W (- W (* 2 hm))]) - ;; H is the total page height; - ;; line is the line that we haven't finished printing; - ;; y is the starting location to print for this page; - ;; h is the height that we're hoping to fit into the page - ;; i is the line number - (let ploop ([this-page 1] - [line first-line] - [y 0.0] - [next-h 0.0] - [i 0]) - (and - line - (let ([h next-h] - [next-h 0.0]) - (let loop ([h h] - [i i] - [line line] - [can-continue? #t] - [unline 0.0]) - (cond - [(or (zero? h) - (and (i . < . num-valid-lines) - (or (zero? page) - ((mline-h line) . < . (- H h))) - can-continue?)) - (let ([lh (mline-h line)] - [new-page? (new-page-line? line)]) - (loop (+ h lh) - (add1 i) - (mline-next line) - (not new-page?) - (if new-page? lh unline)))] - [else - (let-values ([(h i line) - (cond - [(and (not (zero? page)) - (h . < . H) - (i . < . num-valid-lines) - ((mline-h line) . > . H)) - ;; 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 + ;; H is the total page height; + ;; line is the line that we haven't finished printing; + ;; y is the starting location to print for this page; + ;; h is the height that we're hoping to fit into the page + ;; i is the line number + (let ploop ([this-page 1] + [line first-line] + [y 0.0] + [next-h 0.0] + [i 0]) + (and + line + (let ([h next-h] + [next-h 0.0]) + (let loop ([h h] + [i i] + [line line] + [can-continue? #t] + [unline 0.0]) + (cond + [(or (zero? h) + (and (i . < . num-valid-lines) + (or (zero? page) + ((mline-h line) . < . (- H h))) + can-continue?)) + (let ([lh (mline-h line)] + [new-page? (new-page-line? line)]) + (loop (+ h lh) + (add1 i) + (mline-next line) + (not new-page?) + (if new-page? lh unline)))] + [else + (let-values ([(h i line) + (cond + [(and (not (zero? page)) + (h . < . H) + (i . < . num-valid-lines) + ((mline-h line) . > . H)) + ;; 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) - (let ([new-h (- py y)]) - (values (- h new-h) - new-h)) - (values next-h h))) - (values next-h h))]) - (or (if print? - (begin - (when (or (page . <= . 0) - (= this-page page)) - (begin - (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))))]))))))))))) + (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))] + [py (scroll-line-location pos)]) + (if (py . > . y) + (let ([new-h (- py y)]) + (values (- h new-h) + new-h)) + (values next-h h))) + (values next-h h))]) + (or (if print? + (begin + (when (or (page . <= . 0) + (= this-page page)) + (begin + (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) (has/print-page dc page #f)) diff --git a/collects/mzlib/include.rkt b/collects/mzlib/include.rkt index 350efea469..e566060014 100644 --- a/collects/mzlib/include.rkt +++ b/collects/mzlib/include.rkt @@ -90,13 +90,13 @@ (if (regexp-match? #rx#"[.]rkt$" b) (path-replace-suffix p #".ss") p)))]) - + (let ([c-file (if (file-exists? orig-c-file) - orig-c-file - (let ([p2 (rkt->ss orig-c-file)]) - (if (file-exists? p2) - p2 - orig-c-file)))]) + orig-c-file + (let ([p2 (rkt->ss orig-c-file)]) + (if (file-exists? p2) + p2 + orig-c-file)))]) (register-external-file c-file) (let ([read-syntax (if (syntax-e reader) diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index 1d62f8c2f8..1c683e9840 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -372,9 +372,7 @@ TO DO: (define-syntax with-failure (syntax-rules () [(_ thunk body ...) - (with-handlers ([exn? (lambda (exn) - (thunk) - (raise exn))]) + (with-handlers ([exn? (lambda (exn) (thunk) (raise exn))]) body ...)])) (define (get-error-message id) diff --git a/collects/parser-tools/private-yacc/input-file-parser.rkt b/collects/parser-tools/private-yacc/input-file-parser.rkt index 521bddcc1e..ea5446aba4 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.rkt +++ b/collects/parser-tools/private-yacc/input-file-parser.rkt @@ -46,11 +46,11 @@ (datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)] [end-pos-id (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)) - `(,(datum->syntax-object b name b stx-for-original-property) - ,start-pos-id - ,end-pos-id - ,@(get-args (add1 i) (cdr rhs))))) + (set! biggest-pos (cons start-pos-id end-pos-id)) + `(,(datum->syntax-object b name b stx-for-original-property) + ,start-pos-id + ,end-pos-id + ,@(get-args (add1 i) (cdr rhs))))) (else `(,(datum->syntax-object b name b stx-for-original-property) ,@(get-args (add1 i) (cdr rhs)))))))))]) diff --git a/collects/parser-tools/private-yacc/lr0.rkt b/collects/parser-tools/private-yacc/lr0.rkt index eb0b2dafa7..f23773546d 100644 --- a/collects/parser-tools/private-yacc/lr0.rkt +++ b/collects/parser-tools/private-yacc/lr0.rkt @@ -22,10 +22,10 @@ (define (trans-key* . - (any/c any/c any/c any/c)))) + (listof identifier?) (union syntax? false/c) syntax?) + . ->* . + (any/c any/c any/c any/c)))) ;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?) ;; (union syntax? false/c) syntax?) -> syntax? diff --git a/collects/picturing-programs/main.rkt b/collects/picturing-programs/main.rkt index ff6d3b4e24..0b70d29c7b 100644 --- a/collects/picturing-programs/main.rkt +++ b/collects/picturing-programs/main.rkt @@ -15,7 +15,7 @@ show-it) (provide provide all-defined-out all-from-out rename-out except-out -prefix-out struct-out) + prefix-out struct-out) (define (show-it img) (check-arg 'show-it (image? img) "image" "first" img) diff --git a/collects/plai/private/gc-transformer.rkt b/collects/plai/private/gc-transformer.rkt index 9d905f95b4..e487ed2d17 100644 --- a/collects/plai/private/gc-transformer.rkt +++ b/collects/plai/private/gc-transformer.rkt @@ -14,7 +14,7 @@ [id (identifier? stx) (begin (unless (dict-ref id-hash stx false) - (dict-set! id-hash stx true)))] + (dict-set! id-hash stx true)))] [_ (void)])]) (find stx) (filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids))) diff --git a/collects/plai/test-harness.rkt b/collects/plai/test-harness.rkt index f19b73121a..ba1364561b 100644 --- a/collects/plai/test-harness.rkt +++ b/collects/plai/test-harness.rkt @@ -111,12 +111,12 @@ (with-handlers ; Applying the predicate shouldn't raise an exception. ([exn+catching? (λ (exn) - (print-error - 'pred-exception - test-sexp - (exn-message exn) - ' - loc))]) + (print-error + 'pred-exception + test-sexp + (exn-message exn) + ' + loc))]) (let ([test-result (return-exception (test-thunk))]) (if (or (exn:plai? test-result) (not (exn? test-result))) diff --git a/collects/planet2/lib.rkt b/collects/planet2/lib.rkt index f997eaab53..43c1f5f3f6 100644 --- a/collects/planet2/lib.rkt +++ b/collects/planet2/lib.rkt @@ -956,7 +956,7 @@ (report-mismatch update-deps)] [x (eprintf "Invalid input: ~e\n" x) - (loop)]))]))] + (loop)]))]))] [else (λ () (define final-pkg-dir diff --git a/collects/r6rs/private/find-version.rkt b/collects/r6rs/private/find-version.rkt index da2cead888..b3cee647e7 100644 --- a/collects/r6rs/private/find-version.rkt +++ b/collects/r6rs/private/find-version.rkt @@ -16,40 +16,40 @@ (lambda (file) (let ([s (path-element->bytes file)]) (and - (and (len . < . (bytes-length s)) - (bytes=? p (subbytes s 0 len))) - (let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$" - (subbytes s len))]) - (and m - (or (not (cadr m)) - (bytes=? (cadr m) #".mzscheme")) - (car m)))]) - (and ext - (or (and (= (bytes-length s) (+ len (bytes-length ext))) - (cons null ext)) - (let ([vers (subbytes s len (- (bytes-length s) (bytes-length ext)))]) - (and (regexp-match #rx#"^(-[0-9]+)+$" vers) - (cons - (map string->number - (cdr - (map bytes->string/latin-1 - (regexp-split #rx#"-" vers)))) - ext))))))))) + (and (len . < . (bytes-length s)) + (bytes=? p (subbytes s 0 len))) + (let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$" + (subbytes s len))]) + (and m + (or (not (cadr m)) + (bytes=? (cadr m) #".mzscheme")) + (car m)))]) + (and ext + (or (and (= (bytes-length s) (+ len (bytes-length ext))) + (cons null ext)) + (let ([vers (subbytes s len (- (bytes-length s) (bytes-length ext)))]) + (and (regexp-match #rx#"^(-[0-9]+)+$" vers) + (cons + (map string->number + (cdr + (map bytes->string/latin-1 + (regexp-split #rx#"-" vers)))) + ext))))))))) files))] [versions (let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls" #".rkt")] [ext< (lambda (a b) (> (length (member a eo)) (length (member b eo))))]) - (sort candidate-versions - (lambda (a b) + (sort candidate-versions + (lambda (a b) (if (equal? (car a) (car b)) (ext< (cdr a) (cdr b)) (let loop ([a (car a)] [b (car b)]) - (cond - [(null? a) #t] - [(null? b) #f] - [(> (car a) (car b)) #t] - [(< (car a) (car b)) #f] + (cond + [(null? a) #t] + [(null? b) #f] + [(> (car a) (car b)) #t] + [(< (car a) (car b)) #f] [else (loop (cdr a) (cdr b))]))))))]) (ormap (lambda (candidate-version) (and (version-match? (car candidate-version) vers) diff --git a/collects/racket/contract/private/exists.rkt b/collects/racket/contract/private/exists.rkt index ec41cc5e1d..636c298ccd 100644 --- a/collects/racket/contract/private/exists.rkt +++ b/collects/racket/contract/private/exists.rkt @@ -12,16 +12,13 @@ [out (∀∃/c-out ctc)] [pred? (∀∃/c-pred? ctc)] [neg? (∀∃/c-neg? ctc)]) - (λ (blame) - (if (eq? neg? (blame-swapped? blame)) - (λ (val) - (if (pred? val) - (out val) - (raise-blame-error blame - val - "non-polymorphic value: ~e" - val))) - in)))) + (λ (blame) + (if (eq? neg? (blame-swapped? blame)) + (λ (val) + (if (pred? val) + (out val) + (raise-blame-error blame val "non-polymorphic value: ~e" val))) + in)))) (define-struct ∀∃/c (in out pred? name neg?) #:omit-define-syntaxes diff --git a/collects/racket/contract/private/generate-base.rkt b/collects/racket/contract/private/generate-base.rkt index 7c412b8c6c..661e02d1ea 100644 --- a/collects/racket/contract/private/generate-base.rkt +++ b/collects/racket/contract/private/generate-base.rkt @@ -72,16 +72,15 @@ (λ (fuel) (rand 256)) - bytes? - (λ (fuel) - (let* ([len (rand-choice - [1/10 0] - [1/10 1] - [else (+ 2 (rand 260))])] - [bstr (build-list len - (λ (x) - (rand 256)))]) - (apply bytes bstr))))) + bytes? + (λ (fuel) + (let* ([len (rand-choice + [1/10 0] + [1/10 1] + [else (+ 2 (rand 260))])] + [bstr (build-list len + (λ (x) (rand 256)))]) + (apply bytes bstr))))) ;; thread-cell diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index 3f259690bd..00bfa082eb 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -535,7 +535,7 @@ #t] [(#:selector sel-id) (identifier? #'sel-id) - #t] + #t] [(sel-id #:parent struct-id) (and (identifier? #'sel-id) (identifier? #'struct-id)) diff --git a/collects/racket/draw/bmp.rkt b/collects/racket/draw/bmp.rkt index fcebcc2dd1..23c4d2f584 100644 --- a/collects/racket/draw/bmp.rkt +++ b/collects/racket/draw/bmp.rkt @@ -185,7 +185,7 @@ [height (int2 in)] [planes (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) (arithmetic-shift 1 bits-per-pixel) color-count)] diff --git a/collects/racket/draw/private/lzw.rkt b/collects/racket/draw/private/lzw.rkt index f8e135e0e6..1f1d86e88f 100644 --- a/collects/racket/draw/private/lzw.rkt +++ b/collects/racket/draw/private/lzw.rkt @@ -111,16 +111,16 @@ (lambda (code) (let ([j pos]) (let ([i (+ pos (code-depth code))]) - (set! pos (add1 i)) - (if (>= i (bytes-length result-bstr)) - (log-warning "Too much input data for image, ignoring extra") - (let loop ([code code] - [i i]) - ;; (printf "set ~a\n" (vector-ref entries code)) - (bytes-set! result-bstr i (vector-ref entries code)) - (when (i . > . j) - (loop (vector-ref preds code) - (sub1 i))))))))]) + (set! pos (add1 i)) + (if (>= i (bytes-length result-bstr)) + (log-warning "Too much input data for image, ignoring extra") + (let loop ([code code] + [i i]) + ;; (printf "set ~a\n" (vector-ref entries code)) + (bytes-set! result-bstr i (vector-ref entries code)) + (when (i . > . j) + (loop (vector-ref preds code) + (sub1 i))))))))]) (let loop ([last-code -1]) (let ([code (read-bits compression-size bitstream)]) ;; (printf "~s: ~s ~s ~s\n" compression-size code clear-code end-of-input) diff --git a/collects/racket/draw/private/region.rkt b/collects/racket/draw/private/region.rkt index e253143af6..b8f013bc07 100644 --- a/collects/racket/draw/private/region.rkt +++ b/collects/racket/draw/private/region.rkt @@ -100,7 +100,7 @@ [t (ty l t)] [r (tx 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 (values l t (- r l) (- b t))) (let-values ([(l2 t2 w2 h2) (send (caar paths) get-bounding-box)]) diff --git a/collects/racket/match/compiler.rkt b/collects/racket/match/compiler.rkt index 718fd74ffd..12fed0217c 100644 --- a/collects/racket/match/compiler.rkt +++ b/collects/racket/match/compiler.rkt @@ -436,7 +436,7 @@ (if (Row-unmatch (car blocks)) #`(call-with-continuation-prompt (lambda () (let ([#,(Row-unmatch (car blocks)) - (lambda () (abort-current-continuation match-prompt-tag))]) + (lambda () (abort-current-continuation match-prompt-tag))]) rhs)) match-prompt-tag (lambda () (#,esc))) diff --git a/collects/racket/place/define-remote-server.rkt b/collects/racket/place/define-remote-server.rkt index 537c8396f8..acfa5ff989 100644 --- a/collects/racket/place/define-remote-server.rkt +++ b/collects/racket/place/define-remote-server.rkt @@ -48,20 +48,20 @@ #;(printf "FORM_NAME ~a ~a ~a\n" #'form-name (syntax->datum #'form-name) (equal? (syntax->datum #'form-name) 'define-named-remote-server)) (with-syntax ([receive-line - (cond - [(eq? (syntax->datum #'form-name) 'define-named-remote-server) - #'(list (list fname-symbol args (... ...)) src)] - [else - #'(list fname-symbol args (... ...))])] + (cond + [(eq? (syntax->datum #'form-name) 'define-named-remote-server) + #'(list (list fname-symbol args (... ...)) src)] + [else + #'(list fname-symbol args (... ...))])] [send-dest - (cond - [(eq? (syntax->datum #'form-name) 'define-named-remote-server) - #'src] - [else - #'ch])]) + (cond + [(eq? (syntax->datum #'form-name) 'define-named-remote-server) + #'src] + [else + #'ch])]) (define x #'(define-syntax (form-name stx) - (syntax-case stx () + (syntax-case stx () [(_ name forms (... ...)) (let () @@ -111,41 +111,39 @@ (syntax-case r () [(define-type (fname args (... ...)) body (... ...)) (let () - (with-syntax ([fname-symbol #'(quote fname)] - [(send-line (... ...)) - (cond - [(is-id? 'define-rpc #'define-type) #'((dplace/place-channel-put send-dest result))] - [(is-id? 'define-cast #'define-type) #'()] - [else (raise "Bad define in define-remote-server")])]) - #'[receive-line - (define result - (let () - body (... ...))) - send-line (... ...) - (loop)]))]))]) - #`(lambda (ch) - (let () - states2 (... ...) - (let loop () - (define msg (dplace/place-channel-get ch)) - (define (log-to-parent-real msg #:severity [severity 'info]) - (dplace/place-channel-put ch (log-message severity msg))) - (syntax-parameterize ([log-to-parent (make-rename-transformer #'log-to-parent-real)]) + (with-syntax ([fname-symbol #'(quote fname)] + [(send-line (... ...)) + (cond + [(is-id? 'define-rpc #'define-type) #'((dplace/place-channel-put send-dest result))] + [(is-id? 'define-cast #'define-type) #'()] + [else (raise "Bad define in define-remote-server")])]) + #'[receive-line + (define result + (let () + body (... ...))) + send-line (... ...) + (loop)]))]))]) + #`(lambda (ch) + (let () + states2 (... ...) + (let loop () + (define msg (dplace/place-channel-get ch)) + (define (log-to-parent-real msg #:severity [severity 'info]) + (dplace/place-channel-put ch (log-message severity msg))) + (syntax-parameterize ([log-to-parent (make-rename-transformer #'log-to-parent-real)]) (match msg - cases (... ...) - )) - loop) - )))) - (with-syntax ([mkname (string->id stx (format "make-~a" (id->string #'name)))]) - (define x - #`(begin - (require racket/place - racket/match) - #,@trans-rpcs - (define/provide mkname #,trans-place) - (void))) - ;(pretty-print (syntax->datum x)) - x))])) + cases (... ...))) + loop))))) + (with-syntax ([mkname (string->id stx (format "make-~a" (id->string #'name)))]) + (define x + #`(begin + (require racket/place + racket/match) + #,@trans-rpcs + (define/provide mkname #,trans-place) + (void))) + ;(pretty-print (syntax->datum x)) + x))])) ) ;(pretty-print (syntax->datum x)) x)])) @@ -156,5 +154,3 @@ x)])) (provide define-remote-server define-named-remote-server log-to-parent) - - diff --git a/collects/racket/place/distributed.rkt b/collects/racket/place/distributed.rkt index 979cd1fc8d..9ef59e9f7b 100644 --- a/collects/racket/place/distributed.rkt +++ b/collects/racket/place/distributed.rkt @@ -143,10 +143,11 @@ (define (which cmd) (define path (getenv "PATH")) (and path - (exists? (map (lambda (x) (build-path x cmd)) (regexp-split (case (system-type 'os) - [(unix macosx) ":"] - [(windows) "#:;"]) - path))))) + (exists? (map (lambda (x) (build-path x cmd)) + (regexp-split (case (system-type 'os) + [(unix macosx) ":"] + [(windows) "#:;"]) + path))))) (or (which "ssh") (fallback-paths) (raise "ssh binary not found"))) @@ -173,21 +174,21 @@ (let loop ([t 0] [wait-time start-seconds]) (with-handlers ([exn? (lambda (e) - (cond [(t . < . times) - (klogger (format "backing off ~a sec to ~a:~a" (expt 2 t) rname rport)) - (sleep wait-time) - (loop (add1 t) (* 2 wait-time))] - [else (raise e)]))]) + (cond [(t . < . times) + (klogger (format "backing off ~a sec to ~a:~a" (expt 2 t) rname rport)) + (sleep wait-time) + (loop (add1 t) (* 2 wait-time))] + [else (raise e)]))]) (tcp-connect rname (->number rport))))) (define (tcp-connect/retry rname rport #:times [times 10] #:delay [delay 1]) (let loop ([t 0]) (with-handlers ([exn? (lambda (e) - (cond [(t . < . times) - (klogger (format "waiting ~a sec to retry connection to ~a:~a" delay rname rport)) - (sleep delay) - (loop (add1 t))] - [else (raise e)]))]) + (cond [(t . < . times) + (klogger (format "waiting ~a sec to retry connection to ~a:~a" delay rname rport)) + (sleep delay) + (loop (add1 t))] + [else (raise e)]))]) (tcp-connect rname (->number rport))))) (define (format-log-message severity msg) diff --git a/collects/racket/place/distributed/examples/multiple/place-worker.rkt b/collects/racket/place/distributed/examples/multiple/place-worker.rkt index aab672693d..b2ee4ce671 100644 --- a/collects/racket/place/distributed/examples/multiple/place-worker.rkt +++ b/collects/racket/place/distributed/examples/multiple/place-worker.rkt @@ -18,13 +18,14 @@ ;(place-worker p1) (define (main . argv) - (define p (place ch - (random-seed (current-seconds)) - ;(define id (place-channel-get ch)) - (define id "HI") - (for ([i (in-range (+ 5 (random 5)))]) - (displayln (list (current-seconds) id i)) - (flush-output) - ;(place-channel-put ch (list (current-seconds) id i)) - #;(sleep 3)))) + (define p + (place ch + (random-seed (current-seconds)) + ;; (define id (place-channel-get ch)) + (define id "HI") + (for ([i (in-range (+ 5 (random 5)))]) + (displayln (list (current-seconds) id i)) + (flush-output) + ;; (place-channel-put ch (list (current-seconds) id i)) + #;(sleep 3)))) (sync (handle-evt (place-dead-evt p) (lambda (e) (printf "DEAD\n"))))) diff --git a/collects/racket/place/distributed/map-reduce.rkt b/collects/racket/place/distributed/map-reduce.rkt index cebee91311..f643195b41 100644 --- a/collects/racket/place/distributed/map-reduce.rkt +++ b/collects/racket/place/distributed/map-reduce.rkt @@ -128,39 +128,35 @@ (define result (let loop ([ts tasks] - [idle-mappers connections] - [mapping null] - [ready-to-reduce null] - [reducing null]) - ;(printf "STATE\n") - ;(pretty-print (list ts idle-mappers mapping ready-to-reduce reducing)) - ;(flush-output) - (match (list ts idle-mappers mapping ready-to-reduce reducing) - [(list (cons tsh tst) (cons imh imt) mapping rtr r) - (*channel-put (second imh) (list 'map mapper sorter (list tsh))) - (loop tst imt (cons imh mapping) rtr r)] - [(list ts im m (cons rtr1 (cons rtr2 rtrt)) r) - (*channel-put (second rtr1) (list 'reduce-to reducer sorter (first rtr2))) - (loop ts im m rtrt (cons rtr1 (cons rtr2 r)))] - [(list (list) im (list) (list rtr) (list)) - (*channel-put (second rtr) (list 'get-results)) - (second (*channel-get (second rtr)))] - [else ; wait - (apply sync/enable-break (for/list ([m (append mapping reducing)]) - (wrap-evt (second m) - (lambda (e) - (match e - [(list 'reduce-ready) - (loop ts idle-mappers (remove m mapping) (cons m ready-to-reduce) (remove m reducing))] - [(list 'reduce-done) - (loop ts (cons m idle-mappers) mapping ready-to-reduce (remove m reducing))] - [else - (raise (format "Unknown response message ~a" e))])))))]))) + [idle-mappers connections] + [mapping null] + [ready-to-reduce null] + [reducing null]) + ;; (printf "STATE\n") + ;; (pretty-print (list ts idle-mappers mapping ready-to-reduce reducing)) + ;; (flush-output) + (match (list ts idle-mappers mapping ready-to-reduce reducing) + [(list (cons tsh tst) (cons imh imt) mapping rtr r) + (*channel-put (second imh) (list 'map mapper sorter (list tsh))) + (loop tst imt (cons imh mapping) rtr r)] + [(list ts im m (cons rtr1 (cons rtr2 rtrt)) r) + (*channel-put (second rtr1) (list 'reduce-to reducer sorter (first rtr2))) + (loop ts im m rtrt (cons rtr1 (cons rtr2 r)))] + [(list (list) im (list) (list rtr) (list)) + (*channel-put (second rtr) (list 'get-results)) + (second (*channel-get (second rtr)))] + [else ; wait + (apply sync/enable-break + (for/list ([m (append mapping reducing)]) + (wrap-evt (second m) + (lambda (e) + (match e + [(list 'reduce-ready) + (loop ts idle-mappers (remove m mapping) (cons m ready-to-reduce) (remove m reducing))] + [(list 'reduce-done) + (loop ts (cons m idle-mappers) mapping ready-to-reduce (remove m reducing))] + [else + (raise (format "Unknown response message ~a" e))])))))]))) (or (and outputer ((apply-dynamic-require outputer) result)) result)) - - - - - diff --git a/collects/racket/place/distributed/rmpi.rkt b/collects/racket/place/distributed/rmpi.rkt index f879693b03..6c02cae3e8 100644 --- a/collects/racket/place/distributed/rmpi.rkt +++ b/collects/racket/place/distributed/rmpi.rkt @@ -258,11 +258,12 @@ (partit num cnt id)) (define rmpi-build-default-config - (make-keyword-procedure (lambda (kws kw-args . rest) - (for/hash ([kw kws] - [kwa kw-args]) -; (displayln (keyword? kw)) - (values kw kwa))))) + (make-keyword-procedure + (lambda (kws kw-args . rest) + (for/hash ([kw kws] + [kwa kw-args]) + ;; (displayln (keyword? kw)) + (values kw kwa))))) (define (rmpi-launch default config #:no-wait [no-wait #f]) (define (lookup-config-value rest key-str) diff --git a/collects/racket/pretty.rkt b/collects/racket/pretty.rkt index ec60e02b78..6009ecc9db 100644 --- a/collects/racket/pretty.rkt +++ b/collects/racket/pretty.rkt @@ -1092,39 +1092,39 @@ (pp-list vecl extra pp-expr #f depth pair? car cdr pair-open pair-close qd))))] - [(flvector? obj) - (let ([vecl (flvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (pp-pair (cons (make-unquoted 'flvector) vecl) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#fl") - (when print-vec-length? - (out (number->string (flvector-length obj)))) + [(flvector? obj) + (let ([vecl (flvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'flvector) vecl) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fl") + (when print-vec-length? + (out (number->string (flvector-length obj)))) (pp-list vecl extra pp-expr #f depth pair? car cdr pair-open pair-close qd))))] - [(fxvector? obj) - (let ([vecl (fxvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (pp-pair (cons (make-unquoted 'fxvector) vecl) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#fx") - (when print-vec-length? - (out (number->string (fxvector-length obj)))) + [(fxvector? obj) + (let ([vecl (fxvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'fxvector) vecl) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fx") + (when print-vec-length? + (out (number->string (fxvector-length obj)))) (pp-list vecl extra pp-expr #f depth pair? car cdr pair-open pair-close qd))))] [(and (custom-write? obj) (not (struct-type? obj))) (let ([qd (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) + (custom-print-quotable-accessor obj) + 'self)]) (if (memq kind '(self never)) qd (to-quoted out qd obj)))]) diff --git a/collects/racket/private/sc.rkt b/collects/racket/private/sc.rkt index 6bde993abd..0312419b3a 100644 --- a/collects/racket/private/sc.rkt +++ b/collects/racket/private/sc.rkt @@ -890,7 +890,7 @@ (+ s1 (stx-size (cdr stx) (- up-to s1))))] [(vector? stx) (stx-size (vector->list 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])) ;; Generates a list-ref expression; if use-tail-pos diff --git a/collects/racket/private/vector-wraps.rkt b/collects/racket/private/vector-wraps.rkt index 9315f1baca..4b0eabf0ae 100644 --- a/collects/racket/private/vector-wraps.rkt +++ b/collects/racket/private/vector-wraps.rkt @@ -117,9 +117,9 @@ (fXvector-set! v i (let () last-body ...)) (add1 i))) v)))))] - [(_ #:length length-expr (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?)])) + [(_ #:length length-expr (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?)])) (define-syntax (for/fXvector stx) (for_/fXvector stx stx #'for/fXvector #'for/fold/derived #f)) diff --git a/collects/racket/runtime-path.rkt b/collects/racket/runtime-path.rkt index b92d79721f..fa5a4f04ff 100644 --- a/collects/racket/runtime-path.rkt +++ b/collects/racket/runtime-path.rkt @@ -94,21 +94,21 @@ (path->complete-path p base)] [(string? p) (string->path p)] [(path? p) p] - [(and (list? p) - (= 2 (length p)) - (eq? 'so (car p)) - (string? (cadr p))) - (let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))]) - (or (ormap (lambda (p) - (let ([p (build-path p f)]) - (and (file-exists? p) - p))) - (get-lib-search-dirs)) - (cadr p)))] - [(and (list? p) - ((length p) . > . 1) - (eq? 'lib (car p)) - (andmap string? (cdr p))) + [(and (list? p) + (= 2 (length p)) + (eq? 'so (car p)) + (string? (cadr p))) + (let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))]) + (or (ormap (lambda (p) + (let ([p (build-path p f)]) + (and (file-exists? p) + p))) + (get-lib-search-dirs)) + (cadr p)))] + [(and (list? p) + ((length p) . > . 1) + (eq? 'lib (car p)) + (andmap string? (cdr p))) (let* ([strs (regexp-split #rx"/" (let ([s (cadr p)]) (if (regexp-match? #rx"[./]" s) @@ -121,8 +121,8 @@ (list "mzlib") (append (cddr p) (drop-right strs 1)))))] [(and (list? p) - ((length p) . = . 3) - (eq? 'module (car p)) + ((length p) . = . 3) + (eq? 'module (car p)) (or (not (caddr p)) (variable-reference? (caddr p)))) (let ([p (cadr p)] diff --git a/collects/rackunit/private/test-suite.rkt b/collects/rackunit/private/test-suite.rkt index 38a2c70750..1e3295436c 100644 --- a/collects/rackunit/private/test-suite.rkt +++ b/collects/rackunit/private/test-suite.rkt @@ -133,8 +133,7 @@ (define (tests->test-suite-action tests) (lambda (fdown fup fhere seed) - (parameterize - ([current-seed seed]) + (parameterize ([current-seed seed]) (for-each (lambda (t) (cond @@ -152,7 +151,7 @@ (format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests) (current-continuation-marks)))])) tests) - (current-seed)))) + (current-seed)))) ;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite? ;; diff --git a/collects/redex/examples/pi-calculus.rkt b/collects/redex/examples/pi-calculus.rkt index 5cd4503104..e66b63fb9a 100644 --- a/collects/redex/examples/pi-calculus.rkt +++ b/collects/redex/examples/pi-calculus.rkt @@ -354,8 +354,8 @@ [(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-π (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)))))) - (where a_x ,(variable-not-in (term e_2) (term x)))]) + (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)))]) ;; 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 diff --git a/collects/redex/examples/r6rs/r6rs.rkt b/collects/redex/examples/r6rs/r6rs.rkt index a5308e8be6..6ddd8d1b89 100644 --- a/collects/redex/examples/r6rs/r6rs.rkt +++ b/collects/redex/examples/r6rs/r6rs.rkt @@ -689,26 +689,25 @@ (--> (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)) "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 'ignore)) - "6reinit" - (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 (raise (make-cond "reinvoked continuation of letrec init")))) - "6reinite" - (side-condition (term b))) - - (--> (store (sf_1 ...) (in-hole E_1 (letrec ([x_1 e_1] ...) e_2 e_3 ...))) - (store (sf_1 ... (lx bh) ... (ri #f) ...) - (in-hole E_1 - ((lambda (x_1 ...) - (l! lx x_1) ... - (r6rs-subst-many ((x_1 lx) ... e_2)) - (r6rs-subst-many ((x_1 lx) ... e_3)) ...) - (begin0 - (r6rs-subst-many ((x_1 lx) ... e_1)) - (reinit ri)) - ...))) + (--> (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)) + "6reinit" + (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 (raise (make-cond "reinvoked continuation of letrec init")))) + "6reinite" + (side-condition (term b))) + + (--> (store (sf_1 ...) (in-hole E_1 (letrec ([x_1 e_1] ...) e_2 e_3 ...))) + (store (sf_1 ... (lx bh) ... (ri #f) ...) + (in-hole E_1 + ((lambda (x_1 ...) + (l! lx x_1) ... + (r6rs-subst-many ((x_1 lx) ... e_2)) + (r6rs-subst-many ((x_1 lx) ... e_3)) ...) + (begin0 (r6rs-subst-many ((x_1 lx) ... e_1)) + (reinit ri)) + ...))) "6letrec" (side-condition (unique? (term (x_1 ...)))) (fresh ((lx ...) diff --git a/collects/redex/examples/racket-machine/randomized-tests.rkt b/collects/redex/examples/racket-machine/randomized-tests.rkt index 8acd527dcf..f47195b578 100644 --- a/collects/redex/examples/racket-machine/randomized-tests.rkt +++ b/collects/redex/examples/racket-machine/randomized-tests.rkt @@ -74,7 +74,8 @@ ; the reduction graph produces a cutoff result; with it ; a cylce produces a pending, which is treated identically. (hash-set! cache s (cons c 'pending)) - (let ([r (cond [(term (halted? ,s)) + (let ([r + (cond [(term (halted? ,s)) (make-answer (if (eq? s 'error) 'error @@ -98,9 +99,9 @@ (make-non-conf (list (answer-value (car answers)) (answer-value (car others))))))))))))])]) - (begin - (hash-set! cache s (cons c r)) - r)))))))) + (begin + (hash-set! cache s (cons c r)) + r)))))))) (define (verified/cycles? expr cycles verified?) (and (verified? expr) diff --git a/collects/redex/private/gen-trace.rkt b/collects/redex/private/gen-trace.rkt index c476718861..7cb3badf14 100644 --- a/collects/redex/private/gen-trace.rkt +++ b/collects/redex/private/gen-trace.rkt @@ -422,10 +422,11 @@ (define (ybase-sum) (/ yscale-base (- 1 yscale-base))) (define (find-ybase-center) (define mid (/ (ybase-sum) 2)) - (define sums (for/hash ([i 10]) (values (abs (- mid - (apply + (for/list ([k i]) - (expt yscale-base i))))) - i))) + (define sums (for/hash ([i 10]) + (values (abs (- mid + (apply + (for/list ([k i]) + (expt yscale-base i))))) + i))) (hash-ref sums (apply min (hash-keys sums)))) @@ -679,11 +680,12 @@ (define/private (map-y-int y) (hash-ref map-y-int-memo y (λ () - (define res (if (< 0 y) - (+ Y-SHIFT (* (apply + (for/list ([i (in-range 1 y)]) - (expt yscale-base i))) - y-scale)) - (- Y-SHIFT (* (+ (abs y) 1) y-scale)))) + (define res + (if (< 0 y) + (+ Y-SHIFT (* (apply + (for/list ([i (in-range 1 y)]) + (expt yscale-base i))) + y-scale)) + (- Y-SHIFT (* (+ (abs y) 1) y-scale)))) (hash-set! map-y-int-memo y res) res))) (define/private (map-y y) diff --git a/collects/redex/private/search.rkt b/collects/redex/private/search.rkt index 77d568f58c..84aa73b3a3 100644 --- a/collects/redex/private/search.rkt +++ b/collects/redex/private/search.rkt @@ -199,14 +199,14 @@ (define (trim-dqs e pat) (define p-vars (let loop ([p pat]) - (match p - [`(name ,id ,pat) - (set-union (set id) - (loop pat))] - [`(list ,pats ...) - (apply set-union (for/list ([p pats]) - (loop p)))] - [_ (set)]))) + (match p + [`(name ,id ,pat) + (set-union (set id) + (loop pat))] + [`(list ,pats ...) + (apply set-union (for/list ([p pats]) + (loop p)))] + [_ (set)]))) (struct-copy env e [dqs (for/list ([dq (env-dqs e)]) (trim-dq-vars dq p-vars))])) @@ -243,8 +243,8 @@ (values l r)] [else (for/fold ([l1 l] [r1 r]) - ([a-pair (in-list (for*/list ([a vals] [b (set-remove vals a)]) - (list a b)))]) + ([a-pair (in-list (for*/list ([a vals] [b (set-remove vals a)]) + (list a b)))]) (values (cons (first a-pair) l1) (cons (second a-pair) r1)))]))) (let loop ([ps dqps] @@ -386,14 +386,14 @@ (let/ec fail (define new-f (for/list ([a-p-rule (in-list fringe)]) - (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)) - c)) - (when (empty? new-cs) - (fail #f)) - (struct-copy partial-rule - a-p-rule - [clauses new-cs]))) + (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)) + c)) + (when (empty? new-cs) + (fail #f)) + (struct-copy partial-rule + a-p-rule + [clauses new-cs]))) (define candidate-length (length (partial-rule-clauses (car new-f)))) (if (< candidate-length 2) new-f diff --git a/collects/redex/tests/unify-tests.rkt b/collects/redex/tests/unify-tests.rkt index a6ae5c5640..467344f12d 100644 --- a/collects/redex/tests/unify-tests.rkt +++ b/collects/redex/tests/unify-tests.rkt @@ -183,16 +183,16 @@ (check-equal? (all-resolutions (p*e 'number (env (hash) '()))) (set 'number)) (check-equal? (all-resolutions (p*e `(name a ,(bound)) - (env (hash (lvar 'a) 5) '()))) + (env (hash (lvar 'a) 5) '()))) (set 5 `(name a ,(bound)))) (check-equal? (all-resolutions (p*e `(name a ,(bound)) - (env (hash (lvar 'a) (lvar 'b) - (lvar 'b) 7) '()))) + (env (hash (lvar 'a) (lvar 'b) + (lvar 'b) 7) '()))) (set 7 `(name a ,(bound)) `(name b ,(bound)))) (check-equal? (all-resolutions (p*e `(list 1 2 3) (env (hash) '()))) (set '(list 1 2 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))) (check-equal? (all-resolutions (p*e `(list (name a ,(bound)) (name b ,(bound))) (env (hash (lvar 'a) 1 (lvar 'b) 2) '()))) @@ -664,10 +664,10 @@ (lvar 'x7) (lvar 'x1) (lvar 'Γ2) `(cstr - (Γ) - (list - (list (name x1 ,(bound)) (name t_1 ,(bound))) - (name Γ1 ,(bound))))))) + (Γ) + (list + (list (name x1 ,(bound)) (name t_1 ,(bound))) + (name Γ1 ,(bound))))))) (check-false (unify/format `(name x (list x x)) `(name x (list x)) (m-hash (lvar 'x) diff --git a/collects/rnrs/enums-6.rkt b/collects/rnrs/enums-6.rkt index b88f82a018..d8d44fcc7d 100644 --- a/collects/rnrs/enums-6.rkt +++ b/collects/rnrs/enums-6.rkt @@ -28,16 +28,16 @@ 'make-enumeration "list of symbols" enum))]) - (unless (mlist? enum) (bad)) - (let ([enum (mlist->list enum)]) - (unless (andmap symbol? enum) (bad)) - (let ([ht (make-hasheq)]) - (make-universe - ht - (for/list ([s (in-list enum)] - #:when (not (hash-ref ht s #f))) - (hash-set! ht s (arithmetic-shift 1 (hash-count ht))) - s)))))) + (unless (mlist? enum) (bad)) + (let ([enum (mlist->list enum)]) + (unless (andmap symbol? enum) (bad)) + (let ([ht (make-hasheq)]) + (make-universe + ht + (for/list ([s (in-list enum)] + #:when (not (hash-ref ht s #f))) + (hash-set! ht s (arithmetic-shift 1 (hash-count ht))) + s)))))) (define (make-enumeration enum) (let ([uni (make-enumeration-universe enum)]) @@ -236,26 +236,26 @@ (arithmetic-shift 1 (hash-count ht))))) (with-syntax ([(val ...) (map (lambda (s) (hash-ref ht (syntax-e s))) syms)]) - #'(begin - (define enum-universe (make-enumeration-universe (mlist 'sym ...))) - (define-syntax (type-name stx) - (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [(_ sym) #''sym] - ... - [(_ other) - (identifier? #'other) - (raise-syntax-error #f "not in enumeration" stx #'other)])) - (define-syntax (bit-value stx) - (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [(_ orig sym) #'val] - ... - [(_ orig s) - (raise-syntax-error #f "not in enumeration" #'orig #'s)])) - (... - (define-syntax (constructor stx) - (syntax-case stx () - [(_ s ...) - (andmap identifier? (syntax->list #'(s ...))) - (with-syntax ([orig stx]) - #'(make-enum-set (bitwise-ior (bit-value orig s) ...) - enum-universe))]))))))])) + #'(begin + (define enum-universe (make-enumeration-universe (mlist 'sym ...))) + (define-syntax (type-name stx) + (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [(_ sym) #''sym] + ... + [(_ other) + (identifier? #'other) + (raise-syntax-error #f "not in enumeration" stx #'other)])) + (define-syntax (bit-value stx) + (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [(_ orig sym) #'val] + ... + [(_ orig s) + (raise-syntax-error #f "not in enumeration" #'orig #'s)])) + (... + (define-syntax (constructor stx) + (syntax-case stx () + [(_ s ...) + (andmap identifier? (syntax->list #'(s ...))) + (with-syntax ([orig stx]) + #'(make-enum-set (bitwise-ior (bit-value orig s) ...) + enum-universe))]))))))])) diff --git a/collects/scribble/core.rkt b/collects/scribble/core.rkt index 5fefcc0d42..3a6acfd1db 100644 --- a/collects/scribble/core.rkt +++ b/collects/scribble/core.rkt @@ -19,7 +19,7 @@ (when old-val (eprintf "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n" key old-val val)) - (hash-set! ht key val)))) + (hash-set! ht key val)))) (define (resolve-get/where part ri key) (let ([key (tag-key key ri)]) diff --git a/collects/scribble/private/manual-vars.rkt b/collects/scribble/private/manual-vars.rkt index 4707f44c06..dd2158d4ef 100644 --- a/collects/scribble/private/manual-vars.rkt +++ b/collects/scribble/private/manual-vars.rkt @@ -112,9 +112,9 @@ (bound-identifier-mapping-put! ht #'arg #t)] [else (void)]))) (cdr s-exp)) - (unless (identifier? (car s-exp)) - ;; Curried: - (do-proc (car s-exp)))))]) + (unless (identifier? (car s-exp)) + ;; Curried: + (do-proc (car s-exp)))))]) (do-proc s-exp))] [(form form/none form/maybe non-term) (define skip-id (case (syntax-e kind) diff --git a/collects/scribblings/framework/mode-helpers.rkt b/collects/scribblings/framework/mode-helpers.rkt index c45b99f3bf..d2a3e3ea5e 100644 --- a/collects/scribblings/framework/mode-helpers.rkt +++ b/collects/scribblings/framework/mode-helpers.rkt @@ -19,10 +19,9 @@ (syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y))) [(override method (x ...) ...) #'@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 ...) ...) #'@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]. }])) - diff --git a/collects/scribblings/gui/blurbs.rkt b/collects/scribblings/gui/blurbs.rkt index ce730c1f52..f5f99c7b15 100644 --- a/collects/scribblings/gui/blurbs.rkt +++ b/collects/scribblings/gui/blurbs.rkt @@ -25,25 +25,25 @@ (define (labelsimplestripped where what) @elem{If @litchar{&} occurs in @|where|, it is specially parsed; - under Windows and X, the character - following @litchar{&} is underlined in the displayed control to - indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are - not shown.) The mnemonic is meaningless for a @|what| (as far as - @xmethod[top-level-window<%> on-traverse-char] is concerned), - but it is supported for consistency with other control types. A - programmer may assign a meaning to the mnemonic (e.g., by overriding - @method[top-level-window<%> on-traverse-char]).}) + under Windows and X, the character + following @litchar{&} is underlined in the displayed control to + indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are + not shown.) The mnemonic is meaningless for a @|what| (as far as + @xmethod[top-level-window<%> on-traverse-char] is concerned), + but it is supported for consistency with other control types. A + programmer may assign a meaning to the mnemonic (e.g., by overriding + @method[top-level-window<%> on-traverse-char]).}) (define (labelstripped where detail what) @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) @elem{@|pre| @|what| is @|thing|,@|and| if @|the| - 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 - label. Modifying a bitmap while it is used as a label has - an unspecified effect on the displayed label.}) + 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 + label. Modifying a bitmap while it is used as a label has + an unspecified effect on the displayed label.}) (define-syntax bitmaplabeluse (syntax-rules () @@ -79,20 +79,21 @@ (define insertcharundos @elem{Multiple calls to the character-inserting method are grouped together - for undo purposes, since this case of the method is typically used - for handling user keystrokes. However, this undo-grouping feature - interferes with the undo grouping performed by - @method[editor<%> begin-edit-sequence] and - @method[editor<%> end-edit-sequence], so the string-inserting - method should be used instead during undoable edit sequences.}) + for undo purposes, since this case of the method is typically used + for handling user keystrokes. However, this undo-grouping feature + interferes with the undo grouping performed by + @method[editor<%> begin-edit-sequence] and + @method[editor<%> end-edit-sequence], so the string-inserting + method should be used instead during undoable edit sequences.}) (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) @elem{If the insertion @techlink{position} is before -or equal to the selection's start/end @techlink{position}, then the selection's -start/end @techlink{position} is incremented by @|what|.}) + or equal to the selection's start/end @techlink{position}, then the + selection's start/end @techlink{position} is incremented by @|what|.}) (define OVD @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]).}) (define (FCAX c details) - @elem{@|c|alling this method may force the recalculation of @techlink{location} -information@|details|, even if the editor currently has delayed refreshing (see -@method[editor<%> refresh-delayed?]).}) + @elem{ + @|c|alling this method may force the recalculation of @techlink{location} + information@|details|, even if the editor currently has delayed + refreshing (see @method[editor<%> refresh-delayed?]).}) (define FCA (FCAX "C" "")) (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 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 (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 (FontKWs font) + @elem{The @|font| argument determines the font for the control.}) + (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) @elem{For information about the @racket[horiz-margin] and @racket[vert-margin] arguments, see @racket[subarea<%>].}) diff --git a/collects/scribblings/htdp-langs/prim-ops.rkt b/collects/scribblings/htdp-langs/prim-ops.rkt index a85b47dfff..91b7df7154 100644 --- a/collects/scribblings/htdp-langs/prim-ops.rkt +++ b/collects/scribblings/htdp-langs/prim-ops.rkt @@ -63,16 +63,13 @@ @section[#:tag (string-append section-prefix " Pre-Defined Variables")]{Pre-Defined Variables} @defthing[empty empty?]{ - - The empty list.} + The empty list.} @defthing[true boolean?]{ - - The true value.} + The true value.} @defthing[false boolean?]{ - - The false value.} + The false value.} @section[#:tag (string-append section-prefix " Template Variables")]{Template Variables} @; MF: I tried abstracting but I failed diff --git a/collects/scribblings/htdp-langs/std-grammar.rkt b/collects/scribblings/htdp-langs/std-grammar.rkt index e25295d549..f4e4fdf45e 100644 --- a/collects/scribblings/htdp-langs/std-grammar.rkt +++ b/collects/scribblings/htdp-langs/std-grammar.rkt @@ -66,8 +66,8 @@ @t{An @racket[_name] or a @racket[_variable] is a sequence of characters not including a space or one of the following:} -@t{@hspace[2] @litchar{"} @litchar{,} @litchar{'} @litchar{`} -@litchar{(} @litchar{)} @litchar{[} @litchar{]} +@t{@hspace[2] @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"], @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], and @racket[#\space] are characters.} diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt index a6baa61143..19ac8d767e 100644 --- a/collects/scriblib/autobib.rkt +++ b/collects/scriblib/autobib.rkt @@ -157,7 +157,7 @@ (add-cite group (car v) 'autobib-author #f #f style) (add-date-cites group v (send style get-item-sep) style sort? bib-datestring out)) (define/public (get-id) id) (define/public (get-out) out) diff --git a/collects/setup/setup-cmdline.rkt b/collects/setup/setup-cmdline.rkt index 98e677a242..8772055464 100644 --- a/collects/setup/setup-cmdline.rkt +++ b/collects/setup/setup-cmdline.rkt @@ -102,13 +102,13 @@ (cdr (car collections/archives)) '())]) (cond - [raco? - (check-collections short-name rest) - (values (append pre-collections (map list rest)) - pre-archives)] - [else - (values pre-collections - (append pre-archives rest))]))) + [raco? + (check-collections short-name rest) + (values (append pre-collections (map list rest)) + pre-archives)] + [else + (values pre-collections + (append pre-archives rest))]))) (if raco? '("collection") '("archive")) (lambda (s) (display s) diff --git a/collects/sgl/bitmap.rkt b/collects/sgl/bitmap.rkt index df30f6da9e..764fa02fa9 100644 --- a/collects/sgl/bitmap.rkt +++ b/collects/sgl/bitmap.rkt @@ -34,9 +34,9 @@ #:key [with-gl (lambda (f) (f))] [mask (send bm get-loaded-mask)]) - (let ([w (send bm get-width)] - [h (send bm get-height)] - [rgba (argb->rgba (bitmap->argb bm mask))]) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define rgba (argb->rgba (bitmap->argb bm mask))) (with-gl (lambda () (let ((tex (gl-vector-ref (glGenTextures 1) 0)) @@ -67,4 +67,4 @@ (gl-disable 'texture-2d) (gl-end-list) - list-id)))))) + list-id))))) diff --git a/collects/srfi/41/derived.rkt b/collects/srfi/41/derived.rkt index 595623b19f..36b7c03157 100644 --- a/collects/srfi/41/derived.rkt +++ b/collects/srfi/41/derived.rkt @@ -61,26 +61,26 @@ (define (stream->list . 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")) - ((and n (not (integer? n))) (error 'stream->list "non-integer count")) - ((and n (negative? n)) (error 'stream->list "negative count")) - (else (let loop ((n (if n n -1)) (strm strm)) - (if (or (zero? n) (stream-null? strm)) - '() - (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) + ((and n (not (integer? n))) (error 'stream->list "non-integer count")) + ((and n (negative? n)) (error 'stream->list "negative count")) + (else (let loop ((n (if n n -1)) (strm strm)) + (if (or (zero? n) (stream-null? strm)) + '() + (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) (define (stream-append . strms) (define stream-append (stream-lambda (strms) (cond ((null? (cdr strms)) (car strms)) - ((stream-null? (car strms)) (stream-append (cdr strms))) - (else (stream-cons (stream-car (car strms)) - (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) + ((stream-null? (car strms)) (stream-append (cdr strms))) + (else (stream-cons (stream-car (car strms)) + (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) (cond ((null? strms) stream-null) - ((ormap (lambda (x) (not (stream? x))) strms) - (error 'stream-append "non-stream argument")) - (else (stream-append strms)))) + ((ormap (lambda (x) (not (stream? x))) strms) + (error 'stream-append "non-stream argument")) + (else (stream-append strms)))) (define (stream-concat strms) (define stream-concat @@ -91,9 +91,9 @@ ((stream-null? (stream-car strms)) (stream-concat (stream-cdr strms))) (else (stream-cons - (stream-car (stream-car strms)) - (stream-concat - (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) + (stream-car (stream-car strms)) + (stream-concat + (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) (if (not (stream? strms)) (error 'stream-concat "non-stream argument") (stream-concat strms))) @@ -101,9 +101,9 @@ (define stream-constant (stream-lambda objs (cond ((null? objs) stream-null) - ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) - (else (stream-cons (car objs) - (apply stream-constant (append (cdr objs) (list (car objs))))))))) + ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) + (else (stream-cons (car objs) + (apply stream-constant (append (cdr objs) (list (car objs))))))))) (define (stream-drop n strm) (define stream-drop @@ -112,9 +112,9 @@ strm (stream-drop (- n 1) (stream-cdr strm))))) (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) - ((negative? n) (error 'stream-drop "negative argument")) - ((not (stream? strm)) (error 'stream-drop "non-stream argument")) - (else (stream-drop n strm)))) + ((negative? n) (error 'stream-drop "negative argument")) + ((not (stream? strm)) (error 'stream-drop "non-stream argument")) + (else (stream-drop n strm)))) (define (stream-drop-while pred? strm) (define stream-drop-while @@ -123,27 +123,27 @@ (stream-drop-while (stream-cdr strm)) strm))) (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) - ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) - (else (stream-drop-while strm)))) + ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) + (else (stream-drop-while strm)))) (define (stream-filter pred? strm) (define stream-filter (stream-lambda (strm) (cond ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) - (else (stream-filter (stream-cdr strm)))))) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) + (else (stream-filter (stream-cdr strm)))))) (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) - ((not (stream? strm)) (error 'stream-filter "non-stream argument")) - (else (stream-filter strm)))) + ((not (stream? strm)) (error 'stream-filter "non-stream argument")) + (else (stream-filter strm)))) (define (stream-fold proc base strm) (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) - ((not (stream? strm)) (error 'stream-fold "non-stream argument")) - (else (let loop ((base base) (strm strm)) - (if (stream-null? strm) - base - (loop (proc base (stream-car strm)) (stream-cdr strm))))))) + ((not (stream? strm)) (error 'stream-fold "non-stream argument")) + (else (let loop ((base base) (strm strm)) + (if (stream-null? strm) + base + (loop (proc base (stream-car strm)) (stream-cdr strm))))))) (define (stream-for-each proc . strms) (define (stream-for-each strms) @@ -151,19 +151,19 @@ (begin (apply proc (map stream-car strms)) (stream-for-each (map stream-cdr strms))))) (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) - ((null? strms) (error 'stream-for-each "no stream arguments")) - ((ormap (lambda (x) (not (stream? x))) strms) - (error 'stream-for-each "non-stream argument")) - (else (stream-for-each strms)))) + ((null? strms) (error 'stream-for-each "no stream arguments")) + ((ormap (lambda (x) (not (stream? x))) strms) + (error 'stream-for-each "non-stream argument")) + (else (stream-for-each strms)))) (define (stream-from first . step) (define stream-from (stream-lambda (first delta) (stream-cons first (stream-from (+ first delta) delta)))) (let ((delta (if (null? step) 1 (car step)))) - (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) - ((not (number? delta)) (error 'stream-from "non-numeric step size")) - (else (stream-from first delta))))) + (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) + ((not (number? delta)) (error 'stream-from "non-numeric step size")) + (else (stream-from first delta))))) (define (stream-iterate proc base) (define stream-iterate @@ -194,10 +194,10 @@ (stream-cons (apply proc (map stream-car strms)) (stream-map (map stream-cdr strms)))))) (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) - ((null? strms) (error 'stream-map "no stream arguments")) - ((ormap (lambda (x) (not (stream? x))) strms) - (error 'stream-map "non-stream argument")) - (else (stream-map strms)))) + ((null? strms) (error 'stream-map "no stream arguments")) + ((ormap (lambda (x) (not (stream? x))) strms) + (error 'stream-map "non-stream argument")) + (else (stream-map strms)))) (define-syntax stream-match (syntax-rules () @@ -265,21 +265,21 @@ (stream-cons first (stream-range (+ first delta) past delta lt?)) stream-null))) (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) - ((not (number? past)) (error 'stream-range "non-numeric ending number")) - (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) - (if (not (number? delta)) - (error 'stream-range "non-numeric step size") - (let ((lt? (if (< 0 delta) < >))) - (stream-range first past delta lt?))))))) + ((not (number? past)) (error 'stream-range "non-numeric ending number")) + (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) + (if (not (number? delta)) + (error 'stream-range "non-numeric step size") + (let ((lt? (if (< 0 delta) < >))) + (stream-range first past delta lt?))))))) (define (stream-ref strm n) (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) - ((not (integer? n)) (error 'stream-ref "non-integer argument")) - ((negative? n) (error 'stream-ref "negative argument")) - (else (let loop ((strm strm) (n n)) - (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) - ((zero? n) (stream-car strm)) - (else (loop (stream-cdr strm) (- n 1)))))))) + ((not (integer? n)) (error 'stream-ref "non-integer argument")) + ((negative? n) (error 'stream-ref "negative argument")) + (else (let loop ((strm strm) (n n)) + (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) + ((zero? n) (stream-car strm)) + (else (loop (stream-cdr strm) (- n 1)))))))) (define (stream-reverse strm) (define stream-reverse @@ -298,8 +298,8 @@ (stream base) (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) - ((not (stream? strm)) (error 'stream-scan "non-stream argument")) - (else (stream-scan base strm)))) + ((not (stream? strm)) (error 'stream-scan "non-stream argument")) + (else (stream-scan base strm)))) (define (stream-take n strm) (define stream-take @@ -308,20 +308,20 @@ stream-null (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) - ((not (integer? n)) (error 'stream-take "non-integer argument")) - ((negative? n) (error 'stream-take "negative argument")) - (else (stream-take n strm)))) + ((not (integer? n)) (error 'stream-take "non-integer argument")) + ((negative? n) (error 'stream-take "negative argument")) + (else (stream-take n strm)))) (define (stream-take-while pred? strm) (define stream-take-while (stream-lambda (strm) (cond ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) - (else stream-null)))) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) + (else stream-null)))) (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) - ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) - (else (stream-take-while strm)))) + ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) + (else (stream-take-while strm)))) (define (stream-unfold mapper pred? generator base) (define stream-unfold @@ -330,9 +330,9 @@ (stream-cons (mapper base) (stream-unfold (generator base))) stream-null))) (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) - ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) - ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) - (else (stream-unfold base)))) + ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) + ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) + (else (stream-unfold base)))) (define (stream-unfolds gen seed) (define (len-values gen seed) @@ -349,13 +349,13 @@ (stream-lambda (result-stream i) (let ((result (list-ref (stream-car result-stream) (- i 1)))) (cond ((pair? result) - (stream-cons - (car result) - (result-stream->output-stream (stream-cdr result-stream) i))) - ((not result) - (result-stream->output-stream (stream-cdr result-stream) i)) - ((null? result) stream-null) - (else (error 'stream-unfolds "can't happen")))))) + (stream-cons + (car result) + (result-stream->output-stream (stream-cdr result-stream) i))) + ((not result) + (result-stream->output-stream (stream-cdr result-stream) i)) + ((null? result) stream-null) + (else (error 'stream-unfolds "can't happen")))))) (define (result-stream->output-streams result-stream) (let loop ((i (len-values gen seed)) (outputs '())) (if (zero? i) @@ -372,6 +372,6 @@ stream-null (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) (cond ((null? strms) (error 'stream-zip "no stream arguments")) - ((ormap (lambda (x) (not (stream? x))) strms) - (error 'stream-zip "non-stream argument")) - (else (stream-zip strms)))) + ((ormap (lambda (x) (not (stream? x))) strms) + (error 'stream-zip "non-stream argument")) + (else (stream-zip strms)))) diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index 545099b152..8dea5d1d7e 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -70,8 +70,8 @@ (provide/contract [go (->* (program-expander-contract ; program-expander - (step-result? . -> . void?) ; receive-result - (or/c render-settings? false/c)) ; render-settings + (step-result? . -> . void?) ; receive-result + (or/c render-settings? false/c)) ; render-settings (#:raw-step-receiver (-> continuation-mark-set? symbol? void?) #:disable-error-handling? boolean?) diff --git a/collects/stepper/private/shared.rkt b/collects/stepper/private/shared.rkt index f45ef24e4b..11d2da98af 100644 --- a/collects/stepper/private/shared.rkt +++ b/collects/stepper/private/shared.rkt @@ -570,9 +570,12 @@ attached)) (define (values-map fn . lsts) - (apply values (apply map list - (apply map (lambda args (call-with-values (lambda () (apply fn args)) list)) - lsts)))) + (apply values + (apply map list + (apply map (lambda args + (call-with-values (lambda () (apply fn args)) + list)) + lsts)))) ; produces the list of numbers from a to b (inclusive) (define (a...b a b) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 2dcdb48c5c..5b50095e98 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -174,9 +174,10 @@ please adhere to these guidelines: (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) (error-sending-bug-report "Error Sending Bug Report") - (error-sending-bug-report-expln "An error occurred when sending this bug report." - " 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") + (error-sending-bug-report-expln + "An error occurred when sending this bug report." + " 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") (pls-fill-in-field "Please fill in the \"~a\" field") (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-highlight "Highlight") ;; used to search in the graph; the label on a text-field% object (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-short "Short") (module-browser-name-medium "Medium") diff --git a/collects/syntax-color/scribble-lexer.rkt b/collects/syntax-color/scribble-lexer.rkt index 669bd12c3a..94a8237f76 100644 --- a/collects/syntax-color/scribble-lexer.rkt +++ b/collects/syntax-color/scribble-lexer.rkt @@ -27,22 +27,21 @@ (hash-set! rx-keys rx (make-ephemeron rx bstr)) rx)))) -(define (scribble-inside-lexer orig-in offset mode) - (let ([mode (or mode - (list - (make-text #rx"^@" - #f - #f - #rx".*?(?:(?=[@\r\n])|$)" - #f - #f)))] - [in (special-filter-input-port orig-in - (lambda (v s) - (bytes-set! s 0 (char->integer #\.)) - 1))]) - (let-values ([(line col pos) (port-next-location orig-in)]) - (when line - (port-count-lines! in))) +(define (scribble-inside-lexer orig-in offset orig-mode) + (define mode (or orig-mode + (list + (make-text #rx"^@" + #f + #f + #rx".*?(?:(?=[@\r\n])|$)" + #f + #f)))) + (define in (special-filter-input-port + orig-in + (lambda (v s) (bytes-set! s 0 (char->integer #\.)) 1))) + (let-values ([(line col pos) (port-next-location orig-in)]) + (when line + (port-count-lines! in))) (let-values ([(line col pos) (port-next-location in)] [(l) (car mode)]) @@ -362,7 +361,7 @@ (enter-simple-opener (cdr mode))] [else (scribble-inside-lexer in offset (cdr mode))])] - [else (error "bad mode")]))))) + [else (error "bad mode")])))) (define (scribble-lexer in offset mode) (scribble-inside-lexer in offset (or mode (list (make-scheme 'many #f))))) diff --git a/collects/tests/algol60/test.rkt b/collects/tests/algol60/test.rkt index 2b5d4e31a9..d6a2131165 100644 --- a/collects/tests/algol60/test.rkt +++ b/collects/tests/algol60/test.rkt @@ -25,10 +25,10 @@ (check-equal? (capture-output @literal-algol{ -begin - printsln (`hello world') -end -}) + begin + printsln (`hello world') + end + }) '(run "hello world\n" "")) (check-pred @@ -37,8 +37,8 @@ end (list-ref x 1)))) (capture-output @literal-algol{ -begin -})) + begin + })) (check-pred @@ -47,14 +47,15 @@ begin (list-ref x 1)))) (capture-output @literal-algol{ -procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k); - value n, m; array a; integer n, m, i, k; real y; -begin integer p, q; - y := 0; i := k := 1; - for p:=1 step 1 until n do - for q:=1 step 1 until m do - if abs(a[p, q]) > y then - begin y := abs(a[p, q]); - i := p; k := q - end -end Absmax})) + procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k); + value n, m; array a; integer n, m, i, k; real y; + begin integer p, q; + y := 0; i := k := 1; + for p:=1 step 1 until n do + for q:=1 step 1 until m do + if abs(a[p, q]) > y then + begin y := abs(a[p, q]); + i := p; k := q + end + end Absmax + })) diff --git a/collects/tests/datalog/pretty.rkt b/collects/tests/datalog/pretty.rkt index f2c5c5522b..43783586d5 100644 --- a/collects/tests/datalog/pretty.rkt +++ b/collects/tests/datalog/pretty.rkt @@ -9,9 +9,9 @@ "Pretty" (test-equal? "program" - (format-program - (parse-program - (open-input-string #< (string-length (car x)) 3))) - all-info)]) - (map (lambda (x) - (cons (string-append (substring (car x) 3 (string-length (car x))) ".scm") - (cdr x))) - ex-labels))) + (define labels + (let* ([all-info (call-with-input-file (build-path (collection-path "solutions") + 'up 'up "proj" "book" "solutions" + "labels.scm") + read)] + [ex-labels (filter (lambda (x) (and (string=? (substring (car x) 0 3) "ex:") + (> (string-length (car x)) 3))) + all-info)]) + (map (lambda (x) + (cons (string-append (substring (car x) 3 (string-length (car x))) ".scm") + (cdr x))) + ex-labels))) (define sample-solutions (sort diff --git a/collects/tests/framework/text.rkt b/collects/tests/framework/text.rkt index 400da68a16..40ce94b080 100644 --- a/collects/tests/framework/text.rkt +++ b/collects/tests/framework/text.rkt @@ -149,16 +149,16 @@ (delete-file tmp-file) (equal? x 0)) (λ () - (queue-sexp-to-mred - `(let ([t (new text:basic%)]) - (send t insert "abc") - (send t save-file ,tmp-file) - (send t highlight-range 0 3 "red") - (call-with-output-file ,tmp-file - (lambda (port) (display "x\n" port)) - #:exists 'truncate) - (send t load-file) - (length (send t get-highlighted-ranges))))))) + (queue-sexp-to-mred + `(let ([t (new text:basic%)]) + (send t insert "abc") + (send t save-file ,tmp-file) + (send t highlight-range 0 3 "red") + (call-with-output-file ,tmp-file + (lambda (port) (display "x\n" port)) + #:exists 'truncate) + (send t load-file) + (length (send t get-highlighted-ranges))))))) (test 'highlight-range-delegate-1 diff --git a/collects/tests/future/visualizer.rkt b/collects/tests/future/visualizer.rkt index e4da7e3dc6..333ef2d108 100644 --- a/collects/tests/future/visualizer.rkt +++ b/collects/tests/future/visualizer.rkt @@ -20,29 +20,23 @@ (check-false (negative? (segment-y s))) (check-true (< (segment-y s) (frame-info-adjusted-height finfo))))) -;Display tests -(let ([vr (viewable-region 3 3 500 500)]) - (for ([i (in-range 4 503)]) - (check-true (in-viewable-region-horiz vr i) - (format "~a should be in ~a" - i - vr))) - (for ([i (in-range 0 2)]) - (check-false (in-viewable-region-horiz vr i) - (format "~a should not be in ~a" - i - vr)) - (for ([i (in-range 504 1000)]) - (check-false (in-viewable-region-horiz vr i) - (format "~a should not be in ~a" - i - vr))))) +;Display tests +(let ([vr (viewable-region 3 3 500 500)]) + (for ([i (in-range 4 503)]) + (check-true (in-viewable-region-horiz vr i) + (format "~a should be in ~a" i vr))) + (for ([i (in-range 0 2)]) + (check-false (in-viewable-region-horiz vr i) + (format "~a should not be in ~a" i vr)) + (for ([i (in-range 504 1000)]) + (check-false (in-viewable-region-horiz vr i) + (format "~a should not be in ~a" i vr))))) -(let ([vr (viewable-region 0 0 732 685)]) - (check-true (in-viewable-region-horiz vr 10)) - (check-true (in-viewable-region-horiz vr 63.0)) - (check-true (in-viewable-region-horiz vr 116.0)) - (check-true (in-viewable-region-horiz vr 169.0)) +(let ([vr (viewable-region 0 0 732 685)]) + (check-true (in-viewable-region-horiz vr 10)) + (check-true (in-viewable-region-horiz vr 63.0)) + (check-true (in-viewable-region-horiz vr 116.0)) + (check-true (in-viewable-region-horiz vr 169.0)) (check-true (in-viewable-region-horiz vr 222))) (let ([vr (viewable-region 0 0 732 685)] diff --git a/collects/tests/honu/xml.rkt b/collects/tests/honu/xml.rkt index bdb11f9195..4ae3491795 100644 --- a/collects/tests/honu/xml.rkt +++ b/collects/tests/honu/xml.rkt @@ -14,10 +14,10 @@ (struct xml:object (tag elements)) (begin-for-syntax -(define (debug . x) - (void) - #; - (apply printf x))) + (define (debug . x) + (void) + #; + (apply printf x))) (define (xml->string xml) (match xml diff --git a/collects/tests/match/other-tests.rkt b/collects/tests/match/other-tests.rkt index b10f8c4f50..e96274a965 100644 --- a/collects/tests/match/other-tests.rkt +++ b/collects/tests/match/other-tests.rkt @@ -14,78 +14,76 @@ [(mytest tst exp) (test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) (check set-equal? tst exp))])) - - (define other-tests + + (define other-tests (test-suite "Tests copied from match-test.rkt" -(mytest (letrec ((z - (lambda (x) - (match x - ((a b c) - (if (= a 10) - (list a b c) - (begin (cons a (z (list (add1 a) 2 3)))))))))) - (z '(1 2 3))) - '(1 2 3 4 5 6 7 8 9 10 2 3)) +(mytest (letrec ((z + (lambda (x) + (match x + ((a b c) + (if (= a 10) + (list a b c) + (begin (cons a (z (list (add1 a) 2 3)))))))))) + (z '(1 2 3))) + '(1 2 3 4 5 6 7 8 9 10 2 3)) ; this is the same test for match-lambda -(mytest (letrec ((z - (match-lambda ((a b c) - (if (= a 10) - (list a b c) - (cons a (z (list (add1 a) 2 3)))))))) - (z '(1 2 3))) - '(1 2 3 4 5 6 7 8 9 10 2 3)) +(mytest (letrec ((z (match-lambda ((a b c) + (if (= a 10) + (list a b c) + (cons a (z (list (add1 a) 2 3)))))))) + (z '(1 2 3))) + '(1 2 3 4 5 6 7 8 9 10 2 3)) -(mytest (letrec ((z - (match-lambda* ((a b c) - (if (= a 10) - (list a b c) - (cons a (z (add1 a) 2 3))))))) - (z 1 2 3)) - '(1 2 3 4 5 6 7 8 9 10 2 3)) +(mytest (letrec ((z (match-lambda* ((a b c) + (if (= a 10) + (list a b c) + (cons a (z (add1 a) 2 3))))))) + (z 1 2 3)) + '(1 2 3 4 5 6 7 8 9 10 2 3)) ; matchlet tests (mytest (match-let (((a b c) '(1 2 3)) - ((d e f) '(4 5 6))) - (list a b c d e f)) - '(1 2 3 4 5 6)) + ((d e f) '(4 5 6))) + (list a b c d e f)) + '(1 2 3 4 5 6)) ; match: syntax error in (match (hey (((a b c) (d e f)) (list a b c d e f)))) (mytest (match-let hey (((a b c) '(1 2 3)) - ((d e f) '(4 5 6))) - (list a b c d e f)) - '(1 2 3 4 5 6)) + ((d e f) '(4 5 6))) + (list a b c d e f)) + '(1 2 3 4 5 6)) (mytest (match-let hey (((a b c) '(1 2 3)) - ((d e f) '(4 5 6))) - (if (= a 10) - '() - (cons a (hey (list (add1 a) b c) '(d e f))))) - '(1 2 3 4 5 6 7 8 9)) + ((d e f) '(4 5 6))) + (if (= a 10) + '() + (cons a (hey (list (add1 a) b c) '(d e f))))) + '(1 2 3 4 5 6 7 8 9)) - (mytest (let ((f 7)) - (match-let ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) - '(1 5 7 7)) +(mytest (let ((f 7)) + (match-let ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) + '(1 5 7 7)) ; match-let* (mytest (match-let* (((a b c) '(1 2 3)) - ((d e f) '(4 5 6))) - (list a b c d e f)) - '(1 2 3 4 5 6)) + ((d e f) '(4 5 6))) + (list a b c d e f)) + '(1 2 3 4 5 6)) (mytest (match-let* ([(a b c) '(1 2 3)] - [(d e f) (list a b c)]) - (list d e f)) ; should be (1 2 3) - '(1 2 3)) + [(d e f) (list a b c)]) + (list d e f)) ; should be (1 2 3) + '(1 2 3)) (mytest (let ((f 7)) - (match-let* ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) - '(1 5 7 7)) + (match-let* ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) + '(1 5 7 7)) ; match-letrec ;; let rec does not work this well on chez or plt @@ -95,76 +93,74 @@ ; (list c d)) (mytest (match-letrec (((a b c) '(1 2 3)) - ((d e f) '(4 5 6))) - (list a b c d e f)) - '(1 2 3 4 5 6)) + ((d e f) '(4 5 6))) + (list a b c d e f)) + '(1 2 3 4 5 6)) (mytest (match-letrec ([(a b) (list (lambda (x) (if (zero? x) '() (cons x (a (sub1 x))))) - (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))]) - (a 10)) - '(10 9 8 7 6 5 4 3 2 1)) + (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))]) + (a 10)) + '(10 9 8 7 6 5 4 3 2 1)) (mytest (match-letrec ([(a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))]) - (a 10)) - '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) - (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))) - + (a 10)) + '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) + (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))) + (mytest (let ((f 7)) - (match-letrec ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) - '(1 5 7 7)) + (match-letrec ([(a b c) (list 1 2 f)] [(d e) '(5 6)]) (list a d c f))) + '(1 5 7 7)) ; match-lambda (mytest (let ((f 7)) - ((match-lambda ((a b) (list a b f))) '(4 5))) - '(4 5 7)) + ((match-lambda ((a b) (list a b f))) '(4 5))) + '(4 5 7)) (mytest (let ((f 7)) - ((match-lambda* ((a b) (list a b f))) 4 5)) - '(4 5 7)) + ((match-lambda* ((a b) (list a b f))) 4 5)) + '(4 5 7)) ; match-define (mytest (let ((f 7)) - (match-define (a b c) (list 1 2 f)) - (list a b c f)) - '(1 2 7 7)) + (match-define (a b c) (list 1 2 f)) + (list a b c f)) + '(1 2 7 7)) (test-case "match-define" - (let () (match-define (a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) - (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))) - (check-equal? (a 10) - '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) - (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))))) + (let () (match-define (a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) + (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))) + (check-equal? (a 10) + '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) + (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))))) ; this is some thing that I missed before -(mytest (match '((1) (2) (3)) - (((_) ...) 'hey)) - 'hey) +(mytest (match '((1) (2) (3)) (((_) ...) 'hey)) + 'hey) ; failure tests (mytest (match '(1 2 3) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) - ((a b c) (list a b c))) - '(1 2 3)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (=> fail) (if (= a 1) (fail) 'bad)) + ((a b c) (list a b c))) + '(1 2 3)) -;(mytest (match '(1 2 3) -; ((a b c) (=> fail) (if (= a 1) (fail) 'bad))) -; '()) ; this should through a different exception - +; (mytest (match '(1 2 3) +; ((a b c) (=> fail) (if (= a 1) (fail) 'bad))) +; '()) ; this should through a different exception @@ -173,94 +169,89 @@ ; set! for lists #| (mytest (let ((x '(1 2 (3 4)))) - (match x - ((_ _ ((set! set-it) _)) (set-it 17))) - x) - '(1 2 (17 4))) + (match x + ((_ _ ((set! set-it) _)) (set-it 17))) + x) + '(1 2 (17 4))) (mytest (let ((x '(1 2 (3 4)))) - (match x - ((_ _ (_ (set! set-it))) (set-it 17))) - x) - '(1 2 (3 17))) + (match x + ((_ _ (_ (set! set-it))) (set-it 17))) + x) + '(1 2 (3 17))) (mytest (let ((x '(1 2 (3 4)))) - (match x - (((set! set-it) _ (_ _)) (set-it 17))) - x) - '(17 2 (3 4))) + (match x + (((set! set-it) _ (_ _)) (set-it 17))) + x) + '(17 2 (3 4))) (mytest (let ((x '(1 2 (3 4)))) - (match x - ((_ (set! set-it) (_ _)) (set-it 17))) - x) - '(1 17 (3 4))) + (match x + ((_ (set! set-it) (_ _)) (set-it 17))) + x) + '(1 17 (3 4))) ;set! for improper lists (mytest (let ((x '(1 2 (3 . 4) . 5))) - (match x - (((set! set-it) _ (_ . _) . _) (set-it 17))) - x) - '(17 2 (3 . 4) . 5)) + (match x + (((set! set-it) _ (_ . _) . _) (set-it 17))) + x) + '(17 2 (3 . 4) . 5)) (mytest (let ((x '(1 2 (3 . 4) . 5))) - (match x - ((_ (set! set-it) (_ . _) . _) (set-it 17))) - x) - '(1 17 (3 . 4) . 5)) + (match x + ((_ (set! set-it) (_ . _) . _) (set-it 17))) + x) + '(1 17 (3 . 4) . 5)) (mytest (let ((x '(1 2 (3 . 4) . 5))) - (match x - ((_ _ ((set! set-it) . _) . _) (set-it 17))) - x) - '(1 2 (17 . 4) . 5)) + (match x + ((_ _ ((set! set-it) . _) . _) (set-it 17))) + x) + '(1 2 (17 . 4) . 5)) (mytest (let ((x '(1 2 (3 . 4) . 5))) - (match x - ((_ _ (_ . (set! set-it)) . _) (set-it 17))) - x) - '(1 2 (3 . 17) . 5)) + (match x + ((_ _ (_ . (set! set-it)) . _) (set-it 17))) + x) + '(1 2 (3 . 17) . 5)) (mytest (let ((x '(1 2 (3 . 4) . 5))) - (match x - ((_ _ (_ . _) . (set! set-it)) (set-it 17))) - x) - '(1 2 (3 . 4) . 17)) + (match x + ((_ _ (_ . _) . (set! set-it)) (set-it 17))) + x) + '(1 2 (3 . 4) . 17)) ;; set! for vectors (mytest (let ((x (vector 1 2))) - (match x - (#(_ (set! set-it)) (set-it 17))) - x) - #(1 17)) + (match x (#(_ (set! set-it)) (set-it 17))) + x) + #(1 17)) (mytest (let ((x (vector 1 2))) - (match x - (#((set! set-it) _) (set-it 17))) - x) - #(17 2)) + (match x (#((set! set-it) _) (set-it 17))) + x) + #(17 2)) ;; set! for boxes (mytest (let ((x (box 1))) - (match x - (#&(set! set-it) (set-it 17))) - x) - #&17) + (match x (#&(set! set-it) (set-it 17))) + x) + #&17) #; (mytest (let ((x #&(1 2))) - (match x - (#&(_ (set! set-it)) (set-it 17))) - x) - #&(1 17)) + (match x (#&(_ (set! set-it)) (set-it 17))) + x) + #&(1 17)) (mytest (let ((x (box (vector 1 2)))) - (match x - (#&#(_ (set! set-it)) (set-it 17))) - x) - #&#(1 17)) + (match x (#&#(_ (set! set-it)) (set-it 17))) + x) + #&#(1 17)) ; get! tests @@ -268,133 +259,98 @@ ; get! for lists #| (mytest (let* ((x '(1 2 (3 4))) - (f - (match x - ((_ _ ((get! get-it) _)) get-it)))) - (match x - ((_ _ ((set! set-it) _)) (set-it 17))) - (f)) 17) + (f (match x ((_ _ ((get! get-it) _)) get-it)))) + (match x ((_ _ ((set! set-it) _)) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 4))) - (f - (match x - ((_ _ (_ (get! get-it))) get-it)))) - (match x - ((_ _ (_ (set! set-it))) (set-it 17))) - (f)) 17) + (f (match x ((_ _ (_ (get! get-it))) get-it)))) + (match x ((_ _ (_ (set! set-it))) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 4))) - (f - (match x - (((get! get-it) _ (_ _)) get-it)))) - (match x - (((set! set-it) _ (_ _)) (set-it 17))) - (f)) 17) - + (f (match x (((get! get-it) _ (_ _)) get-it)))) + (match x (((set! set-it) _ (_ _)) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 4))) - (f - (match x - ((_ (get! get-it) (_ _)) get-it)))) - (match x - ((_ (set! set-it) (_ _)) (set-it 17))) - (f)) 17) + (f (match x ((_ (get! get-it) (_ _)) get-it)))) + (match x ((_ (set! set-it) (_ _)) (set-it 17))) + (f)) + 17) ;get! for improper lists (mytest (let* ((x '(1 2 (3 . 4) . 5)) - (f - (match x - (((get! get-it) _ (_ . _) . _) get-it)))) - (match x - (((set! set-it) _ (_ . _) . _) (set-it 17))) - (f)) 17) - + (f (match x (((get! get-it) _ (_ . _) . _) get-it)))) + (match x (((set! set-it) _ (_ . _) . _) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 . 4) . 5)) - (f - (match x - ((_ (get! get-it) (_ . _) . _) get-it)))) - (match x - ((_ (set! set-it) (_ . _) . _) (set-it 17))) - (f)) 17) - + (f (match x ((_ (get! get-it) (_ . _) . _) get-it)))) + (match x ((_ (set! set-it) (_ . _) . _) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 . 4) . 5)) - (f - (match x - ((_ _ ((get! get-it) . _) . _) get-it)))) - (match x - ((_ _ ((set! set-it) . _) . _) (set-it 17))) - (f)) 17) - + (f (match x ((_ _ ((get! get-it) . _) . _) get-it)))) + (match x ((_ _ ((set! set-it) . _) . _) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 . 4) . 5)) - (f - (match x - ((_ _ (_ . (get! get-it)) . _) get-it)))) - (match x - ((_ _ (_ . (set! set-it)) . _) (set-it 17))) - (f)) 17) - + (f (match x ((_ _ (_ . (get! get-it)) . _) get-it)))) + (match x ((_ _ (_ . (set! set-it)) . _) (set-it 17))) + (f)) + 17) (mytest (let* ((x '(1 2 (3 . 4) . 5)) - (f - (match x - ((_ _ (_ . _) . (get! get-it)) get-it)))) - (match x - ((_ _ (_ . _) . (set! set-it)) (set-it 17))) - (f)) 17) + (f (match x ((_ _ (_ . _) . (get! get-it)) get-it)))) + (match x ((_ _ (_ . _) . (set! set-it)) (set-it 17))) + (f)) + 17) |# ;; get! for vectors (mytest (let* ((x (vector 1 2)) - (f - (match x - (#(_ (get! get-it)) get-it)))) - (match x - (#(_ (set! set-it)) (set-it 17))) - (f)) 17) - + (f (match x (#(_ (get! get-it)) get-it)))) + (match x (#(_ (set! set-it)) (set-it 17))) + (f)) + 17) (mytest (let* ((x (vector 1 2)) - (f - (match x - (#((get! get-it) _) get-it)))) - (match x - (#((set! set-it) _) (set-it 17))) - (f)) 17) + (f (match x (#((get! get-it) _) get-it)))) + (match x (#((set! set-it) _) (set-it 17))) + (f)) + 17) ;; get! for boxes (mytest (let* ((x (box 1)) - (f - (match x - (#&(get! get-it) get-it)))) - (match x - (#&(set! set-it) (set-it 17))) - (f)) 17) + (f (match x (#&(get! get-it) get-it)))) + (match x (#&(set! set-it) (set-it 17))) + (f)) + 17) #; (mytest (let* ((x #&(1 2)) - (f - (match x - (#&(_ (get! get-it)) get-it)))) - (match x - (#&(_ (set! set-it)) (set-it 17))) - (f)) 17) - + (f (match x (#&(_ (get! get-it)) get-it)))) + (match x (#&(_ (set! set-it)) (set-it 17))) + (f)) + 17) (mytest (let* ((x (box (vector 1 2))) - (f - (match x - (#&#(_ (get! get-it)) get-it)))) - (match x - (#&#(_ (set! set-it)) (set-it 17))) - (f)) 17) + (f (match x (#&#(_ (get! get-it)) get-it)))) + (match x (#&#(_ (set! set-it)) (set-it 17))) + (f)) + 17) |# @@ -402,428 +358,295 @@ (mytest (match '(1 2 3 4 . b) - (`(,b 2 ,@(3 4) . b) b)) - 1) + (`(,b 2 ,@(3 4) . b) b)) + 1) (mytest (match '(1 2 3 4 . 5) - (`(1 2 ,@(3 4) . ,b) b)) - 5) - + (`(1 2 ,@(3 4) . ,b) b)) + 5) + (mytest (match '(a ()) (`(a ()) #t)) #t) (mytest (match '(1 2 3) - (`(,a ,b ,c) (list a b c))) + (`(,a ,b ,c) (list a b c))) '(1 2 3)) -(mytest (match '(c a b 1 2 3 r f i) - (`(c a b ,@(a b c) r f i) (list a b c))) - '(1 2 3)) +(mytest (match '(c a b 1 2 3 r f i) + (`(c a b ,@(a b c) r f i) (list a b c))) + '(1 2 3)) (mytest (match '(3 4 #\c a b 1 (2 (c d))) - (`(3 4 #\c a b ,a ,(b `(c e))) 'not-good) - (`(3 4 #\c a b ,a ,(b `(c d))) (list a b))) - '(1 2)) + (`(3 4 #\c a b ,a ,(b `(c e))) 'not-good) + (`(3 4 #\c a b ,a ,(b `(c d))) (list a b))) + '(1 2)) (mytest (match #(x 2 x) - (`#(x ,x x) (list x))) - '(2)) + (`#(x ,x x) (list x))) + '(2)) (mytest (match #(x 2 x) ;remember that the x's are symbols here - (`#(x ,x x) (list x))) - '(2)) + (`#(x ,x x) (list x))) + '(2)) -(mytest (match #(c a b 1 2 3 r f i) - (`#(c a b ,@(a b c) r f i) (list a b c))) - '(1 2 3)) +(mytest (match #(c a b 1 2 3 r f i) + (`#(c a b ,@(a b c) r f i) (list a b c))) + '(1 2 3)) -(mytest (match #&(c a b 1 2 3 r f i) - (`#&(c a b ,@(a b c) r f i) (list a b c))) - '(1 2 3)) +(mytest (match #&(c a b 1 2 3 r f i) + (`#&(c a b ,@(a b c) r f i) (list a b c))) + '(1 2 3)) -(mytest (match (list - "hi" - 1 - 'there - #\c - #t - #f - '(a b c) - '(a b . c) - '(a b c c c c) - #(a b c) - #(a b c c c c) - #&(a b c) - '(1 2 3) - '(4 5 . 6) - '(7 8 9) - #(10 11 12) - #&(13 14 15 16) - 1 - 2 - 3 - 4 - 17 - ) - (`( - "hi" - 1 - there - #\c - #t - #f - (a b c) - (a b . c) - (a b c ..2) - #(a b c) - #(a b c ..2) - #&(a b c) - ,(a b c) - ,(c1 d . e) - ,(f g h ...) - ,#(i j k) - ,#&(l m n o) - ,@(1 2 3 4 p) - ) - (list - a b c - c1 d e - f g h - i j k - l m n o - p - ))) -'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) +(mytest (match (list "hi" 1 'there #\c #t #f '(a b c) '(a b . c) + '(a b c c c c) #(a b c) #(a b c c c c) #&(a b c) + '(1 2 3) '(4 5 . 6) '(7 8 9) #(10 11 12) #&(13 14 15 16) + 1 2 3 4 17) + (`("hi" 1 there #\c #t #f (a b c) (a b . c) (a b c ..2) #(a b c) + #(a b c ..2) #&(a b c) ,(a b c) ,(c1 d . e) ,(f g h ...) + ,#(i j k) ,#&(l m n o) ,@(1 2 3 4 p)) + (list a b c c1 d e f g h i j k l m n o p))) + '(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) -(mytest (match (vector - "hi" - 1 - 'there - #\c - #t - #f - '(a b c) - '(a b . c) - '(a b c c c c) - #(a b c) - #(a b c c c c) - #&(a b c) - '(1 2 3) - '(4 5 . 6) - '(7 8 9) - #(10 11 12) - #&(13 14 15 16) - 1 - 2 - 3 - 4 - 17 - ) - (`#( - "hi" - 1 - there - #\c - #t - #f - (a b c) - (a b . c) - (a b c ..2) - #(a b c) - #(a b c ..2) - #&(a b c) - ,(a b c) - ,(c1 d . e) - ,(f g h ...) - ,#(i j k) - ,#&(l m n o) - ,@(1 2 3 4 p) - ) - (list - a b c - c1 d e - f g h - i j k - l m n o - p - ))) -'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) +(mytest (match (vector "hi" 1 'there #\c #t #f '(a b c) '(a b . c) + '(a b c c c c) #(a b c) #(a b c c c c) #&(a b c) + '(1 2 3) '(4 5 . 6) '(7 8 9) #(10 11 12) + #&(13 14 15 16) 1 2 3 4 17) + (`#("hi" 1 there #\c #t #f (a b c) (a b . c) (a b c ..2) #(a b c) + #(a b c ..2) #&(a b c) ,(a b c) ,(c1 d . e) ,(f g h ...) + ,#(i j k) ,#&(l m n o) ,@(1 2 3 4 p)) + (list a b c c1 d e f g h i j k l m n o p))) + '(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) -(mytest (match (box (list - "hi" - 1 - 'there - #\c - #t - #f - '(a b c) - '(a b . c) - '(a b c c c c) - #(a b c) - #(a b c c c c) - #&(a b c) - '(1 2 3) - '(4 5 . 6) - '(7 8 9) - #(10 11 12) - #&(13 14 15 16) - 1 - 2 - 3 - 4 - 17 - )) - (`#&( - "hi" - 1 - there - #\c - #t - #f - (a b c) - (a b . c) - (a b c ..2) - #(a b c) - #(a b c ..2) - #&(a b c) - ,(a b c) - ,(c1 d . e) - ,(f g h ...) - ,#(i j k) - ,#&(l m n o) - ,@(1 2 3 4 p) - ) - (list - a b c - c1 d e - f g h - i j k - l m n o - p - ))) -'(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) +(mytest (match (box (list "hi" 1 'there #\c #t #f '(a b c) '(a b . c) + '(a b c c c c) #(a b c) #(a b c c c c) #&(a b c) + '(1 2 3) '(4 5 . 6) '(7 8 9) #(10 11 12) + #&(13 14 15 16) 1 2 3 4 17)) + (`#&("hi" 1 there #\c #t #f (a b c) (a b . c) (a b c ..2) #(a b c) + #(a b c ..2) #&(a b c) ,(a b c) ,(c1 d . e) ,(f g h ...) + ,#(i j k) ,#&(l m n o) ,@(1 2 3 4 p)) + (list a b c c1 d e f g h i j k l m n o p))) + '(1 2 3 4 5 6 7 8 (9) 10 11 12 13 14 15 16 17)) (mytest (match '(1 2 3 4) - (`(,@`(,x ,y) ,@`(,a ,b)) (list x y a b))) - '(1 2 3 4)) + (`(,@`(,x ,y) ,@`(,a ,b)) (list x y a b))) + '(1 2 3 4)) -;; deep nesting +;; deep nesting (mytest (match #(#(#(1 2 3) #(1 2 3) #(2 3 4)) #(#(1 2 3) #(1 2 3) #(2 3 4))) - (#(#(#(a ...) ...) ...) a)) - '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))) + (#(#(#(a ...) ...) ...) a)) + '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))) (mytest (match '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4))) - ((((a ...) ...) ...) a)) - '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))) + ((((a ...) ...) ...) a)) + '(((1 2 3) (1 2 3) (2 3 4)) ((1 2 3) (1 2 3) (2 3 4)))) (mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) - (((((((a ...) ...) ...) ...) ...) ...) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) + (((((((a ...) ...) ...) ...) ...) ...) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + + +(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) + #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) + (#(#(#(#(#(#(a ...) ...) ...) ...) ...) ...) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + +(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) + #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) + ((#((#((#(a ...) ...) ...) ...) ...) ...) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + +(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) + (((((((a ..2) ..2) ..2) ..2) ..2) ..2) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) (mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) - #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) - (#(#(#(#(#(#(a ...) ...) ...) ...) ...) ...) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) + #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) + (#(#(#(#(#(#(a ..2) ..2) ..2) ..2) ..2) ..2) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) (mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) - #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) - ((#((#((#(a ...) ...) ...) ...) ...) ...) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) - -(mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) - (((((((a ..2) ..2) ..2) ..2) ..2) ..2) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) - - - -(mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) - #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) - (#(#(#(#(#(#(a ..2) ..2) ..2) ..2) ..2) ..2) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) - -(mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) - #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) - ((#((#((#(a ..2) ..2) ..2) ..2) ..2) ..2) a)) - '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) + #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) + ((#((#((#(a ..2) ..2) ..2) ..2) ..2) ..2) a)) + '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))))) (mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) - (((((((_ ...) ...) ...) ...) ...) ...) #t) - (_ #f)) - #t) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) + (((((((_ ...) ...) ...) ...) ...) ...) #t) + (_ #f)) + #t) (mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) - #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) - (#(#(#(#(#(#(_ ...) ...) ...) ...) ...) ...) #t) - (_ #f)) - #t) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) + #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) + (#(#(#(#(#(#(_ ...) ...) ...) ...) ...) ...) #t) + (_ #f)) + #t) (mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) - #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) - ((#((#((#(_ ...) ...) ...) ...) ...) ...) #t) - (_ #f)) - #t) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) + #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) + ((#((#((#(_ ...) ...) ...) ...) ...) ...) #t) + (_ #f)) + #t) (mytest (match '((((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) - (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) - ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) - (((((((a b) ...) ...) ...) ...) ...) (list a b))) - '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) - (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8))))) + (((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))) + ((((1 2) (3 4)) ((5 6) (7 8))) (((1 2) (3 4)) ((5 6) (7 8)))))) + (((((((a b) ...) ...) ...) ...) ...) (list a b))) + '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) + (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) (mytest (match #(#(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) - #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) - #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) + #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))))) + #(#(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))) #(#(#(#(1 2) #(3 4)) #(#(5 6) #(7 8))) #(#(#(1 2) #(3 4)) #(#(5 6) #(7 8)))))) - (#(#(#(#(#(#(a b) ...) ...) ...) ...) ...) (list a b))) - '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) - (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) + (#(#(#(#(#(#(a b) ...) ...) ...) ...) ...) (list a b))) + '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) + (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) (mytest (match '(#((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) - #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) - (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) - ((#((#((#(a b) ...) ...) ...) ...) ...) (list a b))) - '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) - (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8))))) + #((#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))) + (#((#(1 2) #(3 4)) (#(5 6) #(7 8))) #((#(1 2) #(3 4)) (#(5 6) #(7 8)))))) + ((#((#((#(a b) ...) ...) ...) ...) ...) (list a b))) + '((((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7)))) ((((1 3) (5 7)) ((1 3) (5 7))) (((1 3) (5 7)) ((1 3) (5 7))))) + (((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8)))) ((((2 4) (6 8)) ((2 4) (6 8))) (((2 4) (6 8)) ((2 4) (6 8))))))) ;the new var pattern -; this allows one to use +; this allows one to use ; var, $, =, and, or, not, ?, set!, or get! ; as pattern variables ; (mytest (match '(1 2 3) -; (((var $) b c) (list $ b c))) -; '(1 2 3)) +; (((var $) b c) (list $ b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var var) b c) (list var b c))) -; '(1 2 3)) +; (((var var) b c) (list var b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var =) b c) (list = b c))) -; '(1 2 3)) +; (((var =) b c) (list = b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var and) b c) (list and b c))) -; '(1 2 3)) +; (((var and) b c) (list and b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var or) b c) (list or b c))) -; '(1 2 3)) +; (((var or) b c) (list or b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var not) b c) (list not b c))) -; '(1 2 3)) +; (((var not) b c) (list not b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var ?) b c) (list ? b c))) -; '(1 2 3)) +; (((var ?) b c) (list ? b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var set!) b c) (list set! b c))) -; '(1 2 3)) +; (((var set!) b c) (list set! b c))) +; '(1 2 3)) ; (mytest (match '(1 2 3) -; (((var get!) b c) (list get! b c))) -; '(1 2 3)) +; (((var get!) b c) (list get! b c))) +; '(1 2 3)) (mytest (match '((1 1 2 2) (1 1 2 2) 5 5 5) - (((1 ... a ...) ... 7 ...) #f) - (((1 ... a ...) ... 6 ...) #f) - (((1 ... a ...) ... 5 ...) a)) - '((2 2) (2 2))) + (((1 ... a ...) ... 7 ...) #f) + (((1 ... a ...) ... 6 ...) #f) + (((1 ... a ...) ... 5 ...) a)) + '((2 2) (2 2))) (mytest (match '(1 1 1 1 1 2 2 2 2) - ((1 ... 2 2 2 2) #t)) - #t) + ((1 ... 2 2 2 2) #t)) + #t) (mytest (match '(1 1 1 1 1 2 2 2 2) - ((1 ... 2 ...) #t)) - #t) + ((1 ... 2 ...) #t)) + #t) (mytest (match '(1 1 1 1 1 2 2 2 2) - (((and (not 2) a) ... 2 ...) a)) - '(1 1 1 1 1)) + (((and (not 2) a) ... 2 ...) a)) + '(1 1 1 1 1)) (mytest (match '(1 1 1 1 1 2 2 2 2) - ((a ... 2 ...) a)) - '(1 1 1 1 1 2 2 2 2)) + ((a ... 2 ...) a)) + '(1 1 1 1 1 2 2 2 2)) (mytest (match '(1 1 1 1 1 2 2 2 2) - ((_ ... 2 ...) #t)) - #t) + ((_ ... 2 ...) #t)) + #t) (mytest (match '(pattern matching in scheme is very cool) - (((and (not 'in) a) ... (and (not 'is) b) ... c ...) (list a c b))) - '((pattern matching) (is very cool) (in scheme))) + (((and (not 'in) a) ... (and (not 'is) b) ... c ...) (list a c b))) + '((pattern matching) (is very cool) (in scheme))) (mytest (match '((1 1 2 2) (1 1 2 2) 5 5 5) - (((1 ... 2 ...) ... 5 ...) #t)) - #t) + (((1 ... 2 ...) ... 5 ...) #t)) + #t) (mytest (match #(1 3 1 9 8 4 2 2 4 7 a b c) (#((and (? odd?) a) ... 8 (and (? even?) b) ... 7 r ...) (list a b r))) - '((1 3 1 9) (4 2 2 4) (a b c))) + '((1 3 1 9) (4 2 2 4) (a b c))) (mytest (match #(#(1 1 2 2) #(1 1 2 2) 5 5 5) - (#(#(1 ... 2 ...) ... 5 ...) #t)) - #t) + (#(#(1 ... 2 ...) ... 5 ...) #t)) + #t) (mytest (match #(#(1 1 2 2) #(1 1 2 2) 5 5 5) - (#(#(1 ... a ...) ... 7 ...) #f) - (#(#(1 ... a ...) ... 6 ...) #f) - (#(#(1 ... a ...) ... 5 ...) a)) - '((2 2) (2 2))) + (#(#(1 ... a ...) ... 7 ...) #f) + (#(#(1 ... a ...) ... 6 ...) #f) + (#(#(1 ... a ...) ... 5 ...) a)) + '((2 2) (2 2))) (mytest (match #(#(1 2) #(1 2) #(1 2) 5 6) [#(#(_ _) ..3 a ...) a]) - '(5 6)) + '(5 6)) ; should not work ; (match x ((... ...) #t)) @@ -832,6 +655,6 @@ ; (match x ((pat ... ... pat) #t)) (mytest (match #(1 2 3 4 5) (#(a b (and c (not 5)) ... d) (list a b c d))) - '(1 2 (3 4) 5)) + '(1 2 (3 4) 5)) ))) diff --git a/collects/tests/plai/gc/good-mutators/bindings.rkt b/collects/tests/plai/gc/good-mutators/bindings.rkt index 96c4e6224b..5b1c5aa41e 100644 --- a/collects/tests/plai/gc/good-mutators/bindings.rkt +++ b/collects/tests/plai/gc/good-mutators/bindings.rkt @@ -8,9 +8,9 @@ (define y (let ([outer-local - (let ([inner-local 'value-expected]) - inner-local)]) - outer-local)) + (let ([inner-local 'value-expected]) + inner-local)]) + outer-local)) (test/value=? y 'value-expected) diff --git a/collects/tests/plai/gc2/good-mutators/bindings.rkt b/collects/tests/plai/gc2/good-mutators/bindings.rkt index 164f830d98..3f9c32ebd5 100644 --- a/collects/tests/plai/gc2/good-mutators/bindings.rkt +++ b/collects/tests/plai/gc2/good-mutators/bindings.rkt @@ -8,9 +8,9 @@ (define y (let ([outer-local - (let ([inner-local 'value-expected]) - inner-local)]) - outer-local)) + (let ([inner-local 'value-expected]) + inner-local)]) + outer-local)) (test/value=? y 'value-expected) diff --git a/collects/tests/racket/benchmarks/places/place-channel.rkt b/collects/tests/racket/benchmarks/places/place-channel.rkt index 995eabd736..9fd3cfa0b1 100644 --- a/collects/tests/racket/benchmarks/places/place-channel.rkt +++ b/collects/tests/racket/benchmarks/places/place-channel.rkt @@ -11,28 +11,31 @@ (fprintf out "~a" txt)))) (define (print-out msg B/sE) - (displayln (list msg - (exact->inexact B/sE) 'bytes-per-second - (exact->inexact (/ B/sE (* 1024 1024))) 'MB-per-second))) + (displayln + (list msg + (exact->inexact B/sE) 'bytes-per-second + (exact->inexact (/ B/sE (* 1024 1024))) + 'MB-per-second))) (define (processes-byte-message-test) - (let ([pl - (pp:place/base (bo ch) - (define message-size (* 4024 1024)) - (define count 10) - (define fourk-b-message (make-bytes message-size 66)) - (for ([i (in-range count)]) - (place-channel-get ch) - (place-channel-put ch fourk-b-message)))]) + (let ([pl (pp:place/base + (bo ch) + (define message-size (* 4024 1024)) + (define count 10) + (define fourk-b-message (make-bytes message-size 66)) + (for ([i (in-range count)]) + (place-channel-get ch) + (place-channel-put ch fourk-b-message)))]) (define message-size (* 4024 1024)) (define four-k-message (make-bytes message-size 65)) (define count 10) (define-values (r t1 t2 t3) - (time-apply (lambda () - (for ([i (in-range count)]) - (pp:place-channel-put pl four-k-message) - (pp:place-channel-get pl))) null)) + (time-apply + (lambda () + (for ([i (in-range count)]) + (pp:place-channel-put pl four-k-message) + (pp:place-channel-get pl))) null)) (print-out "processes-emulated-places" (/ (* 2 count message-size) (/ t2 1000))) @@ -62,10 +65,11 @@ END (define four-k-message (make-bytes message-size 65)) (define count 150) (define-values (r t1 t2 t3) - (time-apply (lambda () - (for ([i (in-range count)]) - (place-channel-put pl four-k-message) - (place-channel-get pl))) null)) + (time-apply + (lambda () + (for ([i (in-range count)]) + (place-channel-put pl four-k-message) + (place-channel-get pl))) null)) (print-out "places" (/ (* 2 count message-size) (/ t2 1000))) @@ -87,16 +91,18 @@ END "pct1.rkt") (let ([pl (dynamic-place "pct1.rkt" 'place-main)]) - (define tree (let loop ([depth 8]) - (if (depth . <= . 0) - 1 - (cons (loop (sub1 depth)) (loop (sub1 depth)))))) + (define tree + (let loop ([depth 8]) + (if (depth . <= . 0) + 1 + (cons (loop (sub1 depth)) (loop (sub1 depth)))))) (define count 500) (define-values (r t1 t2 t3) - (time-apply (lambda () - (for ([i (in-range count)]) - (place-channel-put pl tree) - (place-channel-get pl))) null)) + (time-apply + (lambda () + (for ([i (in-range count)]) + (place-channel-put pl tree) + (place-channel-get pl))) null)) (define s (* (- (expt 2 9) 1) 4 8 count)) (printf "cons-tree ~a ~a ~a ~a\n" t1 t2 t3 (exact->inexact (/ t2 1000))) diff --git a/collects/tests/racket/benchmarks/places/place-processes.rkt b/collects/tests/racket/benchmarks/places/place-processes.rkt index 1d2f0c3a50..00ff5a08d5 100644 --- a/collects/tests/racket/benchmarks/places/place-processes.rkt +++ b/collects/tests/racket/benchmarks/places/place-processes.rkt @@ -164,14 +164,17 @@ (syntax-case stx () [(_ lst (name listvar) body ...) #'(begin - (define places (for/list ([i (in-range (processor-count))]) - (place/lambda (name ch) - (place-channel-put ch ((lambda (listvar) body ...) (place-channel-get ch)))))) + (define places + (for/list ([i (in-range (processor-count))]) + (place/lambda (name ch) + (place-channel-put ch + ((lambda (listvar) body ...) + (place-channel-get ch)))))) - (for ([p places] - [item (split-n (processor-count) lst)]) - (place-channel-put p item)) - (define result ((lambda (listvar) body ...) (map place-channel-get places))) - (map place-wait places) - (map place-kill places) - result)])) + (for ([p places] + [item (split-n (processor-count) lst)]) + (place-channel-put p item)) + (define result ((lambda (listvar) body ...) (map place-channel-get places))) + (map place-wait places) + (map place-kill places) + result)])) diff --git a/collects/tests/racket/benchmarks/places/place-utils.rkt b/collects/tests/racket/benchmarks/places/place-utils.rkt index b4a5412972..230856bc42 100644 --- a/collects/tests/racket/benchmarks/places/place-utils.rkt +++ b/collects/tests/racket/benchmarks/places/place-utils.rkt @@ -63,11 +63,8 @@ (define-syntax (time-n stx) (syntax-case stx () [(_ msg cnt body ...) - #'(let-values ([(r ct rt gct) (time-apply - (lambda () - body ... - ) - null)]) + #'(let-values ([(r ct rt gct) + (time-apply (lambda () body ...) null)]) (displayln (list msg cnt ct rt gct)) (if (pair? r) (car r) r)) #| diff --git a/collects/tests/racket/contract-helpers.rkt b/collects/tests/racket/contract-helpers.rkt index 9a36b5c9b1..a30c8479ac 100644 --- a/collects/tests/racket/contract-helpers.rkt +++ b/collects/tests/racket/contract-helpers.rkt @@ -10,33 +10,30 @@ (check-equal? (matches-arity-exactly? (λ (x y) x) 2 3 '() '()) #f) (check-equal? (matches-arity-exactly? (λ (x y) x) 3 #f '() '()) #f) -(check-equal? (matches-arity-exactly? (case-lambda - [() 1] - [(x) 2]) - 0 1 '() '()) #t) -(check-equal? (matches-arity-exactly? (case-lambda - [() 1] - [(x) 2]) - 0 2 '() '()) #f) -(check-equal? (matches-arity-exactly? (case-lambda - [() 1] - [(x y) 2]) - 0 2 '() '()) #f) -(check-equal? (matches-arity-exactly? (case-lambda - [() 1] - [(x y) 2]) - 0 1 '() '()) #f) -(check-equal? (matches-arity-exactly? (case-lambda - [() 1] - [(x y) 2]) - 0 #f '() '()) #f) +(check-equal? (matches-arity-exactly? (case-lambda [() 1] [(x) 2]) + 0 1 '() '()) + #t) +(check-equal? (matches-arity-exactly? (case-lambda [() 1] [(x) 2]) + 0 2 '() '()) + #f) +(check-equal? (matches-arity-exactly? (case-lambda [() 1] [(x y) 2]) + 0 2 '() '()) + #f) +(check-equal? (matches-arity-exactly? (case-lambda [() 1] [(x y) 2]) + 0 1 '() '()) + #f) +(check-equal? (matches-arity-exactly? (case-lambda [() 1] [(x y) 2]) + 0 #f '() '()) + #f) (check-equal? (matches-arity-exactly? (lambda (x . y) x) - 1 #f '() '()) #t) + 1 #f '() '()) + #t) (check-equal? (matches-arity-exactly? (lambda (x . y) x) - 0 #f '() '()) #f) + 0 #f '() '()) + #f) (check-equal? (matches-arity-exactly? (lambda (x #:y y) y) - 1 1 '(#:y) '()) + 1 1 '(#:y) '()) #t) (check-equal? (matches-arity-exactly? (lambda (x #:y y #:z z) y) 1 1 '(#:y #:z) '()) @@ -68,4 +65,3 @@ (check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y) 1 1 '() '(#:y #:z)) #f) - diff --git a/collects/tests/racket/place-channel-fd.rkt b/collects/tests/racket/place-channel-fd.rkt index 3ca9bbd9ea..6762737848 100644 --- a/collects/tests/racket/place-channel-fd.rkt +++ b/collects/tests/racket/place-channel-fd.rkt @@ -64,8 +64,9 @@ (write-string "Hello\n" o) (close-output-port o) - (with-input-from-file "test1" (lambda () - (check-equal? (port->string) "Hello\nBye\nHello\n" "output file contents match"))) + (with-input-from-file "test1" + (lambda () + (check-equal? (port->string) "Hello\nBye\nHello\n" "output file contents match"))) (define o2 (open-output-file "test1" #:exists 'replace)) (define l (make-list 1024 1)) @@ -76,8 +77,9 @@ (write-string "HELLO\n" o2) (close-output-port o2) - (with-input-from-file "test1" (lambda () - (check-equal? (port->string) "HELLO\nBYE\nHELLO\n" "output file contents match"))) + (with-input-from-file "test1" + (lambda () + (check-equal? (port->string) "HELLO\nBYE\nHELLO\n" "output file contents match"))) (define i2 (open-input-file "test2")) (place-channel-put p (cons i2 l)) diff --git a/collects/tests/racket/place-channel.rkt b/collects/tests/racket/place-channel.rkt index 6ce2a7edb2..24995b2fdb 100644 --- a/collects/tests/racket/place-channel.rkt +++ b/collects/tests/racket/place-channel.rkt @@ -22,15 +22,15 @@ (define-syntax (normal-receiver stx) (syntax-case stx () - [(_ ch x body ...) + [(_ ch x body ...) #'(let ([x (place-channel-get ch)]) - (place-channel-put ch (begin body ...)))])) + (place-channel-put ch (begin body ...)))])) (define-syntax (big-receiver stx) (syntax-case stx () - [(_ ch x body ...) + [(_ ch x body ...) #'(let ([x (car (place-channel-get ch))]) - (place-channel-put ch (cons (begin body ...) big)))])) + (place-channel-put ch (cons (begin body ...) big)))])) (define (test expect fun . args) (printf "~s ==> " (cons fun args)) diff --git a/collects/tests/stepper/test-cases.rkt b/collects/tests/stepper/test-cases.rkt index 3a80298171..9e1014d0d4 100644 --- a/collects/tests/stepper/test-cases.rkt +++ b/collects/tests/stepper/test-cases.rkt @@ -59,7 +59,7 @@ ;; * a `finished-stepping' is added if no error was specified ;; * a `{...}' is replaced with `(hilite ...)' - (t 'mz1 m:mz +(t 'mz1 m:mz (for-each (lambda (x) x) '(1 2 3)) :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) :: ... -> (... {2} ...) @@ -1119,18 +1119,18 @@ (9 false (check-expect (hilite 2) 2))))) (let ([errmsg "rest: expected argument of type ; given ()"]) - (t1 'check-error - m:upto-int/lam - "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) - (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) - (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) - (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) - (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) - (9 true (check-expect (hilite 4) 4)))))) - + (t1 'check-error + m:upto-int/lam + "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) + (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) + (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) + (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) + (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) + (9 true (check-expect (hilite 4) 4)))))) + (t1 'check-error-bad m:upto-int/lam "(check-error (+ (+ 3 4) (rest empty)) (string-append \"b\" \"ogus\")) (check-expect (+ 3 1) 4) (+ 4 5)" diff --git a/collects/tests/typed-racket/fail/pr10350.rkt b/collects/tests/typed-racket/fail/pr10350.rkt index c444677d8b..24731daef8 100644 --- a/collects/tests/typed-racket/fail/pr10350.rkt +++ b/collects/tests/typed-racket/fail/pr10350.rkt @@ -1,7 +1,7 @@ #lang typed-scheme (require/typed -scheme/base -[values (All (T) ((Any -> Boolean) -> (Any -> Boolean : T)))]) + scheme/base + [values (All (T) ((Any -> Boolean) -> (Any -> Boolean : T)))]) (: number->string? (Any -> Boolean : (Number -> String))) (define (number->string? x) diff --git a/collects/tests/typed-racket/fail/require-typed-missing.rkt b/collects/tests/typed-racket/fail/require-typed-missing.rkt index a32f067838..896cd5d8c7 100644 --- a/collects/tests/typed-racket/fail/require-typed-missing.rkt +++ b/collects/tests/typed-racket/fail/require-typed-missing.rkt @@ -4,13 +4,13 @@ (require/typed (make-main (([Listof Node] [Listof Edge] -> Graph) - (State Number Number MouseEvent -> State) - (State KeyEvent -> State) - (State -> Scene) - (Any -> Boolean) - (State -> Boolean) - (Stop -> Graph) - (Any -> Edge) - (Edge -> Graph) - -> - (Boolean -> Graph)))) + (State Number Number MouseEvent -> State) + (State KeyEvent -> State) + (State -> Scene) + (Any -> Boolean) + (State -> Boolean) + (Stop -> Graph) + (Any -> Edge) + (Edge -> Graph) + -> + (Boolean -> Graph)))) diff --git a/collects/tests/typed-racket/fail/subtype-int-err.rkt b/collects/tests/typed-racket/fail/subtype-int-err.rkt index c641c5efc0..97422ead0f 100644 --- a/collects/tests/typed-racket/fail/subtype-int-err.rkt +++ b/collects/tests/typed-racket/fail/subtype-int-err.rkt @@ -3,20 +3,20 @@ #lang typed/scheme/base (: gen-lambda-n-rest ((Any -> Any) - -> (Any -> (Any Any Any Any * -> Any)))) + -> (Any -> (Any Any Any Any * -> Any)))) (define (gen-lambda-n-rest body) - (error 'fail)) + (error 'fail)) (: gen-lambda (Integer Any -> (Any -> (Any * -> Any)))) (define (gen-lambda nb-vars body) - (case nb-vars - ((3) (gen-lambda-3 body)) - (else (gen-lambda-n nb-vars body)))) + (case nb-vars + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) (: gen-lambda-3 (Any -> (Any -> (Any Any Any -> Any)))) (define (gen-lambda-3 body) - (error 'fail)) + (error 'fail)) (: gen-lambda-n (Integer Any -> (Any -> (Any Any Any Any * -> Any)))) (define (gen-lambda-n nb-vars body) - (error 'fail)) + (error 'fail)) diff --git a/collects/tests/typed-racket/main.rkt b/collects/tests/typed-racket/main.rkt index 121c089485..906ead4d11 100644 --- a/collects/tests/typed-racket/main.rkt +++ b/collects/tests/typed-racket/main.rkt @@ -74,7 +74,7 @@ (when (verbose?) (log-warning (format "TR tests: waiting for ~a ~a" dir p))) (force prm)))))) - (make-test-suite dir tests))) + (make-test-suite dir tests))) (define succ-tests (mk-tests "succeed" (lambda (p thnk) diff --git a/collects/tests/typed-racket/succeed/exceptions.rkt b/collects/tests/typed-racket/succeed/exceptions.rkt index 562c508a13..797945ff48 100644 --- a/collects/tests/typed-racket/succeed/exceptions.rkt +++ b/collects/tests/typed-racket/succeed/exceptions.rkt @@ -8,8 +8,8 @@ (syntax-case stx () ((_ body ...) #'(call/cc (lambda: ((k : (Any -> Nothing))) - (parameterize ((abort k)) - body ...)))))) + (parameterize ((abort k)) + body ...)))))) (call-with-exception-handler (lambda (v) (displayln v) ((abort) v)) diff --git a/collects/tests/typed-racket/succeed/foldo.rkt b/collects/tests/typed-racket/succeed/foldo.rkt index 9450b9d421..37040f6b78 100644 --- a/collects/tests/typed-racket/succeed/foldo.rkt +++ b/collects/tests/typed-racket/succeed/foldo.rkt @@ -14,11 +14,11 @@ (syntax-case stx () [(_ name path ...) (with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))]) - #`(define (name p ) - (let* ([dirnames (map path->string (explode-path p))]) - (match (reverse dirnames) ; goofy backwards matching because ... matches greedily - match-clause ... - [_ #f]))))])) + #`(define (name p ) + (let* ([dirnames (map path->string (explode-path p))]) + (match (reverse dirnames) ; goofy backwards matching because ... matches greedily + match-clause ... + [_ #f]))))])) (define-excluder default-excluder "compiled" ".git") diff --git a/collects/tests/typed-racket/succeed/for-seq.rkt b/collects/tests/typed-racket/succeed/for-seq.rkt index a5e11beab7..c0536e5b53 100644 --- a/collects/tests/typed-racket/succeed/for-seq.rkt +++ b/collects/tests/typed-racket/succeed/for-seq.rkt @@ -6,7 +6,7 @@ (display i))) (for: : Void ((i : Integer (ann '(1 2 3) (Sequenceof Integer))) ; doesn't - (j : Char "abc")) + (j : Char "abc")) (display (list i j))) diff --git a/collects/tests/typed-racket/succeed/for-vector.rkt b/collects/tests/typed-racket/succeed/for-vector.rkt index d1081c3eb3..5a1741aa5b 100644 --- a/collects/tests/typed-racket/succeed/for-vector.rkt +++ b/collects/tests/typed-racket/succeed/for-vector.rkt @@ -194,44 +194,44 @@ (flvector)) (test-flvector (for/flvector: #:length 4 ([x (in-range 2)] - #:when #t - [y (in-range 2)]) + #:when #t + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 1.0 2.0)) (test-flvector (for/flvector: #:length 4 ([x (in-range 0)] - #:when #t - [y (in-range 2)]) + #:when #t + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 0.0 0.0 0.0)) (test-flvector (for/flvector: #:length 4 ([x (in-range 2)] - #:when #t - [y (in-range 1)]) + #:when #t + [y (in-range 1)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 0.0 0.0)) (test-flvector (for/flvector: #:length 4 ([x (in-range 2)] - #:when #t - [y (in-range 3)]) + #:when #t + [y (in-range 3)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 2.0 1.0)) (test-flvector (for/flvector: #:length 0 ([x (in-range 2)] - #:when #t - [y (in-range 3)]) + #:when #t + [y (in-range 3)]) (real->double-flonum (+ x y))) (flvector)) (test-flvector (for/flvector: ([x (in-range 2)] - #:when #t - [y (in-range 2)]) + #:when #t + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 1.0 2.0)) (test-flvector (for/flvector: ([x (in-range 0)] - #:when #t - [y (in-range 2)]) + #:when #t + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector)) @@ -274,36 +274,36 @@ (flvector)) (test-flvector (for*/flvector: #:length 4 ([x (in-range 2)] - [y (in-range 2)]) + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 1.0 2.0)) (test-flvector (for*/flvector: #:length 4 ([x (in-range 0)] - [y (in-range 2)]) + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 0.0 0.0 0.0)) (test-flvector (for*/flvector: #:length 4 ([x (in-range 2)] - [y (in-range 1)]) + [y (in-range 1)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 0.0 0.0)) (test-flvector (for*/flvector: #:length 4 ([x (in-range 2)] - [y (in-range 3)]) + [y (in-range 3)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 2.0 1.0)) (test-flvector (for*/flvector: #:length 0 ([x (in-range 2)] - [y (in-range 3)]) + [y (in-range 3)]) (real->double-flonum (+ x y))) (flvector)) (test-flvector (for*/flvector: ([x (in-range 2)] - [y (in-range 2)]) + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector 0.0 1.0 1.0 2.0)) (test-flvector (for*/flvector: ([x (in-range 0)] - [y (in-range 2)]) + [y (in-range 2)]) (real->double-flonum (+ x y))) (flvector)) diff --git a/collects/tests/typed-racket/succeed/infer-funargs.rkt b/collects/tests/typed-racket/succeed/infer-funargs.rkt index c063ee7ccb..4d93a41aca 100644 --- a/collects/tests/typed-racket/succeed/infer-funargs.rkt +++ b/collects/tests/typed-racket/succeed/infer-funargs.rkt @@ -8,6 +8,6 @@ (: make-empty-env (case-lambda [-> Environment] [Environment -> Environment])) (define make-empty-env - (case-lambda: [() (make-Environment #f (make-hasheq))] - [((parent : Environment)) (make-Environment parent -(make-hasheq))])) + (case-lambda: + [() (make-Environment #f (make-hasheq))] + [((parent : Environment)) (make-Environment parent (make-hasheq))])) diff --git a/collects/tests/typed-racket/succeed/random-bits.rkt b/collects/tests/typed-racket/succeed/random-bits.rkt index 958f1883f7..4caf3d4ae3 100644 --- a/collects/tests/typed-racket/succeed/random-bits.rkt +++ b/collects/tests/typed-racket/succeed/random-bits.rkt @@ -510,7 +510,7 @@ (define: (mrg32k3a-random-large [state : State] [n : Nb]) : Nb ; n > m-max (do: : Integer ((k : Integer 2 (+ k 1)) - (mk : Integer (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) + (mk : Integer (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) ((>= mk n) (let* ((mk-by-n (quotient mk n)) (a (* mk-by-n n))) @@ -530,7 +530,7 @@ (define: (mrg32k3a-random-real-mp [state : State] [unit : Real]) : Number (do: : Real ((k : Integer 1 (+ k 1)) - (u : Real (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) + (u : Real (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) ((<= u 1) (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) @@ -545,7 +545,7 @@ (define: (make-random-source) : Random (let: ((state : State (mrg32k3a-pack-state ; make a new copy - (list->vector (vector->list mrg32k3a-initial-state))))) + (list->vector (vector->list mrg32k3a-initial-state))))) (:random-source-make (lambda: () (mrg32k3a-state-ref state)) diff --git a/collects/tests/typed-racket/succeed/threads-and-channels.rkt b/collects/tests/typed-racket/succeed/threads-and-channels.rkt index b5edbe49b2..7c41cac654 100644 --- a/collects/tests/typed-racket/succeed/threads-and-channels.rkt +++ b/collects/tests/typed-racket/succeed/threads-and-channels.rkt @@ -58,15 +58,15 @@ (thread-cell-set! tc 1) (thread-wait (thread (lambda () - (displayln (thread-cell-ref tc)) - (thread-cell-set! tc 2) - (displayln (thread-cell-ref tc))))) + (displayln (thread-cell-ref tc)) + (thread-cell-set! tc 2) + (displayln (thread-cell-ref tc))))) (thread-cell-ref tc) (define blocked-thread (thread (lambda () - (channel-get ((inst make-channel 'unused)))))) + (channel-get ((inst make-channel 'unused)))))) (thread-suspend blocked-thread) diff --git a/collects/tests/unstable/temp-c/ttt-players.rkt b/collects/tests/unstable/temp-c/ttt-players.rkt index c83b01ded1..63c871219b 100644 --- a/collects/tests/unstable/temp-c/ttt-players.rkt +++ b/collects/tests/unstable/temp-c/ttt-players.rkt @@ -43,7 +43,7 @@ (define (turn b board-ref board-set) (or (for*/or ([r (in-range 3)] - [c (in-range 3)]) + [c (in-range 3)]) (and (board-ref b r c) (board-set b r c mark))) (board-set b 0 0 mark))) diff --git a/collects/tests/web-server/http/cookies-test.rkt b/collects/tests/web-server/http/cookies-test.rkt index b664febf45..72deea45b6 100644 --- a/collects/tests/web-server/http/cookies-test.rkt +++ b/collects/tests/web-server/http/cookies-test.rkt @@ -131,13 +131,13 @@ (test-equal? "Google" (request-cookies - (make-request - #"GET" (string->url "http://test.com/foo") - (list (make-header #"Cookie" - #"teaching-order=course; + (make-request + #"GET" (string->url "http://test.com/foo") + (list (make-header #"Cookie" + #"teaching-order=course; __utmz=165257760.1272597702.1.1.utmcsr=(direct)|utmccn=(direct)|utmcmd=(none)\r\n")) - (delay empty) #f - "host" 80 "client")) + (delay empty) #f + "host" 80 "client")) (list (make-client-cookie "teaching-order" "course" #f #f) (make-client-cookie "__utmz" "165257760.1272597702.1.1.utmcsr=(direct)|utmccn=(direct)|utmcmd=(none)" #f #f))) diff --git a/collects/tests/web-server/http/xexpr.rkt b/collects/tests/web-server/http/xexpr.rkt index 59eaf7d88c..b046673718 100644 --- a/collects/tests/web-server/http/xexpr.rkt +++ b/collects/tests/web-server/http/xexpr.rkt @@ -22,7 +22,7 @@ (bytes-sort #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\n\r\nlink") -(write-response (response/xexpr '(html))) + (write-response (response/xexpr '(html))) => (bytes-sort #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\n\r\n") diff --git a/collects/tests/web-server/servlet/bindings-test.rkt b/collects/tests/web-server/servlet/bindings-test.rkt index 2e246547bd..a8e07f2f0a 100644 --- a/collects/tests/web-server/servlet/bindings-test.rkt +++ b/collects/tests/web-server/servlet/bindings-test.rkt @@ -33,7 +33,7 @@ (check-equal? (request-bindings (make-request #"GET" (string->url "http://test.com/foo") empty (delay (list (make-binding:form #"key" #"val") - (make-binding:form #"key2" #"val"))) + (make-binding:form #"key2" #"val"))) #f "host" 80 "client")) '((key . "val") diff --git a/collects/tests/xml/test.rkt b/collects/tests/xml/test.rkt index 66c6afc110..9a257d49e1 100644 --- a/collects/tests/xml/test.rkt +++ b/collects/tests/xml/test.rkt @@ -267,35 +267,35 @@ END (test-read-xml "
" '(make-document - (make-prolog - (list - (make-p-i - (make-source (make-location 1 0 1) (make-location 1 56 57)) - xml - "version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"")) - #f - (list)) - (make-element - (make-source (make-location 1 56 57) (make-location 1 62 63)) - 'br - (list) - (list)) - (list))) + (make-prolog + (list + (make-p-i + (make-source (make-location 1 0 1) (make-location 1 56 57)) + xml + "version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"")) + #f + (list)) + (make-element + (make-source (make-location 1 56 57) (make-location 1 62 63)) + 'br + (list) + (list)) + (list))) (test-read-xml #:document-different? #t "
" '(make-document - (make-prolog (list) #f (list)) - (make-element - (make-source (make-location 1 0 1) (make-location 1 6 7)) - 'br - (list) - (list)) - (list - (make-p-i - (make-source (make-location 1 6 7) (make-location 1 62 63)) - xml - "version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"")))) + (make-prolog (list) #f (list)) + (make-element + (make-source (make-location 1 0 1) (make-location 1 6 7)) + 'br + (list) + (list)) + (list + (make-p-i + (make-source (make-location 1 6 7) (make-location 1 62 63)) + xml + "version=\"1.0\"? encoding=\"UTF-8\" standalone=\"yes\"")))) ; XXX need more read-xml tests diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index 814d1964ab..e765aa6a9f 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -319,7 +319,7 @@ (if up? style cap-style) (if up? size cap-size) 0)] - [rest (loop (cdr l) (not up?))]) + [rest (loop (cdr l) (not up?))]) (if (and up? (pair? (cdr l))) ;; kern capital followed by non-captial (let ([plain-first (not-caps-text first-string diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index d6b674410a..6b1b977267 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -398,10 +398,10 @@ [map (-polydots (c a b) (cl->* (-> (-> a c) (-pair a (-lst a)) (-pair c (-lst c))) - ((list - ((list a) (b b) . ->... . c) - (-lst a)) - ((-lst b) b) . ->... .(-lst c))))] + ((list + ((list a) (b b) . ->... . c) + (-lst a)) + ((-lst b) b) . ->... .(-lst c))))] [for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a)) ((-lst b) b) . ->... . -Void))] #;[fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a)) @@ -473,11 +473,10 @@ ;thread-suspend-evt ;Section 10.1.4 -[thread-send (-poly (a) - (cl->* - (-> -Thread Univ -Void) - (-> -Thread Univ (-val #f) (-opt -Void)) - (-> -Thread Univ (-> a) (Un -Void a))))] +[thread-send + (-poly (a) (cl->* (-> -Thread Univ -Void) + (-> -Thread Univ (-val #f) (-opt -Void)) + (-> -Thread Univ (-> a) (Un -Void a))))] [thread-receive (-> Univ)] [thread-try-receive (-> Univ)] [thread-rewind-receive (-> (-lst Univ) -Void)] @@ -552,9 +551,10 @@ [char-whitespace? (-> -Char B)] [char-blank? (-> -Char B)] [char-iso-control? (-> -Char B)] -[char-general-category (-> -Char (apply Un (map -val - '(lu ll lt lm lo mn mc me nd nl no ps pe pi pf pd - pc po sc sm sk so zs zp zl cc cf cs co cn))))] +[char-general-category + (-> -Char (apply Un (map -val + '(lu ll lt lm lo mn mc me nd nl no ps pe pi pf pd + pc po sc sm sk so zs zp zl cc cf cs co cn))))] [make-known-char-range-list (-> (-lst (-Tuple (list -PosInt -PosInt B))))] [char-upcase (-> -Char -Char)] @@ -823,7 +823,8 @@ -[build-path (cl->* +[build-path + (cl->* ((list -Pathlike*) -Pathlike* . ->* . -Path) ((list -SomeSystemPathlike*) -SomeSystemPathlike* . ->* . -SomeSystemPath))] [build-path/convention-type @@ -1567,10 +1568,10 @@ -Index))] [vector-filter (-poly (a b) (cl->* ((asym-pred a Univ (-FS (-filter b 0) -top)) - (-vec a) - . -> . - (-vec b)) - ((a . -> . Univ) (-vec a) . -> . (-vec a))))] + (-vec a) + . -> . + (-vec b)) + ((a . -> . Univ) (-vec a) . -> . (-vec a))))] [vector-filter-not (-poly (a b) (cl->* ((a . -> . Univ) (-vec a) . -> . (-vec a))))] @@ -1580,7 +1581,7 @@ ((-vec a) -Integer . -> . (-vec a)) ((-vec a) -Integer -Integer . -> . (-vec a))))] [vector-map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-vec a)) - ((-vec b) b) . ->... .(-vec c)))] + ((-vec b) b) . ->... .(-vec c)))] [vector-map! (-polydots (a b) ((list ((list a) (b b) . ->... . a) (-vec a)) ((-vec b) b) . ->... .(-vec a)))] [vector-append (-poly (a) (->* (list) (-vec a) (-vec a)))] @@ -1623,9 +1624,9 @@ (arg-in (make-opt-in-port in)) (arg-err (make-opt-out-port err)) (result (-values (list -Subprocess - (make-opt-in-port (not out)) - (make-opt-out-port (not in)) - (make-opt-in-port (not err)))))) + (make-opt-in-port (not out)) + (make-opt-out-port (not in)) + (make-opt-in-port (not err)))))) (if exact (-> arg-out arg-in arg-err -Pathlike (-val 'exact) -String result) (->* (list arg-out arg-in arg-err -Pathlike) @@ -1661,32 +1662,29 @@ [process (-> -String (-values (list -Input-Port -Output-Port -Nat -Input-Port - (cl->* - (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) - (-> (-val 'exit-code) (-opt -Byte)) - (-> (-val 'wait) ManyUniv) - (-> (-val 'interrupt) -Void) - (-> (-val 'kill) -Void)))))] + (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) + (-> (-val 'exit-code) (-opt -Byte)) + (-> (-val 'wait) ManyUniv) + (-> (-val 'interrupt) -Void) + (-> (-val 'kill) -Void)))))] [process* (cl->* (->* (list -Pathlike) (Un -Path -String -Bytes) - (-values (list -Input-Port -Output-Port -Nat -Input-Port - (cl->* - (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) - (-> (-val 'exit-code) (-opt -Byte)) - (-> (-val 'wait) ManyUniv) - (-> (-val 'interrupt) -Void) - (-> (-val 'kill) -Void))))) + (-values (list -Input-Port -Output-Port -Nat -Input-Port + (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) + (-> (-val 'exit-code) (-opt -Byte)) + (-> (-val 'wait) ManyUniv) + (-> (-val 'interrupt) -Void) + (-> (-val 'kill) -Void))))) (-> -Pathlike (-val 'exact) -String - (-values (list -Input-Port -Output-Port -Nat -Input-Port - (cl->* - (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) - (-> (-val 'exit-code) (-opt -Byte)) - (-> (-val 'wait) ManyUniv) - (-> (-val 'interrupt) -Void) - (-> (-val 'kill) -Void))))))] + (-values (list -Input-Port -Output-Port -Nat -Input-Port + (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) + (-> (-val 'exit-code) (-opt -Byte)) + (-> (-val 'wait) ManyUniv) + (-> (-val 'interrupt) -Void) + (-> (-val 'kill) -Void))))))] [process/ports (let* ((fun-type @@ -1720,12 +1718,12 @@ (err-vals '(#t #f stdout))) (for*/list ((out bools) (in bools) (err err-vals)) (make-specific-case out in err))))) - (apply cl->* - (append - specific-cases - (list - (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -String - (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))] + (apply cl->* + (append + specific-cases + (list + (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -String + (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))] [process*/ports (let* ((fun-type @@ -1765,14 +1763,14 @@ (err-vals '(#t #f stdout))) (for*/list ((out bools) (in bools) (err err-vals) (exact bools)) (make-specific-case out in err exact))))) - (apply cl->* - (append specific-cases - (list - (->* (list (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike) + (apply cl->* + (append specific-cases + (list + (->* (list (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike) (Un -Path -String -Bytes) - (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type)) - (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike (-val 'exact) -String - (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))] + (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type)) + (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike (-val 'exact) -String + (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))] @@ -2327,8 +2325,8 @@ ;12.1.10.1 [port->list (-poly (a) (cl->* - (-> (-lst Univ)) - (->opt (-> -Input-Port a) [-Input-Port] (-lst a))))] + (-> (-lst Univ)) + (->opt (-> -Input-Port a) [-Input-Port] (-lst a))))] [port->string (->opt [-Input-Port] -String)] [port->bytes (->opt [-Input-Port] -Bytes)] #| diff --git a/collects/typed-racket/optimizer/apply.rkt b/collects/typed-racket/optimizer/apply.rkt index 6b2de4f09e..dff34e2f5b 100644 --- a/collects/typed-racket/optimizer/apply.rkt +++ b/collects/typed-racket/optimizer/apply.rkt @@ -20,19 +20,19 @@ ((~and kw2 #%plain-app) (~and m map) f l)) #:with opt (begin (reset-unboxed-gensym) - (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] - [l ((optimize) #'l)] - [f ((optimize) #'f)]) - (log-optimization "apply-map" "apply-map deforestation." - this-syntax) - (add-disappeared-use #'appl) - (add-disappeared-use #'kw2) - (add-disappeared-use #'m) - (syntax/loc/origin - this-syntax #'kw - (let ([f* f]) - (let lp ([v op.identity] [lst l]) - (if (null? lst) - v - (lp (op v (f* (unsafe-car lst))) - (unsafe-cdr lst)))))))))) + (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] + [l ((optimize) #'l)] + [f ((optimize) #'f)]) + (log-optimization "apply-map" "apply-map deforestation." + this-syntax) + (add-disappeared-use #'appl) + (add-disappeared-use #'kw2) + (add-disappeared-use #'m) + (syntax/loc/origin + this-syntax #'kw + (let ([f* f]) + (let lp ([v op.identity] [lst l]) + (if (null? lst) + v + (lp (op v (f* (unsafe-car lst))) + (unsafe-cdr lst)))))))))) diff --git a/collects/typed-racket/types/base-abbrev.rkt b/collects/typed-racket/types/base-abbrev.rkt index f11b277ec0..28bd5fb28b 100644 --- a/collects/typed-racket/types/base-abbrev.rkt +++ b/collects/typed-racket/types/base-abbrev.rkt @@ -209,14 +209,14 @@ (with-syntax ([((extra ...) ...) (for/list ([i (in-range (add1 (length l)))]) (take l i))]) - #'(make-Function - (list - (make-arr* (list ty ... extra ...) - rng - #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw]) - (list (make-Keyword 'k kty opt) ...) - keywordmonitor-predicate/concurrent re->monitor-predicate/serial - (all-from-out - "monitor.rkt" - unstable/automata/re - unstable/automata/re-ext)) + (all-from-out "monitor.rkt" + unstable/automata/re + unstable/automata/re-ext)) -(define-syntax-parameter stx-monitor-id +(define-syntax-parameter stx-monitor-id (λ (stx) (raise-syntax-error 'label "Used outside monitor" stx))) (define-syntax-rule (label n K) diff --git a/collects/web-server/dispatchers/dispatch-log.rkt b/collects/web-server/dispatchers/dispatch-log.rkt index 648e46f1bc..8e13f27b1f 100644 --- a/collects/web-server/dispatchers/dispatch-log.rkt +++ b/collects/web-server/dispatchers/dispatch-log.rkt @@ -84,10 +84,10 @@ [(list req) (loop (with-handlers ([exn:fail? (lambda (e) - ((error-display-handler) "dispatch-log.rkt Error writing log entry" e) - (with-handlers ([exn:fail? (lambda (e) #f)]) - (close-output-port log-p)) - #f)]) + ((error-display-handler) "dispatch-log.rkt Error writing log entry" e) + (with-handlers ([exn:fail? (lambda (e) #f)]) + (close-output-port log-p)) + #f)]) (define the-log-p (if (not (and log-p (file-exists? log-path))) (begin diff --git a/collects/web-server/dispatchers/filesystem-map.rkt b/collects/web-server/dispatchers/filesystem-map.rkt index 4588610cbd..5ba98c7a2b 100644 --- a/collects/web-server/dispatchers/filesystem-map.rkt +++ b/collects/web-server/dispatchers/filesystem-map.rkt @@ -91,10 +91,10 @@ (let loop ([up (url-path u)]) #;(printf "~S\n" `(url->valid-path ,(url->string u) ,up)) (with-handlers ([exn:fail? (lambda (exn) - #;((error-display-handler) (exn-message exn) exn) - (if (empty? up) - (raise exn) - (loop (reverse (rest (reverse up))))))]) + #;((error-display-handler) (exn-message exn) exn) + (if (empty? up) + (raise exn) + (loop (reverse (rest (reverse up))))))]) (define-values (p w/o-base) (url->path (url-replace-path (lambda _ up) u))) (unless (or (file-exists? p) (link-exists? p)) diff --git a/collects/web-server/http/cookie.rkt b/collects/web-server/http/cookie.rkt index fa1188547a..430cb7fdce 100644 --- a/collects/web-server/http/cookie.rkt +++ b/collects/web-server/http/cookie.rkt @@ -7,13 +7,14 @@ racket/contract) (provide/contract - [make-cookie ((cookie-name? cookie-value?) (#:comment (or/c false/c string?) - #:domain (or/c false/c valid-domain?) - #:max-age (or/c false/c exact-nonnegative-integer?) - #:path (or/c false/c string?) - #:expires (or/c false/c string?) - #:secure? (or/c false/c boolean?)) - . ->* . cookie?)] + [make-cookie ((cookie-name? cookie-value?) + (#:comment (or/c false/c string?) + #:domain (or/c false/c valid-domain?) + #:max-age (or/c false/c exact-nonnegative-integer?) + #:path (or/c false/c string?) + #:expires (or/c false/c string?) + #:secure? (or/c false/c boolean?)) + . ->* . cookie?)] [cookie->header (cookie? . -> . header?)]) (define-syntax setter diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 19f9eb5a35..fcc4a3080e 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -163,8 +163,8 @@ (define (ext:wrap f) (lambda (conn . args) (with-handlers ([exn:fail? (lambda (exn) - (kill-connection! conn) - (raise exn))]) + (kill-connection! conn) + (raise exn))]) (apply f conn args) (flush-output (connection-o-port conn)))))