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

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

scrutiny-related fixes

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
240(define ##sys#read-string/port
241  (let ((open-output-string open-output-string)
242        (get-output-string get-output-string) )
243    (lambda (n p)
244      (##sys#check-port p 'read-string)
245      (cond (n (##sys#check-exact n 'read-string)
246               (let* ((str (##sys#make-string n))
247                      (n2 (##sys#read-string! n str p 0)) )
248                 (if (eq? n n2)
249                     str
250                     (##sys#substring str 0 n2))))
251            (else
252             (let ([out (open-output-string)]
253                   (buf (make-string read-string-buffer-size)))
254               (let loop ()
255                 (let ((n (##sys#read-string! read-string-buffer-size
256                                              buf p 0)))
257                   (cond ((eq? n 0)
258                          (get-output-string out))
259                         (else
260                          (write-string buf n out)
261                          (loop)))))))))))
262
263(define (read-string #!optional n (port ##sys#standard-input))
264  (##sys#read-string/port n port) )
265
266(define read-token
267  (let ([open-output-string open-output-string]
268        [get-output-string get-output-string] )
269    (lambda (pred . port)
270      (let ([port (optional port ##sys#standard-input)])
271        (##sys#check-port port 'read-token)
272        (let ([out (open-output-string)])
273          (let loop ()
274            (let ([c (##sys#peek-char-0 port)])
275              (if (and (not (eof-object? c)) (pred c))
276                  (begin
277                    (##sys#write-char-0 (##sys#read-char-0 port) out)
278                    (loop) )
279                  (get-output-string out) ) ) ) ) ) ) ) )
280
281(define write-string 
282  (let ([display display])
283    (lambda (s . more)
284      (##sys#check-string s 'write-string)
285      (let-optionals more ([n #f] [port ##sys#standard-output])
286        (##sys#check-port port 'write-string)
287        (when n (##sys#check-exact n 'write-string))
288        (display
289         (if (and n (fx< n (##sys#size s)))
290             (##sys#substring s 0 n)
291             s)
292         port) ) ) ) )
293
294(define write-line
295  (let ((display display)
296        (newline newline) )
297    (lambda (str . port)
298      (let ((p (if (##core#inline "C_eqp" port '())
299                   ##sys#standard-output
300                   (##sys#slot port 0) ) ) )
301        (##sys#check-port p 'write-line)
302        (##sys#check-string str 'write-line)
303        (display str p)
304        (newline p) ) ) ) )
305
306
307;;; Binary I/O
308
309(define (read-byte #!optional (port ##sys#standard-input))
310  (##sys#check-port port 'read-byte)
311  (let ((x (##sys#read-char-0 port)))
312    (if (eof-object? x)
313        x
314        (char->integer x) ) ) )
315
316(define (write-byte byte #!optional (port ##sys#standard-output))
317  (##sys#check-exact byte 'write-byte)
318  (##sys#check-port port 'write-byte)
319  (##sys#write-char-0 (integer->char byte) port) )
320
321
322
323
324;;; Pretty print:
325;
326; Copyright (c) 1991, Marc Feeley
327; Author: Marc Feeley (feeley@iro.umontreal.ca)
328; Distribution restrictions: none
329;
330; Modified by felix for use with CHICKEN
331;
332
333(define generic-write
334  (let ([open-output-string open-output-string]
335        [get-output-string get-output-string] )
336    (lambda (obj display? width output)
337
338      (define (read-macro? l)
339        (define (length1? l) (and (pair? l) (null? (cdr l))))
340        (let ((head (car l)) (tail (cdr l)))
341          (case head
342            ((quote quasiquote unquote unquote-splicing) (length1? tail))
343            (else                                        #f))))
344
345      (define (read-macro-body l)
346        (cadr l))
347
348      (define (read-macro-prefix l)
349        (let ((head (car l)) (tail (cdr l)))
350          (case head
351            ((quote)            "'")
352            ((quasiquote)       "`")
353            ((unquote)          ",")
354            ((unquote-splicing) ",@"))))
355
356      (define (out str col)
357        (and col (output str) (+ col (string-length str))))
358
359      (define (wr obj col)
360
361        (define (wr-expr expr col)
362          (if (read-macro? expr)
363              (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
364              (wr-lst expr col)))
365
366        (define (wr-lst l col)
367          (if (pair? l)
368              (let loop ((l (cdr l))
369                         (col (and col (wr (car l) (out "(" col)))))
370                (cond ((not col) col)
371                      ((pair? l)
372                       (loop (cdr l) (wr (car l) (out " " col))))
373                      ((null? l) (out ")" col))
374                      (else      (out ")" (wr l (out " . " col))))))
375              (out "()" col)))
376
377        (cond ((pair? obj)        (wr-expr obj col))
378              ((null? obj)        (wr-lst obj col))
379              ((eof-object? obj)  (out "#!eof" col))
380              ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
381              ((boolean? obj)     (out (if obj "#t" "#f") col))
382              ((##sys#number? obj)      (out (##sys#number->string obj) col))
383              ((symbol? obj)
384               (let ([s (open-output-string)])
385                 (##sys#print obj #t s)
386                 (out (get-output-string s) col) ) )
387              ((procedure? obj)   (out (##sys#procedure->string obj) col))
388              ((string? obj)      (if display?
389                                      (out obj col)
390                                      (let loop ((i 0) (j 0) (col (out "\"" col)))
391                                        (if (and col (< j (string-length obj)))
392                                            (let ((c (string-ref obj j)))
393                                              (if (or (char=? c #\\)
394                                                      (char=? c #\"))
395                                                  (loop j
396                                                        (+ j 1)
397                                                        (out "\\"
398                                                             (out (##sys#substring obj i j)
399                                                                  col)))
400                                                  (loop i (+ j 1) col)))
401                                            (out "\""
402                                                 (out (##sys#substring obj i j) col))))))
403              ((char? obj)        (if display?
404                                      (out (make-string 1 obj) col)
405                                      (let ([code (char->integer obj)])
406                                        (out "#\\" col)
407                                        (cond [(char-name obj) 
408                                               => (lambda (cn) 
409                                                    (out (##sys#slot cn 1) col) ) ]
410                                              [(fx< code 32)
411                                               (out "x" col)
412                                               (out (number->string code 16) col) ]
413                                              [(fx> code 255)
414                                               (out (if (fx> code #xffff) "U" "u") col)
415                                               (out (number->string code 16) col) ]
416                                              [else (out (make-string 1 obj) col)] ) ) ) )
417              ((eof-object? obj)  (out "#<eof>" col))
418              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
419              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
420              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
421               (out "#<unbound value>" col) )
422              ((##sys#generic-structure? obj)
423               (let ([o (open-output-string)])
424                 (##sys#user-print-hook obj #t o)
425                 (out (get-output-string o) col) ) )
426              ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
427              ((##core#inline "C_bytevectorp" obj)
428               (if (##core#inline "C_permanentp" obj)
429                   (out "#<static blob of size" col)
430                   (out "#<blob of size " col) )
431               (out (number->string (##core#inline "C_block_size" obj)) col)
432               (out ">" col) )
433              ((##core#inline "C_lambdainfop" obj)
434               (out "#<lambda info " col)
435               (out (##sys#lambda-info->string obj) col)
436               (out "#>" col) )
437              (else (out "#<unprintable object>" col)) ) )
438
439      (define (pp obj col)
440
441        (define (spaces n col)
442          (if (> n 0)
443              (if (> n 7)
444                  (spaces (- n 8) (out "        " col))
445                  (out (##sys#substring "        " 0 n) col))
446              col))
447
448        (define (indent to col)
449          (and col
450               (if (< to col)
451                   (and (out (make-string 1 #\newline) col) (spaces to 0))
452                   (spaces (- to col) col))))
453
454        (define (pr obj col extra pp-pair)
455          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
456              (let ((result '())
457                    (left (max (+ (- (- width col) extra) 1) max-expr-width)))
458                (generic-write obj display? #f
459                               (lambda (str)
460                                 (set! result (cons str result))
461                                 (set! left (- left (string-length str)))
462                                 (> left 0)))
463                (if (> left 0)          ; all can be printed on one line
464                    (out (reverse-string-append result) col)
465                    (if (pair? obj)
466                        (pp-pair obj col extra)
467                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
468              (wr obj col)))
469
470        (define (pp-expr expr col extra)
471          (if (read-macro? expr)
472              (pr (read-macro-body expr)
473                  (out (read-macro-prefix expr) col)
474                  extra
475                  pp-expr)
476              (let ((head (car expr)))
477                (if (symbol? head)
478                    (let ((proc (style head)))
479                      (if proc
480                          (proc expr col extra)
481                          (if (> (string-length (##sys#symbol->qualified-string head))
482                                 max-call-head-width)
483                              (pp-general expr col extra #f #f #f pp-expr)
484                              (pp-call expr col extra pp-expr))))
485                    (pp-list expr col extra pp-expr)))))
486
487                                        ; (head item1
488                                        ;       item2
489                                        ;       item3)
490        (define (pp-call expr col extra pp-item)
491          (let ((col* (wr (car expr) (out "(" col))))
492            (and col
493                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
494
495                                        ; (item1
496                                        ;  item2
497                                        ;  item3)
498        (define (pp-list l col extra pp-item)
499          (let ((col (out "(" col)))
500            (pp-down l col col extra pp-item)))
501
502        (define (pp-down l col1 col2 extra pp-item)
503          (let loop ((l l) (col col1))
504            (and col
505                 (cond ((pair? l)
506                        (let ((rest (cdr l)))
507                          (let ((extra (if (null? rest) (+ extra 1) 0)))
508                            (loop rest
509                                  (pr (car l) (indent col2 col) extra pp-item)))))
510                       ((null? l)
511                        (out ")" col))
512                       (else
513                        (out ")"
514                             (pr l
515                                 (indent col2 (out "." (indent col2 col)))
516                                 (+ extra 1)
517                                 pp-item)))))))
518
519        (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
520
521          (define (tail1 rest col1 col2 col3)
522            (if (and pp-1 (pair? rest))
523                (let* ((val1 (car rest))
524                       (rest (cdr rest))
525                       (extra (if (null? rest) (+ extra 1) 0)))
526                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
527                (tail2 rest col1 col2 col3)))
528
529          (define (tail2 rest col1 col2 col3)
530            (if (and pp-2 (pair? rest))
531                (let* ((val1 (car rest))
532                       (rest (cdr rest))
533                       (extra (if (null? rest) (+ extra 1) 0)))
534                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
535                (tail3 rest col1 col2)))
536
537          (define (tail3 rest col1 col2)
538            (pp-down rest col2 col1 extra pp-3))
539
540          (let* ((head (car expr))
541                 (rest (cdr expr))
542                 (col* (wr head (out "(" col))))
543            (if (and named? (pair? rest))
544                (let* ((name (car rest))
545                       (rest (cdr rest))
546                       (col** (wr name (out " " col*))))
547                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
548                (tail1 rest (+ col indent-general) col* (+ col* 1)))))
549
550        (define (pp-expr-list l col extra)
551          (pp-list l col extra pp-expr))
552
553        (define (pp-lambda expr col extra)
554          (pp-general expr col extra #f pp-expr-list #f pp-expr))
555
556        (define (pp-if expr col extra)
557          (pp-general expr col extra #f pp-expr #f pp-expr))
558
559        (define (pp-cond expr col extra)
560          (pp-call expr col extra pp-expr-list))
561
562        (define (pp-case expr col extra)
563          (pp-general expr col extra #f pp-expr #f pp-expr-list))
564
565        (define (pp-and expr col extra)
566          (pp-call expr col extra pp-expr))
567
568        (define (pp-let expr col extra)
569          (let* ((rest (cdr expr))
570                 (named? (and (pair? rest) (symbol? (car rest)))))
571            (pp-general expr col extra named? pp-expr-list #f pp-expr)))
572
573        (define (pp-begin expr col extra)
574          (pp-general expr col extra #f #f #f pp-expr))
575
576        (define (pp-do expr col extra)
577          (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
578
579                                        ; define formatting style (change these to suit your style)
580
581        (define indent-general 2)
582
583        (define max-call-head-width 5)
584
585        (define max-expr-width 50)
586
587        (define (style head)
588          (case head
589            ((lambda let* letrec define) pp-lambda)
590            ((if set!)                   pp-if)
591            ((cond)                      pp-cond)
592            ((case)                      pp-case)
593            ((and or)                    pp-and)
594            ((let)                       pp-let)
595            ((begin)                     pp-begin)
596            ((do)                        pp-do)
597            (else                        #f)))
598
599        (pr obj col 0 pp-expr))
600
601      (if width
602          (out (make-string 1 #\newline) (pp obj 0))
603          (wr obj 0)))) )
604
605; (reverse-string-append l) = (apply string-append (reverse l))
606
607(define (reverse-string-append l)
608
609  (define (rev-string-append l i)
610    (if (pair? l)
611      (let* ((str (car l))
612             (len (string-length str))
613             (result (rev-string-append (cdr l) (+ i len))))
614        (let loop ((j 0) (k (- (- (string-length result) i) len)))
615          (if (< j len)
616            (begin
617              (string-set! result k (string-ref str j))
618              (loop (+ j 1) (+ k 1)))
619            result)))
620      (make-string i)))
621
622  (rev-string-append l 0))
623
624; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
625; output port is used if 'port' is not specified.
626
627(define pretty-print-width (make-parameter 79))
628
629(define (pretty-print obj . opt)
630  (let ((port (if (pair? opt) (car opt) (current-output-port))))
631    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
632    (##core#undefined) ) )
633
634(define pp pretty-print)
635
636
637;;; Write simple formatted output:
638
639(define fprintf0
640  (let ((write write)
641        (newline newline)
642        (display display) 
643        (open-output-string open-output-string)
644        (get-output-string get-output-string))
645    (lambda (loc port msg args)
646      (when port (##sys#check-port port loc))
647      (let ((out (if (and port (##sys#tty-port? port))
648                     port
649                     (open-output-string))))
650      (let rec ([msg msg] [args args])
651        (##sys#check-string msg loc)
652        (let ((index 0)
653              (len (##sys#size msg)) )
654          (define (fetch)
655            (let ((c (##core#inline "C_subchar" msg index)))
656              (set! index (fx+ index 1))
657              c) )
658          (define (next)
659            (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
660                (##sys#error loc "too few arguments to formatted output procedure")
661                (let ((x (##sys#slot args 0)))
662                  (set! args (##sys#slot args 1)) 
663                  x) ) )
664          (let loop ()
665            (unless (fx>= index len)
666              (let ((c (fetch)))
667                (if (and (eq? c #\~) (fx< index len))
668                    (let ((dchar (fetch)))
669                      (case (char-upcase dchar)
670                        ((#\S) (write (next) out))
671                        ((#\A) (display (next) out))
672                        ((#\C) (##sys#write-char-0 (next) out))
673                        ((#\B) (display (##sys#number->string (next) 2) out))
674                        ((#\O) (display (##sys#number->string (next) 8) out))
675                        ((#\X) (display (##sys#number->string (next) 16) out))
676                        ((#\!) (##sys#flush-output out))
677                        ((#\?)
678                         (let* ([fstr (next)]
679                                [lst (next)] )
680                           (##sys#check-list lst loc)
681                           (rec fstr lst) out) )
682                        ((#\~) (##sys#write-char-0 #\~ out))
683                        ((#\% #\N) (newline out))
684                        (else
685                         (if (char-whitespace? dchar)
686                             (let skip ((c (fetch)))
687                               (if (char-whitespace? c)
688                                   (skip (fetch))
689                                   (set! index (fx- index 1)) ) )
690                             (##sys#error loc "illegal format-string character" dchar) ) ) ) )
691                    (##sys#write-char-0 c out) )
692                (loop) ) ) ) ) )
693      (cond ((not port) (get-output-string out))
694            ((not (eq? out port))
695             (##sys#print (get-output-string out) #f port) ) ) ) ) ) )
696
697(define (fprintf port fstr . args)
698  (fprintf0 'fprintf port fstr args) )
699
700(define (printf fstr . args)
701  (fprintf0 'printf ##sys#standard-output fstr args) )
702
703(define (sprintf fstr . args)
704  (fprintf0 'sprintf #f fstr args) )
705
706(define format
707  (let ([fprintf fprintf]
708        [sprintf sprintf]
709        [printf printf] )
710    (lambda (fmt-or-dst . args)
711      (apply (cond [(not fmt-or-dst)             sprintf]
712                   [(boolean? fmt-or-dst)        printf]
713                   [(string? fmt-or-dst)         (set! args (cons fmt-or-dst args)) sprintf]
714                   [(output-port? fmt-or-dst)    (set! args (cons fmt-or-dst args)) fprintf]
715                   [else
716                    (##sys#error 'format "illegal destination" fmt-or-dst args)])
717             args) ) ) )
718
719(register-feature! 'srfi-28)
720
Note: See TracBrowser for help on using the repository browser.