mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
120 lines
3.6 KiB
Scheme
120 lines
3.6 KiB
Scheme
|
|
(define call/cc call-with-current-continuation)
|
|
|
|
;; Adapted from Bawden's algorithm.
|
|
(define (rationalize x e)
|
|
(define (sr x y return)
|
|
(let ((fx (inexact->exact (floor x))) (fy (inexact->exact (floor y))))
|
|
(cond
|
|
((>= fx x)
|
|
(return fx 1))
|
|
((= fx fy)
|
|
(sr (/ (- y fy)) (/ (- x fx)) (lambda (n d) (return (+ d (* fx n)) n))))
|
|
(else
|
|
(return (+ fx 1) 1)))))
|
|
(if (exact? x)
|
|
(let ((return (if (negative? x) (lambda (num den) (/ (- num) den)) /))
|
|
(x (abs x))
|
|
(e (abs e)))
|
|
(sr (- x e) (+ x e) return))
|
|
x))
|
|
|
|
(define flush-output-port flush-output)
|
|
|
|
(define (close-port port)
|
|
((if (input-port? port) close-input-port close-output-port) port))
|
|
|
|
(define (u8-ready? port) (char-ready? port))
|
|
|
|
(define (call-with-port port proc)
|
|
(let ((res (proc port)))
|
|
(close-port port)
|
|
res))
|
|
|
|
(define (read-bytevector n . o)
|
|
(if (zero? n)
|
|
""
|
|
(let ((res (read-string n (if (pair? o) (car o) (current-input-port)))))
|
|
(if (eof-object? res)
|
|
res
|
|
(string->utf8 res)))))
|
|
|
|
(define (read-bytevector! vec start end . o)
|
|
(if (>= start end)
|
|
0
|
|
(let* ((res (read-bytevector
|
|
(- end start)
|
|
(if (pair? o) (car o) (current-input-port))))
|
|
(len (bytevector-length res)))
|
|
(cond
|
|
((zero? len)
|
|
(read-char (open-input-string "")))
|
|
(else
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i len) len)
|
|
(bytevector-u8-set! vec (+ i start) (bytevector-u8-ref res i))))))))
|
|
|
|
(define (write-bytevector vec . o)
|
|
(write-string (utf8->string vec) (bytevector-length vec) (if (pair? o) (car o) (current-output-port))))
|
|
|
|
(define (write-partial-bytevector vec start end . o)
|
|
(if (zero? start)
|
|
(apply write-bytevector vec end o)
|
|
(apply write-bytevector (bytevector-copy-partial vec start end) o)))
|
|
|
|
(define (make-list n . o)
|
|
(let ((init (and (pair? o) (car o))))
|
|
(let lp ((i 0) (res '()))
|
|
(if (>= i n) res (lp (+ i 1) (cons init res))))))
|
|
|
|
(define (list-copy ls)
|
|
(reverse (reverse ls)))
|
|
|
|
(define (list-set! ls k x)
|
|
(cond ((null? ls) (error "invalid list index"))
|
|
((zero? k) (set-car! ls x))
|
|
(else (list-set! (cdr ls) (- k 1) x))))
|
|
|
|
(define (vector-map proc vec . lov)
|
|
(if (null? lov)
|
|
(let lp ((i (vector-length vec)) (res '()))
|
|
(if (zero? i)
|
|
(list->vector res)
|
|
(lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res))))
|
|
(list->vector (apply map proc (map vector->list (cons vec lov))))))
|
|
|
|
(define (vector-for-each proc vec . lov)
|
|
(if (null? lov)
|
|
(let ((len (vector-length vec)))
|
|
(let lp ((i 0))
|
|
(cond ((< i len)
|
|
(proc (vector-ref vec i))
|
|
(lp (+ i 1))))))
|
|
(apply for-each proc (map vector->list (cons vec lov)))))
|
|
|
|
(define (vector-copy vec)
|
|
(let* ((len (vector-length vec))
|
|
(res (make-vector len)))
|
|
(do ((i 0 (+ i 1))) ((>= i len) res)
|
|
(vector-set! res i (vector-ref vec i)))))
|
|
|
|
(define (vector->string vec)
|
|
(list->string (vector->list vec)))
|
|
|
|
(define (string->vector vec)
|
|
(list->vector (string->list vec)))
|
|
|
|
(define (bytevector-copy bv)
|
|
(let ((res (make-bytevector (bytevector-length bv))))
|
|
(bytevector-copy! bv res)
|
|
res))
|
|
|
|
(define (bytevector-copy! from to)
|
|
(bytevector-copy-partial! from 0 (bytevector-length from) to 0))
|
|
|
|
(define bytevector-copy-partial subbytes)
|
|
|
|
(define (bytevector-copy-partial! from start end to at)
|
|
(do ((i start (+ i 1)))
|
|
((= i end))
|
|
(bytevector-u8-set! to (+ (- i start) at) (bytevector-u8-ref from i))))
|