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
;; 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)
(define/chk (rotate angle image)
(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"
"stop.ss"
"universe-image.ss"
"utilities.rkt"
htdp/error
mzlib/runtime-path
mrlib/bitmap-label

9
collects/compiler/decompile.rkt
View File

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

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

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

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

@ -359,8 +359,16 @@
(define (read-simple-number p)
(integer-bytes->integer (read-bytes 4 p) #f #f))
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis))
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start 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)
(+ (cport-pos cp) (cport-shared-start cp)))
@ -369,8 +377,7 @@
(begin-with-definitions
(when ((cport-pos cp) . >= . (cport-size cp))
(error "off the end"))
(define r
(bytes-ref (cport-bytes cp) (cport-pos cp)))
(define r (cport-get-byte cp (cport-pos cp)))
(set-cport-pos! cp (add1 (cport-pos cp)))
r))
@ -436,7 +443,7 @@
(define (read-compact-bytes port c)
(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)))))
(define (read-compact-chars port c)
@ -742,7 +749,7 @@
v)))]
[(escape)
(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))
(parameterize ([read-accept-compiled #t]
[read-accept-bar-quote #t]
@ -976,17 +983,16 @@
(when (shared-size . >= . size*)
(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))
(error 'not-end))
(unless (= size* (bytes-length rst))
(error "wrong number of bytes"))
(error 'zo-parse "File too big"))
(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)])
(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
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"]
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>
<input>
<tests>
<initial-world>
<tests>
<go>]
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>
<change>
<release>
<clack>
<update-world-posn>
<player-moved?>
@ -1110,6 +1114,7 @@ plus various helper functions.
@chunk[<input-tests>
<change-tests>
<release-tests>
<point-in-this-circle?-tests>
<circle-at-point-tests>
<lt/f-tests>
@ -1118,22 +1123,41 @@ plus various helper functions.
<update-world-posn-tests>
<clack-tests>]
The @scheme[change] function handles keyboard input and merely updates the @tt{h-down?} field
based on the state of the key event during gameplay. Once the game has ended it resets to the
initial world when the user presses @litchar{n}.
The @scheme[change] function handles keyboard input. If the input is @litchar{n} and the
game is over, then restart the game. If the input is @litchar{h} then turn on the help
and otherwise do nothing.
@chunk[<change>
;; change : world key-event -> world
(define (change w ke)
(if (and (not (equal? (world-state w) 'playing))
(key=? ke "n"))
(make-initial-world)
(make-world (world-board w)
(world-cat w)
(world-state w)
(world-size w)
(world-mouse-posn w)
(key=? ke "h"))))]
(cond
[(key=? ke "n")
(if (equal? (world-state w) 'playing)
w
(make-initial-world))]
[(key=? ke "h")
(make-world (world-board w)
(world-cat w)
(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
to a helper function:
@ -2253,7 +2277,23 @@ and reports the results.
'playing 3 (make-posn 0 0) #f)
"h")
(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>
@ -2362,5 +2402,6 @@ by calling @scheme[big-bang] with the appropriate arguments.
(world-width board-size)
(world-height board-size))
(on-key change)
(on-release release)
(on-mouse clack)
(name "Chat Noir"))))]

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

@ -150,15 +150,18 @@
; 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 (symbol=? id 'changes))))))
(unless (andmap zero? nums)
(send-mail-message "drdr@plt-scheme.org"
(define mail-recipients
(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"
cur-rev totals)
(map (curry format "~a@plt-scheme.org")
(append (if include-committer?
(list committer)
empty)
responsibles))
(map (curry format "~a@racket-lang.org")
mail-recipients)
empty empty
(flatten
(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-unit-contracts.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/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *)
"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-scheme" responsible (samth)
"collects/unstable" responsible (jay samth cce ryanc)
"collects/unstable/byte-counting-port.rkt" responsible (jay)
"collects/unstable/debug.rkt" responsible (samth)
"collects/unstable/gui/notify.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/mutated-vars.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/hash.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
date-display-format
find-seconds
date->julian/scalinger
julian/scalinger->string)
;; Support for Julian calendar added by Shriram;
;; current version only works until 2099 CE Gregorian
(define date-display-format
(make-parameter 'american))
;; Support for Julian calendar added by Shriram;
;; current version only works until 2099 CE Gregorian
(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 ""]))
#|
(define (day/number->string x)
(case x
[(0) "Sunday"]
[(1) "Monday"]
[(2) "Tuesday"]
[(3) "Wednesday"]
[(4) "Thursday"]
[(5) "Friday"]
[(6) "Saturday"]
[else ""]))
(define-primitive seconds->date (num -> structure:date))
(define-primitive current-seconds (-> num))
(define-primitive date-second (structure:date -> num))
(define-primitive date-minute (structure:date -> num))
(define-primitive date-hour (structure:date -> num))
(define-primitive date-day (structure:date -> num))
(define-primitive date-month (structure:date -> num))
(define-primitive date-year (structure:date -> num))
(define-primitive date-week-day (structure:date -> num))
(define-primitive date-year-day (structure:date -> num))
(define-primitive date-dst? (structure:date -> bool))
(define-primitive make-date (num num num num num num num num bool ->
structure:date))
(define-primitive expr->string (a -> string))
(define-primitive foldl (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
(define-primitive foldr (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
(define (add-zero n)
(if (< n 10)
(string-append "0" (number->string n))
(number->string n)))
|#
(define (date->string date [time? #f])
(define year (number->string (date-year date)))
(define num-month (number->string (date-month date)))
(define week-day (day/number->string (date-week-day date)))
(define week-day-num (date-week-day date))
(define month (month/number->string (date-month date)))
(define day (number->string (date-day date)))
(define day-th
(if (<= 11 (date-day date) 13)
"th"
(case (modulo (date-day date) 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[(0 4 5 6 7 8 9) "th"])))
(define hour (date-hour date))
(define am-pm (if (>= hour 12) "pm" "am"))
(define hour24 (add-zero hour))
(define hour12
(number->string
(cond
[(zero? hour) 12]
[(> hour 12) (- hour 12)]
[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 legal-formats
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
(define (leap-year? year)
(or (= 0 (modulo year 400))
(and (= 0 (modulo year 4))
(not (= 0 (modulo year 100))))))
(define date-display-format
(make-parameter 'american
(lambda (s)
(unless (memq s legal-formats)
(raise-type-error 'date-display-format
(format "symbol in ~a" legal-formats)
s))
s)))
;; it's not clear what months mean in this context -- use days
(define-struct date-offset (second minute hour day year))
(define month/number->string
(lambda (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 ""])))
(define day/number->string
(lambda (x)
(case x
[(0) "Sunday"]
[(1) "Monday"]
[(2) "Tuesday"]
[(3) "Wednesday"]
[(4) "Thursday"]
[(5) "Friday"]
[(6) "Saturday"]
[else ""])))
(define (fixup s x) (if (< s 0) (+ s x) s))
(define (date- date1 date2)
(define second (- (date-second date1) (date-second date2)))
(define minute
(+ (- (date-minute date1) (date-minute date2))
(if (< second 0) -1 0)))
(define hour
(+ (- (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 date->string
(case-lambda
[(date) (date->string date #f)]
[(date time?)
(let* ((add-zero (lambda (n) (if (< n 10)
(string-append "0" (number->string n))
(number->string n))))
(year (number->string (date-year date)))
(num-month (number->string (date-month date)))
(week-day (day/number->string (date-week-day date)))
(week-day-num (date-week-day date))
(month (month/number->string (date-month date)))
(day (number->string (date-day date)))
(day-th (if (<= 11 (date-day date) 13)
"th"
(case (modulo (date-day date) 10)
[(1) "st"]
[(2) "nd"]
[(3) "rd"]
[(0 4 5 6 7 8 9) "th"])))
(hour (date-hour date))
(am-pm (if (>= hour 12) "pm" "am"))
(hour24 (add-zero hour))
(hour12 (number->string
(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?
(lambda (year)
(or (= 0 (modulo year 400))
(and (= 0 (modulo year 4))
(not (= 0 (modulo year 100)))))))
(define (one-entry b)
(string-append
(number->string (first b))
" "
(second b)
(if (= 1 (first b)) "" "s")))
(define (date-offset->string date [seconds? #f])
(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)]))]))
;; it's not clear what months mean in this context -- use days
(define-struct date-offset (second minute hour day year))
(define (days-per-month year month)
(cond
[(and (= month 2) (leap-year? year)) 29]
[(= month 2) 28]
[(<= month 7) (+ 30 (modulo month 2))]
[else (+ 30 (- 1 (modulo month 2)))]))
(define date-
(lambda (date1 date2)
(let* ((second (- (date-second date1) (date-second date2)))
(minute (+ (- (date-minute date1) (date-minute date2))
(if (< second 0) -1 0)))
(hour (+ (- (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])))
(day (+ (- (date-year-day date1) (date-year-day date2))
(if (< hour 0) -1 0)))
(year (+ (- (date-year date1) (date-year date2))
(if (< day 0) -1 0)))
(fixup (lambda (s x) (if (< s 0) (+ s x) s))))
(make-date-offset (fixup second 60)
(fixup minute 60)
(fixup hour 24)
(fixup day (if (leap-year? (date-year date1)) 366 365))
year))))
(define (find-extreme-date-seconds start offset)
(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
(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 date-offset->string
(let ((first car)
(second cadr))
(case-lambda
[(date) (date-offset->string date #f)]
[(date seconds?)
(let* ((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")))
(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 (date->seconds date)
(find-seconds
(date-second date)
(date-minute date)
(date-hour date)
(date-day date)
(date-month date)
(date-year date)))
(define days-per-month
(lambda (year month)
(define (find-seconds sec min hour day month year)
(define (signal-error msg)
(error 'find-secs (string-append
msg
" (inputs: ~a ~a ~a ~a ~a ~a)")
sec min hour day month year))
(let loop ([below-secs (get-min-seconds)]
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
[above-secs (get-max-seconds)])
(let* ([date (seconds->date secs)]
[compare
(let loop ([inputs (list year month day
hour min sec)]
[tests (list (date-year date)
(date-month date)
(date-day date)
(date-hour date)
(date-minute date)
(date-second date))])
(cond
[(null? inputs) 'equal]
[else (let ([input (car inputs)]
[test (car tests)])
(if (= input test)
(loop (cdr inputs) (cdr tests))
(if (<= input test)
'input-smaller
'test-smaller)))]))])
; (printf "~a ~a ~a~n" compare secs (date->string date))
(cond
[(and (= month 2) (leap-year? year)) 29]
[(= month 2) 28]
[(<= month 7) (+ 30 (modulo month 2))]
[else (+ 30 (- 1 (modulo month 2)))])))
[(eq? compare 'equal) secs]
[(or (= secs below-secs) (= secs above-secs))
(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)]))))
(define find-extreme-date-seconds
(lambda (start offset)
(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))))))))
;; date->julian/scalinger :
;; date -> number [julian-day]
(define get-min-seconds
(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))))
;; Note: This code is correct until 2099 CE Gregorian
(define find-seconds
(lambda (sec min hour day month year)
(let ([signal-error
(lambda (msg)
(error 'find-secs (string-append
msg
" (inputs: ~a ~a ~a ~a ~a ~a)")
sec min hour day month year))])
(let loop ([below-secs (get-min-seconds)]
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
[above-secs (get-max-seconds)])
(let* ([date (seconds->date secs)]
[compare
(let loop ([inputs (list year month day
hour min sec)]
[tests (list (date-year date)
(date-month date)
(date-day date)
(date-hour date)
(date-minute date)
(date-second date))])
(cond
[(null? inputs) 'equal]
[else (let ([input (car inputs)]
[test (car tests)])
(if (= input test)
(loop (cdr inputs) (cdr tests))
(if (<= input test)
'input-smaller
'test-smaller)))]))])
; (printf "~a ~a ~a~n" compare secs (date->string date))
(cond
[(eq? compare 'equal) secs]
[(or (= secs below-secs) (= secs above-secs))
(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)]))))))
(define (date->julian/scalinger date)
(define day (date-day date))
(define month (date-month date))
(define d-year (date-year date))
(define year (+ 4712 d-year))
(define adj-year (if (< month 3) (sub1 year) year))
(define cycle-number (quotient adj-year 4))
(define cycle-position (remainder adj-year 4))
(define base-day (+ (* 1461 cycle-number) (* 365 cycle-position)))
(define 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)))
(define total-days (+ base-day month-day-number day))
(define total-days/march-adjustment (+ total-days 59))
(define gregorian-adjustment
(cond
((< adj-year 1700) 11)
((< adj-year 1800) 12)
(else 13)))
(define final-date
(- total-days/march-adjustment
gregorian-adjustment))
final-date)
;; date->julian/scalinger :
;; date -> number [julian-day]
;; 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))))))))))))
)
;; 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))))))))))))

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

@ -1,4 +1,4 @@
#lang scheme/signature
#lang racket/signature
ftp-connection?
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.1a
;; Micah Flatt
;; 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)
(export ftp^)
@ -197,7 +197,7 @@
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile 'replace)]
[new-file (open-output-file tmpfile #:exists 'replace)]
[tcpstring (bytes-append #"RETR "
(string->bytes/locale filename)
#"\n")]

4
collects/net/ftp.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "ftp-sig.ss" "ftp-unit.ss")
#lang racket/base
(require racket/unit "ftp-sig.rkt" "ftp-unit.rkt")
(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
semantics.
@ -6,20 +6,20 @@ semantics.
== 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
run (each test that explores more than 100 states shows a
colon for each 100 states it explores). To see a more
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
examples in a GUI. Its content shows how to use it and
gives a few examples. Either run it in DrRacket's module
language, or like this from the commandline:
mred show-examples.ss
gracket show-examples.ss
== 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
;; if any of the terms in the graph don't
;; match p*, they will be colored red
;; #; comments out an entire sexpression.
;;
#;
(show '(store () (((lambda (x y) (set! x (+ x y)) x) 2 3))))
;; an infinite, tail-recursive loop
#;
(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
;; one goes into a non-tail infinite loop, the other's reduction graph has a cycle
#;
(step '(store ()
((call/cc call/cc)
(call/cc call/cc))))
;; demonstrates sharing
#;
(show-expression
'((lambda (c)
((lambda (x y)

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

@ -41,7 +41,7 @@
(raise-syntax-error 'scribble/lp "no chunks")))
(define orig-stx (syntax-case stx () [(_ orig) #'orig]))
(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
(let ([main-id (or main-id first-id)])
(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]
@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?]{
Consumes a representation of bytecode and generates a byte string for
the marshaled bytecode. Currently, syntax objects are not supported,
including in @racket[req] for a top-level @racket[#%require].}
the marshaled bytecode.}

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)]}
@defproc[(quotient/remainder [n integer?] [m integer?]) (values number? number?)]{ Returns
@racket[(values (quotient n m) (remainder n m))], but the combination is computed
@defproc[(quotient/remainder [n integer?] [m integer?]) (values integer? integer?)]{ Returns
@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].
@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
@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[print-struct], @scheme[print-hash-table],
@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
@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
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,
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
@racket[file-or-directory-modify-seconds].}
@defproc[(seconds->date [secs-n exact-integer?]) date?]{
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]
@defproc[(current-date) date?]{
An abbreviation for @racket[(seconds->date (current-seconds))].}
@defproc[(date->string [date date?] [time? any/c #f]) string?]{
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
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)]
[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-key key-expr)
(on-release release-expr)
(on-mouse key-expr)
(on-mouse mouse-expr)
(to-draw draw-expr)
(to-draw draw-expr width-expr height-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?]{
compares two @tech{MouseEvent}s for equality}
@defform[(on-mouse clack-expr)
@defform[(on-mouse mouse-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{WorldState})
natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
integer? integer? (unsyntax @tech{MouseEvent})
(unsyntax @tech{WorldState}))])]{
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
@tech{MouseEvent} for every (noticeable) action of the mouse by the
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
of the mouse (across the mouse pad). Instead it samples the movements and
signals most of them.}
@ -694,11 +699,11 @@ As mentioned, all event handlers may return @tech{WorldState}s or
}
@defform/none[#:literals (on-mouse)
(on-mouse clack-expr)
(on-mouse mouse-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{WorldState})
natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
integer? integer? (unsyntax @tech{MouseEvent})
(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
(require tests/eli-tester
(prefix-in ucodec: "uri-codec.ss")
(prefix-in url: "url.ss")
(prefix-in cgi: "cgi.ss")
(prefix-in head: "head.ss")
(prefix-in cookie: "cookie.ss")
(prefix-in encoders: "encoders.ss"))
(prefix-in ucodec: "uri-codec.rkt")
(prefix-in url: "url.rkt")
(prefix-in cgi: "cgi.rkt")
(prefix-in ftp: "ftp.rkt")
(prefix-in head: "head.rkt")
(prefix-in cookie: "cookie.rkt")
(prefix-in encoders: "encoders.rkt"))
(define (tests)
(test do (begin (url:tests)
(ucodec:tests)
(cgi:tests)
(ftp:tests)
(head:tests)
(cookie: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 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
(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?)

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["markparam.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
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,
since the scripts require 2.59. To allow this, the two requirements
in "libffi/configure.ac" and "config/override.m4" were temporarily