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

Last change on this file since 14507 was 14507, checked in by felix winkelmann, 11 years ago

applied read-string patch by zb

File size: 22.9 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(cond-expand
89  (unix
90
91    (define random-seed)
92    (define randomize)
93
94    (let ((srandom (foreign-lambda void "srandom" unsigned-integer)))
95
96      (set! random-seed
97        (lambda (#!optional (seed (current-seconds)))
98          (##sys#check-integer seed 'random-seed)
99          (srandom seed) ) )
100
101      (set! randomize
102        (lambda (#!optional (seed (##sys#fudge 2)))
103          (##sys#check-exact seed 'randomize)
104          (srandom seed) ) ) )
105
106    (define (random n)
107      (##sys#check-integer n 'random)
108      (if (eq? 0 n)
109          0
110          ((foreign-lambda* long ((integer64 n)) "return( random() % ((uint64_t) n) );") n) ) ) )
111  (else
112
113    (define random-seed
114      (let ((srand (foreign-lambda void "srand" unsigned-integer)))
115        (lambda n
116          (let ((t (if (null? n) (current-seconds) (car n))))
117            (##sys#check-integer t 'random-seed)
118            (srand t) ) ) ) )
119
120    (define (randomize . n)
121      (let ((nn (if (null? n) (##sys#fudge 2) (car n))))
122        (##sys#check-exact nn 'randomize)
123        (##core#inline "C_randomize" nn) ) )
124
125    (define (random n)
126      (##sys#check-exact n 'random)
127      (if (eq? n 0)
128          0
129          (##core#inline "C_random_fixnum" n) ) ) ) )
130
131
132;;; Line I/O:
133
134(define read-line
135  (let ([make-string make-string])
136    (define (fixup str len)
137      (##sys#substring
138       str 0
139       (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
140           (fx- len 1)
141           len) ) )
142    (lambda args
143      (let* ([parg (pair? args)]
144             [p (if parg (car args) ##sys#standard-input)]
145             [limit (and parg (pair? (cdr args)) (cadr args))])
146        (##sys#check-port p 'read-line)
147        (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
148              (else
149               (let* ((buffer-len (if limit limit 256))
150                      (buffer (##sys#make-string buffer-len)))
151                 (let loop ([i 0])
152                   (if (and limit (fx>= i limit))
153                       (##sys#substring buffer 0 i)
154                       (let ([c (##sys#read-char-0 p)])
155                         (if (eof-object? c)
156                             (if (fx= i 0)
157                                 c
158                                 (##sys#substring buffer 0 i) ) 
159                             (case c
160                               [(#\newline) (##sys#substring buffer 0 i)]
161                               [(#\return)
162                                (let ([c (peek-char p)])
163                                  (if (char=? c #\newline)
164                                      (begin (##sys#read-char-0 p)
165                                             (##sys#substring buffer 0 i))
166                                      (##sys#substring buffer 0 i) ) ) ]
167                               [else
168                                (when (fx>= i buffer-len)
169                                  (set! buffer (##sys#string-append buffer (make-string buffer-len)))
170                                  (set! buffer-len (fx+ buffer-len buffer-len)) )
171                                (##core#inline "C_setsubchar" buffer i c)
172                                (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
173
174(define read-lines
175  (let ((read-line read-line)
176        (call-with-input-file call-with-input-file) 
177        (reverse reverse) )
178    (lambda port-and-max
179      (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
180             (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
181             (max (if (pair? rest) (##sys#slot rest 0) #f)) )
182        (define (doread port)
183          (let loop ((lns '())
184                     (n (or max 1000000000)) ) ; this is silly
185            (if (eq? n 0)
186                (reverse lns)
187                (let ((ln (read-line port)))
188                  (if (eof-object? ln)
189                      (reverse lns)
190                      (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
191        (if (string? port)
192            (call-with-input-file port doread)
193            (begin
194              (##sys#check-port port 'read-lines)
195              (doread port) ) ) ) ) ) )
196
197
198;;; Extended I/O
199
200(define (##sys#read-string! n dest port start)
201  (cond ((eq? n 0) 0)
202        (else
203         (when (##sys#slot port 6)      ; peeked?
204           (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
205           (set! start (fx+ start 1)) )
206         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
207           (if rdstring
208               (let loop ((start start) (n n) (m 0))
209                 (let ((n2 (rdstring port n dest start)))
210                   (##sys#setislot port 5 ; update port-position
211                                   (fx+ (##sys#slot port 5) n2))
212                   (cond ((eq? n2 0) m)
213                         ((or (not n) (fx< n2 n)) 
214                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)))
215                         (else (fx+ n2 m)))))
216               (let loop ((start start) (n n) (m 0))
217                 (let ((n2 (let ((c (##sys#read-char-0 port)))
218                             (if (eof-object? c)
219                                 0
220                                 (begin
221                                   (##core#inline "C_setsubchar" dest start c)
222                                   1) ) )  ) )
223                   (cond ((eq? n2 0) m)
224                         ((or (not n) (fx< n2 n)) 
225                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
226                         (else (fx+ n2 m))) )))))))
227
228(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
229  (##sys#check-port port 'read-string!)
230  (##sys#check-string dest 'read-string!)
231  (when n
232    (##sys#check-exact n 'read-string!)
233    (when (fx> (fx+ start n) (##sys#size dest))
234      (set! n (fx- (##sys#size dest) start))))
235  (##sys#check-exact start 'read-string!)
236  (##sys#read-string! n dest port start) )
237
238(define-constant read-string-buffer-size 2048)
239(define ##sys#read-string/port
240  (let ((open-output-string open-output-string)
241        (get-output-string get-output-string) )
242    (lambda (n p)
243      (##sys#check-port p 'read-string)
244      (cond (n (##sys#check-exact n 'read-string)
245               (let* ((str (##sys#make-string n))
246                      (n2 (##sys#read-string! n str p 0)) )
247                 (if (eq? n n2)
248                     str
249                     (##sys#substring str 0 n2))))
250            (else
251             (let ([out (open-output-string)]
252                   (buf (make-string read-string-buffer-size)))
253               (let loop ()
254                 (let ((n (##sys#read-string! read-string-buffer-size
255                                              buf p 0)))
256                   (cond ((eq? n 0)
257                          (get-output-string out))
258                         (else
259                          (write-string buf n out)
260                          (loop)))))))))))
261
262(define (read-string #!optional n (port ##sys#standard-input))
263  (##sys#read-string/port n port) )
264
265(define read-token
266  (let ([open-output-string open-output-string]
267        [get-output-string get-output-string] )
268    (lambda (pred . port)
269      (let ([port (optional port ##sys#standard-input)])
270        (##sys#check-port port 'read-token)
271        (let ([out (open-output-string)])
272          (let loop ()
273            (let ([c (##sys#peek-char-0 port)])
274              (if (and (not (eof-object? c)) (pred c))
275                  (begin
276                    (##sys#write-char-0 (##sys#read-char-0 port) out)
277                    (loop) )
278                  (get-output-string out) ) ) ) ) ) ) ) )
279
280(define write-string 
281  (let ([display display])
282    (lambda (s . more)
283      (##sys#check-string s 'write-string)
284      (let-optionals more ([n #f] [port ##sys#standard-output])
285        (##sys#check-port port 'write-string)
286        (when n (##sys#check-exact n 'write-string))
287        (display
288         (if (and n (fx< n (##sys#size s)))
289             (##sys#substring s 0 n)
290             s)
291         port) ) ) ) )
292
293(define write-line
294  (let ((display display)
295        (newline newline) )
296    (lambda (str . port)
297      (let ((p (if (##core#inline "C_eqp" port '())
298                   ##sys#standard-output
299                   (##sys#slot port 0) ) ) )
300        (##sys#check-port p 'write-line)
301        (##sys#check-string str 'write-line)
302        (display str p)
303        (newline p) ) ) ) )
304
305
306;;; Binary I/O
307
308(define (read-byte #!optional (port ##sys#standard-input))
309  (##sys#check-port port 'read-byte)
310  (let ((x (##sys#read-char-0 port)))
311    (if (eof-object? x)
312        x
313        (char->integer x) ) ) )
314
315(define (write-byte byte #!optional (port ##sys#standard-output))
316  (##sys#check-exact byte 'write-byte)
317  (##sys#check-port port 'write-byte)
318  (##sys#write-char-0 (integer->char byte) port) )
319
320
321
322
323;;; Pretty print:
324;
325; Copyright (c) 1991, Marc Feeley
326; Author: Marc Feeley (feeley@iro.umontreal.ca)
327; Distribution restrictions: none
328;
329; Modified by felix for use with CHICKEN
330;
331
332(define generic-write
333  (let ([open-output-string open-output-string]
334        [get-output-string get-output-string] )
335    (lambda (obj display? width output)
336
337      (define (read-macro? l)
338        (define (length1? l) (and (pair? l) (null? (cdr l))))
339        (let ((head (car l)) (tail (cdr l)))
340          (case head
341            ((quote quasiquote unquote unquote-splicing) (length1? tail))
342            (else                                        #f))))
343
344      (define (read-macro-body l)
345        (cadr l))
346
347      (define (read-macro-prefix l)
348        (let ((head (car l)) (tail (cdr l)))
349          (case head
350            ((quote)            "'")
351            ((quasiquote)       "`")
352            ((unquote)          ",")
353            ((unquote-splicing) ",@"))))
354
355      (define (out str col)
356        (and col (output str) (+ col (string-length str))))
357
358      (define (wr obj col)
359
360        (define (wr-expr expr col)
361          (if (read-macro? expr)
362              (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
363              (wr-lst expr col)))
364
365        (define (wr-lst l col)
366          (if (pair? l)
367              (let loop ((l (cdr l))
368                         (col (and col (wr (car l) (out "(" col)))))
369                (cond ((not col) col)
370                      ((pair? l)
371                       (loop (cdr l) (wr (car l) (out " " col))))
372                      ((null? l) (out ")" col))
373                      (else      (out ")" (wr l (out " . " col))))))
374              (out "()" col)))
375
376        (cond ((pair? obj)        (wr-expr obj col))
377              ((null? obj)        (wr-lst obj col))
378              ((eof-object? obj)  (out "#!eof" col))
379              ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
380              ((boolean? obj)     (out (if obj "#t" "#f") col))
381              ((##sys#number? obj)      (out (##sys#number->string obj) col))
382              ((symbol? obj)
383               (let ([s (open-output-string)])
384                 (##sys#print obj #t s)
385                 (out (get-output-string s) col) ) )
386              ((procedure? obj)   (out (##sys#procedure->string obj) col))
387              ((string? obj)      (if display?
388                                      (out obj col)
389                                      (let loop ((i 0) (j 0) (col (out "\"" col)))
390                                        (if (and col (< j (string-length obj)))
391                                            (let ((c (string-ref obj j)))
392                                              (if (or (char=? c #\\)
393                                                      (char=? c #\"))
394                                                  (loop j
395                                                        (+ j 1)
396                                                        (out "\\"
397                                                             (out (##sys#substring obj i j)
398                                                                  col)))
399                                                  (loop i (+ j 1) col)))
400                                            (out "\""
401                                                 (out (##sys#substring obj i j) col))))))
402              ((char? obj)        (if display?
403                                      (out (make-string 1 obj) col)
404                                      (let ([code (char->integer obj)])
405                                        (out "#\\" col)
406                                        (cond [(char-name obj) 
407                                               => (lambda (cn) 
408                                                    (out (##sys#slot cn 1) col) ) ]
409                                              [(fx< code 32)
410                                               (out "x" col)
411                                               (out (number->string code 16) col) ]
412                                              [(fx> code 255)
413                                               (out (if (fx> code #xffff) "U" "u") col)
414                                               (out (number->string code 16) col) ]
415                                              [else (out (make-string 1 obj) col)] ) ) ) )
416              ((eof-object? obj)  (out "#<eof>" col))
417              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
418              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
419              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
420               (out "#<unbound value>" col) )
421              ((##sys#generic-structure? obj)
422               (let ([o (open-output-string)])
423                 (##sys#user-print-hook obj #t o)
424                 (out (get-output-string o) col) ) )
425              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
426              ((##core#inline "C_bytevectorp" obj)
427               (if (##core#inline "C_permanentp" obj)
428                   (out "#<static blob of size" col)
429                   (out "#<blob of size " col) )
430               (out (number->string (##core#inline "C_block_size" obj)) col)
431               (out ">" col) )
432              ((##core#inline "C_lambdainfop" obj)
433               (out "#<lambda info " col)
434               (out (##sys#lambda-info->string obj) col)
435               (out "#>" col) )
436              (else (out "#<unprintable object>" col)) ) )
437
438      (define (pp obj col)
439
440        (define (spaces n col)
441          (if (> n 0)
442              (if (> n 7)
443                  (spaces (- n 8) (out "        " col))
444                  (out (##sys#substring "        " 0 n) col))
445              col))
446
447        (define (indent to col)
448          (and col
449               (if (< to col)
450                   (and (out (make-string 1 #\newline) col) (spaces to 0))
451                   (spaces (- to col) col))))
452
453        (define (pr obj col extra pp-pair)
454          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
455              (let ((result '())
456                    (left (max (+ (- (- width col) extra) 1) max-expr-width)))
457                (generic-write obj display? #f
458                               (lambda (str)
459                                 (set! result (cons str result))
460                                 (set! left (- left (string-length str)))
461                                 (> left 0)))
462                (if (> left 0)          ; all can be printed on one line
463                    (out (reverse-string-append result) col)
464                    (if (pair? obj)
465                        (pp-pair obj col extra)
466                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
467              (wr obj col)))
468
469        (define (pp-expr expr col extra)
470          (if (read-macro? expr)
471              (pr (read-macro-body expr)
472                  (out (read-macro-prefix expr) col)
473                  extra
474                  pp-expr)
475              (let ((head (car expr)))
476                (if (symbol? head)
477                    (let ((proc (style head)))
478                      (if proc
479                          (proc expr col extra)
480                          (if (> (string-length (##sys#symbol->qualified-string head))
481                                 max-call-head-width)
482                              (pp-general expr col extra #f #f #f pp-expr)
483                              (pp-call expr col extra pp-expr))))
484                    (pp-list expr col extra pp-expr)))))
485
486                                        ; (head item1
487                                        ;       item2
488                                        ;       item3)
489        (define (pp-call expr col extra pp-item)
490          (let ((col* (wr (car expr) (out "(" col))))
491            (and col
492                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
493
494                                        ; (item1
495                                        ;  item2
496                                        ;  item3)
497        (define (pp-list l col extra pp-item)
498          (let ((col (out "(" col)))
499            (pp-down l col col extra pp-item)))
500
501        (define (pp-down l col1 col2 extra pp-item)
502          (let loop ((l l) (col col1))
503            (and col
504                 (cond ((pair? l)
505                        (let ((rest (cdr l)))
506                          (let ((extra (if (null? rest) (+ extra 1) 0)))
507                            (loop rest
508                                  (pr (car l) (indent col2 col) extra pp-item)))))
509                       ((null? l)
510                        (out ")" col))
511                       (else
512                        (out ")"
513                             (pr l
514                                 (indent col2 (out "." (indent col2 col)))
515                                 (+ extra 1)
516                                 pp-item)))))))
517
518        (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
519
520          (define (tail1 rest col1 col2 col3)
521            (if (and pp-1 (pair? rest))
522                (let* ((val1 (car rest))
523                       (rest (cdr rest))
524                       (extra (if (null? rest) (+ extra 1) 0)))
525                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
526                (tail2 rest col1 col2 col3)))
527
528          (define (tail2 rest col1 col2 col3)
529            (if (and pp-2 (pair? rest))
530                (let* ((val1 (car rest))
531                       (rest (cdr rest))
532                       (extra (if (null? rest) (+ extra 1) 0)))
533                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
534                (tail3 rest col1 col2)))
535
536          (define (tail3 rest col1 col2)
537            (pp-down rest col2 col1 extra pp-3))
538
539          (let* ((head (car expr))
540                 (rest (cdr expr))
541                 (col* (wr head (out "(" col))))
542            (if (and named? (pair? rest))
543                (let* ((name (car rest))
544                       (rest (cdr rest))
545                       (col** (wr name (out " " col*))))
546                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
547                (tail1 rest (+ col indent-general) col* (+ col* 1)))))
548
549        (define (pp-expr-list l col extra)
550          (pp-list l col extra pp-expr))
551
552        (define (pp-lambda expr col extra)
553          (pp-general expr col extra #f pp-expr-list #f pp-expr))
554
555        (define (pp-if expr col extra)
556          (pp-general expr col extra #f pp-expr #f pp-expr))
557
558        (define (pp-cond expr col extra)
559          (pp-call expr col extra pp-expr-list))
560
561        (define (pp-case expr col extra)
562          (pp-general expr col extra #f pp-expr #f pp-expr-list))
563
564        (define (pp-and expr col extra)
565          (pp-call expr col extra pp-expr))
566
567        (define (pp-let expr col extra)
568          (let* ((rest (cdr expr))
569                 (named? (and (pair? rest) (symbol? (car rest)))))
570            (pp-general expr col extra named? pp-expr-list #f pp-expr)))
571
572        (define (pp-begin expr col extra)
573          (pp-general expr col extra #f #f #f pp-expr))
574
575        (define (pp-do expr col extra)
576          (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
577
578                                        ; define formatting style (change these to suit your style)
579
580        (define indent-general 2)
581
582        (define max-call-head-width 5)
583
584        (define max-expr-width 50)
585
586        (define (style head)
587          (case head
588            ((lambda let* letrec define) pp-lambda)
589            ((if set!)                   pp-if)
590            ((cond)                      pp-cond)
591            ((case)                      pp-case)
592            ((and or)                    pp-and)
593            ((let)                       pp-let)
594            ((begin)                     pp-begin)
595            ((do)                        pp-do)
596            (else                        #f)))
597
598        (pr obj col 0 pp-expr))
599
600      (if width
601          (out (make-string 1 #\newline) (pp obj 0))
602          (wr obj 0)))) )
603
604; (reverse-string-append l) = (apply string-append (reverse l))
605
606(define (reverse-string-append l)
607
608  (define (rev-string-append l i)
609    (if (pair? l)
610      (let* ((str (car l))
611             (len (string-length str))
612             (result (rev-string-append (cdr l) (+ i len))))
613        (let loop ((j 0) (k (- (- (string-length result) i) len)))
614          (if (< j len)
615            (begin
616              (string-set! result k (string-ref str j))
617              (loop (+ j 1) (+ k 1)))
618            result)))
619      (make-string i)))
620
621  (rev-string-append l 0))
622
623; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
624; output port is used if 'port' is not specified.
625
626(define pretty-print-width (make-parameter 79))
627
628(define (pretty-print obj . opt)
629  (let ((port (if (pair? opt) (car opt) (current-output-port))))
630    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
631    (##core#undefined) ) )
632
633(define pp pretty-print)
634
635
636;;; Write simple formatted output:
637
638(define fprintf0
639  (let ((write write)
640        (newline newline)
641        (display display) 
642        (open-output-string open-output-string)
643        (get-output-string get-output-string))
644    (lambda (loc port msg args)
645      (when port (##sys#check-port port loc))
646      (let ((out (if (and port (##sys#tty-port? port))
647                     port
648                     (open-output-string))))
649      (let rec ([msg msg] [args args])
650        (##sys#check-string msg loc)
651        (let ((index 0)
652              (len (##sys#size msg)) )
653          (define (fetch)
654            (let ((c (##core#inline "C_subchar" msg index)))
655              (set! index (fx+ index 1))
656              c) )
657          (define (next)
658            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
659                (##sys#error loc "too few arguments to formatted output procedure")
660                (let ((x (##sys#slot args 0)))
661                  (set! args (##sys#slot args 1)) 
662                  x) ) )
663          (let loop ()
664            (unless (fx>= index len)
665              (let ((c (fetch)))
666                (if (and (eq? c #\~) (fx< index len))
667                    (let ((dchar (fetch)))
668                      (case (char-upcase dchar)
669                        ((#\S) (write (next) out))
670                        ((#\A) (display (next) out))
671                        ((#\C) (##sys#write-char-0 (next) out))
672                        ((#\B) (display (##sys#number->string (next) 2) out))
673                        ((#\O) (display (##sys#number->string (next) 8) out))
674                        ((#\X) (display (##sys#number->string (next) 16) out))
675                        ((#\!) (##sys#flush-output out))
676                        ((#\?)
677                         (let* ([fstr (next)]
678                                [lst (next)] )
679                           (##sys#check-list lst loc)
680                           (rec fstr lst) out) )
681                        ((#\~) (##sys#write-char-0 #\~ out))
682                        ((#\% #\N) (newline out))
683                        (else
684                         (if (char-whitespace? dchar)
685                             (let skip ((c (fetch)))
686                               (if (char-whitespace? c)
687                                   (skip (fetch))
688                                   (set! index (fx- index 1)) ) )
689                             (##sys#error loc "illegal format-string character" dchar) ) ) ) )
690                    (##sys#write-char-0 c out) )
691                (loop) ) ) ) ) )
692      (cond ((not port) (get-output-string out))
693            ((not (eq? out port))
694             (##sys#print (get-output-string out) #f port) ) ) ) ) ) )
695
696(define (fprintf port fstr . args)
697  (fprintf0 'fprintf port fstr args) )
698
699(define (printf fstr . args)
700  (fprintf0 'printf ##sys#standard-output fstr args) )
701
702(define (sprintf fstr . args)
703  (fprintf0 'sprintf #f fstr args) )
704
705(define format
706  (let ([fprintf fprintf]
707        [sprintf sprintf]
708        [printf printf] )
709    (lambda (fmt-or-dst . args)
710      (apply (cond [(not fmt-or-dst)             sprintf]
711                   [(boolean? fmt-or-dst)        printf]
712                   [(string? fmt-or-dst)         (set! args (cons fmt-or-dst args)) sprintf]
713                   [(output-port? fmt-or-dst)    (set! args (cons fmt-or-dst args)) fprintf]
714                   [else
715                    (##sys#error 'format "illegal destination" fmt-or-dst args)])
716             args) ) ) )
717
718(register-feature! 'srfi-28)
719
Note: See TracBrowser for help on using the repository browser.