home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / stdio < prev    next >
Text File  |  1994-06-06  |  4KB  |  150 lines
  1. ;;;; "stdio.scm" Implementation of <stdio.h> functions for Scheme
  2. ;;; Copyright (C) 1991-1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Floating point is not handled yet.  It should not be hard to do.
  21.  
  22. (define (stdio:iprintf out format . args)
  23.   (let loop ((pos 0) (args args))
  24.     (if (< pos (string-length format))
  25.     (case (string-ref format pos)
  26.       ((#\\ )
  27.        (set! pos (+ pos 1))
  28.        (case (string-ref format pos)
  29.          ((#\n #\N) (out #\newline))
  30.          ((#\t #\T) (out slib:tab))
  31.          ((#\r #\R) (out #\return))
  32.          ((#\f #\F) (out slib:form-feed))
  33.          (else (out (string-ref format pos))))
  34.        (loop (+ pos 1) args))
  35.       ((#\%)
  36.        (set! pos (+ pos 1))
  37.        (letrec ((left-adjust #f)
  38.             (pad-char 
  39.              (if (char=? #\0 (string-ref format pos)) #\0 #\ ))
  40.             (width 0)
  41.             (prec #f)
  42.             (pad
  43.              (lambda (s)
  44.                (cond ((<= width (string-length s)) s)
  45.                  (left-adjust
  46.                   (string-append
  47.                    s
  48.                    (make-string (- width (string-length s))
  49.                         #\ )))
  50.                  (else
  51.                   (string-append
  52.                    (make-string (- width (string-length s))
  53.                         pad-char)
  54.                    s))))))
  55.          (let ilp ((pos pos))
  56.            (case (string-ref format pos)
  57.          ((#\d #\D #\u #\U)
  58.           (out (pad (cond ((symbol? (car args))
  59.                    (symbol->string (car args)))
  60.                   ((number? (car args))
  61.                    (number->string (car args)))
  62.                   ((not (car args)) "0")
  63.                   (else "1"))))
  64.           (loop (+ pos 1) (cdr args)))
  65.          ((#\c #\C)
  66.           (out (pad (string (car args))))
  67.           (loop (+ pos 1) (cdr args)))
  68.          ((#\o #\O)
  69.           (out (pad (number->string (car args) 8)))
  70.           (loop (+ pos 1) (cdr args)))
  71.          ((#\x #\X)
  72.           (out (pad (number->string (car args) 16)))
  73.           (loop (+ pos 1) (cdr args)))
  74.          ((#\l #\L) (ilp (+ pos 1)))
  75.          ((#\-) (set! left-adjust #t)
  76.             (ilp (+ pos 1)))
  77.          ((#\.)
  78.           (set! prec 0)
  79.           (set! pos (+ 1 pos))
  80.           (let iilp ()
  81.             (case (string-ref format pos)
  82.               ((#\*) (set! prec (car args))
  83.                  (set! args (cdr args))
  84.                  (ilp (+ pos 1)))
  85.               ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  86.                (set! prec
  87.                  (+ (* prec 10)
  88.                 (- (char->integer (string-ref format pos))
  89.                    (char->integer #\0))))
  90.                (set! pos (+ 1 pos))
  91.                (iilp))
  92.               (else (ilp pos)))))
  93.          ((#\%) (out #\%)
  94.             (loop (+ pos 1) args))
  95.          ((#\s #\S)
  96.           (if (or (not prec)
  97.               (>= prec (string-length (car args))))
  98.               (out (pad (car args)))
  99.               (out (pad (substring (car args) 0 prec))))
  100.           (loop (+ pos 1) (cdr args)))
  101.          ((#\*) (set! width (car args))
  102.             (set! args (cdr args))
  103.             (ilp (+ pos 1)))
  104.          ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  105.           (set! width (+ (* width 10)
  106.                  (- (char->integer (string-ref format pos))
  107.                     (char->integer #\0))))
  108.           (ilp (+ pos 1)))
  109.          (else (out #\%)
  110.                (out (string-ref format pos))
  111.                (loop (+ pos 1) args))))))
  112.       (else (out (string-ref format pos))
  113.         (loop (+ pos 1) args))))))
  114.  
  115. (define (stdio:printf format . args)
  116.   (apply stdio:iprintf display format args))
  117.  
  118. (define (stdio:fprintf port format . args)
  119.   (if (equal? port (current-output-port))
  120.       (apply stdio:iprintf display format args)
  121.       (apply stdio:iprintf (lambda (x) (display x port)) format args)))
  122.  
  123. (define (stdio:sprintf s format . args)
  124.   (let ((p 0) (end (string-length s)))
  125.     (apply stdio:iprintf
  126.        (lambda (x)
  127.          (cond ((string? x)
  128.             (do ((i 0 (+ i 1)))
  129.             ((>= i (min (string-length x) end)))
  130.               (string-set! s p (string-ref x i))
  131.               (set! p (+ p 1))))
  132.            ((>= p end))
  133.            ((char? x)
  134.             (string-set! s p x)
  135.             (set! p (+ p 1)))
  136.            (else
  137.             (string-set! s p #\?)
  138.             (set! p (+ p 1)))))
  139.        format
  140.        args)
  141.     p))
  142.  
  143. (define printf stdio:printf)
  144. (define fprintf stdio:fprintf)
  145. (define sprintf stdio:sprintf)
  146.  
  147. (define stdin (current-input-port))
  148. (define stdout (current-output-port))
  149. (define stderr (current-error-port))
  150.