source: project/chicken/trunk/extras.scm @ 15559

Last change on this file since 15559 was 15559, checked in by felix winkelmann, 10 years ago

test for srandom availability in extras was insufficient - removed srandom support

File size: 22.1 KB
Line 
1;;; extras.scm - Optional non-standard extensions
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29 (unit extras)
30 (uses data-structures ports)
31 (usual-integrations)
32 (disable-warning redef) )
33
34(cond-expand
35 [paranoia]
36 [else
37  (declare
38    (no-bound-checks)
39    (no-procedure-checks-for-usual-bindings)
40    (bound-to-procedure
41      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
42      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
43      ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
44      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
45      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
46      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
47      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
48      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
49      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
50      ##sys#fragments->string ##sys#symbol->qualified-string
51      reverse-string-append ##sys#number? ##sys#procedure->string
52      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
53      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
54      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
55      input-port? make-vector list->vector sort! merge! open-output-string floor
56      get-output-string current-output-port display write port? list->string
57      make-string string pretty-print-width newline char-name read random
58      open-input-string make-string call-with-input-file read-line reverse ) ) ] )
59
60(declare
61  (hide
62    fprintf0 generic-write reverse-string-append) )
63
64(include "unsafe-declarations.scm")
65
66(register-feature! 'extras)
67
68
69;;; Read expressions from file:
70
71(define read-file
72  (let ([read read]
73        [reverse reverse] 
74        [call-with-input-file call-with-input-file] )
75    (lambda (#!optional (port ##sys#standard-input) (reader read) max)
76      (define (slurp port)
77        (do ((x (reader port) (reader port))
78             (i 0 (fx+ i 1))
79             (xs '() (cons x xs)) )
80            ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
81      (if (port? port)
82          (slurp port)
83          (call-with-input-file port slurp) ) ) ) )
84
85
86;;; Random numbers:
87
88(define random-seed
89  (let ((srand (foreign-lambda void "srand" unsigned-integer)))
90    (lambda n
91      (let ((t (if (null? n) (current-seconds) (car n))))
92        (##sys#check-integer t 'random-seed)
93        (srand t) ) ) ) )
94
95(define (randomize . n)
96  (let ((nn (if (null? n) (##sys#fudge 2) (car n))))
97    (##sys#check-exact nn 'randomize)
98    (##core#inline "C_randomize" nn) ) )
99
100(define (random n)
101  (##sys#check-exact n 'random)
102  (if (eq? n 0)
103      0
104      (##core#inline "C_random_fixnum" n) ) )
105
106
107;;; Line I/O:
108
109(define read-line
110  (let ([make-string make-string])
111    (define (fixup str len)
112      (##sys#substring
113       str 0
114       (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
115           (fx- len 1)
116           len) ) )
117    (lambda args
118      (let* ([parg (pair? args)]
119             [p (if parg (car args) ##sys#standard-input)]
120             [limit (and parg (pair? (cdr args)) (cadr args))])
121        (##sys#check-port p 'read-line)
122        (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
123              (else
124               (let* ((buffer-len (if limit limit 256))
125                      (buffer (##sys#make-string buffer-len)))
126                 (let loop ([i 0])
127                   (if (and limit (fx>= i limit))
128                       (##sys#substring buffer 0 i)
129                       (let ([c (##sys#read-char-0 p)])
130                         (if (eof-object? c)
131                             (if (fx= i 0)
132                                 c
133                                 (##sys#substring buffer 0 i) ) 
134                             (case c
135                               [(#\newline) (##sys#substring buffer 0 i)]
136                               [(#\return)
137                                (let ([c (peek-char p)])
138                                  (if (char=? c #\newline)
139                                      (begin (##sys#read-char-0 p)
140                                             (##sys#substring buffer 0 i))
141                                      (##sys#substring buffer 0 i) ) ) ]
142                               [else
143                                (when (fx>= i buffer-len)
144                                  (set! buffer (##sys#string-append buffer (make-string buffer-len)))
145                                  (set! buffer-len (fx+ buffer-len buffer-len)) )
146                                (##core#inline "C_setsubchar" buffer i c)
147                                (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
148
149(define read-lines
150  (let ((read-line read-line)
151        (call-with-input-file call-with-input-file) 
152        (reverse reverse) )
153    (lambda port-and-max
154      (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
155             (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
156             (max (if (pair? rest) (##sys#slot rest 0) #f)) )
157        (define (doread port)
158          (let loop ((lns '())
159                     (n (or max 1000000000)) ) ; this is silly
160            (if (eq? n 0)
161                (reverse lns)
162                (let ((ln (read-line port)))
163                  (if (eof-object? ln)
164                      (reverse lns)
165                      (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
166        (if (string? port)
167            (call-with-input-file port doread)
168            (begin
169              (##sys#check-port port 'read-lines)
170              (doread port) ) ) ) ) ) )
171
172
173;;; Extended I/O
174
175(define (##sys#read-string! n dest port start)
176  (cond ((eq? n 0) 0)
177        (else
178         (when (##sys#slot port 6)      ; peeked?
179           (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
180           (set! start (fx+ start 1)) )
181         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
182           (if rdstring
183               (let loop ((start start) (n n) (m 0))
184                 (let ((n2 (rdstring port n dest start)))
185                   (##sys#setislot port 5 ; update port-position
186                                   (fx+ (##sys#slot port 5) n2))
187                   (cond ((eq? n2 0) m)
188                         ((or (not n) (fx< n2 n)) 
189                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)))
190                         (else (fx+ n2 m)))))
191               (let loop ((start start) (n n) (m 0))
192                 (let ((n2 (let ((c (##sys#read-char-0 port)))
193                             (if (eof-object? c)
194                                 0
195                                 (begin
196                                   (##core#inline "C_setsubchar" dest start c)
197                                   1) ) )  ) )
198                   (cond ((eq? n2 0) m)
199                         ((or (not n) (fx< n2 n)) 
200                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
201                         (else (fx+ n2 m))) )))))))
202
203(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
204  (##sys#check-port port 'read-string!)
205  (##sys#check-string dest 'read-string!)
206  (when n
207    (##sys#check-exact n 'read-string!)
208    (when (fx> (fx+ start n) (##sys#size dest))
209      (set! n (fx- (##sys#size dest) start))))
210  (##sys#check-exact start 'read-string!)
211  (##sys#read-string! n dest port start) )
212
213(define-constant read-string-buffer-size 2048)
214
215(define ##sys#read-string/port
216  (let ((open-output-string open-output-string)
217        (get-output-string get-output-string) )
218    (lambda (n p)
219      (##sys#check-port p 'read-string)
220      (cond (n (##sys#check-exact n 'read-string)
221               (let* ((str (##sys#make-string n))
222                      (n2 (##sys#read-string! n str p 0)) )
223                 (if (eq? n n2)
224                     str
225                     (##sys#substring str 0 n2))))
226            (else
227             (let ([out (open-output-string)]
228                   (buf (make-string read-string-buffer-size)))
229               (let loop ()
230                 (let ((n (##sys#read-string! read-string-buffer-size
231                                              buf p 0)))
232                   (cond ((eq? n 0)
233                          (get-output-string out))
234                         (else
235                          (write-string buf n out)
236                          (loop)))))))))))
237
238(define (read-string #!optional n (port ##sys#standard-input))
239  (##sys#read-string/port n port) )
240
241(define read-token
242  (let ([open-output-string open-output-string]
243        [get-output-string get-output-string] )
244    (lambda (pred . port)
245      (let ([port (optional port ##sys#standard-input)])
246        (##sys#check-port port 'read-token)
247        (let ([out (open-output-string)])
248          (let loop ()
249            (let ([c (##sys#peek-char-0 port)])
250              (if (and (not (eof-object? c)) (pred c))
251                  (begin
252                    (##sys#write-char-0 (##sys#read-char-0 port) out)
253                    (loop) )
254                  (get-output-string out) ) ) ) ) ) ) ) )
255
256(define write-string 
257  (let ([display display])
258    (lambda (s . more)
259      (##sys#check-string s 'write-string)
260      (let-optionals more ([n #f] [port ##sys#standard-output])
261        (##sys#check-port port 'write-string)
262        (when n (##sys#check-exact n 'write-string))
263        (display
264         (if (and n (fx< n (##sys#size s)))
265             (##sys#substring s 0 n)
266             s)
267         port) ) ) ) )
268
269(define write-line
270  (let ((display display)
271        (newline newline) )
272    (lambda (str . port)
273      (let ((p (if (##core#inline "C_eqp" port '())
274                   ##sys#standard-output
275                   (##sys#slot port 0) ) ) )
276        (##sys#check-port p 'write-line)
277        (##sys#check-string str 'write-line)
278        (display str p)
279        (newline p) ) ) ) )
280
281
282;;; Binary I/O
283
284(define (read-byte #!optional (port ##sys#standard-input))
285  (##sys#check-port port 'read-byte)
286  (let ((x (##sys#read-char-0 port)))
287    (if (eof-object? x)
288        x
289        (char->integer x) ) ) )
290
291(define (write-byte byte #!optional (port ##sys#standard-output))
292  (##sys#check-exact byte 'write-byte)
293  (##sys#check-port port 'write-byte)
294  (##sys#write-char-0 (integer->char byte) port) )
295
296
297
298
299;;; Pretty print:
300;
301; Copyright (c) 1991, Marc Feeley
302; Author: Marc Feeley (feeley@iro.umontreal.ca)
303; Distribution restrictions: none
304;
305; Modified by felix for use with CHICKEN
306;
307
308(define generic-write
309  (let ([open-output-string open-output-string]
310        [get-output-string get-output-string] )
311    (lambda (obj display? width output)
312
313      (define (read-macro? l)
314        (define (length1? l) (and (pair? l) (null? (cdr l))))
315        (let ((head (car l)) (tail (cdr l)))
316          (case head
317            ((quote quasiquote unquote unquote-splicing) (length1? tail))
318            (else                                        #f))))
319
320      (define (read-macro-body l)
321        (cadr l))
322
323      (define (read-macro-prefix l)
324        (let ((head (car l)) (tail (cdr l)))
325          (case head
326            ((quote)            "'")
327            ((quasiquote)       "`")
328            ((unquote)          ",")
329            ((unquote-splicing) ",@"))))
330
331      (define (out str col)
332        (and col (output str) (+ col (string-length str))))
333
334      (define (wr obj col)
335
336        (define (wr-expr expr col)
337          (if (read-macro? expr)
338              (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
339              (wr-lst expr col)))
340
341        (define (wr-lst l col)
342          (if (pair? l)
343              (let loop ((l (cdr l))
344                         (col (and col (wr (car l) (out "(" col)))))
345                (cond ((not col) col)
346                      ((pair? l)
347                       (loop (cdr l) (wr (car l) (out " " col))))
348                      ((null? l) (out ")" col))
349                      (else      (out ")" (wr l (out " . " col))))))
350              (out "()" col)))
351
352        (cond ((pair? obj)        (wr-expr obj col))
353              ((null? obj)        (wr-lst obj col))
354              ((eof-object? obj)  (out "#!eof" col))
355              ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
356              ((boolean? obj)     (out (if obj "#t" "#f") col))
357              ((##sys#number? obj)      (out (##sys#number->string obj) col))
358              ((symbol? obj)
359               (let ([s (open-output-string)])
360                 (##sys#print obj #t s)
361                 (out (get-output-string s) col) ) )
362              ((procedure? obj)   (out (##sys#procedure->string obj) col))
363              ((string? obj)      (if display?
364                                      (out obj col)
365                                      (let loop ((i 0) (j 0) (col (out "\"" col)))
366                                        (if (and col (< j (string-length obj)))
367                                            (let ((c (string-ref obj j)))
368                                              (if (or (char=? c #\\)
369                                                      (char=? c #\"))
370                                                  (loop j
371                                                        (+ j 1)
372                                                        (out "\\"
373                                                             (out (##sys#substring obj i j)
374                                                                  col)))
375                                                  (loop i (+ j 1) col)))
376                                            (out "\""
377                                                 (out (##sys#substring obj i j) col))))))
378              ((char? obj)        (if display?
379                                      (out (make-string 1 obj) col)
380                                      (let ([code (char->integer obj)])
381                                        (out "#\\" col)
382                                        (cond [(char-name obj) 
383                                               => (lambda (cn) 
384                                                    (out (##sys#slot cn 1) col) ) ]
385                                              [(fx< code 32)
386                                               (out "x" col)
387                                               (out (number->string code 16) col) ]
388                                              [(fx> code 255)
389                                               (out (if (fx> code #xffff) "U" "u") col)
390                                               (out (number->string code 16) col) ]
391                                              [else (out (make-string 1 obj) col)] ) ) ) )
392              ((eof-object? obj)  (out "#<eof>" col))
393              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
394              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
395              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
396               (out "#<unbound value>" col) )
397              ((##sys#generic-structure? obj)
398               (let ([o (open-output-string)])
399                 (##sys#user-print-hook obj #t o)
400                 (out (get-output-string o) col) ) )
401              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
402              ((##core#inline "C_bytevectorp" obj)
403               (if (##core#inline "C_permanentp" obj)
404                   (out "#<static blob of size" col)
405                   (out "#<blob of size " col) )
406               (out (number->string (##core#inline "C_block_size" obj)) col)
407               (out ">" col) )
408              ((##core#inline "C_lambdainfop" obj)
409               (out "#<lambda info " col)
410               (out (##sys#lambda-info->string obj) col)
411               (out "#>" col) )
412              (else (out "#<unprintable object>" col)) ) )
413
414      (define (pp obj col)
415
416        (define (spaces n col)
417          (if (> n 0)
418              (if (> n 7)
419                  (spaces (- n 8) (out "        " col))
420                  (out (##sys#substring "        " 0 n) col))
421              col))
422
423        (define (indent to col)
424          (and col
425               (if (< to col)
426                   (and (out (make-string 1 #\newline) col) (spaces to 0))
427                   (spaces (- to col) col))))
428
429        (define (pr obj col extra pp-pair)
430          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
431              (let ((result '())
432                    (left (max (+ (- (- width col) extra) 1) max-expr-width)))
433                (generic-write obj display? #f
434                               (lambda (str)
435                                 (set! result (cons str result))
436                                 (set! left (- left (string-length str)))
437                                 (> left 0)))
438                (if (> left 0)          ; all can be printed on one line
439                    (out (reverse-string-append result) col)
440                    (if (pair? obj)
441                        (pp-pair obj col extra)
442                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
443              (wr obj col)))
444
445        (define (pp-expr expr col extra)
446          (if (read-macro? expr)
447              (pr (read-macro-body expr)
448                  (out (read-macro-prefix expr) col)
449                  extra
450                  pp-expr)
451              (let ((head (car expr)))
452                (if (symbol? head)
453                    (let ((proc (style head)))
454                      (if proc
455                          (proc expr col extra)
456                          (if (> (string-length (##sys#symbol->qualified-string head))
457                                 max-call-head-width)
458                              (pp-general expr col extra #f #f #f pp-expr)
459                              (pp-call expr col extra pp-expr))))
460                    (pp-list expr col extra pp-expr)))))
461
462                                        ; (head item1
463                                        ;       item2
464                                        ;       item3)
465        (define (pp-call expr col extra pp-item)
466          (let ((col* (wr (car expr) (out "(" col))))
467            (and col
468                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
469
470                                        ; (item1
471                                        ;  item2
472                                        ;  item3)
473        (define (pp-list l col extra pp-item)
474          (let ((col (out "(" col)))
475            (pp-down l col col extra pp-item)))
476
477        (define (pp-down l col1 col2 extra pp-item)
478          (let loop ((l l) (col col1))
479            (and col
480                 (cond ((pair? l)
481                        (let ((rest (cdr l)))
482                          (let ((extra (if (null? rest) (+ extra 1) 0)))
483                            (loop rest
484                                  (pr (car l) (indent col2 col) extra pp-item)))))
485                       ((null? l)
486                        (out ")" col))
487                       (else
488                        (out ")"
489                             (pr l
490                                 (indent col2 (out "." (indent col2 col)))
491                                 (+ extra 1)
492                                 pp-item)))))))
493
494        (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
495
496          (define (tail1 rest col1 col2 col3)
497            (if (and pp-1 (pair? rest))
498                (let* ((val1 (car rest))
499                       (rest (cdr rest))
500                       (extra (if (null? rest) (+ extra 1) 0)))
501                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
502                (tail2 rest col1 col2 col3)))
503
504          (define (tail2 rest col1 col2 col3)
505            (if (and pp-2 (pair? rest))
506                (let* ((val1 (car rest))
507                       (rest (cdr rest))
508                       (extra (if (null? rest) (+ extra 1) 0)))
509                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
510                (tail3 rest col1 col2)))
511
512          (define (tail3 rest col1 col2)
513            (pp-down rest col2 col1 extra pp-3))
514
515          (let* ((head (car expr))
516                 (rest (cdr expr))
517                 (col* (wr head (out "(" col))))
518            (if (and named? (pair? rest))
519                (let* ((name (car rest))
520                       (rest (cdr rest))
521                       (col** (wr name (out " " col*))))
522                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
523                (tail1 rest (+ col indent-general) col* (+ col* 1)))))
524
525        (define (pp-expr-list l col extra)
526          (pp-list l col extra pp-expr))
527
528        (define (pp-lambda expr col extra)
529          (pp-general expr col extra #f pp-expr-list #f pp-expr))
530
531        (define (pp-if expr col extra)
532          (pp-general expr col extra #f pp-expr #f pp-expr))
533
534        (define (pp-cond expr col extra)
535          (pp-call expr col extra pp-expr-list))
536
537        (define (pp-case expr col extra)
538          (pp-general expr col extra #f pp-expr #f pp-expr-list))
539
540        (define (pp-and expr col extra)
541          (pp-call expr col extra pp-expr))
542
543        (define (pp-let expr col extra)
544          (let* ((rest (cdr expr))
545                 (named? (and (pair? rest) (symbol? (car rest)))))
546            (pp-general expr col extra named? pp-expr-list #f pp-expr)))
547
548        (define (pp-begin expr col extra)
549          (pp-general expr col extra #f #f #f pp-expr))
550
551        (define (pp-do expr col extra)
552          (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
553
554                                        ; define formatting style (change these to suit your style)
555
556        (define indent-general 2)
557
558        (define max-call-head-width 5)
559
560        (define max-expr-width 50)
561
562        (define (style head)
563          (case head
564            ((lambda let* letrec define) pp-lambda)
565            ((if set!)                   pp-if)
566            ((cond)                      pp-cond)
567            ((case)                      pp-case)
568            ((and or)                    pp-and)
569            ((let)                       pp-let)
570            ((begin)                     pp-begin)
571            ((do)                        pp-do)
572            (else                        #f)))
573
574        (pr obj col 0 pp-expr))
575
576      (if width
577          (out (make-string 1 #\newline) (pp obj 0))
578          (wr obj 0)))) )
579
580; (reverse-string-append l) = (apply string-append (reverse l))
581
582(define (reverse-string-append l)
583
584  (define (rev-string-append l i)
585    (if (pair? l)
586      (let* ((str (car l))
587             (len (string-length str))
588             (result (rev-string-append (cdr l) (+ i len))))
589        (let loop ((j 0) (k (- (- (string-length result) i) len)))
590          (if (< j len)
591            (begin
592              (string-set! result k (string-ref str j))
593              (loop (+ j 1) (+ k 1)))
594            result)))
595      (make-string i)))
596
597  (rev-string-append l 0))
598
599; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
600; output port is used if 'port' is not specified.
601
602(define pretty-print-width (make-parameter 79))
603
604(define (pretty-print obj . opt)
605  (let ((port (if (pair? opt) (car opt) (current-output-port))))
606    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
607    (##core#undefined) ) )
608
609(define pp pretty-print)
610
611
612;;; Write simple formatted output:
613
614(define fprintf0
615  (let ((write write)
616        (newline newline)
617        (display display) 
618        (open-output-string open-output-string)
619        (get-output-string get-output-string))
620    (lambda (loc port msg args)
621      (when port (##sys#check-port port loc))
622      (let ((out (if (and port (##sys#tty-port? port))
623                     port
624                     (open-output-string))))
625      (let rec ([msg msg] [args args])
626        (##sys#check-string msg loc)
627        (let ((index 0)
628              (len (##sys#size msg)) )
629          (define (fetch)
630            (let ((c (##core#inline "C_subchar" msg index)))
631              (set! index (fx+ index 1))
632              c) )
633          (define (next)
634            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
635                (##sys#error loc "too few arguments to formatted output procedure")
636                (let ((x (##sys#slot args 0)))
637                  (set! args (##sys#slot args 1)) 
638                  x) ) )
639          (let loop ()
640            (unless (fx>= index len)
641              (let ((c (fetch)))
642                (if (and (eq? c #\~) (fx< index len))
643                    (let ((dchar (fetch)))
644                      (case (char-upcase dchar)
645                        ((#\S) (write (next) out))
646                        ((#\A) (display (next) out))
647                        ((#\C) (##sys#write-char-0 (next) out))
648                        ((#\B) (display (##sys#number->string (next) 2) out))
649                        ((#\O) (display (##sys#number->string (next) 8) out))
650                        ((#\X) (display (##sys#number->string (next) 16) out))
651                        ((#\!) (##sys#flush-output out))
652                        ((#\?)
653                         (let* ([fstr (next)]
654                                [lst (next)] )
655                           (##sys#check-list lst loc)
656                           (rec fstr lst) out) )
657                        ((#\~) (##sys#write-char-0 #\~ out))
658                        ((#\% #\N) (newline out))
659                        (else
660                         (if (char-whitespace? dchar)
661                             (let skip ((c (fetch)))
662                               (if (char-whitespace? c)
663                                   (skip (fetch))
664                                   (set! index (fx- index 1)) ) )
665                             (##sys#error loc "illegal format-string character" dchar) ) ) ) )
666                    (##sys#write-char-0 c out) )
667                (loop) ) ) ) ) )
668      (cond ((not port) (get-output-string out))
669            ((not (eq? out port))
670             (##sys#print (get-output-string out) #f port) ) ) ) ) ) )
671
672(define (fprintf port fstr . args)
673  (fprintf0 'fprintf port fstr args) )
674
675(define (printf fstr . args)
676  (fprintf0 'printf ##sys#standard-output fstr args) )
677
678(define (sprintf fstr . args)
679  (fprintf0 'sprintf #f fstr args) )
680
681(define format
682  (let ([fprintf fprintf]
683        [sprintf sprintf]
684        [printf printf] )
685    (lambda (fmt-or-dst . args)
686      (apply (cond [(not fmt-or-dst)             sprintf]
687                   [(boolean? fmt-or-dst)        printf]
688                   [(string? fmt-or-dst)         (set! args (cons fmt-or-dst args)) sprintf]
689                   [(output-port? fmt-or-dst)    (set! args (cons fmt-or-dst args)) fprintf]
690                   [else
691                    (##sys#error 'format "illegal destination" fmt-or-dst args)])
692             args) ) ) )
693
694(register-feature! 'srfi-28)
695
Note: See TracBrowser for help on using the repository browser.