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

Last change on this file since 13544 was 13544, checked in by Kon Lovett, 12 years ago

Rmvd unused 'C_hashptr' & 'C_mem_compare'. Rmvd hash related 'hides'.

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