Changeset 8155 in project


Ignore:
Timestamp:
02/05/08 09:01:47 (12 years ago)
Author:
felix winkelmann
Message:

refactored [sf]printf, non-tty port is buffered first (ticket #418)

Location:
chicken/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/buildsvnrevision

    r8153 r8155  
    1 8152
     18154
  • chicken/trunk/extras.scm

    r8153 r8155  
    8181(declare
    8282  (hide
    83     #;##sys#sprintf
     83   fprintf0
    8484    ##sys#hash-table-ref        ; shadows eval unit defines if not hidden
    8585    ##sys#hash-table-update!
     
    13291329;;; Write simple formatted output:
    13301330
    1331 (define fprintf
    1332   (let ([write write]
    1333         [newline newline]
    1334         [display display] )
    1335     (lambda (port msg . args)
     1331(define fprintf0
     1332  (let ((write write)
     1333        (newline newline)
     1334        (display display)
     1335        (open-output-string open-output-string)
     1336        (get-output-string get-output-string))
     1337    (lambda (loc port msg args)
    13361338      (let rec ([msg msg] [args args])
    1337         (##sys#check-string msg 'fprintf)
    1338         (##sys#check-port port 'fprintf)
     1339        (##sys#check-string msg loc)
     1340        (when port (##sys#check-port port loc))
    13391341        (let ((index 0)
    1340               (len (##sys#size msg)) )
     1342              (len (##sys#size msg))
     1343              (out (if (and port (##sys#tty-port? port))
     1344                       port
     1345                       (open-output-string))))
    13411346          (define (fetch)
    13421347            (let ((c (##core#inline "C_subchar" msg index)))
     
    13451350          (define (next)
    13461351            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
    1347                 (##sys#error 'fprintf "too few arguments to formatted output procedure")
     1352                (##sys#error loc "too few arguments to formatted output procedure")
    13481353                (let ((x (##sys#slot args 0)))
    13491354                  (set! args (##sys#slot args 1))
     
    13551360                    (let ((dchar (fetch)))
    13561361                      (case (char-upcase dchar)
    1357                         ((#\S) (write (next) port))
    1358                         ((#\A) (display (next) port))
    1359                         ((#\C) (##sys#write-char-0 (next) port))
    1360                         ((#\B) (display (##sys#number->string (next) 2) port))
    1361                         ((#\O) (display (##sys#number->string (next) 8) port))
    1362                         ((#\X) (display (##sys#number->string (next) 16) port))
    1363                         ((#\!) (##sys#flush-output port))
     1362                        ((#\S) (write (next) out))
     1363                        ((#\A) (display (next) out))
     1364                        ((#\C) (##sys#write-char-0 (next) out))
     1365                        ((#\B) (display (##sys#number->string (next) 2) out))
     1366                        ((#\O) (display (##sys#number->string (next) 8) out))
     1367                        ((#\X) (display (##sys#number->string (next) 16) out))
     1368                        ((#\!) (##sys#flush-output out))
    13641369                        ((#\?)
    13651370                         (let* ([fstr (next)]
     
    13671372                           (##sys#check-list lst 'fprintf)
    13681373                           (rec fstr lst) ) )
    1369                         ((#\~) (##sys#write-char-0 #\~ port))
    1370                         ((#\%) (newline port))
    1371                         ((#\% #\N) (newline port))
     1374                        ((#\~) (##sys#write-char-0 #\~ out))
     1375                        ((#\%) (newline out))
     1376                        ((#\% #\N) (newline out))
    13721377                        (else
    13731378                         (if (char-whitespace? dchar)
     
    13761381                                   (skip (fetch))
    13771382                                   (set! index (fx- index 1)) ) )
    1378                              (##sys#error 'fprintf "illegal format-string character" dchar) ) ) ) )
    1379                     (##sys#write-char-0 c port) )
    1380                 (loop) ) ) ) ) ) ) ) )
    1381 
    1382 
    1383 (define printf
    1384   (let ((fprintf fprintf)
    1385         (current-output-port current-output-port) )
    1386     (lambda (msg . args)
    1387       (apply fprintf (current-output-port) msg args) ) ) )
    1388 
    1389 
    1390 (define sprintf
    1391   (let ((open-output-string open-output-string)
    1392         (get-output-string get-output-string)
    1393         (fprintf fprintf) )
    1394     (lambda (fstr . args)
    1395       (let ((out (open-output-string)))
    1396         (apply fprintf out fstr args)
    1397         (get-output-string out) ) ) ) )
    1398 
     1383                             (##sys#error loc "illegal format-string character" dchar) ) ) ) )
     1384                    (##sys#write-char-0 c out) )
     1385                (loop) ) ) )
     1386          (cond ((not port) (get-output-string out))
     1387                ((not (eq? out port))
     1388                 (##sys#print (get-output-string out) #f port) ) ) ) ) ) ) )
     1389
     1390(define (fprintf port fstr . args)
     1391  (fprintf0 'fprintf port fstr args) )
     1392
     1393(define (printf fstr . args)
     1394  (fprintf0 'printf ##sys#standard-output fstr args) )
     1395
     1396(define (sprintf fstr . args)
     1397  (fprintf0 'sprintf #f fstr args) )
    13991398
    14001399(define format
Note: See TracChangeset for help on using the changeset viewer.