source: project/chicken/branches/hygienic/extras.scm @ 10951

Last change on this file since 10951 was 10951, checked in by felix winkelmann, 13 years ago

checking of refs to undefd identifiers in modules

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