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

Change a bunch of "~%" and "~n" in format strings to "\n".

Browse Source
This commit is contained in:
Eli Barzilay 2010-08-25 17:16:32 -04:00
parent 606b7f60dc
commit 7dc4d2e5a6
136 changed files with 1089 additions and 1183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/algol60/prims.rkt
View File

@ -94,10 +94,10 @@
(k (log (get-number 'ln v)))) (k (log (get-number 'ln v))))
(define (printsln k v) (define (printsln k v)
(k (printf "~a~n" (get-string 'printsln v)))) (k (printf "~a\n" (get-string 'printsln v))))
(define (printnln k v) (define (printnln k v)
(k (printf "~a~n" (get-number 'printnln v)))) (k (printf "~a\n" (get-number 'printnln v))))
(define (prints k v) (define (prints k v)
(k (printf "~a" (get-string 'prints v)))) (k (printf "~a" (get-string 'prints v))))

2
collects/algol60/tool.rkt
View File

@ -95,7 +95,7 @@
(drscheme:debug:make-debug-error-display-handler (error-display-handler))) (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(current-compile (make-errortrace-compile-handler)) (current-compile (make-errortrace-compile-handler))
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(printf "~a~n" (printf "~a\n"
(exn-message x)))]) (exn-message x)))])
(namespace-attach-module n path) (namespace-attach-module n path)
(namespace-require path)))))) (namespace-require path))))))

2
collects/browser/private/html.rkt
View File

