397 lines
13 KiB
Scheme
397 lines
13 KiB
Scheme
(define (reduce-port port reader op . seeds)
|
|
(letrec* ((looper (lambda new-seeds
|
|
(let ((read-value (reader port)))
|
|
(if (eof-object? read-value)
|
|
(apply values new-seeds)
|
|
(call-with-values (lambda ()
|
|
(apply op read-value new-seeds))
|
|
looper))))))
|
|
(apply looper seeds)))
|
|
|
|
(define port-fold reduce-port)
|
|
|
|
(define (simplify-file-name fname) ;; TODO
|
|
(cond
|
|
((not (string? fname))
|
|
(error "simplify-file-name error: fname must be string"))
|
|
(else fname)))
|
|
|
|
(define set-umask set-umask!)
|
|
|
|
(define (setenv var val)
|
|
(when (not (string? var)) (error "setenv error: var must be string"))
|
|
(when (not (string? val)) (error "setenv error: val must be string"))
|
|
(set-environment-variable! var val))
|
|
|
|
(define getenv get-environment-variable)
|
|
|
|
(define (glob-quote str)
|
|
(list->string
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (c)
|
|
(if (member c (list #\*))
|
|
(list #\\ c)
|
|
(list c)))
|
|
(string->list str)))))
|
|
|
|
(define (add-after elt after lst)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (item)
|
|
(if (equal? item after)
|
|
(list item elt)
|
|
(list item)))
|
|
lst)))
|
|
|
|
(define (add-before elt after lst)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (item)
|
|
(if (equal? item after)
|
|
(list elt item)
|
|
(list item)))
|
|
lst)))
|
|
|
|
(define (alist->env alist)
|
|
(map (lambda (item)
|
|
(cond
|
|
((not (pair? item))
|
|
(error "alist->env error: alist items must be pairs" item))
|
|
((not (string? (car item)))
|
|
(error "alist->env error: alist item car must be string" item))
|
|
((and (not (string? (cdr item)))
|
|
(not (list? (cdr item))))
|
|
(error (string-append "alist->env error: alist item cdr must be"
|
|
"string or list of strings")
|
|
item))
|
|
((string? (cdr item))
|
|
(string-append (car item) "=" (cdr item)))
|
|
((list? (cdr item))
|
|
(for-each
|
|
(lambda (cdr-list-item)
|
|
(when (not (string? cdr-list-item))
|
|
(error (string-append "alist->env errror: all cdr list"
|
|
" items must be strings"
|
|
item))))
|
|
(cdr item))
|
|
(string-append (car item) "=" (string-join (cdr item) ":")))
|
|
(else (error "alist->env error: unexpected error" alist))))
|
|
alist))
|
|
|
|
(define (alist-compress alist)
|
|
(let ((result '()))
|
|
(for-each
|
|
(lambda (item)
|
|
(when (not (member item result))
|
|
(set! result (cons item result))))
|
|
alist)
|
|
(reverse result)))
|
|
|
|
(define (alist-delete key alist)
|
|
(let ((result '()))
|
|
(for-each
|
|
(lambda (item)
|
|
(when (not (equal? key (car item)))
|
|
(set! result (cons item result))))
|
|
alist)
|
|
(reverse result)))
|
|
|
|
(define (alist-update key val alist)
|
|
(cons (cons key val) (alist-delete key alist)))
|
|
|
|
(define (arg arglist n . default)
|
|
(when (not (list? arglist)) (error "arg error: arglist must be list"))
|
|
(when (not (integer? n)) (error "arg error: n must be integer"))
|
|
(when (< n 1) (error "arg error: Index starts from 1"))
|
|
(if (and (< (length arglist) n)
|
|
(not (null? default)))
|
|
(car default)
|
|
(list-ref arglist (- n 1))))
|
|
|
|
(define (arg* arglist n . default-thunk)
|
|
(when (not (list? arglist)) (error "arg* error: arglist must be list"))
|
|
(when (not (integer? n)) (error "arg* error: n must be integer"))
|
|
(when (< n 1) (error "arg* error: Index starts from 1"))
|
|
(if (and (< (length arglist) n)
|
|
(not (null? default-thunk)))
|
|
(begin
|
|
(when (not (procedure? (car default-thunk)))
|
|
(error "arg* error: default-tunk must be procedure"))
|
|
(apply (car default-thunk) '()))
|
|
(list-ref arglist (- n 1))))
|
|
|
|
(define (argv n)
|
|
(when (not (integer? n)) (error "argv error: n must be integer"))
|
|
(arg (command-line) (+ n 1)))
|
|
|
|
(define current-autoreap-policy 'wait)
|
|
(define autoreap-policy
|
|
(lambda args
|
|
(cond
|
|
((null? args) current-autoreap-policy)
|
|
(else
|
|
(when (not (or (equal? (car args) 'early)
|
|
(equal? (car args) 'late)
|
|
(equal? (car args) #f)))
|
|
(error "autoreap-policy error: policy must be 'early, 'late or #f"
|
|
(car args)))
|
|
(set! current-autoreap-policy (car args))))))
|
|
|
|
(define (sleep time)
|
|
(when (not (integer? time)) (error "sleep error: time must be integer" time))
|
|
(letrec*
|
|
((end-time
|
|
(let ((end-time (current-time))
|
|
(seconds (quotient time 1000))
|
|
(nanoseconds (* (remainder time 1000) 1000000)))
|
|
(set-time-second! end-time (+ (time-second end-time) seconds))
|
|
(set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
|
|
end-time))
|
|
(looper (lambda () (when (time<? (current-time) end-time) (looper)))))
|
|
(looper)))
|
|
|
|
(define (process-sleep secs)
|
|
(when (not (integer? secs))
|
|
(error "process-sleep error: secs must be integer" secs))
|
|
(sleep (* secs 1000)))
|
|
|
|
(define (call-terminally thunk)
|
|
(when (not (procedure? thunk))
|
|
(error "call-terminally error: thunk must be procedure" thunk))
|
|
(thunk)
|
|
(exit 0))
|
|
|
|
(define (call-with-string-output-port procedure)
|
|
(when (not (procedure? procedure))
|
|
(error (string-append "call-with-string-output-port error: procedure"
|
|
" argument must be type of procedure")
|
|
procedure))
|
|
(let ((port (open-output-string)))
|
|
(procedure port)
|
|
(get-output-string port)))
|
|
|
|
(define (char-ascii? character)
|
|
(when (not (char? character))
|
|
(error "char-ascii? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:ascii character))
|
|
|
|
(define (char-blank? character)
|
|
(when (not (char? character))
|
|
(error "char-blank? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:blank character))
|
|
|
|
(define (char-digit? character)
|
|
(when (not (char? character))
|
|
(error "char-digit? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:digit character))
|
|
|
|
(define (char-graphic? character)
|
|
(when (not (char? character))
|
|
(error "char-graphic? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:graphic character))
|
|
|
|
(define (char-hex-digit? character)
|
|
(when (not (char? character))
|
|
(error "char-hex-digit? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:hex-digit character))
|
|
|
|
(define (char-iso-control? character)
|
|
(when (not (char? character))
|
|
(error "char-iso-control? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:iso-control character))
|
|
|
|
(define (char-letter+digit? character)
|
|
(when (not (char? character))
|
|
(error "char-letter+digit? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:letter+digit character))
|
|
|
|
(define (char-letter? character)
|
|
(when (not (char? character))
|
|
(error "char-letter? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:letter character))
|
|
|
|
(define (char-printing? character)
|
|
(when (not (char? character))
|
|
(error "char-printing? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:printing character))
|
|
|
|
(define (char-punctuation? character)
|
|
(when (not (char? character))
|
|
(error "char-punctuation? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:punctuation character))
|
|
|
|
(define (char-title-case? character)
|
|
(when (not (char? character))
|
|
(error "char-title-case? error: character argument must be of type character"
|
|
character))
|
|
(char-set-contains? char-set:title-case character))
|
|
|
|
(define (command-line-arguments)
|
|
(cdr (command-line)))
|
|
|
|
(define (directory-as-file-name fname)
|
|
(cond
|
|
((not (string? fname))
|
|
(error "directory-as-file-name error: fname must be string" fname))
|
|
((string=? fname "/")
|
|
"/")
|
|
((string=? fname "")
|
|
".")
|
|
(else
|
|
(let ((fname-length (string-length fname)))
|
|
(if (char=? (string-ref fname (- fname-length 1)) #\/)
|
|
(string-copy fname 0 (- fname-length 1))
|
|
fname)))))
|
|
|
|
(define (env->alist str)
|
|
(map (lambda (item)
|
|
(apply cons (string-split item #\=)))
|
|
(string-split str #\newline)))
|
|
|
|
(define (error-output-port) (current-error-port))
|
|
|
|
(define (file-last-access fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:atime fi)))
|
|
|
|
(define (file-last-mod fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:mtime fi)))
|
|
|
|
(define (file-last-status-change fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:ctime fi)))
|
|
|
|
(define (file-mode fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:mode fi)))
|
|
|
|
(define (file-name-absolute? fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-absolute? error: fname must be string" fname))
|
|
(if (string=? fname "")
|
|
#t
|
|
(path-absolute? fname)))
|
|
|
|
(define (file-name-as-directory fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-as-directory error: fname must be string" fname))
|
|
(cond ((string=? fname ".") "")
|
|
((string=? fname "/") "/")
|
|
((string=? fname "") "/")
|
|
((char=? (string-ref fname (- (string-length fname) 1)) #\/) fname)
|
|
(else (string-append fname "/"))))
|
|
|
|
(define (file-name-directory fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-directory error: fname must be string" fname))
|
|
(cond ((string=? fname "/") "")
|
|
((string=? fname "") "")
|
|
(else
|
|
(let ((chibi-path (path-directory fname)))
|
|
(if (string=? chibi-path ".")
|
|
""
|
|
chibi-path)))))
|
|
|
|
(define (file-name-directory? fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-directory? error: fname must be string" fname))
|
|
(cond ((string=? fname "/") #t)
|
|
((string=? fname ".") #f)
|
|
((string=? fname "") #t)
|
|
(else (char=? (string-ref fname (- (string-length fname) 1)) #\/))))
|
|
|
|
(define (file-name-extension fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-extension error: fname must be string" fname))
|
|
(let ((extension (path-extension fname)))
|
|
(if extension (string-append "." extension) "")))
|
|
|
|
(define (file-name-non-directory? fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-non-directory? error: fname must be string" fname))
|
|
(if (string=? fname "") #t (not (file-name-directory? fname))))
|
|
|
|
(define (file-name-sans-extension fname)
|
|
(when (not (string? fname))
|
|
(error "file-name-sans-extension error: fname must be string" fname))
|
|
(path-strip-extension fname))
|
|
|
|
(define (file-nlinks fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:nlinks fi)))
|
|
|
|
(define (file-owner fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:uid fi)))
|
|
|
|
(define (file-size fname/port follow?)
|
|
(let* ((fi (file-info fname/port follow?)))
|
|
(file-info:size fi)))
|
|
|
|
(define home-directory (get-environment-variable "HOME"))
|
|
|
|
(define home-file
|
|
(lambda args
|
|
(when (and (= (length args) 1) (not (string? (list-ref args 0))))
|
|
(error "home-file error: fname must be string"))
|
|
(when (and (= (length args) 2) (not (string? (list-ref args 0))))j
|
|
(error "home-file error: user must be string"))
|
|
(when (and (= (length args) 2) (not (string? (list-ref args 1))))
|
|
(error "home-file error: user must be string"))
|
|
(let ((dir (if (= (length args) 2)
|
|
(home-dir (list-ref args 0))
|
|
(home-dir)))
|
|
(fname (if (= (length args) 2)
|
|
(home-dir (list-ref args 1))
|
|
(home-dir))))
|
|
(string-append dir "/" fname))))
|
|
|
|
(define (make-char-port-filter filter)
|
|
(lambda ()
|
|
(letrec* ((looper (lambda (c)
|
|
(when (not (eof-object? c))
|
|
(write-char (filter c))
|
|
(looper (read-char))))))
|
|
(looper (read-char)))))
|
|
|
|
(define (make-string-input-port str) (open-input-string str))
|
|
|
|
(define (make-string-output-port str) (open-output-string str))
|
|
|
|
(define (make-string-port-filter filter . args)
|
|
(lambda ()
|
|
(letrec* ((buflen
|
|
(cond ((and (= (length args) 1)
|
|
(not (integer? (list-ref args 0))))
|
|
(error (string-append "make-string-port-filter error:"
|
|
" buflen must be integer" )))
|
|
((and (= (length args) 1)) (list-ref args 0))
|
|
(else 1024)))
|
|
(looper (lambda (str)
|
|
(when (not (eof-object? str))
|
|
(display (filter str))
|
|
(looper (read-string buflen))))))
|
|
(looper (read-string buflen)))))
|
|
|
|
(define (os)
|
|
(cond-expand
|
|
(linux 'linux)
|
|
(freebsd 'freesdb)
|
|
(netbsd 'netbsd)
|
|
(else 'unix)))
|