~ chicken-core (chicken-5) /extras.scm

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