You know the branches flow to trunk
trunk then flows right back time to code, then to sync merging up to the HEAD of trunk merging up to the HEAD of trunk merging up to the HEAD of trunk, yeah svn: r11996
This commit is contained in:
Stevie Strickland
commit
f6bdaee080
|
|
@ -1,6 +1,6 @@
|
|||
#|
|
||||
|
||||
Hint: include the size of the board in your world structure
|
||||
hint: include the size of the board in your world structure
|
||||
This enables you to make test cases with different size boards,
|
||||
making some of the test cases much easier to manage.
|
||||
|
||||
|
|
@ -624,11 +624,15 @@ making some of the test cases much easier to manage.
|
|||
[(equal? evt 'button-up)
|
||||
(cond
|
||||
[(equal? 'playing (world-state world))
|
||||
(move-cat
|
||||
(make-world (add-obstacle (world-board world) x y)
|
||||
(world-cat world)
|
||||
(world-state world)
|
||||
(world-size world)))]
|
||||
(cond
|
||||
[(point-in-circle? (world-board world) x y)
|
||||
(move-cat
|
||||
(make-world (add-obstacle (world-board world) x y)
|
||||
(world-cat world)
|
||||
(world-state world)
|
||||
(world-size world)))]
|
||||
[else
|
||||
world])]
|
||||
[else
|
||||
world])]
|
||||
[else
|
||||
|
|
@ -833,6 +837,29 @@ making some of the test cases much easier to manage.
|
|||
(list (make-cell (make-posn 0 0) true)
|
||||
(make-cell (make-posn 0 1) false)))
|
||||
|
||||
;; point-in-circle? : board number number -> boolean
|
||||
(define (point-in-circle? board x y)
|
||||
(cond
|
||||
[(empty? board) false]
|
||||
[else
|
||||
(local [(define cell (first board))
|
||||
(define center (+ (cell-center-x (cell-p cell))
|
||||
(* (sqrt -1) (cell-center-y (cell-p cell)))))
|
||||
(define p (+ x (* (sqrt -1) y)))]
|
||||
(or (<= (magnitude (- center p)) circle-radius)
|
||||
(point-in-circle? (rest board) x y)))]))
|
||||
(check-expect (point-in-circle? empty 0 0) false)
|
||||
(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false))
|
||||
(cell-center-x (make-posn 0 0))
|
||||
(cell-center-y (make-posn 0 0)))
|
||||
true)
|
||||
(check-expect (point-in-circle? (list (make-cell (make-posn 0 0) false))
|
||||
0 0)
|
||||
false)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -997,12 +1024,7 @@ making some of the test cases much easier to manage.
|
|||
'playing
|
||||
board-size))]
|
||||
|
||||
(and
|
||||
|
||||
;; illustrates the speedup for state-based dfs
|
||||
;((lambda (x) true) (time (build-table initial-world)))
|
||||
;((lambda (x) true) (time (build-table/fast initial-world)))
|
||||
|
||||
(and ;((lambda (x) true) (time (build-table initial-world))) ;((lambda (x) true) (time (build-table/fast initial-world)))
|
||||
(big-bang (world-width board-size)
|
||||
(world-height board-size)
|
||||
1
|
||||
|
|
|
|||
|
|
@ -225,8 +225,10 @@
|
|||
(tr (td ([colspan "2"] [align "center"])
|
||||
(input ([type "submit"] [name "post"]
|
||||
[value "Login"])))))))))]
|
||||
[user (clean-str (aget (request-bindings request) 'user))]
|
||||
[passwd (aget (request-bindings request) 'passwd)]
|
||||
[bindings (request-bindings request)]
|
||||
[user (aget bindings 'user)]
|
||||
[passwd (aget bindings 'passwd)]
|
||||
[user (and user (clean-str user))]
|
||||
[user-data (get-user-data user)])
|
||||
(cond [(and user-data
|
||||
(string? passwd)
|
||||
|
|
|
|||
|
|
@ -1567,8 +1567,7 @@
|
|||
(define killer-executor (make-will-executor))
|
||||
(define killer-thread #f)
|
||||
|
||||
(provide* (unsafe register-finalizer))
|
||||
(define (register-finalizer obj finalizer)
|
||||
(define* (register-finalizer obj finalizer)
|
||||
(unless killer-thread
|
||||
(set! killer-thread
|
||||
(thread (lambda ()
|
||||
|
|
|
|||
|
|
@ -758,7 +758,7 @@
|
|||
(symbol->string (bind-name y))))))
|
||||
|
||||
(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!)
|
||||
(make-struct-type 'metafunc-proc #f 8 0 #f null (current-inspector) 0))
|
||||
(make-struct-type 'metafunc-proc #f 9 0 #f null (current-inspector) 0))
|
||||
(define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1))
|
||||
(define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2))
|
||||
(define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3))
|
||||
|
|
@ -766,6 +766,7 @@
|
|||
(define metafunc-proc-cps (make-struct-field-accessor metafunc-proc-ref 5))
|
||||
(define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6))
|
||||
(define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7))
|
||||
(define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 8))
|
||||
(define-struct metafunction (proc))
|
||||
|
||||
(define-syntax (in-domain? stx)
|
||||
|
|
@ -865,14 +866,14 @@
|
|||
(and dom-ctcs
|
||||
(rewrite-side-conditions/check-errs
|
||||
lang-nts
|
||||
#t
|
||||
'define-metafunction
|
||||
#f
|
||||
dom-ctcs))]
|
||||
[codom-side-conditions-rewritten
|
||||
(rewrite-side-conditions/check-errs
|
||||
lang-nts
|
||||
#t
|
||||
'define-metafunction
|
||||
#f
|
||||
codom-contract)]
|
||||
[(rhs-fns ...)
|
||||
(map (λ (lhs rhs bindings)
|
||||
|
|
@ -935,7 +936,8 @@
|
|||
'name
|
||||
cps
|
||||
rhss
|
||||
(let ([name (lambda (x) (name-predicate x))]) name)))
|
||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||
`dom-side-conditions-rewritten))
|
||||
`dom-side-conditions-rewritten
|
||||
`codom-side-conditions-rewritten
|
||||
'name))
|
||||
|
|
@ -1711,6 +1713,7 @@
|
|||
metafunc-proc-cps
|
||||
metafunc-proc-rhss
|
||||
metafunc-proc-in-dom?
|
||||
metafunc-proc-dom-pat
|
||||
|
||||
(struct-out binds))
|
||||
|
||||
|
|
|
|||
|
|
@ -414,6 +414,7 @@
|
|||
(define-language four
|
||||
(e 4)
|
||||
(f 5))
|
||||
(define-language empty)
|
||||
|
||||
;; `any' pattern
|
||||
(test (call-with-values (λ () (pick-any four (make-random (list 0 1)))) list)
|
||||
|
|
@ -426,7 +427,10 @@
|
|||
#:nt (patterns fifth second second second)
|
||||
#:seq (list (λ _ 3))
|
||||
#:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz"))))
|
||||
'("foo" "bar" "baz")))
|
||||
'("foo" "bar" "baz"))
|
||||
(test (generate/decisions empty any 5 0 (decisions #:nt (patterns first)
|
||||
#:var (list (λ _ 'x))))
|
||||
'x))
|
||||
|
||||
;; `hide-hole' pattern
|
||||
(let ()
|
||||
|
|
@ -460,19 +464,55 @@
|
|||
(get-output-string p)
|
||||
(close-output-port p))))
|
||||
|
||||
;; check
|
||||
(let ()
|
||||
(define-language lang
|
||||
(d 5)
|
||||
(e e 4))
|
||||
(test (current-error-port-output (λ () (check lang d 2 0 #f)))
|
||||
"failed after 1 attempts: 5")
|
||||
(test (check lang d 2 0 #t) #t)
|
||||
(test (check lang (d e) 2 0 (and (eq? (term d) 5) (eq? (term e) 4))) #t)
|
||||
(test (check lang (d ...) 2 0 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t)
|
||||
(test (current-error-port-output (λ () (check lang (d e) 2 0 #f)))
|
||||
"failed after 1 attempts: (5 4)")
|
||||
(test (exn:fail-message (check lang d 2 0 (error 'pred-raised)))
|
||||
#rx"term 5 raises"))
|
||||
(test (current-error-port-output (λ () (check lang d 2 #f)))
|
||||
"failed after 1 attempts:\n5\n")
|
||||
(test (check lang d #t) #t)
|
||||
(test (check lang (d e) 2 (and (eq? (term d) 5) (eq? (term e) 4))) #t)
|
||||
(test (check lang (d ...) 2 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t)
|
||||
(test (current-error-port-output (λ () (check lang (d e) 2 #f)))
|
||||
"failed after 1 attempts:\n(5 4)\n")
|
||||
(test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised))))
|
||||
"failed after 1 attempts:\n5\n"))
|
||||
|
||||
;; check-metafunction
|
||||
;; TODO: handle no metafunctions with no contract
|
||||
(let ()
|
||||
(define-language empty)
|
||||
(define-metafunction empty
|
||||
f : (side-condition number_1 (odd? (term number_1))) -> number
|
||||
[(f 1) 1]
|
||||
[(f 3) 'NaN])
|
||||
|
||||
(define-metafunction empty
|
||||
g : number ... -> (any ...)
|
||||
[(g number_1 ... 1 number_2 ...) ()])
|
||||
|
||||
(define-metafunction empty
|
||||
h : number -> number
|
||||
[(h any) any])
|
||||
|
||||
(define-metafunction empty
|
||||
[(i any ...) (any ...)])
|
||||
|
||||
;; Dom(f) < Ctc(f)
|
||||
(test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 2) (λ _ 5))))))
|
||||
"failed after 1 attempts:\n(5)\n")
|
||||
;; Rng(f) > Codom(f)
|
||||
(test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 3))))))
|
||||
"failed after 1 attempts:\n(3)\n")
|
||||
;; LHS matches multiple ways
|
||||
(test (current-error-port-output (λ () (check-metafunction g (decisions #:num (list (λ _ 1) (λ _ 1))
|
||||
#:seq (list (λ _ 2))))))
|
||||
"failed after 1 attempts:\n(1 1)\n")
|
||||
;; OK -- generated from Dom(h)
|
||||
(test (check-metafunction h) #t)
|
||||
;; OK -- generated from pattern 'any
|
||||
(test (check-metafunction i) #t))
|
||||
|
||||
;; parse/unparse-pattern
|
||||
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
|
||||
|
|
|
|||
|
|
@ -21,7 +21,10 @@ To do a better job of not generating programs with free variables,
|
|||
"reduction-semantics.ss"
|
||||
"underscore-allowed.ss"
|
||||
"term.ss"
|
||||
"error.ss"
|
||||
(for-syntax "rewrite-side-conditions.ss")
|
||||
(for-syntax "term-fn.ss")
|
||||
(for-syntax "reduction-semantics.ss")
|
||||
mrlib/tex-table)
|
||||
|
||||
(define random-numbers '(0 1 -1 17 8))
|
||||
|
|
@ -39,6 +42,10 @@ To do a better job of not generating programs with free variables,
|
|||
(hash-map uniq (λ (k v) k))))
|
||||
|
||||
(define generation-retries 100)
|
||||
|
||||
(define default-check-attempts 100)
|
||||
(define check-growth-base 5)
|
||||
|
||||
(define ascii-chars-threshold 50)
|
||||
(define tex-chars-threshold 500)
|
||||
(define chinese-chars-threshold 2000)
|
||||
|
|
@ -89,7 +96,7 @@ To do a better job of not generating programs with free variables,
|
|||
(list->string (build-list length (λ (_) (pick-char attempt lang-chars random))))))
|
||||
|
||||
(define (pick-any lang [random random])
|
||||
(if (zero? (random 5))
|
||||
(if (and (not (null? (compiled-lang-lang lang))) (zero? (random 5)))
|
||||
(values lang (pick-from-list (map nt-name (compiled-lang-lang lang)) random))
|
||||
(values sexp (nt-name (car (compiled-lang-lang sexp))))))
|
||||
|
||||
|
|
@ -114,7 +121,7 @@ To do a better job of not generating programs with free variables,
|
|||
(error 'generate "unable to generate pattern ~s in ~s attempts"
|
||||
(unparse-pattern pat) generation-retries))
|
||||
|
||||
(define (generate* lang pat size [decisions@ random-decisions@])
|
||||
(define (generate* lang pat [decisions@ random-decisions@])
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
|
|
@ -240,7 +247,7 @@ To do a better job of not generating programs with free variables,
|
|||
[`(hide-hole ,pattern) ((recur pattern the-hole) state)]
|
||||
[`any
|
||||
(let*-values ([(lang nt) ((next-any-decision) lang)]
|
||||
[(term _) ((generate* lang nt size decisions@) attempt)])
|
||||
[(term _) ((generate* lang nt decisions@) size attempt)])
|
||||
(values term state))]
|
||||
[(? (is-nt? lang))
|
||||
(generate-nt pat pat bound-vars size attempt in-hole state)]
|
||||
|
|
@ -306,7 +313,7 @@ To do a better job of not generating programs with free variables,
|
|||
(state-fvt state))
|
||||
(state-env state)))
|
||||
|
||||
(λ (attempt)
|
||||
(λ (size attempt)
|
||||
(let-values ([(term state)
|
||||
(generate/pred
|
||||
pat
|
||||
|
|
@ -554,43 +561,53 @@ To do a better job of not generating programs with free variables,
|
|||
|
||||
(define-syntax (check stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang pat attempts size property)
|
||||
[(_ lang pat property)
|
||||
(syntax/loc stx (check lang pat default-check-attempts property))]
|
||||
[(_ lang pat attempts property)
|
||||
(let-values ([(names names/ellipses)
|
||||
(extract-names (language-id-nts #'lang 'generate) 'check #t #'pat)])
|
||||
(with-syntax ([(name ...) names]
|
||||
[(name/ellipses ...) names/ellipses])
|
||||
(syntax/loc stx
|
||||
(let ([generator (term-generator lang pat size random-decisions@)])
|
||||
(let loop ([remaining attempts])
|
||||
(if (zero? remaining)
|
||||
#t
|
||||
(let ([attempt (add1 (- attempts remaining))])
|
||||
(let-values ([(term bindings) (generator attempt)])
|
||||
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
|
||||
(if (with-handlers
|
||||
([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))])
|
||||
property)
|
||||
(loop (sub1 remaining))
|
||||
(fprintf (current-error-port)
|
||||
"failed after ~s attempts: ~s"
|
||||
attempt term)))))))))))]))
|
||||
(check-property
|
||||
(term-generator lang pat random-decisions@)
|
||||
(λ (_ bindings)
|
||||
(with-handlers ([exn:fail? (λ (_) #f)])
|
||||
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
|
||||
property)))
|
||||
attempts))))]))
|
||||
|
||||
(define (check-property generate property attempts)
|
||||
(let loop ([remaining attempts])
|
||||
(if (zero? remaining)
|
||||
#t
|
||||
(let ([attempt (add1 (- attempts remaining))])
|
||||
(let-values ([(term bindings)
|
||||
(generate (floor (/ (log attempt) (log check-growth-base))) attempt)])
|
||||
(if (property term bindings)
|
||||
(loop (sub1 remaining))
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"failed after ~s attempts:\n"
|
||||
attempt)
|
||||
(pretty-print term (current-error-port)))))))))
|
||||
|
||||
(define-syntax generate
|
||||
(syntax-rules ()
|
||||
[(_ lang pat size attempt)
|
||||
(let-values ([(term _) ((term-generator lang pat size random-decisions@) attempt)])
|
||||
(let-values ([(term _) ((term-generator lang pat random-decisions@) size attempt)])
|
||||
term)]
|
||||
[(_ lang pat size) (generate lang pat size 0)]))
|
||||
|
||||
(define-syntax generate/decisions
|
||||
(syntax-rules ()
|
||||
[(_ lang pat size attempt decisions@)
|
||||
(let-values ([(term _) ((term-generator lang pat size decisions@) attempt)])
|
||||
(let-values ([(term _) ((term-generator lang pat decisions@) size attempt)])
|
||||
term)]))
|
||||
|
||||
(define-syntax (term-generator stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang pat size decisions@)
|
||||
[(_ lang pat decisions@)
|
||||
(with-syntax ([pattern
|
||||
(rewrite-side-conditions/check-errs
|
||||
(language-id-nts #'lang 'generate)
|
||||
|
|
@ -599,7 +616,28 @@ To do a better job of not generating programs with free variables,
|
|||
(generate*
|
||||
(parse-language lang)
|
||||
(reassign-classes (parse-pattern `pattern lang 'top-level))
|
||||
size decisions@)))]))
|
||||
decisions@)))]))
|
||||
|
||||
(define-syntax (check-metafunction stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name) (syntax/loc stx (check-metafunction name random-decisions@))]
|
||||
[(_ name decisions@)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))])
|
||||
(if (term-fn? tf)
|
||||
(term-fn-get-id tf)
|
||||
(raise-syntax-error #f "not a metafunction" stx #'name)))])
|
||||
(syntax
|
||||
(let ([lang (metafunc-proc-lang m)]
|
||||
[dom (metafunc-proc-dom-pat m)])
|
||||
(check-property
|
||||
(generate* (parse-language lang)
|
||||
(reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level))
|
||||
decisions@)
|
||||
(λ (t _)
|
||||
(with-handlers ([exn:fail:redex? (λ (_) #f)])
|
||||
(begin (term (name ,@t)) #t)))
|
||||
100))))]))
|
||||
|
||||
(define-signature decisions^
|
||||
(next-variable-decision
|
||||
|
|
@ -623,7 +661,7 @@ To do a better job of not generating programs with free variables,
|
|||
pick-nt unique-chars pick-any sexp generate parse-pattern
|
||||
class-reassignments reassign-classes unparse-pattern
|
||||
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
|
||||
(struct-out binder) generate/decisions)
|
||||
(struct-out binder) generate/decisions check-metafunction)
|
||||
|
||||
(provide/contract
|
||||
[find-base-cases (-> compiled-lang? hash?)])
|
||||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "8oct2008")
|
||||
#lang scheme/base (provide stamp) (define stamp "12oct2008")
|
||||
|
|
|
|||
|
|
@ -376,19 +376,16 @@
|
|||
(hash-ref
|
||||
checkers lib
|
||||
(lambda ()
|
||||
(let ([ns (make-base-empty-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require `(for-label ,lib)))
|
||||
(let ([ns-id
|
||||
(let ([ns (make-base-empty-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require `(for-label ,lib))
|
||||
(namespace-syntax-introduce (datum->syntax #f 'x))))])
|
||||
(let ([checker
|
||||
(lambda (id)
|
||||
(parameterize ([current-namespace
|
||||
ns])
|
||||
(free-label-identifier=?
|
||||
(namespace-syntax-introduce
|
||||
(datum->syntax
|
||||
#f
|
||||
(syntax-e id)))
|
||||
id)))])
|
||||
(free-label-identifier=?
|
||||
(datum->syntax ns-id (syntax-e id))
|
||||
id))])
|
||||
(hash-set! checkers lib checker)
|
||||
checker))))])
|
||||
(and (checker id) lib)))
|
||||
|
|
|
|||
|
|
@ -114,9 +114,9 @@ with the output port; when the function returns, the port is closed.
|
|||
(begin (define-values (s-in c-out) (make-pipe))
|
||||
(define-values (c-in s-out) (make-pipe))))
|
||||
(display "hello\n" c-out)
|
||||
(read-line s-in)
|
||||
(close-output-port c-out)
|
||||
(read-line s-in)
|
||||
(read-line s-in)
|
||||
]}
|
||||
|
||||
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
|
|
|||
|
|
@ -330,12 +330,9 @@
|
|||
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
||||
ht))
|
||||
|
||||
(define (read-out-sxref)
|
||||
(define (read-sxref)
|
||||
(fasl->s-exp (current-input-port)))
|
||||
|
||||
(define (normalized-read)
|
||||
(with-module-reading-parameterization read))
|
||||
|
||||
(define (make-sci-cached sci info-out-file setup-printf)
|
||||
(when (verbose)
|
||||
(fprintf (current-error-port) " [Lazy ~a]\n" info-out-file))
|
||||
|
|
@ -348,7 +345,7 @@
|
|||
(void)
|
||||
#;
|
||||
(fprintf (current-error-port) " [Re-load ~a]\n" info-out-file))
|
||||
(let ([v (cadr (with-input-from-file info-out-file read-out-sxref))])
|
||||
(let ([v (cadr (with-input-from-file info-out-file read-sxref))])
|
||||
(set! b (make-weak-box v))
|
||||
v)))))))
|
||||
|
||||
|
|
@ -381,14 +378,21 @@
|
|||
[my-time (file-or-directory-modify-seconds out-file #f (lambda () -inf.0))]
|
||||
[info-out-time (file-or-directory-modify-seconds info-out-file #f (lambda () #f))]
|
||||
[info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))]
|
||||
[info-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))]
|
||||
[vers (send renderer get-serialize-version)]
|
||||
[src-time (max aux-time
|
||||
(file-or-directory-modify-seconds
|
||||
src-zo #f (lambda () +inf.0)))]
|
||||
[up-to-date?
|
||||
(and info-out-time
|
||||
info-in-time
|
||||
(or (not can-run?)
|
||||
(my-time . >= . (max aux-time
|
||||
(file-or-directory-modify-seconds
|
||||
src-zo #f (lambda () +inf.0))))))]
|
||||
;; Need to rebuild if output file is older than input:
|
||||
(my-time . >= . src-time)
|
||||
;; But we can use in/out information if they're already built;
|
||||
;; this is mostly useful if we interrupt setup-plt after
|
||||
;; it runs some documents without rendering them:
|
||||
(info-time . >= . src-time)))]
|
||||
[can-run? (and (or (not latex-dest)
|
||||
(not (omit? (doc-category doc))))
|
||||
(or can-run?
|
||||
|
|
@ -402,46 +406,48 @@
|
|||
(path->name (doc-src-file doc)))
|
||||
(if up-to-date?
|
||||
;; Load previously calculated info:
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(fprintf (current-error-port) "~a\n" (exn-message exn))
|
||||
(delete-file info-out-file)
|
||||
(delete-file info-in-file)
|
||||
((get-doc-info only-dirs latex-dest auto-main?
|
||||
auto-user? with-record-error
|
||||
setup-printf)
|
||||
doc))])
|
||||
(let* ([v-in (with-input-from-file info-in-file normalized-read)]
|
||||
[v-out (with-input-from-file info-out-file read-out-sxref)])
|
||||
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
||||
(equal? (car v-out) (list vers (doc-flags doc))))
|
||||
(error "old info has wrong version or flags"))
|
||||
(make-info
|
||||
doc
|
||||
(make-sci-cached
|
||||
(list-ref v-out 1) ; sci (leave serialized)
|
||||
info-out-file
|
||||
setup-printf)
|
||||
(let ([v (list-ref v-out 2)]) ; provides
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(let ([v (list-ref v-in 1)]) ; undef
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(let ([v (list-ref v-in 3)]) ; searches
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
|
||||
null ; known deps (none at this point)
|
||||
can-run?
|
||||
my-time info-out-time
|
||||
(and can-run? (memq 'always-run (doc-flags doc)))
|
||||
#f #f
|
||||
vers
|
||||
#f
|
||||
#f)))
|
||||
(render-time
|
||||
"use"
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(fprintf (current-error-port) "~a\n" (exn-message exn))
|
||||
(delete-file info-out-file)
|
||||
(delete-file info-in-file)
|
||||
((get-doc-info only-dirs latex-dest auto-main?
|
||||
auto-user? with-record-error
|
||||
setup-printf)
|
||||
doc))])
|
||||
(let* ([v-in (with-input-from-file info-in-file read-sxref)]
|
||||
[v-out (with-input-from-file info-out-file read-sxref)])
|
||||
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
||||
(equal? (car v-out) (list vers (doc-flags doc))))
|
||||
(error "old info has wrong version or flags"))
|
||||
(make-info
|
||||
doc
|
||||
(make-sci-cached
|
||||
(list-ref v-out 1) ; sci (leave serialized)
|
||||
info-out-file
|
||||
setup-printf)
|
||||
(let ([v (list-ref v-out 2)]) ; provides
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(let ([v (list-ref v-in 1)]) ; undef
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(let ([v (list-ref v-in 3)]) ; searches
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
|
||||
null ; known deps (none at this point)
|
||||
can-run?
|
||||
my-time info-out-time
|
||||
(and can-run? (memq 'always-run (doc-flags doc)))
|
||||
#f #f
|
||||
vers
|
||||
#f
|
||||
#f))))
|
||||
(if can-run?
|
||||
;; Run the doc once:
|
||||
(with-record-error
|
||||
|
|
@ -456,7 +462,7 @@
|
|||
[ri (send renderer resolve (list v) (list dest-dir) ci)]
|
||||
[out-v (and info-out-time
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(let ([v (with-input-from-file info-out-file read-out-sxref)])
|
||||
(let ([v (with-input-from-file info-out-file read-sxref)])
|
||||
(unless (equal? (car v) (list vers (doc-flags doc)))
|
||||
(error "old info has wrong version or flags"))
|
||||
v)))]
|
||||
|
|
@ -497,6 +503,10 @@
|
|||
(unless latex-dest
|
||||
(render-time "xref-out" (write-out info setup-printf)))
|
||||
(set-info-need-out-write?! info #f))
|
||||
(when (info-need-in-write? info)
|
||||
(unless latex-dest
|
||||
(render-time "xref-in" (write-in info)))
|
||||
(set-info-need-in-write?! info #f))
|
||||
info))))
|
||||
(lambda () #f))
|
||||
#f))))
|
||||
|
|
@ -644,7 +654,7 @@
|
|||
setup-printf)))
|
||||
(define (write-in info)
|
||||
(make-directory* (doc-dest-dir (info-doc info)))
|
||||
(write- info "in.sxref" (lambda (o i) (write (i)))))
|
||||
(write- info "in.sxref" (lambda (o i) (write-bytes (s-exp->fasl (i))))))
|
||||
|
||||
(define (rel->path r)
|
||||
(if (bytes? r)
|
||||
|
|
|
|||
|
|
@ -47,13 +47,13 @@ pinholes are at position @scheme[(0,0)].
|
|||
|
||||
@defproc[(empty-scene [width natural-number/c]
|
||||
[height natural-number/c])
|
||||
(unsyntax @tech{Scene})]
|
||||
{Creates a @scheme[width] x @scheme[height] @tech{Scene}.}
|
||||
(unsyntax @tech{Scene})]{
|
||||
Creates a @scheme[width] x @scheme[height] @tech{Scene}.}
|
||||
|
||||
@defproc[(place-image [img image?] [x number?] [y number?]
|
||||
[s (unsyntax @tech{Scene})])
|
||||
(unsyntax @tech{Scene})]
|
||||
{Creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s];
|
||||
(unsyntax @tech{Scene})]{
|
||||
Creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s];
|
||||
@scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and
|
||||
down from the upper-left corner.}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
(require (rep type-rep)
|
||||
(r:infer infer)
|
||||
(private type-effect-convenience union type-utils)
|
||||
(prefix-in table: (utils tables))
|
||||
(schemeunit))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -522,11 +522,12 @@ types. In most cases, use of @scheme[:] is preferred to use of @scheme[define:]
|
|||
(define-struct: name ([f : t] ...))
|
||||
(define-struct: (name parent) ([f : t] ...))
|
||||
(define-struct: (v ...) name ([f : t] ...))
|
||||
(define-struct: (v ...) (name parent) ([f : t] ...))]]
|
||||
{Defines a @rtech{structure} with the name @scheme[name], where the fields
|
||||
@scheme[f] have types @scheme[t]. The second and fourth forms define @scheme[name]
|
||||
to be a substructure of @scheme[parent]. The last two forms define structures that
|
||||
are polymorphic in the type variables @scheme[v].}
|
||||
(define-struct: (v ...) (name parent) ([f : t] ...))]]{
|
||||
Defines a @rtech{structure} with the name @scheme[name], where the
|
||||
fields @scheme[f] have types @scheme[t]. The second and fourth forms
|
||||
define @scheme[name] to be a substructure of @scheme[parent]. The
|
||||
last two forms define structures that are polymorphic in the type
|
||||
variables @scheme[v].}
|
||||
|
||||
@subsection{Type Aliases}
|
||||
@defform*[[(define-type-alias name t)
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ RANLIB = @RANLIB@
|
|||
|
||||
CPPFLAGS = @PREFLAGS@ @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ -I$(builddir)/.. -I$(srcdir)/../include
|
||||
CFLAGS = @CFLAGS@ $(CPPFLAGS) @COMPFLAGS@ @PROFFLAGS@
|
||||
LIBS = @LIBS@ -lpthread
|
||||
LIBS = @LIBS@
|
||||
|
||||
DEF_COLLECTS_DIR = +D INITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"'
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user