@ -229,7 +229,7 @@
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(message-box "Warning" (message-box "Warning"
(format "Could not delete file ~s~n~n~a" (format "Could not delete file ~s\n\n~a"
tmp-filename tmp-filename
(if (exn? x) (if (exn? x)
(exn-message x) (exn-message x)

20
collects/combinator-parser/private-combinator/combinator-parser.scm
View File

@ -42,7 +42,7 @@
[(res? result) [(res? result)
(fail-type->message (res-msg result))] (fail-type->message (res-msg result))]
[(lazy-opts? result) [(lazy-opts? result)
#;(printf "lazy-opts ~a~n" result) #;(printf "lazy-opts ~a\n" result)
(let* ([finished? (lambda (o) (let* ([finished? (lambda (o)
(cond [(res? o) (cond [(res? o)
(and (not (null? (res-a o))) (and (not (null? (res-a o)))
@ -79,7 +79,7 @@
(cond (cond
[(pair? p-errors) [(pair? p-errors)
(let ([fails (cons (lazy-opts-errors result) p-errors)]) (let ([fails (cons (lazy-opts-errors result) p-errors)])
#;(printf "~nfails ~a~n~n" fails) #;(printf "\nfails ~a\n\n" fails)
(fail-type->message (fail-type->message
(make-options-fail (rank-choice (map fail-type-chance fails)) (make-options-fail (rank-choice (map fail-type-chance fails))
#f #f
@ -91,7 +91,7 @@
[(null? p-errors) [(null? p-errors)
(fail-type->message (lazy-opts-errors result))]))])))] (fail-type->message (lazy-opts-errors result))]))])))]
[(or (choice-res? result) (pair? result)) [(or (choice-res? result) (pair? result))
#;(printf "choice-res or pair? ~a~n" result) #;(printf "choice-res or pair? ~a\n" result)
(let* ([options (if (choice-res? result) (choice-res-matches result) result)] (let* ([options (if (choice-res? result) (choice-res-matches result) result)]
[finished-options (filter (lambda (o) [finished-options (filter (lambda (o)
(cond [(res? o) (cond [(res? o)
@ -108,10 +108,10 @@
(filter res-possible-error (filter res-possible-error
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) (map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
options))]) options))])
#;(printf "length finished-options ~a~n" finished-options) #;(printf "length finished-options ~a\n" finished-options)
(cond (cond
[(not (null? finished-options)) [(not (null? finished-options))
#;(printf "finished an option~n") #;(printf "finished an option\n")
(let ([first-fo (car finished-options)]) (let ([first-fo (car finished-options)])
(car (cond (car (cond
[(res? first-fo) (res-a first-fo)] [(res? first-fo) (res-a first-fo)]
@ -122,12 +122,12 @@
(error 'parser-internal-errorcp (error 'parser-internal-errorcp
(format "~a" first-fo))])))] (format "~a" first-fo))])))]
#;[(not (null? possible-repeat-errors)) #;[(not (null? possible-repeat-errors))
(printf "possible-repeat error~n") (printf "possible-repeat error\n")
(fail-type->message (fail-type->message
(car (repeat-res-stop (car (repeat-res-stop
(sort-repeats possible-repeat-errors))))] (sort-repeats possible-repeat-errors))))]
[(and (choice-res? result) (fail-type? (choice-res-errors result))) [(and (choice-res? result) (fail-type? (choice-res-errors result)))
#;(printf "choice res and choice res errors ~n") #;(printf "choice res and choice res errors \n")
(cond (cond
[(and (null? possible-repeat-errors) [(and (null? possible-repeat-errors)
(null? possible-errors)) (fail-type->message (choice-res-errors result))] (null? possible-errors)) (fail-type->message (choice-res-errors result))]
@ -143,11 +143,11 @@
(rank-choice (map fail-type-may-use fails)) (rank-choice (map fail-type-may-use fails))
fails)))])] fails)))])]
[(not (null? possible-errors)) [(not (null? possible-errors))
;(printf "choice or pair fail~n") ;(printf "choice or pair fail\n")
(fail-type->message (fail-type->message
(res-possible-error (car (sort-used possible-errors))))] (res-possible-error (car (sort-used possible-errors))))]
[else [else
#;(printf "result ~a~n" result) #;(printf "result ~a\n" result)
(let ([used-sort (sort-used options)]) (let ([used-sort (sort-used options)])
(if (and (choice-res? result) (if (and (choice-res? result)
(choice-res-errors result)) (choice-res-errors result))
@ -164,7 +164,7 @@
[(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop result))) [(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop result)))
(res-a (repeat-res-a result))] (res-a (repeat-res-a result))]
[(and (repeat-res? result) (fail-type? (repeat-res-stop result))) [(and (repeat-res? result) (fail-type? (repeat-res-stop result)))
;(printf "repeat-fail~n") ;(printf "repeat-fail\n")
(fail-type->message (repeat-res-stop result))] (fail-type->message (repeat-res-stop result))]
[else (error 'parser (format "Internal error: received unexpected input ~a" [else (error 'parser (format "Internal error: received unexpected input ~a"
result))])]) result))])])

150
collects/combinator-parser/private-combinator/combinator.scm
View File

@ -62,13 +62,13 @@
build)]) build)])
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
#;(printf "terminal ~a~n" name) #;(printf "terminal ~a\n" name)
#;(cond #;(cond
[(eq? input return-name) (printf "name requested~n")] [(eq? input return-name) (printf "name requested\n")]
[(null? input) (printf "null input~n")] [(null? input) (printf "null input\n")]
[else [else
(let ([token (position-token-token (car input))]) (let ([token (position-token-token (car input))])
(printf "Token given ~a, match? ~a~n" token (pred token)))]) (printf "Token given ~a, match? ~a\n" token (pred token)))])
(cond (cond
[(eq? input return-name) name] [(eq? input return-name) name]
[(eq? input terminal-occurs) (list (make-occurs name 1))] [(eq? input terminal-occurs) (list (make-occurs name 1))]
@ -87,7 +87,7 @@
(cdr input) name (cdr input) name
(value curr-input) 1 #f curr-input)] (value curr-input) 1 #f curr-input)]
[else [else
#;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a ~n" name #;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a \n" name
(cond (cond
[(token-value token) (token-value token)] [(token-value token) (token-value token)]
[else (token-name token)]) [else (token-name token)])
@ -135,7 +135,7 @@
[my-error (sequence-error-gen name sequence-length)] [my-error (sequence-error-gen name sequence-length)]
[my-walker (seq-walker id-position name my-error)]) [my-walker (seq-walker id-position name my-error)])
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
#;(unless (eq? input return-name) (printf "seq ~a~n" name)) #;(unless (eq? input return-name) (printf "seq ~a\n" name))
(cond (cond
[(eq? input return-name) name] [(eq? input return-name) name]
[(eq? input terminal-occurs) [(eq? input terminal-occurs)
@ -158,8 +158,8 @@
[(pair? pre-build-ans) (map builder pre-build-ans)] [(pair? pre-build-ans) (map builder pre-build-ans)]
[else pre-build-ans])]) [else pre-build-ans])])
(weak-map-put! memo-table input ans) (weak-map-put! memo-table input ans)
#;(printf "sequence ~a returning ~n" name) #;(printf "sequence ~a returning \n" name)
#;(printf "answer is ~a ~n" ans) #;(printf "answer is ~a \n" ans)
ans)]))))) ans)])))))
;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result ;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result
@ -198,7 +198,7 @@
(make-src-lst (position-token-start-pos (res-first-tok old-result)) (make-src-lst (position-token-start-pos (res-first-tok old-result))
(position-token-end-pos (res-first-tok old-result))) (position-token-end-pos (res-first-tok old-result)))
last-src))]) last-src))])
#;(printf "next-call ~a ~a: ~a ~a ~a ~a~n" #;(printf "next-call ~a ~a: ~a ~a ~a ~a\n"
seq-name (length seen) old-result (res? rsts) seq-name (length seen) old-result (res? rsts)
(and (res? rsts) (res-a rsts)) (and (res? rsts) (res-a rsts))
(and (res? rsts) (choice-fail? (res-possible-error rsts)))) (and (res? rsts) (choice-fail? (res-possible-error rsts))))
@ -236,7 +236,7 @@
(map (lambda (rst) (next-res old-answer new-id old-used tok rst)) (map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(flatten (correct-list rsts)))] (flatten (correct-list rsts)))]
[(choice-res? rsts) [(choice-res? rsts)
#;(printf "next call, tail-end is choice ~a~n" rsts) #;(printf "next call, tail-end is choice ~a\n" rsts)
(map (lambda (rst) (next-res old-answer new-id old-used tok (map (lambda (rst) (next-res old-answer new-id old-used tok
(update-possible-fail rst rsts))) (update-possible-fail rst rsts)))
(flatten (correct-list (choice-res-matches rsts))))] (flatten (correct-list (choice-res-matches rsts))))]
@ -247,37 +247,37 @@
(cond (cond
[(null? subs) (error 'end-of-subs)] [(null? subs) (error 'end-of-subs)]
[(null? next-preds) [(null? next-preds)
#;(printf "seq-walker called: last case, ~a case of ~a ~n" #;(printf "seq-walker called: last case, ~a case of ~a \n"
seq-name (curr-pred return-name)) seq-name (curr-pred return-name))
(build-error (curr-pred input last-src) (build-error (curr-pred input last-src)
(lambda () (previous? input)) (lambda () (previous? input))
(previous? return-name) #f (previous? return-name) #f
look-back look-back-ref used curr-id seen alts last-src)] look-back look-back-ref used curr-id seen alts last-src)]
[else [else
#;(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n" #;(printf "seq-walker called: else case, ~a case of ~a ~ath case \n"
seq-name (curr-pred return-name) (length seen)) seq-name (curr-pred return-name) (length seen))
(let ([fst (curr-pred input last-src)]) (let ([fst (curr-pred input last-src)])
(cond (cond
[(res? fst) [(res? fst)
#;(printf "res case ~a ~a~n" seq-name (length seen)) #;(printf "res case ~a ~a\n" seq-name (length seen))
(cond (cond
[(res-a fst) (next-call fst fst fst (res-msg fst) [(res-a fst) (next-call fst fst fst (res-msg fst)
(and id-spot? (res-id fst)) (and id-spot? (res-id fst))
(res-first-tok fst) alts)] (res-first-tok fst) alts)]
[else [else
#;(printf "error situation ~a ~a~n" seq-name (length seen)) #;(printf "error situation ~a ~a\n" seq-name (length seen))
(build-error fst (lambda () (previous? input)) (build-error fst (lambda () (previous? input))
(previous? return-name) (previous? return-name)
(car next-preds) look-back look-back-ref used curr-id (car next-preds) look-back look-back-ref used curr-id
seen alts last-src)])] seen alts last-src)])]
[(repeat-res? fst) [(repeat-res? fst)
#;(printf "repeat-res: ~a ~a~n" seq-name (length seen)) #;(printf "repeat-res: ~a ~a\n" seq-name (length seen))
#;(printf "res? ~a~n" (res? (repeat-res-a fst))) #;(printf "res? ~a\n" (res? (repeat-res-a fst)))
(next-call (repeat-res-a fst) fst fst (next-call (repeat-res-a fst) fst fst
(res-msg (repeat-res-a fst)) #f (res-msg (repeat-res-a fst)) #f
(res-first-tok (repeat-res-a fst)) alts)] (res-first-tok (repeat-res-a fst)) alts)]
[(lazy-opts? fst) [(lazy-opts? fst)
#;(printf "lazy res: ~a ~a ~a~n" fst seq-name (length seen)) #;(printf "lazy res: ~a ~a ~a\n" fst seq-name (length seen))
(let* ([opt-r (make-lazy-opts null (let* ([opt-r (make-lazy-opts null
(make-options-fail 0 last-src seq-name 0 0 null) (make-options-fail 0 last-src seq-name 0 0 null)
null)] null)]
@ -285,11 +285,11 @@
[next-c (lambda (res) [next-c (lambda (res)
(cond (cond
[(res? res) [(res? res)
#;(printf "lazy-choice-res, res ~a ~a~n" seq-name (length seen)) #;(printf "lazy-choice-res, res ~a ~a\n" seq-name (length seen))
(next-call res fst res name (and id-spot? (res-id res)) (next-call res fst res name (and id-spot? (res-id res))
(res-first-tok res) alts)] (res-first-tok res) alts)]
[(repeat-res? res) [(repeat-res? res)
#;(printf "lazy- choice-res, repeat-res ~a ~a ~a~n" #;(printf "lazy- choice-res, repeat-res ~a ~a ~a\n"
(res? (repeat-res-a res)) seq-name (length seen)) (res? (repeat-res-a res)) seq-name (length seen))
(next-call (repeat-res-a res) res (repeat-res-a res) (next-call (repeat-res-a res) res (repeat-res-a res)
(res-msg (repeat-res-a res)) #f (res-msg (repeat-res-a res)) #f
@ -313,7 +313,7 @@
(fail-res input (lazy-opts-errors opt-r)))) (fail-res input (lazy-opts-errors opt-r))))
] ]
[(or (choice-res? fst) (pair? fst)) [(or (choice-res? fst) (pair? fst))
#;(printf "choice-res: ~a ~a ~a~n" fst seq-name (length seen)) #;(printf "choice-res: ~a ~a ~a\n" fst seq-name (length seen))
(let*-values (let*-values
([(lst name curr) ([(lst name curr)
(cond (cond
@ -327,12 +327,12 @@
(map (lambda (res) (map (lambda (res)
(cond (cond
[(res? res) [(res? res)
#;(printf "choice-res, res ~a ~a~n" seq-name (length seen)) #;(printf "choice-res, res ~a ~a\n" seq-name (length seen))
(next-call res (curr res) res (name res) (next-call res (curr res) res (name res)
(and id-spot? (res-id res)) (and id-spot? (res-id res))
(res-first-tok res) new-alts)] (res-first-tok res) new-alts)]
[(repeat-res? res) [(repeat-res? res)
#;(printf "choice-res, repeat-res ~a ~a ~a~n" #;(printf "choice-res, repeat-res ~a ~a ~a\n"
(res? (repeat-res-a res)) seq-name (length seen)) (res? (repeat-res-a res)) seq-name (length seen))
(next-call (repeat-res-a res) res (repeat-res-a res) (next-call (repeat-res-a res) res (repeat-res-a res)
(res-msg (repeat-res-a res)) #f (res-msg (repeat-res-a res)) #f
@ -341,12 +341,12 @@
[else (error 'parser-internal-error4 (format "~a" res))])) [else (error 'parser-internal-error4 (format "~a" res))]))
(flatten lst))] (flatten lst))]
[(correct-rsts) (flatten (correct-list rsts))]) [(correct-rsts) (flatten (correct-list rsts))])
#;(printf "case ~a ~a, choice case: intermediate results are ~a~n" #;(printf "case ~a ~a, choice case: intermediate results are ~a\n"
seq-name (length seen) lst) seq-name (length seen) lst)
(cond (cond
[(and (null? correct-rsts) (or (not (lazy-choice? fst)) [(and (null? correct-rsts) (or (not (lazy-choice? fst))
(null? (lazy-opts-thunks fst)))) (null? (lazy-opts-thunks fst))))
#;(printf "correct-rsts null for ~a ~a ~n" seq-name (length seen)) #;(printf "correct-rsts null for ~a ~a \n" seq-name (length seen))
(let ([fails (let ([fails
(map (map
(lambda (rst) (lambda (rst)
@ -418,7 +418,7 @@
;update-possible-rail result result -> result ;update-possible-rail result result -> result
(define (update-possible-fail res back) (define (update-possible-fail res back)
#;(printf "update-possible-fail ~a, ~a~n" res back) #;(printf "update-possible-fail ~a, ~a\n" res back)
(cond (cond
[(and (res? res) (not (res-possible-error res))) [(and (res? res) (not (res-possible-error res)))
(cond (cond
@ -449,18 +449,18 @@
[(and (repeat-res? rpt) (res? (repeat-res-a rpt))) [(and (repeat-res? rpt) (res? (repeat-res-a rpt)))
(let ([inn (repeat-res-a rpt)] (let ([inn (repeat-res-a rpt)]
[stop (repeat-res-stop rpt)]) [stop (repeat-res-stop rpt)])
#;(printf "in repeat->res for ~a~n" name) #;(printf "in repeat->res for ~a\n" name)
#;(when (fail-type? stop) #;(when (fail-type? stop)
(printf "stoped on ~a~n" (fail-type-name stop))) (printf "stoped on ~a\n" (fail-type-name stop)))
#;(printf "stop ~a~n" stop) #;(printf "stop ~a\n" stop)
#;(when (choice-res? back) #;(when (choice-res? back)
(printf "back on ~a~n" (choice-res-name back))) (printf "back on ~a\n" (choice-res-name back)))
#;(when (choice-res? back) (printf "choice-res-errors back ~a~n" #;(when (choice-res? back) (printf "choice-res-errors back ~a\n"
(choice-res-errors back))) (choice-res-errors back)))
#;(when (and (fail-type? stop) #;(when (and (fail-type? stop)
(choice-res? back) (choice-res? back)
(choice-res-errors back)) (choice-res-errors back))
(printf "chances ~a > ~a -> ~a ~n" (printf "chances ~a > ~a -> ~a \n"
(fail-type-chance (choice-res-errors back)) (fail-type-chance (choice-res-errors back))
(fail-type-chance stop) (fail-type-chance stop)
(>= (fail-type-chance (choice-res-errors back)) (>= (fail-type-chance (choice-res-errors back))
@ -490,14 +490,14 @@
[(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res)) [(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res))
(update-possible-fail old-res look-back)] (update-possible-fail old-res look-back)]
[(repeat-res? old-res) [(repeat-res? old-res)
#;(printf "finished on repeat-res for ~a res ~n" name #;old-res) #;(printf "finished on repeat-res for ~a res \n" name #;old-res)
(repeat->res old-res look-back)] (repeat->res old-res look-back)]
[(pair? old-res) [(pair? old-res)
#;(printf "finished on pairs of res for ~a~n" name #;old-res) #;(printf "finished on pairs of res for ~a\n" name #;old-res)
(map (lambda (r) (repeat->res r look-back)) (flatten old-res))] (map (lambda (r) (repeat->res r look-back)) (flatten old-res))]
[else [else
#;(printf "There was an error for ~a~n" name) #;(printf "There was an error for ~a\n" name)
#;(printf "length seen ~a length rest ~a~n" (length seen) (length (res-rest old-res))) #;(printf "length seen ~a length rest ~a\n" (length seen) (length (res-rest old-res)))
(fail-res (res-rest old-res) (fail-res (res-rest old-res)
(let*-values ([(fail) (res-msg old-res)] (let*-values ([(fail) (res-msg old-res)]
[(possible-fail) [(possible-fail)
@ -534,35 +534,35 @@
(res-first-tok old-res))] (res-first-tok old-res))]
[(seen-len) (length seen)] [(seen-len) (length seen)]
[(updated-len) (+ (- used seen-len) len)]) [(updated-len) (+ (- used seen-len) len)])
#;(printf "sequence ~a failed.~n seen ~a~n" name (reverse seen)) #;(printf "sequence ~a failed.\n seen ~a\n" name (reverse seen))
#;(when (repeat-res? look-back) #;(when (repeat-res? look-back)
(printf "look-back repeat-res ~a : ~a vs ~a : ~a > ~a~n" (printf "look-back repeat-res ~a : ~a vs ~a : ~a > ~a\n"
(fail-type? (repeat-res-stop look-back)) (fail-type? (repeat-res-stop look-back))
(and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back))) (and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back)))
(fail-type-name (res-msg old-res)) (fail-type-name (res-msg old-res))
(and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back))) (and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back)))
(fail-type-chance (res-msg old-res)))) (fail-type-chance (res-msg old-res))))
#;(when (choice-res? look-back) #;(when (choice-res? look-back)
(printf "look-back choice: ~a vs ~a : ~a > ~a~n" (printf "look-back choice: ~a vs ~a : ~a > ~a\n"
(choice-res-name look-back) (choice-res-name look-back)
(fail-type-name (res-msg old-res)) (fail-type-name (res-msg old-res))
(and (choice-res-errors look-back) (and (choice-res-errors look-back)
(fail-type-chance (choice-res-errors look-back))) (fail-type-chance (choice-res-errors look-back)))
(fail-type-chance (res-msg old-res))) (fail-type-chance (res-msg old-res)))
(printf "look-back choice and useds: ~a vs ~a -- ~a ~n" (printf "look-back choice and useds: ~a vs ~a -- ~a \n"
used (and (res? look-back-ref) (res-used look-back-ref)) used (and (res? look-back-ref) (res-used look-back-ref))
(and (choice-res-errors look-back) (and (choice-res-errors look-back)
(fail-type-used (choice-res-errors look-back))))) (fail-type-used (choice-res-errors look-back)))))
#;(when (pair? look-back) #;(when (pair? look-back)
(printf "look-back is a pair~n")) (printf "look-back is a pair\n"))
#;(when (res? look-back) #;(when (res? look-back)
(printf "look-back res ~a : ~a vs ~a : ~a > ~a~n" (printf "look-back res ~a : ~a vs ~a : ~a > ~a\n"
(fail-type? (res-possible-error look-back)) (fail-type? (res-possible-error look-back))
(and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back))) (and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back)))
(fail-type-name (res-msg old-res)) (fail-type-name (res-msg old-res))
(and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back))) (and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back)))
(fail-type-chance (res-msg old-res))) (fail-type-chance (res-msg old-res)))
(printf "lookback ~a~n" (res-possible-error look-back))) (printf "lookback ~a\n" (res-possible-error look-back)))
(let* ([seq-fail-maker (let* ([seq-fail-maker
(lambda (fail used) (lambda (fail used)
(let-values ([(kind expected found) (get-fail-info fail)]) (let-values ([(kind expected found) (get-fail-info fail)])
@ -584,12 +584,12 @@
(res? look-back-ref)) (res? look-back-ref))
(- used (res-used look-back-ref)) used)))] (- used (res-used look-back-ref)) used)))]
[opt-fails (list seq-fail pos-fail)]) [opt-fails (list seq-fail pos-fail)])
#;(printf "pos-fail? ~a~n" (and pos-fail #t)) #;(printf "pos-fail? ~a\n" (and pos-fail #t))
#;(printf "seq-fail ~a~n" seq-fail) #;(printf "seq-fail ~a\n" seq-fail)
#;(when pos-fail #;(when pos-fail
(printf "used ~a look-back-ref used ~a ~n" (printf "used ~a look-back-ref used ~a \n"
used (when (res? look-back-ref) (res-used look-back-ref))) used (when (res? look-back-ref) (res-used look-back-ref)))
(printf "opt-fails ~a~n" opt-fails)) (printf "opt-fails ~a\n" opt-fails))
(if pos-fail (if pos-fail
(make-options-fail (rank-choice (map fail-type-chance opt-fails)) (make-options-fail (rank-choice (map fail-type-chance opt-fails))
(map fail-type-src opt-fails) (map fail-type-src opt-fails)
@ -611,18 +611,18 @@
(* expected-no-sub (- 1 sub-chance))))]) (* expected-no-sub (- 1 sub-chance))))])
#;(when (zero? used-toks) #;(when (zero? used-toks)
(printf "compute-chance 0 case: ~a, ~a, ~a, ~a -> ~a~n" (printf "compute-chance 0 case: ~a, ~a, ~a, ~a -> ~a\n"
sub-chance expected-length num-alts may-use sub-chance expected-length num-alts may-use
(* (/ 1 num-alts) sub-chance))) (* (/ 1 num-alts) sub-chance)))
(cond (cond
#;[(zero? used-toks) (* (/ 1 num-alts) sub-chance)] #;[(zero? used-toks) (* (/ 1 num-alts) sub-chance)]
[(zero? used-toks) sub-chance #;probability-with-sub] [(zero? used-toks) sub-chance #;probability-with-sub]
[else [else
#;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a~n" #;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a\n"
expected-length seen-length used-toks num-alts may-use sub-chance) expected-length seen-length used-toks num-alts may-use sub-chance)
#;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a ~a~n" #;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a ~a\n"
revised-expectation possible-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub) revised-expectation possible-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub)
#;(printf "compute-chance answer ~a~n" probability) #;(printf "compute-chance answer ~a\n" probability)
probability]))) probability])))
;greedy-repeat: (list 'a) -> result -> (list 'a) -> result ;greedy-repeat: (list 'a) -> result -> (list 'a) -> result
@ -634,7 +634,7 @@
(lambda (curr-ans rest-ans) (lambda (curr-ans rest-ans)
(cond (cond
[(repeat-res? rest-ans) [(repeat-res? rest-ans)
#;(printf "building up the repeat answer for ~a~n" repeat-name) #;(printf "building up the repeat answer for ~a\n" repeat-name)
(cond (cond
[(res? curr-ans) [(res? curr-ans)
(let* ([a (res-a curr-ans)] (let* ([a (res-a curr-ans)]
@ -643,7 +643,7 @@
(lambda (r) (lambda (r)
(cond (cond
[(res? r) [(res? r)
#;(printf "rest is a res for ~a, res-a is ~a ~n" a repeat-name) #;(printf "rest is a res for ~a, res-a is ~a \n" a repeat-name)
(make-repeat-res (make-repeat-res
(make-res (append a (res-a r)) (res-rest r) (repeat-name) #f (make-res (append a (res-a r)) (res-rest r) (repeat-name) #f
(+ (res-used curr-ans) (res-used r)) (+ (res-used curr-ans) (res-used r))
@ -653,10 +653,10 @@
(error 'parser-internal-error9 (format "~a" r))]))]) (error 'parser-internal-error9 (format "~a" r))]))])
(cond (cond
[(and (pair? rest) (null? (cdr rest))) [(and (pair? rest) (null? (cdr rest)))
#;(printf "rest is a one-element list for ~a~n" repeat-name) #;(printf "rest is a one-element list for ~a\n" repeat-name)
(repeat-build (car rest))] (repeat-build (car rest))]
[(pair? rest) [(pair? rest)
#;(printf "rest is a pair for ~a ~a~n" repeat-name (length rest)) #;(printf "rest is a pair for ~a ~a\n" repeat-name (length rest))
(map repeat-build (flatten rest))] (map repeat-build (flatten rest))]
[else (repeat-build rest)]))] [else (repeat-build rest)]))]
[else (error 'parser-internal-error12 (format "~a" curr-ans))])] [else (error 'parser-internal-error12 (format "~a" curr-ans))])]
@ -678,24 +678,24 @@
[else [else
(let ([ans (let ([ans
(let loop ([curr-input input] [curr-src start-src]) (let loop ([curr-input input] [curr-src start-src])
#;(printf "length of curr-input for ~a ~a~n" repeat-name (length curr-input)) #;(printf "length of curr-input for ~a ~a\n" repeat-name (length curr-input))
#;(printf "curr-input ~a~n" (map position-token-token curr-input)) #;(printf "curr-input ~a\n" (map position-token-token curr-input))
(cond (cond
[(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)] [(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)]
[(null? curr-input) [(null? curr-input)
#;(printf "out of input for ~a~n" (repeat-name)) #;(printf "out of input for ~a\n" (repeat-name))
(make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)] (make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
[else [else
(let ([this-res (sub curr-input curr-src)]) (let ([this-res (sub curr-input curr-src)])
#;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name)) #;(printf "Repeat of ~a called it's repeated entity \n" (repeat-name))
(cond (cond
[(and (res? this-res) (res-a this-res)) [(and (res? this-res) (res-a this-res))
#;(printf "loop again case for ~a~n" (repeat-name)) #;(printf "loop again case for ~a\n" (repeat-name))
(process-rest this-res (process-rest this-res
(loop (res-rest this-res) (loop (res-rest this-res)
(update-src (res-rest this-res) curr-src)))] (update-src (res-rest this-res) curr-src)))]
[(res? this-res) [(res? this-res)
#;(printf "fail for error case of ~a: ~a ~a~n" #;(printf "fail for error case of ~a: ~a ~a\n"
repeat-name repeat-name
(cond (cond
[(choice-fail? (res-msg this-res)) 'choice] [(choice-fail? (res-msg this-res)) 'choice]
@ -708,7 +708,7 @@
(weak-map-put! inner-memo-table curr-input fail) (weak-map-put! inner-memo-table curr-input fail)
fail)] fail)]
[(repeat-res? this-res) [(repeat-res? this-res)
#;(printf "repeat-res case of ~a~n" repeat-name) #;(printf "repeat-res case of ~a\n" repeat-name)
(process-rest (repeat-res-a this-res) (process-rest (repeat-res-a this-res)
(res-rest (repeat-res-a this-res)))] (res-rest (repeat-res-a this-res)))]
[(lazy-opts? this-res) [(lazy-opts? this-res)
@ -728,7 +728,7 @@
[(or (choice-res? this-res) (pair? this-res)) [(or (choice-res? this-res) (pair? this-res))
(let ([list-of-answer (let ([list-of-answer
(if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))]) (if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))])
#;(printf "repeat call of ~a, choice-res ~a~n" #;(printf "repeat call of ~a, choice-res ~a\n"
repeat-name repeat-name
(and (choice-res? this-res) (and (choice-res? this-res)
(length list-of-answer))) (length list-of-answer)))
@ -740,7 +740,7 @@
curr-src)))] curr-src)))]
[else [else
(map (lambda (match) (map (lambda (match)
#;(printf "calling repeat loop again ~a, res-rest match ~a~n" #;(printf "calling repeat loop again ~a, res-rest match ~a\n"
(repeat-name) (length (res-rest match))) (repeat-name) (length (res-rest match)))
(process-rest match (process-rest match
(loop (res-rest match) (loop (res-rest match)
@ -748,7 +748,7 @@
list-of-answer)]))] list-of-answer)]))]
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))]) [else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
(weak-map-put! memo-table input ans) (weak-map-put! memo-table input ans)
#;(printf "repeat of ~a ended with ans ~n" repeat-name #;ans) #;(printf "repeat of ~a ended with ans \n" repeat-name #;ans)
ans)])))) ans)]))))
;choice: [list [[list 'a ] -> result]] name -> result ;choice: [list [[list 'a ] -> result]] name -> result
@ -758,8 +758,8 @@
[num-choices (length opt-list)] [num-choices (length opt-list)]
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
#;(unless (eq? input return-name) (printf "choice ~a~n" name)) #;(unless (eq? input return-name) (printf "choice ~a\n" name))
#;(printf "possible options are ~a~n" (choice-names)) #;(printf "possible options are ~a\n" (choice-names))
(let ([sub-opts (sub1 (+ alts num-choices))]) (let ([sub-opts (sub1 (+ alts num-choices))])
(cond (cond
[(eq? input return-name) name] [(eq? input return-name) name]
@ -772,11 +772,11 @@
terminal-counts))] terminal-counts))]
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)] [(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
[else [else
#;(printf "choice ~a~n" name) #;(printf "choice ~a\n" name)
#;(printf "possible options are ~a~n" (choice-names)) #;(printf "possible options are ~a\n" (choice-names))
(let*-values (let*-values
([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)] ([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)]
#;[a (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options)] #;[a (printf "choice-options ~a \n ~a \n\n\n" choice-names options)]
[(fails) (map (lambda (x) [(fails) (map (lambda (x)
(cond (cond
[(res? x) (res-msg x)] [(res? x) (res-msg x)]
@ -806,9 +806,9 @@
(cond (cond
[(null? corrects) (fail-res input (fail-builder fails))] [(null? corrects) (fail-res input (fail-builder fails))]
[else (make-choice-res name corrects (fail-builder errors))])]) [else (make-choice-res name corrects (fail-builder errors))])])
#;(printf "choice ~a is returning options were ~a ~n" name (choice-names)) #;(printf "choice ~a is returning options were ~a \n" name (choice-names))
#;(printf "corrects were ~a~n" corrects) #;(printf "corrects were ~a\n" corrects)
#;(printf "errors were ~a~n" errors) #;(printf "errors were ~a\n" errors)
(weak-map-put! memo-table input ans) ans)]))))) (weak-map-put! memo-table input ans) ans)])))))
;choice: [list [[list 'a ] -> result]] name -> result ;choice: [list [[list 'a ] -> result]] name -> result
@ -817,8 +817,8 @@
[num-choices (length opt-list)] [num-choices (length opt-list)]
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
#;(unless (eq? input return-name) (printf "choice ~a~n" name)) #;(unless (eq? input return-name) (printf "choice ~a\n" name))
#;(printf "possible options are ~a~n" choice-names) #;(printf "possible options are ~a\n" choice-names)
(let ([sub-opts (sub1 (+ alts num-choices))]) (let ([sub-opts (sub1 (+ alts num-choices))])
(cond (cond
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)] [(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
@ -842,7 +842,7 @@
(if (next-opt initial-ans) (if (next-opt initial-ans)
initial-ans initial-ans
(fail-res input (lazy-opts-errors initial-ans)))]) (fail-res input (lazy-opts-errors initial-ans)))])
#;(printf "choice ~a is returning options were ~a, answer is ~a ~n" name (choice-names) ans) #;(printf "choice ~a is returning options were ~a, answer is ~a \n" name (choice-names) ans)
(weak-map-put! memo-table input ans) ans)]))))) (weak-map-put! memo-table input ans) ans)])))))
(define (flatten lst) (define (flatten lst)

36
collects/combinator-parser/private-combinator/errors.scm
View File

@ -24,7 +24,7 @@
(list? (car (fail-type-src fail-type)))) (list? (car (fail-type-src fail-type))))
(car (fail-type-src fail-type)) (car (fail-type-src fail-type))
(fail-type-src fail-type))))]) (fail-type-src fail-type))))])
#;(printf "fail-type->message ~a~n" fail-type) #;(printf "fail-type->message ~a\n" fail-type)
(cond (cond
[(terminal-fail? fail-type) [(terminal-fail? fail-type)
(collapse-message (collapse-message
@ -43,7 +43,7 @@
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)])) (input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
name #f message-to-date))] name #f message-to-date))]
[(sequence-fail? fail-type) [(sequence-fail? fail-type)
#;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type)) #;(printf "sequence-fail case: kind is ~a\n" (sequence-fail-kind fail-type))
(let* ([curr-id (sequence-fail-id fail-type)] (let* ([curr-id (sequence-fail-id fail-type)]
[id-name [id-name
(if curr-id (string-append name " " (sequence-fail-id fail-type)) name)] (if curr-id (string-append name " " (sequence-fail-id fail-type)) name)]
@ -54,7 +54,7 @@
[(end) [(end)
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "Expected ~a to contain ~a ~a to complete the ~a. ~nFound ~a before ~a ended." (msg (format "Expected ~a to contain ~a ~a to complete the ~a. \nFound ~a before ~a ended."
input-type a2 expected id-name (format-seen show-sequence) input-type)) input-type a2 expected id-name (format-seen show-sequence) input-type))
name curr-id message-to-date))] name curr-id message-to-date))]
[(wrong) [(wrong)
@ -95,7 +95,7 @@
name curr-id message-to-date))] name curr-id message-to-date))]
[(sub-seq choice) [(sub-seq choice)
(fail-type->message (sequence-fail-found fail-type) (fail-type->message (sequence-fail-found fail-type)
(add-to-message (msg (format "An error occured in ~a.~n" id-name)) (add-to-message (msg (format "An error occured in ~a.\n" id-name))
name (sequence-fail-id fail-type) message-to-date))] name (sequence-fail-id fail-type) message-to-date))]
[(options) [(options)
(let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type)) (let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type))
@ -106,12 +106,12 @@
name (sequence-fail-id fail-type) message-to-date)) name (sequence-fail-id fail-type) message-to-date))
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts) (fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
(add-to-message (add-to-message
(msg (format "There is an error in this ~a after ~a, the program resembles a(n) ~a here.~n" (msg (format "There is an error in this ~a after ~a, the program resembles a(n) ~a here.\n"
id-name (car (reverse show-sequence)) id-name (car (reverse show-sequence))
(fail-type-name (car sorted-opts)))) (fail-type-name (car sorted-opts))))
name (sequence-fail-id fail-type) message-to-date))))]))] name (sequence-fail-id fail-type) message-to-date))))]))]
[(options-fail? fail-type) [(options-fail? fail-type)
#;(printf "selecting for options on ~a~n" name) #;(printf "selecting for options on ~a\n" name)
(let* ([winners (select-errors (options-fail-opts fail-type))] (let* ([winners (select-errors (options-fail-opts fail-type))]
[top-names (map fail-type-name winners)] [top-names (map fail-type-name winners)]
[non-dup-tops (remove-dups top-names name)] [non-dup-tops (remove-dups top-names name)]
@ -122,7 +122,7 @@
(> (length winners) max-choice-depth)) (> (length winners) max-choice-depth))
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "An error occurred in this ~a. Program resembles these: ~a.~n" (msg (format "An error occurred in this ~a. Program resembles these: ~a.\n"
name (nice-list non-dup-tops))) name (nice-list non-dup-tops)))
name #f message-to-date))] name #f message-to-date))]
[(and (> (length winners) 1) [(and (> (length winners) 1)
@ -138,7 +138,7 @@
[else msg])]) [else msg])])
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "An error occured in the ~a. Possible errors were: ~n ~a" (msg (format "An error occured in the ~a. Possible errors were: \n ~a"
name name
(alternate-error-list (map err-msg messages)))) (alternate-error-list (map err-msg messages))))
name #f message-to-date)))]))] name #f message-to-date)))]))]
@ -147,13 +147,13 @@
(car winners) (car winners)
(add-to-message (add-to-message
(msg (msg
(format "There is an error in this ~a~a.~n" (format "There is an error in this ~a~a.\n"
name name
(if (equal? top-name name) "" (if (equal? top-name name) ""
(format ", program resembles ~a ~a" (a/an top-name) top-name)))) (format ", program resembles ~a ~a" (a/an top-name) top-name))))
name #f message-to-date))]))] name #f message-to-date))]))]
[(choice-fail? fail-type) [(choice-fail? fail-type)
#;(printf "selecting for ~a~n message-to-date ~a~n" name message-to-date) #;(printf "selecting for ~a\n message-to-date ~a\n" name message-to-date)
(let* ([winners (select-errors (choice-fail-messages fail-type))] (let* ([winners (select-errors (choice-fail-messages fail-type))]
[top-names (map fail-type-name winners)] [top-names (map fail-type-name winners)]
[top-name (car top-names)] [top-name (car top-names)]
@ -190,7 +190,7 @@
[else [else
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "An error occured in this ~a; expected ~a instead. Possible errors were:~n~a" (msg (format "An error occured in this ~a; expected ~a instead. Possible errors were:\n~a"
name (nice-list no-dup-names) name (nice-list no-dup-names)
(alternate-error-list (map err-msg messages)))) (alternate-error-list (map err-msg messages))))
name #f message-to-date))]))] name #f message-to-date))]))]
@ -198,7 +198,7 @@
(> (length winners) 1)) (> (length winners) 1))
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "An error occured in this ~a. Possible options include ~a.~n" (msg (format "An error occured in this ~a. Possible options include ~a.\n"
name (nice-list name (nice-list
(first-n max-choice-depth no-dup-names)))) (first-n max-choice-depth no-dup-names))))
name #f message-to-date))] name #f message-to-date))]
@ -206,7 +206,7 @@
(fail-type->message (fail-type->message
(car winners) (car winners)
(add-to-message (add-to-message
(msg (format "An error occured in this ~a~a.~a~n" (msg (format "An error occured in this ~a~a.~a\n"
name name
(if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here" (if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here"
(a/an top-name) top-name)) (a/an top-name) top-name))
@ -233,17 +233,17 @@
(narrow-opts chance-may-use chance-used-winners)] (narrow-opts chance-may-use chance-used-winners)]
[winners (narrow-opts chance chance-may-winners)]) [winners (narrow-opts chance chance-may-winners)])
#;(printf "all options: ~a~n" opts-list) #;(printf "all options: ~a\n" opts-list)
#;(printf "~a ~a ~a ~a ~a~n" #;(printf "~a ~a ~a ~a ~a\n"
(map fail-type-name opts-list) (map fail-type-name opts-list)
(map fail-type-chance opts-list) (map fail-type-chance opts-list)
(map fail-type-used opts-list) (map fail-type-used opts-list)
(map fail-type-may-use opts-list) (map fail-type-may-use opts-list)
(map composite opts-list)) (map composite opts-list))
#;(printf "composite round: ~a ~a ~n" #;(printf "composite round: ~a ~a \n"
(map fail-type-name composite-winners) (map fail-type-name composite-winners)
(map composite composite-winners)) (map composite composite-winners))
#;(printf "final sorting: ~a~n" (map fail-type-name winners)) #;(printf "final sorting: ~a\n" (map fail-type-name winners))
winners)) winners))
(define (first-n n lst) (define (first-n n lst)
@ -300,7 +300,7 @@
(let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l))))) (let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l)))))
(substring (car l) 0 (sub1 (string-length (car l)))) (substring (car l) 0 (sub1 (string-length (car l))))
(car l))]) (car l))])
(string-append (format "~a~a~n" #\tab msg) (string-append (format "~a~a\n" #\tab msg)
(alternate-error-list (cdr l))))])) (alternate-error-list (cdr l))))]))
(define (downcase string) (define (downcase string)

2
collects/combinator-parser/private-combinator/structs.scm
View File

@ -82,7 +82,7 @@
(define (next-opt lc) (define (next-opt lc)
(letrec ([next (letrec ([next
(lambda (lc update-errors) (lambda (lc update-errors)
#;(printf "next-opt ~a~n" lc) #;(printf "next-opt ~a\n" lc)
(cond (cond
[(null? (lazy-opts-thunks lc)) #f] [(null? (lazy-opts-thunks lc)) #f]
[else [else

16
collects/compiler/embed-unit.rkt
View File

@ -381,7 +381,7 @@
;; First use of the module. Get code and then get code for imports. ;; First use of the module. Get code and then get code for imports.
(begin (begin
(when verbose? (when verbose?
(fprintf (current-error-port) "Getting ~s~n" filename)) (fprintf (current-error-port) "Getting ~s\n" filename))
(let ([code (get-module-code filename (let ([code (get-module-code filename
"compiled" "compiled"
compiler compiler
@ -413,7 +413,7 @@
(cond (cond
[(extension? code) [(extension? code)
(when verbose? (when verbose?
(fprintf (current-error-port) " using extension: ~s~n" (extension-path code))) (fprintf (current-error-port) " using extension: ~s\n" (extension-path code)))
(set-box! codes (set-box! codes
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name prefix (string->symbol name prefix (string->symbol
@ -850,7 +850,7 @@
(quote ,(map (lambda (m) (quote ,(map (lambda (m)
(let ([p (extension-path (mod-code m))]) (let ([p (extension-path (mod-code m))])
(when verbose? (when verbose?
(fprintf (current-error-port) "Recording extension at ~s~n" p)) (fprintf (current-error-port) "Recording extension at ~s\n" p))
(list (path->bytes p) (list (path->bytes p)
(mod-full-name m) (mod-full-name m)
;; The program name isn't used. It just helps ensures that ;; The program name isn't used. It just helps ensures that
@ -942,7 +942,7 @@
(unless (or (extension? (mod-code nc)) (unless (or (extension? (mod-code nc))
(eq? nc table-mod)) (eq? nc table-mod))
(when verbose? (when verbose?
(fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc))) (fprintf (current-error-port) "Writing module from ~s\n" (mod-file nc)))
(write (compile-using-kernel (write (compile-using-kernel
`(current-module-declare-name `(current-module-declare-name
(make-resolved-module-path (make-resolved-module-path
@ -968,7 +968,7 @@
outp)))) outp))))
(for-each (lambda (f) (for-each (lambda (f)
(when verbose? (when verbose?
(fprintf (current-error-port) "Copying from ~s~n" f)) (fprintf (current-error-port) "Copying from ~s\n" f))
(call-with-input-file* f (call-with-input-file* f
(lambda (i) (lambda (i)
(copy-port i outp)))) (copy-port i outp))))
@ -1071,7 +1071,7 @@
(check-collects-path 'create-embedding-executable collects-path collects-path-bytes) (check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
(let ([exe (find-exe mred? variant)]) (let ([exe (find-exe mred? variant)])
(when verbose? (when verbose?
(fprintf (current-error-port) "Copying to ~s~n" dest)) (fprintf (current-error-port) "Copying to ~s\n" dest))
(let-values ([(dest-exe orig-exe osx?) (let-values ([(dest-exe orig-exe osx?)
(cond (cond
[(and mred? (eq? 'macosx (system-type))) [(and mred? (eq? 'macosx (system-type)))
@ -1162,7 +1162,7 @@
#:exists 'append) #:exists 'append)
(values start (file-size dest-exe))))]) (values start (file-size dest-exe))))])
(when verbose? (when verbose?
(fprintf (current-error-port) "Setting command line~n")) (fprintf (current-error-port) "Setting command line\n"))
(let ([start-s (number->string start)] (let ([start-s (number->string start)]
[end-s (number->string end)]) [end-s (number->string end)])
(let ([full-cmdline (append (let ([full-cmdline (append
@ -1180,7 +1180,7 @@
cmdline)]) cmdline)])
(when collects-path-bytes (when collects-path-bytes
(when verbose? (when verbose?
(fprintf (current-error-port) "Setting collection path~n")) (fprintf (current-error-port) "Setting collection path\n"))
(set-collects-path dest-exe collects-path-bytes)) (set-collects-path dest-exe collects-path-bytes))
(cond (cond
[osx? [osx?

6
collects/compiler/private/analyze.rkt
View File

@ -1165,9 +1165,9 @@
(begin (begin
(when (compiler:option:verbose) (when (compiler:option:verbose)
(compiler:warning ast "letrec will be rewritten with set!")) (compiler:warning ast "letrec will be rewritten with set!"))
(debug "rewriting letrec~n") (debug "rewriting letrec\n")
(let ([new-ast (letrec->let+set! ast)]) (let ([new-ast (letrec->let+set! ast)])
(debug "reanalyzing...~n") (debug "reanalyzing...\n")
(analyze! new-ast env inlined tail? wcm-tail?))))] (analyze! new-ast env inlined tail? wcm-tail?))))]
;;----------------------------------------------------- ;;-----------------------------------------------------
@ -1288,7 +1288,7 @@
(lambda (why) (lambda (why)
'(begin '(begin
(zodiac:print-start! (current-output-port) ast) (zodiac:print-start! (current-output-port) ast)
(printf "no inlining: ~a~n" (eval why))) (printf "no inlining: ~a\n" (eval why)))
(let* ([fun (let ([v (analyze!-sv (zodiac:app-fun ast) env inlined)]) (let* ([fun (let ([v (analyze!-sv (zodiac:app-fun ast) env inlined)])
(if (zodiac:varref? v) (if (zodiac:varref? v)
v v

184
collects/compiler/private/driver.rkt
View File

@ -222,7 +222,7 @@
(define s:expand-top-level-expressions! (define s:expand-top-level-expressions!
(lambda (input-directory reader verbose?) (lambda (input-directory reader verbose?)
(when verbose? (printf "~n Reading... ") (flush-output)) (when verbose? (printf "\n Reading... ") (flush-output))
;; During reads, errors are truly fatal ;; During reads, errors are truly fatal
(let ([exprs (let ([failed? #f]) (let ([exprs (let ([failed? #f])
(let loop ([n 1]) (let loop ([n 1])
@ -238,7 +238,7 @@
(cons sexp (loop (+ n 1))))))))]) (cons sexp (loop (+ n 1))))))))])
(unless (null? compiler:messages) (when (compiler:option:verbose) (newline))) (unless (null? compiler:messages) (when (compiler:option:verbose) (newline)))
(compiler:report-messages! #t) (compiler:report-messages! #t)
(when verbose? (printf " expanding...~n")) (when verbose? (printf " expanding...\n"))
(parameterize ([current-load-relative-directory input-directory]) (parameterize ([current-load-relative-directory input-directory])
(map (lambda (expr) (map (lambda (expr)
(let ([expanded ((if has-prefix? (let ([expanded ((if has-prefix?
@ -314,7 +314,7 @@
max-arity) max-arity)
(begin (begin
;; (printf "~a~n" (syntax-line (zodiac:zodiac-stx (car sexps)))) ;; (printf "~a\n" (syntax-line (zodiac:zodiac-stx (car sexps))))
(let-values ([(exp free-vars local-vars global-vars used-vars captured-vars (let-values ([(exp free-vars local-vars global-vars used-vars captured-vars
children new-max-arity multi) children new-max-arity multi)
@ -492,7 +492,7 @@
[string (compiler:message-message message)]) [string (compiler:message-message message)])
(zodiac:print-start! (current-output-port) ast) (zodiac:print-start! (current-output-port) ast)
(printf (printf
"~a: ~a~n" "~a: ~a\n"
(cond (cond
[(compiler:error-msg? message) "Error"] [(compiler:error-msg? message) "Error"]
[(compiler:warning-msg? message) "Warning"] [(compiler:warning-msg? message) "Warning"]
@ -503,9 +503,9 @@
(when (compiler:internal-error-msg? message) (when (compiler:internal-error-msg? message)
(printf (printf
(string-append (string-append
" please report the bug using Help Desk~n" " please report the bug using DrRacket\n"
" or http://bugs.racket-lang.org/~n" " or http://bugs.racket-lang.org/\n"
" and include a transcript in verbose mode~n"))))) " and include a transcript in verbose mode\n")))))
msgs) msgs)
(when (and stop-on-errors? (when (and stop-on-errors?
@ -521,7 +521,7 @@
(set! total-cpu-time (+ total-cpu-time cpu)) (set! total-cpu-time (+ total-cpu-time cpu))
(set! total-real-time (+ total-real-time real)) (set! total-real-time (+ total-real-time real))
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " [cpu: ~ams, real: ~ams, gc: ~ams]~n" cpu real gc)) (printf " [cpu: ~ams, real: ~ams, gc: ~ams]\n" cpu real gc))
(apply values vals)))) (apply values vals))))
;;----------------------------------------------------------------------------- ;;-----------------------------------------------------------------------------
@ -704,8 +704,8 @@
;; Extract stateless, phaseless core, leaving the rest of bytecode ;; Extract stateless, phaseless core, leaving the rest of bytecode
;; ;;
(when (compiler:option:verbose) (printf " extracting core expressions~n")) (when (compiler:option:verbose) (printf " extracting core expressions\n"))
(when (compiler:option:debug) (debug " = CORE =~n")) (when (compiler:option:debug) (debug " = CORE =\n"))
(let ([core-thunk (let ([core-thunk
(lambda () (lambda ()
@ -736,8 +736,8 @@
;; Run a preprocessing phase on the input ;; Run a preprocessing phase on the input
;; ;;
(when (compiler:option:verbose) (printf " pre-processing and scanning for errors~n")) (when (compiler:option:verbose) (printf " pre-processing and scanning for errors\n"))
(when (compiler:option:debug) (debug " = PREPHASE =~n")) (when (compiler:option:debug) (debug " = PREPHASE =\n"))
(let ([prephase-thunk (let ([prephase-thunk
(lambda () (lambda ()
@ -758,7 +758,7 @@
(verbose-time prephase-thunk)) (verbose-time prephase-thunk))
(compiler:report-messages! (not (compiler:option:test))) (compiler:report-messages! (not (compiler:option:test)))
(when (compiler:option:test) (when (compiler:option:test)
(printf "skipping over top-level expressions with errors...~n")) (printf "skipping over top-level expressions with errors...\n"))
; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block)) ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
@ -766,8 +766,8 @@
;; A-normalize input ;; A-normalize input
;; ;;
(when (compiler:option:verbose) (printf " transforming to a-normal form~n")) (when (compiler:option:verbose) (printf " transforming to a-normal form\n"))
(when (compiler:option:debug) (debug " = ANORM =~n")) (when (compiler:option:debug) (debug " = ANORM =\n"))
(let ([anorm-thunk (let ([anorm-thunk
(lambda () (lambda ()
@ -784,9 +784,9 @@
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " determining known bindings~n")) (printf " determining known bindings\n"))
(when (compiler:option:debug) (when (compiler:option:debug)
(debug " = KNOWN =~n")) (debug " = KNOWN =\n"))
; analyze top level expressions ; analyze top level expressions
(let ([known-thunk (let ([known-thunk
@ -806,9 +806,9 @@
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " transforming to b-normal form, analyzing, and inlining~n")) (printf " transforming to b-normal form, analyzing, and inlining\n"))
(when (compiler:option:debug) (when (compiler:option:debug)
(debug " = ANALYZE =~n")) (debug " = ANALYZE =\n"))
; analyze top level expressions, cataloguing local variables ; analyze top level expressions, cataloguing local variables
(compiler:init-define-lists!) (compiler:init-define-lists!)
@ -840,9 +840,9 @@
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " finding static procedures~n")) (printf " finding static procedures\n"))
(when (compiler:option:debug) (when (compiler:option:debug)
(debug " = LIFT =~n")) (debug " = LIFT =\n"))
(let ([lift-thunk s:lift]) (let ([lift-thunk s:lift])
(verbose-time lift-thunk)) (verbose-time lift-thunk))
@ -855,7 +855,7 @@
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " closure conversion and explicit control transformation~n")) (printf " closure conversion and explicit control transformation\n"))
(let ([closure-thunk (let ([closure-thunk
(lambda () (lambda ()
@ -871,7 +871,7 @@
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " closure->vehicle mapping~n")) (printf " closure->vehicle mapping\n"))
(when (eq? (compiler:option:vehicles) 'vehicles:automatic) (when (eq? (compiler:option:vehicles) 'vehicles:automatic)
(for-each (for-each
@ -885,7 +885,7 @@
(when (eq? (compiler:option:vehicles) 'vehicles:units) (when (eq? (compiler:option:vehicles) 'vehicles:units)
(compiler:fatal-error (compiler:fatal-error
#f #f
"unit-wise vehicle mapping not currently supported~n")) "unit-wise vehicle mapping not currently supported\n"))
(let ([vehicle-thunk (let ([vehicle-thunk
(lambda () (lambda ()
(compiler:init-vehicles!) (compiler:init-vehicles!)
@ -900,7 +900,7 @@
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf (printf
" choosing data representations~n")) " choosing data representations\n"))
(let ([rep-thunk (let ([rep-thunk
(lambda () (lambda ()
@ -936,8 +936,8 @@
;; we have to update the local variable set for each top-level ;; we have to update the local variable set for each top-level
;; expression or code body. ;; expression or code body.
(when (compiler:option:verbose) (printf " transforming to Virtual Machine form~n")) (when (compiler:option:verbose) (printf " transforming to Virtual Machine form\n"))
(when (compiler:option:debug) (debug " = VMPHASE =~n")) (when (compiler:option:debug) (debug " = VMPHASE =\n"))
(let ([vmphase-thunk (let ([vmphase-thunk
(lambda () (lambda ()
@ -1018,7 +1018,7 @@
;; ;;
;; As in the previous phase, new local variables may be created. ;; As in the previous phase, new local variables may be created.
(when (compiler:option:verbose) (printf " optimizing Virtual Machine code~n")) (when (compiler:option:verbose) (printf " optimizing Virtual Machine code\n"))
(let ([vmopt-thunk (let ([vmopt-thunk
(lambda () (lambda ()
@ -1064,7 +1064,7 @@
;; Virtual Machine -> ANSI C translation ;; Virtual Machine -> ANSI C translation
;; ;;
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " [emitting ~a C to \"~a\"]~n" (printf " [emitting ~a C to \"~a\"]\n"
"ANSI" "ANSI"
c-output-path)) c-output-path))
@ -1078,38 +1078,38 @@
;;value ;;value
(lambda () (lambda ()
(fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name) (fprintf c-port "#define MZC_SRC_FILE ~s\n" input-name)
(when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n")) (when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1\n"))
(when (compiler:option:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1~n")) (when (compiler:option:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1\n"))
(when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1~n")) (when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1\n"))
(fprintf c-port "~n#include \"~ascheme.h\"~n" (fprintf c-port "\n#include \"~ascheme.h\"\n"
(if (compiler:option:compile-for-embedded) (if (compiler:option:compile-for-embedded)
"" ""
"e")) "e"))
(unless (null? c-declares) (unless (null? c-declares)
(fprintf c-port "~n/* c-declare literals */~n~n") (fprintf c-port "\n/* c-declare literals */\n\n")
(for-each (for-each
(lambda (c-declare) (lambda (c-declare)
(fprintf c-port "~a~n" c-declare)) (fprintf c-port "~a\n" c-declare))
(reverse c-declares)) (reverse c-declares))
(fprintf c-port "~n/* done with c-declare literals */~n~n")) (fprintf c-port "\n/* done with c-declare literals */\n\n"))
(unless (null? c-lambdas) (unless (null? c-lambdas)
(fprintf c-port "~n/* c-lambda implementations */~n~n") (fprintf c-port "\n/* c-lambda implementations */\n\n")
(for-each (for-each
(lambda (c-lambda) (lambda (c-lambda)
(let ([name (car c-lambda)] (let ([name (car c-lambda)]
[body (cdr c-lambda)]) [body (cdr c-lambda)])
(fprintf c-port "Scheme_Object *~a(int argc, Scheme_Object **argv) {\n" (fprintf c-port "Scheme_Object *~a(int argc, Scheme_Object **argv) {\n"
name) name)
(fprintf c-port "~a~n" body) (fprintf c-port "~a\n" body)
(fprintf c-port "}~n"))) (fprintf c-port "}\n")))
(reverse c-lambdas)) (reverse c-lambdas))
(fprintf c-port "~n/* done with c-lambda implementations */~n~n")) (fprintf c-port "\n/* done with c-lambda implementations */\n\n"))
(fprintf c-port "#include \"mzc.h\"~n~n") (fprintf c-port "#include \"mzc.h\"\n\n")
(vm->c:emit-struct-definitions! (compiler:get-structs) c-port) (vm->c:emit-struct-definitions! (compiler:get-structs) c-port)
(vm->c:emit-symbol-declarations! c-port) (vm->c:emit-symbol-declarations! c-port)
(vm->c:emit-inexact-declarations! c-port) (vm->c:emit-inexact-declarations! c-port)
@ -1138,27 +1138,27 @@
(newline c-port) (newline c-port)
(unless (compiler:multi-o-constant-pool) (unless (compiler:multi-o-constant-pool)
(fprintf c-port "~nstatic void make_symbols()~n{~n") (fprintf c-port "\nstatic void make_symbols()\n{\n")
(vm->c:emit-symbol-definitions! c-port) (vm->c:emit-symbol-definitions! c-port)
(fprintf c-port "}~n")) (fprintf c-port "}\n"))
(unless (zero? (const:get-inexact-counter)) (unless (zero? (const:get-inexact-counter))
(fprintf c-port "~nstatic void make_inexacts()~n{~n") (fprintf c-port "\nstatic void make_inexacts()\n{\n")
(vm->c:emit-inexact-definitions! c-port) (vm->c:emit-inexact-definitions! c-port)
(fprintf c-port "}~n")) (fprintf c-port "}\n"))
(fprintf c-port "~nstatic void gc_registration()~n{~n") (fprintf c-port "\nstatic void gc_registration()\n{\n")
(vm->c:emit-registration! c-port) (vm->c:emit-registration! c-port)
(fprintf c-port "}~n") (fprintf c-port "}\n")
(fprintf c-port "~nstatic void init_prims(Scheme_Env * env)~n{~n") (fprintf c-port "\nstatic void init_prims(Scheme_Env * env)\n{\n")
(vm->c:emit-prim-ref-definitions! c-port) (vm->c:emit-prim-ref-definitions! c-port)
(fprintf c-port "}~n") (fprintf c-port "}\n")
(unless (null? (compiler:get-case-lambdas)) (unless (null? (compiler:get-case-lambdas))
(fprintf c-port "~nstatic void init_cases_arities()~n{~n") (fprintf c-port "\nstatic void init_cases_arities()\n{\n")
(vm->c:emit-case-arities-definitions! c-port) (vm->c:emit-case-arities-definitions! c-port)
(fprintf c-port "}~n")) (fprintf c-port "}\n"))
(newline c-port) (newline c-port)
(let* ([codes (block-codes s:file-block)] (let* ([codes (block-codes s:file-block)]
@ -1182,91 +1182,91 @@
#f #f ; no module entries #f #f ; no module entries
c-port)]) c-port)])
(fprintf c-port (fprintf c-port
"static Scheme_Object * do_scheme_reload(Scheme_Env * env)~n{~n") "static Scheme_Object * do_scheme_reload(Scheme_Env * env)\n{\n")
(fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n" (fprintf c-port"~aScheme_Per_Load_Statics *PLS;\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(fprintf c-port (fprintf c-port
"~aPLS = (Scheme_Per_Load_Statics *)scheme_malloc(sizeof(Scheme_Per_Load_Statics));~n" "~aPLS = (Scheme_Per_Load_Statics *)scheme_malloc(sizeof(Scheme_Per_Load_Statics));\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(let loop ([c 0]) (let loop ([c 0])
(fprintf c-port "~a~atop_level_~a(env, PLS);~n" (fprintf c-port "~a~atop_level_~a(env, PLS);\n"
vm->c:indent-spaces vm->c:indent-spaces
(if (= c top-level-count) "return " "") (if (= c top-level-count) "return " "")
c) c)
(unless (= c top-level-count) (unless (= c top-level-count)
(loop (add1 c)))) (loop (add1 c))))
(fprintf c-port (fprintf c-port
"}~n~n") "}\n\n")
(fprintf c-port (fprintf c-port
"Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n" "Scheme_Object * scheme_reload~a(Scheme_Env * env)\n{\n"
compiler:setup-suffix) compiler:setup-suffix)
(fprintf c-port"~areturn do_scheme_reload(env);~n" (fprintf c-port"~areturn do_scheme_reload(env);\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(fprintf c-port (fprintf c-port
"}~n~n") "}\n\n")
(fprintf c-port (fprintf c-port
"~nstatic void do_scheme_setup(Scheme_Env * env)~n{~n") "\nstatic void do_scheme_setup(Scheme_Env * env)\n{\n")
(fprintf c-port (fprintf c-port
"~ascheme_set_tail_buffer_size(~a);~n" "~ascheme_set_tail_buffer_size(~a);\n"
vm->c:indent-spaces vm->c:indent-spaces
s:max-arity) s:max-arity)
(fprintf c-port "~agc_registration();~n" (fprintf c-port "~agc_registration();\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(unless (compiler:multi-o-constant-pool) (unless (compiler:multi-o-constant-pool)
(fprintf c-port "~amake_symbols();~n" (fprintf c-port "~amake_symbols();\n"
vm->c:indent-spaces)) vm->c:indent-spaces))
(unless (zero? (const:get-inexact-counter)) (unless (zero? (const:get-inexact-counter))
(fprintf c-port "~amake_inexacts();~n" (fprintf c-port "~amake_inexacts();\n"
vm->c:indent-spaces)) vm->c:indent-spaces))
(fprintf c-port "~ainit_prims(env);~n" (fprintf c-port "~ainit_prims(env);\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(unless (null? (compiler:get-case-lambdas)) (unless (null? (compiler:get-case-lambdas))
(fprintf c-port "~ainit_cases_arities();~n" (fprintf c-port "~ainit_cases_arities();\n"
vm->c:indent-spaces)) vm->c:indent-spaces))
(let loop ([c 0]) (let loop ([c 0])
(unless (> c init-constants-count) (unless (> c init-constants-count)
(fprintf c-port "~ainit_constants_~a(env);~n" (fprintf c-port "~ainit_constants_~a(env);\n"
vm->c:indent-spaces vm->c:indent-spaces
c) c)
(loop (add1 c)))) (loop (add1 c))))
(fprintf c-port (fprintf c-port
"}~n~n") "}\n\n")
(fprintf c-port (fprintf c-port
"~nvoid scheme_setup~a(Scheme_Env * env)~n{~n" "\nvoid scheme_setup~a(Scheme_Env * env)\n{\n"
compiler:setup-suffix) compiler:setup-suffix)
(fprintf c-port (fprintf c-port
"~ado_scheme_setup(env);~n" "~ado_scheme_setup(env);\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(fprintf c-port (fprintf c-port
"}~n~n") "}\n\n")
(when (string=? "" compiler:setup-suffix) (when (string=? "" compiler:setup-suffix)
(fprintf c-port (fprintf c-port
"~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n") "\nScheme_Object * scheme_initialize(Scheme_Env * env)\n{\n")
(fprintf c-port "~ado_scheme_setup~a(env);~n" (fprintf c-port "~ado_scheme_setup~a(env);\n"
vm->c:indent-spaces vm->c:indent-spaces
compiler:setup-suffix) compiler:setup-suffix)
(fprintf c-port "~areturn do_scheme_reload~a(env);~n" (fprintf c-port "~areturn do_scheme_reload~a(env);\n"
vm->c:indent-spaces vm->c:indent-spaces
compiler:setup-suffix) compiler:setup-suffix)
(fprintf c-port (fprintf c-port
"}~n~n")) "}\n\n"))
(fprintf c-port (fprintf c-port
"~nScheme_Object * ~ascheme_module_name()~n{~n~areturn " "\nScheme_Object * ~ascheme_module_name()\n{\n~areturn "
compiler:setup-suffix compiler:setup-suffix
vm->c:indent-spaces) vm->c:indent-spaces)
(if compiler:module-decl-name (if compiler:module-decl-name
(let ([s (symbol->string compiler:module-decl-name)]) (let ([s (symbol->string compiler:module-decl-name)])
(fprintf c-port "scheme_intern_exact_symbol(~s, ~a)" s (string-length s))) (fprintf c-port "scheme_intern_exact_symbol(~s, ~a)" s (string-length s)))
(fprintf c-port "scheme_false")) (fprintf c-port "scheme_false"))
(fprintf c-port ";~n}~n")) (fprintf c-port ";\n}\n"))
(let emit-vehicles ([vehicle-number 0]) (let emit-vehicles ([vehicle-number 0])
(unless (= vehicle-number (compiler:get-total-vehicles)) (unless (= vehicle-number (compiler:get-total-vehicles))
@ -1288,7 +1288,7 @@
(for-each (lambda (L) (for-each (lambda (L)
(let ([code (get-annotation L)] (let ([code (get-annotation L)]
[start (zodiac:zodiac-start L)]) [start (zodiac:zodiac-start L)])
(fprintf c-port "~a/* code body ~a ~a [~a,~a] */~n" (fprintf c-port "~a/* code body ~a ~a [~a,~a] */\n"
vm->c:indent-spaces (closure-code-label code) vm->c:indent-spaces (closure-code-label code)
(let ([n (closure-code-name code)]) (let ([n (closure-code-name code)])
(if n (if n
@ -1311,11 +1311,11 @@
(vm->c:emit-case-prologue L i (vm->c:emit-case-prologue L i
(lambda () (lambda ()
(if suffix? (if suffix?
(fprintf c-port "~a~a/* begin case ~a */~n~a~a{~n" (fprintf c-port "~a~a/* begin case ~a */\n~a~a{\n"
vm->c:indent-spaces vm->c:indent-spaces i vm->c:indent-spaces vm->c:indent-spaces i
vm->c:indent-spaces vm->c:indent-spaces) vm->c:indent-spaces vm->c:indent-spaces)
(when (zero? i) (when (zero? i)
(fprintf c-port "~a{~n" vm->c:indent-spaces)))) (fprintf c-port "~a{\n" vm->c:indent-spaces))))
(if suffix? (format "c~a" i) "") (if suffix? (format "c~a" i) "")
indent indent
c-port)]) c-port)])
@ -1327,7 +1327,7 @@
-1) -1)
(vm->c:emit-case-epilogue L i undefines indent c-port) (vm->c:emit-case-epilogue L i undefines indent c-port)
(when suffix? (when suffix?
(fprintf c-port "~a~a} /* end case ~a */~n" (fprintf c-port "~a~a} /* end case ~a */\n"
vm->c:indent-spaces vm->c:indent-spaces
vm->c:indent-spaces i))) vm->c:indent-spaces i)))
@ -1359,9 +1359,9 @@
(when (compiler:multi-o-constant-pool) (when (compiler:multi-o-constant-pool)
(call-with-output-file constant-pool-output-path (call-with-output-file constant-pool-output-path
(lambda (port) (lambda (port)
(fprintf port "(~s~n (symbols~n" compiler:setup-suffix) (fprintf port "(~s\n (symbols\n" compiler:setup-suffix)
(vm->c:emit-symbol-list! port "" #f) (vm->c:emit-symbol-list! port "" #f)
(fprintf port " )~n )~n"))))))) (fprintf port " )\n )\n")))))))
;;----------------------------------------------------------------------- ;;-----------------------------------------------------------------------
;; 3m xform ;; 3m xform
@ -1369,7 +1369,7 @@
(when c3m-output-path (when c3m-output-path
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " [xforming C to \"~a\"]~n" (printf " [xforming C to \"~a\"]\n"
c3m-output-path)) c3m-output-path))
(let ([clean-up-src-c (let ([clean-up-src-c
@ -1400,14 +1400,14 @@
(if c-only? (if c-only?
(when (compiler:option:somewhat-verbose) (when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]~n" (or c3m-output-path c-output-path))) (printf " [output to \"~a\"]\n" (or c3m-output-path c-output-path)))
(begin (begin
(unless input-path (unless input-path
(when (compiler:option:somewhat-verbose) (when (compiler:option:somewhat-verbose)
(printf "\"~a\": ~n" (or c3m-output-path c-output-path)))) (printf "\"~a\": \n" (or c3m-output-path c-output-path))))
(when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n" (when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]\n"
obj-output-path)) obj-output-path))
(let ([clean-up (let ([clean-up
@ -1440,11 +1440,11 @@
(if multi-o? (if multi-o?
(when (compiler:option:somewhat-verbose) (when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]~n" obj-output-path)) (printf " [output to \"~a\"]\n" obj-output-path))
(begin (begin
;; Link ;; Link
(when (compiler:option:verbose) (printf " [linking to \"~a\"]~n" (when (compiler:option:verbose) (printf " [linking to \"~a\"]\n"
dll-output-path)) dll-output-path))
(let ([link-thunk (let ([link-thunk
(lambda () (lambda ()
@ -1465,7 +1465,7 @@
(delete-file obj-output-path)) (delete-file obj-output-path))
(when (compiler:option:somewhat-verbose) (when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]~n" dll-output-path)))))) (printf " [output to \"~a\"]\n" dll-output-path))))))
(when debug:port (when debug:port
(close-output-port debug:port)) (close-output-port debug:port))
@ -1477,6 +1477,6 @@
(compiler:init-structs!) (compiler:init-structs!)
(set! s:file-block #f) (set! s:file-block #f)
(when (compiler:option:verbose) (when (compiler:option:verbose)
(printf " finished [cpu ~a, real ~a].~n" (printf " finished [cpu ~a, real ~a].\n"
total-cpu-time total-cpu-time
total-real-time))))))) total-real-time)))))))

2
collects/compiler/private/library.rkt
View File

@ -95,7 +95,7 @@
(let ([i set-next-index]) (let ([i set-next-index])
(set! set-next-index (add1 set-next-index)) (set! set-next-index (add1 set-next-index))
(unless (< i (vector-length index-vector)) (unless (< i (vector-length index-vector))
(printf "grow ~a~n" i) (printf "grow ~a\n" i)
(let* ([old-iv index-vector] (let* ([old-iv index-vector]
[old-sv singleton-vector] [old-sv singleton-vector]
[old-size (vector-length index-vector)] [old-size (vector-length index-vector)]

2
collects/compiler/private/vehicle.rkt
View File

@ -137,7 +137,7 @@
vnum vnum
(lambda () (lambda ()
(compiler:internal-error (compiler:internal-error
#f "bad hash table lookup (2)~n")))] #f "bad hash table lookup (2)\n")))]
[curr-label (vehicle-total-labels vehicle)]) [curr-label (vehicle-total-labels vehicle)])
(vehicle:register-max-arity! vehicle (closure-code-max-arity code)) (vehicle:register-max-arity! vehicle (closure-code-max-arity code))
(s:register-max-arity! (closure-code-max-arity code)) (s:register-max-arity! (closure-code-max-arity code))

234
collects/compiler/private/vm2c.rkt
View File

@ -85,7 +85,7 @@
(vector-set! v (string->number (symbol->string (zodiac:varref-var b))) sym))) (vector-set! v (string->number (symbol->string (zodiac:varref-var b))) sym)))
(let loop ([i 0]) (let loop ([i 0])
(unless (= i (vector-length v)) (unless (= i (vector-length v))
(fprintf port " ~s~a ~a~n" (-symbol->string (vector-ref v i)) comma (fprintf port " ~s~a ~a\n" (-symbol->string (vector-ref v i)) comma
(if c-comment? (if c-comment?
(format "/* ~a */" i) (format "/* ~a */" i)
(format "; ~a" i))) (format "; ~a" i)))
@ -109,14 +109,14 @@
(define (vm->c:emit-symbol-declarations! port) (define (vm->c:emit-symbol-declarations! port)
(unless (zero? (const:get-symbol-counter)) (unless (zero? (const:get-symbol-counter))
(unless (compiler:multi-o-constant-pool) (unless (compiler:multi-o-constant-pool)
(fprintf port "static const char *SYMBOL_STRS[~a] = {~n" (const:get-symbol-counter)) (fprintf port "static const char *SYMBOL_STRS[~a] = {\n" (const:get-symbol-counter))
(vm->c:emit-symbol-list! port "," #t) (vm->c:emit-symbol-list! port "," #t)
(fprintf port "}; /* end of SYMBOL_STRS */~n~n") (fprintf port "}; /* end of SYMBOL_STRS */\n\n")
(fprintf port "static const long SYMBOL_LENS[~a] = {~n" (const:get-symbol-counter)) (fprintf port "static const long SYMBOL_LENS[~a] = {\n" (const:get-symbol-counter))
(vm->c:emit-symbol-length-list! port "," #t) (vm->c:emit-symbol-length-list! port "," #t)
(fprintf port "}; /* end of SYMBOL_LENS */~n~n")) (fprintf port "}; /* end of SYMBOL_LENS */\n\n"))
(fprintf port "~aScheme_Object * ~a[~a];~n~n" (fprintf port "~aScheme_Object * ~a[~a];\n\n"
(if (compiler:multi-o-constant-pool) "" "static ") (if (compiler:multi-o-constant-pool) "" "static ")
(vm->c:SYMBOLS-name) (vm->c:SYMBOLS-name)
(const:get-symbol-counter)))) (const:get-symbol-counter))))
@ -135,10 +135,10 @@
(define (vm->c:emit-inexact-declarations! port) (define (vm->c:emit-inexact-declarations! port)
(unless (zero? (const:get-inexact-counter)) (unless (zero? (const:get-inexact-counter))
(fprintf port "static const double INEXACT_NUMBERS[~a] = {~n" (const:get-inexact-counter)) (fprintf port "static const double INEXACT_NUMBERS[~a] = {\n" (const:get-inexact-counter))
(vm->c:emit-inexact-list! port "," #t) (vm->c:emit-inexact-list! port "," #t)
(fprintf port "}; /* end of INEXACT_NUMBERS */~n~n") (fprintf port "}; /* end of INEXACT_NUMBERS */\n\n")
(fprintf port "static Scheme_Object * ~a[~a];~n~n" (fprintf port "static Scheme_Object * ~a[~a];\n\n"
(vm->c:INEXACTS-name) (vm->c:INEXACTS-name)
(const:get-inexact-counter)))) (const:get-inexact-counter))))
@ -161,7 +161,7 @@
(substring str 0 (min len 24)) (substring str 0 (min len 24))
(bytes->string/latin-1 (subbytes str 0 (min len 24))))]) (bytes->string/latin-1 (subbytes str 0 (min len 24))))])
(fprintf port (fprintf port
"/* ~a */~n" "/* ~a */\n"
(list->string (map (lambda (i) (list->string (map (lambda (i)
(cond (cond
[(eq? i #\/) #\_] [(eq? i #\/) #\_]
@ -173,12 +173,12 @@
(let loop ([i 0]) (let loop ([i 0])
(unless (= i len) (unless (= i len)
(when (zero? (modulo i 20)) (when (zero? (modulo i 20))
(fprintf port "~n ")) (fprintf port "\n "))
(fprintf port "~a, " (if (string? str) (fprintf port "~a, " (if (string? str)
(char->integer (string-ref str i)) (char->integer (string-ref str i))
(bytes-ref str i))) (bytes-ref str i)))
(loop (add1 i))))) (loop (add1 i)))))
(fprintf port "0 }; /* end of ~a */~n~n" name))) (fprintf port "0 }; /* end of ~a */\n\n" name)))
(define (vm->c:emit-symbol-definitions! port) (define (vm->c:emit-symbol-definitions! port)
(unless (zero? (const:get-symbol-counter)) (unless (zero? (const:get-symbol-counter))
@ -193,7 +193,7 @@
(lambda (sym b) (lambda (sym b)
(unless (interned? sym) (unless (interned? sym)
(let ([pos (zodiac:varref-var b)]) (let ([pos (zodiac:varref-var b)])
(fprintf port " s = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n" (fprintf port " s = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */\n"
pos pos) pos pos)
(fprintf port " SYMBOLS[~a] = s;\n" pos))))))) (fprintf port " SYMBOLS[~a] = s;\n" pos)))))))
@ -208,24 +208,24 @@
(define vm->c:emit-prim-ref-declarations! (define vm->c:emit-prim-ref-declarations!
(lambda (port) (lambda (port)
(unless (set-empty? (compiler:get-primitive-refs)) (unless (set-empty? (compiler:get-primitive-refs))
(fprintf port "/* primitives referenced by the code */~n") (fprintf port "/* primitives referenced by the code */\n")
(fprintf port "static struct {~n") (fprintf port "static struct {\n")
(for-each (lambda (a) (for-each (lambda (a)
(fprintf port " Scheme_Object * ~a;~n" (fprintf port " Scheme_Object * ~a;\n"
(vm->c:convert-symbol (vm->c:convert-symbol
(vm->c:bucket-name (vm->c:bucket-name
(module-path-index-join ''#%kernel #f) (module-path-index-join ''#%kernel #f)
a)))) a))))
(set->list (compiler:get-primitive-refs))) (set->list (compiler:get-primitive-refs)))
(fprintf port "} P;~n") (fprintf port "} P;\n")
(newline port)))) (newline port))))
(define vm->c:emit-prim-ref-definitions! (define vm->c:emit-prim-ref-definitions!
(lambda (port) (lambda (port)
(unless (set-empty? (compiler:get-primitive-refs)) (unless (set-empty? (compiler:get-primitive-refs))
(fprintf port " /* primitives referenced by the code */~n") (fprintf port " /* primitives referenced by the code */\n")
(for-each (lambda (a) (for-each (lambda (a)
(fprintf port "~aP.~a = scheme_module_bucket(~a, ~a, -1, env)->val;~n" (fprintf port "~aP.~a = scheme_module_bucket(~a, ~a, -1, env)->val;\n"
vm->c:indent-spaces vm->c:indent-spaces
(vm->c:convert-symbol (vm->c:bucket-name (module-path-index-join ''#%kernel #f) a)) (vm->c:convert-symbol (vm->c:bucket-name (module-path-index-join ''#%kernel #f) a))
(vm->c:make-symbol-const-string (compiler:get-symbol-const! #f '#%kernel)) (vm->c:make-symbol-const-string (compiler:get-symbol-const! #f '#%kernel))
@ -234,21 +234,21 @@
(define vm->c:emit-struct-definitions! (define vm->c:emit-struct-definitions!
(lambda (structs port) (lambda (structs port)
(fprintf port "/* compiler-written structures */~n") (fprintf port "/* compiler-written structures */\n")
(for-each (lambda (struct) (for-each (lambda (struct)
(fprintf port "struct ~a~n{~n" (fprintf port "struct ~a\n{\n"
(vm->c:convert-symbol (vm->c:convert-symbol
(rep:struct-name struct))) (rep:struct-name struct)))
(for-each (for-each
(lambda (field) (lambda (field)
(fprintf port "~a~a ~a;~n" (fprintf port "~a~a ~a;\n"
vm->c:indent-spaces vm->c:indent-spaces
(vm->c:convert-type-definition (vm->c:convert-type-definition
(rep:struct-field-rep field)) (rep:struct-field-rep field))
(vm->c:convert-symbol (vm->c:convert-symbol
(rep:struct-field-name field)))) (rep:struct-field-name field))))
(rep:struct-fields struct)) (rep:struct-fields struct))
(fprintf port "};~n")) (fprintf port "};\n"))
(reverse structs)) (reverse structs))
(newline port))) (newline port)))
@ -259,57 +259,57 @@
(define (emit-static-variable-fields! port l) (define (emit-static-variable-fields! port l)
(unless (null? l) (unless (null? l)
(fprintf port "#ifndef MZ_PRECISE_GC~n") (fprintf port "#ifndef MZ_PRECISE_GC\n")
(fprintf port " /* Write fields as an array to help C compilers */~n") (fprintf port " /* Write fields as an array to help C compilers */\n")
(fprintf port " /* that don't like really big records. */~n") (fprintf port " /* that don't like really big records. */\n")
(fprintf port " Scheme_Object * _consts_[~a];~n" (length l)) (fprintf port " Scheme_Object * _consts_[~a];\n" (length l))
(let svloop ([l l][n 0]) (let svloop ([l l][n 0])
(unless (null? l) (unless (null? l)
(fprintf port "# define ~a _consts_[~a]~n" (fprintf port "# define ~a _consts_[~a]\n"
(vm->c:convert-symbol (car l)) n) (vm->c:convert-symbol (car l)) n)
(svloop (cdr l) (add1 n)))) (svloop (cdr l) (add1 n))))
(fprintf port "#else~n") (fprintf port "#else\n")
(for-each (lambda (c) (for-each (lambda (c)
(fprintf port " Scheme_Object * ~a;~n" (fprintf port " Scheme_Object * ~a;\n"
(vm->c:convert-symbol c))) (vm->c:convert-symbol c)))
l) l)
(fprintf port "#endif~n"))) (fprintf port "#endif\n")))
;; when statics have binding information, this will look more like ;; when statics have binding information, this will look more like
;; emit-local-variable-declarations! ;; emit-local-variable-declarations!
(define vm->c:emit-static-declarations! (define vm->c:emit-static-declarations!
(lambda (port) (lambda (port)
(unless (not (compiler:any-statics?)) (unless (not (compiler:any-statics?))
(fprintf port "/* compiler-written static variables */~n") (fprintf port "/* compiler-written static variables */\n")
(fprintf port "static struct {~n") (fprintf port "static struct {\n")
(emit-static-variable-fields! port (compiler:get-static-list)) (emit-static-variable-fields! port (compiler:get-static-list))
(unless (null? (compiler:get-case-lambdas)) (unless (null? (compiler:get-case-lambdas))
(fprintf port " mzshort *casesArities[~a];~n" (fprintf port " mzshort *casesArities[~a];\n"
(length (compiler:get-case-lambdas)))) (length (compiler:get-case-lambdas))))
(for-each (for-each
(lambda (ll) (lambda (ll)
(fprintf port " Scheme_Object * ~a;~n" (fprintf port " Scheme_Object * ~a;\n"
(vm->c:convert-symbol (zodiac:varref-var ll)))) (vm->c:convert-symbol (zodiac:varref-var ll))))
(compiler:get-lifted-lambda-vars)) (compiler:get-lifted-lambda-vars))
(fprintf port "} S;~n~n")) (fprintf port "} S;\n\n"))
(fprintf port "/* compiler-written per-load static variables */~n") (fprintf port "/* compiler-written per-load static variables */\n")
(fprintf port "typedef struct Scheme_Per_Load_Statics {~n") (fprintf port "typedef struct Scheme_Per_Load_Statics {\n")
(if (null? (compiler:get-per-load-static-list)) (if (null? (compiler:get-per-load-static-list))
(fprintf port " int dummy;~n") (fprintf port " int dummy;\n")
(emit-static-variable-fields! port (compiler:get-per-load-static-list))) (emit-static-variable-fields! port (compiler:get-per-load-static-list)))
(fprintf port "} Scheme_Per_Load_Statics;~n") (fprintf port "} Scheme_Per_Load_Statics;\n")
(newline port))) (newline port)))
;; when statics have binding information, this need only register ;; when statics have binding information, this need only register
;; pointer declarations ;; pointer declarations
(define vm->c:emit-registration! (define vm->c:emit-registration!
(lambda (port) (lambda (port)
(fprintf port "~a/* register compiler-written static variables with GC */~n" (fprintf port "~a/* register compiler-written static variables with GC */\n"
vm->c:indent-spaces) vm->c:indent-spaces)
(let ([register (let ([register
(lambda (v) (lambda (v)
(fprintf port "~ascheme_register_extension_global(&~a, sizeof(~a));~n" (fprintf port "~ascheme_register_extension_global(&~a, sizeof(~a));\n"
vm->c:indent-spaces v v))]) vm->c:indent-spaces v v))])
(unless (or (zero? (const:get-symbol-counter)) (compiler:multi-o-constant-pool)) (unless (or (zero? (const:get-symbol-counter)) (compiler:multi-o-constant-pool))
(register "SYMBOLS")) (register "SYMBOLS"))
@ -322,30 +322,30 @@
(newline port))) (newline port)))
(define (vm->c:emit-case-arities-definitions! port) (define (vm->c:emit-case-arities-definitions! port)
(fprintf port " /* arity information for compiled case-lambdas */~n") (fprintf port " /* arity information for compiled case-lambdas */\n")
(let caloop ([l (reverse (compiler:get-case-lambdas))][pos 0]) (let caloop ([l (reverse (compiler:get-case-lambdas))][pos 0])
(unless (null? l) (unless (null? l)
(let* ([ast (car l)] (let* ([ast (car l)]
[args (zodiac:case-lambda-form-args ast)]) [args (zodiac:case-lambda-form-args ast)])
(if (null? args) (if (null? args)
(fprintf port "~aS.casesArities[~a] = NULL;~n" (fprintf port "~aS.casesArities[~a] = NULL;\n"
vm->c:indent-spaces pos) vm->c:indent-spaces pos)
(begin (begin
(fprintf port "~a{~n~a mzshort * arities;~n" (fprintf port "~a{\n~a mzshort * arities;\n"
vm->c:indent-spaces vm->c:indent-spaces) vm->c:indent-spaces vm->c:indent-spaces)
(fprintf port "~a arities = (mzshort *)scheme_malloc_atomic(~a * sizeof(mzshort));~n" (fprintf port "~a arities = (mzshort *)scheme_malloc_atomic(~a * sizeof(mzshort));\n"
vm->c:indent-spaces vm->c:indent-spaces
(* 2 (length args))) (* 2 (length args)))
(let cailoop ([l args][n 0]) (let cailoop ([l args][n 0])
(unless (null? l) (unless (null? l)
(let-values ([(min-arity max-arity) (compiler:formals->arity (car l))]) (let-values ([(min-arity max-arity) (compiler:formals->arity (car l))])
(fprintf port "~a arities[~a] = ~a;~n~a arities[~a] = ~a;~n" (fprintf port "~a arities[~a] = ~a;\n~a arities[~a] = ~a;\n"
vm->c:indent-spaces (* 2 n) min-arity vm->c:indent-spaces (* 2 n) min-arity
vm->c:indent-spaces (add1 (* 2 n)) max-arity)) vm->c:indent-spaces (add1 (* 2 n)) max-arity))
(cailoop (cdr l) (add1 n)))) (cailoop (cdr l) (add1 n))))
(fprintf port "~a S.casesArities[~a] = arities;~n" (fprintf port "~a S.casesArities[~a] = arities;\n"
vm->c:indent-spaces pos) vm->c:indent-spaces pos)
(fprintf port "~a}~n" vm->c:indent-spaces)))) (fprintf port "~a}\n" vm->c:indent-spaces))))
(caloop (cdr l) (add1 pos))))) (caloop (cdr l) (add1 pos)))))
(define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list (define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list
@ -357,26 +357,26 @@
[ll locals-list] [ll locals-list]
[bl globals-list]) [bl globals-list])
(fprintf c-port (fprintf c-port
"static ~a ~a_~a(Scheme_Env * env~a)~n{~n" "static ~a ~a_~a(Scheme_Env * env~a)\n{\n"
(if return? "Scheme_Object *" "void") (if return? "Scheme_Object *" "void")
kind i kind i
(if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" "")) (if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" ""))
(when null-self-modidx? (fprintf c-port "#define self_modidx NULL~n")) (when null-self-modidx? (fprintf c-port "#define self_modidx NULL\n"))
(when (> max-arity 0) (when (> max-arity 0)
(fprintf c-port (fprintf c-port
"~aScheme_Object * arg[~a];~n" "~aScheme_Object * arg[~a];\n"
vm->c:indent-spaces vm->c:indent-spaces
max-arity) max-arity)
(fprintf c-port "~aScheme_Object ** tail_buf;~n" (fprintf c-port "~aScheme_Object ** tail_buf;\n"
vm->c:indent-spaces)) vm->c:indent-spaces))
(let loop ([c (compiler:option:max-exprs-per-top-level-set)][n n][vml vml][ll ll][bl bl]) (let loop ([c (compiler:option:max-exprs-per-top-level-set)][n n][vml vml][ll ll][bl bl])
(if (or (zero? c) (null? vml) (= n count)) (if (or (zero? c) (null? vml) (= n count))
(begin (begin
(unless (or (null? vml) (= n count) (not return?)) (unless (or (null? vml) (= n count) (not return?))
(fprintf c-port "~areturn NULL;~n" vm->c:indent-spaces)) (fprintf c-port "~areturn NULL;\n" vm->c:indent-spaces))
(when null-self-modidx? (fprintf c-port "#undef self_modidx~n")) (when null-self-modidx? (fprintf c-port "#undef self_modidx\n"))
(fprintf c-port (fprintf c-port
"} /* end of ~a_~a */~n~n" kind i) "} /* end of ~a_~a */\n\n" kind i)
(if (or (null? vml) (= n count)) (if (or (null? vml) (= n count))
i i
(tls-loop (add1 i) n vml ll bl))) (tls-loop (add1 i) n vml ll bl)))
@ -384,7 +384,7 @@
(loop c n (cdr vml) (cdr ll) (cdr bl)) (loop c n (cdr vml) (cdr ll) (cdr bl))
(begin (begin
(let ([start (zodiac:zodiac-start (car vml))]) (let ([start (zodiac:zodiac-start (car vml))])
(fprintf c-port "~a{ /* [~a,~a] */~n" vm->c:indent-spaces (fprintf c-port "~a{ /* [~a,~a] */\n" vm->c:indent-spaces
(zodiac:location-line start) (zodiac:location-line start)
(zodiac:location-column start))) (zodiac:location-column start)))
(vm->c:emit-local-variable-declarations! (vm->c:emit-local-variable-declarations!
@ -403,7 +403,7 @@
(vm->c-expression (car vml) #f c-port vm->c:indent-by #t n) (vm->c-expression (car vml) #f c-port vm->c:indent-by #t n)
(fprintf c-port "~a}~n" vm->c:indent-spaces) (fprintf c-port "~a}\n" vm->c:indent-spaces)
(loop (sub1 c) (add1 n) (cdr vml) (cdr ll) (cdr bl)))))))) (loop (sub1 c) (add1 n) (cdr vml) (cdr ll) (cdr bl))))))))
@ -426,13 +426,13 @@
(define vm->c:emit-vehicle-declaration (define vm->c:emit-vehicle-declaration
(lambda (port number) (lambda (port number)
(vm->c:emit-vehicle-prototype port number) (vm->c:emit-vehicle-prototype port number)
(fprintf port "; /* ~a */ ~n" (fprintf port "; /* ~a */ \n"
(vehicle-total-labels (get-vehicle number))))) (vehicle-total-labels (get-vehicle number)))))
(define vm->c:emit-vehicle-header (define vm->c:emit-vehicle-header
(lambda (port number) (lambda (port number)
(vm->c:emit-vehicle-prototype port number) (vm->c:emit-vehicle-prototype port number)
(fprintf port "~n{~n"))) (fprintf port "\n{\n")))
(define vm->c:emit-vehicle-prologue (define vm->c:emit-vehicle-prologue
(lambda (port vehicle) (lambda (port vehicle)
@ -442,18 +442,18 @@
0)]) 0)])
(when (> max-arity 0) (when (> max-arity 0)
;; emit declaration of argument stack ;; emit declaration of argument stack
(fprintf port "~aScheme_Object * arg[~a];~n" (fprintf port "~aScheme_Object * arg[~a];\n"
vm->c:indent-spaces vm->c:indent-spaces
max-arity)) max-arity))
(when (> max-args 0) (when (> max-args 0)
;; emit declaration of global variables for argument passing ;; emit declaration of global variables for argument passing
(let loop ([n 0]) (let loop ([n 0])
(unless (= n max-args) (unless (= n max-args)
(fprintf port "~aregister long reg~a;~n" vm->c:indent-spaces n) (fprintf port "~aregister long reg~a;\n" vm->c:indent-spaces n)
(loop (+ n 1))))) (loop (+ n 1)))))
(when (> max-arity 0) (when (> max-arity 0)
;; tail-buffer-setup ;; tail-buffer-setup
(fprintf port "~aScheme_Object ** tail_buf;~n" (fprintf port "~aScheme_Object ** tail_buf;\n"
vm->c:indent-spaces))) vm->c:indent-spaces)))
(when local-vars-at-top? (when local-vars-at-top?
@ -466,23 +466,23 @@
;; emit jump to function... ;; emit jump to function...
(when (> (vehicle-total-labels vehicle) 1) (when (> (vehicle-total-labels vehicle) 1)
;; emit switch dispatcher ;; emit switch dispatcher
(fprintf port "~aswitch(MZC_PARAM_TO_SWITCH(void_param))~n~a{ " (fprintf port "~aswitch(MZC_PARAM_TO_SWITCH(void_param))\n~a{ "
vm->c:indent-spaces vm->c:indent-spaces
vm->c:indent-spaces ) vm->c:indent-spaces )
(let loop ([n 0]) (let loop ([n 0])
(when (and (zero? (modulo n 3)) (when (and (zero? (modulo n 3))
(not (= n (compiler:get-label-number)))) (not (= n (compiler:get-label-number))))
(fprintf port "~n~a~a" vm->c:indent-spaces vm->c:indent-spaces)) (fprintf port "\n~a~a" vm->c:indent-spaces vm->c:indent-spaces))
(if (= n (sub1 (vehicle-total-labels vehicle))) (if (= n (sub1 (vehicle-total-labels vehicle)))
(fprintf port "default: goto FGN~a;" n) (fprintf port "default: goto FGN~a;" n)
(begin (begin
(fprintf port "case ~a: goto FGN~a;" n n) (fprintf port "case ~a: goto FGN~a;" n n)
(loop (add1 n))))) (loop (add1 n)))))
(fprintf port "~n~a}~n" vm->c:indent-spaces)))) (fprintf port "\n~a}\n" vm->c:indent-spaces))))
(define vm->c:emit-vehicle-epilogue (define vm->c:emit-vehicle-epilogue
(lambda (port number) (lambda (port number)
(fprintf port "} /* end of vehicle # ~a */~n" number))) (fprintf port "} /* end of vehicle # ~a */\n" number)))
;; Will be expanded to hold environments, perhaps, etc. ;; Will be expanded to hold environments, perhaps, etc.
(define vm->c:convert-type-definition (define vm->c:convert-type-definition
@ -539,7 +539,7 @@
(void) (void)
(let* ([bound (car locals)] (let* ([bound (car locals)]
[rep (binding-rep (get-annotation bound))]) [rep (binding-rep (get-annotation bound))])
(fprintf port "~a~a ~a;~n" (fprintf port "~a~a ~a;\n"
indent indent
(vm->c:convert-type-definition rep) (vm->c:convert-type-definition rep)
(vm->c:convert-symbol (zodiac:binding-var bound))) (vm->c:convert-symbol (zodiac:binding-var bound)))
@ -552,10 +552,10 @@
(cond (cond
[(const:per-load-statics-table? var) [(const:per-load-statics-table? var)
(unless top-level? (unless top-level?
(fprintf port "~aScheme_Per_Load_Statics * PLS;~n" (fprintf port "~aScheme_Per_Load_Statics * PLS;\n"
indent))] indent))]
[else [else
(fprintf port "~aScheme_Bucket * G~a;~n" (fprintf port "~aScheme_Bucket * G~a;\n"
indent indent
(vm->c:convert-symbol (mod-glob-cname var)))])) (vm->c:convert-symbol (mod-glob-cname var)))]))
(set->list globals)))) (set->list globals))))
@ -576,7 +576,7 @@
(compiler:get-module-path-constant mod))] (compiler:get-module-path-constant mod))]
[mod-local (and mod (not (symbol? mod)) (not modidx))] [mod-local (and mod (not (symbol? mod)) (not modidx))]
[mod-far (and mod (or (symbol? mod) modidx))]) [mod-far (and mod (or (symbol? mod) modidx))])
(fprintf port "~aG~a = scheme_~a~a~a_bucket(~a~a~a, ~a~a~a);~n" (fprintf port "~aG~a = scheme_~a~a~a_bucket(~a~a~a, ~a~a~a);\n"
indent indent
name name
(if et? "exptime_" "") (if et? "exptime_" "")
@ -619,29 +619,29 @@
;; if the binding is mutable, we need to make a box and fill it with ;; if the binding is mutable, we need to make a box and fill it with
;; the correct value ;; the correct value
(let ([rep (get-rep n)]) (let ([rep (get-rep n)])
(fprintf port "~ascheme_malloc(sizeof(~a));~n" (fprintf port "~ascheme_malloc(sizeof(~a));\n"
(get-cast n #f) (get-cast n #f)
(vm->c:convert-type-definition (vm->c:convert-type-definition
(rep:pointer-to rep))) (rep:pointer-to rep)))
(fprintf port "~a*(~a)~a = (~a)~a;~n" (fprintf port "~a*(~a)~a = (~a)~a;\n"
indent indent
(vm->c:convert-type-definition rep) (vm->c:convert-type-definition rep)
(get-dest n) (get-dest n)
(vm->c:convert-type-definition (rep:pointer-to rep)) (vm->c:convert-type-definition (rep:pointer-to rep))
(argv-n))) (argv-n)))
(fprintf port "~a~a;~n" (get-cast n #t) (argv-n))) (fprintf port "~a~a;\n" (get-cast n #t) (argv-n)))
(loop (cdr args) (sub1 n) #f)] (loop (cdr args) (sub1 n) #f)]
[else ; the rest get pulled into a list [else ; the rest get pulled into a list
(when (dest-boxed? n) (when (dest-boxed? n)
(fprintf port (fprintf port
"~a~a = ~ascheme_malloc(sizeof(Scheme_Object *));~n" "~a~a = ~ascheme_malloc(sizeof(Scheme_Object *));\n"
indent indent
(get-dest n) (get-dest n)
(get-cast n #f))) (get-cast n #f)))
(fprintf port (fprintf port
"~a~a~a = ~ascheme_build_list_offset(argc, argv, ~a);~n" "~a~a~a = ~ascheme_build_list_offset(argc, argv, ~a);\n"
indent indent
(if (dest-boxed? n) (if (dest-boxed? n)
"*(Scheme_Object * *)" "*(Scheme_Object * *)"
@ -677,7 +677,7 @@
(lambda (binding) (lambda (binding)
(let* ([rep (binding-rep (get-annotation binding))] (let* ([rep (binding-rep (get-annotation binding))]
[derep (rep:pointer-to rep)]) [derep (rep:pointer-to rep)])
(fprintf port "~a~a = (~a)~a;~n~a*(~a) = scheme_undefined;~n" (fprintf port "~a~a = (~a)~a;\n~a*(~a) = scheme_undefined;\n"
indent indent
(vm->c:convert-symbol (zodiac:binding-var binding)) (vm->c:convert-symbol (zodiac:binding-var binding))
(vm->c:convert-type-definition rep) (vm->c:convert-type-definition rep)
@ -691,7 +691,7 @@
(lambda (undefines indent port) (lambda (undefines indent port)
(for-each (for-each
(lambda (name) (lambda (name)
(fprintf port "#~aundef ~a~n" (fprintf port "#~aundef ~a\n"
indent name)) indent name))
undefines))) undefines)))
@ -703,7 +703,7 @@
(values 1 #f) (values 1 #f)
(begin (begin
;; The foreign entry label ;; The foreign entry label
(fprintf port "FGN~a:~n" label) (fprintf port "FGN~a:\n" label)
(let loop ([args (zodiac:case-lambda-form-args L)][i 0]) (let loop ([args (zodiac:case-lambda-form-args L)][i 0])
(if (null? args) (if (null? args)
(begin (begin
@ -718,27 +718,27 @@
(compiler:formals->arity (car l))]) (compiler:formals->arity (car l))])
(fprintf port ", ~a, ~a" min-arity max-arity) (fprintf port ", ~a, ~a" min-arity max-arity)
(loop (cdr l))))) (loop (cdr l)))))
(fprintf port ");~n") (fprintf port ");\n")
(fprintf port "~a~areturn NULL;~n" (fprintf port "~a~areturn NULL;\n"
vm->c:indent-spaces vm->c:indent-spaces) vm->c:indent-spaces vm->c:indent-spaces)
(values i #t)) (values i #t))
(let ([a (car args)]) (let ([a (car args)])
(cond (cond
[(zodiac:sym-arglist? a) [(zodiac:sym-arglist? a)
(fprintf port "~a~agoto FGN~ac~a;~n" (fprintf port "~a~agoto FGN~ac~a;\n"
vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces
label label
i) i)
(values (add1 i) #t)] (values (add1 i) #t)]
[(zodiac:list-arglist? a) [(zodiac:list-arglist? a)
(fprintf port "~a~aif (argc == ~a) goto FGN~ac~a;~n" (fprintf port "~a~aif (argc == ~a) goto FGN~ac~a;\n"
vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces
(length (zodiac:arglist-vars a)) (length (zodiac:arglist-vars a))
label label
i) i)
(loop (cdr args) (add1 i))] (loop (cdr args) (add1 i))]
[else [else
(fprintf port "~a~aif (argc >= ~a) goto FGN~ac~a;~n" (fprintf port "~a~aif (argc >= ~a) goto FGN~ac~a;\n"
vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces vm->c:indent-spaces
(sub1 (length (zodiac:arglist-vars a))) (sub1 (length (zodiac:arglist-vars a)))
label label
@ -757,8 +757,8 @@
[name (vm->c:convert-symbol vname)] [name (vm->c:convert-symbol vname)]
[fname (rep:find-field (closure-code-rep code) vname)]) [fname (rep:find-field (closure-code-rep code) vname)])
(fprintf port (if (compiler:option:unpack-environments) (fprintf port (if (compiler:option:unpack-environments)
"~a~a = env->~a;~n" "~a~a = env->~a;\n"
"#~adefine ~a env->~a~n") "#~adefine ~a env->~a\n")
indent indent
name name
fname) fname)
@ -781,8 +781,8 @@
(begin (begin
(fprintf port (fprintf port
(if (compiler:option:unpack-environments) (if (compiler:option:unpack-environments)
"~aPLS = env->pls;~n" "~aPLS = env->pls;\n"
"#~adefine PLS env->pls~n") "#~adefine PLS env->pls\n")
indent) indent)
(loop (cdr vars) (loop (cdr vars)
(if (compiler:option:unpack-environments) (if (compiler:option:unpack-environments)
@ -794,8 +794,8 @@
[fname (rep:find-field (closure-code-rep code) vname)]) [fname (rep:find-field (closure-code-rep code) vname)])
(fprintf port (fprintf port
(if (compiler:option:unpack-environments) (if (compiler:option:unpack-environments)
"~aG~a = env->~a;~n" "~aG~a = env->~a;\n"
"#~adefine G~a env->~a~n") "#~adefine G~a env->~a\n")
indent indent
name name
fname) fname)
@ -827,12 +827,12 @@
(loop (cdr l))))))))]) (loop (cdr l))))))))])
(set-minus free-set uncaptured-anchor-set))]) (set-minus free-set uncaptured-anchor-set))])
; The foreign entry label ; The foreign entry label
(fprintf port "FGN~a~a:~n" label lsuffix) (fprintf port "FGN~a~a:\n" label lsuffix)
; Pull arguments to global registers ; Pull arguments to global registers
(vm->c:pack-global-registers! L which indent port) (vm->c:pack-global-registers! L which indent port)
; The local entry label ; The local entry label
(fprintf port "LOC~a~a:~n" label lsuffix) (fprintf port "LOC~a~a:\n" label lsuffix)
(pre-decl) (pre-decl)
(unless local-vars-at-top? (unless local-vars-at-top?
(vm->c:emit-local-variable-declarations! (code-local-vars case-code) indent port)) (vm->c:emit-local-variable-declarations! (code-local-vars case-code) indent port))
@ -843,8 +843,8 @@
(let ([r (closure-code-rep code)]) (let ([r (closure-code-rep code)])
(when r (when r
;; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r)) ;; (fprintf port "~aconst ~a * env;\n" indent (vm->c:convert-type-definition r))
(fprintf port "#~adefine env MZC_ENV_POINTER(~a, ~a, void_param)~n" (fprintf port "#~adefine env MZC_ENV_POINTER(~a, ~a, void_param)\n"
indent indent
(vm->c:convert-type-definition r) (vm->c:convert-type-definition r)
(vm->c:convert-type-definition (closure-code-alloc-rep code))))) (vm->c:convert-type-definition (closure-code-alloc-rep code)))))
@ -875,7 +875,7 @@
#| #|
(let ([r (closure-code-rep code)]) (let ([r (closure-code-rep code)])
(when r (when r
(fprintf port "~aenv = (~a *)void_param;~n" (fprintf port "~aenv = (~a *)void_param;\n"
indent indent
(vm->c:convert-type-definition r)))) (vm->c:convert-type-definition r))))
|# |#
@ -897,18 +897,18 @@
undefines)) undefines))
(when (case-code-has-continue? case-code) (when (case-code-has-continue? case-code)
(fprintf port "~awhile(1)~n" indent)) (fprintf port "~awhile(1)\n" indent))
undefines))) undefines)))
(define vm->c:emit-case-epilogue (define vm->c:emit-case-epilogue
(lambda (code which undefines indent port) (lambda (code which undefines indent port)
(fprintf port "#~aundef env~n" indent) (fprintf port "#~aundef env\n" indent)
(vm->c:emit-undefines undefines indent port))) (vm->c:emit-undefines undefines indent port)))
(define vm->c:emit-function-epilogue (define vm->c:emit-function-epilogue
(lambda (code close port) (lambda (code close port)
(fprintf port "~a~a /* end of function body ~a */~n" (fprintf port "~a~a /* end of function body ~a */\n"
vm->c:indent-spaces close (closure-code-label code)))) vm->c:indent-spaces close (closure-code-label code))))
(define vm->c:convert-symbol (define vm->c:convert-symbol
@ -1007,12 +1007,12 @@
;; (%sequence V ...) -> { M; ... } ;; (%sequence V ...) -> { M; ... }
[(vm:sequence? ast) [(vm:sequence? ast)
(let* ([seq (vm:sequence-vals ast)]) (let* ([seq (vm:sequence-vals ast)])
(when braces? (emit-indentation) (emit "{~n")) (when braces? (emit-indentation) (emit "{\n"))
(for-each (lambda (v) (for-each (lambda (v)
(process v (indent) #t #t) (process v (indent) #t #t)
(unless (vm->c:block-statement? v) (emit ";~n"))) (unless (vm->c:block-statement? v) (emit ";\n")))
seq) seq)
(when braces? (emit-indentation) (emit "}~n")))] (when braces? (emit-indentation) (emit "}\n")))]
;; (if R (sequence V) (sequence V)) -> ;; (if R (sequence V) (sequence V)) ->
;; if (!SCHEME_FALSEP(A)) { V ... } else { V ...} ;; if (!SCHEME_FALSEP(A)) { V ... } else { V ...}
@ -1032,7 +1032,7 @@
(emit "!SCHEME_FALSEP(") (emit "!SCHEME_FALSEP(")
(process test indent-level #f #t) (process test indent-level #f #t)
(emit ")")))) (emit ")"))))
(emit ")~n") (emit ")\n")
(process (vm:if-then ast) indent-level #t #t) (process (vm:if-then ast) indent-level #t #t)
(let ([else-vals (vm:sequence-vals else)]) (let ([else-vals (vm:sequence-vals else)])
(cond (cond
@ -1041,7 +1041,7 @@
(emit-indentation) (emit "else ") (emit-indentation) (emit "else ")
(iloop (car else-vals))] (iloop (car else-vals))]
[(not (null? else-vals)) [(not (null? else-vals))
(emit-indentation) (emit "else~n") (emit-indentation) (emit "else\n")
(process (vm:if-else ast) indent-level #f #t)] (process (vm:if-else ast) indent-level #f #t)]
[else (void)]))))] [else (void)]))))]
@ -1056,15 +1056,15 @@
(let ([var (vm->c:convert-symbol (let ([var (vm->c:convert-symbol
(vm:local-varref-var (vm:begin0-setup!-var ast)))]) (vm:local-varref-var (vm:begin0-setup!-var ast)))])
(emit-indentation) (emit-indentation)
(emit "if (~a.val == SCHEME_MULTIPLE_VALUES) {~n" var) (emit "if (~a.val == SCHEME_MULTIPLE_VALUES) {\n" var)
(emit-indentation) (emit-indentation)
(emit " Scheme_Thread *pr = scheme_current_thread;\n") (emit " Scheme_Thread *pr = scheme_current_thread;\n")
(emit-indentation) (emit-indentation)
(emit " ~a.array = pr->ku.multiple.array;~n" var) (emit " ~a.array = pr->ku.multiple.array;\n" var)
(emit-indentation) (emit-indentation)
(emit " ~a.count = pr->ku.multiple.count;~n" var) (emit " ~a.count = pr->ku.multiple.count;\n" var)
(emit-indentation) (emit-indentation)
(emit " SCHEME_DETATCH_MV_BUFFER(~a.array, pr);~n" var) (emit " SCHEME_DETATCH_MV_BUFFER(~a.array, pr);\n" var)
(emit-indentation) (emit-indentation)
(emit "} else ~a.array = NULL" var))] (emit "} else ~a.array = NULL" var))]
[(vm:begin0-extract? ast) [(vm:begin0-extract? ast)
@ -1138,12 +1138,12 @@
(emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set)) (emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set))
(emit "}") (emit "}")
(if (not (null? vars)) (if (not (null? vars))
(emit "~n")) (emit "\n"))
(let aloop ([vars vars] [n 0]) (let aloop ([vars vars] [n 0])
(unless (null? vars) (unless (null? vars)
(emit-indentation) (emit-indentation)
(process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f) (process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f)
(emit ";~n") (emit ";\n")
(aloop (cdr vars) (+ n 1)))) (aloop (cdr vars) (+ n 1))))
))))] ))))]
@ -1183,7 +1183,7 @@
(when (and (eq? arg-type:tail-arg (vm:args-type ast)) (when (and (eq? arg-type:tail-arg (vm:args-type ast))
(not (null? (vm:args-vals ast)))) (not (null? (vm:args-vals ast))))
(emit-indentation) (emit-indentation)
(emit "tail_buf = scheme_tail_apply_buffer_wp(~a, scheme_current_thread);~n" (emit "tail_buf = scheme_tail_apply_buffer_wp(~a, scheme_current_thread);\n"
(length (vm:args-vals ast)))) (length (vm:args-vals ast))))
(if (null? (vm:args-vals ast)) (if (null? (vm:args-vals ast))
(emit-indentation) (emit-indentation)
@ -1201,7 +1201,7 @@
(process (car args) indent-level #f #t) (process (car args) indent-level #f #t)
;; (emit ")") ;; DEBUGGING ;; (emit ")") ;; DEBUGGING
(unless (null? (cdr args)) (unless (null? (cdr args))
(emit ";~n")) (emit ";\n"))
(arloop (add1 n) (cdr args)))))] (arloop (add1 n) (cdr args)))))]
[(vm:register-args? ast) [(vm:register-args? ast)
@ -1214,7 +1214,7 @@
(emit "~a = " (vm->c:convert-symbol (zodiac:binding-var var))) (emit "~a = " (vm->c:convert-symbol (zodiac:binding-var var)))
(process val indent-level #f #f) (process val indent-level #f #f)
(unless (null? (cdr vars)) (unless (null? (cdr vars))
(emit ";~n") (emit ";\n")
(raloop (cdr vars) (cdr vals))))))] (raloop (cdr vars) (cdr vals))))))]
;; (alloc ) -> malloc ;; (alloc ) -> malloc
@ -1304,11 +1304,11 @@
(let ([var (vm->c:convert-symbol (let ([var (vm->c:convert-symbol
(vm:local-varref-var (vm:wcm-remember!-var ast)))]) (vm:local-varref-var (vm:wcm-remember!-var ast)))])
(emit-indentation) (emit-indentation)
(emit "scheme_temp_dec_mark_depth();~n") (emit "scheme_temp_dec_mark_depth();\n")
(emit-indentation) (emit-indentation)
(emit "~a.val = " var) (emit "~a.val = " var)
(process (vm:wcm-remember!-val ast) indent-level #f #t) (process (vm:wcm-remember!-val ast) indent-level #f #t)
(emit ";~n") (emit ";\n")
(emit-indentation) (emit-indentation)
(emit "scheme_temp_inc_mark_depth()"))] (emit "scheme_temp_inc_mark_depth()"))]
[(vm:wcm-extract? ast) [(vm:wcm-extract? ast)
@ -1319,7 +1319,7 @@
;; (continue) -> continue; ;; (continue) -> continue;
[(vm:continue? ast) [(vm:continue? ast)
(unless (compiler:option:disable-interrupts) (unless (compiler:option:disable-interrupts)
(emit-expr "SCHEME_USE_FUEL(1);~n")) (emit-expr "SCHEME_USE_FUEL(1);\n"))
(emit-expr "continue")] (emit-expr "continue")]
;; use NULL instead of tail_buf if no args ;; use NULL instead of tail_buf if no args
@ -1337,11 +1337,11 @@
(emit-indentation) (emit-indentation)
(emit "void_param = MZC_PRIM_CLS_DATA(") (emit "void_param = MZC_PRIM_CLS_DATA(")
(process (vm:tail-call-closure ast) indent-level #f #t) (process (vm:tail-call-closure ast) indent-level #f #t)
(emit ");~n")) (emit ");\n"))
;; be nice to threads & user breaks: ;; be nice to threads & user breaks:
(unless (compiler:option:disable-interrupts) (unless (compiler:option:disable-interrupts)
(emit-indentation) (emit-indentation)
(emit "SCHEME_USE_FUEL(1);~n")) (emit "SCHEME_USE_FUEL(1);\n"))
(emit-indentation) (emit-indentation)
; unless its to a variable arity function! ARGH ; unless its to a variable arity function! ARGH
(let* ([label (vm:tail-call-label ast)] (let* ([label (vm:tail-call-label ast)]

2
collects/compiler/private/vmphase.rkt
View File

@ -247,7 +247,7 @@
(lambda (ast multi? leaf tail-pos tail? used?) (lambda (ast multi? leaf tail-pos tail? used?)
(when (compiler:option:debug) (when (compiler:option:debug)
(zodiac:print-start! (debug:get-port) ast) (zodiac:print-start! (debug:get-port) ast)
(fprintf (debug:get-port) "~a~n" ast)) (fprintf (debug:get-port) "~a\n" ast))
(cond (cond
;;----------------------------------------------------------------- ;;-----------------------------------------------------------------

12
collects/compiler/private/winicon.rkt
View File

@ -95,7 +95,7 @@
(bytes->string/latin-1 unistr) (bytes->string/latin-1 unistr)
"")))) ""))))
(value name-delta))]) (value name-delta))])
;;(printf "Name: ~a~a = ~a~n" path name (+ rsrc-pos (value data-delta))) ;;(printf "Name: ~a~a = ~a\n" path name (+ rsrc-pos (value data-delta)))
(let ([full-name (format "~a~a" path name)]) (let ([full-name (format "~a~a" path name)])
(if (flag data-delta) (if (flag data-delta)
(loop (value data-delta) (string-append full-name ".")) (loop (value data-delta) (string-append full-name "."))
@ -148,14 +148,14 @@
[vdelta image-base]) [vdelta image-base])
(file-position p pos) (file-position p pos)
(let loop ([delay-pos (dword->integer p)]) (let loop ([delay-pos (dword->integer p)])
(printf "~a ~a~n" delay-pos vdelta) (printf "~a ~a\n" delay-pos vdelta)
(file-position p (+ delay-pos vdelta)) (file-position p (+ delay-pos vdelta))
(dword->integer p) ; skip attributes (dword->integer p) ; skip attributes
(let ([name-pos (dword->integer p)]) (let ([name-pos (dword->integer p)])
(printf "~a ~a~n" name-pos vdelta) (printf "~a ~a\n" name-pos vdelta)
(file-position p (+ name-pos vdelta)) (file-position p (+ name-pos vdelta))
(let ([name (regexp-match "^[^\0]*" p)]) (let ([name (regexp-match "^[^\0]*" p)])
(printf "~a~n" name)))))))) (printf "~a\n" name))))))))
(define-struct icon (desc data)) (define-struct icon (desc data))
;; desc is (list width height colors 0 planes bitcount) ;; desc is (list width height colors 0 planes bitcount)
@ -256,7 +256,7 @@
image image
(mask->alpha (cvt image) mask)) (mask->alpha (cvt image) mask))
mask)))))))))]) mask)))))))))])
(unless ico-icon (printf "no! ~a~n" (icon-desc exe-icon))) (unless ico-icon (printf "no! ~a\n" (icon-desc exe-icon)))
(when ico-icon (when ico-icon
(file-position p (car (icon-data exe-icon))) (file-position p (car (icon-data exe-icon)))
(display (cdr (icon-data ico-icon)) p))))) (display (cdr (icon-data ico-icon)) p)))))
@ -296,7 +296,7 @@
dword->integer) dword->integer)
p))) p)))
(loop (add1 i)))))]) (loop (add1 i)))))])
;; (printf "~a~n" icons) ;; (printf "~a\n" icons)
(for-each (lambda (icon) (for-each (lambda (icon)
(set-icon-data! (set-icon-data!
icon icon

194
collects/compiler/private/xform.rkt
View File

@ -459,7 +459,7 @@
(let loop () (let loop ()
(let ([l (read-bytes-line (list-ref proc 3) 'any)]) (let ([l (read-bytes-line (list-ref proc 3) 'any)])
(unless (eof-object? l) (unless (eof-object? l)
(fprintf (current-error-port) "~a~n" l) (fprintf (current-error-port) "~a\n" l)
(loop)))) (loop))))
(close-input-port (list-ref proc 3))))) (close-input-port (list-ref proc 3)))))
@ -615,14 +615,14 @@
;; Setup GC_variable_stack macro ;; Setup GC_variable_stack macro
(printf (case gc-var-stack-mode (printf (case gc-var-stack-mode
[(table) [(table)
"#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n"] "#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)\n"]
[(getspecific) [(getspecific)
"#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)~n"] "#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)\n"]
[(function) [(function)
"#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)~n"] "#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)\n"]
[(thread-local) [(thread-local)
"#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)~n"] "#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)\n"]
[else "#define GC_VARIABLE_STACK GC_variable_stack~n"])) [else "#define GC_VARIABLE_STACK GC_variable_stack\n"]))
(if gc-variable-stack-through-funcs? (if gc-variable-stack-through-funcs?
(begin (begin
@ -638,11 +638,11 @@
(if callee-restore? (if callee-restore?
" SET_GC_VARIABLE_STACK(__gc_var_stack__);" " SET_GC_VARIABLE_STACK(__gc_var_stack__);"
"") "")
"~n")) "\n"))
;; Same, but in a function where the number of registered variables ;; Same, but in a function where the number of registered variables
;; never changes within the procedure (i.e., in nested blocks): ;; never changes within the procedure (i.e., in nested blocks):
(printf "#define PREPARE_VAR_STACK_ONCE(size) PREPARE_VAR_STACK(size); __gc_var_stack__[1] = (void *)size;~n") (printf "#define PREPARE_VAR_STACK_ONCE(size) PREPARE_VAR_STACK(size); __gc_var_stack__[1] = (void *)size;\n")
;; Full setup to use before a function call, normally used with FUNCCALL: ;; Full setup to use before a function call, normally used with FUNCCALL:
(printf (string-append (printf (string-append
@ -650,7 +650,7 @@
(if callee-restore? (if callee-restore?
"" ""
"SET_GC_VARIABLE_STACK(__gc_var_stack__), ") "SET_GC_VARIABLE_STACK(__gc_var_stack__), ")
"__gc_var_stack__[1] = (void *)x)~n")) "__gc_var_stack__[1] = (void *)x)\n"))
;; Debugging support: ;; Debugging support:
(printf "#ifdef MZ_3M_CHECK_VAR_STACK\n") (printf "#ifdef MZ_3M_CHECK_VAR_STACK\n")
@ -662,110 +662,110 @@
;; Call a function where the number of registered variables can change in ;; Call a function where the number of registered variables can change in
;; nested blocks: ;; nested blocks:
(printf "#define FUNCCALL_each(setup, x) (CHECK_GC_V_S setup, x)~n") (printf "#define FUNCCALL_each(setup, x) (CHECK_GC_V_S setup, x)\n")
;; The same, but a "tail" call: ;; The same, but a "tail" call:
(printf "#define FUNCCALL_EMPTY_each(x) (SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), x)~n") (printf "#define FUNCCALL_EMPTY_each(x) (SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), x)\n")
;; The same, but the number of registered variables for this call is definitely ;; The same, but the number of registered variables for this call is definitely
;; the same as for the previous call: ;; the same as for the previous call:
(printf (if callee-restore? (printf (if callee-restore?
"#define FUNCCALL_AGAIN_each(x) (CHECK_GC_V_S x)~n" "#define FUNCCALL_AGAIN_each(x) (CHECK_GC_V_S x)\n"
"#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK(__gc_var_stack__), x)~n")) "#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK(__gc_var_stack__), x)\n"))
;; As above, but when the number of registered variables never changes ;; As above, but when the number of registered variables never changes
;; within a procedure: ;; within a procedure:
(printf "#define FUNCCALL_once(setup, x) FUNCCALL_AGAIN_each(x)~n") (printf "#define FUNCCALL_once(setup, x) FUNCCALL_AGAIN_each(x)\n")
(printf "#define FUNCCALL_EMPTY_once(x) FUNCCALL_EMPTY_each(x)~n") (printf "#define FUNCCALL_EMPTY_once(x) FUNCCALL_EMPTY_each(x)\n")
(printf "#define FUNCCALL_AGAIN_once(x) FUNCCALL_AGAIN_each(x)~n") (printf "#define FUNCCALL_AGAIN_once(x) FUNCCALL_AGAIN_each(x)\n")
;; Register a particular variable locally: ;; Register a particular variable locally:
(printf "#define PUSH(v, x) (__gc_var_stack__[x+2] = (void *)&(v))~n") (printf "#define PUSH(v, x) (__gc_var_stack__[x+2] = (void *)&(v))\n")
;; Register a particular array variable locally: ;; Register a particular array variable locally:
(printf (string-append (printf (string-append
"#define PUSHARRAY(v, l, x) (__gc_var_stack__[x+2] = (void *)0, __gc_var_stack__[x+3] = (void *)&(v), " "#define PUSHARRAY(v, l, x) (__gc_var_stack__[x+2] = (void *)0, __gc_var_stack__[x+3] = (void *)&(v), "
"__gc_var_stack__[x+4] = (void *)l)~n")) "__gc_var_stack__[x+4] = (void *)l)\n"))
;; Wraps code to setup a block's variables: ;; Wraps code to setup a block's variables:
(printf "#define BLOCK_SETUP_TOP(x) ~a~n" (if per-block-push? "x" "/* skipped */")) (printf "#define BLOCK_SETUP_TOP(x) ~a\n" (if per-block-push? "x" "/* skipped */"))
;; Same, but specifically in a function where nested blocks register ;; Same, but specifically in a function where nested blocks register
;; extra variables: ;; extra variables:
(printf "#define BLOCK_SETUP_each(x) BLOCK_SETUP_TOP(x)~n") (printf "#define BLOCK_SETUP_each(x) BLOCK_SETUP_TOP(x)\n")
;; Same, but specifically in a function where nested blocks DO NOT ;; Same, but specifically in a function where nested blocks DO NOT
;; register extra variables: ;; register extra variables:
(printf "#define BLOCK_SETUP_once(x) /* no effect */~n") (printf "#define BLOCK_SETUP_once(x) /* no effect */\n")
;; Wrap a normal return: ;; Wrap a normal return:
(printf (if callee-restore? (printf (if callee-restore?
"#define RET_VALUE_START return (__ret__val__ = ~n" "#define RET_VALUE_START return (__ret__val__ = \n"
"#define RET_VALUE_START return~n")) "#define RET_VALUE_START return\n"))
(printf (if callee-restore? (printf (if callee-restore?
"#define RET_VALUE_END , SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), __ret__val__)~n" "#define RET_VALUE_END , SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), __ret__val__)\n"
"#define RET_VALUE_END ~n")) "#define RET_VALUE_END \n"))
;; Wrap a return where the value is produced by a FUNCCALL_EMPTY expression: ;; Wrap a return where the value is produced by a FUNCCALL_EMPTY expression:
(printf "#define RET_VALUE_EMPTY_START return~n") (printf "#define RET_VALUE_EMPTY_START return\n")
(printf "#define RET_VALUE_EMPTY_END ~n") (printf "#define RET_VALUE_EMPTY_END \n")
;; Replacement for non-value return: ;; Replacement for non-value return:
(printf "#define RET_NOTHING { SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]); return; }~n") (printf "#define RET_NOTHING { SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]); return; }\n")
;; A non-value return inserted at the end of a void-returning function: ;; A non-value return inserted at the end of a void-returning function:
(printf "#define RET_NOTHING_AT_END RET_NOTHING~n") (printf "#define RET_NOTHING_AT_END RET_NOTHING\n")
;; Declare a temp variable to hold the return value of the indicated type: ;; Declare a temp variable to hold the return value of the indicated type:
(printf (if callee-restore? (printf (if callee-restore?
"#define DECL_RET_SAVE(type) type __ret__val__;~n" "#define DECL_RET_SAVE(type) type __ret__val__;\n"
"#define DECL_RET_SAVE(type) /**/~n")) "#define DECL_RET_SAVE(type) /**/\n"))
;; Value used to initialize pointer variables: ;; Value used to initialize pointer variables:
(printf "#define NULLED_OUT 0~n") (printf "#define NULLED_OUT 0\n")
;; Macro to initialize a pointer array: ;; Macro to initialize a pointer array:
(printf "#define NULL_OUT_ARRAY(a) memset(a, 0, sizeof(a))~n") (printf "#define NULL_OUT_ARRAY(a) memset(a, 0, sizeof(a))\n")
;; Annotation that normally disappears: ;; Annotation that normally disappears:
(printf "#define GC_CAN_IGNORE /**/~n") (printf "#define GC_CAN_IGNORE /**/\n")
(printf "#define __xform_nongcing__ /**/~n") (printf "#define __xform_nongcing__ /**/\n")
;; Another annotation to protect against GC conversion: ;; Another annotation to protect against GC conversion:
(printf "#define HIDE_FROM_XFORM(x) x~n") (printf "#define HIDE_FROM_XFORM(x) x\n")
(printf "#define XFORM_HIDE_EXPR(x) x~n") (printf "#define XFORM_HIDE_EXPR(x) x\n")
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/~n") (printf "#define HIDE_NOTHING_FROM_XFORM() /**/\n")
;; In case a conversion is unnecessary where we have this annotation: ;; In case a conversion is unnecessary where we have this annotation:
(printf "#define START_XFORM_SKIP /**/~n") (printf "#define START_XFORM_SKIP /**/\n")
(printf "#define END_XFORM_SKIP /**/~n") (printf "#define END_XFORM_SKIP /**/\n")
(printf "#define START_XFORM_SUSPEND /**/~n") (printf "#define START_XFORM_SUSPEND /**/\n")
(printf "#define END_XFORM_SUSPEND /**/~n") (printf "#define END_XFORM_SUSPEND /**/\n")
(printf "#define XFORM_START_SKIP /**/~n") (printf "#define XFORM_START_SKIP /**/\n")
(printf "#define XFORM_END_SKIP /**/~n") (printf "#define XFORM_END_SKIP /**/\n")
(printf "#define XFORM_START_SUSPEND /**/~n") (printf "#define XFORM_START_SUSPEND /**/\n")
(printf "#define XFORM_END_SUSPEND /**/~n") (printf "#define XFORM_END_SUSPEND /**/\n")
(printf "#define XFORM_SKIP_PROC /**/~n") (printf "#define XFORM_SKIP_PROC /**/\n")
;; For avoiding warnings: ;; For avoiding warnings:
(printf "#define XFORM_OK_PLUS +~n") (printf "#define XFORM_OK_PLUS +\n")
(printf "#define XFORM_OK_MINUS -~n") (printf "#define XFORM_OK_MINUS -\n")
(printf "#define XFORM_TRUST_PLUS +~n") (printf "#define XFORM_TRUST_PLUS +\n")
(printf "#define XFORM_TRUST_MINUS -~n") (printf "#define XFORM_TRUST_MINUS -\n")
(printf "#define XFORM_OK_ASSIGN /**/~n") (printf "#define XFORM_OK_ASSIGN /**/\n")
(printf "~n") (printf "\n")
;; C++ cupport: ;; C++ cupport:
(printf "#define NEW_OBJ(t) new (UseGC) t~n") (printf "#define NEW_OBJ(t) new (UseGC) t\n")
(printf "#define NEW_ARRAY(t, array) (new (UseGC) t array)~n") (printf "#define NEW_ARRAY(t, array) (new (UseGC) t array)\n")
(printf "#define NEW_ATOM(t) (new (AtomicGC) t)~n") (printf "#define NEW_ATOM(t) (new (AtomicGC) t)\n")
(printf "#define NEW_PTR(t) (new (UseGC) t)~n") (printf "#define NEW_PTR(t) (new (UseGC) t)\n")
(printf "#define NEW_ATOM_ARRAY(t, array) (new (AtomicGC) t array)~n") (printf "#define NEW_ATOM_ARRAY(t, array) (new (AtomicGC) t array)\n")
(printf "#define NEW_PTR_ARRAY(t, array) (new (UseGC) t* array)~n") (printf "#define NEW_PTR_ARRAY(t, array) (new (UseGC) t* array)\n")
(printf "#define DELETE(x) (delete x)~n") (printf "#define DELETE(x) (delete x)\n")
(printf "#define DELETE_ARRAY(x) (delete[] x)~n") (printf "#define DELETE_ARRAY(x) (delete[] x)\n")
(printf (if callee-restore? (printf (if callee-restore?
"#define XFORM_RESET_VAR_STACK /* empty */~n" "#define XFORM_RESET_VAR_STACK /* empty */\n"
"#define XFORM_RESET_VAR_STACK SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]);~n")) "#define XFORM_RESET_VAR_STACK SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]);\n"))
(unless pgc-really? (unless pgc-really?
(printf "#include \"cgc2.h\"~n")) (printf "#include \"cgc2.h\"\n"))
(printf "~n")) (printf "\n"))
(when (and pgc? precompiled-header) (when (and pgc? precompiled-header)
(printf "#include \"~a\"~n" (let-values ([(base name dir?) (split-path precompiled-header)]) (printf "#include \"~a\"\n" (let-values ([(base name dir?) (split-path precompiled-header)])
(path->string name)))) (path->string name))))
(when palm? (when palm?
(printf "#include \"segmap.h\"~n")) (printf "#include \"segmap.h\"\n"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Structures and constants ;; Structures and constants
@ -1279,7 +1279,7 @@
(display/indent v "));") (display/indent v "));")
(newline) (newline)
(inc-line!)) (inc-line!))
(printf "#~adefine ~a_COUNT (~a~a)~n" tabbing tag size prev-add) (printf "#~adefine ~a_COUNT (~a~a)\n" tabbing tag size prev-add)
(inc-line!) (inc-line!)
(printf "#~adefine SETUP_~a(x) " tabbing tag) (printf "#~adefine SETUP_~a(x) " tabbing tag)
(cond (cond
@ -1295,20 +1295,20 @@
(make-string (sub1 indent) #\space))]) (make-string (sub1 indent) #\space))])
(case (tok-n v) (case (tok-n v)
[(nested) [(nested)
(printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_each(x)~n" tabbing) (printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_each(x)\n" tabbing)
(printf "#~adefine FUNCCALL(s, x) FUNCCALL_each(s, x)~n" tabbing) (printf "#~adefine FUNCCALL(s, x) FUNCCALL_each(s, x)\n" tabbing)
(printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_each(x)~n" tabbing) (printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_each(x)\n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_each(x)~n" tabbing)] (printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_each(x)\n" tabbing)]
[(no-nested) [(no-nested)
(printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_once(x)~n" tabbing) (printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_once(x)\n" tabbing)
(printf "#~adefine FUNCCALL(s, x) FUNCCALL_once(s, x)~n" tabbing) (printf "#~adefine FUNCCALL(s, x) FUNCCALL_once(s, x)\n" tabbing)
(printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_once(x)~n" tabbing) (printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_once(x)\n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_once(x)~n" tabbing)] (printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_once(x)\n" tabbing)]
[(undefine) [(undefine)
(printf "#~aundef BLOCK_SETUP~n" tabbing) (printf "#~aundef BLOCK_SETUP\n" tabbing)
(printf "#~aundef FUNCCALL~n" tabbing) (printf "#~aundef FUNCCALL\n" tabbing)
(printf "#~aundef FUNCCALL_EMPTY~n" tabbing) (printf "#~aundef FUNCCALL_EMPTY\n" tabbing)
(printf "#~aundef FUNCCALL_AGAIN~n" tabbing)]) (printf "#~aundef FUNCCALL_AGAIN\n" tabbing)])
(set! line (+ 4 line)))] (set! line (+ 4 line)))]
[(memq (tok-n v) asm-commands) [(memq (tok-n v) asm-commands)
(newline/indent indent) (newline/indent indent)
@ -1483,7 +1483,7 @@
[(typedef? e) [(typedef? e)
(when show-info? (when show-info?
(printf "/* TYPEDEF */~n")) (printf "/* TYPEDEF */\n"))
(if (or (simple-unused-def? e) (if (or (simple-unused-def? e)
(unused-struc-typedef? e)) (unused-struc-typedef? e))
null null
@ -1496,7 +1496,7 @@
(when (eq? (tok-n (car e)) '__xform_nongcing__) (when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t)) (hash-table-put! non-gcing-functions name #t))
(when show-info? (when show-info?
(printf "/* PROTO ~a */~n" name)) (printf "/* PROTO ~a */\n" name))
(if (or precompiling-header? (if (or precompiling-header?
(> (hash-table-get used-symbols name) 1) (> (hash-table-get used-symbols name) 1)
(ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods! (ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods!
@ -1509,17 +1509,17 @@
(begin (begin
(when pgc? (when pgc?
(register-struct e)) (register-struct e))
(when show-info? (printf "/* STRUCT ~a */~n" (tok-n (cadr e))))) (when show-info? (printf "/* STRUCT ~a */\n" (tok-n (cadr e)))))
(when show-info? (printf "/* STRUCT DECL */~n"))) (when show-info? (printf "/* STRUCT DECL */\n")))
e] e]
[(class-decl? e) [(class-decl? e)
(if (or (braces? (caddr e)) (if (or (braces? (caddr e))
(eq? '|:| (tok-n (caddr e)))) (eq? '|:| (tok-n (caddr e))))
(begin (begin
(when show-info? (printf "/* CLASS ~a */~n" (tok-n (cadr e)))) (when show-info? (printf "/* CLASS ~a */\n" (tok-n (cadr e))))
(register-class e)) (register-class e))
(begin (begin
(when show-info? (printf "/* CLASS DECL */~n")) (when show-info? (printf "/* CLASS DECL */\n"))
(let ([name (tok-n (cadr e))]) (let ([name (tok-n (cadr e))])
(if (assoc name c++-classes) (if (assoc name c++-classes)
;; we already know this class ;; we already know this class
@ -1532,7 +1532,7 @@
(if (skip-function? e) (if (skip-function? e)
e e
(begin (begin
(when show-info? (printf "/* FUNCTION ~a */~n" name)) (when show-info? (printf "/* FUNCTION ~a */\n" name))
(if (or (positive? suspend-xform) (if (or (positive? suspend-xform)
(not pgc?) (not pgc?)
(and where (and where
@ -1550,7 +1550,7 @@
;; or still in headers and probably a simple inlined function ;; or still in headers and probably a simple inlined function
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
(when palm? (when palm?
(fprintf map-port "(~aimpl ~s)~n" (fprintf map-port "(~aimpl ~s)\n"
(if palm-static? "s" "") (if palm-static? "s" "")
name) name)
(call-graph name e)) (call-graph name e))
@ -1567,7 +1567,7 @@
e)) e))
(convert-function e name)))))] (convert-function e name)))))]
[(var-decl? e) [(var-decl? e)
(when show-info? (printf "/* VAR */~n")) (when show-info? (printf "/* VAR */\n"))
(if (and can-drop-vars? (if (and can-drop-vars?
(simple-unused-def? e)) (simple-unused-def? e))
null null
@ -1984,7 +1984,7 @@
tcp_accept_addr)))) tcp_accept_addr))))
(begin (begin
(when show-info? (when show-info?
(printf "/* ~a: ~a ~a*/~n" (printf "/* ~a: ~a ~a*/\n"
comment name comment name
(cond (cond
[struct-array? [struct-array?
@ -2022,7 +2022,7 @@
(log-error "[INST] ~a in ~a: Static instance of class ~a." (log-error "[INST] ~a in ~a: Static instance of class ~a."
(tok-line (car e)) (tok-file (car e)) base)) (tok-line (car e)) (tok-file (car e)) base))
(when show-info? (when show-info?
(printf "/* NP ~a: ~a */~n" (printf "/* NP ~a: ~a */\n"
comment name)) comment name))
(loop (sub1 l) #f pointers (cons (cons name (loop (sub1 l) #f pointers (cons (cons name
(make-non-pointer-type non-ptr-base)) (make-non-pointer-type non-ptr-base))
@ -2060,7 +2060,7 @@
(let loop ([e e]) (let loop ([e e])
(cond (cond
[(null? (cdr e)) [(null? (cdr e))
(fprintf map-port "(decl ~s)~n" name) (fprintf map-port "(decl ~s)\n" name)
(list (make-tok (string->symbol (format "SEGOF_~a" name)) (list (make-tok (string->symbol (format "SEGOF_~a" name))
#f #f) #f #f)
(car e))] (car e))]
@ -3449,14 +3449,14 @@
(not (or (ormap (lambda (var) (not (or (ormap (lambda (var)
(and (array-type? (cdr var)) (and (array-type? (cdr var))
'(fprintf (current-error-port) '(fprintf (current-error-port)
"Optwarn [return] ~a in ~a: tail-push blocked by ~s[].~n" "Optwarn [return] ~a in ~a: tail-push blocked by ~s[].\n"
(tok-line (car func)) (tok-file (car func)) (tok-line (car func)) (tok-file (car func))
(car var)))) (car var))))
(live-var-info-vars live-vars)) (live-var-info-vars live-vars))
(ormap (lambda (&-var) (ormap (lambda (&-var)
(and (assq &-var vars) (and (assq &-var vars)
'(fprintf (current-error-port) '(fprintf (current-error-port)
"Optwarn [return] ~a in ~a: tail-push blocked by &~s.~n" "Optwarn [return] ~a in ~a: tail-push blocked by &~s.\n"
(tok-line (car func)) (tok-file (car func)) (tok-line (car func)) (tok-file (car func))
&-var))) &-var)))
&-vars))))] &-vars))))]
@ -3854,7 +3854,7 @@
(call-graph/body name (seq->list (seq-in v)))] (call-graph/body name (seq->list (seq-in v)))]
[(assq (tok-n v) (prototyped)) [(assq (tok-n v) (prototyped))
(fprintf map-port (fprintf map-port
"(call ~s ~s)~n" "(call ~s ~s)\n"
name (tok-n v))] name (tok-n v))]
[else (void)])) [else (void)]))
e)) e))
@ -4032,8 +4032,8 @@
(when precompiling-header? (when precompiling-header?
(let loop ([i 1]) (let loop ([i 1])
(unless (i . > . gentag-count) (unless (i . > . gentag-count)
(printf "#undef XfOrM~a_COUNT~n" i) (printf "#undef XfOrM~a_COUNT\n" i)
(printf "#undef SETUP_XfOrM~a~n" i) (printf "#undef SETUP_XfOrM~a\n" i)
(loop (add1 i))))) (loop (add1 i)))))
(close-output-port (current-output-port)) (close-output-port (current-output-port))

6
collects/compiler/src2src.rkt
View File

@ -79,7 +79,7 @@
(init-field src-stx) (init-field src-stx)
(when (not (syntax? src-stx)) (when (not (syntax? src-stx))
(printf "~a~n" src-stx) (printf "~a\n" src-stx)
(error 'stx)) (error 'stx))
(init-field [cert-stxes (list src-stx)]) (init-field [cert-stxes (list src-stx)])
(field (known-value #f)) (field (known-value #f))
@ -701,7 +701,7 @@
[f (dynamic-require 'mzscheme (send rator orig-name))]) [f (dynamic-require 'mzscheme (send rator orig-name))])
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(fprintf (current-error-port) (fprintf (current-error-port)
"constant calculation error: ~a~n" "constant calculation error: ~a\n"
(exn-message x)) (exn-message x))
this)]) this)])
(known-single-result (known-single-result
@ -1583,7 +1583,7 @@
(syntax-position stx))]) (syntax-position stx))])
(fprintf (current-output-port) " ")) (fprintf (current-output-port) " "))
(fprintf (current-output-port) (fprintf (current-output-port)
"~a: ~.s~n" "~a: ~.s\n"
msg msg
(syntax->datum (send exp sexpr))))) (syntax->datum (send exp sexpr)))))

2
collects/deinprogramm/world.rkt
View File

@ -194,7 +194,7 @@
(else #f)))) (else #f))))
[define (end-of-time s) [define (end-of-time s)
(printf "end of time: ~a~n" s) (printf "end of time: ~a\n" s)
(stop-it) (stop-it)
the-world] the-world]

2
collects/dynext/compile-unit.rkt
View File

@ -290,7 +290,7 @@
((current-make-compile-input-strings) in) ((current-make-compile-input-strings) in)
((current-make-compile-output-strings) out))]) ((current-make-compile-output-strings) out))])
(unless quiet? (unless quiet?
(printf "compile-extension: ~a~n" command)) (printf "compile-extension: ~a\n" command))
(apply my-process* command))) (apply my-process* command)))
quiet?) quiet?)
(error 'compile-extension "can't find an installed C compiler"))))) (error 'compile-extension "can't find an installed C compiler")))))

10
collects/dynext/link-unit.rkt
View File

@ -350,7 +350,7 @@
libs libs
output-strings)]) output-strings)])
(unless quiet? (unless quiet?
(printf "link-extension: ~a~n" command)) (printf "link-extension: ~a\n" command))
(stdio-link (lambda (quiet?) (stdio-link (lambda (quiet?)
(apply my-process* command)) (apply my-process* command))
quiet?) quiet?)
@ -393,25 +393,25 @@
(cddr l)] (cddr l)]
[else (cons (car l) (loop (cdr l)))]))]) [else (cons (car l) (loop (cdr l)))]))])
(unless quiet? (unless quiet?
(printf "link-extension, dlltool phase: ~a~n" (printf "link-extension, dlltool phase: ~a\n"
(cons dlltool dll-command))) (cons dlltool dll-command)))
(stdio-link (lambda (quiet?) (stdio-link (lambda (quiet?)
(apply my-process* dlltool dll-command)) (apply my-process* dlltool dll-command))
quiet?) quiet?)
(unless quiet? (unless quiet?
(printf "link-extension, re-link phase: ~a~n" (printf "link-extension, re-link phase: ~a\n"
command1)) command1))
(stdio-link (lambda (quiet?) (stdio-link (lambda (quiet?)
(apply my-process* command1)) (apply my-process* command1))
quiet?) quiet?)
(unless quiet? (unless quiet?
(printf "link-extension, re-dlltool phase: ~a~n" (printf "link-extension, re-dlltool phase: ~a\n"
(cons dlltool dll-command))) (cons dlltool dll-command)))
(stdio-link (lambda (quiet?) (stdio-link (lambda (quiet?)
(apply my-process* dlltool dll-command)) (apply my-process* dlltool dll-command))
quiet?) quiet?)
(unless quiet? (unless quiet?
(printf "link-extension, last re-link phase: ~a~n" (printf "link-extension, last re-link phase: ~a\n"
command2)) command2))
(stdio-link (lambda (quiet?) (stdio-link (lambda (quiet?)
(apply my-process* command2)) (apply my-process* command2))

2
collects/dynext/private/stdio.rkt
View File

@ -27,7 +27,7 @@
(let loop () (let loop ()
(let ([t (read-line in 'any)]) (let ([t (read-line in 'any)])
(unless (eof-object? t) (unless (eof-object? t)
(unless quiet? (fprintf (dest) "~a~n" t)) (unless quiet? (fprintf (dest) "~a\n" t))
(set-box! box (string-append (unbox box) (set-box! box (string-append (unbox box)
(string #\newline) t)) (string #\newline) t))
(loop)))))))] (loop)))))))]

62
collects/eopl/private/sllgen.rkt
View File

@ -677,7 +677,7 @@
(letrec (letrec
((loop ((loop
(lambda (rhs) (lambda (rhs)
;; (eopl:printf "~s~%" rhs) ;; (eopl:printf "~s\n" rhs)
(if (null? rhs) 0 (if (null? rhs) 0
(let ((rhs-item (car rhs)) (let ((rhs-item (car rhs))
(rest (cdr rhs))) (rest (cdr rhs)))
@ -685,26 +685,26 @@
((and ((and
(symbol? rhs-item) (symbol? rhs-item)
(sllgen:non-terminal? rhs-item)) (sllgen:non-terminal? rhs-item))
; (eopl:printf "found nonterminal~%") ; (eopl:printf "found nonterminal\n")
(+ 1 (loop rest))) (+ 1 (loop rest)))
((symbol? rhs-item) ((symbol? rhs-item)
; (eopl:printf "found terminal~%") ; (eopl:printf "found terminal\n")
(+ 1 (loop rest))) (+ 1 (loop rest)))
((sllgen:arbno? rhs-item) ((sllgen:arbno? rhs-item)
; (eopl:printf "found arbno~%") ; (eopl:printf "found arbno\n")
(+ (+
(loop (sllgen:arbno->rhs rhs-item)) (loop (sllgen:arbno->rhs rhs-item))
(loop rest))) (loop rest)))
((sllgen:separated-list? rhs-item) ((sllgen:separated-list? rhs-item)
; (eopl:printf "found seplist~%") ; (eopl:printf "found seplist\n")
(+ (+
(loop (sllgen:separated-list->rhs rhs-item)) (loop (sllgen:separated-list->rhs rhs-item))
(loop rest))) (loop rest)))
((string? rhs-item) ((string? rhs-item)
; (eopl:printf "found string~%") ; (eopl:printf "found string\n")
(loop rest)) (loop rest))
(else (else
; (eopl:printf "found error~%") ; (eopl:printf "found error\n")
(report-error rhs-item "unrecognized item")))))))) (report-error rhs-item "unrecognized item"))))))))
(loop rhs))))) (loop rhs)))))
@ -884,7 +884,7 @@
(init-loop (cdr productions)))))) (init-loop (cdr productions))))))
(rhs-loop (rhs-loop
(lambda (lhs rhs) (lambda (lhs rhs)
;; (eopl:printf "rhs-loop lhs=~s rhs=~s~%" lhs rhs) ;; (eopl:printf "rhs-loop lhs=~s rhs=~s\n" lhs rhs)
(cond (cond
((null? rhs) #t) ((null? rhs) #t)
((get-nonterminal (car rhs)) => ((get-nonterminal (car rhs)) =>
@ -905,7 +905,7 @@
(set! closure-rules (set! closure-rules
(cons (list lhs nonterminal) (cons (list lhs nonterminal)
closure-rules)) closure-rules))
;; (eopl:printf "~s~%" (list lhs nonterminal)) ;; (eopl:printf "~s\n" (list lhs nonterminal))
))) )))
first-of-rest)) first-of-rest))
;; now keep looking ;; now keep looking
@ -1073,7 +1073,7 @@
;; 1999, since class could be a string. ;; 1999, since class could be a string.
((member class (car (car others))) ((member class (car (car others)))
(error 'parser-generation (error 'parser-generation
"grammar not LL(1): shift conflict detected for class ~s in nonterminal ~s:~%~s~%~s~%" "grammar not LL(1): shift conflict detected for class ~s in nonterminal ~s:\n~s\n~s\n"
class non-terminal this-production (car others))) class non-terminal this-production (car others)))
(else (inner (cdr others)))))) (else (inner (cdr others))))))
(car this-production)) (car this-production))
@ -1495,7 +1495,7 @@
; ) ; )
; (case opcode ; (case opcode
; ((skip) (sllgen:error 'sllgen:cook-token ; ((skip) (sllgen:error 'sllgen:cook-token
; "~%Internal error: skip should have been handled earlier ~s" ; "\nInternal error: skip should have been handled earlier ~s"
; actions)) ; actions))
; ((make-symbol identifier) ; ((make-symbol identifier)
; (sllgen:make-token 'identifier ; (sllgen:make-token 'identifier
@ -1511,7 +1511,7 @@
; loc)) ; loc))
; (else ; (else
; (sllgen:error 'scanning ; (sllgen:error 'scanning
; "~%Unknown opcode selected from action list ~s" ; "\nUnknown opcode selected from action list ~s"
; actions)))))) ; actions))))))
@ -1522,16 +1522,16 @@
(newstates '()) (newstates '())
(char '()) (char '())
(eos-found? #f)) ; do we need to return this too? (eos-found? #f)) ; do we need to return this too?
;(eopl:printf "initializing sllgen:scanner-inner-loop~%") ;(eopl:printf "initializing sllgen:scanner-inner-loop\n")
(let loop ((local-states local-states)) ; local-states (let loop ((local-states local-states)) ; local-states
; '(begin ; '(begin
; (eopl:printf "sllgen:scanner-inner-loop char = ~s actions=~s local-states =~%" ; (eopl:printf "sllgen:scanner-inner-loop char = ~s actions=~s local-states =\n"
; char actions) ; char actions)
; (for-each ; (for-each
; (lambda (local-state) ; (lambda (local-state)
; (sllgen:pretty-print (map sllgen:unparse-regexp local-state))) ; (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
; local-states) ; local-states)
; (eopl:printf "newstates = ~%") ; (eopl:printf "newstates = \n")
; (for-each ; (for-each
; (lambda (local-state) ; (lambda (local-state)
; (sllgen:pretty-print (map sllgen:unparse-regexp local-state))) ; (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
@ -1540,7 +1540,7 @@
;; no more states to consider ;; no more states to consider
(begin (begin
; '(eopl:printf ; '(eopl:printf
; "sllgen:scanner-inner-loop returning with actions = ~s char = ~s newstates = ~%" ; "sllgen:scanner-inner-loop returning with actions = ~s char = ~s newstates = \n"
; actions char) ; actions char)
; '(for-each ; '(for-each
; (lambda (local-state) ; (lambda (local-state)
@ -1548,7 +1548,7 @@
; newstates) ; newstates)
(k actions newstates char stream)) (k actions newstates char stream))
(let ((state (car local-states))) (let ((state (car local-states)))
; (eopl:printf "first state:~%") ; (eopl:printf "first state:\n")
; (sllgen:pretty-print state) ; (sllgen:pretty-print state)
(cond (cond
((sllgen:action? (car state)) ; state should never be null ((sllgen:action? (car state)) ; state should never be null
@ -1564,11 +1564,11 @@
(if (and (null? char) (not eos-found?)) (if (and (null? char) (not eos-found?))
(sllgen:char-stream-get! stream (sllgen:char-stream-get! stream
(lambda (ch1) (lambda (ch1)
'(eopl:printf "read character ~s~%" ch1) '(eopl:printf "read character ~s\n" ch1)
(set! char ch1)) (set! char ch1))
(lambda () (lambda ()
(set! eos-found? #t)))) (set! eos-found? #t))))
'(eopl:printf "applying tester ~s to ~s~%" tester char) '(eopl:printf "applying tester ~s to ~s\n" tester char)
(if (and (not (null? char)) (if (and (not (null? char))
(sllgen:apply-tester tester char)) (sllgen:apply-tester tester char))
;; passed the test -- shift is possible ;; passed the test -- shift is possible
@ -1602,7 +1602,7 @@
=> =>
(sllgen:xapply (sllgen:xapply
(lambda (sequents) (lambda (sequents)
;; (printf "processing concat: sequents = ~s~%" sequents) ;; (printf "processing concat: sequents = ~s\n" sequents)
(loop (loop
(cons (cons
(append sequents (cdr state)) (append sequents (cdr state))
@ -1630,7 +1630,7 @@
;; ok, the current buffer is a candidate token ;; ok, the current buffer is a candidate token
(begin (begin
(set! success-buffer buffer) (set! success-buffer buffer)
;; (printf "success-buffer =~s~%" success-buffer) ;; (printf "success-buffer =~s\n" success-buffer)
(set! actions new-actions)) (set! actions new-actions))
;; otherwise leave success-buffer and actions alone ;; otherwise leave success-buffer and actions alone
) )
@ -1663,7 +1663,7 @@
;; this really is reference equality. ;; this really is reference equality.
#t #t
(begin (begin
;; (eopl:printf "pushing back ~s~%" (car buff)) ;; (eopl:printf "pushing back ~s\n" (car buff))
(sllgen:char-stream-push-back! (car buffer) stream) (sllgen:char-stream-push-back! (car buffer) stream)
(set! buffer (cdr buffer)) (set! buffer (cdr buffer))
(push-back-loop)))) (push-back-loop))))
@ -1724,9 +1724,9 @@
(define sllgen:make-stream (define sllgen:make-stream
(lambda (tag char stream) (lambda (tag char stream)
;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s~%" tag char) ;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s\n" tag char)
(lambda (fcn eos-fcn) (lambda (fcn eos-fcn)
;(eopl:printf "sllgen:make-stream: emitting ~s~%" char) ;(eopl:printf "sllgen:make-stream: emitting ~s\n" char)
(fcn char stream)))) (fcn char stream))))
(define sllgen:list->stream (define sllgen:list->stream
@ -1778,7 +1778,7 @@
(lambda () (lambda ()
;; when the stream runs out, try this ;; when the stream runs out, try this
(let ((sentinel (sentinel-fcn))) (let ((sentinel (sentinel-fcn)))
; (eopl:printf "~s~%" sentinel) ; (eopl:printf "~s\n" sentinel)
(fn sentinel (sllgen:constant-stream sentinel)))))))) (fn sentinel (sllgen:constant-stream sentinel))))))))
; no longer used ; no longer used
@ -1952,13 +1952,13 @@
(if (null? token) (if (null? token)
(sllgen:stream-get! stream (sllgen:stream-get! stream
(lambda (next-token next-stream) (lambda (next-token next-stream)
; '(eopl:printf "find-production: filling token buffer with ~s~%" token) ; '(eopl:printf "find-production: filling token buffer with ~s\n" token)
(set! token next-token) (set! token next-token)
(set! stream next-stream)) (set! stream next-stream))
(lambda () (lambda ()
(error 'sllgen:find-production (error 'sllgen:find-production
"internal error: shouldn't run off end of stream")))) "internal error: shouldn't run off end of stream"))))
; '(eopl:printf "sllgen:find-production: nonterminal = ~s token = ~s~%" ; '(eopl:printf "sllgen:find-production: nonterminal = ~s token = ~s\n"
; non-terminal token) ; non-terminal token)
(let loop (let loop
((alternatives (cdr (assq non-terminal parser)))) ((alternatives (cdr (assq non-terminal parser))))
@ -1971,7 +1971,7 @@
(sllgen:token->class token) (sllgen:token->class token)
(sllgen:token->data token))) (sllgen:token->data token)))
((member (sllgen:token->class token) (car (car alternatives))) ((member (sllgen:token->class token) (car (car alternatives)))
; '(eopl:printf "sllgen:find-production: using ~s~%~%" ; '(eopl:printf "sllgen:find-production: using ~s\n\n"
; (cdr (car alternatives))) ; (cdr (car alternatives)))
(sllgen:apply-actions non-terminal (cdr (car alternatives)) (sllgen:apply-actions non-terminal (cdr (car alternatives))
parser buf token stream k)) parser buf token stream k))
@ -2001,7 +2001,7 @@
(report-error (report-error
(lambda (target) (lambda (target)
(error 'parsing (error 'parsing
"at line ~s: looking for ~s, found ~s ~s in production~%~s" "at line ~s: looking for ~s, found ~s ~s in production\n~s"
(sllgen:token->location token) (sllgen:token->location token)
target target
(sllgen:token->class token) (sllgen:token->class token)
@ -2009,7 +2009,7 @@
action-list)))) action-list))))
(let ((action (car actions)) (let ((action (car actions))
(next-action (cdr actions))) (next-action (cdr actions)))
; (eopl:printf "actions = ~s~%token = ~s buf = ~s~%~%" actions token buf) ; (eopl:printf "actions = ~s\ntoken = ~s buf = ~s~%~%" actions token buf)
(case (car action) (case (car action)
((term) ((term)
(fill-token!) (fill-token!)
@ -2077,7 +2077,7 @@
(let loop ((trees trees) (let loop ((trees trees)
(ptr ans) (ptr ans)
(ctr n)) (ctr n))
; (eopl:printf "ctr = ~s trees = ~s~%" ctr trees) ; (eopl:printf "ctr = ~s trees = ~s\n" ctr trees)
(cond (cond
((null? trees) (mlist->list ans)) ((null? trees) (mlist->list ans))
((zero? ctr) (loop trees ans n)) ((zero? ctr) (loop trees ans n))

10
collects/errortrace/errortrace-lib.rkt
View File

@ -370,7 +370,7 @@
(define (output-profile-results paths? sort-time?) (define (output-profile-results paths? sort-time?)
(profiling-enabled #f) (profiling-enabled #f)
(error-print-width 50) (error-print-width 50)
(printf "Sorting profile data...~n") (printf "Sorting profile data...\n")
(let* ([sel (if sort-time? cadr car)] (let* ([sel (if sort-time? cadr car)]
[counts (sort (filter (lambda (c) (positive? (car c))) [counts (sort (filter (lambda (c) (positive? (car c)))
(get-profile-results)) (get-profile-results))
@ -379,8 +379,8 @@
(for-each (for-each
(lambda (c) (lambda (c)
(set! total (+ total (sel c))) (set! total (+ total (sel c)))
(printf "=========================================================~n") (printf "=========================================================\n")
(printf "time = ~a : no. = ~a : ~e in ~s~n" (printf "time = ~a : no. = ~a : ~e in ~s\n"
(cadr c) (car c) (caddr c) (cadddr c)) (cadr c) (car c) (caddr c) (cadddr c))
;; print call paths ;; print call paths
(when paths? (when paths?
@ -392,10 +392,10 @@
(lambda (cm) (lambda (cm)
(printf " <- ~e" (car cm))) (printf " <- ~e" (car cm)))
(cddr cms)) (cddr cms))
(printf "~n"))) (printf "\n")))
(sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b))))))) (sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b)))))))
counts) counts)
(printf "Total samples: ~a~n" total))) (printf "Total samples: ~a\n" total)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
collects/framework/preferences.rkt
View File

@ -244,7 +244,7 @@ the state transitions / contracts are:
(pref-can-init? p)) (pref-can-init? p))
(let ([default-okay? (checker default-value)]) (let ([default-okay? (checker default-value)])
(unless default-okay? (unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t\n"
p checker default-okay? default-value))) p checker default-okay? default-value)))
(unless (= (length aliases) (length rewrite-aliases)) (unless (= (length aliases) (length rewrite-aliases))

6
collects/framework/private/color-model.rkt
View File

@ -192,7 +192,7 @@
(,(xyz-z xyz-white))))]) (,(xyz-z xyz-white))))])
(apply values (car (transpose sigmas))))) (apply values (car (transpose sigmas)))))
;; (printf "should be equal to xyz-white: ~n~a~n" ;; (printf "should be equal to xyz-white: \n~a\n"
;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b)))) ;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
(define rgb->xyz-matrix (define rgb->xyz-matrix
@ -203,13 +203,13 @@
(define xyz->rgb-matrix (define xyz->rgb-matrix
(matrix-invert rgb->xyz-matrix)) (matrix-invert rgb->xyz-matrix))
;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) ;;(printf "should be identity: \n~a\n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
(define (rgb->xyz r g b) (define (rgb->xyz r g b)
(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
;;(print-struct #t) ;;(print-struct #t)
;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255)) ;; (printf "should be xyz-white: \n~a\n" (rgb->xyz 255 255 255))
(define (xyz->rgb x y z) (define (xyz->rgb x y z)
(car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))

40
collects/framework/private/color.rkt
View File

@ -286,7 +286,7 @@ added get-regions
(enable-suspend #t)))]) (enable-suspend #t)))])
(unless (eq? 'eof type) (unless (eq? 'eof type)
(enable-suspend #f) (enable-suspend #f)
#; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) #; (printf "~a at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
(+ in-start-pos (sub1 new-token-end))) (+ in-start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
@ -418,11 +418,11 @@ added get-regions
(define/private (colorer-driver) (define/private (colorer-driver)
(unless (andmap lexer-state-up-to-date? lexer-states) (unless (andmap lexer-state-up-to-date? lexer-states)
#;(printf "revision ~a~n" (get-revision-number)) #;(printf "revision ~a\n" (get-revision-number))
(unless (and tok-cor (= rev (get-revision-number))) (unless (and tok-cor (= rev (get-revision-number)))
(when tok-cor (when tok-cor
(coroutine-kill tok-cor)) (coroutine-kill tok-cor))
#;(printf "new coroutine~n") #;(printf "new coroutine\n")
(set! tok-cor (set! tok-cor
(coroutine (coroutine
(λ (enable-suspend) (λ (enable-suspend)
@ -450,19 +450,19 @@ added get-regions
(format "exception in colorer thread: ~s" exn) (format "exception in colorer thread: ~s" exn)
exn)) exn))
(set! tok-cor #f)))) (set! tok-cor #f))))
#;(printf "begin lexing~n") #;(printf "begin lexing\n")
(when (coroutine-run 10 tok-cor) (when (coroutine-run 10 tok-cor)
(for-each (lambda (ls) (for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t)) (set-lexer-state-up-to-date?! ls #t))
lexer-states))) lexer-states)))
#;(printf "end lexing~n") #;(printf "end lexing\n")
#;(printf "begin coloring~n") #;(printf "begin coloring\n")
;; This edit sequence needs to happen even when colors is null ;; This edit sequence needs to happen even when colors is null
;; for the paren highlighter. ;; for the paren highlighter.
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(color) (color)
(end-edit-sequence) (end-edit-sequence)
#;(printf "end coloring~n"))) #;(printf "end coloring\n")))
(define/private (colorer-callback) (define/private (colorer-callback)
(cond (cond
@ -643,7 +643,7 @@ added get-regions
;; possible. ;; possible.
(define/private match-parens (define/private match-parens
(lambda ([just-clear? #f]) (lambda ([just-clear? #f])
;;(printf "(match-parens ~a)~n" just-clear?) ;;(printf "(match-parens ~a)\n" just-clear?)
(when (and (not in-match-parens?) (when (and (not in-match-parens?)
;; Trying to match open parens while the ;; Trying to match open parens while the
;; background thread is going slows it down. ;; background thread is going slows it down.
@ -918,21 +918,21 @@ added get-regions
(let* ((x null) (let* ((x null)
(f (λ (a b c) (set! x (cons (list a b c) x))))) (f (λ (a b c) (set! x (cons (list a b c) x)))))
(send (lexer-state-tokens ls) for-each f) (send (lexer-state-tokens ls) for-each f)
(printf "tokens: ~.s~n" (reverse x)) (printf "tokens: ~.s\n" (reverse x))
(set! x null) (set! x null)
(send (lexer-state-invalid-tokens ls) for-each f) (send (lexer-state-invalid-tokens ls) for-each f)
(printf "invalid-tokens: ~.s~n" (reverse x)) (printf "invalid-tokens: ~.s\n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a\n"
(lexer-state-start-pos ls) (lexer-state-start-pos ls)
(lexer-state-current-pos ls) (lexer-state-current-pos ls)
(lexer-state-invalid-tokens-start ls)) (lexer-state-invalid-tokens-start ls))
(printf "parens: ~.s~n" (car (send (lexer-state-parens ls) test))))) (printf "parens: ~.s\n" (car (send (lexer-state-parens ls) test)))))
lexer-states)) lexer-states))
;; ------------------------- Callbacks to Override ---------------------- ;; ------------------------- Callbacks to Override ----------------------
(define/override (lock x) (define/override (lock x)
;;(printf "(lock ~a)~n" x) ;;(printf "(lock ~a)\n" x)
(super lock x) (super lock x)
(when (and restart-callback (not x)) (when (and restart-callback (not x))
(set! restart-callback #f) (set! restart-callback #f)
@ -940,25 +940,25 @@ added get-regions
(define/override (on-focus on?) (define/override (on-focus on?)
;;(printf "(on-focus ~a)~n" on?) ;;(printf "(on-focus ~a)\n" on?)
(super on-focus on?) (super on-focus on?)
(match-parens (not on?))) (match-parens (not on?)))
(define/augment (after-edit-sequence) (define/augment (after-edit-sequence)
;;(printf "(after-edit-sequence)~n") ;;(printf "(after-edit-sequence)\n")
(when (has-focus?) (when (has-focus?)
(match-parens)) (match-parens))
(inner (void) after-edit-sequence)) (inner (void) after-edit-sequence))
(define/augment (after-set-position) (define/augment (after-set-position)
;;(printf "(after-set-position)~n") ;;(printf "(after-set-position)\n")
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(match-parens))) (match-parens)))
(inner (void) after-set-position)) (inner (void) after-set-position))
(define/augment (after-change-style a b) (define/augment (after-change-style a b)
;;(printf "(after-change-style)~n") ;;(printf "(after-change-style)\n")
(unless (get-styles-fixed) (unless (get-styles-fixed)
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
@ -966,19 +966,19 @@ added get-regions
(inner (void) after-change-style a b)) (inner (void) after-change-style a b))
(define/augment (on-set-size-constraint) (define/augment (on-set-size-constraint)
;;(printf "(on-set-size-constraint)~n") ;;(printf "(on-set-size-constraint)\n")
(unless (local-edit-sequence?) (unless (local-edit-sequence?)
(when (has-focus?) (when (has-focus?)
(match-parens))) (match-parens)))
(inner (void) on-set-size-constraint)) (inner (void) on-set-size-constraint))
(define/augment (after-insert edit-start-pos change-length) (define/augment (after-insert edit-start-pos change-length)
;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length) ;;(printf "(after-insert ~a ~a)\n" edit-start-pos change-length)
(do-insert/delete edit-start-pos change-length) (do-insert/delete edit-start-pos change-length)
(inner (void) after-insert edit-start-pos change-length)) (inner (void) after-insert edit-start-pos change-length))
(define/augment (after-delete edit-start-pos change-length) (define/augment (after-delete edit-start-pos change-length)
;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length) ;;(printf "(after-delete ~a ~a)\n" edit-start-pos change-length)
(do-insert/delete edit-start-pos (- change-length)) (do-insert/delete edit-start-pos (- change-length))
(inner (void) after-delete edit-start-pos change-length)) (inner (void) after-delete edit-start-pos change-length))

4
collects/framework/private/editor.rkt
View File

@ -242,10 +242,10 @@
(unless (and (procedure? t) (unless (and (procedure? t)
(= 0 (procedure-arity t))) (= 0 (procedure-arity t)))
(error 'editor:basic::run-after-edit-sequence (error 'editor:basic::run-after-edit-sequence
"expected procedure of arity zero, got: ~s~n" t)) "expected procedure of arity zero, got: ~s\n" t))
(unless (or (symbol? sym) (not sym)) (unless (or (symbol? sym) (not sym))
(error 'editor:basic::run-after-edit-sequence (error 'editor:basic::run-after-edit-sequence
"expected second argument to be a symbol or #f, got: ~s~n" "expected second argument to be a symbol or #f, got: ~s\n"
sym)) sym))
(if (refresh-delayed?) (if (refresh-delayed?)
(if in-local-edit-sequence? (if in-local-edit-sequence?

4
collects/framework/private/gen-standard-menus.rkt
View File

@ -125,7 +125,7 @@
(write-docs)) (write-docs))
(define (write-docs) (define (write-docs)
(printf "writing to ~a~n" docs-menus.ss-filename) (printf "writing to ~a\n" docs-menus.ss-filename)
(call-with-output-file docs-menus.ss-filename (call-with-output-file docs-menus.ss-filename
(λ (port) (λ (port)
(define (pop-out sexp) (define (pop-out sexp)
@ -203,7 +203,7 @@
#:exists 'truncate)) #:exists 'truncate))
(define (write-standard-menus.rkt) (define (write-standard-menus.rkt)
(printf "writing to ~a~n" standard-menus.rkt-filename) (printf "writing to ~a\n" standard-menus.rkt-filename)
(call-with-output-file standard-menus.rkt-filename (call-with-output-file standard-menus.rkt-filename
(λ (port) (λ (port)

2
collects/framework/private/panel.rkt
View File

@ -44,7 +44,7 @@
[(left top) 0] [(left top) 0]
[(right bottom) (- total-size item-size)] [(right bottom) (- total-size item-size)]
[else (error 'place-children [else (error 'place-children
"alignment spec is unknown ~a~n" spec)])))]) "alignment spec is unknown ~a\n" spec)])))])
(map (λ (l) (map (λ (l)
(let*-values ([(min-width min-height h-stretch? v-stretch?) (let*-values ([(min-width min-height h-stretch? v-stretch?)
(apply values l)] (apply values l)]

2
collects/framework/private/preferences.rkt
View File

@ -528,7 +528,7 @@ the state transitions / contracts are:
(cond (cond
[(string? default) string?] [(string? default) string?]
[(number? default) number?] [(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)])) [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)]))
(preferences:add-callback (preferences:add-callback
name name
(λ (p new-value) (λ (p new-value)

4
collects/framework/splash.rkt
View File

@ -123,12 +123,12 @@
[(or (path? splash-draw-spec) [(or (path? splash-draw-spec)
(string? splash-draw-spec)) (string? splash-draw-spec))
(unless (file-exists? splash-draw-spec) (unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec) (fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
(no-splash)) (no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec)) (set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?) (unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec) (fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
(no-splash)) (no-splash))
(send splash-canvas min-width (send splash-bitmap get-width)) (send splash-canvas min-width (send splash-bitmap get-width))

2
collects/framework/test.rkt
View File

@ -363,7 +363,7 @@
(loop (- n 1))))])))] (loop (- n 1))))])))]
[(number? state) [(number? state)
(unless (send rb is-enabled? state) (unless (send rb is-enabled? state)
(error 'test:set-radio-box! "item ~a is not enabled~n" state)) (error 'test:set-radio-box! "item ~a is not enabled\n" state))
(send rb set-selection state)] (send rb set-selection state)]
[else (error 'test:set-radio-box! [else (error 'test:set-radio-box!
"expected a string or a number as second arg, got: ~e (other arg: ~e)" "expected a string or a number as second arg, got: ~e (other arg: ~e)"

2
collects/racket/match/compiler.rkt
View File

@ -402,7 +402,7 @@
(Row-vars-seen (Row-vars-seen
(car block))))) (car block)))))
#'failkv)))] #'failkv)))]
[else (error 'compile "unsupported pattern: ~a~n" first)])) [else (error 'compile "unsupported pattern: ~a\n" first)]))
(define (compile* vars rows esc) (define (compile* vars rows esc)
(define (let/wrap clauses body) (define (let/wrap clauses body)

8
collects/racket/match/split-rows.rkt
View File

@ -30,13 +30,13 @@
(cond [(Row-unmatch r) (cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))] (split-rows rows (cons (reverse matched-rows) prev-mats))]
[(and (Struct? p) struct-key (eq? (pat-key p) struct-key)) [(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
;; (printf "struct-keys were equal: ~a~n" struct-key) ;; (printf "struct-keys were equal: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats struct-key rs)] (loop/con (cons r matched-rows) prev-mats struct-key rs)]
[(and (Struct? p) (not struct-key)) [(and (Struct? p) (not struct-key))
;; (printf "no struct-key so far: ~a~n" struct-key) ;; (printf "no struct-key so far: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats (pat-key p) rs)] (loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
[(and (CPat? p) (not (Struct? p))) [(and (CPat? p) (not (Struct? p)))
;; (printf "wasn't a struct: ~a~n" p) ;; (printf "wasn't a struct: ~a\n" p)
(loop/con (cons r matched-rows) prev-mats struct-key rs)] (loop/con (cons r matched-rows) prev-mats struct-key rs)]
[else (split-rows rows (cons (reverse matched-rows) [else (split-rows rows (cons (reverse matched-rows)
prev-mats))])))) prev-mats))]))))
@ -66,7 +66,7 @@
[(CPat? p) [(CPat? p)
(if (Struct? p) (if (Struct? p)
(begin (begin
;; (printf "found a struct: ~a~n" (pat-key r)) ;; (printf "found a struct: ~a\n" (pat-key r))
(loop/con (list r) acc (pat-key p) rs)) (loop/con (list r) acc (pat-key p) rs))
(loop/con (list r) acc #f rs))] (loop/con (list r) acc #f rs))]
[else (split-rows rs (cons (list r) acc))])))) [else (split-rows rs (cons (list r) acc))]))))

2
collects/racket/private/more-scheme.rkt
View File

@ -341,7 +341,7 @@
(syntax/loc (syntax/loc
stx stx
(let-values ([(v cpu user gc) (time-apply (lambda () expr1 expr ...) null)]) (let-values ([(v cpu user gc) (time-apply (lambda () expr1 expr ...) null)])
(printf "cpu time: ~s real time: ~s gc time: ~s~n" cpu user gc) (printf "cpu time: ~s real time: ~s gc time: ~s\n" cpu user gc)
(apply values v)))]))) (apply values v)))])))
(define-syntax (log-it stx) (define-syntax (log-it stx)

15
collects/racket/trace.rkt
View File

@ -93,9 +93,8 @@
(lambda (n port offset width) (lambda (n port offset width)
(display (display
(if n (if n
(if (zero? n) first (if (zero? n) first (format "\n~a" rest))
(format "~n~a" rest)) "\n")
(format "~n"))
port) port)
(if n (if n
(if (zero? n) (if (zero? n)
@ -119,9 +118,8 @@
(lambda (n port offset width) (lambda (n port offset width)
(display (display
(if n (if n
(if (zero? n) first (if (zero? n) first (format "\n~a" rest))
(format "~n~a" rest)) "\n")
(format "~n"))
port) port)
(if n (if n
(if (zero? n) (if (zero? n)
@ -139,9 +137,8 @@
(lambda (n port offset width) (lambda (n port offset width)
(display (display
(if n (if n
(if (zero? n) rest (if (zero? n) rest (format "\n~a" rest))
(format "~n~a" rest)) "\n")
(format "~n"))
port) port)
(if n (if n
(string-length rest) (string-length rest)

2
collects/setup/parallel-build-worker.rkt
View File

@ -17,7 +17,7 @@
(write msg))) (write msg)))
(let ([cep (current-error-port)]) (let ([cep (current-error-port)])
(define (pp x) (define (pp x)
(fprintf cep "COMPILING ~a ~a ~a ~a~n" worker-id name file x)) (fprintf cep "COMPILING ~a ~a ~a ~a\n" worker-id name file x))
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(send/resp (list 'ERROR (exn-message x))))]) (send/resp (list 'ERROR (exn-message x))))])
(parameterize ( (parameterize (

8
collects/setup/parallel-build.rkt
View File

@ -25,8 +25,8 @@
['DONE (void)]) ['DONE (void)])
(when (or (not (zero? (string-length out))) (not (zero? (string-length err)))) (when (or (not (zero? (string-length out))) (not (zero? (string-length err))))
((collects-queue-printer jobqueue) (current-error-port) "build-output" "~a ~a" cc-name file) ((collects-queue-printer jobqueue) (current-error-port) "build-output" "~a ~a" cc-name file)
(eprintf "STDOUT:~n~a=====~n" out) (eprintf "STDOUT:\n~a=====\n" out)
(eprintf "STDERR:~n~a=====~n" err)))])) (eprintf "STDERR:\n~a=====\n" err)))]))
;; assigns a collection to each worker to be compiled ;; assigns a collection to each worker to be compiled
;; when it runs out of collections, steals work from other workers collections ;; when it runs out of collections, steals work from other workers collections
(define (get-job jobqueue workerid) (define (get-job jobqueue workerid)
@ -53,7 +53,7 @@
(let* ([cc-name (cc-name cc)] (let* ([cc-name (cc-name cc)]
[cc-path (cc-path cc)] [cc-path (cc-path cc)]
[full-path (path->string (build-path cc-path file))]) [full-path (path->string (build-path cc-path file))])
;(printf "JOB ~a ~a ~a ~a~n" workerid cc-name cc-path file) ;(printf "JOB ~a ~a ~a ~a\n" workerid cc-name cc-path file)
(values (list cc file) (list cc-name (->bytes cc-path) (->bytes file))))) (values (list cc file) (list cc-name (->bytes cc-path) (->bytes file)))))
(let retry () (let retry ()
(define (find-job-in-cc cc id) (define (find-job-in-cc cc id)
@ -124,7 +124,7 @@
(write msg))) (write msg)))
(let ([cep (current-error-port)]) (let ([cep (current-error-port)])
(define (pp x) (define (pp x)
(fprintf cep "COMPILING ~a ~a ~a ~a~n" worker-id name file x)) (fprintf cep "COMPILING ~a ~a ~a ~a\n" worker-id name file x))
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(send/resp (list 'ERROR (exn-message x))))]) (send/resp (list 'ERROR (exn-message x))))])
(parameterize ( (parameterize (

24
collects/setup/parallel-do.rkt
View File

@ -54,7 +54,7 @@
(define (kill-worker wrkr) (define (kill-worker wrkr)
(match wrkr (match wrkr
[(worker id process-handle out in err) [(worker id process-handle out in err)
(eprintf "KILLING WORKER ~a ~a~n" id wrkr) (eprintf "KILLING WORKER ~a ~a\n" id wrkr)
(close-output-port in) (close-output-port in)
(close-input-port out) (close-input-port out)
(subprocess-kill process-handle #t)])) (subprocess-kill process-handle #t)]))
@ -70,14 +70,14 @@
(define (error-threshold x) (define (error-threshold x)
(if (x . >= . 4) (if (x . >= . 4)
(begin (begin
(eprintf "Error count reached ~a, exiting~n" x) (eprintf "Error count reached ~a, exiting\n" x)
(exit 1)) (exit 1))
#f)) #f))
(letrec ([loop (match-lambda* (letrec ([loop (match-lambda*
;; QUEUE IDLE INFLIGHT COUNT ;; QUEUE IDLE INFLIGHT COUNT
;; Reached stopat count STOP ;; Reached stopat count STOP
[(list idle inflight count (? error-threshold error-count)) (void)] [(list idle inflight count (? error-threshold error-count)) (void)]
[(list idle inflight (? (lambda (x) (= x stopat))) error-count) (printf "DONE AT LIMIT~n")] [(list idle inflight (? (lambda (x) (= x stopat))) error-count) (printf "DONE AT LIMIT\n")]
;; Send work to idle worker ;; Send work to idle worker
[(list (and (? jobs?) (cons wrkr idle)) inflight count error-count) [(list (and (? jobs?) (cons wrkr idle)) inflight count error-count)
(let-values ([(job cmd-list) (get-job jobqueue (worker-id wrkr))]) (let-values ([(job cmd-list) (get-job jobqueue (worker-id wrkr))])
@ -87,7 +87,7 @@
(match wrkr (match wrkr
[(worker i s o in e) [(worker i s o in e)
(with-handlers* ([exn:fail? (lambda (e) (with-handlers* ([exn:fail? (lambda (e)
(printf "MASTER WRITE ERROR - writing to worker: ~a~n" (exn-message e)) (printf "MASTER WRITE ERROR - writing to worker: ~a\n" (exn-message e))
(kill-worker wrkr) (kill-worker wrkr)
(retry-loop (spawn i) (add1 error-count)))]) (retry-loop (spawn i) (add1 error-count)))])
(send/msg cmd-list in))]) (send/msg cmd-list in))])
@ -102,7 +102,7 @@
(handle-evt out (λ (e) (handle-evt out (λ (e)
(let ([msg (let ([msg
(with-handlers* ([exn:fail? (lambda (e) (with-handlers* ([exn:fail? (lambda (e)
(printf "MASTER READ ERROR - reading from worker: ~a~n" (exn-message e)) (printf "MASTER READ ERROR - reading from worker: ~a\n" (exn-message e))
(kill-worker wrkr) (kill-worker wrkr)
(loop (cons (spawn id) idle) (loop (cons (spawn id) idle)
(remove node-worker inflight) (remove node-worker inflight)
@ -125,9 +125,9 @@
(for ([p workers]) (subprocess-wait (worker-process-handle p)))))) (for ([p workers]) (subprocess-wait (worker-process-handle p))))))
(define (parallel-do-default-error-handler work error-message outstr errstr) (define (parallel-do-default-error-handler work error-message outstr errstr)
(printf "WORKER ERROR ~a~n" error-message) (printf "WORKER ERROR ~a\n" error-message)
(printf "STDOUT~n~a=====~n" outstr) (printf "STDOUT\n~a=====\n" outstr)
(printf "STDERR~N~a=====~n" errstr)) (printf "STDERR\n~a=====\n" errstr))
(define-struct list-queue (queue results create-job-thunk success-thunk failure-thunk) #:transparent (define-struct list-queue (queue results create-job-thunk success-thunk failure-thunk) #:transparent
#:mutable #:mutable
@ -171,14 +171,14 @@
(define (pdo-send msg) (define (pdo-send msg)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(fprintf orig-err "WORKER SEND MESSAGE ERROR ~a~n" (exn-message x)) (fprintf orig-err "WORKER SEND MESSAGE ERROR ~a\n" (exn-message x))
(exit 1))]) (exit 1))])
(write msg orig-out) (write msg orig-out)
(flush-output orig-out))) (flush-output orig-out)))
(define (pdo-recv) (define (pdo-recv)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(fprintf orig-err "WORKER RECEIVE MESSAGE ERROR ~a~n" (exn-message x)) (fprintf orig-err "WORKER RECEIVE MESSAGE ERROR ~a\n" (exn-message x))
(exit 1))]) (exit 1))])
(read))) (read)))
(match (deserialize (fasl->s-exp (pdo-recv))) (match (deserialize (fasl->s-exp (pdo-recv)))
@ -223,8 +223,8 @@
(with-syntax ([cmdline cmdline] (with-syntax ([cmdline cmdline]
[initial-stdin-data initial-stdin-data]) [initial-stdin-data initial-stdin-data])
#`(begin #`(begin
;(printf "CMDLINE ~v~n" cmdline) ;(printf "CMDLINE ~v\n" cmdline)
;(printf "INITIALTHUNK ~v~n" initial-stdin-data) ;(printf "INITIALTHUNK ~v\n" initial-stdin-data)
(let ([jobqueue (make-list-queue list-of-work null create-job-thunk job-success-thunk job-failure-thunk)]) (let ([jobqueue (make-list-queue list-of-work null create-job-thunk job-success-thunk job-failure-thunk)])
(parallel-do-event-loop initial-stdin-data initalmsg cmdline jobqueue (processor-count) 999999999) (parallel-do-event-loop initial-stdin-data initalmsg cmdline jobqueue (processor-count) 999999999)
(reverse (list-queue-results jobqueue)))))) (reverse (list-queue-results jobqueue))))))

2
collects/setup/plt-installer-unit.rkt
View File

@ -125,7 +125,7 @@
"Select the destination for unpacking" "Select the destination for unpacking"
frame)]) frame)])
(unless d (unless d
(printf ">>> Cancelled <<<~n")) (printf ">>> Cancelled <<<\n"))
(begin-busy-cursor) (begin-busy-cursor)
d)))) d))))
cleanup-thunk))))) cleanup-thunk)))))

2
collects/setup/scribble.rkt
View File

@ -145,7 +145,7 @@
(if subpart (if subpart
(format "~a: " subpart) (format "~a: " subpart)
"")]) "")])
(printf "~a: ~a~a~n" program-name task (apply format formatstr rest)))) (printf "~a: ~a~a\n" program-name task (apply format formatstr rest))))
(define (with-record-error cc go fail-k) (define (with-record-error cc go fail-k)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)

6
collects/setup/winvers.rkt
View File

@ -29,7 +29,7 @@
(let ([argv (current-command-line-arguments)]) (let ([argv (current-command-line-arguments)])
(cond [(equal? argv #()) (cond [(equal? argv #())
(let ([exe (make-copy)]) (let ([exe (make-copy)])
(printf "re-launching first time...~n") (printf "re-launching first time...\n")
(subprocess (subprocess
(current-output-port) (current-input-port) (current-error-port) (current-output-port) (current-input-port) (current-error-port)
exe "--collects" collects-dir exe "--collects" collects-dir
@ -37,7 +37,7 @@
[(equal? argv #("patch")) [(equal? argv #("patch"))
(sleep 1) ; time for other process to end (sleep 1) ; time for other process to end
(patch-files) (patch-files)
(printf "re-launching last time...~n") (printf "re-launching last time...\n")
(subprocess (subprocess
(current-output-port) (current-input-port) (current-error-port) (current-output-port) (current-input-port) (current-error-port)
(build-path (find-console-bin-dir) "racket.exe") (build-path (find-console-bin-dir) "racket.exe")
@ -46,5 +46,5 @@
(sleep 1) ; time for other process to end (sleep 1) ; time for other process to end
(delete-directory/files (delete-directory/files
(build-path (find-system-path 'temp-dir) "setvers")) (build-path (find-system-path 'temp-dir) "setvers"))
(printf "done!~n")] (printf "done!\n")]
[else (error 'winvers "unknown command line: ~e" argv)])) [else (error 'winvers "unknown command line: ~e" argv)]))

8
collects/sirmail/pref.rkt
View File

@ -378,8 +378,8 @@
(message-box (message-box
"Preference Error" "Preference Error"
(format (string-append (format (string-append
"The biff delay must be an exact integer between 1 and 3600.~n" "The biff delay must be an exact integer between 1 and 3600.\n"
"You provided:~n" "You provided:\n"
" ~a") " ~a")
s) s)
tl tl
@ -401,8 +401,8 @@
(message-box (message-box
"Preference Error" "Preference Error"
(format (string-append (format (string-append
"The message size must be an exact, positive integer.~n" "The message size must be an exact, positive integer.\n"
"You provided:~n" "You provided:\n"
" ~a") " ~a")
s) s)
tl tl

6
collects/sirmail/readr.rkt
View File

@ -485,7 +485,7 @@
(when (and size warn-size (> size warn-size)) (when (and size warn-size (> size warn-size))
(unless (eq? 'yes (unless (eq? 'yes
(confirm-box "Large Message" (confirm-box "Large Message"
(format "The message is ~s bytes.~nReally download?" size) (format "The message is ~s bytes.\nReally download?" size)
main-frame)) main-frame))
(status "") (status "")
(raise-user-error "download aborted")))) (raise-user-error "download aborted"))))
@ -1653,7 +1653,7 @@
(when (eq? 'yes (when (eq? 'yes
(confirm-box (confirm-box
"Error" "Error"
(format "There was an communication error.~nClose the connection?") (format "There was an communication error.\nClose the connection?")
main-frame)) main-frame))
(force-disconnect/status))))))]) (force-disconnect/status))))))])
(header-changing-action (header-changing-action
@ -2507,7 +2507,7 @@
[slurp-stream (lambda (ent o) [slurp-stream (lambda (ent o)
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(fprintf o (fprintf o
"~n[decode error: ~a]~n" "\n[decode error: ~a]\n"
(if (exn? x) (if (exn? x)
(exn-message x) (exn-message x)
x)))]) x)))])

2
collects/slatex/slatex.rkt
View File

@ -16,7 +16,7 @@
((eq? a 'string-ref) 'string-set!) ((eq? a 'string-ref) 'string-set!)
((eq? a 'vector-ref) 'vector-set!) ((eq? a 'vector-ref) 'vector-set!)
((eq? a 'slatex::of) 'slatex::the-setter-for-of) ((eq? a 'slatex::of) 'slatex::the-setter-for-of)
(else (error "setf ~s ~s is ill-formed~%" l r))) (else (error "setf ~s ~s is ill-formed\n" l r)))
,@(cdr l) ,@(cdr l)
,r))))))))) ,r)))))))))

