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))))
(define (printsln k v)
(k (printf "~a~n" (get-string 'printsln v))))
(k (printf "~a\n" (get-string 'printsln 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)
(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)))
(current-compile (make-errortrace-compile-handler))
(with-handlers ([void (lambda (x)
(printf "~a~n"
(printf "~a\n"
(exn-message x)))])
(namespace-attach-module n path)
(namespace-require path))))))

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

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

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

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

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

@ -62,13 +62,13 @@
build)])
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
#;(printf "terminal ~a~n" name)
#;(printf "terminal ~a\n" name)
#;(cond
[(eq? input return-name) (printf "name requested~n")]
[(null? input) (printf "null input~n")]
[(eq? input return-name) (printf "name requested\n")]
[(null? input) (printf "null input\n")]
[else
(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
[(eq? input return-name) name]
[(eq? input terminal-occurs) (list (make-occurs name 1))]
@ -87,7 +87,7 @@
(cdr input) name
(value curr-input) 1 #f curr-input)]
[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
[(token-value token) (token-value token)]
[else (token-name token)])
@ -135,7 +135,7 @@
[my-error (sequence-error-gen name sequence-length)]
[my-walker (seq-walker id-position name my-error)])
(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
[(eq? input return-name) name]
[(eq? input terminal-occurs)
@ -158,8 +158,8 @@
[(pair? pre-build-ans) (map builder pre-build-ans)]
[else pre-build-ans])])
(weak-map-put! memo-table input ans)
#;(printf "sequence ~a returning ~n" name)
#;(printf "answer is ~a ~n" ans)
#;(printf "sequence ~a returning \n" name)
#;(printf "answer is ~a \n" ans)
ans)])))))
;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))
(position-token-end-pos (res-first-tok old-result)))
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)
(and (res? rsts) (res-a 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))
(flatten (correct-list 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
(update-possible-fail rst rsts)))
(flatten (correct-list (choice-res-matches rsts))))]
@ -247,37 +247,37 @@
(cond
[(null? subs) (error 'end-of-subs)]
[(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))
(build-error (curr-pred input last-src)
(lambda () (previous? input))
(previous? return-name) #f
look-back look-back-ref used curr-id seen alts last-src)]
[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))
(let ([fst (curr-pred input last-src)])
(cond
[(res? fst)
#;(printf "res case ~a ~a~n" seq-name (length seen))
#;(printf "res case ~a ~a\n" seq-name (length seen))
(cond
[(res-a fst) (next-call fst fst fst (res-msg fst)
(and id-spot? (res-id fst))
(res-first-tok fst) alts)]
[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))
(previous? return-name)
(car next-preds) look-back look-back-ref used curr-id
seen alts last-src)])]
[(repeat-res? fst)
#;(printf "repeat-res: ~a ~a~n" seq-name (length seen))
#;(printf "res? ~a~n" (res? (repeat-res-a fst)))
#;(printf "repeat-res: ~a ~a\n" seq-name (length seen))
#;(printf "res? ~a\n" (res? (repeat-res-a fst)))
(next-call (repeat-res-a fst) fst fst
(res-msg (repeat-res-a fst)) #f
(res-first-tok (repeat-res-a fst)) alts)]
[(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
(make-options-fail 0 last-src seq-name 0 0 null)
null)]
@ -285,11 +285,11 @@
[next-c (lambda (res)
(cond
[(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))
(res-first-tok res) alts)]
[(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))
(next-call (repeat-res-a res) res (repeat-res-a res)
(res-msg (repeat-res-a res)) #f
@ -313,7 +313,7 @@
(fail-res input (lazy-opts-errors opt-r))))
]
[(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
([(lst name curr)
(cond
@ -327,12 +327,12 @@
(map (lambda (res)
(cond
[(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)
(and id-spot? (res-id res))
(res-first-tok res) new-alts)]
[(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))
(next-call (repeat-res-a res) res (repeat-res-a res)
(res-msg (repeat-res-a res)) #f
@ -341,12 +341,12 @@
[else (error 'parser-internal-error4 (format "~a" res))]))
(flatten lst))]
[(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)
(cond
[(and (null? correct-rsts) (or (not (lazy-choice? 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
(map
(lambda (rst)
@ -418,7 +418,7 @@
;update-possible-rail result result -> result
(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
[(and (res? res) (not (res-possible-error res)))
(cond
@ -449,18 +449,18 @@
[(and (repeat-res? rpt) (res? (repeat-res-a rpt)))
(let ([inn (repeat-res-a 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)
(printf "stoped on ~a~n" (fail-type-name stop)))
#;(printf "stop ~a~n" stop)
(printf "stoped on ~a\n" (fail-type-name stop)))
#;(printf "stop ~a\n" stop)
#;(when (choice-res? back)
(printf "back on ~a~n" (choice-res-name back)))
#;(when (choice-res? back) (printf "choice-res-errors back ~a~n"
(printf "back on ~a\n" (choice-res-name back)))
#;(when (choice-res? back) (printf "choice-res-errors back ~a\n"
(choice-res-errors back)))
#;(when (and (fail-type? stop)
(choice-res? 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 stop)
(>= (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))
(update-possible-fail old-res look-back)]
[(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)]
[(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))]
[else
#;(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 "There was an error for ~a\n" name)
#;(printf "length seen ~a length rest ~a\n" (length seen) (length (res-rest old-res)))
(fail-res (res-rest old-res)
(let*-values ([(fail) (res-msg old-res)]
[(possible-fail)
@ -534,35 +534,35 @@
(res-first-tok old-res))]
[(seen-len) (length seen)]
[(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)
(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))
(and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back)))
(fail-type-name (res-msg old-res))
(and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back)))
(fail-type-chance (res-msg old-res))))
#;(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)
(fail-type-name (res-msg old-res))
(and (choice-res-errors look-back)
(fail-type-chance (choice-res-errors look-back)))
(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))
(and (choice-res-errors look-back)
(fail-type-used (choice-res-errors look-back)))))
#;(when (pair? look-back)
(printf "look-back is a pair~n"))
(printf "look-back is a pair\n"))
#;(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))
(and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back)))
(fail-type-name (res-msg old-res))
(and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back)))
(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
(lambda (fail used)
(let-values ([(kind expected found) (get-fail-info fail)])
@ -584,12 +584,12 @@
(res? look-back-ref))
(- used (res-used look-back-ref)) used)))]
[opt-fails (list seq-fail pos-fail)])
#;(printf "pos-fail? ~a~n" (and pos-fail #t))
#;(printf "seq-fail ~a~n" seq-fail)
#;(printf "pos-fail? ~a\n" (and pos-fail #t))
#;(printf "seq-fail ~a\n" seq-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)))
(printf "opt-fails ~a~n" opt-fails))
(printf "opt-fails ~a\n" opt-fails))
(if pos-fail
(make-options-fail (rank-choice (map fail-type-chance opt-fails))
(map fail-type-src opt-fails)
@ -611,18 +611,18 @@
(* expected-no-sub (- 1 sub-chance))))])
#;(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
(* (/ 1 num-alts) sub-chance)))
(cond
#;[(zero? used-toks) (* (/ 1 num-alts) sub-chance)]
[(zero? used-toks) sub-chance #;probability-with-sub]
[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)
#;(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)
#;(printf "compute-chance answer ~a~n" probability)
#;(printf "compute-chance answer ~a\n" probability)
probability])))
;greedy-repeat: (list 'a) -> result -> (list 'a) -> result
@ -634,7 +634,7 @@
(lambda (curr-ans rest-ans)
(cond
[(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
[(res? curr-ans)
(let* ([a (res-a curr-ans)]
@ -643,7 +643,7 @@
(lambda (r)
(cond
[(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-res (append a (res-a r)) (res-rest r) (repeat-name) #f
(+ (res-used curr-ans) (res-used r))
@ -653,10 +653,10 @@
(error 'parser-internal-error9 (format "~a" r))]))])
(cond
[(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))]
[(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))]
[else (repeat-build rest)]))]
[else (error 'parser-internal-error12 (format "~a" curr-ans))])]
@ -678,24 +678,24 @@
[else
(let ([ans
(let loop ([curr-input input] [curr-src start-src])
#;(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 "length of curr-input for ~a ~a\n" repeat-name (length curr-input))
#;(printf "curr-input ~a\n" (map position-token-token curr-input))
(cond
[(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table 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)]
[else
(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
[(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
(loop (res-rest this-res)
(update-src (res-rest this-res) curr-src)))]
[(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
(cond
[(choice-fail? (res-msg this-res)) 'choice]
@ -708,7 +708,7 @@
(weak-map-put! inner-memo-table curr-input fail)
fail)]
[(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)
(res-rest (repeat-res-a this-res)))]
[(lazy-opts? this-res)
@ -728,7 +728,7 @@
[(or (choice-res? this-res) (pair? this-res))
(let ([list-of-answer
(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
(and (choice-res? this-res)
(length list-of-answer)))
@ -740,7 +740,7 @@
curr-src)))]
[else
(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)))
(process-rest match
(loop (res-rest match)
@ -748,7 +748,7 @@
list-of-answer)]))]
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
(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)]))))
;choice: [list [[list 'a ] -> result]] name -> result
@ -758,8 +758,8 @@
[num-choices (length 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])
#;(unless (eq? input return-name) (printf "choice ~a~n" name))
#;(printf "possible options are ~a~n" (choice-names))
#;(unless (eq? input return-name) (printf "choice ~a\n" name))
#;(printf "possible options are ~a\n" (choice-names))
(let ([sub-opts (sub1 (+ alts num-choices))])
(cond
[(eq? input return-name) name]
@ -772,11 +772,11 @@
terminal-counts))]
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
[else
#;(printf "choice ~a~n" name)
#;(printf "possible options are ~a~n" (choice-names))
#;(printf "choice ~a\n" name)
#;(printf "possible options are ~a\n" (choice-names))
(let*-values
([(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)
(cond
[(res? x) (res-msg x)]
@ -806,9 +806,9 @@
(cond
[(null? corrects) (fail-res input (fail-builder fails))]
[else (make-choice-res name corrects (fail-builder errors))])])
#;(printf "choice ~a is returning options were ~a ~n" name (choice-names))
#;(printf "corrects were ~a~n" corrects)
#;(printf "errors were ~a~n" errors)
#;(printf "choice ~a is returning options were ~a \n" name (choice-names))
#;(printf "corrects were ~a\n" corrects)
#;(printf "errors were ~a\n" errors)
(weak-map-put! memo-table input ans) ans)])))))
;choice: [list [[list 'a ] -> result]] name -> result
@ -817,8 +817,8 @@
[num-choices (length 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])
#;(unless (eq? input return-name) (printf "choice ~a~n" name))
#;(printf "possible options are ~a~n" choice-names)
#;(unless (eq? input return-name) (printf "choice ~a\n" name))
#;(printf "possible options are ~a\n" choice-names)
(let ([sub-opts (sub1 (+ alts num-choices))])
(cond
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
@ -842,7 +842,7 @@
(if (next-opt initial-ans)
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)])))))
(define (flatten lst)

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

@ -24,7 +24,7 @@
(list? (car (fail-type-src fail-type))))
(car (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
[(terminal-fail? fail-type)
(collapse-message
@ -43,7 +43,7 @@
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
name #f message-to-date))]
[(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)]
[id-name
(if curr-id (string-append name " " (sequence-fail-id fail-type)) name)]
@ -54,7 +54,7 @@
[(end)
(collapse-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))
name curr-id message-to-date))]
[(wrong)
@ -95,7 +95,7 @@
name curr-id message-to-date))]
[(sub-seq choice)
(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))]
[(options)
(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))
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
(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))
(fail-type-name (car sorted-opts))))
name (sequence-fail-id fail-type) message-to-date))))]))]
[(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))]
[top-names (map fail-type-name winners)]
[non-dup-tops (remove-dups top-names name)]
@ -122,7 +122,7 @@
(> (length winners) max-choice-depth))
(collapse-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 #f message-to-date))]
[(and (> (length winners) 1)
@ -138,7 +138,7 @@
[else msg])])
(collapse-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
(alternate-error-list (map err-msg messages))))
name #f message-to-date)))]))]
@ -147,13 +147,13 @@
(car winners)
(add-to-message
(msg
(format "There is an error in this ~a~a.~n"
(format "There is an error in this ~a~a.\n"
name
(if (equal? top-name name) ""
(format ", program resembles ~a ~a" (a/an top-name) top-name))))
name #f message-to-date))]))]
[(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))]
[top-names (map fail-type-name winners)]
[top-name (car top-names)]
@ -190,7 +190,7 @@
[else
(collapse-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)
(alternate-error-list (map err-msg messages))))
name #f message-to-date))]))]
@ -198,7 +198,7 @@
(> (length winners) 1))
(collapse-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
(first-n max-choice-depth no-dup-names))))
name #f message-to-date))]
@ -206,7 +206,7 @@
(fail-type->message
(car winners)
(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
(if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here"
(a/an top-name) top-name))
@ -233,17 +233,17 @@
(narrow-opts chance-may-use chance-used-winners)]
[winners (narrow-opts chance chance-may-winners)])
#;(printf "all options: ~a~n" opts-list)
#;(printf "~a ~a ~a ~a ~a~n"
#;(printf "all options: ~a\n" opts-list)
#;(printf "~a ~a ~a ~a ~a\n"
(map fail-type-name opts-list)
(map fail-type-chance opts-list)
(map fail-type-used opts-list)
(map fail-type-may-use 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 composite composite-winners))
#;(printf "final sorting: ~a~n" (map fail-type-name winners))
#;(printf "final sorting: ~a\n" (map fail-type-name winners))
winners))
(define (first-n n lst)
@ -300,7 +300,7 @@
(let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l)))))
(substring (car l) 0 (sub1 (string-length (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))))]))
(define (downcase string)

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

@ -82,7 +82,7 @@
(define (next-opt lc)
(letrec ([next
(lambda (lc update-errors)
#;(printf "next-opt ~a~n" lc)
#;(printf "next-opt ~a\n" lc)
(cond
[(null? (lazy-opts-thunks lc)) #f]
[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.
(begin
(when verbose?
(fprintf (current-error-port) "Getting ~s~n" filename))
(fprintf (current-error-port) "Getting ~s\n" filename))
(let ([code (get-module-code filename
"compiled"
compiler
@ -413,7 +413,7 @@
(cond
[(extension? code)
(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
(cons (make-mod filename module-path code
name prefix (string->symbol
@ -850,7 +850,7 @@
(quote ,(map (lambda (m)
(let ([p (extension-path (mod-code m))])
(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)
(mod-full-name m)
;; The program name isn't used. It just helps ensures that
@ -942,7 +942,7 @@
(unless (or (extension? (mod-code nc))
(eq? nc table-mod))
(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
`(current-module-declare-name
(make-resolved-module-path
@ -968,7 +968,7 @@
outp))))
(for-each (lambda (f)
(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
(lambda (i)
(copy-port i outp))))
@ -1071,7 +1071,7 @@
(check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
(let ([exe (find-exe mred? variant)])
(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?)
(cond
[(and mred? (eq? 'macosx (system-type)))
@ -1162,7 +1162,7 @@
#:exists 'append)
(values start (file-size dest-exe))))])
(when verbose?
(fprintf (current-error-port) "Setting command line~n"))
(fprintf (current-error-port) "Setting command line\n"))
(let ([start-s (number->string start)]
[end-s (number->string end)])
(let ([full-cmdline (append
@ -1180,7 +1180,7 @@
cmdline)])
(when collects-path-bytes
(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))
(cond
[osx?

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

@ -1165,9 +1165,9 @@
(begin
(when (compiler:option:verbose)
(compiler:warning ast "letrec will be rewritten with set!"))
(debug "rewriting letrec~n")
(debug "rewriting letrec\n")
(let ([new-ast (letrec->let+set! ast)])
(debug "reanalyzing...~n")
(debug "reanalyzing...\n")
(analyze! new-ast env inlined tail? wcm-tail?))))]
;;-----------------------------------------------------
@ -1288,7 +1288,7 @@
(lambda (why)
'(begin
(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)])
(if (zodiac:varref? v)
v

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

@ -222,7 +222,7 @@
(define s:expand-top-level-expressions!
(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
(let ([exprs (let ([failed? #f])
(let loop ([n 1])
@ -238,7 +238,7 @@
(cons sexp (loop (+ n 1))))))))])
(unless (null? compiler:messages) (when (compiler:option:verbose) (newline)))
(compiler:report-messages! #t)
(when verbose? (printf " expanding...~n"))
(when verbose? (printf " expanding...\n"))
(parameterize ([current-load-relative-directory input-directory])
(map (lambda (expr)
(let ([expanded ((if has-prefix?
@ -314,7 +314,7 @@
max-arity)
(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
children new-max-arity multi)
@ -492,7 +492,7 @@
[string (compiler:message-message message)])
(zodiac:print-start! (current-output-port) ast)
(printf
"~a: ~a~n"
"~a: ~a\n"
(cond
[(compiler:error-msg? message) "Error"]
[(compiler:warning-msg? message) "Warning"]
@ -503,9 +503,9 @@
(when (compiler:internal-error-msg? message)
(printf
(string-append
" please report the bug using Help Desk~n"
" or http://bugs.racket-lang.org/~n"
" and include a transcript in verbose mode~n")))))
" please report the bug using DrRacket\n"
" or http://bugs.racket-lang.org/\n"
" and include a transcript in verbose mode\n")))))
msgs)
(when (and stop-on-errors?
@ -521,7 +521,7 @@
(set! total-cpu-time (+ total-cpu-time cpu))
(set! total-real-time (+ total-real-time real))
(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))))
;;-----------------------------------------------------------------------------
@ -704,8 +704,8 @@
;; Extract stateless, phaseless core, leaving the rest of bytecode
;;
(when (compiler:option:verbose) (printf " extracting core expressions~n"))
(when (compiler:option:debug) (debug " = CORE =~n"))
(when (compiler:option:verbose) (printf " extracting core expressions\n"))
(when (compiler:option:debug) (debug " = CORE =\n"))
(let ([core-thunk
(lambda ()
@ -736,8 +736,8 @@
;; Run a preprocessing phase on the input
;;
(when (compiler:option:verbose) (printf " pre-processing and scanning for errors~n"))
(when (compiler:option:debug) (debug " = PREPHASE =~n"))
(when (compiler:option:verbose) (printf " pre-processing and scanning for errors\n"))
(when (compiler:option:debug) (debug " = PREPHASE =\n"))
(let ([prephase-thunk
(lambda ()
@ -758,7 +758,7 @@
(verbose-time prephase-thunk))
(compiler:report-messages! (not (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))
@ -766,8 +766,8 @@
;; A-normalize input
;;
(when (compiler:option:verbose) (printf " transforming to a-normal form~n"))
(when (compiler:option:debug) (debug " = ANORM =~n"))
(when (compiler:option:verbose) (printf " transforming to a-normal form\n"))
(when (compiler:option:debug) (debug " = ANORM =\n"))
(let ([anorm-thunk
(lambda ()
@ -784,9 +784,9 @@
;;
(when (compiler:option:verbose)
(printf " determining known bindings~n"))
(printf " determining known bindings\n"))
(when (compiler:option:debug)
(debug " = KNOWN =~n"))
(debug " = KNOWN =\n"))
; analyze top level expressions
(let ([known-thunk
@ -806,9 +806,9 @@
;;
(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)
(debug " = ANALYZE =~n"))
(debug " = ANALYZE =\n"))
; analyze top level expressions, cataloguing local variables
(compiler:init-define-lists!)
@ -840,9 +840,9 @@
;;
(when (compiler:option:verbose)
(printf " finding static procedures~n"))
(printf " finding static procedures\n"))
(when (compiler:option:debug)
(debug " = LIFT =~n"))
(debug " = LIFT =\n"))
(let ([lift-thunk s:lift])
(verbose-time lift-thunk))
@ -855,7 +855,7 @@
;;
(when (compiler:option:verbose)
(printf " closure conversion and explicit control transformation~n"))
(printf " closure conversion and explicit control transformation\n"))
(let ([closure-thunk
(lambda ()
@ -871,7 +871,7 @@
;;
(when (compiler:option:verbose)
(printf " closure->vehicle mapping~n"))
(printf " closure->vehicle mapping\n"))
(when (eq? (compiler:option:vehicles) 'vehicles:automatic)
(for-each
@ -885,7 +885,7 @@
(when (eq? (compiler:option:vehicles) 'vehicles:units)
(compiler:fatal-error
#f
"unit-wise vehicle mapping not currently supported~n"))
"unit-wise vehicle mapping not currently supported\n"))
(let ([vehicle-thunk
(lambda ()
(compiler:init-vehicles!)
@ -900,7 +900,7 @@
(when (compiler:option:verbose)
(printf
" choosing data representations~n"))
" choosing data representations\n"))
(let ([rep-thunk
(lambda ()
@ -936,8 +936,8 @@
;; we have to update the local variable set for each top-level
;; expression or code body.
(when (compiler:option:verbose) (printf " transforming to Virtual Machine form~n"))
(when (compiler:option:debug) (debug " = VMPHASE =~n"))
(when (compiler:option:verbose) (printf " transforming to Virtual Machine form\n"))
(when (compiler:option:debug) (debug " = VMPHASE =\n"))
(let ([vmphase-thunk
(lambda ()
@ -1018,7 +1018,7 @@
;;
;; 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
(lambda ()
@ -1064,7 +1064,7 @@
;; Virtual Machine -> ANSI C translation
;;
(when (compiler:option:verbose)
(printf " [emitting ~a C to \"~a\"]~n"
(printf " [emitting ~a C to \"~a\"]\n"
"ANSI"
c-output-path))
@ -1078,38 +1078,38 @@
;;value
(lambda ()
(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:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1~n"))
(when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1~n"))
(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:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 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)
""
"e"))
(unless (null? c-declares)
(fprintf c-port "~n/* c-declare literals */~n~n")
(fprintf c-port "\n/* c-declare literals */\n\n")
(for-each
(lambda (c-declare)
(fprintf c-port "~a~n" c-declare))
(fprintf c-port "~a\n" c-declare))
(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)
(fprintf c-port "~n/* c-lambda implementations */~n~n")
(fprintf c-port "\n/* c-lambda implementations */\n\n")
(for-each
(lambda (c-lambda)
(let ([name (car c-lambda)]
[body (cdr c-lambda)])
(fprintf c-port "Scheme_Object *~a(int argc, Scheme_Object **argv) {\n"
name)
(fprintf c-port "~a~n" body)
(fprintf c-port "}~n")))
(fprintf c-port "~a\n" body)
(fprintf c-port "}\n")))
(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-symbol-declarations! c-port)
(vm->c:emit-inexact-declarations! c-port)
@ -1138,27 +1138,27 @@
(newline c-port)
(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)
(fprintf c-port "}~n"))
(fprintf c-port "}\n"))
(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)
(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)
(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)
(fprintf c-port "}~n")
(fprintf c-port "}\n")
(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)
(fprintf c-port "}~n"))
(fprintf c-port "}\n"))
(newline c-port)
(let* ([codes (block-codes s:file-block)]
@ -1182,91 +1182,91 @@
#f #f ; no module entries
c-port)])
(fprintf c-port
"static Scheme_Object * do_scheme_reload(Scheme_Env * env)~n{~n")
(fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n"
"static Scheme_Object * do_scheme_reload(Scheme_Env * env)\n{\n")
(fprintf c-port"~aScheme_Per_Load_Statics *PLS;\n"
vm->c:indent-spaces)
(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)
(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
(if (= c top-level-count) "return " "")
c)
(unless (= c top-level-count)
(loop (add1 c))))
(fprintf c-port
"}~n~n")
"}\n\n")
(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)
(fprintf c-port"~areturn do_scheme_reload(env);~n"
(fprintf c-port"~areturn do_scheme_reload(env);\n"
vm->c:indent-spaces)
(fprintf c-port
"}~n~n")
"}\n\n")
(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
"~ascheme_set_tail_buffer_size(~a);~n"
"~ascheme_set_tail_buffer_size(~a);\n"
vm->c:indent-spaces
s:max-arity)
(fprintf c-port "~agc_registration();~n"
(fprintf c-port "~agc_registration();\n"
vm->c:indent-spaces)
(unless (compiler:multi-o-constant-pool)
(fprintf c-port "~amake_symbols();~n"
(fprintf c-port "~amake_symbols();\n"
vm->c:indent-spaces))
(unless (zero? (const:get-inexact-counter))
(fprintf c-port "~amake_inexacts();~n"
(fprintf c-port "~amake_inexacts();\n"
vm->c:indent-spaces))
(fprintf c-port "~ainit_prims(env);~n"
(fprintf c-port "~ainit_prims(env);\n"
vm->c:indent-spaces)
(unless (null? (compiler:get-case-lambdas))
(fprintf c-port "~ainit_cases_arities();~n"
(fprintf c-port "~ainit_cases_arities();\n"
vm->c:indent-spaces))
(let loop ([c 0])
(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
c)
(loop (add1 c))))
(fprintf c-port
"}~n~n")
"}\n\n")
(fprintf c-port
"~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
"\nvoid scheme_setup~a(Scheme_Env * env)\n{\n"
compiler:setup-suffix)
(fprintf c-port
"~ado_scheme_setup(env);~n"
"~ado_scheme_setup(env);\n"
vm->c:indent-spaces)
(fprintf c-port
"}~n~n")
"}\n\n")
(when (string=? "" compiler:setup-suffix)
(fprintf c-port
"~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n")
(fprintf c-port "~ado_scheme_setup~a(env);~n"
"\nScheme_Object * scheme_initialize(Scheme_Env * env)\n{\n")
(fprintf c-port "~ado_scheme_setup~a(env);\n"
vm->c:indent-spaces
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
compiler:setup-suffix)
(fprintf c-port
"}~n~n"))
"}\n\n"))
(fprintf c-port
"~nScheme_Object * ~ascheme_module_name()~n{~n~areturn "
"\nScheme_Object * ~ascheme_module_name()\n{\n~areturn "
compiler:setup-suffix
vm->c:indent-spaces)
(if 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_false"))
(fprintf c-port ";~n}~n"))
(fprintf c-port ";\n}\n"))
(let emit-vehicles ([vehicle-number 0])
(unless (= vehicle-number (compiler:get-total-vehicles))
@ -1288,7 +1288,7 @@
(for-each (lambda (L)
(let ([code (get-annotation 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)
(let ([n (closure-code-name code)])
(if n
@ -1311,11 +1311,11 @@
(vm->c:emit-case-prologue L i
(lambda ()
(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)
(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) "")
indent
c-port)])
@ -1327,7 +1327,7 @@
-1)
(vm->c:emit-case-epilogue L i undefines indent c-port)
(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 i)))
@ -1359,9 +1359,9 @@
(when (compiler:multi-o-constant-pool)
(call-with-output-file constant-pool-output-path
(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)
(fprintf port " )~n )~n")))))))
(fprintf port " )\n )\n")))))))
;;-----------------------------------------------------------------------
;; 3m xform
@ -1369,7 +1369,7 @@
(when c3m-output-path
(when (compiler:option:verbose)
(printf " [xforming C to \"~a\"]~n"
(printf " [xforming C to \"~a\"]\n"
c3m-output-path))
(let ([clean-up-src-c
@ -1400,14 +1400,14 @@
(if c-only?
(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
(unless input-path
(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))
(let ([clean-up
@ -1440,11 +1440,11 @@
(if multi-o?
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]~n" obj-output-path))
(printf " [output to \"~a\"]\n" obj-output-path))
(begin
;; Link
(when (compiler:option:verbose) (printf " [linking to \"~a\"]~n"
(when (compiler:option:verbose) (printf " [linking to \"~a\"]\n"
dll-output-path))
(let ([link-thunk
(lambda ()
@ -1465,7 +1465,7 @@
(delete-file obj-output-path))
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]~n" dll-output-path))))))
(printf " [output to \"~a\"]\n" dll-output-path))))))
(when debug:port
(close-output-port debug:port))
@ -1477,6 +1477,6 @@
(compiler:init-structs!)
(set! s:file-block #f)
(when (compiler:option:verbose)
(printf " finished [cpu ~a, real ~a].~n"
(printf " finished [cpu ~a, real ~a].\n"
total-cpu-time
total-real-time)))))))

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

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

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

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

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

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

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

@ -459,7 +459,7 @@
(let loop ()
(let ([l (read-bytes-line (list-ref proc 3) 'any)])
(unless (eof-object? l)
(fprintf (current-error-port) "~a~n" l)
(fprintf (current-error-port) "~a\n" l)
(loop))))
(close-input-port (list-ref proc 3)))))
@ -615,14 +615,14 @@
;; Setup GC_variable_stack macro
(printf (case gc-var-stack-mode
[(table)
"#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n"]
"#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)\n"]
[(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)
"#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)
"#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)~n"]
[else "#define GC_VARIABLE_STACK GC_variable_stack~n"]))
"#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)\n"]
[else "#define GC_VARIABLE_STACK GC_variable_stack\n"]))
(if gc-variable-stack-through-funcs?
(begin
@ -638,11 +638,11 @@
(if callee-restore?
" SET_GC_VARIABLE_STACK(__gc_var_stack__);"
"")
"~n"))
"\n"))
;; Same, but in a function where the number of registered variables
;; 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:
(printf (string-append
@ -650,7 +650,7 @@
(if callee-restore?
""
"SET_GC_VARIABLE_STACK(__gc_var_stack__), ")
"__gc_var_stack__[1] = (void *)x)~n"))
"__gc_var_stack__[1] = (void *)x)\n"))
;; Debugging support:
(printf "#ifdef MZ_3M_CHECK_VAR_STACK\n")
@ -662,110 +662,110 @@
;; Call a function where the number of registered variables can change in
;; 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:
(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 as for the previous call:
(printf (if callee-restore?
"#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) (CHECK_GC_V_S 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
;; within a procedure:
(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_AGAIN_once(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_AGAIN_once(x) FUNCCALL_AGAIN_each(x)\n")
;; 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:
(printf (string-append
"#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:
(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
;; 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
;; 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:
(printf (if callee-restore?
"#define RET_VALUE_START return (__ret__val__ = ~n"
"#define RET_VALUE_START return~n"))
"#define RET_VALUE_START return (__ret__val__ = \n"
"#define RET_VALUE_START return\n"))
(printf (if callee-restore?
"#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 , SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), __ret__val__)\n"
"#define RET_VALUE_END \n"))
;; 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_END ~n")
(printf "#define RET_VALUE_EMPTY_START return\n")
(printf "#define RET_VALUE_EMPTY_END \n")
;; 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:
(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:
(printf (if callee-restore?
"#define DECL_RET_SAVE(type) type __ret__val__;~n"
"#define DECL_RET_SAVE(type) /**/~n"))
"#define DECL_RET_SAVE(type) type __ret__val__;\n"
"#define DECL_RET_SAVE(type) /**/\n"))
;; Value used to initialize pointer variables:
(printf "#define NULLED_OUT 0~n")
(printf "#define NULLED_OUT 0\n")
;; 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:
(printf "#define GC_CAN_IGNORE /**/~n")
(printf "#define __xform_nongcing__ /**/~n")
(printf "#define GC_CAN_IGNORE /**/\n")
(printf "#define __xform_nongcing__ /**/\n")
;; Another annotation to protect against GC conversion:
(printf "#define HIDE_FROM_XFORM(x) x~n")
(printf "#define XFORM_HIDE_EXPR(x) x~n")
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/~n")
(printf "#define HIDE_FROM_XFORM(x) x\n")
(printf "#define XFORM_HIDE_EXPR(x) x\n")
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/\n")
;; In case a conversion is unnecessary where we have this annotation:
(printf "#define START_XFORM_SKIP /**/~n")
(printf "#define END_XFORM_SKIP /**/~n")
(printf "#define START_XFORM_SUSPEND /**/~n")
(printf "#define END_XFORM_SUSPEND /**/~n")
(printf "#define XFORM_START_SKIP /**/~n")
(printf "#define XFORM_END_SKIP /**/~n")
(printf "#define XFORM_START_SUSPEND /**/~n")
(printf "#define XFORM_END_SUSPEND /**/~n")
(printf "#define XFORM_SKIP_PROC /**/~n")
(printf "#define START_XFORM_SKIP /**/\n")
(printf "#define END_XFORM_SKIP /**/\n")
(printf "#define START_XFORM_SUSPEND /**/\n")
(printf "#define END_XFORM_SUSPEND /**/\n")
(printf "#define XFORM_START_SKIP /**/\n")
(printf "#define XFORM_END_SKIP /**/\n")
(printf "#define XFORM_START_SUSPEND /**/\n")
(printf "#define XFORM_END_SUSPEND /**/\n")
(printf "#define XFORM_SKIP_PROC /**/\n")
;; For avoiding warnings:
(printf "#define XFORM_OK_PLUS +~n")
(printf "#define XFORM_OK_MINUS -~n")
(printf "#define XFORM_TRUST_PLUS +~n")
(printf "#define XFORM_TRUST_MINUS -~n")
(printf "#define XFORM_OK_ASSIGN /**/~n")
(printf "~n")
(printf "#define XFORM_OK_PLUS +\n")
(printf "#define XFORM_OK_MINUS -\n")
(printf "#define XFORM_TRUST_PLUS +\n")
(printf "#define XFORM_TRUST_MINUS -\n")
(printf "#define XFORM_OK_ASSIGN /**/\n")
(printf "\n")
;; C++ cupport:
(printf "#define NEW_OBJ(t) new (UseGC) t~n")
(printf "#define NEW_ARRAY(t, array) (new (UseGC) t array)~n")
(printf "#define NEW_ATOM(t) (new (AtomicGC) 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_PTR_ARRAY(t, array) (new (UseGC) t* array)~n")
(printf "#define DELETE(x) (delete x)~n")
(printf "#define DELETE_ARRAY(x) (delete[] x)~n")
(printf "#define NEW_OBJ(t) new (UseGC) t\n")
(printf "#define NEW_ARRAY(t, array) (new (UseGC) t array)\n")
(printf "#define NEW_ATOM(t) (new (AtomicGC) 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_PTR_ARRAY(t, array) (new (UseGC) t* array)\n")
(printf "#define DELETE(x) (delete x)\n")
(printf "#define DELETE_ARRAY(x) (delete[] x)\n")
(printf (if callee-restore?
"#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 /* empty */\n"
"#define XFORM_RESET_VAR_STACK SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]);\n"))
(unless pgc-really?
(printf "#include \"cgc2.h\"~n"))
(printf "#include \"cgc2.h\"\n"))
(printf "~n"))
(printf "\n"))
(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))))
(when palm?
(printf "#include \"segmap.h\"~n"))
(printf "#include \"segmap.h\"\n"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Structures and constants
@ -1279,7 +1279,7 @@
(display/indent v "));")
(newline)
(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!)
(printf "#~adefine SETUP_~a(x) " tabbing tag)
(cond
@ -1295,20 +1295,20 @@
(make-string (sub1 indent) #\space))])
(case (tok-n v)
[(nested)
(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_EMPTY(x) FUNCCALL_EMPTY_each(x)~n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_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_EMPTY(x) FUNCCALL_EMPTY_each(x)\n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_each(x)\n" tabbing)]
[(no-nested)
(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_EMPTY(x) FUNCCALL_EMPTY_once(x)~n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_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_EMPTY(x) FUNCCALL_EMPTY_once(x)\n" tabbing)
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_once(x)\n" tabbing)]
[(undefine)
(printf "#~aundef BLOCK_SETUP~n" tabbing)
(printf "#~aundef FUNCCALL~n" tabbing)
(printf "#~aundef FUNCCALL_EMPTY~n" tabbing)
(printf "#~aundef FUNCCALL_AGAIN~n" tabbing)])
(printf "#~aundef BLOCK_SETUP\n" tabbing)
(printf "#~aundef FUNCCALL\n" tabbing)
(printf "#~aundef FUNCCALL_EMPTY\n" tabbing)
(printf "#~aundef FUNCCALL_AGAIN\n" tabbing)])
(set! line (+ 4 line)))]
[(memq (tok-n v) asm-commands)
(newline/indent indent)
@ -1483,7 +1483,7 @@
[(typedef? e)
(when show-info?
(printf "/* TYPEDEF */~n"))
(printf "/* TYPEDEF */\n"))
(if (or (simple-unused-def? e)
(unused-struc-typedef? e))
null
@ -1496,7 +1496,7 @@
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(when show-info?
(printf "/* PROTO ~a */~n" name))
(printf "/* PROTO ~a */\n" name))
(if (or precompiling-header?
(> (hash-table-get used-symbols name) 1)
(ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods!
@ -1509,17 +1509,17 @@
(begin
(when pgc?
(register-struct e))
(when show-info? (printf "/* STRUCT ~a */~n" (tok-n (cadr e)))))
(when show-info? (printf "/* STRUCT DECL */~n")))
(when show-info? (printf "/* STRUCT ~a */\n" (tok-n (cadr e)))))
(when show-info? (printf "/* STRUCT DECL */\n")))
e]
[(class-decl? e)
(if (or (braces? (caddr e))
(eq? '|:| (tok-n (caddr e))))
(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))
(begin
(when show-info? (printf "/* CLASS DECL */~n"))
(when show-info? (printf "/* CLASS DECL */\n"))
(let ([name (tok-n (cadr e))])
(if (assoc name c++-classes)
;; we already know this class
@ -1532,7 +1532,7 @@
(if (skip-function? e)
e
(begin
(when show-info? (printf "/* FUNCTION ~a */~n" name))
(when show-info? (printf "/* FUNCTION ~a */\n" name))
(if (or (positive? suspend-xform)
(not pgc?)
(and where
@ -1550,7 +1550,7 @@
;; or still in headers and probably a simple inlined function
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
(when palm?
(fprintf map-port "(~aimpl ~s)~n"
(fprintf map-port "(~aimpl ~s)\n"
(if palm-static? "s" "")
name)
(call-graph name e))
@ -1567,7 +1567,7 @@
e))
(convert-function e name)))))]
[(var-decl? e)
(when show-info? (printf "/* VAR */~n"))
(when show-info? (printf "/* VAR */\n"))
(if (and can-drop-vars?
(simple-unused-def? e))
null
@ -1984,7 +1984,7 @@
tcp_accept_addr))))
(begin
(when show-info?
(printf "/* ~a: ~a ~a*/~n"
(printf "/* ~a: ~a ~a*/\n"
comment name
(cond
[struct-array?
@ -2022,7 +2022,7 @@
(log-error "[INST] ~a in ~a: Static instance of class ~a."
(tok-line (car e)) (tok-file (car e)) base))
(when show-info?
(printf "/* NP ~a: ~a */~n"
(printf "/* NP ~a: ~a */\n"
comment name))
(loop (sub1 l) #f pointers (cons (cons name
(make-non-pointer-type non-ptr-base))
@ -2060,7 +2060,7 @@
(let loop ([e e])
(cond
[(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))
#f #f)
(car e))]
@ -3449,14 +3449,14 @@
(not (or (ormap (lambda (var)
(and (array-type? (cdr var))
'(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))
(car var))))
(live-var-info-vars live-vars))
(ormap (lambda (&-var)
(and (assq &-var vars)
'(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))
&-var)))
&-vars))))]
@ -3854,7 +3854,7 @@
(call-graph/body name (seq->list (seq-in v)))]
[(assq (tok-n v) (prototyped))
(fprintf map-port
"(call ~s ~s)~n"
"(call ~s ~s)\n"
name (tok-n v))]
[else (void)]))
e))
@ -4032,8 +4032,8 @@
(when precompiling-header?
(let loop ([i 1])
(unless (i . > . gentag-count)
(printf "#undef XfOrM~a_COUNT~n" i)
(printf "#undef SETUP_XfOrM~a~n" i)
(printf "#undef XfOrM~a_COUNT\n" i)
(printf "#undef SETUP_XfOrM~a\n" i)
(loop (add1 i)))))
(close-output-port (current-output-port))

6
collects/compiler/src2src.rkt
View File

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

2
collects/deinprogramm/world.rkt
View File

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

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

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

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

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

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

@ -27,7 +27,7 @@
(let loop ()
(let ([t (read-line in 'any)])
(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)
(string #\newline) t))
(loop)))))))]

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

@ -677,7 +677,7 @@
(letrec
((loop
(lambda (rhs)
;; (eopl:printf "~s~%" rhs)
;; (eopl:printf "~s\n" rhs)
(if (null? rhs) 0
(let ((rhs-item (car rhs))
(rest (cdr rhs)))
@ -685,26 +685,26 @@
((and
(symbol? rhs-item)
(sllgen:non-terminal? rhs-item))
; (eopl:printf "found nonterminal~%")
; (eopl:printf "found nonterminal\n")
(+ 1 (loop rest)))
((symbol? rhs-item)
; (eopl:printf "found terminal~%")
; (eopl:printf "found terminal\n")
(+ 1 (loop rest)))
((sllgen:arbno? rhs-item)
; (eopl:printf "found arbno~%")
; (eopl:printf "found arbno\n")
(+
(loop (sllgen:arbno->rhs rhs-item))
(loop rest)))
((sllgen:separated-list? rhs-item)
; (eopl:printf "found seplist~%")
; (eopl:printf "found seplist\n")
(+
(loop (sllgen:separated-list->rhs rhs-item))
(loop rest)))
((string? rhs-item)
; (eopl:printf "found string~%")
; (eopl:printf "found string\n")
(loop rest))
(else
; (eopl:printf "found error~%")
; (eopl:printf "found error\n")
(report-error rhs-item "unrecognized item"))))))))
(loop rhs)))))
@ -884,7 +884,7 @@
(init-loop (cdr productions))))))
(rhs-loop
(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
((null? rhs) #t)
((get-nonterminal (car rhs)) =>
@ -905,7 +905,7 @@
(set! closure-rules
(cons (list lhs nonterminal)
closure-rules))
;; (eopl:printf "~s~%" (list lhs nonterminal))
;; (eopl:printf "~s\n" (list lhs nonterminal))
)))
first-of-rest))
;; now keep looking
@ -1073,7 +1073,7 @@
;; 1999, since class could be a string.
((member class (car (car others)))
(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)))
(else (inner (cdr others))))))
(car this-production))
@ -1495,7 +1495,7 @@
; )
; (case opcode
; ((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))
; ((make-symbol identifier)
; (sllgen:make-token 'identifier
@ -1511,7 +1511,7 @@
; loc))
; (else
; (sllgen:error 'scanning
; "~%Unknown opcode selected from action list ~s"
; "\nUnknown opcode selected from action list ~s"
; actions))))))
@ -1522,16 +1522,16 @@
(newstates '())
(char '())
(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
; '(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)
; (for-each
; (lambda (local-state)
; (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
; local-states)
; (eopl:printf "newstates = ~%")
; (eopl:printf "newstates = \n")
; (for-each
; (lambda (local-state)
; (sllgen:pretty-print (map sllgen:unparse-regexp local-state)))
@ -1540,7 +1540,7 @@
;; no more states to consider
(begin
; '(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)
; '(for-each
; (lambda (local-state)
@ -1548,7 +1548,7 @@
; newstates)
(k actions newstates char stream))
(let ((state (car local-states)))
; (eopl:printf "first state:~%")
; (eopl:printf "first state:\n")
; (sllgen:pretty-print state)
(cond
((sllgen:action? (car state)) ; state should never be null
@ -1564,11 +1564,11 @@
(if (and (null? char) (not eos-found?))
(sllgen:char-stream-get! stream
(lambda (ch1)
'(eopl:printf "read character ~s~%" ch1)
'(eopl:printf "read character ~s\n" ch1)
(set! char ch1))
(lambda ()
(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))
(sllgen:apply-tester tester char))
;; passed the test -- shift is possible
@ -1602,7 +1602,7 @@
=>
(sllgen:xapply
(lambda (sequents)
;; (printf "processing concat: sequents = ~s~%" sequents)
;; (printf "processing concat: sequents = ~s\n" sequents)
(loop
(cons
(append sequents (cdr state))
@ -1630,7 +1630,7 @@
;; ok, the current buffer is a candidate token
(begin
(set! success-buffer buffer)
;; (printf "success-buffer =~s~%" success-buffer)
;; (printf "success-buffer =~s\n" success-buffer)
(set! actions new-actions))
;; otherwise leave success-buffer and actions alone
)
@ -1663,7 +1663,7 @@
;; this really is reference equality.
#t
(begin
;; (eopl:printf "pushing back ~s~%" (car buff))
;; (eopl:printf "pushing back ~s\n" (car buff))
(sllgen:char-stream-push-back! (car buffer) stream)
(set! buffer (cdr buffer))
(push-back-loop))))
@ -1724,9 +1724,9 @@
(define sllgen:make-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)
;(eopl:printf "sllgen:make-stream: emitting ~s~%" char)
;(eopl:printf "sllgen:make-stream: emitting ~s\n" char)
(fcn char stream))))
(define sllgen:list->stream
@ -1778,7 +1778,7 @@
(lambda ()
;; when the stream runs out, try this
(let ((sentinel (sentinel-fcn)))
; (eopl:printf "~s~%" sentinel)
; (eopl:printf "~s\n" sentinel)
(fn sentinel (sllgen:constant-stream sentinel))))))))
; no longer used
@ -1952,13 +1952,13 @@
(if (null? token)
(sllgen:stream-get! 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! stream next-stream))
(lambda ()
(error 'sllgen:find-production
"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)
(let loop
((alternatives (cdr (assq non-terminal parser))))
@ -1971,7 +1971,7 @@
(sllgen:token->class token)
(sllgen:token->data token)))
((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)))
(sllgen:apply-actions non-terminal (cdr (car alternatives))
parser buf token stream k))
@ -2001,7 +2001,7 @@
(report-error
(lambda (target)
(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)
target
(sllgen:token->class token)
@ -2009,7 +2009,7 @@
action-list))))
(let ((action (car 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)
((term)
(fill-token!)
@ -2077,7 +2077,7 @@
(let loop ((trees trees)
(ptr ans)
(ctr n))
; (eopl:printf "ctr = ~s trees = ~s~%" ctr trees)
; (eopl:printf "ctr = ~s trees = ~s\n" ctr trees)
(cond
((null? trees) (mlist->list ans))
((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?)
(profiling-enabled #f)
(error-print-width 50)
(printf "Sorting profile data...~n")
(printf "Sorting profile data...\n")
(let* ([sel (if sort-time? cadr car)]
[counts (sort (filter (lambda (c) (positive? (car c)))
(get-profile-results))
@ -379,8 +379,8 @@
(for-each
(lambda (c)
(set! total (+ total (sel c)))
(printf "=========================================================~n")
(printf "time = ~a : no. = ~a : ~e in ~s~n"
(printf "=========================================================\n")
(printf "time = ~a : no. = ~a : ~e in ~s\n"
(cadr c) (car c) (caddr c) (cadddr c))
;; print call paths
(when paths?
@ -392,10 +392,10 @@
(lambda (cm)
(printf " <- ~e" (car cm)))
(cddr cms))
(printf "~n")))
(printf "\n")))
(sort (cadddr (cdr c)) (lambda (a b) (> (car a) (car b)))))))
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))
(let ([default-okay? (checker default-value)])
(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)))
(unless (= (length aliases) (length rewrite-aliases))

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

@ -192,7 +192,7 @@
(,(xyz-z xyz-white))))])
(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))))
(define rgb->xyz-matrix
@ -203,13 +203,13 @@
(define xyz->rgb-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)
(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
;;(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)
(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)))])
(unless (eq? 'eof type)
(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)))
(let ((len (- new-token-end new-token-start)))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
@ -418,11 +418,11 @@ added get-regions
(define/private (colorer-driver)
(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)))
(when tok-cor
(coroutine-kill tok-cor))
#;(printf "new coroutine~n")
#;(printf "new coroutine\n")
(set! tok-cor
(coroutine
(λ (enable-suspend)
@ -450,19 +450,19 @@ added get-regions
(format "exception in colorer thread: ~s" exn)
exn))
(set! tok-cor #f))))
#;(printf "begin lexing~n")
#;(printf "begin lexing\n")
(when (coroutine-run 10 tok-cor)
(for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t))
lexer-states)))
#;(printf "end lexing~n")
#;(printf "begin coloring~n")
#;(printf "end lexing\n")
#;(printf "begin coloring\n")
;; This edit sequence needs to happen even when colors is null
;; for the paren highlighter.
(begin-edit-sequence #f #f)
(color)
(end-edit-sequence)
#;(printf "end coloring~n")))
#;(printf "end coloring\n")))
(define/private (colorer-callback)
(cond
@ -643,7 +643,7 @@ added get-regions
;; possible.
(define/private match-parens
(lambda ([just-clear? #f])
;;(printf "(match-parens ~a)~n" just-clear?)
;;(printf "(match-parens ~a)\n" just-clear?)
(when (and (not in-match-parens?)
;; Trying to match open parens while the
;; background thread is going slows it down.
@ -918,21 +918,21 @@ added get-regions
(let* ((x null)
(f (λ (a b c) (set! x (cons (list a b c) x)))))
(send (lexer-state-tokens ls) for-each f)
(printf "tokens: ~.s~n" (reverse x))
(printf "tokens: ~.s\n" (reverse x))
(set! x null)
(send (lexer-state-invalid-tokens ls) for-each f)
(printf "invalid-tokens: ~.s~n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n"
(printf "invalid-tokens: ~.s\n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a\n"
(lexer-state-start-pos ls)
(lexer-state-current-pos 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))
;; ------------------------- Callbacks to Override ----------------------
(define/override (lock x)
;;(printf "(lock ~a)~n" x)
;;(printf "(lock ~a)\n" x)
(super lock x)
(when (and restart-callback (not x))
(set! restart-callback #f)
@ -940,25 +940,25 @@ added get-regions
(define/override (on-focus on?)
;;(printf "(on-focus ~a)~n" on?)
;;(printf "(on-focus ~a)\n" on?)
(super on-focus on?)
(match-parens (not on?)))
(define/augment (after-edit-sequence)
;;(printf "(after-edit-sequence)~n")
;;(printf "(after-edit-sequence)\n")
(when (has-focus?)
(match-parens))
(inner (void) after-edit-sequence))
(define/augment (after-set-position)
;;(printf "(after-set-position)~n")
;;(printf "(after-set-position)\n")
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(inner (void) after-set-position))
(define/augment (after-change-style a b)
;;(printf "(after-change-style)~n")
;;(printf "(after-change-style)\n")
(unless (get-styles-fixed)
(unless (local-edit-sequence?)
(when (has-focus?)
@ -966,19 +966,19 @@ added get-regions
(inner (void) after-change-style a b))
(define/augment (on-set-size-constraint)
;;(printf "(on-set-size-constraint)~n")
;;(printf "(on-set-size-constraint)\n")
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(inner (void) on-set-size-constraint))
(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)
(inner (void) after-insert 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))
(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)
(= 0 (procedure-arity t)))
(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))
(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))
(if (refresh-delayed?)
(if in-local-edit-sequence?

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

@ -125,7 +125,7 @@
(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
(λ (port)
(define (pop-out sexp)
@ -203,7 +203,7 @@
#:exists 'truncate))
(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
(λ (port)

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

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

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

@ -528,7 +528,7 @@ the state transitions / contracts are:
(cond
[(string? default) string?]
[(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
name
(λ (p new-value)

4
collects/framework/splash.rkt
View File

@ -123,12 +123,12 @@
[(or (path? splash-draw-spec)
(string? 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))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(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))
(send splash-canvas min-width (send splash-bitmap get-width))

2
collects/framework/test.rkt
View File

@ -363,7 +363,7 @@
(loop (- n 1))))])))]
[(number? 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)]
[else (error 'test:set-radio-box!
"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
(car block)))))
#'failkv)))]
[else (error 'compile "unsupported pattern: ~a~n" first)]))
[else (error 'compile "unsupported pattern: ~a\n" first)]))
(define (compile* vars rows esc)
(define (let/wrap clauses body)

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

@ -30,13 +30,13 @@
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(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)]
[(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)]
[(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)]
[else (split-rows rows (cons (reverse matched-rows)
prev-mats))]))))
@ -66,7 +66,7 @@
[(CPat? p)
(if (Struct? p)
(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 #f rs))]
[else (split-rows rs (cons (list r) acc))]))))

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

@ -341,7 +341,7 @@
(syntax/loc
stx
(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)))])))
(define-syntax (log-it stx)

15
collects/racket/trace.rkt
View File

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

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

@ -17,7 +17,7 @@
(write msg)))
(let ([cep (current-error-port)])
(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)
(send/resp (list 'ERROR (exn-message x))))])
(parameterize (

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

@ -25,8 +25,8 @@
['DONE (void)])
(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)
(eprintf "STDOUT:~n~a=====~n" out)
(eprintf "STDERR:~n~a=====~n" err)))]))
(eprintf "STDOUT:\n~a=====\n" out)
(eprintf "STDERR:\n~a=====\n" err)))]))
;; assigns a collection to each worker to be compiled
;; when it runs out of collections, steals work from other workers collections
(define (get-job jobqueue workerid)
@ -53,7 +53,7 @@
(let* ([cc-name (cc-name cc)]
[cc-path (cc-path cc)]
[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)))))
(let retry ()
(define (find-job-in-cc cc id)
@ -124,7 +124,7 @@
(write msg)))
(let ([cep (current-error-port)])
(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)
(send/resp (list 'ERROR (exn-message x))))])
(parameterize (

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

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

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

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

2
collects/setup/scribble.rkt
View File

@ -145,7 +145,7 @@
(if 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)
(with-handlers ([exn:fail?
(lambda (exn)

6
collects/setup/winvers.rkt
View File

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

8
collects/sirmail/pref.rkt
View File

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

6
collects/sirmail/readr.rkt
View File

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

2
collects/slatex/slatex.rkt
View File

@ -16,7 +16,7 @@
((eq? a 'string-ref) 'string-set!)
((eq? a 'vector-ref) 'vector-set!)
((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)
,r)))))))))

24
collects/slideshow/viewer.rkt
View File

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

7
collects/srpersist/doc.txt
View File

@ -127,8 +127,8 @@
(with-handlers ([(lambda (exn)
(exn-with-info? exn))
(lambda (exn)
(printf "Got exn-with-info exception~n")
(printf "Value: ~a~n" (exn-with-info-val exn)))])
(printf "Got exn-with-info exception\n")
(printf "Value: ~a\n" (exn-with-info-val exn)))])
...)
Applications can call sql-error, get-diag-rec, or get-diag-field
@ -2607,6 +2607,3 @@
[ODBC 3.5 or greater]
'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
([(lambda (exn) (exn-no-data? exn))
(lambda (exn) (printf "** End of data **~n"))])
(lambda (exn) (printf "** End of data **\n"))])
(let loop ()
(fetch hstmt)
(printf "Name: ~a Age: ~a~n"
(printf "Name: ~a Age: ~a\n"
(read-buffer name-buffer)
(read-buffer age-buffer))
(loop)))

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

@ -77,7 +77,7 @@
; [elaborated (cadr arg-list)]
; [eval-result (caddr arg-list)]
; [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
; (eval collapsed)
; eval-result)

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

@ -138,7 +138,7 @@
(lookup-first-binding (lambda (id2) (free-identifier=? id id2))
mark-list
(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)
id))))))

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

@ -89,7 +89,7 @@
(define/public (display-untested-summary port)
(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)
(fprintf port "Tests disabled.\n"))

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

@ -106,7 +106,7 @@
(formatter (check-fail-format fail)))
(cond
[(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))
(unexpected-error-message fail))]
[(unequal? fail)
@ -119,11 +119,11 @@
(formatter (outofrange-range fail))
(formatter (outofrange-actual 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-message 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))
(expected-error-message fail))]
[(message-error? fail)
@ -147,8 +147,6 @@
arguments))
(result-arguments-list (property-fail-result 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))])
(print-string "\n")))

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

@ -26,12 +26,12 @@
(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-max-height: ~s~n" (send snip get-max-height))
(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-width: ~s~n" (send snip get-min-width))
;(printf "snip-width: ~s~n" (send pasteboard snip-width snip))
;(printf "snip-height: ~s~n" (send pasteboard snip-height snip))
(printf "get-max-height: ~s\n" (send snip get-max-height))
(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-width: ~s\n" (send snip get-min-width))
;(printf "snip-width: ~s\n" (send pasteboard snip-width snip))
;(printf "snip-height: ~s\n" (send pasteboard snip-height snip))
))
;;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
(instantiate frame% ()
@ -229,4 +229,4 @@
)
(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
(instantiate frame% ()
@ -187,4 +187,4 @@
)
(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 all (+ fails succs))
(unless (zero? all)
(printf "~S~n"
(printf "~S\n"
`(,kind-name
(#f ,fails)
(#t ,succs)
,all))))
(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
(sort (filter (λ (p) ((car p) . > . 10))
(hash-map errors (λ (k v) (cons v k))))
> #:key car)])
(unless (empty? common-errors)
(printf "Common Errors:~n")
(printf "Common Errors:\n")
(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)

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)])
(unless (string=? result got)
(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)))))
(define (test-hash-bang)
@ -1058,7 +1058,7 @@ the settings above should match r5rs
(let* ([got (fetch-output/should-be-tested drs)])
(unless (string=? "1" got)
(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)))))
(define (fetch-output/should-be-tested . args)
@ -1095,7 +1095,7 @@ the settings above should match r5rs
(string-length line1-got))))
(regexp-match line1-expect line1-got)))
(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-got line1-got)
(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?)
(let* ([plain-print-style (if has-print-printing? "print" "write")]
[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
(lambda (option show-sharing pretty?)
(set-language #f)
@ -1178,7 +1178,7 @@ the settings above should match r5rs
(answer got)
(whitespace-string=? answer got))
(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?
(shorten got)
(if (procedure? answer) (answer) answer)))))])
@ -1285,11 +1285,11 @@ the settings above should match r5rs
(lambda (expected)
(cond
[(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)
"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)
"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)
(cond
[(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-should-be
(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
sample-solutions-teachpack-filename
teachpacks)))]
@ -126,7 +126,7 @@
(has-error? drs-frame))
=>
(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
section
err-msg
@ -142,7 +142,7 @@
(unless (eof-object? sexp)
(cond
[(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))
(let ([after (with-handlers ([(lambda (exn) #t)
(lambda (exn) exn)])

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

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

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

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

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

@ -711,14 +711,14 @@
(with-handlers (((lambda (x) (not (fatal-exn? x)))
(lambda (x)
(fprintf (thread-output-port)
": error: ~a~n"
": error: ~a\n"
(exn-message x)))))
(if (eq? dest 'values)
(k v)
(send dest add (k v)))
(flush-display)
(fprintf (thread-output-port) ": success~n"))))
(fprintf (thread-output-port) "~a: failure: ~a~n" name v)))
(fprintf (thread-output-port) ": success\n"))))
(fprintf (thread-output-port) "~a: failure: ~a\n" name v)))
(define (try-args arg-types dest name k)
(apply-args (get-args arg-types) dest name k))
@ -734,7 +734,7 @@
(flush-output (thread-output-port))
(with-handlers ([exn:fail:contract?
(lambda (x)
(fprintf (thread-output-port) ": exn: ~a~n"
(fprintf (thread-output-port) ": exn: ~a\n"
(exn-message x))
;; Check that exn is from the right place:
(let ([class (if (list? name)
@ -748,30 +748,30 @@
; init is never inherited, so class name really should be present
(unless (regexp-match (symbol->string class) (exn-message x))
(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)))
(unless (regexp-match (symbol->string method) (exn-message x))
(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))))]
[exn:fail:contract:arity?
(lambda (x)
(fprintf (thread-output-port)
": UNEXPECTED ARITY MISMATCH: ~a~n"
": UNEXPECTED ARITY MISMATCH: ~a\n"
(exn-message x)))]
[(lambda (x) (not (fatal-exn? x)))
(lambda (x)
(fprintf (thread-output-port)
": WRONG EXN TYPE: ~a~n"
": WRONG EXN TYPE: ~a\n"
(exn-message x)))])
(k v)
(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)
(let ([args (get-bad-args arg-types)])
(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
(let loop ([pres null][posts args])
(unless (null? posts)
@ -799,16 +799,16 @@
(loop (cdr l)))))))
(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)
(create-some k try-args))))
(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)
(create-some k try-all-args))))
(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)
(create-some k try-bad-args))))
@ -819,7 +819,7 @@
[name (cadr v)]
[methods (cdddr v)])
(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])
(unless (null? l)
(unless (symbol? (car l))
@ -850,7 +850,7 @@
(loop (cdr l)))))))
(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)
(unless (member k except)
(try-methods k try-args)))))
@ -859,7 +859,7 @@
(call-random null))
(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))))
(define (call-all-non-editor)
@ -871,7 +871,7 @@
(create-all-random)
(create-all-random))
(printf " Creating Example Instances~n")
(printf " Creating Example Instances\n")
(define f (make-object frame% "Example Frame 1"))
(send frame%-example-list add f)
@ -1000,9 +1000,9 @@
(send clipboard<%>-example-list add the-clipboard)
(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)
(hash-table-for-each classinfo
(lambda (key v)
@ -1015,7 +1015,7 @@
(if (void? (with-handlers ([void void])
(namespace-variable-value name)))
;; Not there
(printf "No such procedure/value: ~a~n" name)
(printf "No such procedure/value: ~a\n" name)
(let ([v (namespace-variable-value name)])
(when (procedure? v)
@ -1028,7 +1028,7 @@
(andmap integer? a)
(andmap integer? 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))))))
(set! in-top-level (cons name in-top-level)))
@ -1046,12 +1046,12 @@
(if (interface? key) "interface" "class")
s))])
(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
(let ([ex (send (car v) choose-example)])
(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
(lambda (name method)
(if (or (and (interface? key)
@ -1063,21 +1063,21 @@
'(when (is-a? ex key)
(let ([m (make-generic ex name)])
(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
(arity m) (cadr method)))))
;; Not there
(printf "No such method: ~a in ~a~n" name key)))
(printf "No such method: ~a in ~a\n" name key)))
names methods))
; Check everything is documented
(for-each
(lambda (n)
(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)))))))))
(printf " Method-checking done~n")
(printf " Method-checking done\n")
(let* ([get-all (lambda (n)
(parameterize ([current-namespace n])
@ -1092,7 +1092,7 @@
(for-each
(lambda (i)
(unless (memq i expect-n)
(printf "Undocumented global: ~a~n" i)))
(printf "Undocumented global: ~a\n" i)))
actual-n))
(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))))))
(define (enable-tests f)
(printf "Enable ~a~n" f)
(printf "Enable ~a\n" f)
(st #t f is-enabled?)
(stv f enable #f)
(st #f f is-enabled?)
@ -47,7 +47,7 @@
(st #t f is-enabled?))
(define (drop-file-tests f)
(printf "Drop File ~a~n" f)
(printf "Drop File ~a\n" f)
(st #f f accept-drop-files)
(stv f accept-drop-files #t)
(st #t f accept-drop-files)
@ -55,7 +55,7 @@
(st #f f accept-drop-files))
(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)])
(stvals '(0 0) f screen->client x y))
(let-values ([(x y) (send f screen->client 0 0)])
@ -66,7 +66,7 @@
(stv f refresh))
(define (area-tests f sw? sh? no-stretch?)
(printf "Area ~a~n" f)
(printf "Area ~a\n" f)
(let ([x (send f min-width)]
[y (send f min-height)])
(st sw? f stretchable-width)
@ -76,7 +76,7 @@
(let-values ([(w h) (if no-stretch?
(send f get-size)
(values 0 0))])
(printf "Size ~a x ~a~n" w h)
(printf "Size ~a x ~a\n" w h)
(when no-stretch?
(stv f min-width w) ; when we turn of stretchability, don't resize
(stv f min-height h))
@ -95,7 +95,7 @@
(define (containee-tests f sw? sh? m)
(area-tests f sw? sh? #f)
(printf "Containee ~a~n" f)
(printf "Containee ~a\n" f)
(st m f horiz-margin)
(st m f vert-margin)
(stv f horiz-margin 3)
@ -108,14 +108,14 @@
(stv f vert-margin m))
(define (container-tests f win?)
(printf "Container ~a~n" f)
(printf "Container ~a\n" f)
(let-values ([(x y) (send f get-alignment)])
(stv f set-alignment 'right 'bottom)
(stvals '(right bottom) f get-alignment)
(stv f set-alignment x y)))
(define (cursor-tests f)
(printf "Cursor ~a~n" f)
(printf "Cursor ~a\n" f)
(let ([c (send f get-cursor)])
(stv f set-cursor c)
(st c f get-cursor)
@ -131,7 +131,7 @@
(define (show-tests f)
(unless (is-a? f dialog%)
(printf "Show ~a~n" f)
(printf "Show ~a\n" f)
(let ([on? (send f is-shown?)])
(stv f show #f)
(when on?
@ -193,7 +193,7 @@
(st #f f get-menu-bar))]
[space-tests
(lambda ()
(printf "Spacing~n")
(printf "Spacing\n")
(let ([b (send f border)])
(stv f border 25)
(st 25 f border)
@ -209,14 +209,14 @@
(drop-file-tests f))]
[client->screen-tests
(lambda ()
(printf "Client<->Screen~n")
(printf "Client<->Screen\n")
(let-values ([(x y) (send f client->screen 0 0)])
(stvals '(0 0) f screen->client x y))
(let-values ([(x y) (send f screen->client 0 0)])
(stvals '(0 0) f client->screen x y)))]
[container-tests
(lambda ()
(printf "Container~n")
(printf "Container\n")
(area-tests f #t #t #t)
(let-values ([(x y) (send f container-size null)])
(st x f min-width)
@ -238,15 +238,15 @@
(container-tests)
(cursor-tests)
(printf "Init~n")
(printf "Init\n")
(init-tests #f)
(stv f show #t)
(pause)
(printf "Show Init~n")
(printf "Show Init\n")
(init-tests #t)
(stv f show #f)
(pause)
(printf "Hide Init~n")
(printf "Hide Init\n")
(init-tests #f)
(send f show #t)
(pause)
@ -258,7 +258,7 @@
(stv f change-children values)
(printf "Iconize~n")
(printf "Iconize\n")
(stv f iconize #t)
(pause)
(pause)
@ -272,7 +272,7 @@
(stv f maximize #f)
(pause)
(printf "Move~n")
(printf "Move\n")
(stv f move 34 37)
(pause)
(FAILS (st 34 f get-x))
@ -280,7 +280,7 @@
(st 150 f get-width)
(st 151 f get-height)
(printf "Resize~n")
(printf "Resize\n")
(stv f resize 56 57)
(pause)
(FAILS (st 34 f get-x))
@ -306,7 +306,7 @@
(cursor-tests)
(printf "Menu Bar~n")
(printf "Menu Bar\n")
(let ([mb (make-object menu-bar% f)])
(st mb f get-menu-bar)
(st f mb get-frame)
@ -320,11 +320,11 @@
(st null mb get-items)
(printf "Menu 1~n")
(printf "Menu 1\n")
(let* ([m (make-object menu% "&File" mb)]
[i m]
[delete-enable-test (lambda (i parent empty)
(printf "Item~n")
(printf "Item\n")
(st #f i is-deleted?)
(st #t i is-enabled?)
@ -371,7 +371,7 @@
(st null m get-items)
(printf "Menu Items~n")
(printf "Menu Items\n")
(let ([i1 (make-object menu-item% "&Plain" m
(lambda (i e)
(test-control-event e '(menu))
@ -391,7 +391,7 @@
(lambda (i empty name)
(delete-enable-test i m empty)
(printf "Shortcut~n")
(printf "Shortcut\n")
(set! hit i)
(stv i command (make-object control-event% 'menu))
(test name 'hit-command hit)
@ -437,7 +437,7 @@
'done)
(printf "Menu 2~n")
(printf "Menu 2\n")
(let* ([m2 (make-object menu% "&Edit" mb "Help Edit")]
[i2 m2])
(st (list i i2) mb get-items)
@ -468,7 +468,7 @@
(define (test-controls parent frame)
(define side-effect #f)
(printf "Buttons~n")
(printf "Buttons\n")
(letrec ([b (make-object button%
"&Button"
parent
@ -484,7 +484,7 @@
(containee-window-tests b #f #f parent frame 2))
(printf "Check Box~n")
(printf "Check Box\n")
(letrec ([c (make-object check-box%
"&Check Box"
parent
@ -511,7 +511,7 @@
#t)])
(st #t c get-value))
(printf "Radio Box~n")
(printf "Radio Box\n")
(letrec ([r (make-object radio-box%
"&Radio Box"
(list "O&ne" "T&wo" "T&hree")
@ -586,7 +586,7 @@
'(vertical)
3))
(printf "Gauge~n")
(printf "Gauge\n")
(letrec ([g (make-object gauge%
"&Gauge"
10
@ -618,7 +618,7 @@
(containee-window-tests g #t #f parent frame 2))
(printf "Slider~n")
(printf "Slider\n")
(letrec ([s (make-object slider%
"&Slider"
-2 8
@ -774,7 +774,7 @@
'done-list)])
(printf "Choice~n")
(printf "Choice\n")
(letrec ([c (make-object choice%
"&Choice"
'("A" "B" "C & D")
@ -808,7 +808,7 @@
(let ([mk-list
(lambda (style)
(printf "List Box: ~a~n" style)
(printf "List Box: ~a\n" style)
(letrec ([l (make-object list-box%
"&List Box"
'("A" "B" "C & D")
@ -869,7 +869,7 @@
(let ([c (make-object canvas% parent '(hscroll vscroll))])
(printf "Tab Focus~n")
(printf "Tab Focus\n")
(st #f c accept-tab-focus)
(stv c accept-tab-focus #t)
(st #t c accept-tab-focus)
@ -880,7 +880,7 @@
; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t)
(let-values ([(w h) (send c get-virtual-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
(lambda (xpos ypos)
(let-values ([(x y) (send c get-view-start)])
@ -958,7 +958,7 @@
102)])
(let loop ([n 100])
(unless (zero? n)
(send e insert (format "line ~a~n" n))
(send e insert (format "line ~a\n" n))
(loop (sub1 n))))
(st #f c allow-scroll-to-last)

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

@ -29,7 +29,7 @@
(for-each
(lambda (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)))
'(25 -22 -1 -233344433 177000000 859489222))
@ -49,13 +49,13 @@
(set-date-dst?! date #f)
(set-date-time-zone-offset! date 0)
(unless (test-date date)
(printf "Error in test-date~n")
(printf "Error in test-date\n")
(set! errors? #t)))
(for-each
(lambda (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)))
'(0 1 3.14 25.00 -22.34 11.7832 91000000000 25034343434.9933))
@ -81,7 +81,7 @@
[expected (caddr t)])
(unless (equal? got expected)
(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))))
com-tests)
@ -93,11 +93,11 @@
(set! errors? #t))
(if errors?
(printf "There were errors!~n")
(printf "No errors in conversions and COM tests~n"))
(printf "There were errors!\n")
(printf "No errors in conversions and COM tests\n"))
(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)
(printf t button shift x y))))
@ -110,17 +110,10 @@
(lambda (sf)
(com-register-event-handler ctrl (car sf) (cadr sf)))
`(("Click"
,(lambda () (printf "Click~n")))
,(lambda () (printf "Click\n")))
,(mouse-pair "MouseMove")
,(mouse-pair "MouseDown")
,(mouse-pair "MouseUp")))
(printf "Try clicking and moving the mouse over the object~n")
(printf "You should see Click, MouseMove, MouseDown, and MouseUp events~n"))
(printf "Try clicking and moving the mouse over the object\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)
; should show an About box
(printf "You should see the About box~n")
(printf "You should see the About box\n")
(run "About")
; tests whether Eval returns sensible result
(if (string=? (mzeval "(+ 20 22)")
"42")
(printf "1st Eval test ok~n")
(printf "1st Eval test ok\n")
(begin
(add-error!)
(fprintf (current-error-port) "1st Eval test failed~n")))
(fprintf (current-error-port) "1st Eval test failed\n")))
(mzeval "(define x 42)")
; tests whether preceding definition really holds
(if (string=? "42" (mzeval "x"))
(printf "define test ok~n")
(printf "define test ok\n")
(begin
(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
; tests for removal of binding
(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
(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
(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
(add-error!)
(fprintf (current-error-port) "3rd Eval test failed~n"))
(fprintf (current-error-port) "3rd Eval test failed\n"))
(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)
(printf "Iteration: ~a~n" x)
(printf "Iteration: ~a\n" x)
(if (zero? x) 0
(loop (- (+ (local-vars) (- x 1)) 8))))
; Generate gradually increasing sizes of lists
; To trigger garbage collection at different points
(printf "~a~n" (gen-list 1))
(printf "~a~n" (gen-list 2))
(printf "~a~n" (gen-list 4))
(printf "~a~n" (gen-list 8))
(printf "~a\n" (gen-list 1))
(printf "~a\n" (gen-list 2))
(printf "~a\n" (gen-list 4))
(printf "~a\n" (gen-list 8))
; Run a loop that uses local vars a few times
(printf "Generating Primitives in loops~n")
(printf "Generating Primitives in loops\n")
(loop 20)
(printf "Try Allocating large list again~n")
(printf "~a~n" (gen-list 8))
(printf "Try Allocating large list again\n")
(printf "~a\n" (gen-list 8))
; Create some circular references
@ -54,25 +54,25 @@
(set-rest! x y)
x)))
(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 "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 "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 "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 "Running sample tests~n")
(printf "Running sample tests\n")
(define (fact x)
(if (zero? x)
1
@ -114,18 +114,18 @@
(define head (cons 4 (cons 3 (cons 2 tail))))
(set-rest! tail head)
(printf "res ~a~n" head)
(printf "res ~a\n" head)
(set! head empty)
(set! tail head)
(printf "res ~a~n" lst)
(printf "res ~a~n" (length '(hello goodbye)))
(printf "res ~a~n" (map sub1 lst))
(printf "res ~a\n" lst)
(printf "res ~a\n" (length '(hello goodbye)))
(printf "res ~a\n" (map sub1 lst))
(printf "(fact-help 15 1): ~a~n" (fact-help 15 1))
(printf "(fact 9): ~a~n" (fact 9))
(printf "(fact-help 15 1): ~a\n" (fact-help 15 1))
(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 "(filter even? (map sub1 lst)): ~a~n" (filter even? (map sub1 lst)))
(printf "(length lst): ~a~n" (length 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 "(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))))))
(command-line #:args (n)
(printf "Ack(3,~a): ~a~n"
(printf "Ack(3,~a): ~a\n"
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)))
((= i n))
(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))

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

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

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

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

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

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

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

@ -40,6 +40,6 @@
(when (> counter 0)
(set! result (test-lists))
(loop (- counter 1))))
(printf "~s~n" result)))
(printf "~s\n" result)))
(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))]
[x 0])
(nest 6 (set! x (+ x 1)))
(printf "~s~n" x)))
(printf "~s\n" x)))
(main (current-command-line-arguments))

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

@ -35,5 +35,5 @@
(gen_random 100.0)
(loop (- iter 1)))
#t))
(printf "~a~%"
(printf "~a\n"
(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)
(printf "Ack(3,~A): ~A~%" n (ack 3 n))
(printf "Fib(~a): ~a~%"
(printf "Ack(3,~A): ~A\n" n (ack 3 n))
(printf "Fib(~a): ~a\n"
(real->decimal-string (+ 27.0 n) 1)
(real->decimal-string (fibflt (+ 27.0 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 "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
(printf "Fib(3): ~A\n" (fib 3))
(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)]
[count (add1 count)])
(when (zero? n)
(printf "~a: ~a~n" count num))
(printf "~a: ~a\n" count num))
(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))))))
(command-line #:args (n)
(printf "Ack(3,~a): ~a~n"
(printf "Ack(3,~a): ~a\n"
n
(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)))
((= i n))
(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))

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

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

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

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

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

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

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

@ -44,6 +44,6 @@
(when (> counter 0)
(set! result (test-lists))
(loop (- counter 1))))
(printf "~s~n" result)))
(printf "~s\n" result)))
(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?)]
[x : Integer 0])
(nest 6 (set! x (+ x 1)))
(printf "~s~n" x)))
(printf "~s\n" x)))
(main (current-command-line-arguments))

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

@ -35,5 +35,5 @@
(gen_random 100.0)
(loop (- iter 1)))
#t))
(printf "~a~%"
(printf "~a\n"
(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))
(define (main n)
(printf "Ack(3,~A): ~A~%" n (ack 3 n))
(printf "Fib(~a): ~a~%"
(printf "Ack(3,~A): ~A\n" n (ack 3 n))
(printf "Fib(~a): ~a\n"
(real->decimal-string (+ 27.0 n) 1)
(real->decimal-string (fibflt (+ 27.0 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 "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
(printf "Fib(3): ~A\n" (fib 3))
(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))]
[count (add1 count)])
(when (zero? n)
(printf "~a: ~a~n" count num))
(printf "~a: ~a\n" count num))
(loop (cdr phones) count)))
(loop (cdr phones) count))))))))

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

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

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

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

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

@ -1,4 +1,4 @@
(printf "nested loop~n")
(printf "nested loop\n")
(time
(let loop ([n 10000])
(unless (zero? n)
@ -7,13 +7,13 @@
(loop (sub1 n))
(loop2 (sub1 m)))))))
(printf "single loop~n")
(printf "single loop\n")
(time
(let loop ([n 100000])
(unless (zero? n)
(loop (sub1 n)))))
(printf "Y loop~n")
(printf "Y loop\n")
(time
((lambda (f n) (f f n))
(lambda (loop n)
@ -22,27 +22,27 @@
100000))
(printf "let closure recur~n")
(printf "let closure recur\n")
(time
(let ([f (lambda (x) (sub1 x))])
(let loop ([n 100000])
(unless (zero? n)
(loop (f n))))))
(printf "direct closure recur~n")
(printf "direct closure recur\n")
(time
(let loop ([n 100000])
(unless (zero? n)
(loop ((lambda (x) (sub1 x)) n)))))
(printf "direct closure recur if~n")
(printf "direct closure recur if\n")
(time
(let loop ([n 100000])
(if (zero? n)
(void)
(loop ((lambda (x) (sub1 x)) n)))))
(printf "let closure top-level~n")
(printf "let closure top-level\n")
(define loop
(let ([f (lambda (x) (sub1 x))])
(lambda (n)
@ -50,7 +50,7 @@
(loop (f n))))))
(time (loop 100000))
(printf "direct closure top-level~n")
(printf "direct closure top-level\n")
(define loop
(lambda (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)
@ -51,7 +51,7 @@
(error "check-failed" (file-position p) c c2)
(begin
(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))
(loop (add1 badc)))))
(unless (eof-object? c)
@ -107,8 +107,8 @@
(define r2 #f)
(define w2 #f)
(thread (copy-stream (cadddr p) (current-error-port)))
(fprintf (cadr p) "(define log void)~n")
(fprintf (cadr p) "~s~n" cs-prog)
(fprintf (cadr p) "(define log void)\n")
(fprintf (cadr p) "~s\n" cs-prog)
(if tcp?
(let ([t
(thread (lambda ()
@ -118,12 +118,12 @@
(set! w ww)
(set! r2 rr2)
(set! w2 ww2)))])
(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 (r w) (tcp-connect \"localhost\" ~a))\n" portno)
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
(flush-output (cadr p))
(thread-wait t)
(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 ((copy-stream r w2)) (exit))\n"))
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
(flush-output (cadr p))
(unless tcp?
@ -149,51 +149,51 @@
(let ([ps-ms (current-process-milliseconds)]
[gc-ms (current-gc-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)
(- ms start-ms)
(- gc-ms start-gc-ms))))
'(thread (lambda ()
(let loop ()
(printf "alive~n")
(printf "alive\n")
(sleep 1)
(loop))))
(start "Quick check:~n")
(start "Quick check:\n")
(define p (open-input-file test-file))
(check-file/fast p)
(close-input-port p)
(end)
(start "Quicker check:~n")
(start "Quicker check:\n")
(define p (open-input-file test-file))
(check-file/fastest p)
(close-input-port p)
(end)
(start "Plain pipe...~n")
(start "Plain pipe...\n")
(define-values (r w) (make-pipe))
(feed-file w)
(close-output-port w)
(check-file r)
(end)
(start "Plain pipe, faster...~n")
(start "Plain pipe, faster...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fast r)
(end)
(start "Plain pipe, fastest...~n")
(start "Plain pipe, fastest...\n")
(define-values (r w) (make-pipe))
(feed-file/fast w)
(close-output-port w)
(check-file/fastest r)
(end)
(start "Limited pipe...~n")
(start "Limited pipe...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file w)
@ -201,7 +201,7 @@
(check-file r)
(end)
(start "Limited pipe, faster...~n")
(start "Limited pipe, faster...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
@ -209,7 +209,7 @@
(check-file/fast r)
(end)
(start "Limited pipe, fastest...~n")
(start "Limited pipe, fastest...\n")
(define-values (r w) (make-pipe 253))
(thread (lambda ()
(feed-file/fast w)
@ -217,8 +217,8 @@
(check-file/fastest r)
(end)
(start "To file and back:~n")
(start " to...~n")
(start "To file and back:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
@ -228,7 +228,7 @@
(close-output-port p)
(end)
(start " back...~n")
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
@ -238,8 +238,8 @@
(check-file r)
(end)
(start "To file and back, faster:~n")
(start " to...~n")
(start "To file and back, faster:\n")
(start " to...\n")
(define-values (r w) (make-pipe))
(define p (open-output-file tmp-file #:exists 'truncate))
(define t (thread (copy-stream r p)))
@ -249,7 +249,7 @@
(close-output-port p)
(end)
(start " back...~n")
(start " back...\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
@ -259,7 +259,7 @@
(check-file/fast r)
(end)
(start "File back, fastest:~n")
(start "File back, fastest:\n")
(define-values (r w) (make-pipe))
(define p (open-input-file tmp-file))
(define t (thread (copy-stream p w)))
@ -269,7 +269,7 @@
(check-file/fastest r)
(end)
(start "Echo...~n")
(start "Echo...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file (cadr p))
@ -277,7 +277,7 @@
(check-file (car p))
(end)
(start "Echo, faster...~n")
(start "Echo, faster...\n")
(define p (setup-mzscheme-echo #f))
(thread (lambda ()
(feed-file/fast (cadr p))
@ -285,7 +285,7 @@
(check-file/fast (car p))
(end)
(start "Echo, indirect...~n")
(start "Echo, indirect...\n")
(define p (setup-mzscheme-echo #f))
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
@ -300,7 +300,7 @@
(define l1 (tcp-listen 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))
(close-input-port r)
(thread (lambda ()
@ -310,7 +310,7 @@
(close-input-port r2)
(end)
(start "TCP Echo, faster...~n")
(start "TCP Echo, faster...\n")
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
(close-input-port r)
(thread (lambda ()
@ -320,7 +320,7 @@
(close-input-port r2)
(end)
(start "TCP Echo, indirect...~n")
(start "TCP Echo, indirect...\n")
(define-values (rp1 wp1) (make-pipe))
(define-values (rp2 wp2) (make-pipe))
(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"
(let ([p (process* cat)])
(fprintf (cadr p) "Hello~n")
(fprintf (cadr p) "Hello\n")
(close-output-port (cadr p))
(test "Hello" read-line (car p))
(test eof read-line (car p))
@ -38,7 +38,7 @@
;; Generate output to stderr as well as stdout
(let ([p (process* cat "-" "nosuchfile")])
(fprintf (cadr p) "Hello~n")
(fprintf (cadr p) "Hello\n")
(close-output-port (cadr p))
(test "Hello" read-line (car p))
(test eof read-line (car p))
@ -58,7 +58,7 @@
(let ([p (process*/ports f #f #f cat)])
(test #f car p)
(fprintf (cadr p) "Hello~n")
(fprintf (cadr p) "Hello\n")
(close-output-port (cadr p))
(test eof read-line (cadddr p))
@ -78,7 +78,7 @@
(test #f car p)
(test #f cadddr p)
(fprintf (cadr p) "Hello~n")
(fprintf (cadr p) "Hello\n")
(close-output-port (cadr p))
((list-ref p 4) 'wait)
@ -132,7 +132,7 @@
(test #f car p)
(test #f cadddr p)
(fprintf (cadr p) "First line~n")
(fprintf (cadr p) "First line\n")
(close-output-port (cadr p))
((list-ref p 4) 'wait)
@ -153,7 +153,7 @@
(test #f car p)
(test #f cadddr p)
(fprintf (cadr p) "The line~n")
(fprintf (cadr p) "The line\n")
(close-output-port (cadr p))
((list-ref p 4) 'wait)
@ -175,7 +175,7 @@
;; Supply file for stdin
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
(fprintf f "Howdy~n")
(fprintf f "Howdy\n")
(close-output-port f))
(let ([f (open-input-file tmpfile)])
(let ([p (process*/ports #f f #f cat)])
@ -256,7 +256,7 @@
"(let loop () (unless (eof-object? (eval (read))) (loop)))")))
(define (test-line out in)
(fprintf w "~a~n" in)
(fprintf w "~a\n" in)
(flush-output w)
(when out
(test out (lambda (ignored) (read-line r)) in)))

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

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

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

@ -53,9 +53,9 @@
(define make-move
(lambda (other-move p/o tag)
(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)))
(printf "terminal states removed: ~s~n"
(printf "terminal states removed: ~s\n"
(- (length states) (length t)))
(if (null? t)
(void)

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

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

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

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

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

@ -102,87 +102,12 @@
(define bi (make-boxed-uint 42))
(printf "~a~n" results-1)
(printf "~a~n" results-2)
(printf "~a~n" results-3)
(printf "~a~n" ind-result-1)
(printf "~a~n" ind-result-2)
(printf "~a~n" ind-result-3)
(printf "~a~n" ind-result-4)
(printf "~a~n" (read-boxed-uint bi))
(printf "~a\n" results-1)
(printf "~a\n" results-2)
(printf "~a\n" results-3)
(printf "~a\n" ind-result-1)
(printf "~a\n" ind-result-2)
(printf "~a\n" ind-result-3)
(printf "~a\n" ind-result-4)
(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
(lambda (exn)
(if (check? exn)
(printf " ~a~n" (exn-message exn))
(printf " ~a\n" (exn-message exn))
(let ([ok-type? (exn:application:arity? exn)])
(printf " WRONG EXN ~a: ~s~n"
(printf " WRONG EXN ~a: ~s\n"
(if ok-type?
"FIELD"
"TYPE")
@ -240,7 +240,7 @@
(cons f args)))))
(done (void)))])
(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))))))])
(let loop ([n 0][l '()])
(unless (>= n min)
@ -265,11 +265,11 @@
(test l call-with-values thunk list))
(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)
(printf "and ~a exception field tests.~n~n"
(printf "and ~a exception field tests.\n\n"
number-of-exn-tests)
(if (null? errs)
(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")
(provide start)
(define (start x)
(begin (printf "Before~n")
(begin (printf "Before\n")
(values 1 x)
(printf "After~n")
(printf "After\n")
x))))])
(check = 3 (test `(dispatch-start start 3)))))
@ -118,9 +118,9 @@
(provide start)
(define (start x)
(begin0 x
(printf "Before~n")
(printf "Before\n")
(values 1 x)
(printf "After~n")))))])
(printf "After\n")))))])
(check = 3 (test `(dispatch-start start 3)))))
(test-case
@ -132,9 +132,9 @@
(define (start x)
(let-values ([(_ ans)
(begin0 (values 1 x)
(printf "Before~n")
(printf "Before\n")
x
(printf "After~n"))])
(printf "After\n"))])
ans))))])
(check = 3 (test `(dispatch-start start 3))))))
@ -229,18 +229,18 @@
(cadr
(call-with-serializable-current-continuation
(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))))))
(define (start ignore)
(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)))))
(table-01-eval '(require 'm06))
(let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
[second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
[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 = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
@ -258,12 +258,12 @@
(cadr
(call-with-serializable-current-continuation
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(let ([ignore (printf "Please send the ~a number.\n" which)])
k)))))
(define (start ignore)
(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)))))])
(let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
[second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
@ -285,12 +285,12 @@
(cadr
(call-with-serializable-current-continuation
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(let ([ignore (printf "Please send the ~a number.\n" which)])
k)))))
(define (start ignore)
(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)))))])
(let* ([first-key (test-m06.2 '(dispatch-start start 'foo))]
[second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
@ -382,7 +382,7 @@
(cadr
(call-with-serializable-current-continuation
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(let ([ignore (printf "Please send the ~a number.\n" which)])
k)))))
(define (start ignore)
@ -391,7 +391,7 @@
[g (let ([n (gn "second")])
(lambda (m) (+ n (f m))))])
(let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
(let ([ignore (printf "The answer is: ~s\n" result)])
result))))))])
(let* ([k0 (test-m08 '(serialize (dispatch-start start 'foo)))]
[k1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))]
@ -416,7 +416,7 @@
(define (non-tail-apply f . args)
(let ([result (apply f args)])
(printf "result = ~s~n" result)
(printf "result = ~s\n" result)
result))))])
(nta-eval '(module m09 (lib "lang.rkt" "web-server")
(require 'nta)
@ -438,7 +438,7 @@
(provide start)
(define (nta f arg)
(let ([result (f arg)])
(printf "result = ~s~n" result)
(printf "result = ~s\n" result)
result))
(define (start ignore)
(nta (lambda (x) (let/cc k (k x))) 7))))])
@ -493,7 +493,7 @@
(map
(lambda (n) (call-with-serializable-current-continuation
(lambda (k)
(let ([ignore (printf "n = ~s~n" n)])
(let ([ignore (printf "n = ~s\n" n)])
k))))
(list 1 2 3)))))])
(check-true (catch-unsafe-context-exn
@ -519,7 +519,7 @@
(cadr
(call-with-serializable-current-continuation
(lambda (k)
(let ([ignore (printf "n = ~s~n" n)])
(let ([ignore (printf "n = ~s\n" n)])
k))))) 7)))))
(ta-eval '(require 'm14))

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

@ -99,7 +99,7 @@
(define (alpha= expr1 expr2)
(define r (alpha=/env empty-env empty-env expr1 expr2))
(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)
(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)
(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
#;(define (collect d req)
@ -108,14 +108,14 @@
; This causes a dead lock, even though the log shows that the channel should sync
(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)
(printf "-CHAN ~S PUT: ~S~n" c v))
(printf "-CHAN ~S PUT: ~S\n" c v))
(define (channel-get* c)
(printf "+CHAN ~S GET~n" c)
(printf "+CHAN ~S GET\n" c)
(let ([v (channel-get c)])
(printf "-CHAN ~S GET: ~S~n" c v)
(printf "-CHAN ~S GET: ~S\n" c v)
v))
#;(define (collect d req)

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

@ -426,22 +426,22 @@
(let ([tag (car s)])
(case tag
[(local)
(format "{~a}~n" (output (cadr s)))]
(format "{~a}\n" (output (cadr s)))]
[(begin)
(apply string-append (map output (cdr s)))]
[(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)
(apply string-append (map output (cdddr s))))]
[(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)))]
[(thickness)
(format "\\~a~a" (cadr s) (output (caddr s)))]
[(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)
(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)
(format "[~a]" (cadr s))
"")

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