~ 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 ((char<? c #\x20)118 (loop (fx+ j 1)119 (fx+ j 1)120 (let ((col2121 (out (##sys#substring obj i j) col)))122 (cond ((assq c '((#\tab . "\\t")123 (#\newline . "\\n")124 (#\return . "\\r")125 (#\vtab . "\\v")126 (#\page . "\\f")127 (#\alarm . "\\a")128 (#\backspace . "\\b")))129 =>130 (lambda (a)131 (out (cdr a) col2)))132 (else133 (out (string-append134 "\\x"135 (number->string (char->integer c) 16)136 ";")137 col2))))))138 (else (loop i (fx+ j 1) col))))139 (out "\""140 (out (##sys#substring obj i j) col))))))141 ((char? obj) (if display?142 (out (make-string 1 obj) col)143 (let ((code (char->integer obj))144 (col2 (out "#\\" col)))145 (cond ((char-name obj)146 => (lambda (cn)147 (out (##sys#symbol->string/shared cn) col2) ) )148 ((or (fx< code 32) (fx> code 127))149 (out (number->string code 16)150 (out "x" col2)))151 (else (out (make-string 1 obj) col2)) ) ) ) )152 ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))153 ((##core#inline "C_unboundvaluep" obj) (out "#<unbound value>" col))154 ((##core#inline "C_immp" obj) (out "#<unprintable object>" col))155 ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))156 ((##sys#generic-structure? obj)157 (let ((o (open-output-string)))158 (##sys#user-print-hook obj #t o)159 (out (get-output-string o) col) ) )160 ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))161 ((##core#inline "C_bytevectorp" obj)162 (out "#u8" col)163 (wr-lst (##sys#bytevector->list obj) col))164 ((##core#inline "C_lambdainfop" obj)165 (out ">"166 (out (##sys#lambda-info->string obj)167 (out "#<lambda info " col) )))168 (else (out "#<unprintable object>" col)) ) )169170 (define (pp obj col)171172 (define (spaces n col)173 (if (> n 0)174 (if (> n 7)175 (spaces (- n 8) (out " " col))176 (out (##sys#substring " " 0 n) col))177 col))178179 (define (indent to col)180 (and col181 (if (< to col)182 (and (out (make-string 1 #\newline) col) (spaces to 0))183 (spaces (- to col) col))))184185 (define (pr obj col extra pp-pair)186 (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines187 (let ((result '())188 (left (max (+ (- (- width col) extra) 1) max-expr-width)))189 (generic-write obj display? #f190 (lambda (str)191 (set! result (cons str result))192 (set! left (- left (string-length str)))193 (> left 0)))194 (if (> left 0) ; all can be printed on one line195 (out (reverse-string-append result) col)196 (if (pair? obj)197 (pp-pair obj col extra)198 (pp-list (vector->list obj) (out "#" col) extra pp-expr))))199 (wr obj col)))200201 (define (pp-expr expr col extra)202 (if (read-macro? expr)203 (pr (read-macro-body expr)204 (out (read-macro-prefix expr) col)205 extra206 pp-expr)207 (let ((head (car expr)))208 (if (symbol? head)209 (let ((proc (style head)))210 (if proc211 (proc expr col extra)212 (if (> (string-length (##sys#symbol->string/shared head))213 max-call-head-width)214 (pp-general expr col extra #f #f #f pp-expr)215 (pp-call expr col extra pp-expr))))216 (pp-list expr col extra pp-expr)))))217218 ; (head item1219 ; item2220 ; item3)221 (define (pp-call expr col extra pp-item)222 (let ((col* (wr (car expr) (out "(" col))))223 (and col224 (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))225226 ; (item1227 ; item2228 ; item3)229 (define (pp-list l col extra pp-item)230 (let ((col (out "(" col)))231 (pp-down l col col extra pp-item)))232233 (define (pp-down l col1 col2 extra pp-item)234 (let loop ((l l) (col col1))235 (and col236 (cond ((pair? l)237 (let ((rest (cdr l)))238 (let ((extra (if (null? rest) (+ extra 1) 0)))239 (loop rest240 (pr (car l) (indent col2 col) extra pp-item)))))241 ((null? l)242 (out ")" col))243 (else244 (out ")"245 (pr l246 (indent col2 (out "." (indent col2 col)))247 (+ extra 1)248 pp-item)))))))249250 (define (pp-general expr col extra named? pp-1 pp-2 pp-3)251252 (define (tail1 rest col1 col2 col3)253 (if (and pp-1 (pair? rest))254 (let* ((val1 (car rest))255 (rest (cdr rest))256 (extra (if (null? rest) (+ extra 1) 0)))257 (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))258 (tail2 rest col1 col2 col3)))259260 (define (tail2 rest col1 col2 col3)261 (if (and pp-2 (pair? rest))262 (let* ((val1 (car rest))263 (rest (cdr rest))264 (extra (if (null? rest) (+ extra 1) 0)))265 (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))266 (tail3 rest col1 col2)))267268 (define (tail3 rest col1 col2)269 (pp-down rest col2 col1 extra pp-3))270271 (let* ((head (car expr))272 (rest (cdr expr))273 (col* (wr head (out "(" col))))274 (if (and named? (pair? rest))275 (let* ((name (car rest))276 (rest (cdr rest))277 (col** (wr name (out " " col*))))278 (tail1 rest (+ col indent-general) col** (+ col** 1)))279 (tail1 rest (+ col indent-general) col* (+ col* 1)))))280281 (define (pp-expr-list l col extra)282 (pp-list l col extra pp-expr))283284 (define (pp-lambda expr col extra)285 (pp-general expr col extra #f pp-expr-list #f pp-expr))286287 (define (pp-if expr col extra)288 (pp-general expr col extra #f pp-expr #f pp-expr))289290 (define (pp-cond expr col extra)291 (pp-call expr col extra pp-expr-list))292293 (define (pp-case expr col extra)294 (pp-general expr col extra #f pp-expr #f pp-expr-list))295296 (define (pp-and expr col extra)297 (pp-call expr col extra pp-expr))298299 (define (pp-let expr col extra)300 (let* ((rest (cdr expr))301 (named? (and (pair? rest) (symbol? (car rest)))))302 (pp-general expr col extra named? pp-expr-list #f pp-expr)))303304 (define (pp-begin expr col extra)305 (pp-general expr col extra #f #f #f pp-expr))306307 (define (pp-do expr col extra)308 (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))309310 ;; define formatting style (change these to suit your style)311312 (define indent-general 2)313314 (define max-call-head-width 5)315316 (define max-expr-width 50)317318 (define (style head)319 (case head320 ((lambda let* letrec letrec* define) pp-lambda)321 ((if set!) pp-if)322 ((cond) pp-cond)323 ((case) pp-case)324 ((and or) pp-and)325 ((let) pp-let)326 ((begin) pp-begin)327 ((do) pp-do)328 (else #f)))329330 (pr obj col 0 pp-expr))331332 (if width333 (out (make-string 1 #\newline) (pp obj 0))334 (wr obj 0))))335336; (pretty-print obj port) pretty prints 'obj' on 'port'. The current337; output port is used if 'port' is not specified.338339(define pretty-print-width (make-parameter 79))340341(define (pretty-print obj . opt)342 (let ((port (if (pair? opt) (car opt) (current-output-port))))343 (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))344 (##core#undefined) ) )345346(define pp pretty-print))347348349;;; Write simple formatted output:350351(module chicken.format352 (format fprintf printf sprintf)353354(import scheme chicken.base chicken.fixnum chicken.platform)355(import (only (scheme base) open-output-string get-output-string))356357(define fprintf0358 (lambda (loc port msg args)359 (when port (##sys#check-output-port port #t loc))360 (let ((out (if (and port (##sys#tty-port? port))361 port362 (open-output-string))))363 (let rec ([msg msg] [args args])364 (##sys#check-string msg loc)365 (let ((index 0)366 (len (string-length msg)) )367 (define (fetch)368 (let ((c (string-ref msg index)))369 (set! index (fx+ index 1))370 c) )371 (define (next)372 (if (##core#inline "C_eqp" args '())373 (##sys#error loc "too few arguments to formatted output procedure")374 (let ((x (##sys#slot args 0)))375 (set! args (##sys#slot args 1))376 x) ) )377 (let loop ()378 (unless (fx>= index len)379 (let ((c (fetch)))380 (if (and (eq? c #\~) (fx< index len))381 (let ((dchar (fetch)))382 (case (char-upcase dchar)383 ((#\S) (write (next) out))384 ((#\A) (display (next) out))385 ((#\C) (##sys#write-char-0 (next) out))386 ((#\B) (display (##sys#number->string (next) 2) out))387 ((#\O) (display (##sys#number->string (next) 8) out))388 ((#\X) (display (##sys#number->string (next) 16) out))389 ((#\!) (##sys#flush-output out))390 ((#\?)391 (let* ([fstr (next)]392 [lst (next)] )393 (##sys#check-list lst loc)394 (rec fstr lst) out) )395 ((#\~) (##sys#write-char-0 #\~ out))396 ((#\% #\N) (newline out))397 (else398 (if (char-whitespace? dchar)399 (let skip ((c (fetch)))400 (if (char-whitespace? c)401 (skip (fetch))402 (set! index (fx- index 1)) ) )403 (##sys#error loc "illegal format-string character" dchar) ) ) ) )404 (##sys#write-char-0 c out) )405 (loop) ) ) ) ) )406 (cond ((not port) (get-output-string out))407 ((not (eq? out port))408 (##sys#print (get-output-string out) #f port) ) ) ) ) )409410(define (fprintf port fstr . args)411 (fprintf0 'fprintf port fstr args) )412413(define (printf fstr . args)414 (fprintf0 'printf ##sys#standard-output fstr args) )415416(define (sprintf fstr . args)417 (fprintf0 'sprintf #f fstr args) )418419(define format420 (lambda (fmt-or-dst . args)421 (apply (cond [(not fmt-or-dst) sprintf]422 [(boolean? fmt-or-dst) printf]423 [(string? fmt-or-dst) (set! args (cons fmt-or-dst args)) sprintf]424 [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]425 [else426 (##sys#error 'format "illegal destination" fmt-or-dst args)])427 args) ) )428429(register-feature! 'srfi-28))430431432;;; Random numbers:433434(module chicken.random435 (set-pseudo-random-seed! pseudo-random-integer pseudo-random-real random-bytes)436437(import scheme chicken.base chicken.time chicken.io chicken.foreign)438439(define (set-pseudo-random-seed! buf #!optional n)440 (cond (n (##sys#check-fixnum n 'set-pseudo-random-seed!)441 (when (##core#inline "C_fixnum_lessp" n 0)442 (##sys#error 'set-pseudo-random-seed! "invalid size" n)))443 (else (set! n (##sys#size buf))))444 (##sys#check-bytevector buf 'set-pseudo-random-seed!)445 (##core#inline "C_set_random_seed" buf446 (##core#inline "C_i_fixnum_min"447 n448 (##sys#size buf))))449450(define (pseudo-random-integer n)451 (cond ((##core#inline "C_fixnump" n)452 (##core#inline "C_random_fixnum" n))453 ((not (##core#inline "C_i_bignump" n))454 (##sys#error 'pseudo-random-integer "bad argument type" n))455 (else456 (##core#inline_allocate ("C_s_a_u_i_random_int" 2) n))))457458(define (pseudo-random-real)459 (##core#inline_allocate ("C_a_i_random_real" 2)))460461(define random-bytes462 (let ((nstate (foreign-value "C_RANDOM_STATE_SIZE" unsigned-int)))463 (lambda (#!optional buf size)464 (when size465 (##sys#check-fixnum size 'random-bytes)466 (when (< size 0)467 (##sys#error 'random-bytes "invalid size" size)))468 (let* ((dest (cond (buf469 (when (or (##sys#immediate? buf)470 (not (##core#inline "C_byteblockp" buf)))471 (##sys#error 'random-bytes472 "invalid buffer type" buf))473 buf)474 (else (##sys#make-bytevector (or size nstate)))))475 (r (##core#inline "C_random_bytes" dest476 (or size (##sys#size dest)))))477 (unless r478 (##sys#error 'random-bytes "unable to read random bytes"))479 dest))))480481)482483484;;; Version comparison (used for egg versions)485486(module chicken.version (version>=?)487488(import scheme)489(import (chicken base)490 (chicken string)491 (chicken fixnum))492493(define (version>=? v1 v2)494 (define (version->list s)495 (map (lambda (x) (or (string->number x) x))496 (let ((len (string-length s)))497 (let loop ((start 0) (pos 0))498 (cond ((fx>= pos len) (list (substring s start len)))499 ((memv (string-ref s pos) '(#\- #\\ #\. #\_ #\/))500 (cons (substring s start pos)501 (let ((p2 (fx+ pos 1)))502 (loop p2 p2))))503 (else (loop start (fx+ pos 1))))))))504 (##sys#check-string v1 'version>=?)505 (##sys#check-string v2 'version>=?)506 (let loop ((p1 (version->list v1))507 (p2 (version->list v2)))508 (cond ((null? p1) (null? p2))509 ((null? p2))510 ((number? (car p1))511 (and (number? (car p2))512 (or (> (car p1) (car p2))513 (and (= (car p1) (car p2))514 (loop (cdr p1) (cdr p2))))))515 ((number? (car p2)))516 ((string>? (car p1) (car p2)))517 (else518 (and (string=? (car p1) (car p2))519 (loop (cdr p1) (cdr p2)))))))520521) ;; end module