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

Fix lots of indentation mistakes.

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

8
collects/algol60/compile.rkt
View File

@ -433,10 +433,10 @@
(car spec)))
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))

18
collects/algol60/simplify.rkt
View File

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

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

@ -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]

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

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

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

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

22
collects/data/queue.rkt
View File

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

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

@ -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!")]))

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

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

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

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

20
collects/deinprogramm/turtle.rkt
View File

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

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

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

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

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

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

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

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

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

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

@ -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"

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

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

6
collects/framework/main.rkt
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -31,10 +31,10 @@
[new-bitmap-height (floor (/ (- puzzle-height 1) pixel-size))])
(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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

12
collects/mzlib/include.rkt
View File

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

4
collects/openssl/mzssl.rkt
View File

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

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

@ -46,11 +46,11 @@
(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)]
[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)))))))))])

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

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

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

@ -9,8 +9,9 @@
(provide/contract
(build-parser ((string? any/c any/c (listof identifier?) (listof identifier?)
(listof identifier?) (union syntax? false/c) syntax?) . ->* .
(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?

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

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

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

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

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

@ -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)
'<no-expected-value>
loc))])
(print-error
'pred-exception
test-sexp
(exn-message exn)
'<no-expected-value>
loc))])
(let ([test-result (return-exception (test-thunk))])
(if (or (exn:plai? test-result)
(not (exn? test-result)))

2
collects/planet2/lib.rkt
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -48,20 +48,20 @@
#;(printf "FORM_NAME ~a ~a ~a\n" #'form-name (syntax->datum #'form-name)
(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)

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

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

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

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

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

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

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

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

48
collects/racket/pretty.rkt
View File

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

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

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

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

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

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

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

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

@ -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?
;;

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

@ -354,8 +354,8 @@
[(encode-as-π (lam x e) a) (in a x (in a v (encode-as-π e v)))]
[(encode-as-π 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

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

@ -689,26 +689,25 @@
(--> (store (sf_1 ... (x_1 #f) sf_2 ...) (in-hole E_1 (reinit x_1)))
(store (sf_1 ... (x_1 #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 ...)

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

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

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

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

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

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

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

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

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

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

2
collects/scribble/core.rkt
View File

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

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

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

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

@ -19,10 +19,9 @@
(syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(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].
}]))

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

@ -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<%>].})

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

@ -63,16 +63,13 @@
@section[#:tag (string-append section-prefix " Pre-Defined Variables")]{Pre-Defined Variables}
@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

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

@ -66,8 +66,8 @@
@t{An @racket[_name] or a @racket[_variable] is a sequence of characters
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.}

2
collects/scriblib/autobib.rkt
View File

@ -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-date<? bib-date=?)))))
(send style get-group-sep))
(list (send style get-cite-close)))))
(list (send style get-cite-close)))))
(define (extract-bib-author b)
(or (auto-bib-author b)

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

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

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

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

8
collects/sgl/bitmap.rkt
View File

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

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

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

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

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

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

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

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

@ -174,9 +174,10 @@ please adhere to these guidelines:
(saved-unsubmitted-bug-reports "Saved, unsubmitted bug reports:")
;; 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")

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

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

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

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

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

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

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

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

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

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

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

@ -230,17 +230,18 @@
(define toc (call-with-input-file (build-path sample-solutions-dir "toc.rkt") read))
(define 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 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

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