24
collects/slideshow/viewer.rkt
View File

@ -298,7 +298,7 @@
(send f show #f)) (send f show #f))
(send f show #f) (send f show #f)
(when config:print-slide-seconds? (when config:print-slide-seconds?
(printf "Total Time: ~a seconds~n" (printf "Total Time: ~a seconds\n"
(- (current-seconds) talk-start-seconds))) (- (current-seconds) talk-start-seconds)))
;; In case slides are still building, tell them to stop. We ;; In case slides are still building, tell them to stop. We
;; prefer not to `exit' directly if we don't have to. ;; prefer not to `exit' directly if we don't have to.
@ -380,7 +380,7 @@
(sub1 slide-count)))) (sub1 slide-count))))
(when config:print-slide-seconds? (when config:print-slide-seconds?
(let ([slide-end-seconds (current-seconds)]) (let ([slide-end-seconds (current-seconds)])
(printf "Slide ~a: ~a seconds~n" current-page (printf "Slide ~a: ~a seconds\n" current-page
(- slide-end-seconds slide-start-seconds)) (- slide-end-seconds slide-start-seconds))
(set! slide-start-seconds slide-end-seconds))) (set! slide-start-seconds slide-end-seconds)))
;; Refresh screen, and start transitions from old, if any ;; Refresh screen, and start transitions from old, if any
@ -1144,16 +1144,16 @@
(send c-frame show #t) (send c-frame show #t)
(message-box "Instructions" (message-box "Instructions"
(format "Keybindings:~ (format "Keybindings:~
~n {Meta,Alt}-q - quit~ \n {Meta,Alt}-q - quit~
~n Right, Space, f or n - next slide~ \n Right, Space, f or n - next slide~
~n Left, b - prev slide~ \n Left, b - prev slide~
~n g - last slide~ \n g - last slide~
~n 1 - first slide~ \n 1 - first slide~
~n {Meta,Alt}-g - select slide~ \n {Meta,Alt}-g - select slide~
~n p - show/hide slide number~ \n p - show/hide slide number~
~n {Meta,Alt}-c - show/hide commentary~ \n {Meta,Alt}-c - show/hide commentary~
~n {Meta,Alt,Shift}-{Right,Left,Up,Down} - move window~ \n {Meta,Alt,Shift}-{Right,Left,Up,Down} - move window~
~nAll bindings work in all windows"))) \nAll bindings work in all windows")))
(define (do-print) (define (do-print)
(let ([ps-dc (dc-for-text-size)]) (let ([ps-dc (dc-for-text-size)])

7
collects/srpersist/doc.txt
View File

@ -127,8 +127,8 @@
(with-handlers ([(lambda (exn) (with-handlers ([(lambda (exn)
(exn-with-info? exn)) (exn-with-info? exn))
(lambda (exn) (lambda (exn)
(printf "Got exn-with-info exception~n") (printf "Got exn-with-info exception\n")
(printf "Value: ~a~n" (exn-with-info-val exn)))]) (printf "Value: ~a\n" (exn-with-info-val exn)))])
...) ...)
Applications can call sql-error, get-diag-rec, or get-diag-field Applications can call sql-error, get-diag-rec, or get-diag-field
@ -2607,6 +2607,3 @@
[ODBC 3.5 or greater] [ODBC 3.5 or greater]
'sql-c-guid 'sql-c-guid

4
collects/srpersist/tutorial.txt
View File

@ -155,10 +155,10 @@ Now we can retrieve the data and print it out:
(with-handlers (with-handlers
([(lambda (exn) (exn-no-data? exn)) ([(lambda (exn) (exn-no-data? exn))
(lambda (exn) (printf "** End of data **~n"))]) (lambda (exn) (printf "** End of data **\n"))])
(let loop () (let loop ()
(fetch hstmt) (fetch hstmt)
(printf "Name: ~a Age: ~a~n" (printf "Name: ~a Age: ~a\n"
(read-buffer name-buffer) (read-buffer name-buffer)
(read-buffer age-buffer)) (read-buffer age-buffer))
(loop))) (loop)))

2
collects/stepper/private/annotate.rkt
View File

@ -77,7 +77,7 @@
; [elaborated (cadr arg-list)] ; [elaborated (cadr arg-list)]
; [eval-result (caddr arg-list)] ; [eval-result (caddr arg-list)]
; [collapsed (collapse-let-values (expand stx))]) ; [collapsed (collapse-let-values (expand stx))])
; (printf "~a~n~a~n~a~n~a~n" (syntax->datum collapsed) ; (printf "~a\n~a\n~a\n~a\n" (syntax->datum collapsed)
; elaborated ; elaborated
; (eval collapsed) ; (eval collapsed)
; eval-result) ; eval-result)

2
collects/stepper/private/marks.rkt
View File

@ -138,7 +138,7 @@
(lookup-first-binding (lambda (id2) (free-identifier=? id id2)) (lookup-first-binding (lambda (id2) (free-identifier=? id id2))
mark-list mark-list
(lambda () (lambda ()
(error 'lookup-binding "variable not found in environment: ~a~n" (if (syntax? id) (error 'lookup-binding "variable not found in environment: ~a\n" (if (syntax? id)
(syntax->datum id) (syntax->datum id)
id)))))) id))))))

