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

I used to merge a little but a little wouldn't do

Browse Source 
so the little got more and more
I just keep trying to merge a little better
said a little better than before

svn: r11844
This commit is contained in:
Stevie Strickland 2008-09-23 18:41:46 +00:00
commit 6de2993655
10 changed files with 77 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/drscheme/private/debug.ss
View File

@ -338,16 +338,17 @@ profile todo:
;; =User=
(define (parse-gp exn gp)
(match gp
[`(planet ,fn (,user ,package ,version ...))
[`(planet ,fn (,user ,package ,planet-version ...))
(list (cons 'component (format "~a/~a" user package))
(cons 'keywords "contract violation")
(cons 'pltversion (version))
(cons 'planetversion
(cond
[(null? version) ""]
[(null? (cdr version))
(format "~s" `(,(car version) ?))]
[(null? planet-version) ""]
[(null? (cdr planet-version))
(format "~s" `(,(car planet-version) ?))]
[else
(format "~s" `(,(car version) ,(cadr version)))]))
(format "~s" `(,(car planet-version) ,(cadr planet-version)))]))
(cons 'description (exn->trace exn)))]
[else #f]))

12
collects/help/search.ss
View File

@ -14,6 +14,18 @@
[path (if (file-exists? path) path (build-path (find-doc-dir) sub))])
(send-url/file path #:fragment fragment #:query query)))
;; This is an example of changing this code to use the online manuals.
;; Useful in cases like schools that use systems that have problems
;; running a browser on local files (like NEU). If you use this, then
;; it is a good idea to put the documentation tree somewhere local, to
;; have better interaction times and not overload the PLT server.
;; (define doc-url "http://download.plt-scheme.org/doc/4.1/html/")
;; (define (send-main-page #:sub [sub "index.html"]
;; #:fragment [fragment #f] #:query [query #f])
;; (define (part pfx x) (if x (list pfx x) '()))
;; (send-url (apply string-append doc-url sub
;; (append (part "#" fragment) (part "?" query)))))
(define (perform-search str [context #f])
;; `context' can be a pre-filter query string to use for a context,
;; optionally a list of one and a label to display for that context.

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "22sep2008")
#lang scheme/base (provide stamp) (define stamp "23sep2008")

2
collects/setup/private/omitted-paths.ss
View File

@ -43,7 +43,7 @@
(if (eof-object? x)
(reverse r)
(let* ([x (and (list? x) (= 7 (length x)) (list-ref x 4))]
[x (and (bytes? x) (bytes->path x))])
[x (and (bytes? x) (simplify-path (bytes->path x)))])
(loop (if x (cons x r) r)))))))))))))
;; if `x' has `y' as a prefix, return the tail,

19
collects/teachpack/htdp/scribblings/world.scrbl
View File

@ -71,7 +71,7 @@ pinholes are at position @scheme[(0,0)].
for describing students work.
}
In addition,
Example:
@schemeblock[
(define (create-UFO-scene height)
(place-image UFO 50 height (empty-scene 100 100)))
@ -174,6 +174,23 @@ A @tech{KeyEvent} represents key board events, e.g., keys pressed or
tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to
the respective handlers. As a result, the canvas isn't updated either.}
Example: The following examples shows that @scheme[(run-simulation 100 100
(/ 1 28) create-UFO-scene)] is a short-hand for three lines of code:
@schemeblock[
(define (create-UFO-scene height)
(place-image UFO 50 height (empty-scene 100 100)))
(define UFO
(overlay (circle 10 'solid 'green)
(rectangle 40 4 'solid 'green)))
(big-bang 100 100 (/1 28) 0)
(on-tick-event add1)
(on-redraw create-UFO-scene)
]
Exercise: Add a condition for stopping the flight of the UFO when it
reaches the bottom.
@section{Scenes and Images}
For the creation of scenes from the world, use the functions from @secref["image"]. The following two

1
collects/typed-scheme/private/base-env.ss
View File

@ -130,6 +130,7 @@
(eof-object? (make-pred-ty (-val eof)))
[null (-val null)]
(number? (make-pred-ty N))
[char? (make-pred-ty -Char)]
(integer? (make-pred-ty -Integer))
(boolean? (make-pred-ty B))
(add1 (cl->*

6
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -104,8 +104,10 @@
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #f (cons dty dbound) null null))
(define (make-promise-ty t)
(make-Struct (string->uninterned-symbol "Promise") #f (list t) #f #f #'promise? values))
(define make-promise-ty
(let ([s (string->uninterned-symbol "Promise")])
(lambda (t)
(make-Struct s #f (list t) #f #f #'promise? values))))
(define N (make-Base 'Number))
(define -Integer (make-Base 'Integer))

3
collects/typed-scheme/private/type-utils.ss
View File

@ -163,7 +163,8 @@
(match t
[(PolyDots: (list fixed ... dotted) body)
(unless (= (length fixed) (length types))
(int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a" (length fixed) (length types)))
(int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a, types were ~a"
(length fixed) (length types) types))
(let ([body* (subst-all (map list fixed types) body)])
(substitute-dotted image var dotted body*))]
[_ (int-err "instantiate-poly-dotted: requires PolyDots type, got ~a" t)]))

19
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -606,10 +606,27 @@
[(Value: '()) null]
[_ (int-err "bad value in type->list: ~a" t)]))
;; id: identifier
;; sym: a symbol
;; mod: a quoted require spec like 'scheme/base
;; is id the name sym defined in mod?
(define (id-from? id sym mod)
(and (eq? (syntax-e id) sym)
(eq? (module-path-index-resolve (syntax-source-module id))
((current-module-name-resolver) mod #f #f #f))))
(define (tc/app/internal form expected)
(kernel-syntax-case* form #f
(values apply not list list* call-with-values do-make-object make-object cons
andmap ormap) ;; the special-cased functions
andmap ormap) ;; the special-cased functions
;; special case for delay
[(#%plain-app
mp1
(#%plain-lambda ()
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
(and (id-from? #'mp1 'make-promise 'scheme/promise)
(id-from? #'mp2 'make-promise 'scheme/promise))
(ret (-Promise (tc-expr/t #'e)))]
;; special cases for classes
[(#%plain-app make-object cl . args)
(check-do-make-object #'cl #'args #'() #'())]

24
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -46,6 +46,7 @@
[else Univ]))
;; do-inst : syntax type -> type
(define (do-inst stx ty)
(define inst (syntax-property stx 'type-inst))
(define (split-last l)
@ -53,16 +54,16 @@
(values all-but (car last-list))))
(cond [(not inst) ty]
[(not (or (Poly? ty) (PolyDots? ty)))
(tc-error/expr #:return (ret (Un)) "Cannot instantiate non-polymorphic type ~a" ty)]
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
[(and (Poly? ty)
(not (= (length (syntax->list inst)) (Poly-n ty))))
(tc-error/expr #:return (ret (Un))
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (Poly-n ty) (length (syntax->list inst)))]
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
;; we can provide 0 arguments for the ... var
(tc-error/expr #:return (ret (Un))
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
[(PolyDots? ty)
@ -73,13 +74,16 @@
[(cons last-ty-stx (? identifier? last-id-stx))
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
(let* ([last-id (syntax-e last-id-stx)]
[last-ty
(parameterize ([current-tvars (extend-env (list last-id)
(list (make-DottedBoth (make-F last-id)))
(current-tvars))])
(parse-type last-ty-stx))])
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))]
(if (= (length all-but-last) (sub1 (PolyDots-n ty)))
(let* ([last-id (syntax-e last-id-stx)]
[last-ty
(parameterize ([current-tvars (extend-env (list last-id)
(list (make-DottedBoth (make-F last-id)))
(current-tvars))])
(parse-type last-ty-stx))])
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))
(tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length all-but-last)))]
[_
(instantiate-poly ty (map parse-type (syntax->list inst)))]))]
[else