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

Last change on this file since 13140 was 13140, checked in by Kon Lovett, 11 years ago

Renamed not proper list error per ##sys#error- for all error type procs, deprecated '##sys#not-a-proper-list-error'.

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