~ chicken-core (master) /extras.scm
Trap1;;; extras.scm - Optional non-standard extensions2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; 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 promote15; 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 EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit extras)30 (uses data-structures))3132(include "common-declarations.scm")3334;;; Pretty print:35;36; Copyright (c) 1991, Marc Feeley37; Author: Marc Feeley (feeley@iro.umontreal.ca)38; Distribution restrictions: none39;40; Modified by felix for use with CHICKEN41;4243(module chicken.pretty-print44 (pp pretty-print pretty-print-width)4546(import scheme chicken.base chicken.fixnum chicken.keyword chicken.string)47(import (only (scheme base) make-parameter open-output-string get-output-string port?))4849(define generic-write50 (lambda (obj display? width output)5152 (define (read-macro? l)53 (define (length1? l) (and (pair? l) (null? (cdr l))))54 (let ((head (car l)) (tail (cdr l)))55 (case head56 ((quote quasiquote unquote unquote-splicing) (length1? tail))57 (else #f))))5859 (define (read-macro-body l)60 (cadr l))6162 (define (read-macro-prefix l)63 (let ((head (car l)) (tail (cdr l)))64 (case head65 ((quote) "'")66 ((quasiquote) "`")67 ((unquote) ",")68 ((unquote-splicing) ",@"))))6970 (define (out str col)71 (and col (output str) (+ col (string-length str))))7273 (define (wr obj col)7475 (define (wr-expr expr col)76 (if (read-macro? expr)77 (wr (read-macro-body expr) (out (read-macro-prefix expr) col))78 (wr-lst expr col)))7980 (define (wr-lst l col)81 (if (pair? l)82 (let loop ((l (cdr l))83 (col (and col (wr (car l) (out "(" col)))))84 (cond ((not col) col)85 ((pair? l)86 (loop (cdr l) (wr (car l) (out " " col))))87 ((null? l) (out ")" col))88 (else (out ")" (wr l (out " . " col))))))89 (out "()" col)))9091 (cond ((pair? obj) (wr-expr obj col))92 ((null? obj) (wr-lst obj col))93 ((eof-object? obj) (out "#!eof" col))94 ((bwp-object? obj) (out "#!bwp" col))95 ((vector? obj) (wr-lst (vector->list obj) (out "#" col)))96 ((boolean? obj) (out (if obj "#t" "#f") col))97 ((number? obj) (out (##sys#number->string obj) col))98 ((or (keyword? obj) (symbol? obj))99 (let ((s (open-output-string)))100 (##sys#print obj #t s)101 (out (get-output-string s) col) ) )102 ((procedure? obj) (out (##sys#procedure->string obj) col))103 ((string? obj)104 (if display?105 (out obj col)106 (let loop ((i 0) (j 0) (col (out "\"" col)))107 (if (and col (fx< j (string-length obj)))108 (let ((c (string-ref obj j)))109 (cond110 ((or (char=? c #\\)111 (char=? c #\"))112 (loop j113 (+ j 1)114 (out "\\"115 (out (##sys#substring obj i j)116 col))))117 ((or (char<? c #\x20)118 (char>=? c #\x7f))119 (loop (fx+ j 1)120 (fx+ j 1)121 (let ((col2122 (out (##sys#substring obj i j) col)))123 (cond ((assq c '((#\tab . "\\t")124 (#\newline . "\\n")125 (#\return . "\\r")126 (#\vtab . "\\v")127 (#\page . "\\f")128 (#\alarm . "\\a")129 (#\backspace . "\\b")))130 =>131 (lambda (a)132 (out (cdr a) col2)))133 (else134 (out (string-append135 "\\x"136 (number->string (char->integer c) 16)137 ";")138 col2))))))139 (else (loop i (fx+ j 1) col))))140 (out "\""141 (out (##sys#substring obj i j) col))))))142 ((char? obj) (if display?143 (out (make-string 1 obj) col)144 (let ((code (char->integer obj))145 (col2 (out "#\\" col)))146 (cond ((char-name obj)147 => (lambda (cn)148 (out (##sys#symbol->string/shared cn) col2) ) )149 ((or (fx< code 32) (fx> code 127))150 (out (number->string code 16)151 (out "x" col2)))152 (else (out (make-string 1 obj) col2)) ) ) ) )153 ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))154 ((##core#inline "C_unboundvaluep" obj) (out "#<unbound value>" col))155 ((##core#inline "C_immp" obj) (out "#<unprintable object>" col))156 ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))157 ((##sys#generic-structure? obj)158 (let ((o (open-output-string)))159 (##sys#user-print-hook obj #t o)160 (out (get-output-string o) col) ) )161 ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))162 ((##core#inline "C_bytevectorp" obj)163 (out "#u8" col)164 (wr-lst (##sys#bytevector->list obj) col))165 ((##core#inline "C_lambdainfop" obj)166 (out ">"167 (out (##sys#lambda-info->string obj)168 (out "#<lambda info " col) )))169 (else (out "#<unprintable object>" col)) ) )170171 (define (pp obj col)172173 (define (spaces n col)174 (if (> n 0)175 (if (> n 7)176 (spaces (- n 8) (out " " col))177 (out (##sys#substring " " 0 n) col))178 col))179180 (define (indent to col)181 (and col182 (if (< to col)183 (and (out (make-string 1 #\newline) col) (spaces to 0))184 (spaces (- to col) col))))185186 (define (pr obj col extra pp-pair)187 (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines188 (let ((result '())189 (left (max (+ (- (- width col) extra) 1) max-expr-width)))190 (generic-write obj display? #f191 (lambda (str)192 (set! result (cons str result))193 (set! left (- left (string-length str)))194 (> left 0)))195 (if (> left 0) ; all can be printed on one line196 (out (reverse-string-append result) col)197 (if (pair? obj)198 (pp-pair obj col extra)199 (pp-list (vector->list obj) (out "#" col) extra pp-expr))))200 (wr obj col)))201202 (define (pp-expr expr col extra)203 (if (read-macro? expr)204 (pr (read-macro-body expr)205 (out (read-macro-prefix expr) col)206 extra207 pp-expr)208 (let ((head (car expr)))209 (if (symbol? head)210 (let ((proc (style head)))211 (if proc212 (proc expr col extra)213 (if (> (string-length (##sys#symbol->string/shared head))214 max-call-head-width)215 (pp-general expr col extra #f #f #f pp-expr)216 (pp-call expr col extra pp-expr))))217 (pp-list expr col extra pp-expr)))))218219 ; (head item1220 ; item2221 ; item3)222 (define (pp-call expr col extra pp-item)223 (let ((col* (wr (car expr) (out "(" col))))224 (and col225 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))226227 ; (item1228 ; item2229 ; item3)230 (define (pp-list l col extra pp-item)231 (let ((col (out "(" col)))232 (pp-down l col col extra pp-item)))233234 (define (pp-down l col1 col2 extra pp-item)235 (let loop ((l l) (col col1))236 (and col237 (cond ((pair? l)238 (let ((rest (cdr l)))239 (let ((extra (if (null? rest) (+ extra 1) 0)))240 (loop rest241 (pr (car l) (indent col2 col) extra pp-item)))))242 ((null? l)243 (out ")" col))244 (else245 (out ")"246 (pr l247 (indent col2 (out "." (indent col2 col)))248 (+ extra 1)249 pp-item)))))))250251 (define (pp-general expr col extra named? pp-1 pp-2 pp-3)252253 (define (tail1 rest col1 col2 col3)254 (if (and pp-1 (pair? rest))255 (let* ((val1 (car rest))256 (rest (cdr rest))257 (extra (if (null? rest) (+ extra 1) 0)))258 (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))259 (tail2 rest col1 col2 col3)))260261 (define (tail2 rest col1 col2 col3)262 (if (and pp-2 (pair? rest))263 (let* ((val1 (car rest))264 (rest (cdr rest))265 (extra (if (null? rest) (+ extra 1) 0)))266 (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))267 (tail3 rest col1 col2)))268269 (define (tail3 rest col1 col2)270 (pp-down rest col2 col1 extra pp-3))271272 (let* ((head (car expr))273 (rest (cdr expr))274 (col* (wr head (out "(" col))))275 (if (and named? (pair? rest))276 (let* ((name (car rest))277 (rest (cdr rest))278 (col** (wr name (out " " col*))))279 (tail1 rest (+ col indent-general) col** (+ col** 1)))280 (tail1 rest (+ col indent-general) col* (+ col* 1)))))281282 (define (pp-expr-list l col extra)283 (pp-list l col extra pp-expr))284285 (define (pp-lambda expr col extra)286 (pp-general expr col extra #f pp-expr-list #f pp-expr))287288 (define (pp-if expr col extra)289 (pp-general expr col extra #f pp-expr #f pp-expr))290291 (define (pp-cond expr col extra)292 (pp-call expr col extra pp-expr-list))293294 (define (pp-case expr col extra)295 (pp-general expr col extra #f pp-expr #f pp-expr-list))296297 (define (pp-and expr col extra)298 (pp-call expr col extra pp-expr))299300 (define (pp-let expr col extra)301 (let* ((rest (cdr expr))302 (named? (and (pair? rest) (symbol? (car rest)))))303 (pp-general expr col extra named? pp-expr-list #f pp-expr)))304305 (define (pp-begin expr col extra)306 (pp-general expr col extra #f #f #f pp-expr))307308 (define (pp-do expr col extra)309 (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))310311 ;; define formatting style (change these to suit your style)312313 (define indent-general 2)314315 (define max-call-head-width 5)316317 (define max-expr-width 50)318319 (define (style head)320 (case head321 ((lambda let* letrec letrec* define) pp-lambda)322 ((if set!) pp-if)323 ((cond) pp-cond)324 ((case) pp-case)325 ((and or) pp-and)326 ((let) pp-let)327 ((begin) pp-begin)328 ((do) pp-do)329 (else #f)))330331 (pr obj col 0 pp-expr))332333 (if width334 (out (make-string 1 #\newline) (pp obj 0))335 (wr obj 0))))336337; (pretty-print obj port) pretty prints 'obj' on 'port'. The current338; output port is used if 'port' is not specified.339340(define pretty-print-width (make-parameter 79))341342(define (pretty-print obj . opt)343 (let ((port (if (pair? opt) (car opt) (current-output-port))))344 (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))345 (##core#undefined) ) )346347(define pp pretty-print))348349350;;; Write simple formatted output:351352(module chicken.format353 (format fprintf printf sprintf)354355(import scheme chicken.base chicken.fixnum chicken.platform)356(import (only (scheme base) open-output-string get-output-string))357358(define fprintf0359 (lambda (loc port msg args)360 (when port (##sys#check-output-port port #t loc))361 (let ((out (if (and port (##sys#tty-port? port))362 port363 (open-output-string))))364 (let rec ([msg msg] [args args])365 (##sys#check-string msg loc)366 (let ((index 0)367 (len (string-length msg)) )368 (define (fetch)369 (let ((c (string-ref msg index)))370 (set! index (fx+ index 1))371 c) )372 (define (next)373 (if (##core#inline "C_eqp" args '())374 (##sys#error loc "too few arguments to formatted output procedure")375 (let ((x (##sys#slot args 0)))376 (set! args (##sys#slot args 1))377 x) ) )378 (let loop ()379 (unless (fx>= index len)380 (let ((c (fetch)))381 (if (and (eq? c #\~) (fx< index len))382 (let ((dchar (fetch)))383 (case (char-upcase dchar)384 ((#\S) (write (next) out))385 ((#\A) (display (next) out))386 ((#\C) (##sys#write-char-0 (next) out))387 ((#\B) (display (##sys#number->string (next) 2) out))388 ((#\O) (display (##sys#number->string (next) 8) out))389 ((#\X) (display (##sys#number->string (next) 16) out))390 ((#\!) (##sys#flush-output out))391 ((#\?)392 (let* ([fstr (next)]393 [lst (next)] )394 (##sys#check-list lst loc)395 (rec fstr lst) out) )396 ((#\~) (##sys#write-char-0 #\~ out))397 ((#\% #\N) (newline out))398 (else399 (if (char-whitespace? dchar)400 (let skip ((c (fetch)))401 (if (char-whitespace? c)402 (skip (fetch))403 (set! index (fx- index 1)) ) )404 (##sys#error loc "illegal format-string character" dchar) ) ) ) )405 (##sys#write-char-0 c out) )406 (loop) ) ) ) ) )407 (cond ((not port) (get-output-string out))408 ((not (eq? out port))409 (##sys#print (get-output-string out) #f port) ) ) ) ) )410411(define (fprintf port fstr . args)412 (fprintf0 'fprintf port fstr args) )413414(define (printf fstr . args)415 (fprintf0 'printf ##sys#standard-output fstr args) )416417(define (sprintf fstr . args)418 (fprintf0 'sprintf #f fstr args) )419420(define format421 (lambda (fmt-or-dst . args)422 (apply (cond [(not fmt-or-dst) sprintf]423 [(boolean? fmt-or-dst) printf]424 [(string? fmt-or-dst) (set! args (cons fmt-or-dst args)) sprintf]425 [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]426 [else427 (##sys#error 'format "illegal destination" fmt-or-dst args)])428 args) ) )429430(register-feature! 'srfi-28))431432433;;; Random numbers:434435(module chicken.random436 (set-pseudo-random-seed! pseudo-random-integer pseudo-random-real random-bytes)437438(import scheme chicken.base chicken.time chicken.io chicken.foreign)439440(define (set-pseudo-random-seed! buf #!optional n)441 (cond (n (##sys#check-fixnum n 'set-pseudo-random-seed!)442 (when (##core#inline "C_fixnum_lessp" n 0)443 (##sys#error 'set-pseudo-random-seed! "invalid size" n)))444 (else (set! n (##sys#size buf))))445 (##sys#check-bytevector buf 'set-pseudo-random-seed!)446 (##core#inline "C_set_random_seed" buf447 (##core#inline "C_i_fixnum_min"448 n449 (##sys#size buf))))450451(define (pseudo-random-integer n)452 (cond ((##core#inline "C_fixnump" n)453 (##core#inline "C_random_fixnum" n))454 ((not (##core#inline "C_i_bignump" n))455 (##sys#error 'pseudo-random-integer "bad argument type" n))456 (else457 (##core#inline_allocate ("C_s_a_u_i_random_int" 2) n))))458459(define (pseudo-random-real)460 (##core#inline_allocate ("C_a_i_random_real" 2)))461462(define random-bytes463 (let ((nstate (foreign-value "C_RANDOM_STATE_SIZE" unsigned-int)))464 (lambda (#!optional buf size)465 (when size466 (##sys#check-fixnum size 'random-bytes)467 (when (< size 0)468 (##sys#error 'random-bytes "invalid size" size)))469 (let* ((dest (cond (buf470 (when (or (##sys#immediate? buf)471 (not (##core#inline "C_byteblockp" buf)))472 (##sys#error 'random-bytes473 "invalid buffer type" buf))474 buf)475 (else (##sys#make-bytevector (or size nstate)))))476 (r (##core#inline "C_random_bytes" dest477 (or size (##sys#size dest)))))478 (unless r479 (##sys#error 'random-bytes "unable to read random bytes"))480 dest))))481482)