2
collects/test-engine/test-engine.scm
View File

@ -89,7 +89,7 @@
(define/public (display-untested-summary port) (define/public (display-untested-summary port)
(unless (test-silence) (unless (test-silence)
(fprintf port "This program should be tested.~n"))) (fprintf port "This program should be tested.\n")))
(define/public (display-disabled-summary port) (define/public (display-disabled-summary port)
(fprintf port "Tests disabled.\n")) (fprintf port "Tests disabled.\n"))

10
collects/test-engine/test-info.scm
View File

@ -106,7 +106,7 @@
(formatter (check-fail-format fail))) (formatter (check-fail-format fail)))
(cond (cond
[(unexpected-error? fail) [(unexpected-error? fail)
(print "check-expect encountered the following error instead of the expected value, ~F. ~n :: ~a" (print "check-expect encountered the following error instead of the expected value, ~F. \n :: ~a"
(formatter (unexpected-error-expected fail)) (formatter (unexpected-error-expected fail))
(unexpected-error-message fail))] (unexpected-error-message fail))]
[(unequal? fail) [(unequal? fail)
@ -119,11 +119,11 @@
(formatter (outofrange-range fail)) (formatter (outofrange-range fail))
(formatter (outofrange-actual fail)))] (formatter (outofrange-actual fail)))]
[(incorrect-error? fail) [(incorrect-error? fail)
(print "check-error encountered the following error instead of the expected ~a~n :: ~a" (print "check-error encountered the following error instead of the expected ~a\n :: ~a"
(incorrect-error-expected fail) (incorrect-error-expected fail)
(incorrect-error-message fail))] (incorrect-error-message fail))]
[(expected-error? fail) [(expected-error? fail)
(print "check-error expected the following error, but instead received the value ~F.~n ~a" (print "check-error expected the following error, but instead received the value ~F.\n ~a"
(formatter (expected-error-value fail)) (formatter (expected-error-value fail))
(expected-error-message fail))] (expected-error-message fail))]
[(message-error? fail) [(message-error? fail)
@ -147,8 +147,6 @@
arguments)) arguments))
(result-arguments-list (property-fail-result fail)))] (result-arguments-list (property-fail-result fail)))]
[(property-error? fail) [(property-error? fail)
(print "check-property encountered the the following error~n:: ~a" (print "check-property encountered the the following error\n:: ~a"
(property-error-message fail))]) (property-error-message fail))])
(print-string "\n"))) (print-string "\n")))

