Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

working towards snow portability

Browse source
This commit is contained in:
Alex Shinn 2016-10-17 23:00:14 +09:00
parent 74d4fa3199
commit 50b17ac397
6 changed files with 163 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
lib/chibi/binary-record.sld
View file

@ -1,11 +1,21 @@
(define-library (chibi binary-record)
(import (scheme base)
(srfi 1) (srfi 9)
(chibi io) (chibi string)
(only (chibi) identifier? er-macro-transformer))
(srfi 1)
(chibi string))
(cond-expand
((library (srfi 33)) (import (srfi 33)))
(else (import (srfi 60))))
(cond-expand
(chibi
(import (only (chibi) identifier? er-macro-transformer)))
(chicken
(import chicken)
(begin
(define identifier? symbol?)))
(sagittarius
(import (sagittarius))
(begin
(define identifier? symbol?))))
(export define-binary-record-type)
(include "binary-record.scm"))

88
lib/chibi/filesystem.sld
View file

@ -35,6 +35,90 @@
file-is-readable? file-is-writable? file-is-executable?
lock/shared lock/exclusive lock/non-blocking lock/unlock
chmod is-a-tty?)
(import (chibi) (chibi string))
(include-shared "filesystem")
(import (chibi string))
(cond-expand
(chibi
(import (chibi))
(include-shared "filesystem"))
(chicken
(import (scheme base) (library) (posix))
(begin
(define file-status file-stat)
(define (file-link-status x) (file-stat x #t))
(define (stat-dev x) (vector-ref x 9))
(define (stat-ino x) (vector-ref x 0))
(define (stat-mode x) (vector-ref x 1))
(define (stat-nlinks x) (vector-ref x 2))
(define (stat-uid x) (vector-ref x 3))
(define (stat-gid x) (vector-ref x 4))
(define (stat-rdev x) (vector-ref x 10))
(define (stat-size x) (vector-ref x 5))
(define (stat-blksize x) (vector-ref x 11))
(define (stat-blocks x) (vector-ref x 12))
(define (stat-atime x) (vector-ref x 6))
(define (stat-mtime x) (vector-ref x 7))
(define (stat-ctime x) (vector-ref x 8))
(define duplicate-file-descriptor duplicate-fileno)
(define duplicate-file-descriptor-to duplicate-fileno)
(define close-file-descriptor file-close)
(define open-input-file-descriptor open-input-file*)
(define open-output-file-descriptor open-output-file*)
(define link-file file-link)
(define symbolic-link-file create-symbolic-link)
(define read-link read-symbolic-link)
(define open file-open)
(define open-pipe create-pipe)
(define make-fifo create-fifo)
(define file-regular? regular-file?)
(define file-directory? directory?)
(define file-character? character-device?)
(define file-block? block-device?)
(define file-fifo? fifo?)
(define file-link? symbolic-link?)
(define file-socket? socket?)
(define file-is-readable? file-read-access?)
(define file-is-writable? file-write-access?)
(define file-is-executable? file-execute-access?)
(define (get-file-descriptor-flags fileno)
(file-control fileno fcntl/getfd))
(define (set-file-descriptor-flags! fileno x)
(file-control fileno fcntl/setfd x))
(define (get-file-descriptor-status fileno)
(file-control fileno fcntl/getfl))
(define (set-file-descriptor-status! fileno x)
(file-control fileno fcntl/setfl x))
(define open/read-write open/rdwr)
(define open/create open/creat)
(define open/exclusive open/excl)
(define open/truncate open/trunc)
(define open/non-block open/nonblock)
(define chmod change-file-mode)
(define is-a-tty? terminal-port?)
))
(sagittarius
(import (scheme base) (sagittarius))
(begin
(define (file-status x) x)
(define file-link-status file-status)
(define-syntax define-unimplemented
(syntax-rules ()
((define-unimplemented def ...)
(define (def . x) (error "unimplemented" 'def)) ...)))
(define-unimplemented
stat-dev stat-ino stat-mode stat-nlinks stat-uid stat-gid
stat-rdev stat-blksize stat-blocks)
(define (stat-size x) (file-size-in-bytes x))
(define (stat-atime x) (file-stat-atime x))
(define (stat-mtime x) (file-stat-mtime x))
(define (stat-ctime x) (file-stat-ctime x))
(define file-is-readable? file-readable?)
(define file-is-writable? file-writable?)
(define file-is-executable? file-executable?)
(define file-link? file-symbolic-link?)
(define-unimplemented
duplicate-file-descriptor duplicate-file-descriptor-to
close-file-descriptor open-input-file-descriptor
open-output-file-descriptor)
)))
(include "filesystem.scm"))

6
lib/chibi/snow/fort.sld
View file

@ -15,7 +15,6 @@
(scheme file)
(srfi 1)
(srfi 18)
(srfi 33)
(chibi snow package)
(chibi bytevector)
(chibi config)
@ -29,6 +28,11 @@
(chibi string)
(chibi sxml)
(chibi tar))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
(cond-expand
(chibi
(import (only (chibi ast)

52
lib/chibi/snow/interface.sld
View file

@ -4,6 +4,54 @@
restore-history save-history)
(import (scheme base) (scheme char) (scheme read) (scheme write)
(scheme file) (scheme process-context) (srfi 1)
(chibi config) (chibi filesystem) (chibi pathname)
(chibi show) (chibi stty) (chibi term edit-line))
(chibi config) (chibi pathname) (chibi show))
(cond-expand
(chibi
(import (chibi filesystem) (chibi stty)))
(chicken
(import posix stty)
(begin
(define (create-directory* dir) (create-directory dir #t))
(define (edit-line ))))
(sagittarius
(import (only (sagittarius) create-directory)
(chibi string))
(begin
(define (create-directory* dir . o)
(let ((mode (if (pair? o) (car o) #o755)))
(or (file-directory? dir)
(create-directory dir mode)
(let* ((start (string-cursor-start dir))
(slash
(string-find-right dir #\/ start
(string-skip-right dir #\/))))
(and (string-cursor>? slash start)
(let ((parent (substring-cursor dir start slash)))
(and (not (equal? parent dir))
(not (file-exists? parent))
(create-directory* parent mode)
(create-directory dir mode))))))))
(define (with-stty spec thunk)
(thunk)))))
(cond-expand
(chibi
(import (chibi term edit-line)))
(else
(begin
(define (get-key ls key . o)
(let ((x (memq key ls)))
(if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
(define (edit-line . args)
(let ((in (if (and (pair? args) (input-port? (car args)))
(car args)
(current-input-port)))
(out (if (and (eq? in (car args))
(pair? (cdr args))
(output-port? (cadr args)))
(cadr args)
(current-output-port)))
(prompter (get-key args 'prompt: "> ")))
(display (if (procedure? prompter) (prompter) prompter) out)
(flush-output-port out)
(read-line in))))))
(include "interface.scm"))

1
lib/chibi/snow/package.sld
View file

@ -34,7 +34,6 @@
(chibi crypto md5)
(chibi crypto rsa)
(chibi crypto sha2)
(chibi filesystem)
(chibi io)
(chibi pathname)
(chibi regexp)

12
lib/chibi/tar.sld
View file

@ -1,8 +1,14 @@
(define-library (chibi tar)
(import (scheme base) (scheme file) (scheme time) (srfi 1) (srfi 33)
(chibi string) (chibi binary-record)
(chibi pathname) (chibi filesystem) (chibi system))
(import (scheme base) (scheme file) (scheme time) (srfi 1)
(chibi string) (chibi binary-record) (chibi pathname)
(chibi filesystem)
(chibi system))
(cond-expand
((library (srfi 33))
(import (srfi 33)))
(else
(import (srfi 60))))
(export
;; basic
tar make-tar tar? read-tar write-tar