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

More hot merging action

Browse Source 
svn: r11891
This commit is contained in:
Stevie Strickland 2008-09-27 20:33:33 +00:00
commit 154f988722
12 changed files with 207 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/handin-server/checker.ss
View File

@ -36,7 +36,7 @@
(path->string (current-directory)))])
(if m
(cadr m)
(error* "internal error: unexpected directory name: ~a"
(error* "internal error: unexpected directory name: \"~a\""
(current-directory)))))
(provide user-data)
@ -78,7 +78,7 @@
(let ([line (bytes->string/utf-8 line)])
(unless (or (< (string-length line) len)
(< (string-width line) len))
(error* "~a \"~a\" in ~a is longer than ~a characters"
(error* "~a \"~a\" in \"~a\" is longer than ~a characters"
(if n (format "Line #~a" n) "The line")
(regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1")
(currently-processed-file-name)
@ -164,7 +164,7 @@
[line (if (and untabify? (regexp-match? #rx"\t" line))
(untabify line) line)])
(when (and bad-re (regexp-match? bad-re line))
(error* "You cannot use \"~a\" in ~a!~a"
(error* "You cannot use \"~a\" in \"~a\"!~a"
(if (regexp? bad-re) (object-name bad-re) bad-re)
(currently-processed-file-name)
(if textualize? "" (format " (line ~a)" n))))
@ -546,7 +546,7 @@
;; "`textualize?' and `coverage?'"]
[else #f])])
(when bad
(error* "bad checker specifications: ~a" bad)))
(error* "bad checker specifications: ~e" bad)))
;; ========================================
(list pre check post)))))])))
@ -657,7 +657,7 @@
;; expected to be used only with identifiers
(begin (with-handlers ([exn:fail:contract:variable?
(lambda (_)
(error* "missing binding: ~a" (->disp 'id)))])
(error* "missing binding: ~e" (->disp 'id)))])
((submission-eval) `id))
...))
@ -666,14 +666,14 @@
(syntax-rules ()
[(_ expr)
(unless (procedure? ((submission-eval) `expr))
(error* "~a is expected to be bound to a procedure" (->disp 'expr)))]
(error* "~e is expected to be bound to a procedure" (->disp 'expr)))]
[(_ expr arity)
(let ([ar arity]
[val ((submission-eval) `expr)])
(unless (procedure? val)
(error* "~a is expected to be bound to a procedure" (->disp 'expr)))
(error* "~e is expected to be bound to a procedure" (->disp 'expr)))
(unless (procedure-arity-includes? val ar)
(error* "~a is expected to be bound to a procedure of ~s arguments"
(error* "~e is expected to be bound to a procedure of ~s arguments"
(->disp 'expr) ar)))]))
(define-syntax !procedure
(syntax-rules ()
@ -683,7 +683,7 @@
(provide !integer* !integer)
(define-syntax-rule (!integer* expr)
(unless (integer? ((submission-eval) `expr))
(error* "~a is expected to be bound to an integer" (->disp 'expr))))
(error* "~e is expected to be bound to an integer" (->disp 'expr))))
(define-syntax-rule (!integer id)
(begin (!defined id) (!integer* id)))
@ -695,12 +695,12 @@
(syntax-rules ()
[(_ expr)
(unless ((submission-eval) `expr)
(error* "your code failed a test: ~a is false" (->disp 'expr)))]
(error* "your code failed a test: ~e is false" (->disp 'expr)))]
[(_ expr result) (!test expr result equal?)]
[(_ expr result equal?)
(let ([val ((submission-eval) `expr)])
(unless (equal? result val)
(error* "your code failed a test: ~a evaluated to ~a, expecting ~a"
(error* "your code failed a test: ~e evaluated to ~e, expecting ~e"
(->disp 'expr) (->disp val) (->disp result))))]))
(provide !all-covered)

3
collects/handin-server/overridden-collects/fake-teachpack/htdp/guess.ss
View File

@ -11,9 +11,6 @@
(define-higher-order-primitive guess-with-gui-list guess-with-gui-list/proc
(_ check-guess-list))
(define (convert guesses:vec)
(void))
(define (guess-with-gui/proc cg)
(check-proc 'guess-with-gui cg 2 'first "two arguments")
(void))

11
collects/handin-server/overridden-collects/fake-teachpack/htdp/master.ss Normal file
View File

@ -0,0 +1,11 @@
#lang scheme/gui
(require htdp/error lang/prim)
(provide master)
(define-higher-order-primitive master master/proc (compare-guess))
(define (master/proc cg)
(check-proc 'master cg 4 'first 'arguments)
(void))

2
collects/handin-server/utils.ss
View File

@ -154,7 +154,7 @@
(parameterize ([pretty-print-show-inexactness #t]
[pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t]
[pretty-print-columns +inf.0]
[pretty-print-columns 'infinity]
[read-case-sensitive #t])
(let ([p (open-output-string)])
(pretty-print (value-converter v) p)

64
collects/mzlib/foreign.ss
View File

@ -1176,40 +1176,36 @@
[error-str (format "~a`~a' pointer"
(if nullable? "" "non-null ") tag)]
[error* (lambda (p) (raise-type-error tag->C error-str p))])
(let-syntax ([tag-or-error
(syntax-rules ()
[(tag-or-error ptr t)
(let ([p ptr])
(if (cpointer? p)
(unless (cpointer-has-tag? p t) (error* p))
(error* p)))])]
[tag-or-error/null
(syntax-rules ()
[(tag-or-error/null ptr t)
(let ([p ptr])
(if (cpointer? p)
(when p (unless (cpointer-has-tag? p t) (error* p)))
(error* p)))])])
(make-ctype (or ptr-type _pointer)
;; bad hack: `if's outside the lambda for efficiency
(if nullable?
(if scheme->c
(lambda (p) (tag-or-error/null (scheme->c p) tag) p)
(lambda (p) (tag-or-error/null p tag) p))
(if scheme->c
(lambda (p) (tag-or-error (scheme->c p) tag) p)
(lambda (p) (tag-or-error p tag) p)))
(if nullable?
(if c->scheme
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
(lambda (p) (when p (cpointer-push-tag! p tag)) p))
(if c->scheme
(lambda (p)
(if p (cpointer-push-tag! p tag) (error* p))
(c->scheme p))
(lambda (p)
(if p (cpointer-push-tag! p tag) (error* p))
p))))))]))
(define-syntax-rule (tag-or-error ptr t)
(let ([p ptr])
(if (cpointer? p)
(if (cpointer-has-tag? p t) p (error* p))
(error* p))))
(define-syntax-rule (tag-or-error/null ptr t)
(let ([p ptr])
(if (cpointer? p)
(and p (if (cpointer-has-tag? p t) p (error* p)))
(error* p))))
(make-ctype (or ptr-type _pointer)
;; bad hack: `if's outside the lambda for efficiency
(if nullable?
(if scheme->c
(lambda (p) (tag-or-error/null (scheme->c p) tag))
(lambda (p) (tag-or-error/null p tag)))
(if scheme->c
(lambda (p) (tag-or-error (scheme->c p) tag))
(lambda (p) (tag-or-error p tag))))
(if nullable?
(if c->scheme
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
(lambda (p) (when p (cpointer-push-tag! p tag)) p))
(if c->scheme
(lambda (p)
(if p (cpointer-push-tag! p tag) (error* p))
(c->scheme p))
(lambda (p)
(if p (cpointer-push-tag! p tag) (error* p))
p)))))]))
;; This is a kind of a pointer that gets a specific tag when converted to
;; Scheme, and accepts only such tagged pointers when going to C. An optional

70
collects/redex/private/reduction-semantics.ss
View File

@ -1046,39 +1046,47 @@
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values
(wrap
(letrec ([metafunc
(letrec ([cache (make-hash)]
[not-in-cache (gensym)]
[metafunc
(λ (exp)
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([patterns compiled-patterns]
[rhss (append old-rhss rhss)]
[num (- (length old-cps))])
(let ([cache-ref (hash-ref cache exp not-in-cache)])
(cond
[(null? patterns)
(redex-error name "no clauses matched for ~s" `(,name . ,exp))]
[else
(let ([pattern (car patterns)]
[rhs (car rhss)])
(let ([mtchs (match-pattern pattern exp)])
(cond
[(not mtchs) (loop (cdr patterns)
(cdr rhss)
(+ num 1))]
[(not (null? (cdr mtchs)))
(redex-error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
[else
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
ans)])))])))])
[(eq? cache-ref not-in-cache)
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([patterns compiled-patterns]
[rhss (append old-rhss rhss)]
[num (- (length old-cps))])
(cond
[(null? patterns)
(redex-error name "no clauses matched for ~s" `(,name . ,exp))]
[else
(let ([pattern (car patterns)]
[rhs (car rhss)])
(let ([mtchs (match-pattern pattern exp)])
(cond
[(not mtchs) (loop (cdr patterns)
(cdr rhss)
(+ num 1))]
[(not (null? (cdr mtchs)))
(redex-error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
[else
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
(hash-set! cache exp ans)
ans)])))]))]
[else
cache-ref])))])
metafunc)
compiled-patterns
rhss)

5
collects/redex/redex.scrbl
View File

@ -840,6 +840,11 @@ Raises an exception recognized by @scheme[exn:fail:redex?] if
no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated.
Note that metafunctions are assumed to always return the same results
for the same inputs, and their results are cached. Accordingly, if a
metafunction is called with the same inputs twice, then its body is
only evaluated a single time.
As an example, these metafunctions finds the free variables in
an expression in the lc-lang above:

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

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

146
collects/scheme/help.ss
View File

@ -1,121 +1,49 @@
#lang scheme/base
(require setup/xref
scribble/xref
scribble/manual-struct
net/uri-codec
net/sendurl
scheme/path
(for-syntax scheme/base))
(require (for-syntax scheme/base) scheme/promise)
(provide help)
(define-syntax (help stx)
(if (identifier? stx)
#'(open-help-start)
(syntax-case stx ()
[(help)
#'(open-help-start)]
[(help id)
(identifier? #'id)
#'(find-help (quote-syntax id))]
[(help id #:from lib)
(if (identifier? #'id)
(if (module-path? (syntax->datum #'lib))
#'(find-help/lib (quote id) (quote lib))
(raise-syntax-error
#f
"expected a module path after #:from"
stx
#'lib))
(raise-syntax-error
#f
"expected an identifier before #:from"
stx
#'id))]
[(help #:search str ...)
(with-syntax ([(str ...)
(map (lambda (e)
(if (string? (syntax-e e))
e
(format "~s"
(syntax->datum e))))
(syntax->list #'(str ...)))])
#'(search-for (list str ...)))]
[_
(raise-syntax-error #f
"expects a single identifer, a #:from clause, or a #:search clause; try just `help' for more information"
stx)])))
#'(open-help-start)
(syntax-case stx ()
[(help)
#'(open-help-start)]
[(help id)
(identifier? #'id)
#'(find-help (quote-syntax id))]
[(help id #:from lib)
(if (identifier? #'id)
(if (module-path? (syntax->datum #'lib))
#'(find-help/lib (quote id) (quote lib))
(raise-syntax-error
#f "expected a module path after #:from" stx #'lib))
(raise-syntax-error
#f "expected an identifier before #:from" stx #'id))]
[(help #:search str ...)
(with-syntax ([(str ...)
(map (lambda (e)
(if (string? (syntax-e e))
e
(format "~s" (syntax->datum e))))
(syntax->list #'(str ...)))])
#'(search-for (list str ...)))]
[_
(raise-syntax-error
#f
(string-append "expects a single identifer, a #:from clause, or a"
" #:search clause; try just `help' for more information")
stx)])))
(define (open-help-start)
(find-help #'help))
(define-namespace-anchor anchor)
(define (find-help/lib sym lib)
(let ([id (parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(namespace-require `(for-label ,lib))
(namespace-syntax-introduce (datum->syntax #f sym)))])
(if (identifier-label-binding id)
(find-help id)
(error 'help
"no binding for identifier: ~a from module: ~a"
sym
lib))))
(define (find-help id)
(let* ([lb (identifier-label-binding id)]
[b (and (not lb) (identifier-binding id))]
[xref (load-collections-xref
(lambda ()
(printf "Loading help index...\n")))])
(if (or lb b)
(let ([tag (xref-binding->definition-tag
xref
(or lb b)
(if lb #f 0))])
(if tag
(go-to-tag xref tag)
(error 'help
"no documentation found for: ~e provided by: ~a"
(syntax-e id)
(module-path-index-resolve (caddr (or lb b))))))
(search-for-exports xref (syntax-e id)))))
(define (search-for-exports xref sym)
(let ([idx (xref-index xref)]
[libs null])
(for-each (lambda (entry)
(when (exported-index-desc? (entry-desc entry))
(when (eq? sym (exported-index-desc-name (entry-desc entry)))
(set! libs (append libs (exported-index-desc-from-libs (entry-desc entry)))))))
idx)
(if (null? libs)
(printf "Not found in any library's documentation: ~a\n" sym)
(begin
(printf "No documentation for current binding, but provided by:\n")
(let loop ([libs libs])
(unless (null? libs)
(unless (member (car libs) (cdr libs))
(printf " ~a\n" (car libs)))
(loop (cdr libs))))))))
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n" file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (and anchor (uri-encode anchor)))
(error 'help "browser launch failed"))))
(define generate-search-results #f)
(define (search-for strs)
(printf "Generating and opening search page...\n")
(unless generate-search-results
(parameterize ([current-namespace (namespace-anchor->empty-namespace
anchor)])
(set! generate-search-results
(dynamic-require 'help/search 'perform-search))))
(generate-search-results strs))
(define-syntax-rule (define-help-autoload id)
(begin
(define auto (delay (dynamic-require 'scheme/private/help-autoload 'id)))
(define (id . args) (apply (force auto) args))))
(define-help-autoload find-help)
(define-help-autoload find-help/lib)
(define-help-autoload search-for)

67
collects/scheme/private/help-autoload.ss Normal file
View File

@ -0,0 +1,67 @@
#lang scheme/base
(require setup/xref
scribble/xref
scribble/manual-struct
help/search
net/uri-codec
net/sendurl
scheme/path
scheme/list)
(provide find-help find-help/lib search-for)
(define-namespace-anchor anchor)
(define (find-help/lib sym lib)
(let ([id (parameterize ([current-namespace
(namespace-anchor->empty-namespace anchor)])
(namespace-require `(for-label ,lib))
(namespace-syntax-introduce (datum->syntax #f sym)))])
(if (identifier-label-binding id)
(find-help id)
(error 'help "no binding for identifier: ~a from module: ~a" sym lib))))
(define (find-help id)
(let* ([lb (identifier-label-binding id)]
[b (and (not lb) (identifier-binding id))]
[xref (load-collections-xref
(lambda ()
(printf "Loading help index...\n")))])
(if (or lb b)
(let ([tag (xref-binding->definition-tag xref (or lb b) (if lb #f 0))])
(if tag
(go-to-tag xref tag)
(error 'help
"no documentation found for: ~e provided by: ~a"
(syntax-e id)
(module-path-index-resolve (caddr (or lb b))))))
(search-for-exports xref (syntax-e id)))))
(define (search-for-exports xref sym)
(let ([idx (xref-index xref)]
[libs null])
(for ([entry (in-list idx)])
(when (and (exported-index-desc? (entry-desc entry))
(eq? sym (exported-index-desc-name (entry-desc entry))))
(set! libs (append libs (exported-index-desc-from-libs
(entry-desc entry))))))
(if (null? libs)
(printf "Not found in any library's documentation: ~a\n" sym)
(begin
(printf "No documentation for current binding, but provided by:\n")
(let loop ([libs libs])
(unless (null? libs)
(unless (member (car libs) (cdr libs))
(printf " ~a\n" (car libs)))
(loop (cdr libs))))))))
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n" file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (and anchor (uri-encode anchor)))
(error 'help "browser launch failed"))))
(define (search-for strs)
(perform-search (apply string-append (add-between strs " "))))

23
collects/scribble/text.ss
View File

@ -1,22 +1,5 @@
#lang scheme/base
(require scheme/promise)
;; output
(provide output)
(define (output x [p (current-output-port)])
(let loop ([x x])
(cond [(or (void? x) (not x) (null? x)) (void)]
[(pair? x) (loop (car x)) (loop (cdr x))]
[(promise? x) (loop (force x))]
[(keyword? x) (loop (keyword->string x))]
[(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
[(bytes? x) (write-bytes x p)]
[(string? x) (write-string x p)]
[(char? x) (write-char x p)]
[(number? x) (write x p)]
[(symbol? x) (display x p)]
;; generic fallback
[else (error 'output "don't know how to render value: ~v" x)]))
(void))
(require scheme/promise "text/output.ss" "text/syntax-utils.ss")
(provide (all-from-out scheme/promise "text/output.ss")
begin/text include/text)

4
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -89,7 +89,7 @@
#:type-wrapper [type-wrapper values]
#:mutable [setters? #f]
#:proc-ty [proc-ty #f]
#:maker [maker #f]
#:maker [maker* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f])
;; create the approriate names that define-struct will bind
@ -102,7 +102,7 @@
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper wrapper
#:type-wrapper type-wrapper
#:maker maker
#:maker (or maker* maker)
#:constructor-return cret)))
;; generate names, and register the approriate types give field types and structure type