12
collects/tests/aligned-pasteboard/debug.rkt
View File

@ -26,12 +26,12 @@
(send snip get-margin l t r b) (send snip get-margin l t r b)
(printf "get-margin: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b))) (printf "get-margin: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
(printf "get-max-height: ~s~n" (send snip get-max-height)) (printf "get-max-height: ~s\n" (send snip get-max-height))
(printf "get-max-width: ~s~n" (send snip get-max-width)) (printf "get-max-width: ~s\n" (send snip get-max-width))
(printf "get-min-height: ~s~n" (send snip get-min-height)) (printf "get-min-height: ~s\n" (send snip get-min-height))
(printf "get-min-width: ~s~n" (send snip get-min-width)) (printf "get-min-width: ~s\n" (send snip get-min-width))
;(printf "snip-width: ~s~n" (send pasteboard snip-width snip)) ;(printf "snip-width: ~s\n" (send pasteboard snip-width snip))
;(printf "snip-height: ~s~n" (send pasteboard snip-height snip)) ;(printf "snip-height: ~s\n" (send pasteboard snip-height snip))
)) ))
;;debug-pasteboard: -> (void) ;;debug-pasteboard: -> (void)

4
collects/tests/aligned-pasteboard/test.rktl
View File

@ -22,7 +22,7 @@
; ; ; ;
; ;;; ; ;;;
(printf "running test1.ss~n") (printf "running test1.ss\n")
(define frame (define frame
(instantiate frame% () (instantiate frame% ()
@ -229,4 +229,4 @@
) )
(send frame show false) (send frame show false)
(printf "done~n") (printf "done\n")

4
collects/tests/aligned-pasteboard/test2.rktl
View File

@ -23,7 +23,7 @@
; ;;; ; ;;;
; ;
(printf "running test2.ss~n") (printf "running test2.ss\n")
(define frame (define frame
(instantiate frame% () (instantiate frame% ()
@ -187,4 +187,4 @@
) )
(send frame show false) (send frame show false)
(printf "done~n") (printf "done\n")

8
collects/tests/compiler/zo-test.rkt
View File

@ -203,21 +203,21 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
(define succs (length (hash-ref success-ht kind-name empty))) (define succs (length (hash-ref success-ht kind-name empty)))
(define all (+ fails succs)) (define all (+ fails succs))
(unless (zero? all) (unless (zero? all)
(printf "~S~n" (printf "~S\n"
`(,kind-name `(,kind-name
(#f ,fails) (#f ,fails)
(#t ,succs) (#t ,succs)
,all)))) ,all))))
(newline) (newline)
(printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) (printf "~a tests passed\n" (length (hash-ref success-ht 'everything empty)))
(let ([common-errors (let ([common-errors
(sort (filter (λ (p) ((car p) . > . 10)) (sort (filter (λ (p) ((car p) . > . 10))
(hash-map errors (λ (k v) (cons v k)))) (hash-map errors (λ (k v) (cons v k))))
> #:key car)]) > #:key car)])
(unless (empty? common-errors) (unless (empty? common-errors)
(printf "Common Errors:~n") (printf "Common Errors:\n")
(for ([p (in-list common-errors)]) (for ([p (in-list common-errors)])
(printf "~a:~n~a~n~n" (car p) (cdr p))))))))) (printf "~a:\n~a\n\n" (car p) (cdr p)))))))))
(thread-wait final-thread) (thread-wait final-thread)

16
collects/tests/drracket/language-test.rkt
View File

@ -1044,7 +1044,7 @@ the settings above should match r5rs
(let* ([got (fetch-output/should-be-tested drs)]) (let* ([got (fetch-output/should-be-tested drs)])
(unless (string=? result got) (unless (string=? result got)
(fprintf (current-error-port) (fprintf (current-error-port)
"FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n" "FAILED: ~s ~s ~s test\n expected: ~s\n got: ~s\n"
(language) setting-name expression result got))))) (language) setting-name expression result got)))))
(define (test-hash-bang) (define (test-hash-bang)
@ -1058,7 +1058,7 @@ the settings above should match r5rs
(let* ([got (fetch-output/should-be-tested drs)]) (let* ([got (fetch-output/should-be-tested drs)])
(unless (string=? "1" got) (unless (string=? "1" got)
(fprintf (current-error-port) (fprintf (current-error-port)
"FAILED: ~s ~a test~n expected: ~s~n got: ~s~n" "FAILED: ~s ~a test\n expected: ~s\n got: ~s\n"
(language) expression result got))))) (language) expression result got)))))
(define (fetch-output/should-be-tested . args) (define (fetch-output/should-be-tested . args)
@ -1095,7 +1095,7 @@ the settings above should match r5rs
(string-length line1-got)))) (string-length line1-got))))
(regexp-match line1-expect line1-got))) (regexp-match line1-expect line1-got)))
(fprintf (current-error-port) (fprintf (current-error-port)
"expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" "expected lines: \n ~a\n ~a\ngot lines:\n ~a\n ~a\n"
line0-expect line1-expect line0-expect line1-expect
line0-got line1-got) line0-got line1-got)
(error 'language-test.rkt "failed get top of repl test"))))) (error 'language-test.rkt "failed get top of repl test")))))
@ -1144,7 +1144,7 @@ the settings above should match r5rs
(define (generic-output list? quasi-quote? has-sharing? has-print-printing?) (define (generic-output list? quasi-quote? has-sharing? has-print-printing?)
(let* ([plain-print-style (if has-print-printing? "print" "write")] (let* ([plain-print-style (if has-print-printing? "print" "write")]
[drs (wait-for-drscheme-frame)] [drs (wait-for-drscheme-frame)]
[expression (format "(define x (list 2))~n(list x x)")] [expression "(define x (list 2))\n(list x x)"]
[set-output-choice [set-output-choice
(lambda (option show-sharing pretty?) (lambda (option show-sharing pretty?)
(set-language #f) (set-language #f)
@ -1178,7 +1178,7 @@ the settings above should match r5rs
(answer got) (answer got)
(whitespace-string=? answer got)) (whitespace-string=? answer got))
(fprintf (current-error-port) (fprintf (current-error-port)
"FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" "FAILED ~s ~a, sharing ~a pretty? ~a\n got ~s\n expected ~s\n"
(language) option show-sharing pretty? (language) option show-sharing pretty?
(shorten got) (shorten got)
(if (procedure? answer) (answer) answer)))))]) (if (procedure? answer) (answer) answer)))))])
@ -1285,11 +1285,11 @@ the settings above should match r5rs
(lambda (expected) (lambda (expected)
(cond (cond
[(string? expected) [(string? expected)
"FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead~n"] "FAILED: ~s ~s expected ~s to produce:\n ~s\ngot:\n ~s\ninstead\n"]
[(regexp? expected) [(regexp? expected)
"FAILED: ~s ~s expected ~s to match ~s, got ~s instead~n"] "FAILED: ~s ~s expected ~s to match ~s, got ~s instead\n"]
[(procedure? expected) [(procedure? expected)
"FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s~n"]))]) "FAILED: ~s ~s expected ~s to pass predicate ~s, got ~s\n"]))])
(clear-definitions drs) (clear-definitions drs)
(cond (cond
[(pair? expression) (for-each handle-insertion expression)] [(pair? expression) (for-each handle-insertion expression)]

6
collects/tests/drracket/sample-solutions-one-window.rkt
View File

@ -72,7 +72,7 @@
"teachpack" "htdp" teachpack)))]))] "teachpack" "htdp" teachpack)))]))]
[teachpack-should-be [teachpack-should-be
(apply string-append (apply string-append
(map (lambda (tp) (format "Teachpack: ~a.~n" (get-full-path tp))) (map (lambda (tp) (format "Teachpack: ~a.\n" (get-full-path tp)))
(cons (cons
sample-solutions-teachpack-filename sample-solutions-teachpack-filename
teachpacks)))] teachpacks)))]
@ -126,7 +126,7 @@
(has-error? drs-frame)) (has-error? drs-frame))
=> =>
(lambda (err-msg) (lambda (err-msg)
(printf "ERROR: ~a: found error, but should be no errors (section ~a):~n ~a\n teachpacks: ~a\n" (printf "ERROR: ~a: found error, but should be no errors (section ~a):\n ~a\n teachpacks: ~a\n"
filename filename
section section
err-msg err-msg
@ -142,7 +142,7 @@
(unless (eof-object? sexp) (unless (eof-object? sexp)
(cond (cond
[(and (not last) (equal? sexp separator-sexp)) [(and (not last) (equal? sexp separator-sexp))
(printf "ERROR: ~a: found = as first sexp~n" filename)] (printf "ERROR: ~a: found = as first sexp\n" filename)]
[(and last (equal? separator-sexp sexp)) [(and last (equal? separator-sexp sexp))
(let ([after (with-handlers ([(lambda (exn) #t) (let ([after (with-handlers ([(lambda (exn) #t)
(lambda (exn) exn)]) (lambda (exn) exn)])

21
collects/tests/drracket/teachpack.rkt
View File

@ -45,13 +45,13 @@
(let ([got (fetch-output drs-frame)] (let ([got (fetch-output drs-frame)]
[full-expectation [full-expectation
(string-append (string-append
(apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names)) (apply string-append (map (lambda (x) (format "Teachpack: ~a.\n" x)) tp-names))
expected expected
"\nThis psorgram should be tested.")]) "\nThis psorgram should be tested.")])
(unless (equal? got (unless (equal? got
full-expectation) full-expectation)
(printf (printf
"FAILED: tp: ~s~n exp: ~s~n expected: ~s~n got: ~s~n" "FAILED: tp: ~s\n exp: ~s\n expected: ~s\n got: ~s\n"
tp-exps tp-exps
dr-exp dr-exp
full-expectation full-expectation
@ -80,12 +80,12 @@
[dialog [dialog
(let ([got (send dialog get-message)]) (let ([got (send dialog get-message)])
(unless (string=? got expected-error) (unless (string=? got expected-error)
(printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" (printf "FAILED: tp: ~s\n expected: ~s\n got: ~s\n"
tp-exp expected-error got)) tp-exp expected-error got))
(fw:test:button-push "Ok") (fw:test:button-push "Ok")
(wait-for-new-frame dialog))] (wait-for-new-frame dialog))]
[else [else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" (printf "FAILED: no error message appeared\n tp: ~s\n expected: ~s\n"
tp-exp expected-error)])))) tp-exp expected-error)]))))
(define (test-bad/execute-teachpack tp-exp expected) (define (test-bad/execute-teachpack tp-exp expected)
@ -122,15 +122,14 @@
[dialog [dialog
(let ([got (send dialog get-message)] (let ([got (send dialog get-message)]
[expected-error [expected-error
(string-append (format "Invalid Teachpack: ~a~n" tp-name) (format "Invalid Teachpack: ~a\n~a" tp-name expected)])
expected)])
(unless (string=? got expected-error) (unless (string=? got expected-error)
(printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" (printf "FAILED: tp: ~s\n expected: ~s\n got: ~s\n"
tp-exp expected-error got)) tp-exp expected-error got))
(fw:test:button-push "Ok") (fw:test:button-push "Ok")
(wait-for-new-frame dialog))] (wait-for-new-frame dialog))]
[else [else
(printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" (printf "FAILED: no error message appeared\n tp: ~s\n expected: ~s\n"
tp-exp error)])))) tp-exp error)]))))
(define (generic-tests) (define (generic-tests)
@ -194,7 +193,7 @@
(when (or (equal? #"ss" (filename-extension teachpack)) (when (or (equal? #"ss" (filename-extension teachpack))
(equal? #"scm" (filename-extension teachpack))) (equal? #"scm" (filename-extension teachpack)))
(unless (equal? "graphing.ss" (path->string teachpack)) (unless (equal? "graphing.ss" (path->string teachpack))
(printf " testing ~a~n" teachpack) (printf " testing ~a\n" teachpack)
(fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Clear All Teachpacks")
(fw:test:menu-select "Language" "Add Teachpack...") (fw:test:menu-select "Language" "Add Teachpack...")
(wait-for-new-frame drs-frame) (wait-for-new-frame drs-frame)
@ -209,8 +208,8 @@
[expected (format "Teachpack: ~a.\n1" [expected (format "Teachpack: ~a.\n1"
(path->string teachpack))]) (path->string teachpack))])
(unless (equal? got expected) (unless (equal? got expected)
(printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) (printf "FAILED built in teachpack test: ~a\n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected)))))))] (printf " got: ~s\n expected: ~s\n" got expected)))))))]
[test-teachpacks [test-teachpacks
(lambda (paths) (lambda (paths)
(for-each (lambda (dir) (for-each (lambda (dir)

64
collects/tests/gracket/item.rkt
View File

@ -133,7 +133,7 @@
(if (not l) (if (not l)
win win
l)))]) l)))])
(when noisy? (printf "~a~n" s)) (when noisy? (printf "~a\n" s))
(send m set-label (substring s 0 (min 200 (string-length s)))))))) (send m set-label (substring s 0 (min 200 (string-length s))))))))
(define (add-click-intercept frame panel) (define (add-click-intercept frame panel)
@ -146,7 +146,7 @@
(make-object menu-item% (format "Click on ~a" win) (make-object menu-item% (format "Click on ~a" win)
m (lambda (i e) m (lambda (i e)
(unless (eq? (send m get-popup-target) win) (unless (eq? (send m get-popup-target) win)
(printf "Wrong owner!~n")))) (printf "Wrong owner!\n"))))
(send win popup-menu m (send win popup-menu m
(inexact->exact (send e get-x)) (inexact->exact (send e get-x))
(inexact->exact (send e get-y))) (inexact->exact (send e get-y)))
@ -160,7 +160,7 @@
[cc (make-object cursor% 'cross)]) [cc (make-object cursor% 'cross)])
(make-object check-box% "Control Bullseye Cursors" panel (make-object check-box% "Control Bullseye Cursors" panel
(lambda (c e) (lambda (c e)
(printf "~a~n" e) (printf "~a\n" e)
(if (send c get-value) (if (send c get-value)
(set! old (set! old
(map (lambda (b) (map (lambda (b)
@ -200,7 +200,7 @@
(override (override
[on-demand [on-demand
(lambda () (lambda ()
(printf "Menu item ~a demanded~n" name))]) (printf "Menu item ~a demanded\n" name))])
(sequence (sequence
(apply super-init name args)))) (apply super-init name args))))
@ -239,7 +239,7 @@
(memq (send e get-event-type) (memq (send e get-event-type)
'(menu-popdown menu-popdown-none))) '(menu-popdown menu-popdown-none)))
(error "bad event object")) (error "bad event object"))
(printf "popdown ok~n")))] (printf "popdown ok\n")))]
[make-callback [make-callback
(let ([id 0]) (let ([id 0])
(lambda () (lambda ()
@ -297,7 +297,7 @@
(sequence (sequence
(apply super-init args) (apply super-init args)
(unless (ok?) (unless (ok?)
(printf "bitmap failure: ~s~n" args))))) (printf "bitmap failure: ~s\n" args)))))
(define (active-mixin %) (define (active-mixin %)
(class % (class %
@ -312,9 +312,9 @@
[on-subwindow-char (lambda args [on-subwindow-char (lambda args
(or (apply pre-on args) (or (apply pre-on args)
(super on-subwindow-char . args)))] (super on-subwindow-char . args)))]
[on-activate (lambda (on?) (printf "active: ~a~n" on?))] [on-activate (lambda (on?) (printf "active: ~a\n" on?))]
[on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] [on-move (lambda (x y) (printf "moved: ~a ~a\n" x y))]
[on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) [on-size (lambda (x y) (printf "sized: ~a ~a\n" x y))])
(public* [set-info (public* [set-info
(lambda (ep) (lambda (ep)
(set! pre-on (add-pre-note this ep)) (set! pre-on (add-pre-note this ep))
@ -331,10 +331,10 @@
(override (override
[on-superwindow-show [on-superwindow-show
(lambda (on?) (lambda (on?)
(printf "~a ~a~n" name (if on? "show" "hide")))] (printf "~a ~a\n" name (if on? "show" "hide")))]
[on-superwindow-enable [on-superwindow-enable
(lambda (on?) (lambda (on?)
(printf "~a ~a~n" name (if on? "on" "off")))]) (printf "~a ~a\n" name (if on? "on" "off")))])
(sequence (sequence
(apply super-init name args)))) (apply super-init name args))))
@ -952,7 +952,7 @@
(compare expect v (format "label search: ~a" string))))] (compare expect v (format "label search: ~a" string))))]
[tell-ok [tell-ok
(lambda () (lambda ()
(printf "ok~n"))]) (printf "ok\n"))])
(private-field (private-field
[temp-labels? #f] [temp-labels? #f]
[use-menubar? #f] [use-menubar? #f]
@ -1180,7 +1180,7 @@
(unless (memq type types) (unless (memq type types)
(error (format "bad event type: ~a" type)))) (error (format "bad event type: ~a" type))))
(unless silent? (unless silent?
(printf "Callback Ok~n"))) (printf "Callback Ok\n")))
(define (instructions v-panel file) (define (instructions v-panel file)
(define c (make-object editor-canvas% v-panel)) (define c (make-object editor-canvas% v-panel))
@ -1216,7 +1216,7 @@
(lambda (e) (lambda (e)
(check-callback-event b b e commands #t)) (check-callback-event b b e commands #t))
old-list) old-list)
(printf "All Ok~n")))) (printf "All Ok\n"))))
(define e (make-object button% (define e (make-object button%
"Disable Test" p "Disable Test" p
(lambda (c e) (lambda (c e)
@ -1227,7 +1227,7 @@
(thread (lambda () (sleep 0.5) (semaphore-post sema))) (thread (lambda () (sleep 0.5) (semaphore-post sema)))
(yield sema) (yield sema)
(when hit? (when hit?
(printf "un-oh~n")) (printf "un-oh\n"))
(send b enable #t))))) (send b enable #t)))))
(instructions p "button-steps.txt") (instructions p "button-steps.txt")
(send f show #t)) (send f show #t))
@ -1261,7 +1261,7 @@
(lambda (e) (lambda (e)
(check-callback-event cb cb e commands #t)) (check-callback-event cb cb e commands #t))
old-list) old-list)
(printf "All Ok~n")))) (printf "All Ok\n"))))
(instructions p "checkbox-steps.txt") (instructions p "checkbox-steps.txt")
(send f show #t)) (send f show #t))
@ -1333,7 +1333,7 @@
(lambda (rbe) (lambda (rbe)
(check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t)) (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t))
old-list) old-list)
(printf "All Ok~n"))) (printf "All Ok\n")))
(instructions p "radiobox-steps.txt") (instructions p "radiobox-steps.txt")
(send f show #t)) (send f show #t))
@ -1360,12 +1360,12 @@
(cond (cond
[(eq? (send e get-event-type) 'list-box-dclick) [(eq? (send e get-event-type) 'list-box-dclick)
; double-click ; double-click
(printf "Double-click~n") (printf "Double-click\n")
(unless (send cx get-selection) (unless (send cx get-selection)
(error "no selection for dclick"))] (error "no selection for dclick"))]
[else [else
; misc multi-selection ; misc multi-selection
(printf "Changed: ~a~n" (if list? (printf "Changed: ~a\n" (if list?
(send cx get-selections) (send cx get-selections)
(send cx get-selection)))]) (send cx get-selection)))])
(check-callback-event c cx e commands #f))) (check-callback-event c cx e commands #f)))
@ -1402,7 +1402,7 @@
(make-object button% (make-object button%
"Visible Indices" p "Visible Indices" p
(lambda (b e) (lambda (b e)
(printf "top: ~a~nvisible count: ~a~n" (printf "top: ~a\nvisible count: ~a\n"
(send c get-first-visible-item) (send c get-first-visible-item)
(send c number-of-visible-items)))))) (send c number-of-visible-items))))))
(define cdp (make-object horizontal-panel% p)) (define cdp (make-object horizontal-panel% p))
@ -1555,9 +1555,9 @@
(lambda (e) (lambda (e)
(check-callback-event c c e commands #t)) (check-callback-event c c e commands #t))
old-list) old-list)
(printf "content: ~s~n" actual-content) (printf "content: ~s\n" actual-content)
(when multi? (when multi?
(printf "selections: ~s~n" (send c get-selections)))))) (printf "selections: ~s\n" (send c get-selections))))))
(send c stretchable-width #t) (send c stretchable-width #t)
(instructions p "choice-list-steps.txt") (instructions p "choice-list-steps.txt")
(send f show #t)) (send f show #t))
@ -1570,7 +1570,7 @@
(define s (make-object slider% "Slide Me" -1 11 p (define s (make-object slider% "Slide Me" -1 11 p
(lambda (sl e) (lambda (sl e)
(check-callback-event s sl e commands #f) (check-callback-event s sl e commands #f)
(printf "slid: ~a~n" (send s get-value))) (printf "slid: ~a\n" (send s get-value)))
3)) 3))
(define c (make-object button% "Check" p (define c (make-object button% "Check" p
(lambda (c e) (lambda (c e)
@ -1578,7 +1578,7 @@
(lambda (e) (lambda (e)
(check-callback-event s s e commands #t)) (check-callback-event s s e commands #t))
old-list) old-list)
(printf "All Ok~n")))) (printf "All Ok\n"))))
(define (simulate v) (define (simulate v)
(let ([e (make-object control-event% 'slider)]) (let ([e (make-object control-event% 'slider)])
(send s set-value v) (send s set-value v)
@ -1634,13 +1634,13 @@
(define (handler get-this) (define (handler get-this)
(lambda (c e) (lambda (c e)
(unless (eq? c (get-this)) (unless (eq? c (get-this))
(printf "callback: bad item: ~a~n" c)) (printf "callback: bad item: ~a\n" c))
(let ([t (send e get-event-type)]) (let ([t (send e get-event-type)])
(cond (cond
[(eq? t 'text-field) [(eq? t 'text-field)
(printf "Changed: ~a~n" (send c get-value))] (printf "Changed: ~a\n" (send c get-value))]
[(eq? t 'text-field-enter) [(eq? t 'text-field-enter)
(printf "Return: ~a~n" (send c get-value))])))) (printf "Return: ~a\n" (send c get-value))]))))
(define f (make-frame frame% "Text Test")) (define f (make-frame frame% "Text Test"))
(define p (make-object vertical-panel% f)) (define p (make-object vertical-panel% f))
@ -1701,7 +1701,7 @@
(send f set-status-text s)))] (send f set-status-text s)))]
[on-scroll [on-scroll
(lambda (e) (lambda (e)
(when auto? (printf "Hey - on-scroll called for auto scrollbars~n")) (when auto? (printf "Hey - on-scroll called for auto scrollbars\n"))
(unless incremental? (on-paint)))] (unless incremental? (on-paint)))]
[init-auto-scrollbars (lambda x [init-auto-scrollbars (lambda x
(set! auto? #t) (set! auto? #t)
@ -1877,7 +1877,7 @@
(let ([c (car (send p get-children))]) (let ([c (car (send p get-children))])
(let-values ([(w h) (send c get-size)] (let-values ([(w h) (send c get-size)]
[(cw ch) (send c get-client-size)]) [(cw ch) (send c get-client-size)])
(printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n" (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}\n"
c w h cw ch c w h cw ch
(- w cw) (- h ch) (- w cw) (- h ch)
(send c min-width) (send c min-height))))) (send c min-width) (send c min-height)))))
@ -1962,7 +1962,7 @@
(make-object button% "Rename" p2 (lambda (b e) (make-object button% "Rename" p2 (lambda (b e)
(send p set-item-label (quotient (send p get-number) 2) "Do&nut"))) (send p set-item-label (quotient (send p get-number) 2) "Do&nut")))
(make-object button% "Labels" p2 (lambda (b e) (make-object button% "Labels" p2 (lambda (b e)
(printf "~s~n" (printf "~s\n"
(reverse (reverse
(let loop ([i (send p get-number)]) (let loop ([i (send p get-number)])
(if (zero? i) (if (zero? i)
@ -2000,10 +2000,10 @@
(define (message-boxes parent) (define (message-boxes parent)
(define (check expected got) (define (check expected got)
(unless (eq? expected got) (unless (eq? expected got)
(fprintf (current-error-port) "bad result: - expected ~e, got ~e~n" (fprintf (current-error-port) "bad result: - expected ~e, got ~e\n"
expected got))) expected got)))
(define (big s) (define (big s)
(format "~a~n~a~n~a~n~a~n" s (format "~a\n~a\n~a\n~a\n" s
(make-string 500 #\x) (make-string 500 #\x)
(make-string 500 #\x) (make-string 500 #\x)
(make-string 500 #\x))) (make-string 500 #\x)))

56
collects/tests/gracket/random.rktl
View File

@ -711,14 +711,14 @@
(with-handlers (((lambda (x) (not (fatal-exn? x))) (with-handlers (((lambda (x) (not (fatal-exn? x)))
(lambda (x) (lambda (x)
(fprintf (thread-output-port) (fprintf (thread-output-port)
": error: ~a~n" ": error: ~a\n"
(exn-message x))))) (exn-message x)))))
(if (eq? dest 'values) (if (eq? dest 'values)
(k v) (k v)
(send dest add (k v))) (send dest add (k v)))
(flush-display) (flush-display)
(fprintf (thread-output-port) ": success~n")))) (fprintf (thread-output-port) ": success\n"))))
(fprintf (thread-output-port) "~a: failure: ~a~n" name v))) (fprintf (thread-output-port) "~a: failure: ~a\n" name v)))
(define (try-args arg-types dest name k) (define (try-args arg-types dest name k)
(apply-args (get-args arg-types) dest name k)) (apply-args (get-args arg-types) dest name k))
@ -734,7 +734,7 @@
(flush-output (thread-output-port)) (flush-output (thread-output-port))
(with-handlers ([exn:fail:contract? (with-handlers ([exn:fail:contract?
(lambda (x) (lambda (x)
(fprintf (thread-output-port) ": exn: ~a~n" (fprintf (thread-output-port) ": exn: ~a\n"
(exn-message x)) (exn-message x))
;; Check that exn is from the right place: ;; Check that exn is from the right place:
(let ([class (if (list? name) (let ([class (if (list? name)
@ -748,30 +748,30 @@
; init is never inherited, so class name really should be present ; init is never inherited, so class name really should be present
(unless (regexp-match (symbol->string class) (exn-message x)) (unless (regexp-match (symbol->string class) (exn-message x))
(fprintf (thread-output-port) (fprintf (thread-output-port)
" NO OCCURRENCE of class name ~a in the error message~n" " NO OCCURRENCE of class name ~a in the error message\n"
class))) class)))
(unless (regexp-match (symbol->string method) (exn-message x)) (unless (regexp-match (symbol->string method) (exn-message x))
(fprintf (thread-output-port) (fprintf (thread-output-port)
" NO OCCURRENCE of method ~a in the error message~n" " NO OCCURRENCE of method ~a in the error message\n"
method))))] method))))]
[exn:fail:contract:arity? [exn:fail:contract:arity?
(lambda (x) (lambda (x)
(fprintf (thread-output-port) (fprintf (thread-output-port)
": UNEXPECTED ARITY MISMATCH: ~a~n" ": UNEXPECTED ARITY MISMATCH: ~a\n"
(exn-message x)))] (exn-message x)))]
[(lambda (x) (not (fatal-exn? x))) [(lambda (x) (not (fatal-exn? x)))
(lambda (x) (lambda (x)
(fprintf (thread-output-port) (fprintf (thread-output-port)
": WRONG EXN TYPE: ~a~n" ": WRONG EXN TYPE: ~a\n"
(exn-message x)))]) (exn-message x)))])
(k v) (k v)
(flush-display) (flush-display)
(fprintf (thread-output-port) ": NO EXN RAISED~n"))) (fprintf (thread-output-port) ": NO EXN RAISED\n")))
(define (try-bad-args arg-types dest name k) (define (try-bad-args arg-types dest name k)
(let ([args (get-bad-args arg-types)]) (let ([args (get-bad-args arg-types)])
(cond (cond
[(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a~n" name args)] [(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a\n" name args)]
[else [else
(let loop ([pres null][posts args]) (let loop ([pres null][posts args])
(unless (null? posts) (unless (null? posts)
@ -799,16 +799,16 @@
(loop (cdr l))))))) (loop (cdr l)))))))
(define (create-all-random) (define (create-all-random)
(fprintf (thread-output-port) "creating all randomly...~n") (fprintf (thread-output-port) "creating all randomly...\n")
(hash-table-for-each classinfo (lambda (k v) (hash-table-for-each classinfo (lambda (k v)
(create-some k try-args)))) (create-some k try-args))))
(define (create-all-exhaust) (define (create-all-exhaust)
(fprintf (thread-output-port) "creating all exhaustively...~n") (fprintf (thread-output-port) "creating all exhaustively...\n")
(hash-table-for-each classinfo (lambda (k v) (hash-table-for-each classinfo (lambda (k v)
(create-some k try-all-args)))) (create-some k try-all-args))))
(define (create-all-bad) (define (create-all-bad)
(fprintf (thread-output-port) "creating all with bad arguments...~n") (fprintf (thread-output-port) "creating all with bad arguments...\n")
(hash-table-for-each classinfo (lambda (k v) (hash-table-for-each classinfo (lambda (k v)
(create-some k try-bad-args)))) (create-some k try-bad-args))))
@ -819,7 +819,7 @@
[name (cadr v)] [name (cadr v)]
[methods (cdddr v)]) [methods (cdddr v)])
(if (void? use) (if (void? use)
(fprintf (thread-output-port) "~s: no examples~n" name) (fprintf (thread-output-port) "~s: no examples\n" name)
(let loop ([l methods]) (let loop ([l methods])
(unless (null? l) (unless (null? l)
(unless (symbol? (car l)) (unless (symbol? (car l))
@ -850,7 +850,7 @@
(loop (cdr l))))))) (loop (cdr l)))))))
(define (call-random except) (define (call-random except)
(fprintf (thread-output-port) "calling all except ~a randomly...~n" except) (fprintf (thread-output-port) "calling all except ~a randomly...\n" except)
(hash-table-for-each classinfo (lambda (k v) (hash-table-for-each classinfo (lambda (k v)
(unless (member k except) (unless (member k except)
(try-methods k try-args))))) (try-methods k try-args)))))
@ -859,7 +859,7 @@
(call-random null)) (call-random null))
(define (call-all-bad) (define (call-all-bad)
(fprintf (thread-output-port) "calling all with bad arguments...~n") (fprintf (thread-output-port) "calling all with bad arguments...\n")
(hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args)))) (hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args))))
(define (call-all-non-editor) (define (call-all-non-editor)
@ -871,7 +871,7 @@
(create-all-random) (create-all-random)
(create-all-random)) (create-all-random))
(printf " Creating Example Instances~n") (printf " Creating Example Instances\n")
(define f (make-object frame% "Example Frame 1")) (define f (make-object frame% "Example Frame 1"))
(send frame%-example-list add f) (send frame%-example-list add f)
@ -1000,9 +1000,9 @@
(send clipboard<%>-example-list add the-clipboard) (send clipboard<%>-example-list add the-clipboard)
(send clipboard-client%-example-list add (make-object clipboard-client%)) (send clipboard-client%-example-list add (make-object clipboard-client%))
(printf " Done Creating Example Instances~n") (printf " Done Creating Example Instances\n")
(printf " Checking all methods~n") (printf " Checking all methods\n")
(define in-top-level null) (define in-top-level null)
(hash-table-for-each classinfo (hash-table-for-each classinfo
(lambda (key v) (lambda (key v)
@ -1015,7 +1015,7 @@
(if (void? (with-handlers ([void void]) (if (void? (with-handlers ([void void])
(namespace-variable-value name))) (namespace-variable-value name)))
;; Not there ;; Not there
(printf "No such procedure/value: ~a~n" name) (printf "No such procedure/value: ~a\n" name)
(let ([v (namespace-variable-value name)]) (let ([v (namespace-variable-value name)])
(when (procedure? v) (when (procedure? v)
@ -1028,7 +1028,7 @@
(andmap integer? a) (andmap integer? a)
(andmap integer? b) (andmap integer? b)
(equal? (sort a <) (sort b <))))) (equal? (sort a <) (sort b <)))))
(printf "Arity mismatch for ~a, real: ~a documented: ~a~n" (printf "Arity mismatch for ~a, real: ~a documented: ~a\n"
name (procedure-arity v) (cadr method)))))) name (procedure-arity v) (cadr method))))))
(set! in-top-level (cons name in-top-level))) (set! in-top-level (cons name in-top-level)))
@ -1046,12 +1046,12 @@
(if (interface? key) "interface" "class") (if (interface? key) "interface" "class")
s))]) s))])
(unless (string=? sp ss) (unless (string=? sp ss)
(printf "bad printed form: ~a != ~a~n" sp ss)))) (printf "bad printed form: ~a != ~a\n" sp ss))))
; Check documented methods are right ; Check documented methods are right
(let ([ex (send (car v) choose-example)]) (let ([ex (send (car v) choose-example)])
(unless (is-a? ex key) (unless (is-a? ex key)
(printf "Bad example: ~a for ~a~n" ex key)) (printf "Bad example: ~a for ~a\n" ex key))
(for-each (for-each
(lambda (name method) (lambda (name method)
(if (or (and (interface? key) (if (or (and (interface? key)
@ -1063,21 +1063,21 @@
'(when (is-a? ex key) '(when (is-a? ex key)
(let ([m (make-generic ex name)]) (let ([m (make-generic ex name)])
(unless (equal? (arity m) (cadr method)) (unless (equal? (arity m) (cadr method))
(printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a~n" (printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a\n"
name key name key
(arity m) (cadr method))))) (arity m) (cadr method)))))
;; Not there ;; Not there
(printf "No such method: ~a in ~a~n" name key))) (printf "No such method: ~a in ~a\n" name key)))
names methods)) names methods))
; Check everything is documented ; Check everything is documented
(for-each (for-each
(lambda (n) (lambda (n)
(unless (memq n names) (unless (memq n names)
(printf "Undocumented method: ~a in ~a~n" n key))) (printf "Undocumented method: ~a in ~a\n" n key)))
(interface->method-names (if (interface? key) key (class->interface key))))))))) (interface->method-names (if (interface? key) key (class->interface key)))))))))
(printf " Method-checking done~n") (printf " Method-checking done\n")
(let* ([get-all (lambda (n) (let* ([get-all (lambda (n)
(parameterize ([current-namespace n]) (parameterize ([current-namespace n])
@ -1092,7 +1092,7 @@
(for-each (for-each
(lambda (i) (lambda (i)
(unless (memq i expect-n) (unless (memq i expect-n)
(printf "Undocumented global: ~a~n" i))) (printf "Undocumented global: ~a\n" i)))
actual-n)) actual-n))
(unless (and (>= (vector-length argv) 1) (unless (and (>= (vector-length argv) 1)

68
collects/tests/gracket/windowing.rktl
View File

@ -39,7 +39,7 @@
(test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v)))))) (test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v))))))
(define (enable-tests f) (define (enable-tests f)
(printf "Enable ~a~n" f) (printf "Enable ~a\n" f)
(st #t f is-enabled?) (st #t f is-enabled?)
(stv f enable #f) (stv f enable #f)
(st #f f is-enabled?) (st #f f is-enabled?)
@ -47,7 +47,7 @@
(st #t f is-enabled?)) (st #t f is-enabled?))
(define (drop-file-tests f) (define (drop-file-tests f)
(printf "Drop File ~a~n" f) (printf "Drop File ~a\n" f)
(st #f f accept-drop-files) (st #f f accept-drop-files)
(stv f accept-drop-files #t) (stv f accept-drop-files #t)
(st #t f accept-drop-files) (st #t f accept-drop-files)
@ -55,7 +55,7 @@
(st #f f accept-drop-files)) (st #f f accept-drop-files))
(define (client->screen-tests f) (define (client->screen-tests f)
(printf "Client<->Screen ~a~n" f) (printf "Client<->Screen ~a\n" f)
(let-values ([(x y) (send f client->screen 0 0)]) (let-values ([(x y) (send f client->screen 0 0)])
(stvals '(0 0) f screen->client x y)) (stvals '(0 0) f screen->client x y))
(let-values ([(x y) (send f screen->client 0 0)]) (let-values ([(x y) (send f screen->client 0 0)])
@ -66,7 +66,7 @@
(stv f refresh)) (stv f refresh))
(define (area-tests f sw? sh? no-stretch?) (define (area-tests f sw? sh? no-stretch?)
(printf "Area ~a~n" f) (printf "Area ~a\n" f)
(let ([x (send f min-width)] (let ([x (send f min-width)]
[y (send f min-height)]) [y (send f min-height)])
(st sw? f stretchable-width) (st sw? f stretchable-width)
@ -76,7 +76,7 @@
(let-values ([(w h) (if no-stretch? (let-values ([(w h) (if no-stretch?
(send f get-size) (send f get-size)
(values 0 0))]) (values 0 0))])
(printf "Size ~a x ~a~n" w h) (printf "Size ~a x ~a\n" w h)
(when no-stretch? (when no-stretch?
(stv f min-width w) ; when we turn of stretchability, don't resize (stv f min-width w) ; when we turn of stretchability, don't resize
(stv f min-height h)) (stv f min-height h))
@ -95,7 +95,7 @@
(define (containee-tests f sw? sh? m) (define (containee-tests f sw? sh? m)
(area-tests f sw? sh? #f) (area-tests f sw? sh? #f)
(printf "Containee ~a~n" f) (printf "Containee ~a\n" f)
(st m f horiz-margin) (st m f horiz-margin)
(st m f vert-margin) (st m f vert-margin)
(stv f horiz-margin 3) (stv f horiz-margin 3)
@ -108,14 +108,14 @@
(stv f vert-margin m)) (stv f vert-margin m))
(define (container-tests f win?) (define (container-tests f win?)
(printf "Container ~a~n" f) (printf "Container ~a\n" f)
(let-values ([(x y) (send f get-alignment)]) (let-values ([(x y) (send f get-alignment)])
(stv f set-alignment 'right 'bottom) (stv f set-alignment 'right 'bottom)
(stvals '(right bottom) f get-alignment) (stvals '(right bottom) f get-alignment)
(stv f set-alignment x y))) (stv f set-alignment x y)))
(define (cursor-tests f) (define (cursor-tests f)
(printf "Cursor ~a~n" f) (printf "Cursor ~a\n" f)
(let ([c (send f get-cursor)]) (let ([c (send f get-cursor)])
(stv f set-cursor c) (stv f set-cursor c)
(st c f get-cursor) (st c f get-cursor)
@ -131,7 +131,7 @@
(define (show-tests f) (define (show-tests f)
(unless (is-a? f dialog%) (unless (is-a? f dialog%)
(printf "Show ~a~n" f) (printf "Show ~a\n" f)
(let ([on? (send f is-shown?)]) (let ([on? (send f is-shown?)])
(stv f show #f) (stv f show #f)
(when on? (when on?
@ -193,7 +193,7 @@
(st #f f get-menu-bar))] (st #f f get-menu-bar))]
[space-tests [space-tests
(lambda () (lambda ()
(printf "Spacing~n") (printf "Spacing\n")
(let ([b (send f border)]) (let ([b (send f border)])
(stv f border 25) (stv f border 25)
(st 25 f border) (st 25 f border)
@ -209,14 +209,14 @@
(drop-file-tests f))] (drop-file-tests f))]
[client->screen-tests [client->screen-tests
(lambda () (lambda ()
(printf "Client<->Screen~n") (printf "Client<->Screen\n")
(let-values ([(x y) (send f client->screen 0 0)]) (let-values ([(x y) (send f client->screen 0 0)])
(stvals '(0 0) f screen->client x y)) (stvals '(0 0) f screen->client x y))
(let-values ([(x y) (send f screen->client 0 0)]) (let-values ([(x y) (send f screen->client 0 0)])
(stvals '(0 0) f client->screen x y)))] (stvals '(0 0) f client->screen x y)))]
[container-tests [container-tests
(lambda () (lambda ()
(printf "Container~n") (printf "Container\n")
(area-tests f #t #t #t) (area-tests f #t #t #t)
(let-values ([(x y) (send f container-size null)]) (let-values ([(x y) (send f container-size null)])
(st x f min-width) (st x f min-width)
@ -238,15 +238,15 @@
(container-tests) (container-tests)
(cursor-tests) (cursor-tests)
(printf "Init~n") (printf "Init\n")
(init-tests #f) (init-tests #f)
(stv f show #t) (stv f show #t)
(pause) (pause)
(printf "Show Init~n") (printf "Show Init\n")
(init-tests #t) (init-tests #t)
(stv f show #f) (stv f show #f)
(pause) (pause)
(printf "Hide Init~n") (printf "Hide Init\n")
(init-tests #f) (init-tests #f)
(send f show #t) (send f show #t)
(pause) (pause)
@ -258,7 +258,7 @@
(stv f change-children values) (stv f change-children values)
(printf "Iconize~n") (printf "Iconize\n")
(stv f iconize #t) (stv f iconize #t)
(pause) (pause)
(pause) (pause)
@ -272,7 +272,7 @@
(stv f maximize #f) (stv f maximize #f)
(pause) (pause)
(printf "Move~n") (printf "Move\n")
(stv f move 34 37) (stv f move 34 37)
(pause) (pause)
(FAILS (st 34 f get-x)) (FAILS (st 34 f get-x))
@ -280,7 +280,7 @@
(st 150 f get-width) (st 150 f get-width)
(st 151 f get-height) (st 151 f get-height)
(printf "Resize~n") (printf "Resize\n")
(stv f resize 56 57) (stv f resize 56 57)
(pause) (pause)
(FAILS (st 34 f get-x)) (FAILS (st 34 f get-x))
@ -306,7 +306,7 @@
(cursor-tests) (cursor-tests)
(printf "Menu Bar~n") (printf "Menu Bar\n")
(let ([mb (make-object menu-bar% f)]) (let ([mb (make-object menu-bar% f)])
(st mb f get-menu-bar) (st mb f get-menu-bar)
(st f mb get-frame) (st f mb get-frame)
@ -320,11 +320,11 @@
(st null mb get-items) (st null mb get-items)
(printf "Menu 1~n") (printf "Menu 1\n")
(let* ([m (make-object menu% "&File" mb)] (let* ([m (make-object menu% "&File" mb)]
[i m] [i m]
[delete-enable-test (lambda (i parent empty) [delete-enable-test (lambda (i parent empty)
(printf "Item~n") (printf "Item\n")
(st #f i is-deleted?) (st #f i is-deleted?)
(st #t i is-enabled?) (st #t i is-enabled?)
@ -371,7 +371,7 @@
(st null m get-items) (st null m get-items)
(printf "Menu Items~n") (printf "Menu Items\n")
(let ([i1 (make-object menu-item% "&Plain" m (let ([i1 (make-object menu-item% "&Plain" m
(lambda (i e) (lambda (i e)
(test-control-event e '(menu)) (test-control-event e '(menu))
@ -391,7 +391,7 @@
(lambda (i empty name) (lambda (i empty name)
(delete-enable-test i m empty) (delete-enable-test i m empty)
(printf "Shortcut~n") (printf "Shortcut\n")
(set! hit i) (set! hit i)
(stv i command (make-object control-event% 'menu)) (stv i command (make-object control-event% 'menu))
(test name 'hit-command hit) (test name 'hit-command hit)
@ -437,7 +437,7 @@
'done) 'done)
(printf "Menu 2~n") (printf "Menu 2\n")
(let* ([m2 (make-object menu% "&Edit" mb "Help Edit")] (let* ([m2 (make-object menu% "&Edit" mb "Help Edit")]
[i2 m2]) [i2 m2])
(st (list i i2) mb get-items) (st (list i i2) mb get-items)
@ -468,7 +468,7 @@
(define (test-controls parent frame) (define (test-controls parent frame)
(define side-effect #f) (define side-effect #f)
(printf "Buttons~n") (printf "Buttons\n")
(letrec ([b (make-object button% (letrec ([b (make-object button%
"&Button" "&Button"
parent parent
@ -484,7 +484,7 @@
(containee-window-tests b #f #f parent frame 2)) (containee-window-tests b #f #f parent frame 2))
(printf "Check Box~n") (printf "Check Box\n")
(letrec ([c (make-object check-box% (letrec ([c (make-object check-box%
"&Check Box" "&Check Box"
parent parent
@ -511,7 +511,7 @@
#t)]) #t)])
(st #t c get-value)) (st #t c get-value))
(printf "Radio Box~n") (printf "Radio Box\n")
(letrec ([r (make-object radio-box% (letrec ([r (make-object radio-box%
"&Radio Box" "&Radio Box"
(list "O&ne" "T&wo" "T&hree") (list "O&ne" "T&wo" "T&hree")
@ -586,7 +586,7 @@
'(vertical) '(vertical)
3)) 3))
(printf "Gauge~n") (printf "Gauge\n")
(letrec ([g (make-object gauge% (letrec ([g (make-object gauge%
"&Gauge" "&Gauge"
10 10
@ -618,7 +618,7 @@
(containee-window-tests g #t #f parent frame 2)) (containee-window-tests g #t #f parent frame 2))
(printf "Slider~n") (printf "Slider\n")
(letrec ([s (make-object slider% (letrec ([s (make-object slider%
"&Slider" "&Slider"
-2 8 -2 8
@ -774,7 +774,7 @@
'done-list)]) 'done-list)])
(printf "Choice~n") (printf "Choice\n")
(letrec ([c (make-object choice% (letrec ([c (make-object choice%
"&Choice" "&Choice"
'("A" "B" "C & D") '("A" "B" "C & D")
@ -808,7 +808,7 @@
(let ([mk-list (let ([mk-list
(lambda (style) (lambda (style)
(printf "List Box: ~a~n" style) (printf "List Box: ~a\n" style)
(letrec ([l (make-object list-box% (letrec ([l (make-object list-box%
"&List Box" "&List Box"
'("A" "B" "C & D") '("A" "B" "C & D")
@ -869,7 +869,7 @@
(let ([c (make-object canvas% parent '(hscroll vscroll))]) (let ([c (make-object canvas% parent '(hscroll vscroll))])
(printf "Tab Focus~n") (printf "Tab Focus\n")
(st #f c accept-tab-focus) (st #f c accept-tab-focus)
(stv c accept-tab-focus #t) (stv c accept-tab-focus #t)
(st #t c accept-tab-focus) (st #t c accept-tab-focus)
@ -880,7 +880,7 @@
; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t)
(let-values ([(w h) (send c get-virtual-size)] (let-values ([(w h) (send c get-virtual-size)]
[(cw ch) (send c get-client-size)]) [(cw ch) (send c get-client-size)])
(printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch) (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a\n" w h cw ch)
(let ([check-scroll (let ([check-scroll
(lambda (xpos ypos) (lambda (xpos ypos)
(let-values ([(x y) (send c get-view-start)]) (let-values ([(x y) (send c get-view-start)])
@ -958,7 +958,7 @@
102)]) 102)])
(let loop ([n 100]) (let loop ([n 100])
(unless (zero? n) (unless (zero? n)
(send e insert (format "line ~a~n" n)) (send e insert (format "line ~a\n" n))
(loop (sub1 n)))) (loop (sub1 n))))
(st #f c allow-scroll-to-last) (st #f c allow-scroll-to-last)

27
collects/tests/mysterx/mystests.rktl
View File

@ -29,7 +29,7 @@
(for-each (for-each
(lambda (n) (lambda (n)
(unless (test-scode n) (unless (test-scode n)
(printf "Error in test-scode for value ~a~n" n) (printf "Error in test-scode for value ~a\n" n)
(set! errors? #t))) (set! errors? #t)))
'(25 -22 -1 -233344433 177000000 859489222)) '(25 -22 -1 -233344433 177000000 859489222))
@ -49,13 +49,13 @@
(set-date-dst?! date #f) (set-date-dst?! date #f)
(set-date-time-zone-offset! date 0) (set-date-time-zone-offset! date 0)
(unless (test-date date) (unless (test-date date)
(printf "Error in test-date~n") (printf "Error in test-date\n")
(set! errors? #t))) (set! errors? #t)))
(for-each (for-each
(lambda (n) (lambda (n)
(unless (test-currency n) (unless (test-currency n)
(printf "Error in test-currency for value ~a~n" n) (printf "Error in test-currency for value ~a\n" n)
(set! errors? #t))) (set! errors? #t)))
'(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933)) '(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933))
@ -81,7 +81,7 @@
[expected (caddr t)]) [expected (caddr t)])
(unless (equal? got expected) (unless (equal? got expected)
(set! errors? #t) (set! errors? #t)
(printf "Error in com-tests. Expected: ~a~nGot : ~a~n" (printf "Error in com-tests. Expected: ~a\nGot : ~a\n"
expected got)))) expected got))))
com-tests) com-tests)
@ -93,11 +93,11 @@
(set! errors? #t)) (set! errors? #t))
(if errors? (if errors?
(printf "There were errors!~n") (printf "There were errors!\n")
(printf "No errors in conversions and COM tests~n")) (printf "No errors in conversions and COM tests\n"))
(define (make-mousefun s) (define (make-mousefun s)
(let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a~n")]) (let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a\n")])
(lambda (button shift x y) (lambda (button shift x y)
(printf t button shift x y)))) (printf t button shift x y))))
@ -110,17 +110,10 @@
(lambda (sf) (lambda (sf)
(com-register-event-handler ctrl (car sf) (cadr sf))) (com-register-event-handler ctrl (car sf) (cadr sf)))
`(("Click" `(("Click"
,(lambda () (printf "Click~n"))) ,(lambda () (printf "Click\n")))
,(mouse-pair "MouseMove") ,(mouse-pair "MouseMove")
,(mouse-pair "MouseDown") ,(mouse-pair "MouseDown")
,(mouse-pair "MouseUp"))) ,(mouse-pair "MouseUp")))
(printf "Try clicking and moving the mouse over the object~n") (printf "Try clicking and moving the mouse over the object\n")
(printf "You should see Click, MouseMove, MouseDown, and MouseUp events~n")) (printf "You should see Click, MouseMove, MouseDown, and MouseUp events\n"))

24
collects/tests/mzcom/test.rktl
View File

@ -17,43 +17,43 @@
(print-struct #t) (print-struct #t)
; should show an About box ; should show an About box
(printf "You should see the About box~n") (printf "You should see the About box\n")
(run "About") (run "About")
; tests whether Eval returns sensible result ; tests whether Eval returns sensible result
(if (string=? (mzeval "(+ 20 22)") (if (string=? (mzeval "(+ 20 22)")
"42") "42")
(printf "1st Eval test ok~n") (printf "1st Eval test ok\n")
(begin (begin
(add-error!) (add-error!)
(fprintf (current-error-port) "1st Eval test failed~n"))) (fprintf (current-error-port) "1st Eval test failed\n")))
(mzeval "(define x 42)") (mzeval "(define x 42)")
; tests whether preceding definition really holds ; tests whether preceding definition really holds
(if (string=? "42" (mzeval "x")) (if (string=? "42" (mzeval "x"))
(printf "define test ok~n") (printf "define test ok\n")
(begin (begin
(add-error!) (add-error!)
(fprintf (current-error-port) "define test failed~n"))) (fprintf (current-error-port) "define test failed\n")))
(printf "Resetting environment~n") (printf "Resetting environment\n")
(run "Reset") ; removes binding for x (run "Reset") ; removes binding for x
; tests for removal of binding ; tests for removal of binding
(with-handlers (with-handlers
([void (lambda (exn) (printf "2nd Eval test looks ok~nexn was: ~a~n" exn))]) ([void (lambda (exn) (printf "2nd Eval test looks ok\nexn was: ~a\n" exn))])
(mzeval "x") ; binding for x missing (mzeval "x") ; binding for x missing
(add-error!) (add-error!)
(fprintf (current-error-port) "2nd Eval test failed~n")) (fprintf (current-error-port) "2nd Eval test failed\n"))
; tests if a Scheme error results in a COM error ; tests if a Scheme error results in a COM error
(with-handlers (with-handlers
([void (lambda (exn) (printf "3rd Eval test looks ok~nexn was: ~a~n" exn))]) ([void (lambda (exn) (printf "3rd Eval test looks ok\nexn was: ~a\n" exn))])
(mzeval "(+ 'foo 42)") ; should raise Scheme error (mzeval "(+ 'foo 42)") ; should raise Scheme error
(add-error!) (add-error!)
(fprintf (current-error-port) "3rd Eval test failed~n")) (fprintf (current-error-port) "3rd Eval test failed\n"))
(when (> num-errors 0) (when (> num-errors 0)
(fprintf (current-error-port) "There were ~a errors.~n" num-errors)) (fprintf (current-error-port) "There were ~a errors.\n" num-errors))
(printf "End of MzCOM tests.~n") (printf "End of MzCOM tests.\n")

70
collects/tests/plai/gc/good-mutators/student-1.rkt
View File

@ -28,23 +28,23 @@
(define (loop x) (define (loop x)
(printf "Iteration: ~a~n" x) (printf "Iteration: ~a\n" x)
(if (zero? x) 0 (if (zero? x) 0
(loop (- (+ (local-vars) (- x 1)) 8)))) (loop (- (+ (local-vars) (- x 1)) 8))))
; Generate gradually increasing sizes of lists ; Generate gradually increasing sizes of lists
; To trigger garbage collection at different points ; To trigger garbage collection at different points
(printf "~a~n" (gen-list 1)) (printf "~a\n" (gen-list 1))
(printf "~a~n" (gen-list 2)) (printf "~a\n" (gen-list 2))
(printf "~a~n" (gen-list 4)) (printf "~a\n" (gen-list 4))
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
; Run a loop that uses local vars a few times ; Run a loop that uses local vars a few times
(printf "Generating Primitives in loops~n") (printf "Generating Primitives in loops\n")
(loop 20) (loop 20)
(printf "Try Allocating large list again~n") (printf "Try Allocating large list again\n")
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
; Create some circular references ; Create some circular references
@ -54,25 +54,25 @@
(set-rest! x y) (set-rest! x y)
x))) x)))
(printf "Testing Circular References~n") (printf "Testing Circular References\n")
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "~a~n" (gen-circular)) (printf "~a\n" (gen-circular))
(printf "Try allocating large list again~n") (printf "Try allocating large list again\n")
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
(printf "~a~n" (gen-list 8)) (printf "~a\n" (gen-list 8))
(printf "Running sample tests~n") (printf "Running sample tests\n")
(define (fact x) (define (fact x)
(if (zero? x) (if (zero? x)
1 1
@ -114,18 +114,18 @@
(define head (cons 4 (cons 3 (cons 2 tail)))) (define head (cons 4 (cons 3 (cons 2 tail))))
(set-rest! tail head) (set-rest! tail head)
(printf "res ~a~n" head) (printf "res ~a\n" head)
(set! head empty) (set! head empty)
(set! tail head) (set! tail head)
(printf "res ~a~n" lst) (printf "res ~a\n" lst)
(printf "res ~a~n" (length '(hello goodbye))) (printf "res ~a\n" (length '(hello goodbye)))
(printf "res ~a~n" (map sub1 lst)) (printf "res ~a\n" (map sub1 lst))
(printf "(fact-help 15 1): ~a~n" (fact-help 15 1)) (printf "(fact-help 15 1): ~a\n" (fact-help 15 1))
(printf "(fact 9): ~a~n" (fact 9)) (printf "(fact 9): ~a\n" (fact 9))
(printf "(append lst lst): ~a~n" (append lst lst)) (printf "(append lst lst): ~a\n" (append lst lst))
(printf "(map-add 5 lst): ~a~n" (map-add 5 lst)) (printf "(map-add 5 lst): ~a\n" (map-add 5 lst))
(printf "(filter even? (map sub1 lst)): ~a~n" (filter even? (map sub1 lst))) (printf "(filter even? (map sub1 lst)): ~a\n" (filter even? (map sub1 lst)))
(printf "(length lst): ~a~n" (length lst)) (printf "(length lst): ~a\n" (length lst))

2
collects/tests/racket/benchmarks/shootout/ackermann.rkt
View File

@ -7,6 +7,6 @@
(else (ack (- m 1) (ack m (- n 1)))))) (else (ack (- m 1) (ack m (- n 1))))))
(command-line #:args (n) (command-line #:args (n)
(printf "Ack(3,~a): ~a~n" (printf "Ack(3,~a): ~a\n"
n n
(ack 3 (string->number n)))) (ack 3 (string->number n))))

2
collects/tests/racket/benchmarks/shootout/except.rkt
View File

@ -32,6 +32,6 @@
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
(some_fun i))) (some_fun i)))
(printf "Exceptions: HI=~a / LO=~a~n" HI LO)) (printf "Exceptions: HI=~a / LO=~a\n" HI LO))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/hash.rkt
View File

@ -14,6 +14,6 @@
(when (hash-ref hash (number->string i) false) (when (hash-ref hash (number->string i) false)
(set! accum (+ accum 1))) (set! accum (+ accum 1)))
(loop (sub1 i)))) (loop (sub1 i))))
(printf "~s~n" accum))) (printf "~s\n" accum)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/hash2.rkt
View File

@ -17,7 +17,7 @@
key key
(+ (hash-ref hash2 key zero) value)))) (+ (hash-ref hash2 key zero) value))))
(loop (add1 i)))) (loop (add1 i))))
(printf "~s ~s ~s ~s~n" (printf "~s ~s ~s ~s\n"
(hash-ref hash1 "foo_1") (hash-ref hash1 "foo_1")
(hash-ref hash1 "foo_9999") (hash-ref hash1 "foo_9999")
(hash-ref hash2 "foo_1") (hash-ref hash2 "foo_1")

2
collects/tests/racket/benchmarks/shootout/heapsort.rkt
View File

@ -61,7 +61,7 @@
((= i last)) ((= i last))
(vector-set! ary i (gen_random 1.0))) (vector-set! ary i (gen_random 1.0)))
(heapsort n ary) (heapsort n ary)
(printf "~a~n" (printf "~a\n"
(real->decimal-string (vector-ref ary n) 10)))) (real->decimal-string (vector-ref ary n) 10))))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/lists.rkt
View File

@ -40,6 +40,6 @@
(when (> counter 0) (when (> counter 0)
(set! result (test-lists)) (set! result (test-lists))
(loop (- counter 1)))) (loop (- counter 1))))
(printf "~s~n" result))) (printf "~s\n" result)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/nestedloop.rkt
View File

@ -14,6 +14,6 @@
(let* ([n (string->number (vector-ref argv 0))] (let* ([n (string->number (vector-ref argv 0))]
[x 0]) [x 0])
(nest 6 (set! x (+ x 1))) (nest 6 (set! x (+ x 1)))
(printf "~s~n" x))) (printf "~s\n" x)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/random.rkt
View File

@ -35,5 +35,5 @@
(gen_random 100.0) (gen_random 100.0)
(loop (- iter 1))) (loop (- iter 1)))
#t)) #t))
(printf "~a~%" (printf "~a\n"
(real->decimal-string (gen_random 100.0) 9))) (real->decimal-string (gen_random 100.0) 9)))

10
collects/tests/racket/benchmarks/shootout/recursive.rkt
View File

@ -43,16 +43,16 @@
(define (main n) (define (main n)
(printf "Ack(3,~A): ~A~%" n (ack 3 n)) (printf "Ack(3,~A): ~A\n" n (ack 3 n))
(printf "Fib(~a): ~a~%" (printf "Fib(~a): ~a\n"
(real->decimal-string (+ 27.0 n) 1) (real->decimal-string (+ 27.0 n) 1)
(real->decimal-string (fibflt (+ 27.0 n)) 1)) (real->decimal-string (fibflt (+ 27.0 n)) 1))
(set! n (- n 1)) (set! n (- n 1))
(printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n)) (printf "Tak(~A,~A,~A): ~A\n" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
(printf "Fib(3): ~A~%" (fib 3)) (printf "Fib(3): ~A\n" (fib 3))
(printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1))) (printf "Tak(3.0,2.0,1.0): ~a\n" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
;; ------------------------------- ;; -------------------------------

2
collects/tests/racket/benchmarks/shootout/regexmatch.rkt
View File

@ -55,7 +55,7 @@
[num (bytes-append #"(" area #") " exch #"-" numb)] [num (bytes-append #"(" area #") " exch #"-" numb)]
[count (add1 count)]) [count (add1 count)])
(when (zero? n) (when (zero? n)
(printf "~a: ~a~n" count num)) (printf "~a: ~a\n" count num))
(loop (cdr phones) count))) (loop (cdr phones) count)))
(loop (cdr phones) count)))))))) (loop (cdr phones) count))))))))

2
collects/tests/racket/benchmarks/shootout/typed/ackermann.rktl
View File

@ -7,6 +7,6 @@
(else (ack (- m 1) (ack m (- n 1)))))) (else (ack (- m 1) (ack m (- n 1))))))
(command-line #:args (n) (command-line #:args (n)
(printf "Ack(3,~a): ~a~n" (printf "Ack(3,~a): ~a\n"
n n
(ack 3 (assert (string->number (assert n string?)) exact-integer?)))) (ack 3 (assert (string->number (assert n string?)) exact-integer?))))

2
collects/tests/racket/benchmarks/shootout/typed/except.rktl
View File

@ -39,6 +39,6 @@
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
(some_fun i))) (some_fun i)))
(printf "Exceptions: HI=~a / LO=~a~n" HI LO)) (printf "Exceptions: HI=~a / LO=~a\n" HI LO))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/hash.rktl
View File

@ -13,6 +13,6 @@
(when (hash-ref hash (number->string i) false) (when (hash-ref hash (number->string i) false)
(set! accum (+ accum 1))) (set! accum (+ accum 1)))
(loop (sub1 i)))) (loop (sub1 i))))
(printf "~s~n" accum))) (printf "~s\n" accum)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/hash2.rktl
View File

@ -16,7 +16,7 @@
key key
(+ (hash-ref hash2 key zero) value)))) (+ (hash-ref hash2 key zero) value))))
(loop (add1 i)))) (loop (add1 i))))
(printf "~s ~s ~s ~s~n" (printf "~s ~s ~s ~s\n"
(hash-ref hash1 "foo_1") (hash-ref hash1 "foo_1")
(hash-ref hash1 "foo_9999") (hash-ref hash1 "foo_9999")
(hash-ref hash2 "foo_1") (hash-ref hash2 "foo_1")

2
collects/tests/racket/benchmarks/shootout/typed/heapsort.rktl
View File

@ -66,7 +66,7 @@
((= i last)) ((= i last))
(vector-set! ary i (gen_random 1.0))) (vector-set! ary i (gen_random 1.0)))
(heapsort n ary) (heapsort n ary)
(printf "~a~n" (printf "~a\n"
(real->decimal-string (vector-ref ary n) 10)))) (real->decimal-string (vector-ref ary n) 10))))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/lists.rktl
View File

@ -44,6 +44,6 @@
(when (> counter 0) (when (> counter 0)
(set! result (test-lists)) (set! result (test-lists))
(loop (- counter 1)))) (loop (- counter 1))))
(printf "~s~n" result))) (printf "~s\n" result)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/nestedloop.rktl
View File

@ -13,6 +13,6 @@
(let*: ([n : Integer (assert (string->number (vector-ref argv 0)) exact-integer?)] (let*: ([n : Integer (assert (string->number (vector-ref argv 0)) exact-integer?)]
[x : Integer 0]) [x : Integer 0])
(nest 6 (set! x (+ x 1))) (nest 6 (set! x (+ x 1)))
(printf "~s~n" x))) (printf "~s\n" x)))
(main (current-command-line-arguments)) (main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/random.rktl
View File

@ -35,5 +35,5 @@
(gen_random 100.0) (gen_random 100.0)
(loop (- iter 1))) (loop (- iter 1)))
#t)) #t))
(printf "~a~%" (printf "~a\n"
(real->decimal-string (gen_random 100.0) 9))) (real->decimal-string (gen_random 100.0) 9)))

10
collects/tests/racket/benchmarks/shootout/typed/recursive.rktl
View File

@ -48,16 +48,16 @@
(: main (Integer -> Void)) (: main (Integer -> Void))
(define (main n) (define (main n)
(printf "Ack(3,~A): ~A~%" n (ack 3 n)) (printf "Ack(3,~A): ~A\n" n (ack 3 n))
(printf "Fib(~a): ~a~%" (printf "Fib(~a): ~a\n"
(real->decimal-string (+ 27.0 n) 1) (real->decimal-string (+ 27.0 n) 1)
(real->decimal-string (fibflt (+ 27.0 n)) 1)) (real->decimal-string (fibflt (+ 27.0 n)) 1))
(set! n (- n 1)) (set! n (- n 1))
(printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n)) (printf "Tak(~A,~A,~A): ~A\n" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
(printf "Fib(3): ~A~%" (fib 3)) (printf "Fib(3): ~A\n" (fib 3))
(printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1))) (printf "Tak(3.0,2.0,1.0): ~a\n" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
;; ------------------------------- ;; -------------------------------

2
collects/tests/racket/benchmarks/shootout/typed/regexmatch.rktl
View File

@ -60,7 +60,7 @@
(assert numb))] (assert numb))]
[count (add1 count)]) [count (add1 count)])
(when (zero? n) (when (zero? n)
(printf "~a: ~a~n" count num)) (printf "~a: ~a\n" count num))
(loop (cdr phones) count))) (loop (cdr phones) count)))
(loop (cdr phones) count)))))))) (loop (cdr phones) count))))))))

2
collects/tests/racket/benchmarks/shootout/typed/wordfreq.rktl
View File

@ -28,7 +28,7 @@
t t
(lambda: ((word : String) (count : Natural)) (lambda: ((word : String) (count : Natural))
(let ((count (number->string count))) (let ((count (number->string count)))
(format"~a~a ~a~%" (format"~a~a ~a\n"
(make-string (- 7 (string-length count)) #\space) (make-string (- 7 (string-length count)) #\space)
count count
word)))) word))))

2
collects/tests/racket/benchmarks/shootout/wordfreq.rkt
View File

@ -26,7 +26,7 @@
t t
(lambda (word count) (lambda (word count)
(let ((count (number->string count))) (let ((count (number->string count)))
(format"~a~a ~a~%" (format"~a~a ~a\n"
(make-string (- 7 (string-length count)) #\space) (make-string (- 7 (string-length count)) #\space)
count count
word)))) word))))

16
collects/tests/racket/ltest.rktl
View File

@ -1,4 +1,4 @@
(printf "nested loop~n") (printf "nested loop\n")
(time (time
(let loop ([n 10000]) (let loop ([n 10000])
(unless (zero? n) (unless (zero? n)
@ -7,13 +7,13 @@
(loop (sub1 n)) (loop (sub1 n))
(loop2 (sub1 m))))))) (loop2 (sub1 m)))))))
(printf "single loop~n") (printf "single loop\n")
(time (time
(let loop ([n 100000]) (let loop ([n 100000])
(unless (zero? n) (unless (zero? n)
(loop (sub1 n))))) (loop (sub1 n)))))
(printf "Y loop~n") (printf "Y loop\n")
(time (time
((lambda (f n) (f f n)) ((lambda (f n) (f f n))
(lambda (loop n) (lambda (loop n)
@ -22,27 +22,27 @@
100000)) 100000))
(printf "let closure recur~n") (printf "let closure recur\n")
(time (time
(let ([f (lambda (x) (sub1 x))]) (let ([f (lambda (x) (sub1 x))])
(let loop ([n 100000]) (let loop ([n 100000])
(unless (zero? n) (unless (zero? n)
(loop (f n)))))) (loop (f n))))))
(printf "direct closure recur~n") (printf "direct closure recur\n")
(time (time
(let loop ([n 100000]) (let loop ([n 100000])
(unless (zero? n) (unless (zero? n)
(loop ((lambda (x) (sub1 x)) n))))) (loop ((lambda (x) (sub1 x)) n)))))
(printf "direct closure recur if~n") (printf "direct closure recur if\n")
(time (time
(let loop ([n 100000]) (let loop ([n 100000])
(if (zero? n) (if (zero? n)
(void) (void)
(loop ((lambda (x) (sub1 x)) n))))) (loop ((lambda (x) (sub1 x)) n)))))
(printf "let closure top-level~n") (printf "let closure top-level\n")
(define loop (define loop
(let ([f (lambda (x) (sub1 x))]) (let ([f (lambda (x) (sub1 x))])
(lambda (n) (lambda (n)
@ -50,7 +50,7 @@
(loop (f n)))))) (loop (f n))))))
(time (loop 100000)) (time (loop 100000))
(printf "direct closure top-level~n") (printf "direct closure top-level\n")
(define loop (define loop
(lambda (n) (lambda (n)
(unless (zero? n) (unless (zero? n)

62
collects/tests/racket/stream.rktl
View File

@ -1,5 +1,5 @@
(printf "Stream Tests (current dir must be startup dir)~n") (printf "Stream Tests (current dir must be startup dir)\n")
(require scheme/system) (require scheme/system)
@ -51,7 +51,7 @@
(error "check-failed" (file-position p) c c2) (error "check-failed" (file-position p) c c2)
(begin (begin
(fprintf (current-error-port) (fprintf (current-error-port)
"fail: ~a ~s=~s ~s=~s~n" "fail: ~a ~s=~s ~s=~s\n"
(file-position p) c (integer->char c) c2 (integer->char c2)) (file-position p) c (integer->char c) c2 (integer->char c2))
(loop (add1 badc))))) (loop (add1 badc)))))
(unless (eof-object? c) (unless (eof-object? c)
@ -107,8 +107,8 @@
(define r2 #f) (define r2 #f)
(define w2 #f) (define w2 #f)
(thread (copy-stream (cadddr p) (current-error-port))) (thread (copy-stream (cadddr p) (current-error-port)))
(fprintf (cadr p) "(define log void)~n") (fprintf (cadr p) "(define log void)\n")
(fprintf (cadr p) "~s~n" cs-prog) (fprintf (cadr p) "~s\n" cs-prog)
(if tcp? (if tcp?
(let ([t (let ([t
(thread (lambda () (thread (lambda ()
@ -118,12 +118,12 @@
(set! w ww) (set! w ww)
(set! r2 rr2) (set! r2 rr2)
(set! w2 ww2)))]) (set! w2 ww2)))])
(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno) (fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))\n" portno)
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno)) (fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
(flush-output (cadr p)) (flush-output (cadr p))
(thread-wait t) (thread-wait t)
(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n")) (fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))\n"))
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) (fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
(flush-output (cadr p)) (flush-output (cadr p))
(unless tcp? (unless tcp?
@ -149,51 +149,51 @@
(let ([ps-ms (current-process-milliseconds)] (let ([ps-ms (current-process-milliseconds)]
[gc-ms (current-gc-milliseconds)] [gc-ms (current-gc-milliseconds)]
[ms (current-milliseconds)]) [ms (current-milliseconds)])
(printf "cpu: ~a real: ~a gc ~a~n" (printf "cpu: ~a real: ~a gc ~a\n"
(- ps-ms start-ps-ms) (- ps-ms start-ps-ms)
(- ms start-ms) (- ms start-ms)
(- gc-ms start-gc-ms)))) (- gc-ms start-gc-ms))))
'(thread (lambda () '(thread (lambda ()
(let loop () (let loop ()
(printf "alive~n") (printf "alive\n")
(sleep 1) (sleep 1)
(loop)))) (loop))))
(start "Quick check:~n") (start "Quick check:\n")
(define p (open-input-file test-file)) (define p (open-input-file test-file))
(check-file/fast p) (check-file/fast p)
(close-input-port p) (close-input-port p)
(end) (end)
(start "Quicker check:~n") (start "Quicker check:\n")
(define p (open-input-file test-file)) (define p (open-input-file test-file))
(check-file/fastest p) (check-file/fastest p)
(close-input-port p) (close-input-port p)
(end) (end)
(start "Plain pipe...~n") (start "Plain pipe...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(feed-file w) (feed-file w)
(close-output-port w) (close-output-port w)
(check-file r) (check-file r)
(end) (end)
(start "Plain pipe, faster...~n") (start "Plain pipe, faster...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(feed-file/fast w) (feed-file/fast w)
(close-output-port w) (close-output-port w)
(check-file/fast r) (check-file/fast r)
(end) (end)
(start "Plain pipe, fastest...~n") (start "Plain pipe, fastest...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(feed-file/fast w) (feed-file/fast w)
(close-output-port w) (close-output-port w)
(check-file/fastest r) (check-file/fastest r)
(end) (end)
(start "Limited pipe...~n") (start "Limited pipe...\n")
(define-values (r w) (make-pipe 253)) (define-values (r w) (make-pipe 253))
(thread (lambda () (thread (lambda ()
(feed-file w) (feed-file w)
@ -201,7 +201,7 @@
(check-file r) (check-file r)
(end) (end)
(start "Limited pipe, faster...~n") (start "Limited pipe, faster...\n")
(define-values (r w) (make-pipe 253)) (define-values (r w) (make-pipe 253))
(thread (lambda () (thread (lambda ()
(feed-file/fast w) (feed-file/fast w)
@ -209,7 +209,7 @@
(check-file/fast r) (check-file/fast r)
(end) (end)
(start "Limited pipe, fastest...~n") (start "Limited pipe, fastest...\n")
(define-values (r w) (make-pipe 253)) (define-values (r w) (make-pipe 253))
(thread (lambda () (thread (lambda ()
(feed-file/fast w) (feed-file/fast w)
@ -217,8 +217,8 @@
(check-file/fastest r) (check-file/fastest r)
(end) (end)
(start "To file and back:~n") (start "To file and back:\n")
(start " to...~n") (start " to...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate)) (define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p))) (define t (thread (copy-stream r p)))
@ -228,7 +228,7 @@
(close-output-port p) (close-output-port p)
(end) (end)
(start " back...~n") (start " back...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define p (open-input-file tmp-file)) (define p (open-input-file tmp-file))
(define t (thread (copy-stream p w))) (define t (thread (copy-stream p w)))
@ -238,8 +238,8 @@
(check-file r) (check-file r)
(end) (end)
(start "To file and back, faster:~n") (start "To file and back, faster:\n")
(start " to...~n") (start " to...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate)) (define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p))) (define t (thread (copy-stream r p)))
@ -249,7 +249,7 @@
(close-output-port p) (close-output-port p)
(end) (end)
(start " back...~n") (start " back...\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define p (open-input-file tmp-file)) (define p (open-input-file tmp-file))
(define t (thread (copy-stream p w))) (define t (thread (copy-stream p w)))
@ -259,7 +259,7 @@
(check-file/fast r) (check-file/fast r)
(end) (end)
(start "File back, fastest:~n") (start "File back, fastest:\n")
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define p (open-input-file tmp-file)) (define p (open-input-file tmp-file))
(define t (thread (copy-stream p w))) (define t (thread (copy-stream p w)))
@ -269,7 +269,7 @@
(check-file/fastest r) (check-file/fastest r)
(end) (end)
(start "Echo...~n") (start "Echo...\n")
(define p (setup-mzscheme-echo #f)) (define p (setup-mzscheme-echo #f))
(thread (lambda () (thread (lambda ()
(feed-file (cadr p)) (feed-file (cadr p))
@ -277,7 +277,7 @@
(check-file (car p)) (check-file (car p))
(end) (end)
(start "Echo, faster...~n") (start "Echo, faster...\n")
(define p (setup-mzscheme-echo #f)) (define p (setup-mzscheme-echo #f))
(thread (lambda () (thread (lambda ()
(feed-file/fast (cadr p)) (feed-file/fast (cadr p))
@ -285,7 +285,7 @@
(check-file/fast (car p)) (check-file/fast (car p))
(end) (end)
(start "Echo, indirect...~n") (start "Echo, indirect...\n")
(define p (setup-mzscheme-echo #f)) (define p (setup-mzscheme-echo #f))
(define-values (rp1 wp1) (make-pipe)) (define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe)) (define-values (rp2 wp2) (make-pipe))
@ -300,7 +300,7 @@
(define l1 (tcp-listen portno 5 #t)) (define l1 (tcp-listen portno 5 #t))
(define l2 (tcp-listen (add1 portno) 5 #t)) (define l2 (tcp-listen (add1 portno) 5 #t))
(start "TCP Echo...~n") (start "TCP Echo...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t)) (define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r) (close-input-port r)
(thread (lambda () (thread (lambda ()
@ -310,7 +310,7 @@
(close-input-port r2) (close-input-port r2)
(end) (end)
(start "TCP Echo, faster...~n") (start "TCP Echo, faster...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t)) (define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r) (close-input-port r)
(thread (lambda () (thread (lambda ()
@ -320,7 +320,7 @@
(close-input-port r2) (close-input-port r2)
(end) (end)
(start "TCP Echo, indirect...~n") (start "TCP Echo, indirect...\n")
(define-values (rp1 wp1) (make-pipe)) (define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe)) (define-values (rp2 wp2) (make-pipe))
(define-values (r w r2 w2) (setup-mzscheme-echo #t)) (define-values (r w r2 w2) (setup-mzscheme-echo #t))

16
collects/tests/racket/subprocess.rktl
View File

@ -23,7 +23,7 @@
;; Simple `process' tests using "cat" ;; Simple `process' tests using "cat"
(let ([p (process* cat)]) (let ([p (process* cat)])
(fprintf (cadr p) "Hello~n") (fprintf (cadr p) "Hello\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
(test "Hello" read-line (car p)) (test "Hello" read-line (car p))
(test eof read-line (car p)) (test eof read-line (car p))
@ -38,7 +38,7 @@
;; Generate output to stderr as well as stdout ;; Generate output to stderr as well as stdout
(let ([p (process* cat "-" "nosuchfile")]) (let ([p (process* cat "-" "nosuchfile")])
(fprintf (cadr p) "Hello~n") (fprintf (cadr p) "Hello\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
(test "Hello" read-line (car p)) (test "Hello" read-line (car p))
(test eof read-line (car p)) (test eof read-line (car p))
@ -58,7 +58,7 @@
(let ([p (process*/ports f #f #f cat)]) (let ([p (process*/ports f #f #f cat)])
(test #f car p) (test #f car p)
(fprintf (cadr p) "Hello~n") (fprintf (cadr p) "Hello\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
(test eof read-line (cadddr p)) (test eof read-line (cadddr p))
@ -78,7 +78,7 @@
(test #f car p) (test #f car p)
(test #f cadddr p) (test #f cadddr p)
(fprintf (cadr p) "Hello~n") (fprintf (cadr p) "Hello\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
((list-ref p 4) 'wait) ((list-ref p 4) 'wait)
@ -132,7 +132,7 @@
(test #f car p) (test #f car p)
(test #f cadddr p) (test #f cadddr p)
(fprintf (cadr p) "First line~n") (fprintf (cadr p) "First line\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
((list-ref p 4) 'wait) ((list-ref p 4) 'wait)
@ -153,7 +153,7 @@
(test #f car p) (test #f car p)
(test #f cadddr p) (test #f cadddr p)
(fprintf (cadr p) "The line~n") (fprintf (cadr p) "The line\n")
(close-output-port (cadr p)) (close-output-port (cadr p))
((list-ref p 4) 'wait) ((list-ref p 4) 'wait)
@ -175,7 +175,7 @@
;; Supply file for stdin ;; Supply file for stdin
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]) (let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
(fprintf f "Howdy~n") (fprintf f "Howdy\n")
(close-output-port f)) (close-output-port f))
(let ([f (open-input-file tmpfile)]) (let ([f (open-input-file tmpfile)])
(let ([p (process*/ports #f f #f cat)]) (let ([p (process*/ports #f f #f cat)])
@ -256,7 +256,7 @@
"(let loop () (unless (eof-object? (eval (read))) (loop)))"))) "(let loop () (unless (eof-object? (eval (read))) (loop)))")))
(define (test-line out in) (define (test-line out in)
(fprintf w "~a~n" in) (fprintf w "~a\n" in)
(flush-output w) (flush-output w)
(when out (when out
(test out (lambda (ignored) (read-line r)) in))) (test out (lambda (ignored) (read-line r)) in)))

14
collects/tests/racket/tcp.rktl
View File

@ -17,7 +17,7 @@
(define (tread connect) (define (tread connect)
(let-values ([(r w close) (connect)]) (let-values ([(r w close) (connect)])
(printf "Hit return to start reading~n") (printf "Hit return to start reading\n")
(read-line) (read-line)
(let loop ([last -1]) (let loop ([last -1])
(let ([v (read r)]) (let ([v (read r)])
@ -29,9 +29,9 @@
last) last)
(begin (begin
(unless (= v (add1 last)) (unless (= v (add1 last))
(printf "skipped! ~a ~a~n" last v)) (printf "skipped! ~a ~a\n" last v))
(when (zero? (modulo v print-mod)) (when (zero? (modulo v print-mod))
(printf "got ~a~n" v)) (printf "got ~a\n" v))
(loop v))))))) (loop v)))))))
(define (twrite connect) (define (twrite connect)
@ -39,7 +39,7 @@
[(t) (thread (lambda () [(t) (thread (lambda ()
(let loop () (let loop ()
(sleep 1) (sleep 1)
(printf "tick~n") (printf "tick\n")
(loop))))]) (loop))))])
(let ([done (lambda () (let ([done (lambda ()
(close-output-port w) (close-output-port w)
@ -49,11 +49,11 @@
(let loop ([n 0]) (let loop ([n 0])
(if (= n max-send) (if (= n max-send)
(begin (begin
(printf "stopped before ~a~n" n) (printf "stopped before ~a\n" n)
(done)) (done))
(begin (begin
(fprintf w "~s~n" n) (fprintf w "~s\n" n)
(when (zero? (modulo n print-mod)) (when (zero? (modulo n print-mod))
(printf "sent ~a~n" n)) (printf "sent ~a\n" n))
(loop (add1 n)))))))) (loop (add1 n))))))))

4
collects/tests/racket/ttt/tic-bang.rktl
View File

@ -53,9 +53,9 @@
(define make-move (define make-move
(lambda (other-move p/o tag) (lambda (other-move p/o tag)
(lambda (states) (lambda (states)
(printf "~s: processing ~s states ~n" tag (length states)) (printf "~s: processing ~s states \n" tag (length states))
(let ((t (print&remove-terminals states))) (let ((t (print&remove-terminals states)))
(printf "terminal states removed: ~s~n" (printf "terminal states removed: ~s\n"
(- (length states) (length t))) (- (length states) (length t)))
(if (null? t) (if (null? t)
(void) (void)

8
collects/tests/racket/ttt/tic-func.rktl
View File

@ -29,10 +29,10 @@
(define make-move (define make-move
(lambda (other-move p/o tag) (lambda (other-move p/o tag)
(lambda (states) (lambda (states)
(printf "~s: processing ~s states of length ~s ~n" (printf "~s: processing ~s states of length ~s \n"
tag (length states) (length (car states))) tag (length states) (length (car states)))
(let ((t (print&remove-terminals states))) (let ((t (print&remove-terminals states)))
(printf "terminal states removed: ~s~n" (printf "terminal states removed: ~s\n"
(- (length states) (length t))) (- (length states) (length t)))
(if (null? t) (if (null? t)
(void) (void)
@ -85,10 +85,10 @@
(define print-state2 (define print-state2
(lambda (astate) (lambda (astate)
(cond (cond
((null? astate) (printf "------------~n")) ((null? astate) (printf "------------\n"))
(else (print-state (cdr astate)) (else (print-state (cdr astate))
(let ((x (car astate))) (let ((x (car astate)))
(printf " ~s @ (~s,~s) ~n" (printf " ~s @ (~s,~s) \n"
(entry-who x) (entry-x x) (entry-y x))))))) (entry-who x) (entry-x x) (entry-y x)))))))
(define print-state (define print-state

22
collects/tests/racket/ztest.rktl
View File

@ -5,16 +5,16 @@
(define ztest (define ztest
(lambda (z) (lambda (z)
(printf "z = ~a~n" z) (printf "z = ~a\n" z)
(printf " zabs(z) = ~a~n" (zabs z)) (printf " zabs(z) = ~a\n" (zabs z))
(printf " zlog(z) = ~a~n" (zlog z)) (printf " zlog(z) = ~a\n" (zlog z))
(printf " zexp(z) = ~a~n" (zexp z)) (printf " zexp(z) = ~a\n" (zexp z))
(printf " zsqrt(z) = ~a~n" (zsqrt z)) (printf " zsqrt(z) = ~a\n" (zsqrt z))
(printf " zsin(z) = ~a~n" (zsin z)) (printf " zsin(z) = ~a\n" (zsin z))
(printf " zcos(z) = ~a~n" (zcos z)) (printf " zcos(z) = ~a\n" (zcos z))
(printf " ztan(z) = ~a~n" (ztan z)) (printf " ztan(z) = ~a\n" (ztan z))
(printf " zasin(z) = ~a~n" (zasin z)) (printf " zasin(z) = ~a\n" (zasin z))
(printf " zacos(z) = ~a~n" (zacos z)) (printf " zacos(z) = ~a\n" (zacos z))
(printf " zatan(z) = ~a~n" (zatan z)))) (printf " zatan(z) = ~a\n" (zatan z))))
(ztest 0.5) (ztest 0.5)

93
collects/tests/srpersist/srptests.rktl
View File

@ -102,87 +102,12 @@
(define bi (make-boxed-uint 42)) (define bi (make-boxed-uint 42))
(printf "~a~n" results-1) (printf "~a\n" results-1)
(printf "~a~n" results-2) (printf "~a\n" results-2)
(printf "~a~n" results-3) (printf "~a\n" results-3)
(printf "~a~n" ind-result-1) (printf "~a\n" ind-result-1)
(printf "~a~n" ind-result-2) (printf "~a\n" ind-result-2)
(printf "~a~n" ind-result-3) (printf "~a\n" ind-result-3)
(printf "~a~n" ind-result-4) (printf "~a\n" ind-result-4)
(printf "~a~n" (read-boxed-uint bi)) (printf "~a\n" (read-boxed-uint bi))

10
collects/tests/utils/mz-testing.rkt
View File

@ -226,9 +226,9 @@
(let ([v (with-handlers ([void (let ([v (with-handlers ([void
(lambda (exn) (lambda (exn)
(if (check? exn) (if (check? exn)
(printf " ~a~n" (exn-message exn)) (printf " ~a\n" (exn-message exn))
(let ([ok-type? (exn:application:arity? exn)]) (let ([ok-type? (exn:application:arity? exn)])
(printf " WRONG EXN ~a: ~s~n" (printf " WRONG EXN ~a: ~s\n"
(if ok-type? (if ok-type?
"FIELD" "FIELD"
"TYPE") "TYPE")
@ -240,7 +240,7 @@
(cons f args))))) (cons f args)))))
(done (void)))]) (done (void)))])
(apply f args))]) (apply f args))])
(printf "~s~n BUT EXPECTED ERROR~n" v) (printf "~s\n BUT EXPECTED ERROR\n" v)
(record-error (list v 'Error (cons f args))))))]) (record-error (list v 'Error (cons f args))))))])
(let loop ([n 0][l '()]) (let loop ([n 0][l '()])
(unless (>= n min) (unless (>= n min)
@ -265,11 +265,11 @@
(test l call-with-values thunk list)) (test l call-with-values thunk list))
(define (report-errs) (define (report-errs)
(printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n" (printf "\nPerformed ~a expression tests (~a good expressions, ~a bad expressions)\n"
(+ number-of-tests number-of-error-tests) (+ number-of-tests number-of-error-tests)
number-of-tests number-of-tests
number-of-error-tests) number-of-error-tests)
(printf "and ~a exception field tests.~n~n" (printf "and ~a exception field tests.\n\n"
number-of-exn-tests) number-of-exn-tests)
(if (null? errs) (if (null? errs)
(display "Passed all tests.") (display "Passed all tests.")

38
collects/tests/web-server/lang-test.rkt
View File

@ -104,9 +104,9 @@
(module m03 (lib "lang.rkt" "web-server") (module m03 (lib "lang.rkt" "web-server")
(provide start) (provide start)
(define (start x) (define (start x)
(begin (printf "Before~n") (begin (printf "Before\n")
(values 1 x) (values 1 x)
(printf "After~n") (printf "After\n")
x))))]) x))))])
(check = 3 (test `(dispatch-start start 3))))) (check = 3 (test `(dispatch-start start 3)))))
@ -118,9 +118,9 @@
(provide start) (provide start)
(define (start x) (define (start x)
(begin0 x (begin0 x
(printf "Before~n") (printf "Before\n")
(values 1 x) (values 1 x)
(printf "After~n")))))]) (printf "After\n")))))])
(check = 3 (test `(dispatch-start start 3))))) (check = 3 (test `(dispatch-start start 3)))))
(test-case (test-case
@ -132,9 +132,9 @@
(define (start x) (define (start x)
(let-values ([(_ ans) (let-values ([(_ ans)
(begin0 (values 1 x) (begin0 (values 1 x)
(printf "Before~n") (printf "Before\n")
x x
(printf "After~n"))]) (printf "After\n"))])
ans))))]) ans))))])
(check = 3 (test `(dispatch-start start 3)))))) (check = 3 (test `(dispatch-start start 3))))))
@ -229,18 +229,18 @@
(cadr (cadr
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)]) (let ([ignore (printf "Please send the ~a number.\n" which)])
(store-k k)))))) (store-k k))))))
(define (start ignore) (define (start ignore)
(let ([result (+ (gn "first") (gn "second"))]) (let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s\n" result)])
result))))) result)))))
(table-01-eval '(require 'm06)) (table-01-eval '(require 'm06))
(let* ([first-key (table-01-eval '(dispatch-start start 'foo))] (let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
[second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))] [second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
[third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))]) [third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
#;(printf "~S~n" (list first-key second-key third-key)) #;(printf "~S\n" (list first-key second-key third-key))
(check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2)))) (check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2))))
(check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3)))) (check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1))))) (check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
@ -258,12 +258,12 @@
(cadr (cadr
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)]) (let ([ignore (printf "Please send the ~a number.\n" which)])
k))))) k)))))
(define (start ignore) (define (start ignore)
(let ([result (+ (gn "first") (gn "second"))]) (let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s\n" result)])
result)))))]) result)))))])
(let* ([first-key (test-m06.1 '(dispatch-start start 'foo))] (let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
[second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))] [second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
@ -285,12 +285,12 @@
(cadr (cadr
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)]) (let ([ignore (printf "Please send the ~a number.\n" which)])
k))))) k)))))
(define (start ignore) (define (start ignore)
(let ([result (+ (gn #:page "first") (gn #:page "second"))]) (let ([result (+ (gn #:page "first") (gn #:page "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s\n" result)])
result)))))]) result)))))])
(let* ([first-key (test-m06.2 '(dispatch-start start 'foo))] (let* ([first-key (test-m06.2 '(dispatch-start start 'foo))]
[second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))] [second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
@ -382,7 +382,7 @@
(cadr (cadr
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)]) (let ([ignore (printf "Please send the ~a number.\n" which)])
k))))) k)))))
(define (start ignore) (define (start ignore)
@ -391,7 +391,7 @@
[g (let ([n (gn "second")]) [g (let ([n (gn "second")])
(lambda (m) (+ n (f m))))]) (lambda (m) (+ n (f m))))])
(let ([result (g (gn "third"))]) (let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s\n" result)])
result))))))]) result))))))])
(let* ([k0 (test-m08 '(serialize (dispatch-start start 'foo)))] (let* ([k0 (test-m08 '(serialize (dispatch-start start 'foo)))]
[k1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))] [k1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))]
@ -416,7 +416,7 @@
(define (non-tail-apply f . args) (define (non-tail-apply f . args)
(let ([result (apply f args)]) (let ([result (apply f args)])
(printf "result = ~s~n" result) (printf "result = ~s\n" result)
result))))]) result))))])
(nta-eval '(module m09 (lib "lang.rkt" "web-server") (nta-eval '(module m09 (lib "lang.rkt" "web-server")
(require 'nta) (require 'nta)
@ -438,7 +438,7 @@
(provide start) (provide start)
(define (nta f arg) (define (nta f arg)
(let ([result (f arg)]) (let ([result (f arg)])
(printf "result = ~s~n" result) (printf "result = ~s\n" result)
result)) result))
(define (start ignore) (define (start ignore)
(nta (lambda (x) (let/cc k (k x))) 7))))]) (nta (lambda (x) (let/cc k (k x))) 7))))])
@ -493,7 +493,7 @@
(map (map
(lambda (n) (call-with-serializable-current-continuation (lambda (n) (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "n = ~s~n" n)]) (let ([ignore (printf "n = ~s\n" n)])
k)))) k))))
(list 1 2 3)))))]) (list 1 2 3)))))])
(check-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
@ -519,7 +519,7 @@
(cadr (cadr
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(let ([ignore (printf "n = ~s~n" n)]) (let ([ignore (printf "n = ~s\n" n)])
k))))) 7))))) k))))) 7)))))
(ta-eval '(require 'm14)) (ta-eval '(require 'm14))

