mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Refactoring some utils.
This commit is contained in:
parent
78d68de282
commit
b40f5284fc
3 changed files with 59 additions and 78 deletions
|
@ -3,24 +3,6 @@
|
|||
;; This code was written by Alex Shinn in 2014 and placed in the
|
||||
;; Public Domain. All warranties are disclaimed.
|
||||
|
||||
(define (find-in-path file . o)
|
||||
(any (lambda (dir)
|
||||
(let ((path (make-path dir file)))
|
||||
(and (file-exists? path) path)))
|
||||
(if (pair? o)
|
||||
(car o)
|
||||
(string-split (get-environment-variable "PATH") #\:))))
|
||||
|
||||
(define (find-sexp-in-path file dirs . o)
|
||||
(let ((pred (if (pair? o) (car o) (lambda (x) #t))))
|
||||
(any (lambda (dir)
|
||||
(let ((path (make-path dir file)))
|
||||
(and (file-exists? path)
|
||||
(guard (exn (else #f))
|
||||
(let ((x (call-with-input-file path read)))
|
||||
(and (pred x) x))))))
|
||||
dirs)))
|
||||
|
||||
(define known-implementations
|
||||
'((chibi "chibi-scheme")
|
||||
(chicken "chicken")
|
||||
|
@ -72,52 +54,6 @@
|
|||
(define (conf-for-implementation cfg impl)
|
||||
(conf-specialize cfg 'implementation impl))
|
||||
|
||||
(define (call-with-output-string proc)
|
||||
(let ((out (open-output-string)))
|
||||
(proc out)
|
||||
(get-output-string out)))
|
||||
|
||||
(define (write-to-string x)
|
||||
(call-with-output-string (lambda (out) (write x out))))
|
||||
|
||||
(define (resource->bytevector uri)
|
||||
(let ((uri (if (uri? uri) uri (string->path-uri 'http uri))))
|
||||
(if (uri-host uri)
|
||||
(call-with-input-url uri port->bytevector)
|
||||
(file->bytevector (uri-path uri)))))
|
||||
|
||||
(define (file->sexp-list file)
|
||||
(call-with-input-file file
|
||||
(lambda (in)
|
||||
(let lp ((res '()))
|
||||
(let ((x (read in)))
|
||||
(if (eof-object? x)
|
||||
(reverse res)
|
||||
(lp (cons x res))))))))
|
||||
|
||||
(define (version-split str)
|
||||
(if str
|
||||
(map (lambda (x) (or (string->number x) x))
|
||||
(string-split str #\.))
|
||||
'()))
|
||||
|
||||
(define (version-compare a b)
|
||||
(define (less? x y)
|
||||
(cond ((number? x) (if (number? y) (< x y) 1))
|
||||
((number? y) -1)
|
||||
(else (string<? x y))))
|
||||
(let lp ((as (version-split a))
|
||||
(bs (version-split b)))
|
||||
(cond
|
||||
((null? as) (if (null? bs) -1 0))
|
||||
((null? bs) 1)
|
||||
((less? (car as) (car bs)) -1)
|
||||
((less? (car bs) (car as)) 1)
|
||||
(else (lp (cdr as) (cdr bs))))))
|
||||
|
||||
(define (version>? a b) (> (version-compare a b) 0))
|
||||
(define (version>=? a b) (>= (version-compare a b) 0))
|
||||
|
||||
;; Hack to evaluate an expression in a separate process with a larger
|
||||
;; default heap. The expression and result must be serializable with
|
||||
;; write, and imports should be an argument list for environment.
|
||||
|
|
|
@ -1,10 +1,50 @@
|
|||
|
||||
;;> Copies the file \var{from} to \var{to}.
|
||||
(define (find-in-path file . o)
|
||||
(any (lambda (dir)
|
||||
(let ((path (make-path dir file)))
|
||||
(and (file-exists? path) path)))
|
||||
(if (pair? o)
|
||||
(car o)
|
||||
(string-split (get-environment-variable "PATH") #\:))))
|
||||
|
||||
(define (copy-file from to)
|
||||
(let ((in (open-binary-input-file from))
|
||||
(out (open-binary-output-file to)))
|
||||
(let lp ()
|
||||
(let ((n (read-u8 in)))
|
||||
(cond ((eof-object? n) (close-input-port in) (close-output-port out))
|
||||
(else (write-u8 n out) (lp)))))))
|
||||
(define (find-sexp-in-path file dirs . o)
|
||||
(let ((pred (if (pair? o) (car o) (lambda (x) #t))))
|
||||
(any (lambda (dir)
|
||||
(let ((path (make-path dir file)))
|
||||
(and (file-exists? path)
|
||||
(guard (exn (else #f))
|
||||
(let ((x (call-with-input-file path read)))
|
||||
(and (pred x) x))))))
|
||||
dirs)))
|
||||
|
||||
(define (write-to-string x)
|
||||
(call-with-output-string (lambda (out) (write x out))))
|
||||
|
||||
(define (resource->bytevector uri)
|
||||
(let ((uri (if (uri? uri) uri (string->path-uri 'http uri))))
|
||||
(if (uri-host uri)
|
||||
(call-with-input-url uri port->bytevector)
|
||||
(file->bytevector (uri-path uri)))))
|
||||
|
||||
(define (version-split str)
|
||||
(if str
|
||||
(map (lambda (x) (or (string->number x) x))
|
||||
(string-split str #\.))
|
||||
'()))
|
||||
|
||||
(define (version-compare a b)
|
||||
(define (less? x y)
|
||||
(cond ((number? x) (if (number? y) (< x y) 1))
|
||||
((number? y) -1)
|
||||
(else (string<? x y))))
|
||||
(let lp ((as (version-split a))
|
||||
(bs (version-split b)))
|
||||
(cond
|
||||
((null? as) (if (null? bs) -1 0))
|
||||
((null? bs) 1)
|
||||
((less? (car as) (car bs)) -1)
|
||||
((less? (car bs) (car as)) 1)
|
||||
(else (lp (cdr as) (cdr bs))))))
|
||||
|
||||
(define (version>? a b) (> (version-compare a b) 0))
|
||||
(define (version>=? a b) (>= (version-compare a b) 0))
|
||||
|
|
|
@ -1,12 +1,17 @@
|
|||
|
||||
(define-library (chibi snow utils)
|
||||
(export copy-file)
|
||||
(export find-in-path find-sexp-in-path
|
||||
write-to-string resource->bytevector
|
||||
version-split version-compare version>? version>=?)
|
||||
(import (scheme base)
|
||||
(scheme file)
|
||||
(scheme time)
|
||||
(srfi 33)
|
||||
(chibi filesystem)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme process-context)
|
||||
(srfi 1)
|
||||
(chibi io)
|
||||
(chibi net http)
|
||||
(chibi pathname)
|
||||
(chibi process)
|
||||
(chibi snow interface))
|
||||
(chibi string)
|
||||
(chibi uri))
|
||||
(include "utils.scm"))
|
||||
|
|
Loading…
Add table
Reference in a new issue