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

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

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-24 14:05:29 -07:00
commit 3b90cdb872
32 changed files with 722 additions and 1959 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/private/image-more.rkt
View File

@ -352,7 +352,7 @@
;; scale : I number -> I ;; scale : I number -> I
;; scales the I by the given factor ;; scales the I by the given factor
;; rotate : I number -> I ;; rotate : number I -> I
;; rotates the I around the top-left corner by the given angle (in degrees) ;; rotates the I around the top-left corner by the given angle (in degrees)
(define/chk (rotate angle image) (define/chk (rotate angle image)
(let* ([rotated-shape (rotate-normalized-shape (let* ([rotated-shape (rotate-normalized-shape

11
collects/2htdp/private/utilities.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket
(provide/contract
;; like the unix debugging facility
[tee (-> symbol? any/c any)]
)
(define (tee tag x)
(printf "~a ~s\n" tag x)
x)

1
collects/2htdp/private/world.rkt
View File

@ -6,6 +6,7 @@
"checked-cell.ss" "checked-cell.ss"
"stop.ss" "stop.ss"
"universe-image.ss" "universe-image.ss"
"utilities.rkt"
htdp/error htdp/error
mzlib/runtime-path mzlib/runtime-path
mrlib/bitmap-label mrlib/bitmap-label

9
collects/compiler/decompile.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require compiler/zo-parse (require compiler/zo-parse
syntax/modcollapse syntax/modcollapse
scheme/port
scheme/match) scheme/match)
(provide decompile) (provide decompile)
@ -21,10 +22,10 @@
[table (make-hash)]) [table (make-hash)])
(for ([b (in-list bindings)]) (for ([b (in-list bindings)])
(let ([v (and (cdr b) (let ([v (and (cdr b)
(zo-parse (let-values ([(in out) (make-pipe)]) (zo-parse
(write (cdr b) out) (open-input-bytes
(close-output-port out) (with-output-to-bytes
in)))]) (λ () (write (cdr b)))))))])
(let ([n (match v (let ([n (match v
[(struct compilation-top (_ prefix (struct primval (n)))) n] [(struct compilation-top (_ prefix (struct primval (n)))) n]
[else #f])]) [else #f])])

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

@ -1,11 +1,15 @@
#lang scheme/base #lang scheme/base
(require compiler/zo-structs (require compiler/zo-structs
unstable/byte-counting-port
scheme/match scheme/match
scheme/contract
scheme/local scheme/local
scheme/list scheme/list
scheme/dict) scheme/dict)
(provide zo-marshal) (provide/contract
[zo-marshal (compilation-top? . -> . bytes?)]
[zo-marshal-to (compilation-top? output-port? . -> . void?)])
#| Unresolved Issues #| Unresolved Issues
@ -16,69 +20,70 @@
(define current-wrapped-ht (make-parameter #f)) (define current-wrapped-ht (make-parameter #f))
(define (zo-marshal top) (define (zo-marshal top)
(define bs (open-output-bytes))
(zo-marshal-to top bs)
(get-output-bytes bs))
(define (zo-marshal-to top outp)
(match top (match top
[(struct compilation-top (max-let-depth prefix form)) [(struct compilation-top (max-let-depth prefix form))
(let ([encountered (make-hasheq)] (define encountered (make-hasheq))
[shared (make-hasheq)] (define shared (make-hasheq))
[wrapped (make-hasheq)]) (define wrapped (make-hasheq))
(let ([visit (lambda (v) (define (visit v)
(if (hash-ref shared v #f) (if (hash-ref shared v #f)
#f #f
(if (hash-ref encountered v #f) (if (hash-ref encountered v #f)
(begin (begin
(hash-set! shared v (add1 (hash-count shared))) (hash-set! shared v (add1 (hash-count shared)))
#f) #f)
(begin (begin
(hash-set! encountered v #t) (hash-set! encountered v #t)
(when (closure? v) (when (closure? v)
(hash-set! shared v (add1 (hash-count shared)))) (hash-set! shared v (add1 (hash-count shared))))
#t))))]) #t))))
(parameterize ([current-wrapped-ht wrapped]) (define (v-skipping v)
(traverse-prefix prefix visit) (define skip? #t)
(traverse-form form visit))) (lambda (v2)
(let* ([s (open-output-bytes)] (if (and skip? (eq? v v2))
[out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)] (begin
[offsets (set! skip? #f)
(map (lambda (v) #f)
(let ([v (cdr v)]) (hash-ref shared v2 #f))))
(begin0 (parameterize ([current-wrapped-ht wrapped])
(file-position s) (traverse-prefix prefix visit)
(out-anything v (make-out (traverse-form form visit))
s (local [(define in-order-shareds
(let ([skip? #t]) (sort (hash-map shared (lambda (k v) (cons v k)))
(lambda (v2) <
(if (and skip? (eq? v v2)) #:key car))
(begin (define (write-all outp)
(set! skip? #f) (define offsets
#f) (for/list ([k*v (in-list in-order-shareds)])
(hash-ref shared v2 #f)))) (define v (cdr k*v))
wrapped))))) (begin0
(sort (hash-map shared (lambda (k v) (cons v k))) (file-position outp)
< (out-anything v (make-out outp (v-skipping v) wrapped)))))
#:key car))] (define post-shared (file-position outp))
[post-shared (file-position s)] (out-data (list* max-let-depth prefix (protect-quote form))
[all-short? (post-shared . < . #xFFFF)]) (make-out outp (lambda (v) (hash-ref shared v #f)) wrapped))
(out-data (list* max-let-depth prefix (protect-quote form)) out) (values offsets post-shared (file-position outp)))
(let ([res (get-output-bytes s)] (define counting-p (make-byte-counting-port))
[version-bs (string->bytes/latin-1 (version))]) (define-values (offsets post-shared all-forms-length)
(bytes-append #"#~" (write-all counting-p))
(bytes (bytes-length version-bs)) (define all-short? (post-shared . < . #xFFFF))
version-bs (define version-bs (string->bytes/latin-1 (version)))]
(int->bytes (add1 (hash-count shared))) (write-bytes #"#~" outp)
(bytes (if all-short? (write-bytes (bytes (bytes-length version-bs)) outp)
1 (write-bytes version-bs outp)
0)) (write-bytes (int->bytes (add1 (hash-count shared))) outp)
(apply (write-bytes (bytes (if all-short? 1 0)) outp)
bytes-append (for ([o (in-list offsets)])
(map (lambda (o) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp))
(integer->integer-bytes o (write-bytes (int->bytes post-shared) outp)
(if all-short? 2 4) (write-bytes (int->bytes all-forms-length) outp)
#f (write-all outp)
#f)) (void))]))
offsets))
(int->bytes post-shared)
(int->bytes (bytes-length res))
res))))]))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -359,8 +359,16 @@
(define (read-simple-number p) (define (read-simple-number p)
(integer-bytes->integer (read-bytes 4 p) #f #f)) (integer-bytes->integer (read-bytes 4 p) #f #f))
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis))
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis)) (define (cport-get-bytes cp len)
(define port (cport-orig-port cp))
(define pos (cport-pos cp))
(file-position port (+ (cport-bytes-start cp) pos))
(read-bytes len port))
(define (cport-get-byte cp pos)
(define port (cport-orig-port cp))
(file-position port (+ (cport-bytes-start cp) pos))
(read-byte port))
(define (cport-rpos cp) (define (cport-rpos cp)
(+ (cport-pos cp) (cport-shared-start cp))) (+ (cport-pos cp) (cport-shared-start cp)))
@ -369,8 +377,7 @@
(begin-with-definitions (begin-with-definitions
(when ((cport-pos cp) . >= . (cport-size cp)) (when ((cport-pos cp) . >= . (cport-size cp))
(error "off the end")) (error "off the end"))
(define r (define r (cport-get-byte cp (cport-pos cp)))
(bytes-ref (cport-bytes cp) (cport-pos cp)))
(set-cport-pos! cp (add1 (cport-pos cp))) (set-cport-pos! cp (add1 (cport-pos cp)))
r)) r))
@ -436,7 +443,7 @@
(define (read-compact-bytes port c) (define (read-compact-bytes port c)
(begin0 (begin0
(subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c)) (cport-get-bytes port c)
(set-cport-pos! port (+ c (cport-pos port))))) (set-cport-pos! port (+ c (cport-pos port)))))
(define (read-compact-chars port c) (define (read-compact-chars port c)
@ -742,7 +749,7 @@
v)))] v)))]
[(escape) [(escape)
(let* ([len (read-compact-number cp)] (let* ([len (read-compact-number cp)]
[s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))]) [s (cport-get-bytes cp len)])
(set-cport-pos! cp (+ (cport-pos cp) len)) (set-cport-pos! cp (+ (cport-pos cp) len))
(parameterize ([read-accept-compiled #t] (parameterize ([read-accept-compiled #t]
[read-accept-bar-quote #t] [read-accept-bar-quote #t]
@ -976,17 +983,16 @@
(when (shared-size . >= . size*) (when (shared-size . >= . size*)
(error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)")) (error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)"))
(define rst (read-bytes size* port)) (define rst-start (file-position port))
(file-position port (+ rst-start size*))
(unless (eof-object? (read-byte port)) (unless (eof-object? (read-byte port))
(error 'not-end)) (error 'zo-parse "File too big"))
(unless (= size* (bytes-length rst))
(error "wrong number of bytes"))
(define symtab (make-vector symtabsize (make-not-ready))) (define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 shared-size port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)]) (for/list ([i (in-range 1 symtabsize)])
(define vv (vector-ref symtab i)) (define vv (vector-ref symtab i))

69
collects/games/chat-noir/chat-noir-literate.rkt
View File

@ -16,6 +16,9 @@ that space, and the cat responds by taking a step. If the cat is
completely boxed in and thus unable reach the border, you win. If the completely boxed in and thus unable reach the border, you win. If the
cat does reach the border, you lose. cat does reach the border, you lose.
To start a new game, hit the ``n'' key (but only after losing or
winning a game).
@play-margin-note["Chat Noir"] @play-margin-note["Chat Noir"]
To get some insight into the cat's behavior, hold down the ``h'' To get some insight into the cat's behavior, hold down the ``h''
@ -57,8 +60,8 @@ and some code that builds an initial world and starts the game.
<drawing-the-cat> <drawing-the-cat>
<drawing> <drawing>
<input> <input>
<tests>
<initial-world> <initial-world>
<tests>
<go>] <go>]
Each section also comes with a series of test cases that are collected into the Each section also comes with a series of test cases that are collected into the
@ -1098,6 +1101,7 @@ plus various helper functions.
@chunk[<input> @chunk[<input>
<change> <change>
<release>
<clack> <clack>
<update-world-posn> <update-world-posn>
<player-moved?> <player-moved?>
@ -1110,6 +1114,7 @@ plus various helper functions.
@chunk[<input-tests> @chunk[<input-tests>
<change-tests> <change-tests>
<release-tests>
<point-in-this-circle?-tests> <point-in-this-circle?-tests>
<circle-at-point-tests> <circle-at-point-tests>
<lt/f-tests> <lt/f-tests>
@ -1118,22 +1123,41 @@ plus various helper functions.
<update-world-posn-tests> <update-world-posn-tests>
<clack-tests>] <clack-tests>]
The @scheme[change] function handles keyboard input and merely updates the @tt{h-down?} field The @scheme[change] function handles keyboard input. If the input is @litchar{n} and the
based on the state of the key event during gameplay. Once the game has ended it resets to the game is over, then restart the game. If the input is @litchar{h} then turn on the help
initial world when the user presses @litchar{n}. and otherwise do nothing.
@chunk[<change> @chunk[<change>
;; change : world key-event -> world ;; change : world key-event -> world
(define (change w ke) (define (change w ke)
(if (and (not (equal? (world-state w) 'playing)) (cond
(key=? ke "n")) [(key=? ke "n")
(make-initial-world) (if (equal? (world-state w) 'playing)
(make-world (world-board w) w
(world-cat w) (make-initial-world))]
(world-state w) [(key=? ke "h")
(world-size w) (make-world (world-board w)
(world-mouse-posn w) (world-cat w)
(key=? ke "h"))))] (world-state w)
(world-size w)
(world-mouse-posn w)
#t)]
[else w]))]
The @scheme[release] function adjusts the world for a key release event.
@chunk[<release>
;; release : world key-event -> world
(define (release w ke)
(make-world (world-board w)
(world-cat w)
(world-state w)
(world-size w)
(world-mouse-posn w)
(if (key=? ke "h")
#f
(world-h-down? w))))]
The @scheme[clack] function handles mouse input. It has three tasks and each corresponds The @scheme[clack] function handles mouse input. It has three tasks and each corresponds
to a helper function: to a helper function:
@ -2253,7 +2277,23 @@ and reports the results.
'playing 3 (make-posn 0 0) #f) 'playing 3 (make-posn 0 0) #f)
"h") "h")
(make-world '() (make-posn 1 1) (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t))] 'playing 3 (make-posn 0 0) #t))
(test (change (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #f)
"n")
(make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #f))
(test (world-state (change (make-world '() (make-posn 1 1)
'cat-lost 3 (make-posn 0 0) #f)
"n"))
'playing)]
@chunk[<release-tests>
(test (release (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t)
"h")
(make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #f))]
@chunk[<point-in-this-circle?-tests> @chunk[<point-in-this-circle?-tests>
@ -2362,5 +2402,6 @@ by calling @scheme[big-bang] with the appropriate arguments.
(world-width board-size) (world-width board-size)
(world-height board-size)) (world-height board-size))
(on-key change) (on-key change)
(on-release release)
(on-mouse clack) (on-mouse clack)
(name "Chat Noir"))))] (name "Chat Noir"))))]

17
collects/meta/drdr/analyze.ss
View File

@ -150,15 +150,18 @@
; XXX But even then it can lead to problems ; XXX But even then it can lead to problems
(not (path-random? (build-path (revision-trunk-dir cur-rev) (substring (path->string* p) 1))))) (not (path-random? (build-path (revision-trunk-dir cur-rev) (substring (path->string* p) 1)))))
(not (symbol=? id 'changes)))))) (not (symbol=? id 'changes))))))
(unless (andmap zero? nums) (define mail-recipients
(send-mail-message "drdr@plt-scheme.org" (append (if include-committer?
(list committer)
empty)
responsibles))
(unless (or (andmap zero? nums)
(empty? mail-recipients))
(send-mail-message "drdr@racket-lang.org"
(format "[DrDr] R~a ~a" (format "[DrDr] R~a ~a"
cur-rev totals) cur-rev totals)
(map (curry format "~a@plt-scheme.org") (map (curry format "~a@racket-lang.org")
(append (if include-committer? mail-recipients)
(list committer)
empty)
responsibles))
empty empty empty empty
(flatten (flatten
(list (format "DrDr has finished building push #~a after ~a." (list (format "DrDr has finished building push #~a after ~a."

3
collects/meta/props
View File

@ -1800,6 +1800,7 @@ path/s is either such a string or a list of them.
"collects/tests/units/test-runtime.rktl" drdr:command-line (racket "-f" *) "collects/tests/units/test-runtime.rktl" drdr:command-line (racket "-f" *)
"collects/tests/units/test-unit-contracts.rktl" drdr:command-line (racket "-f" *) "collects/tests/units/test-unit-contracts.rktl" drdr:command-line (racket "-f" *)
"collects/tests/units/test-unit.rktl" drdr:command-line (racket "-f" *) "collects/tests/units/test-unit.rktl" drdr:command-line (racket "-f" *)
"collects/tests/unstable/byte-counting-port.rkt" responsible (jay)
"collects/tests/unstable/generics.rkt" responsible (jay) "collects/tests/unstable/generics.rkt" responsible (jay)
"collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *) "collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *)
"collects/tests/utils" responsible (unknown) "collects/tests/utils" responsible (unknown)
@ -1839,6 +1840,7 @@ path/s is either such a string or a list of them.
"collects/typed/rackunit/gui.rkt" drdr:command-line (gracket "-t" *) "collects/typed/rackunit/gui.rkt" drdr:command-line (gracket "-t" *)
"collects/typed-scheme" responsible (samth) "collects/typed-scheme" responsible (samth)
"collects/unstable" responsible (jay samth cce ryanc) "collects/unstable" responsible (jay samth cce ryanc)
"collects/unstable/byte-counting-port.rkt" responsible (jay)
"collects/unstable/debug.rkt" responsible (samth) "collects/unstable/debug.rkt" responsible (samth)
"collects/unstable/gui/notify.rkt" drdr:command-line (gracket-text "-t" *) "collects/unstable/gui/notify.rkt" drdr:command-line (gracket-text "-t" *)
"collects/unstable/gui/prefs.rkt" drdr:command-line (gracket-text "-t" *) "collects/unstable/gui/prefs.rkt" drdr:command-line (gracket-text "-t" *)
@ -1846,6 +1848,7 @@ path/s is either such a string or a list of them.
"collects/unstable/match.rkt" responsible (samth) "collects/unstable/match.rkt" responsible (samth)
"collects/unstable/mutated-vars.rkt" responsible (samth) "collects/unstable/mutated-vars.rkt" responsible (samth)
"collects/unstable/poly-c.rkt" responsible (samth) "collects/unstable/poly-c.rkt" responsible (samth)
"collects/unstable/scribblings/byte-counting-port.scrbl" responsible (jay)
"collects/unstable/scribblings/debug.scrbl" responsible (samth) "collects/unstable/scribblings/debug.scrbl" responsible (samth)
"collects/unstable/scribblings/hash.scrbl" responsible (samth) "collects/unstable/scribblings/hash.scrbl" responsible (samth)
"collects/unstable/scribblings/match.scrbl" responsible (samth) "collects/unstable/scribblings/match.scrbl" responsible (samth)

710
collects/mzlib/date.rkt
View File

@ -1,391 +1,365 @@
#lang racket/base
(require racket/promise
racket/match
racket/list
racket/function
racket/contract)
(module date mzscheme (provide/contract
[current-date (-> date?)]
[date->seconds (date? . -> . exact-integer?)]
[date->string ((date?) (boolean?) . ->* . string?)]
[date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))]
[find-seconds ((integer-in 0 61)
(integer-in 0 59)
(integer-in 0 23)
(integer-in 1 31)
(integer-in 1 12)
exact-nonnegative-integer?
. -> .
exact-integer?)]
[date->julian/scalinger (date? . -> . exact-integer?)]
[julian/scalinger->string (exact-integer? . -> . string?)])
(require "list.rkt") (define (current-date)
(seconds->date (current-seconds)))
(provide date->string ;; Support for Julian calendar added by Shriram;
date-display-format ;; current version only works until 2099 CE Gregorian
find-seconds
date->julian/scalinger (define date-display-format
julian/scalinger->string) (make-parameter 'american))
(define (month/number->string x)
(case x
[(12) "December"] [(1) "January"] [(2) "February"]
[(3) "March"] [(4) "April"] [(5) "May"]
[(6) "June"] [(7) "July"] [(8) "August"]
[(9) "September"] [(10) "October"] [(11) "November"]
[else ""]))
;; Support for Julian calendar added by Shriram; (define (day/number->string x)
;; current version only works until 2099 CE Gregorian (case x
[(0) "Sunday"]
[(1) "Monday"]
[(2) "Tuesday"]
[(3) "Wednesday"]
[(4) "Thursday"]
[(5) "Friday"]
[(6) "Saturday"]
[else ""]))
#| (define (add-zero n)
(if (< n 10)
(string-append "0" (number->string n))
(number->string n)))
(define-primitive seconds->date (num -> structure:date)) (define (date->string date [time? #f])
(define-primitive current-seconds (-> num)) (define year (number->string (date-year date)))
(define-primitive date-second (structure:date -> num)) (define num-month (number->string (date-month date)))
(define-primitive date-minute (structure:date -> num)) (define week-day (day/number->string (date-week-day date)))
(define-primitive date-hour (structure:date -> num)) (define week-day-num (date-week-day date))
(define-primitive date-day (structure:date -> num)) (define month (month/number->string (date-month date)))
(define-primitive date-month (structure:date -> num)) (define day (number->string (date-day date)))
(define-primitive date-year (structure:date -> num)) (define day-th
(define-primitive date-week-day (structure:date -> num)) (if (<= 11 (date-day date) 13)
(define-primitive date-year-day (structure:date -> num)) "th"
(define-primitive date-dst? (structure:date -> bool)) (case (modulo (date-day date) 10)
(define-primitive make-date (num num num num num num num num bool -> [(1) "st"]
structure:date)) [(2) "nd"]
(define-primitive expr->string (a -> string)) [(3) "rd"]
(define-primitive foldl (case-> [(0 4 5 6 7 8 9) "th"])))
((a z -> z) z (listof a) -> z) (define hour (date-hour date))
((a b z -> z) z (listof a) (listof b) -> z) (define am-pm (if (>= hour 12) "pm" "am"))
((a b c z -> z) z (listof a) (listof b) (listof c) -> z) (define hour24 (add-zero hour))
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) (define hour12
(define-primitive foldr (case-> (number->string
((a z -> z) z (listof a) -> z) (cond
((a b z -> z) z (listof a) (listof b) -> z) [(zero? hour) 12]
((a b c z -> z) z (listof a) (listof b) (listof c) -> z) [(> hour 12) (- hour 12)]
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z))) [else hour])))
(define minute (add-zero (date-minute date)))
(define second (add-zero (date-second date)))
(define-values
(day-strs time-strs)
(case (date-display-format)
[(american)
(values (list week-day ", " month " " day day-th ", " year)
(list " " hour12 ":" minute ":" second am-pm))]
[(chinese)
(values
(list year "/" num-month "/" day
" \u661F\u671F" (case (date-week-day date)
[(0) "\u5929"]
[(1) "\u4E00"]
[(2) "\u4E8C"]
[(3) "\u4e09"]
[(4) "\u56DB"]
[(5) "\u4E94"]
[(6) "\u516D"]
[else ""]))
(list " " hour24 ":" minute ":" second))]
[(indian)
(values (list day "-" num-month "-" year)
(list " " hour12 ":" minute ":" second am-pm))]
[(german)
(values (list day ". "
(case (date-month date)
[(1) "Januar"]
[(2) "Februar"]
[(3) "M\344rz"]
[(4) "April"]
[(5) "Mai"]
[(6) "Juni"]
[(7) "Juli"]
[(8) "August"]
[(9) "September"]
[(10) "Oktober"]
[(11) "November"]
[(12) "Dezember"]
[else ""])
" " year)
(list ", " hour24 "." minute))]
[(irish)
(values (list week-day ", " day day-th " " month " " year)
(list ", " hour12 ":" minute am-pm))]
[(julian)
(values (list (julian/scalinger->string
(date->julian/scalinger date)))
(list ", " hour24 ":" minute ":" second))]
[(iso-8601)
(values
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
(list " " hour24 ":" minute ":" second))]
[(rfc2822)
(values
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
(list* " " hour24 ":" minute ":" second " "
(let* ([delta (date-time-zone-offset date)]
[hours (quotient delta 3600)]
[minutes (modulo (quotient delta 60) 60)])
(list
(if (negative? delta) "-" "+")
(add-zero (abs hours))
(add-zero minutes)))))]
[else (error 'date->string "unknown date-display-format: ~s"
(date-display-format))]))
(apply string-append
(if time?
(append day-strs time-strs)
day-strs)))
|# (define (leap-year? year)
(or (= 0 (modulo year 400))
(and (= 0 (modulo year 4))
(not (= 0 (modulo year 100))))))
(define legal-formats ;; it's not clear what months mean in this context -- use days
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822)) (define-struct date-offset (second minute hour day year))
(define date-display-format (define (fixup s x) (if (< s 0) (+ s x) s))
(make-parameter 'american (define (date- date1 date2)
(lambda (s) (define second (- (date-second date1) (date-second date2)))
(unless (memq s legal-formats) (define minute
(raise-type-error 'date-display-format (+ (- (date-minute date1) (date-minute date2))
(format "symbol in ~a" legal-formats) (if (< second 0) -1 0)))
s)) (define hour
s))) (+ (- (date-hour date1) (date-hour date2))
(if (< minute 0) -1 0)
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
[(date-dst? date1) -1]
[(date-dst? date2) 1])))
(define day
(+ (- (date-year-day date1) (date-year-day date2))
(if (< hour 0) -1 0)))
(define year
(+ (- (date-year date1) (date-year date2))
(if (< day 0) -1 0)))
(make-date-offset
(fixup second 60)
(fixup minute 60)
(fixup hour 24)
(fixup day (if (leap-year? (date-year date1)) 366 365))
year))
(define month/number->string (define (one-entry b)
(lambda (x) (string-append
(case x (number->string (first b))
[(12) "December"] [(1) "January"] [(2) "February"] " "
[(3) "March"] [(4) "April"] [(5) "May"] (second b)
[(6) "June"] [(7) "July"] [(8) "August"] (if (= 1 (first b)) "" "s")))
[(9) "September"] [(10) "October"] [(11) "November"] (define (date-offset->string date [seconds? #f])
[else ""]))) (define fields
(list (list (date-offset-year date) "year")
(list (date-offset-day date) "day")
(list (date-offset-hour date) "hour")
(list (date-offset-minute date) "minute")
(list (if seconds? (date-offset-second date) 0) "second")))
(define non-zero-fields
(filter (negate (compose (curry = 0) first)) fields))
(match non-zero-fields
[(list) ""]
[(list one) (one-entry one)]
[_
(for/fold ([string ""])
([b (in-list non-zero-fields)])
(cond
[(= 0 (first b)) string]
[(string=? string "")
(string-append "and "
(one-entry b)
string)]
[else (string-append (one-entry b) ", " string)]))]))
(define day/number->string (define (days-per-month year month)
(lambda (x) (cond
(case x [(and (= month 2) (leap-year? year)) 29]
[(0) "Sunday"] [(= month 2) 28]
[(1) "Monday"] [(<= month 7) (+ 30 (modulo month 2))]
[(2) "Tuesday"] [else (+ 30 (- 1 (modulo month 2)))]))
[(3) "Wednesday"]
[(4) "Thursday"]
[(5) "Friday"]
[(6) "Saturday"]
[else ""])))
(define date->string (define (find-extreme-date-seconds start offset)
(case-lambda (let/ec found
[(date) (date->string date #f)] (letrec ([find-between
[(date time?) (lambda (lo hi)
(let* ((add-zero (lambda (n) (if (< n 10) (let ([mid (floor (/ (+ lo hi) 2))])
(string-append "0" (number->string n)) (if (or (and (positive? offset) (= lo mid))
(number->string n)))) (and (negative? offset) (= hi mid)))
(year (number->string (date-year date))) (found lo)
(num-month (number->string (date-month date))) (let ([mid-ok?
(week-day (day/number->string (date-week-day date))) (with-handlers ([exn:fail? (lambda (exn) #f)])
(week-day-num (date-week-day date)) (seconds->date mid)
(month (month/number->string (date-month date))) #t)])
(day (number->string (date-day date))) (if mid-ok?
(day-th (if (<= 11 (date-day date) 13) (find-between mid hi)
"th" (find-between lo mid))))))])
(case (modulo (date-day date) 10) (let loop ([lo start][offset offset])
[(1) "st"] (let ([hi (+ lo offset)])
[(2) "nd"] (with-handlers ([exn:fail?
[(3) "rd"] (lambda (exn)
[(0 4 5 6 7 8 9) "th"]))) ; failed - must be between lo & hi
(hour (date-hour date)) (find-between lo hi))])
(am-pm (if (>= hour 12) "pm" "am")) (seconds->date hi))
(hour24 (add-zero hour)) ; succeeded; double offset again
(hour12 (number->string (loop hi (* 2 offset)))))))
(cond
[(zero? hour) 12]
[(> hour 12) (- hour 12)]
[else hour])))
(minute (add-zero (date-minute date)))
(second (add-zero (date-second date))))
(let-values
([(day time)
(case (date-display-format)
[(american)
(values (list week-day ", " month " " day day-th ", " year)
(list " " hour12 ":" minute ":" second am-pm))]
[(chinese)
(values
(list year "/" num-month "/" day
" \u661F\u671F" (case (date-week-day date)
[(0) "\u5929"]
[(1) "\u4E00"]
[(2) "\u4E8C"]
[(3) "\u4e09"]
[(4) "\u56DB"]
[(5) "\u4E94"]
[(6) "\u516D"]
[else ""]))
(list " " hour24 ":" minute ":" second))]
[(indian)
(values (list day "-" num-month "-" year)
(list " " hour12 ":" minute ":" second am-pm))]
[(german)
(values (list day ". "
(case (date-month date)
[(1) "Januar"]
[(2) "Februar"]
[(3) "M\344rz"]
[(4) "April"]
[(5) "Mai"]
[(6) "Juni"]
[(7) "Juli"]
[(8) "August"]
[(9) "September"]
[(10) "Oktober"]
[(11) "November"]
[(12) "Dezember"]
[else ""])
" " year)
(list ", " hour24 "." minute))]
[(irish)
(values (list week-day ", " day day-th " " month " " year)
(list ", " hour12 ":" minute am-pm))]
[(julian)
(values (list (julian/scalinger->string
(date->julian/scalinger date)))
(list ", " hour24 ":" minute ":" second))]
[(iso-8601)
(values
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
(list " " hour24 ":" minute ":" second))]
[(rfc2822)
(values
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
(list* " " hour24 ":" minute ":" second " "
(let* ([delta (date-time-zone-offset date)]
[hours (quotient delta 3600)]
[minutes (modulo (quotient delta 60) 60)])
(list
(if (negative? delta) "-" "+")
(add-zero (abs hours))
(add-zero minutes)))))]
[else (error 'date->string "unknown date-display-format: ~s"
(date-display-format))])])
(apply string-append (if time?
(append day time)
day))))]))
(define leap-year? (define get-min-seconds
(lambda (year) (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
(or (= 0 (modulo year 400)) (lambda ()
(and (= 0 (modulo year 4)) (force d))))
(not (= 0 (modulo year 100))))))) (define get-max-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
(lambda ()
(force d))))
;; it's not clear what months mean in this context -- use days (define (date->seconds date)
(define-struct date-offset (second minute hour day year)) (find-seconds
(date-second date)
(date-minute date)
(date-hour date)
(date-day date)
(date-month date)
(date-year date)))
(define date- (define (find-seconds sec min hour day month year)
(lambda (date1 date2) (define (signal-error msg)
(let* ((second (- (date-second date1) (date-second date2))) (error 'find-secs (string-append
(minute (+ (- (date-minute date1) (date-minute date2)) msg
(if (< second 0) -1 0))) " (inputs: ~a ~a ~a ~a ~a ~a)")
(hour (+ (- (date-hour date1) (date-hour date2)) sec min hour day month year))
(if (< minute 0) -1 0) (let loop ([below-secs (get-min-seconds)]
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0] [secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
[(date-dst? date1) -1] [above-secs (get-max-seconds)])
[(date-dst? date2) 1]))) (let* ([date (seconds->date secs)]
(day (+ (- (date-year-day date1) (date-year-day date2)) [compare
(if (< hour 0) -1 0))) (let loop ([inputs (list year month day
(year (+ (- (date-year date1) (date-year date2)) hour min sec)]
(if (< day 0) -1 0))) [tests (list (date-year date)
(fixup (lambda (s x) (if (< s 0) (+ s x) s)))) (date-month date)
(make-date-offset (fixup second 60) (date-day date)
(fixup minute 60) (date-hour date)
(fixup hour 24) (date-minute date)
(fixup day (if (leap-year? (date-year date1)) 366 365)) (date-second date))])
year)))) (cond
[(null? inputs) 'equal]
[else (let ([input (car inputs)]
(define date-offset->string [test (car tests)])
(let ((first car) (if (= input test)
(second cadr)) (loop (cdr inputs) (cdr tests))
(case-lambda (if (<= input test)
[(date) (date-offset->string date #f)] 'input-smaller
[(date seconds?) 'test-smaller)))]))])
(let* ((fields (list (list (date-offset-year date) "year") ; (printf "~a ~a ~a~n" compare secs (date->string date))
(list (date-offset-day date) "day")
(list (date-offset-hour date) "hour")
(list (date-offset-minute date) "minute")
(list (if seconds? (date-offset-second date) 0) "second")))
(non-zero-fields (foldl (lambda (x l)
(if (= 0 (first x))
l
(cons x l)))
null
fields))
(one-entry (lambda (b)
(string-append
(number->string (first b))
" "
(second b)
(if (= 1 (first b)) "" "s")))))
(cond
[(null? non-zero-fields) ""]
[(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
[else (foldl (lambda (b string)
(cond
[(= 0 (first b)) string]
[(string=? string "")
(string-append "and "
(one-entry b)
string)]
[else (string-append (one-entry b) ", " string)]))
""
non-zero-fields)]))])))
(define days-per-month
(lambda (year month)
(cond (cond
[(and (= month 2) (leap-year? year)) 29] [(eq? compare 'equal) secs]
[(= month 2) 28] [(or (= secs below-secs) (= secs above-secs))
[(<= month 7) (+ 30 (modulo month 2))] (signal-error "non-existent date")]
[else (+ 30 (- 1 (modulo month 2)))]))) [(eq? compare 'input-smaller)
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
[(eq? compare 'test-smaller)
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))
(define find-extreme-date-seconds ;; date->julian/scalinger :
(lambda (start offset) ;; date -> number [julian-day]
(let/ec found
(letrec ([find-between
(lambda (lo hi)
(let ([mid (floor (/ (+ lo hi) 2))])
(if (or (and (positive? offset) (= lo mid))
(and (negative? offset) (= hi mid)))
(found lo)
(let ([mid-ok?
(with-handlers ([exn:fail? (lambda (exn) #f)])
(seconds->date mid)
#t)])
(if mid-ok?
(find-between mid hi)
(find-between lo mid))))))])
(let loop ([lo start][offset offset])
(let ([hi (+ lo offset)])
(with-handlers ([exn:fail?
(lambda (exn)
; failed - must be between lo & hi
(find-between lo hi))])
(seconds->date hi))
; succeeded; double offset again
(loop hi (* 2 offset))))))))
(define get-min-seconds ;; Note: This code is correct until 2099 CE Gregorian
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
(lambda ()
(force d))))
(define get-max-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
(lambda ()
(force d))))
(define find-seconds (define (date->julian/scalinger date)
(lambda (sec min hour day month year) (define day (date-day date))
(let ([signal-error (define month (date-month date))
(lambda (msg) (define d-year (date-year date))
(error 'find-secs (string-append (define year (+ 4712 d-year))
msg (define adj-year (if (< month 3) (sub1 year) year))
" (inputs: ~a ~a ~a ~a ~a ~a)") (define cycle-number (quotient adj-year 4))
sec min hour day month year))]) (define cycle-position (remainder adj-year 4))
(let loop ([below-secs (get-min-seconds)] (define base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))] (define month-day-number
[above-secs (get-max-seconds)]) (case month
(let* ([date (seconds->date secs)] ((3) 0)
[compare ((4) 31)
(let loop ([inputs (list year month day ((5) 61)
hour min sec)] ((6) 92)
[tests (list (date-year date) ((7) 122)
(date-month date) ((8) 153)
(date-day date) ((9) 184)
(date-hour date) ((10) 214)
(date-minute date) ((11) 245)
(date-second date))]) ((12) 275)
(cond ((1) 306)
[(null? inputs) 'equal] ((2) 337)))
[else (let ([input (car inputs)] (define total-days (+ base-day month-day-number day))
[test (car tests)]) (define total-days/march-adjustment (+ total-days 59))
(if (= input test) (define gregorian-adjustment
(loop (cdr inputs) (cdr tests)) (cond
(if (<= input test) ((< adj-year 1700) 11)
'input-smaller ((< adj-year 1800) 12)
'test-smaller)))]))]) (else 13)))
; (printf "~a ~a ~a~n" compare secs (date->string date)) (define final-date
(cond (- total-days/march-adjustment
[(eq? compare 'equal) secs] gregorian-adjustment))
[(or (= secs below-secs) (= secs above-secs)) final-date)
(signal-error "non-existent date")]
[(eq? compare 'input-smaller)
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
[(eq? compare 'test-smaller)
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
;; date->julian/scalinger : ;; julian/scalinger->string :
;; date -> number [julian-day] ;; number [julian-day] -> string [julian-day-format]
;; Note: This code is correct until 2099 CE Gregorian
(define (date->julian/scalinger date)
(let ((day (date-day date))
(month (date-month date))
(year (date-year date)))
(let ((year (+ 4712 year)))
(let ((year (if (< month 3) (sub1 year) year)))
(let ((cycle-number (quotient year 4))
(cycle-position (remainder year 4)))
(let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
(let ((month-day-number (case month
((3) 0)
((4) 31)
((5) 61)
((6) 92)
((7) 122)
((8) 153)
((9) 184)
((10) 214)
((11) 245)
((12) 275)
((1) 306)
((2) 337))))
(let ((total-days (+ base-day month-day-number day)))
(let ((total-days/march-adjustment (+ total-days 59)))
(let ((gregorian-adjustment (cond
((< year 1700) 11)
((< year 1800) 12)
(else 13))))
(let ((final-date (- total-days/march-adjustment
gregorian-adjustment)))
final-date)))))))))))
;; julian/scalinger->string :
;; number [julian-day] -> string [julian-day-format]
(define (julian/scalinger->string julian-day)
(apply string-append
(cons "JD "
(reverse
(let loop ((reversed-digits (map number->string
(let loop ((jd julian-day))
(if (zero? jd) null
(cons (remainder jd 10)
(loop (quotient jd 10))))))))
(cond
((or (null? reversed-digits)
(null? (cdr reversed-digits))
(null? (cdr (cdr reversed-digits)))
(null? (cdr (cdr (cdr reversed-digits)))))
(list (apply string-append (reverse reversed-digits))))
(else (cons (apply string-append
(list " "
(caddr reversed-digits)
(cadr reversed-digits)
(car reversed-digits)))
(loop (cdr (cdr (cdr reversed-digits))))))))))))
)
(define (julian/scalinger->string julian-day)
(apply string-append
(cons "JD "
(reverse
(let loop ((reversed-digits (map number->string
(let loop ((jd julian-day))
(if (zero? jd) null
(cons (remainder jd 10)
(loop (quotient jd 10))))))))
(cond
((or (null? reversed-digits)
(null? (cdr reversed-digits))
(null? (cdr (cdr reversed-digits)))
(null? (cdr (cdr (cdr reversed-digits)))))
(list (apply string-append (reverse reversed-digits))))
(else (cons (apply string-append
(list " "
(caddr reversed-digits)
(cadr reversed-digits)
(car reversed-digits)))
(loop (cdr (cdr (cdr reversed-digits))))))))))))

2
collects/net/ftp-sig.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/signature #lang racket/signature
ftp-connection? ftp-connection?
ftp-cd ftp-cd

6
collects/net/ftp-unit.rkt
View File

@ -1,10 +1,10 @@
#lang scheme/unit #lang racket/unit
;; Version 0.2 ;; Version 0.2
;; Version 0.1a ;; Version 0.1a
;; Micah Flatt ;; Micah Flatt
;; 06-06-2002 ;; 06-06-2002
(require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss") (require racket/date racket/file racket/port racket/tcp "ftp-sig.rkt")
(import) (import)
(export ftp^) (export ftp^)
@ -197,7 +197,7 @@
(path->string (build-path folder "ftptmp")) (path->string (build-path folder "ftptmp"))
"~~") "~~")
"~a"))] "~a"))]
[new-file (open-output-file tmpfile 'replace)] [new-file (open-output-file tmpfile #:exists 'replace)]
[tcpstring (bytes-append #"RETR " [tcpstring (bytes-append #"RETR "
(string->bytes/locale filename) (string->bytes/locale filename)
#"\n")] #"\n")]

4
collects/net/ftp.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/unit "ftp-sig.ss" "ftp-unit.ss") (require racket/unit "ftp-sig.rkt" "ftp-unit.rkt")
(define-values/invoke-unit/infer ftp@) (define-values/invoke-unit/infer ftp@)

1456
collects/redex/doc.txt
View File

File diff suppressed because it is too large Load Diff

52
collects/redex/examples/README Normal file
View File

@ -0,0 +1,52 @@
The examples subcollection contains several small languages
to demonstrate various different uses of PLT Redex:
arithmetic.rkt: an arithmetic language with every
possible order of evaluation
beginner.rkt: a PLT Redex implementation of (much of) the
beginning student teaching language.
church.rkt: Church numerals with call by name
normal order evaluation
combinators.rkt: fills in the gaps in a proof in
Barendregt that i and j (defined in the file) are
a combinator basis
compatible-closure.rkt: an example use of compatible
closure. Also, one of the first examples from Matthias
Felleisen and Matthew Flatt's monograph
contracts.rkt: A core contract calculus, including blame,
with function contracts, (eager) pair contracts,
and a few numeric predicates
letrec.rkt: shows how to model letrec with a store and
some infinite looping terms
omega.rkt: the call by value lambda calculus with call/cc.
Includes omega and two call/cc-based infinite loops, one of
which has an ever-expanding term size and one of which has
a bounded term size.
pi-calculus.rkt: a formulation of the pi calculus, following
Milner's 1990 paper, "Functions as Processes"
racket-machine: an operational semantics for (much of) Racket
bytecode
r6rs: an implementation of the R6RS Scheme formal semantics
semaphores.rkt: a simple threaded language with semaphores
subject-reduction.rkt: demos traces/pred that type checks
the term.
threads.rkt: shows how non-deterministic choice can be
modeled in a reduction semantics. Contains an example use
of a simple alternative pretty printer.
types.rkt: shows how the simply-typed lambda calculus's
type system can be written as a rewritten system (see
Kuan, MacQueen, Findler in ESOP 2007 for more).

8
collects/redex/examples/r6rs/README
View File

@ -1,4 +1,4 @@
This directory contains the PLT Redex implementation of the This directory a the PLT Redex implementation of the
R6RS operational semantics and a test suite for the R6RS operational semantics and a test suite for the
semantics. semantics.
@ -6,20 +6,20 @@ semantics.
== r6rs-tests.ss: the test suite for the semantics. Use: == r6rs-tests.ss: the test suite for the semantics. Use:
mzscheme -t r6rs-tests.ss -m racket -t r6rs-tests.ss -m
to run the tests and see a single period shown per test to run the tests and see a single period shown per test
run (each test that explores more than 100 states shows a run (each test that explores more than 100 states shows a
colon for each 100 states it explores). To see a more colon for each 100 states it explores). To see a more
verbose output (that shows each test), use: verbose output (that shows each test), use:
mzscheme -t r6rs-tests.ss -m #t racket -t r6rs-tests.ss -m #t
== show-examples.ss: use this file to explore particular == show-examples.ss: use this file to explore particular
examples in a GUI. Its content shows how to use it and examples in a GUI. Its content shows how to use it and
gives a few examples. Either run it in DrRacket's module gives a few examples. Either run it in DrRacket's module
language, or like this from the commandline: language, or like this from the commandline:
mred show-examples.ss gracket show-examples.ss
== test.ss: test suite infrastructure == test.ss: test suite infrastructure

5
collects/redex/examples/r6rs/show-examples.rkt
View File

@ -36,26 +36,21 @@
;; example uses of the above functions ;; example uses of the above functions
;; if any of the terms in the graph don't ;; if any of the terms in the graph don't
;; match p*, they will be colored red ;; match p*, they will be colored red
;; #; comments out an entire sexpression.
;; ;;
#;
(show '(store () (((lambda (x y) (set! x (+ x y)) x) 2 3)))) (show '(store () (((lambda (x y) (set! x (+ x y)) x) 2 3))))
;; an infinite, tail-recursive loop ;; an infinite, tail-recursive loop
#;
(show-expression '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc))) (show-expression '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
;; two infinite loops, one in left-to-right and one in right-to-left evaluation order ;; two infinite loops, one in left-to-right and one in right-to-left evaluation order
;; one goes into a non-tail infinite loop, the other's reduction graph has a cycle ;; one goes into a non-tail infinite loop, the other's reduction graph has a cycle
#;
(step '(store () (step '(store ()
((call/cc call/cc) ((call/cc call/cc)
(call/cc call/cc)))) (call/cc call/cc))))
;; demonstrates sharing ;; demonstrates sharing
#;
(show-expression (show-expression
'((lambda (c) '((lambda (c)
((lambda (x y) ((lambda (x y)

2
collects/scribble/lp/lang/lang.rkt
View File

@ -41,7 +41,7 @@
(raise-syntax-error 'scribble/lp "no chunks"))) (raise-syntax-error 'scribble/lp "no chunks")))
(define orig-stx (syntax-case stx () [(_ orig) #'orig])) (define orig-stx (syntax-case stx () [(_ orig) #'orig]))
(define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) (define (restore nstx d) (datum->syntax orig-stx d nstx nstx))
(define (shift nstx) (datum->syntax orig-stx (syntax-e nstx) nstx nstx)) (define (shift nstx) (replace-context orig-stx nstx))
(define body (define body
(let ([main-id (or main-id first-id)]) (let ([main-id (or main-id first-id)])
(restore (restore

7
collects/scribblings/raco/decompile.scrbl
View File

@ -132,9 +132,12 @@ Consumes the result of parsing bytecode and returns an S-expression
@defmodule[compiler/zo-marshal] @defmodule[compiler/zo-marshal]
@defproc[(zo-marshal-to [top compilation-top?] [out output-port?]) void?]{
Consumes a representation of bytecode and writes it to @racket[out].}
@defproc[(zo-marshal [top compilation-top?]) bytes?]{ @defproc[(zo-marshal [top compilation-top?]) bytes?]{
Consumes a representation of bytecode and generates a byte string for Consumes a representation of bytecode and generates a byte string for
the marshaled bytecode. Currently, syntax objects are not supported, the marshaled bytecode.}
including in @racket[req] for a top-level @racket[#%require].}

6
collects/scribblings/reference/numbers.scrbl
View File

@ -253,8 +253,8 @@ otherwise.}
@mz-examples[(remainder 10 3) (remainder -10.0 3) (remainder 10.0 -3) (remainder -10 -3) (remainder +inf.0 3)]} @mz-examples[(remainder 10 3) (remainder -10.0 3) (remainder 10.0 -3) (remainder -10 -3) (remainder +inf.0 3)]}
@defproc[(quotient/remainder [n integer?] [m integer?]) (values number? number?)]{ Returns @defproc[(quotient/remainder [n integer?] [m integer?]) (values integer? integer?)]{ Returns
@racket[(values (quotient n m) (remainder n m))], but the combination is computed @racket[(values (quotient n m) (remainder n m))], but the combination may be computed
more efficiently than separate calls to @racket[quotient] and @racket[remainder]. more efficiently than separate calls to @racket[quotient] and @racket[remainder].
@mz-examples[ @mz-examples[
@ -262,7 +262,7 @@ otherwise.}
]} ]}
@defproc[(modulo [n integer?] [m integer?]) number?]{ Returns @defproc[(modulo [n integer?] [m integer?]) integer?]{ Returns
@racket[_q] with the same sign as @racket[m] where @racket[_q] with the same sign as @racket[m] where
@itemize[ @itemize[

2
collects/scribblings/reference/pretty-print.scrbl
View File

@ -20,7 +20,7 @@ In addition to the parameters defined in this section,
@scheme[pretty-print] conforms to the @scheme[print-graph], @scheme[pretty-print] conforms to the @scheme[print-graph],
@scheme[print-struct], @scheme[print-hash-table], @scheme[print-struct], @scheme[print-hash-table],
@scheme[print-vector-length], @scheme[print-box], and @scheme[print-vector-length], @scheme[print-box], and
@scheme[print-as-quasiquote] parameters. @scheme[print-as-expression] parameters.
The pretty printer detects structures that have the The pretty printer detects structures that have the
@scheme[prop:custom-write] property and it calls the corresponding @scheme[prop:custom-write] property and it calls the corresponding

2
collects/scribblings/reference/sequences.scrbl
View File

@ -193,7 +193,7 @@ its value from @scheme[hash] (as opposed to using @scheme[hash] directly
as a sequence to get the key and value as separate values for each as a sequence to get the key and value as separate values for each
element).} element).}
@defproc[(in-directory [dir (or/c #f path-string?)]) sequence?]{ @defproc[(in-directory [dir (or/c #f path-string?) #f]) sequence?]{
Return a sequence that produces all of the paths for files, Return a sequence that produces all of the paths for files,
directories, and links with @racket[dir]. If @racket[dir] is not directories, and links with @racket[dir]. If @racket[dir] is not

9
collects/scribblings/reference/time.scrbl
View File

@ -15,7 +15,6 @@ The value of @racket[(current-seconds)] increases as time passes
seconds can be compared with a time returned by seconds can be compared with a time returned by
@racket[file-or-directory-modify-seconds].} @racket[file-or-directory-modify-seconds].}
@defproc[(seconds->date [secs-n exact-integer?]) date?]{ @defproc[(seconds->date [secs-n exact-integer?]) date?]{
Takes @racket[secs-n], a platform-specific time in seconds returned by Takes @racket[secs-n], a platform-specific time in seconds returned by
@ -125,6 +124,10 @@ result is the result of @racket[expr].}
@note-lib-only[racket/date] @note-lib-only[racket/date]
@defproc[(current-date) date?]{
An abbreviation for @racket[(seconds->date (current-seconds))].}
@defproc[(date->string [date date?] [time? any/c #f]) string?]{ @defproc[(date->string [date date?] [time? any/c #f]) string?]{
Converts a date to a string. The returned string contains the time of Converts a date to a string. The returned string contains the time of
@ -143,6 +146,10 @@ day only if @racket[time?]. See also @racket[date-display-format].}
Parameter that determines the date string format. The initial format Parameter that determines the date string format. The initial format
is @racket['american].} is @racket['american].}
@defproc[(date->seconds [date date?]) exact-integer?]{
Finds the representation of a date in platform-specific seconds. If
the platform cannot represent the specified date, an error is
signaled, otherwise an integer is returned. }
@defproc[(find-seconds [second (integer-in 0 61)] @defproc[(find-seconds [second (integer-in 0 61)]
[minute (integer-in 0 59)] [minute (integer-in 0 59)]

15
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -162,7 +162,7 @@ The design of a world program demands that you come up with a data
(on-tick tick-expr rate-expr) (on-tick tick-expr rate-expr)
(on-key key-expr) (on-key key-expr)
(on-release release-expr) (on-release release-expr)
(on-mouse key-expr) (on-mouse mouse-expr)
(to-draw draw-expr) (to-draw draw-expr)
(to-draw draw-expr width-expr height-expr) (to-draw draw-expr width-expr height-expr)
(stop-when stop-expr) (stop-when stop-expr last-scene-expr) (stop-when stop-expr) (stop-when stop-expr last-scene-expr)
@ -371,17 +371,22 @@ All @tech{MouseEvent}s are represented via strings:
@defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{ @defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{
compares two @tech{MouseEvent}s for equality} compares two @tech{MouseEvent}s for equality}
@defform[(on-mouse clack-expr) @defform[(on-mouse mouse-expr)
#:contracts #:contracts
([clack-expr ([clack-expr
(-> (unsyntax @tech{WorldState}) (-> (unsyntax @tech{WorldState})
natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) integer? integer? (unsyntax @tech{MouseEvent})
(unsyntax @tech{WorldState}))])]{ (unsyntax @tech{WorldState}))])]{
tell DrRacket to call @scheme[clack-expr] on the current world, the current tell DrRacket to call @scheme[clack-expr] on the current world, the current
@scheme[x] and @scheme[y] coordinates of the mouse, and and a @scheme[x] and @scheme[y] coordinates of the mouse, and and a
@tech{MouseEvent} for every (noticeable) action of the mouse by the @tech{MouseEvent} for every (noticeable) action of the mouse by the
computer user. The result of the call becomes the current world. computer user. The result of the call becomes the current world.
For @scheme["leave"] and @scheme["enter"] events, the coordinates of the
mouse click may be outside of the (implicitly) rectangle. That is, the
coordinates may be negative or larger than the (implicitly) specified
width and height.
Note: the computer's software doesn't really notice every single movement Note: the computer's software doesn't really notice every single movement
of the mouse (across the mouse pad). Instead it samples the movements and of the mouse (across the mouse pad). Instead it samples the movements and
signals most of them.} signals most of them.}
@ -694,11 +699,11 @@ As mentioned, all event handlers may return @tech{WorldState}s or
} }
@defform/none[#:literals (on-mouse) @defform/none[#:literals (on-mouse)
(on-mouse clack-expr) (on-mouse mouse-expr)
#:contracts #:contracts
([clack-expr ([clack-expr
(-> (unsyntax @tech{WorldState}) (-> (unsyntax @tech{WorldState})
natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) integer? integer? (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{WorldState}) package?))])]{ (or/c (unsyntax @tech{WorldState}) package?))])]{
} }

27
collects/tests/net/ftp.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang racket
(require net/ftp tests/eli-tester)
(define server "ftp.gnu.org")
(define port 21)
(define user "anonymous")
(define passwd "nonny")
(provide tests)
(define (tests)
(define conn #f)
(define pth "=README-about-.diff-files")
(define tmp-dir (make-temporary-file "ftp~a" 'directory))
(test (ftp-connection? 1) => #f
(set! conn (ftp-establish-connection server port user passwd))
(ftp-connection? conn)
(ftp-cd conn "gnu")
(for ([f (in-list (ftp-directory-list conn))])
(match-define (list type ftp-date name) f)
(test
(ftp-make-file-seconds ftp-date)))
(ftp-download-file conn tmp-dir pth)
(delete-file (build-path tmp-dir pth))
(delete-directory/files tmp-dir)
(ftp-close-connection conn)))

14
collects/tests/net/main.rkt
View File

@ -1,17 +1,19 @@
#lang scheme/base #lang scheme/base
(require tests/eli-tester (require tests/eli-tester
(prefix-in ucodec: "uri-codec.ss") (prefix-in ucodec: "uri-codec.rkt")
(prefix-in url: "url.ss") (prefix-in url: "url.rkt")
(prefix-in cgi: "cgi.ss") (prefix-in cgi: "cgi.rkt")
(prefix-in head: "head.ss") (prefix-in ftp: "ftp.rkt")
(prefix-in cookie: "cookie.ss") (prefix-in head: "head.rkt")
(prefix-in encoders: "encoders.ss")) (prefix-in cookie: "cookie.rkt")
(prefix-in encoders: "encoders.rkt"))
(define (tests) (define (tests)
(test do (begin (url:tests) (test do (begin (url:tests)
(ucodec:tests) (ucodec:tests)
(cgi:tests) (cgi:tests)
(ftp:tests)
(head:tests) (head:tests)
(cookie:tests) (cookie:tests)
(encoders:tests)))) (encoders:tests))))

29
collects/tests/racket/date.rktl
View File

@ -19,6 +19,35 @@
(test-find 0 0 0 1 4 1975) (test-find 0 0 0 1 4 1975)
(test-find 0 0 0 1 4 2005) (test-find 0 0 0 1 4 2005)
; date->string
(let* ([secs (find-seconds 1 2 3 4 5 2006)]
[d (seconds->date secs)])
(define (test-string fmt time? result)
(test (parameterize ([date-display-format fmt])
(date->string d time?))
fmt result))
(test secs date->seconds d)
(test-string 'american #f "Thursday, May 4th, 2006")
(test-string 'american #t "Thursday, May 4th, 2006 3:02:01am")
(test-string 'chinese #f "2006/5/4 星期四")
(test-string 'chinese #t "2006/5/4 星期四 03:02:01")
(test-string 'german #f "4. Mai 2006")
(test-string 'german #t "4. Mai 2006, 03.02")
(test-string 'indian #f "4-5-2006")
(test-string 'indian #t "4-5-2006 3:02:01am")
(test-string 'irish #f "Thursday, 4th May 2006")
(test-string 'irish #t "Thursday, 4th May 2006, 3:02am")
(test-string 'iso-8601 #f "2006-05-04")
(test-string 'iso-8601 #t "2006-05-04 03:02:01")
(test-string 'rfc2822 #f "Thu, 4 May 2006")
(test-string 'rfc2822 #t "Thu, 4 May 2006 03:02:01 -0600")
(test-string 'julian #f "JD 2 453 860")
(test-string 'julian #t "JD 2 453 860, 03:02:01")
(test 2453860 date->julian/scalinger d)
(test "JD 2 453 860" julian/scalinger->string 2453860))
;; Bad dates ;; Bad dates
(err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?) (err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?)
(err/rt-test (find-seconds 0 0 0 0 1 1990) exn:fail?) (err/rt-test (find-seconds 0 0 0 0 1 1990) exn:fail?)

18
collects/tests/unstable/byte-counting-port.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket
(require unstable/byte-counting-port
tests/eli-tester)
(define name (gensym))
(define cp (make-byte-counting-port name))
(define (test-cp cp)
(for/fold ([l 0])
([i (in-range 100)])
(define n (random 25))
(test
(file-position cp) => l
(write-bytes (make-bytes n) cp))
(+ l n)))
(test
(object-name cp) => name
(test-cp cp)
(test-cp (make-byte-counting-port)))

17
collects/unstable/byte-counting-port.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang racket
(define (make-byte-counting-port [name 'byte-counting-port])
(define location 0)
(define (write-out bs starting ending opt1 opt2)
(define how-many-written (- ending starting))
(set! location (+ location how-many-written))
how-many-written)
(define close void)
(define (get-location)
(values #f #f location))
(make-output-port name always-evt write-out close
#f #f #f
get-location))
(provide/contract
[make-byte-counting-port (() (any/c) . ->* . output-port?)])

15
collects/unstable/scribblings/byte-counting-port.scrbl Normal file
View File

@ -0,0 +1,15 @@
#lang scribble/manual
@(require "utils.rkt" (for-label racket unstable/byte-counting-port))
@title{Byte Counting Ports}
@defmodule[unstable/byte-counting-port]
@unstable[@author+email["Jay McCarthy" "jay@racket-lang.org"]]
This library provides an output port constructor like @racket[open-output-nowhere], except it counts how many bytes have been written (available through @racket[file-position].)
@defproc[(make-byte-counting-port [name any/c 'byte-counting-port])
output-port?]{
Creates and returns an output port that discards all output sent to it (without blocking.) The @racket[name] argument is used as the port's name. The total number bytes written is available through @racket[file-position].}

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -95,6 +95,7 @@ Keep documentation and tests up to date.
@include-section["generics.scrbl"] @include-section["generics.scrbl"]
@include-section["markparam.scrbl"] @include-section["markparam.scrbl"]
@include-section["debug.scrbl"] @include-section["debug.scrbl"]
@include-section["byte-counting-port.scrbl"]
@;{--------} @;{--------}

3
src/foreign/README
View File

@ -35,6 +35,9 @@ Local changes:
git master source at http://github.com/atgreen/libffi/, tree git master source at http://github.com/atgreen/libffi/, tree
997968323ed45a5ea5db1ff83124619ae1949bfb. (r18350) 997968323ed45a5ea5db1ff83124619ae1949bfb. (r18350)
* Observing ftruncate result in closures.c to remove warning. (commit
b5ee4ac21b1c4d759659 and c64704742c0963310b49)
Note: recreating "configure" with autoconf 2.61 does not work as is, Note: recreating "configure" with autoconf 2.61 does not work as is,
since the scripts require 2.59. To allow this, the two requirements since the scripts require 2.59. To allow this, the two requirements
in "libffi/configure.ac" and "config/override.m4" were temporarily in "libffi/configure.ac" and "config/override.m4" were temporarily