2
collects/tests/web-server/lang/anormal-test.rkt
View File

@ -99,7 +99,7 @@
(define (alpha= expr1 expr2) (define (alpha= expr1 expr2)
(define r (alpha=/env empty-env empty-env expr1 expr2)) (define r (alpha=/env empty-env empty-env expr1 expr2))
(unless r (unless r
(error 'alpha= "Not alpha=:\t~S~n\t~S~n" (syntax->datum expr1) (syntax->datum expr2))) (error 'alpha= "Not alpha=:\t~S\n\t~S\n" (syntax->datum expr1) (syntax->datum expr2)))
r) r)
(define normalize-term (make-anormal-term (lambda _ (error 'anormal "No elim-letrec given.")))) (define normalize-term (make-anormal-term (lambda _ (error 'anormal "No elim-letrec given."))))

10
collects/tests/web-server/util.rkt
View File

@ -88,7 +88,7 @@
[(list _ s) [(list _ s)
(string->xexpr (bytes->string/utf-8 s))] (string->xexpr (bytes->string/utf-8 s))]
[_ [_
(error 'html "Given ~S~n" bs)])) (error 'html "Given ~S\n" bs)]))
; This causes infinite loop. I will try putting it in a thread like on the real server ; This causes infinite loop. I will try putting it in a thread like on the real server
#;(define (collect d req) #;(define (collect d req)
@ -108,14 +108,14 @@
; This causes a dead lock, even though the log shows that the channel should sync ; This causes a dead lock, even though the log shows that the channel should sync
(define (channel-put* c v) (define (channel-put* c v)
(printf "+CHAN ~S PUT: ~S~n" c v) (printf "+CHAN ~S PUT: ~S\n" c v)
(channel-put c v) (channel-put c v)
(printf "-CHAN ~S PUT: ~S~n" c v)) (printf "-CHAN ~S PUT: ~S\n" c v))
(define (channel-get* c) (define (channel-get* c)
(printf "+CHAN ~S GET~n" c) (printf "+CHAN ~S GET\n" c)
(let ([v (channel-get c)]) (let ([v (channel-get c)])
(printf "-CHAN ~S GET: ~S~n" c v) (printf "-CHAN ~S GET: ~S\n" c v)
v)) v))
#;(define (collect d req) #;(define (collect d req)

10
collects/texpict/private/texpict-extra.rkt
View File

@ -426,22 +426,22 @@
(let ([tag (car s)]) (let ([tag (car s)])
(case tag (case tag
[(local) [(local)
(format "{~a}~n" (output (cadr s)))] (format "{~a}\n" (output (cadr s)))]
[(begin) [(begin)
(apply string-append (map output (cdr s)))] (apply string-append (map output (cdr s)))]
[(picture) [(picture)
(format "\\begin{picture}(~a,~a)~n~a\\end{picture}~n" (format "\\begin{picture}(~a,~a)\n~a\\end{picture}\n"
(cadr s) (caddr s) (cadr s) (caddr s)
(apply string-append (map output (cdddr s))))] (apply string-append (map output (cdddr s))))]
[(color) [(color)
(format "\\special{color push ~a}~n~a\\special{color pop}~n" (format "\\special{color push ~a}\n~a\\special{color pop}\n"
(cadr s) (output (cddr s)))] (cadr s) (output (cddr s)))]
[(thickness) [(thickness)
(format "\\~a~a" (cadr s) (output (caddr s)))] (format "\\~a~a" (cadr s) (output (caddr s)))]
[(put) [(put)
(format "\\put(~a,~a){~a}~n" (cadr s) (caddr s) (output (cadddr s)))] (format "\\put(~a,~a){~a}\n" (cadr s) (caddr s) (output (cadddr s)))]
[(qbezier) [(qbezier)
(apply format "\\qbezier~a(~a,~a)(~a,~a)(~a,~a)~n" (apply format "\\qbezier~a(~a,~a)(~a,~a)(~a,~a)\n"
(if (cadr s) (if (cadr s)
(format "[~a]" (cadr s)) (format "[~a]" (cadr s))
"") "")

Some files were not shown because too many files have changed in this diff Show More