summaryrefslogtreecommitdiff
path: root/modules
diff options
context:
space:
mode:
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>2018-03-16 23:50:39 +0100
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>2018-03-16 23:50:39 +0100
commit2050e8565493ca0491ae4b4c44764eda56626427 (patch)
tree404cda14abdb2ff4a847955dc6780c41ba8663f4 /modules
parentb740e34851938e6e9c8b1e80cf5ffd52164aa2b0 (diff)
os module now compiles
Diffstat (limited to 'modules')
-rw-r--r--modules/language/python/for.scm39
-rw-r--r--modules/language/python/module/errno.scm11
-rw-r--r--modules/language/python/module/os.scm671
-rw-r--r--modules/language/python/module/python.scm59
-rw-r--r--modules/language/python/module/resource.scm84
-rw-r--r--modules/language/python/module/stat.scm15
-rw-r--r--modules/language/python/set.scm6
7 files changed, 537 insertions, 348 deletions
diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm
index 4541df2..fcd562b 100644
--- a/modules/language/python/for.scm
+++ b/modules/language/python/for.scm
@@ -18,44 +18,55 @@
(define-syntax for
(syntax-rules (:)
((for ((x ... : E) ...) ((c n) ...) code ... #:final fin)
- (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin))
+ (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin values))
+
+ ((for ((x ... : E) ...) ((c n) ...) code ... #:else fin)
+ (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values)
+ (lambda () fin)))
((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin)
- (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin))
+ (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin values))
+
+ ((for lp ((x ... : E) ...) ((c n) ...) code ... #:else fin)
+ (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values)
+ (lambda () fin)))
((for ((x ... : E) ...) ((c n) ...) code ...)
- (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values)))
+ (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values) values))
((for lp ((x ... : E) ...) ((c n) ...) code ...)
- (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values)))))
+ (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values) values))))
(define-syntax for-work
- (lambda (x)
+ (lambda (z)
(define (wrap-continue lp code)
(if (syntax->datum lp)
#`(lambda () (let/ec #,lp #,@code))
#`(lambda () #,@code)))
- (syntax-case x ()
- ((for lp ((x ... : E) ...) ((c n) ...) (code ...) fin)
+ (syntax-case z ()
+ ((for lp ((x ... : E) ...) ((c n) ...) (code ...) fin er)
(with-syntax (((It ...) (generate-temporaries #'(E ...)))
((cc ...) (generate-temporaries #'(c ...)))
(((x1 ...) ...) (generate-temporaries2 #'((x ...) ...)))
(((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))
((N ...) (map length #'((x ...) ...)))
+ (else- (datum->syntax #'for 'else-))
(llp (if (syntax->datum #'lp) #'lp #'lpu)))
- #`(let/ec lp-break
+ #`(let/ec lp-break0
+ (let ((It (wrap-in E)) ...
+ (c n ) ...
+ (x 'None ) ... ...
+ (x1 #f ) ... ...)
+ (let* ((else- er )
+ (lp-break (lambda q (else-) (apply lp-break0 q))))
(syntax-parameterize ((break (lambda (z)
(syntax-case z ()
((_ . l)
#'(lp-break . l))
(_ #'lp-break)))))
-
- (let ((It (wrap-in E)) ...
- (c n ) ...
- (x 'None ) ... ...
- (x1 #f ) ... ...)
+
(catch StopIteration
(lambda ()
(let llp ((cc c) ...)
@@ -81,7 +92,7 @@
#'lp
#'((let ((x x) ... ...) code ...)))
(lambda (cc ... . q) (llp cc ...)))))
- (lambda q fin))))))))))
+ (lambda q (else-) fin)))))))))))
(define-class <scm-list> () l)
(define-class <scm-string> () s i)
diff --git a/modules/language/python/module/errno.scm b/modules/language/python/module/errno.scm
index 6bcc02a..1626175 100644
--- a/modules/language/python/module/errno.scm
+++ b/modules/language/python/module/errno.scm
@@ -1,7 +1,6 @@
(define-module (language python module errno)
#:use-module (system foreign)
- #:use-module (language python dict)
- #:use-module (language python list)
+ #:use-module (oop pf-objects)
#:export (errno errorcode))
@@ -10,13 +9,15 @@
(lambda ()
(pointer-address (dereference-pointer f)))))
-(define errorcode (dict))
+(define errorcode (make-hash-table))
(define-syntax-rule (mk x n)
(begin
- (define x n)
+ (if (defined? 'x)
+ (define! 'x x)
+ (define! 'x n))
(export x)
- (pylist-set! errorcode n "x")))
+ (pylist-set! errorcode n (symbol->string 'x))))
(mk EPERM 1)
(mk ENOENT 2)
diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm
index 29f7a5b..6639b1d 100644
--- a/modules/language/python/module/os.scm
+++ b/modules/language/python/module/os.scm
@@ -1,23 +1,31 @@
(define-module (language python module os)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
+ #:use-module (ice-9 control)
#:use-module (system foreign)
#:use-module (oop pf-objects)
#:use-module (oop goops)
#:use-module (rnrs bytevectors)
#:use-module (language python for)
- #:use-module ((language python module python) #:select (open))
+ #:use-module (language python persist)
#:use-module (language python try)
#:use-module (language python module stat)
#:use-module (language python exceptions)
#:use-module (language python yield)
+ #:use-module (language python range)
#:use-module (language python string)
#:use-module (language python bytes)
+ #:use-module (language python dict)
+ #:use-module (language python set)
+ #:use-module (language python def)
#:use-module (language python module errno)
+ #:use-module (language python module resource)
+ #:use-module ((language python module python)
+ #:select ((open . builtin:open)))
#:use-module (language python list)
#:export (error name ctermid environ environb chdir fchdir getcwd
fsencode fdencode fspath PathLike getenv getenvb
- get_exec_path getgid getegid geteuid
+ get_exec_path getgid getegid geteuid fdopen
getgroups getgrouplist getlogin getpgid getpgrp getpid
getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority
getresgid getuid initgroups putenv setegid seteuid
@@ -94,14 +102,23 @@
(raise error (errno) ((@ (guile) strerror) (errno)))
(values))))
+(define-syntax-rule (defineu f x)
+ (define f
+ (catch #t
+ (lambda () x)
+ (lambda z
+ (let ((message (format #f "could not define ~a" 'f)))
+ (warn message)
+ (lambda z (error message)))))))
+
(define-syntax guile
(syntax-rules ()
((_ (x ...) code) (guile (x ...) code code))
((_ (x ...) code1 code2)
- (define code1 (lambda (x ...) (ca ((@ (guile) code2 x ...))))))
+ (define code1 (lambda (x ...) (ca ((@ (guile) code2) x ...)))))
((_ code) (guile code code))
((_ code1 code2)
- (define code1 (lambda x (ca (apply (@ (guile) code2 x))))))))
+ (define code1 (lambda x (ca (apply (@ (guile) code2) x)))))))
(define path "posixpath")
@@ -150,11 +167,11 @@
(define __setitem__
(lambda (self k v)
- (putenv (slot-ref (pystring (+ k "=" v)) 'str))))
+ ((@ (guile) putenv) (slot-ref (pystring (+ k "=" v)) 'str))))
(define __delitem__
(lambda (self k)
- (putenv (slot-ref (pystring k) 'str))))
+ ((@ (guile) putenv) (slot-ref (pystring k) 'str))))
(define __iter__
(lambda (self)
@@ -174,11 +191,11 @@
(define __setitem__
(lambda (self k v)
- (putenv (slot-ref (string (+ k "=" v)) 'str))))
+ ((@ (guile) putenv) (slot-ref (string (+ k "=" v)) 'str))))
(define __delitem__
(lambda (self k)
- (putenv (slot-ref (string k) 'str))))
+ ((@ (guile) putenv) (slot-ref (string k) 'str))))
(define __iter__
(lambda (self)
@@ -232,7 +249,7 @@
(define* (get_exec_path #:key (env #f))
(define (f s)
(let ((s (slot-ref (string s) 'str)))
- (string-split str ":")))
+ (string-split s ":")))
(if env
(f (pylist-ref env "PATH"))
(f (pylist-ref environ "PATH"))))
@@ -261,12 +278,13 @@
(guile getppid)
(define PRIO_PROCESS (@ (guile) PRIO_PROCESS))
-(define PRIO_PRGRP (@ (guile) PRIO_PRGRP))
+(define PRIO_PGRP (@ (guile) PRIO_PGRP))
(define PRIO_USER (@ (guile) PRIO_USER))
(guile getpriority)
-(define getresgid
+(define getresgid #f)
+(defineu getresgid
(let* ((f (pointer->procedure
void
(dynamic-func "getresgid" (dynamic-link))
@@ -287,14 +305,15 @@
(guile getuid)
-(define initgroup
+(define initgroups #f)
+(defineu initgroups
(let ((f (pointer->procedure
- 'int
+ int
(dynamic-func "initgroups" (dynamic-link))
- '(* int))))
+ (list '* int))))
(lambda (user group)
- (rm (string->pointer user) group))))
+ (rm (f (string->pointer user) group)))))
(define (putenv key value)
(pylist-set! environ key value))
@@ -304,8 +323,9 @@
(guile setgid)
(guile setgroups)
-(define setpgrp
- (let ((f (pointer->procedure 'int
+(define setpgrp #f)
+(defineu setpgrp
+ (let ((f (pointer->procedure int
(dynamic-func "setpgrp" (dynamic-link))
'())))
(lambda ()
@@ -314,31 +334,35 @@
(guile setpgid)
(guile setpriority)
+(define setregid #f)
(define setregid
- (let ((f (pointer->procedure 'int
+ (let ((f (pointer->procedure int
(dynamic-func "setregid" (dynamic-link))
- '(int int))))
+ (list int int))))
(lambda (a b)
(rm (f a b)))))
+(define setresgid #f)
(define setresgid
- (let ((f (pointer->procedure 'int
+ (let ((f (pointer->procedure int
(dynamic-func "setresgid" (dynamic-link))
- '(int int int))))
+ (list int int int))))
(lambda (a b c)
(rm (f a b c)))))
-(define setreuid
- (let ((f (pointer->procedure 'int
+(define setreuid #f)
+(defineu setreuid
+ (let ((f (pointer->procedure int
(dynamic-func "setreuid" (dynamic-link))
- '(int int))))
+ (list int int))))
(lambda (a b)
(rm (f a b)))))
-(define setresuid
- (let ((f (pointer->procedure 'int
+(define setresuid #f)
+(defineu setresuid
+ (let ((f (pointer->procedure int
(dynamic-func "setresuid" (dynamic-link))
- '(int int int))))
+ (list int int int))))
(lambda (a b c)
(rm (f a b c)))))
@@ -351,26 +375,25 @@
(guile unsetenv)
;; File descriptor operations
-(define fdopen open)
(define close
(lambda (fd)
- (ca (close-fd fd))))
+ (ca ((@ (guile) close-fdes) fd))))
(define (closerange fd_low fd_high)
- (for ((i : (range low high))) ()
- (try:
+ (for ((i : (range fd_low fd_high))) ()
+ (try
(lambda () (close i))
- (#:except OSError => (lambda (x) (values))))))
+ (#:except OSError => (lambda x (values))))))
(define device_encoding (lambda (fd) (error "not implemented")))
(guile (fd) dup)
(define dup2
- (let ((f (pointer->procedure 'int
+ (let ((f (pointer->procedure int
(dynamic-func "dup3" (dynamic-link))
- '(int int int))))
+ (list int int int))))
(lambda* (fd fd2 #:optional (inheritable? #t))
(if inheritable?
(rm (f fd fd2 O_CLOEXEC))
@@ -400,9 +423,11 @@
((_ 1 (m mm) self scm)
(with-syntax ((mem (concat "st_" #'mm))
(smem (concat "stat:" #'m)))
- #'(set self 'mem (smem scm)))))))
+ #'(set self 'mem (smem scm))))
((_ 1 m self scm)
- (statset 1 (m m) self scm))))
+ #'(statset 1 (m m) self scm)))))
+
+(define stat-float-times #t)
(define-python-class stat_result ()
(define __init__
@@ -433,7 +458,7 @@
(guile (fd) fsynch fsync)
-(guil (fd len) ftruncate truncate-file)
+(guile (fd len) ftruncate truncate-file)
(guile (fd) isatty isatty?)
@@ -441,10 +466,12 @@
(define F_TLOCK 2)
(define F_ULOCK 0)
(define F_TEST 3)
-(define lockf
- (let ((f (pointer->procedure 'int
+
+(define lockf #f)
+(defineu lockf
+ (let ((f (pointer->procedure int
(dynamic-func "lockf" (dynamic-link))
- '(int int long))))
+ (list int int long))))
(lambda (fd op len)
(rm (f fd op len)))))
@@ -456,17 +483,18 @@
(define SEEK_DATA #x3)
(define SEEK_HOLE #x4)
-(define lseek
- (let ((f (pointer->procedure 'int
+(define lseek #f)
+(defineu lseek
+ (let ((f (pointer->procedure int
(dynamic-func "lseek" (dynamic-link))
- '(int long int))))
+ (list int long int))))
(lambda (fd pos how)
(rm (f fd pos how)))))
(define open
- (let ((f (pointer->procedure 'int
+ (let ((f (pointer->procedure int
(dynamic-func "openat" (dynamic-link))
- '(int * int int))))
+ (list int '* int int))))
(lambda* (path flags mode #:optional (dir_fd None))
(if (eq? dir_fd None)
@@ -506,33 +534,38 @@
(define openpty (lambda x (error "not implemented")))
+(define fdopen builtin:open)
+
(define pipe
- (let ((x (ca (@ (guile) pipe))))
+ (let ((x (ca ((@ (guile) pipe)))))
(values (car x) (cdr x))))
-(define pipe2
- (let ((f (pointer->procedure 'int
+(define pipe2 #f)
+(defineu pipe2
+ (let ((f (pointer->procedure int
(dynamic-func "pipe2" (dynamic-link))
- '(int * int))))
+ (list int '* int))))
(lambda (flags)
- (let* ((a (make-bytevector 16))
+ (let* ((a (make-bytevector 8))
(ap (bytevector->pointer a)))
(rm (f ap flags))
(values (bytevector-s32-ref a 0 (native-endianness))
- (bytevector-s32-ref a 1 (native-endianness)))))))
+ (bytevector-s32-ref a 4 (native-endianness)))))))
-(define posix_fallocate
- (let ((f (pointer->procedure 'int
+(define posix_fallocate #f)
+(defineu posix_fallocate
+ (let ((f (pointer->procedure int
(dynamic-func "posix_fallocate" (dynamic-link))
- '(int long long))))
+ (list int long long))))
(lambda (fd off len)
(rm (f fd off len)))))
-(define posix_fadvise
- (let ((f (pointer->procedure 'int
+(define posix_fadvise #f)
+(defineu posix_fadvise
+ (let ((f (pointer->procedure int
(dynamic-func "posix_fadvise" (dynamic-link))
- '(int long long int))))
+ (list int long long int))))
(lambda (fd off len advice)
(rm (f fd off len advice)))))
@@ -543,10 +576,11 @@
(define POSIX_FADV_DONTNEED 4)
(define POSIX_FADV_NOREUSE 5)
-(define pread
- (let ((f (pointer->procedure 'int
+(define pread #f)
+(defineu pread
+ (let ((f (pointer->procedure int
(dynamic-func "pread" (dynamic-link))
- '(int * long long))))
+ (list int '* long long))))
(lambda (fd size offset)
(let* ((a (make-bytevector size))
(ap (bytevector->pointer a)))
@@ -559,19 +593,21 @@
(slot-set! o 'bv a)
o)))))))
-(define pwrite
- (let ((f (pointer->procedure 'int
+(define pwrite #f)
+(defineu pwrite
+ (let ((f (pointer->procedure int
(dynamic-func "pwrite" (dynamic-link))
- '(int * long long))))
+ (list int '* long long))))
(lambda (fd a offset)
- (let* ((ap (bytevector->pointer a)))
- (rm (f fd ap size offset))))))
+ (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes))))
+ (rm (f fd ap (len a) offset))))))
-(define read
- (let ((f (pointer->procedure 'int
+(define read #f)
+(defineu read
+ (let ((f (pointer->procedure int
(dynamic-func "read" (dynamic-link))
- '(int * long))))
+ (list int '* long))))
(lambda (fd size)
(let* ((a (make-bytevector size))
(ap (bytevector->pointer a)))
@@ -584,19 +620,23 @@
(slot-set! o 'bv a)
o)))))))
+
(define (sendfile out in offset count)
(ca
(if (eq? count None)
- ((@ (guile) sendfile out in count))
- ((@ (guile) sendfile out in count offset)))))
+ ((@ (guile) sendfile) out in count)
+ ((@ (guile) sendfile) out in count offset))))
(define F_GETFL 3)
-(define fcntl2 (pointer->procedure 'int
- (dynamic-func "fcntl" (dynamic-link))
- '(int int)))
-(define fcntl3 (pointer->procedure 'int
- (dynamic-func "fcntl" (dynamic-link))
- '(int int INT)))
+
+(define fcntl2 #f)
+(define fcntl3 #f)
+(defineu fcntl2 (pointer->procedure int
+ (dynamic-func "fcntl" (dynamic-link))
+ (list int int)))
+(defineu fcntl3 (pointer->procedure int
+ (dynamic-func "fcntl" (dynamic-link))
+ (list int int int)))
(define (set_blocking fd is-blocking?)
(let ((o (rm (fcntl2 fd F_GETFL))))
@@ -614,14 +654,15 @@
(guile (fd pg) tcsetpgrp)
(guile (fd) ttyname)
-(define write
- (let ((f (pointer->procedure 'int
+(define write #f)
+(defineu write
+ (let ((f (pointer->procedure int
(dynamic-func "write" (dynamic-link))
- '(int * long))))
+ (list int '* long))))
(lambda (fd a)
- (let* ((ap (bytevector->pointer a)))
- (rm (f fd ap size))))))
+ (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes))))
+ (rm (f fd ap (len a)))))))
(define (writev fd buffers) (error "not implemented"))
@@ -647,13 +688,14 @@
(define R_OK (@ (guile) R_OK))
(define X_OK (@ (guile) X_OK))
-(define access
- (let ((f (pointer->procedure 'int
+(define access #f)
+(defineu access
+ (let ((f (pointer->procedure int
(dynamic-func "access" (dynamic-link))
- '(* int)))
- (fa (pointer->procedure 'int
+ (list '* int)))
+ (fa (pointer->procedure int
(dynamic-func "faccessat" (dynamic-link))
- '(* int int int))))
+ (list '* int int int))))
(lambda* (path mode #:key
(dir_fd None)
@@ -666,16 +708,16 @@
(if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))
-
-(define chdir
- (let ((f (pointer->procedure 'int
- (dynamic-func "access" (dynamic-link))
+(define chdir #f)
+(defineu chdir
+ (let ((f (pointer->procedure int
+ (dynamic-func "chdir" (dynamic-link))
'(*))))
(lambda (pth)
(let ((pth (aif it (ref pth '__fspath__)
(it)
pth)))
- (if (int? pth)
+ (if (number? pth)
(rm (f pth))
(ca ((@ (guile) chdir) pth)))))))
@@ -683,18 +725,19 @@
(define chflags
(lambda x (error "Not implemented")))
-(define chmod
- (let ((f (pointer->procedure 'int
+(define chmod (lambda x #f))
+(defineu chmod
+ (let ((f (pointer->procedure int
(dynamic-func "chmod" (dynamic-link))
- '(* int)))
- (ff (pointer->procedure 'int
+ (list '* int)))
+ (ff (pointer->procedure int
(dynamic-func "fchmod" (dynamic-link))
- '(int int)))
- (fat (pointer->procedure 'int
+ (list int int)))
+ (fat (pointer->procedure int
(dynamic-func "fchmodat" (dynamic-link))
- '(* int int int))))
+ (list '* int int int))))
(lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
- (if (int? path)
+ (if (number? path)
(rm (ff path mode))
(let ((path (aif it (ref path '__fspath__)
(it)
@@ -714,21 +757,22 @@
(it)
path))
-(define chown
- (let ((f (pointer->procedure 'int
+(define chown (lambda x #f))
+(defineu chown
+ (let ((f (pointer->procedure int
(dynamic-func "chown" (dynamic-link))
- '(* int int)))
- (ff (pointer->procedure 'int
+ (list '* int int)))
+ (ff (pointer->procedure int
(dynamic-func "fchown" (dynamic-link))
- '(int int int)))
- (lf (pointer->procedure 'int
- (dynamic-func "lchow" (dynamic-link))
- '(* int int)))
- (fat (pointer->procedure 'int
+ (list int int int)))
+ (lf (pointer->procedure int
+ (dynamic-func "lchown" (dynamic-link))
+ (list '* int int)))
+ (fat (pointer->procedure int
(dynamic-func "fchownat" (dynamic-link))
- '(* int int int int))))
+ (list '* int int int int))))
(lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
- (if (int? path)
+ (if (number? path)
(rm (ff path uid gid))
(let ((path (path-it path)))
(if (eq? dir_fd None)
@@ -740,14 +784,14 @@
0
AT_SYMLINK_NOFOLLOW)))))))))
-(guile ((x)) chroot)
+(guile (x) chroot)
(define fchdir chdir)
(guile () getcwd)
(define (getcwdb)
- (byte (getcwd)))
+ (bytes (getcwd)))
(define lchflags (lambda x (error "not implemented")))
@@ -757,13 +801,16 @@
(define (lchown path uid gid)
(chown path uid gid #:follow_symlinks #f))
-(define link
- (let ((f (pointer->procedure 'int
- (dynamic-func "linkat" (dynamic-link))
- '(* * int int int))))
+(define AT_FDCWD -100)
+
+(define link #f)
+(defineu link
+ (let ((f (pointer->procedure int
+ (dynamic-func "linkat" (dynamic-link))
+ (list '* '* int int int))))
(lambda* (src dst #:key
(src_dir_fd None)
- (dst_dir_fd None),
+ (dst_dir_fd None)
(follow_symlinks #t))
(let ((src (path-it src))
(dst (path-it dst))
@@ -786,14 +833,17 @@
(dynamic-wind
(lambda x #f)
(lambda ()
- (let lp ((o ) (l '()))
+ (let lp ((o o))
(let ((w (ca (readdir o))))
(if (eof-object? w)
'()
- (cons w (lp o))))))
+ (if (or (equal? w ".") (equal? w ".."))
+ (lp o)
+ (cons w (lp o)))))))
(lambda x (closedir o)))))))
-(define stat
+(define stat (lambda x #f))
+(defineu stat
(let ((f (pointer->procedure int
(dynamic-func "__fxstatat" (dynamic-link))
(list int int '* '* int)))
@@ -822,10 +872,11 @@
(lambda* (path #:key (dir_fd None))
(stat path #:dir_fd dir_fd #:follow_symlinks #f)))
-(define mkdir
+(define mkdir #f)
+(defineu mkdir
(let ((fat (pointer->procedure int
(dynamic-func "mkdirat" (dynamic-link))
- (list int * int))))
+ (list int '* int))))
(lambda* (path mode #:key (dir_fd None))
(rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
(string->pointer (path-it path))
@@ -854,40 +905,45 @@
(mkdir s mode)))
(lp s l))))))
-(define mkfifo
+(define mkfifo #f)
+(defineu mkfifo
(let ((fat (pointer->procedure int
(dynamic-func "mkfifoat" (dynamic-link))
- (list int * int))))
+ (list int '* int))))
(lambda* (path mode #:key (dir_fd None))
(rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
(string->pointer (path-it path))
mode)))))
-(define mknod
+(define mknod #f)
+(defineu mknod
(let ((fat (pointer->procedure int
- (dynamic-func "mknodat" (dynamic-link))
- (list int * int))))
+ (dynamic-func "__xmknodat" (dynamic-link))
+ (list int int '* int))))
(lambda* (path mode #:optional (device 0) #:key (dir_fd None))
- (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
+ (rm (fat 1 (if (eq? dir_fd None) AT_FDCWD dir_fd)
(string->pointer (path-it path))
mode
device)))))
-(define major
+(define major #f)
+(defineu major
(let ((f (pointer->procedure int
(dynamic-func "gnu_dev_major" (dynamic-link))
(list int64))))
(lambda (device)
(ca (f device)))))
-(define minor
+(define minor #f)
+(defineu minor
(let ((f (pointer->procedure int
(dynamic-func "gnu_dev_minor" (dynamic-link))
(list int64))))
(lambda (device)
(ca (f device)))))
-(define makedev
+(define makedev #f)
+(defineu makedev
(let ((f (pointer->procedure int64
(dynamic-func "gnu_dev_makedev" (dynamic-link))
(list int int))))
@@ -915,8 +971,9 @@
(error "Bug could not find pathcond name endex")
(rm e2))))))
-
-(define pathconf
+
+(define pathconf #f)
+(defineu pathconf
(let ((f (pointer->procedure long
(dynamic-func "pathconf" (dynamic-link))
(list '* int)))
@@ -930,10 +987,11 @@
(let ((path (path-it path)))
(rmp (f (string->pointer path) ni))))))))
-(define readlink
+(define readlink #f)
+(defineu readlink
(let ((fat (pointer->procedure int
(dynamic-func "readlinkat" (dynamic-link))
- (list int * * long))))
+ (list int '* '* long))))
(lambda* (path #:key (dir_fd None))
(let* ((n 10000)
(bv (make-bytevector 10000))
@@ -945,11 +1003,11 @@
(bytevector-u8-set! bv (- n 1) 0)
(pointer->string bvp)))))
-
-(define remove
+(define remove #f)
+(defineu remove
(let ((fat (pointer->procedure int
(dynamic-func "unlinkat" (dynamic-link))
- (list int * int))))
+ (list int '* int))))
(lambda* (path #:key (dir_fd None))
(rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
(string->pointer (path-it path))
@@ -958,7 +1016,7 @@
(define unlink remove)
(define rmdir
- (lambda (path #:key (dir_fd None))
+ (lambda* (path #:key (dir_fd None))
(let ((path (path-it path)))
(if (eq? dir_fd None)
((@ (guile) rmdir) path)
@@ -978,10 +1036,11 @@
(lambda x (values)))
(lp (cdr l)))))))
-(define rename
+(define rename #f)
+(defineu rename
(let ((fat (pointer->procedure int
(dynamic-func "renameat" (dynamic-link))
- (list int * int *))))
+ (list int '* int '*))))
(lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None))
(rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)
(string->pointer (path-it src))
@@ -1009,10 +1068,10 @@
(lp l (cons x d)))
(lp l (cons x d))))))
(rename old new)
- (let ((l (split old #\/)))
+ (let ((l (string-split old #\/)))
(if (> (length l) 1)
(if (= (length l) 2)
- (removedirs (string-concat (car l) "/"))
+ (removedirs (string-append (car l) "/"))
(removedirs (string-join (reverse (cdr (reverse l))) "/")))))
(values)))
@@ -1035,12 +1094,12 @@
(define is_dir
(lambda* (self #:key (follow_symlinks #t))
- (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
+ (let ((s (stat (ref self 'path) #:follow_symlinks follow_symlinks)))
((@ (stat) is-dir?) (ref s '_st_mode)))))
(define is_file
(lambda* (self #:key (follow_symlinks #t))
- (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
+ (let ((s (stat (ref self 'path) #:follow_symlinks follow_symlinks)))
((@ (stat) is-reg?) (ref s '_st_mode)))))
(define is_symlink
@@ -1070,7 +1129,6 @@
#f
(path-it path)))))
-(define stat-float-times #t)
(define (stat_float_times newvalue)
(set! stat-float-times newvalue))
@@ -1105,33 +1163,35 @@
f_namemax)
(list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)))))
-(define statvfs
+(define statvfs #f)
+(defineu statvfs
(let ((f (pointer->procedure int
(dynamic-func "statvfs" (dynamic-link))
- (list * *)))
+ (list '* '*)))
(ff (pointer->procedure int
(dynamic-func "fstatvfs" (dynamic-link))
- (list int *)))))
+ (list int '*))))
(lambda (path)
- (let* ((bv (make-bytevector 11*8))
+ (let* ((bv (make-bytevector (* 11 8)))
(bvp (bytevector->pointer bv)))
(rm (if (number? path)
(ff path bvp)
(f (string->pointer (path-it path)) bvp)))
(StatVFS
- (bytevector-u64-ref bv 0 (native-endianness))
- (bytevector-u64-ref bv 1 (native-endianness))
- (bytevector-u64-ref bv 2 (native-endianness))
- (bytevector-u64-ref bv 3 (native-endianness))
- (bytevector-u64-ref bv 4 (native-endianness))
- (bytevector-u64-ref bv 5 (native-endianness))
- (bytevector-u64-ref bv 6 (native-endianness))
- (bytevector-u64-ref bv 8 (native-endianness))
- (bytevector-u64-ref bv 9 (native-endianness))
- (bytevector-u64-ref bv 10 (native-endianness)))))))
-
-(define symlink
+ (bytevector-u64-ref bv (* 0 8) (native-endianness))
+ (bytevector-u64-ref bv (* 1 8) (native-endianness))
+ (bytevector-u64-ref bv (* 2 8) (native-endianness))
+ (bytevector-u64-ref bv (* 3 8) (native-endianness))
+ (bytevector-u64-ref bv (* 4 8) (native-endianness))
+ (bytevector-u64-ref bv (* 5 8) (native-endianness))
+ (bytevector-u64-ref bv (* 6 8) (native-endianness))
+ (bytevector-u64-ref bv (* 7 8) (native-endianness))
+ (bytevector-u64-ref bv (* 9 8) (native-endianness))
+ (bytevector-u64-ref bv (* 10 8) (native-endianness)))))))
+
+(define symlink #f)
+(defineu symlink
(let ((fat (pointer->procedure int
(dynamic-func "symlinkat" (dynamic-link))
(list '* int '*))))
@@ -1141,7 +1201,8 @@
(if (eq? dir_fd None) AT_FDCWD dir_fd)
(string->pointer (path-it src))))))))
-(define truncate
+(define truncate #f)
+(defineu truncate
(let ((ff (pointer->procedure int
(dynamic-func "ftruncate" (dynamic-link))
(list int long)))
@@ -1156,48 +1217,50 @@
length))))))
(define UTIME_NOW (- (ash 1 30) 1))
-(define utime
+
+(define utime #f)
+(defineu utime
(let ((ff (pointer->procedure int
- (dynamic-func "futimens" (dynamic-link))
- (int '*)))
+ (dynamic-func "futimes" (dynamic-link))
+ (list int '*)))
(fat (pointer->procedure int
- (dynamic-func "futimensat" (dynamic-link))
- (int '* '* int)))
+ (dynamic-func "futimesat" (dynamic-link))
+ (list int '* '* int))))
(lambda* (path #:optional (times None) (ns #f) #:key (dir_fd None)
(follow_symlinks #t))
(let* ((bv (make-bytevector 32))
- (bvp (byteector->pointer bv)))
+ (bvp (bytevector->pointer bv)))
(if (eq? ns None)
(if (eq? times None)
(let ()
- (bytevector-s64-set! bv 0 0
+ (bytevector-s64-set! bv 0 0
(native-endianness))
- (bytevector-s64-set! bv 1 0 UTIME_NOW
+ (bytevector-s64-set! bv 8 UTIME_NOW
(native-endianness))
- (bytevector-s64-set! bv 2 0
+ (bytevector-s64-set! bv 16 0
(native-endianness))
- (bytevector-s64-set! bv 3 UTIME_NOW
+ (bytevector-s64-set! bv 24 UTIME_NOW
(native-endianness)))
(let ((x1 (pylist-ref ns 0))
(x2 (pylist-ref ns 1)))
- (bytevector-s64-set! bv 0 (floor-quotient x1 1000000000)
+ (bytevector-s64-set! bv 0 (floor-quotient x1 1000000000)
(native-endianness))
- (bytevector-s64-set! bv 1 (modulo x1 1000000000)
+ (bytevector-s64-set! bv 8 (modulo x1 1000000000)
(native-endianness))
- (bytevector-s64-set! bv 2 (floor-quotient x2 1000000000)
+ (bytevector-s64-set! bv 16 (floor-quotient x2 1000000000)
(native-endianness))
- (bytevector-s64-set! bv 3 (modulo x2 1000000000)
+ (bytevector-s64-set! bv 24 (modulo x2 1000000000)
(native-endianness))))
(if (eq? times None)
(begin
(bytevector-s64-set! bv 0 (pylist-ref times 0)
(native-endianness))
- (bytevector-s64-set! bv 1 0
+ (bytevector-s64-set! bv 8 0
(native-endianness))
- (bytevector-s64-set! bv 2 (pylist-ref times 1)
+ (bytevector-s64-set! bv 16 (pylist-ref times 1)
(native-endianness))
- (bytevector-s64-set! bv 3 0
+ (bytevector-s64-set! bv 24 0
(native-endianness)))
(raise error "utime cannot set both s and ns")))
(rm (if (number? path)
@@ -1206,10 +1269,10 @@
(string->pointer (path-it path))
(if follow_symlinks
0
- AT_SYMLINK_NOFOLLOW)))))))))
+ AT_SYMLINK_NOFOLLOW))))))))
-(define* (walk top #:key (topdown #t) (onerror None) (followlinks #f))
+(def (walk top (= topdown #t) (= onerror None) (= followlinks #f))
((make-generator ()
(lambda (yield)
(let/ec ret
@@ -1220,13 +1283,13 @@
(try
(lambda ()
(set! entries (py-list (scandir top))))
- (#except error =>
+ (#:except error =>
(lambda (x . _)
(if onerror (onerror x) (ret)))))
(for ((entry : entries)) ()
(define is_dir (try
- (lambda ((ref entry 'is_dir)))
+ (lambda () (ref entry 'is_dir))
(#:except error => (lambda x #f))))
(if is_dir
(pylist-append! dirs (ref entry 'name))
@@ -1240,7 +1303,7 @@
(try
(lambda () ((ref entry 'is_symlink)))
(#:except error => (lambda x #f)))))))
- (if walk_into
+ (if walk-into
(for ((a b c : (walk (ref entry 'path) topdown
onerror followlinks))) ()
(yield a b c)))))
@@ -1288,13 +1351,13 @@
(() (string-join (reverse r) "/")))))
(define (path:join . l)
- (normpath (string-join (map path-it l) "/")))
+ (path:normpath (string-join (map path-it l) "/")))
(define (_fwalk topfd toppath topdown onerror follow_symlinks)
((make-generator ()
(lambda (yield)
(define names (listdir topfd))
- (define dir (py-list))
+ (define dirs (py-list))
(define nondirs (py-list))
(for ((name : names)) ()
@@ -1315,7 +1378,7 @@
(if topdown
(yield toppath dirs nondirs topfd))
-
+
(for continue ((name : dirs)) ()
(call-with-values
(lambda ()
@@ -1324,8 +1387,8 @@
(values (stat name #:dir_fd topfd
#:follow_symlinks follow_symlinks))
(open name O_RDONLY #:dir_fd topfd))
- (#:except errpr =>
- (lambda (err . l)
+ (#:except error =>
+ (lambda (err . l)
(if (not (eq? onerror None))
(onerror err)
(continue))))))
@@ -1337,48 +1400,52 @@
(for ((a b c d :
(_fwalk dirfd dirpath topdown onerror
follow_symlinks))) ()
- (yield a b c d)))))
- (#:finally
- (close dirfd))))))
+ (yield a b c d)))))
+
+ #:finally
+ (close dirfd)))))
(if not topdown
(yield toppath dirs nondirs topfd))))))
-(define* (fwalk #:optinal (top ".") (topdown #t) (onerror #t)
- #:key (follow_symlinks #f) (dir_fd None))
+(def (fwalk (= top ".") (= topdown #t) (= onerror #t)
+ (= follow_symlinks #f) (= dir_fd None))
((make-generator ()
(lambda (yield)
(define orig_st (stat top #:follow_symlinks #f #:dir_fd dir_fd))
(define topfd (open top O_RDONLY #:dir_fd dir_fd))
(try
- (if (or follow_symlinks or (and (S_ISDIR (ref orig_st 'st_mode))
- (path:samestat orig_st (stat topfd))))
- (for ((a b c d : (_fwalk topfd top topdown onerror follow_symlinks)))
- ()
- (yield a b c d)))
- (#:finally:
- (close topfd)))))))
+ (lambda ()
+ (if (or follow_symlinks (and (S_ISDIR (ref orig_st 'st_mode))
+ (path:samestat orig_st (stat topfd))))
+ (for ((a b c d :
+ (_fwalk topfd top topdown onerror follow_symlinks)))
+ ()
+ (yield a b c d))))
+ #:finally
+ (close topfd))))))
;; Extended attributes
-(define getxattr
+(define getxattr #f)
+(defineu getxattr
(let ((f (pointer->procedure int
(dynamic-func "getxattr" (dynamic-link))
- ('* '* '* int)))
+ (list '* '* '* int)))
(lf (pointer->procedure int
(dynamic-func "lgetxattr" (dynamic-link))
- ('* '* '* int)))
+ (list '* '* '* int)))
(ff (pointer->procedure int
(dynamic-func "fgetxattr" (dynamic-link))
- ('* '* '* int))))
- (lambda (path attribute #:key (follow_symlink #t))
+ (list '* '* '* int))))
+ (lambda* (path attribute #:key (follow_symlink #t))
(let ((path (ca (if (number? path)
path
(string->pointer (path-it path)))))
(k (ca (string->pointer attribute))))
(let lp ((size 128))
- (let ((v (make-bytevector size))
- (pv (bytevector->pointer v)))
+ (let* ((v (make-bytevector size))
+ (pv (bytevector->pointer v)))
(let ((n (rm (if (number? path)
(ff path k pv size)
(if follow_symlink
@@ -1388,19 +1455,20 @@
(lp (* 2 size))
(pointer->string pv)))))))))
-(define listxattr
+(define listxattr #f)
+(defineu listxattr
(let ((f (pointer->procedure int
(dynamic-func "listxattr" (dynamic-link))
- ('* '* int)))
+ (list '* '* int)))
(lf (pointer->procedure int
(dynamic-func "llistxattr" (dynamic-link))
- ('* '* int)))
+ (list '* '* int)))
(ff (pointer->procedure int
(dynamic-func "flistxattr" (dynamic-link))
- ('* '* int))))
+ (list '* '* int))))
(define (mk l)
(define v (make-bytevector (+ (length l) 1)))
- (define vp (bytevector->pointer))
+ (define vp (bytevector->pointer v))
(let lp ((i 0) (l l))
(if (pair? l)
(begin
@@ -1410,11 +1478,11 @@
(bytevector-u8-set! v i 0)
(pointer->string vp)))))
- (lambda (path attribute #:key (follow_symlink #t))
+ (lambda* (path attribute #:key (follow_symlink #t))
(let ((path (if (number? path) path (string->pointer (path-it path)))))
(let lp ((size 128))
- (let ((v (make-bytevector size))
- (pv (bytevector->pointer v)))
+ (let* ((v (make-bytevector size))
+ (pv (bytevector->pointer v)))
(let ((n (rm (if (number? path)
(ff path pv size)
(if follow_symlink
@@ -1435,20 +1503,21 @@
(lp2 (+ j 1) (cons x r))))
(if (null? r)
(lp j l)
- (lp j (cons (mk (reverse r) l))))))
- (pylist (reverse l)))))))))))))
+ (lp j (cons (mk (reverse r)) l)))))
+ (pylist (reverse l))))))))))))
-(define removexattr
+(define removexattr #f)
+(defineu removexattr
(let ((f (pointer->procedure int
(dynamic-func "removexattr" (dynamic-link))
- ('* '*)))
+ (list '* '*)))
(lf (pointer->procedure int
(dynamic-func "lremovexattr" (dynamic-link))
- ('* '*)))
+ (list '* '*)))
(ff (pointer->procedure int
(dynamic-func "fremovexattr" (dynamic-link))
- (int '*))))
- (lambda (path attribute #:key (follow_symlink #t))
+ (list int '*))))
+ (lambda* (path attribute #:key (follow_symlink #t))
(let ((path (if (number? path)
path
(string->pointer (path-it path))))
@@ -1459,21 +1528,22 @@
(f path k)
(lf path k))))))))
-(define setxattr
+(define setxattr #f)
+(defineu setxattr
(let ((f (pointer->procedure int
(dynamic-func "setxattr" (dynamic-link))
- ('* '* '* int int)))
+ (list '* '* '* int int)))
(lf (pointer->procedure int
(dynamic-func "lsetxattr" (dynamic-link))
- ('* '* '* int int)))
+ (list '* '* '* int int)))
(ff (pointer->procedure int
(dynamic-func "fsetxattr" (dynamic-link))
- (int '* '* int int))))
- (lambda (path attribute value flags #:key (follow_symlink #t))
- (let ((path (if (number? path) path (string->pointer (path-it path))))
- (val (ca (string->pointer value)))
- (s (string-length val))
- (k (ca (string->pointer attribute))))
+ (list int '* '* int int))))
+ (lambda* (path attribute value flags #:key (follow_symlink #t))
+ (let* ((path (if (number? path) path (string->pointer (path-it path))))
+ (val (ca (string->pointer value)))
+ (s (string-length val))
+ (k (ca (string->pointer attribute))))
(rm (if (number? path)
(ff path k val s flags)
(if follow_symlink
@@ -1487,15 +1557,24 @@
;; Processes
(define (abort) ((@ (guile) raise) (@ (guile) SIGABRT)))
+(define (exists p)
+ (if (number? p)
+ (catch #t
+ (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p)))
+ (lambda x #f))
+ (catch #t
+ (lambda () ((@ (guile) stat) (path-it p)) #t)
+ (lambda x #f))))
+
(define (comp e pth)
(if (eq? (string-ref pth 0) #\/)
pth
- (let ((r (pylist-get e "PATH")))
+ (let ((r (py-get e "PATH")))
(if r
(let lp ((l (string-split r #\:)))
(match l
((pp . l)
- (let ((newpath (join pp p)))
+ (let ((newpath (string-join (cons pp pth) "/")))
(if (exists newpath)
newpath
(lp l))))
@@ -1518,8 +1597,8 @@
(define (execlpe path . args)
(let* ((a (reverse args))
(e (compe (car args)))
- (l (cons e (reverse (cdr args))))))
- (apply (@ (guile) execle) (comp e (path-it path)) l)
+ (l (cons e (reverse (cdr args)))))
+ (apply (@ (guile) execle) (comp e (path-it path)) l)))
(define (execlp path . args) (apply (@ (guile) execlp) (path-it path) args))
@@ -1569,18 +1648,27 @@
(define (nice i) (ca ((@ (guile) nice) i)))
(define killpg
- (let ((f))
+ (let ((f (pointer->procedure int
+ (dynamic-func "killpg" (dynamic-link))
+ (list int int))))
(lambda (pgid sig)
(rm (f pgid sig)))))
(define (plock . l) (error "not implemented"))
-(define DEFAULT_BUFFER_SIZE 4096)
+(define DEFAULT_BUFFER_SIZE (@@ (language python module python)
+ DEFAULT_BUFFER_SIZE))
+
(define* (popen com #:optional (mode "r") (buffering -1))
- (let ((port (ca (open-pipe com (case mode
- (("r") OPEN_READ)
- (("w") OPEN_WRITE)
- (("rw" "wr") OPEN_BOTH))))))
+ (let ((port (ca ((@ (ice-9 popen) open-pipe) com
+ (cond
+ ((equal? mode "r") OPEN_READ)
+ ((equal? mode "w") OPEN_WRITE)
+ ((or (equal? mode "rw")
+ (equal? mode "r+")
+ (equal? mode "w+")
+ (equal? mode "wr"))
+ OPEN_BOTH))))))
(ca
(case buffering
((-1)
@@ -1643,7 +1731,7 @@
(ca (Times ((@ (guile) times)))))
(define (wait)
- (let ((x (wait-pid -1)))
+ (let ((x ((@ (guile) waitpid) -1)))
(list (car x) (cdr x))))
(define-python-class SigInfo ()
@@ -1665,16 +1753,16 @@
(ref self 'si_uid)
(ref self 'si_status)))))
-
-(define waitid
+(define waitid #f)
+(defineu waitid
(let ((f (pointer->procedure int
(dynamic-func "waitid" (dynamic-link))
- (int int '* int))))
+ (list int int '* int))))
(lambda (idtype id options)
(let* ((b (make-bytevector 228))
(vp (bytevector->pointer b))
- (ref (lambda (i) (bytebector-s32-ref
- b i (native-endianess))))
+ (ref (lambda (i) (bytevector-s32-ref
+ b i (native-endianness))))
(si_status (lambda () (ref 6)))
(si_code (lambda () (ref 2)))
(si_pid (lambda () (ref 4)))
@@ -1705,60 +1793,51 @@
(define (waitpid pid options)
(ca ((@ (guile) waitpid) pid options)))
-(define wait3
+(define wait3 #f)
+(defineu wait3
(let ((f (pointer->procedure int
(dynamic-func "wait3" (dynamic-link))
- ('* int '*))))
+ (list '* int '*))))
(lambda (option)
(let* ((v (make-bytevector 250))
(vp (bytevector->pointer v))
- (w (mkae-bytevector 8))
+ (w (make-bytevector 8))
(wp (bytevector->pointer w)))
(let ((pid (rm (f wp option vp))))
(list pid
- (bytevector-s32-ref w 0 (native-endianess))
+ (bytevector-s32-ref w 0 (native-endianness))
(ResUsage v)))))))
-(define wait4
+(define wait4 #f)
+(defineu wait4
(let ((f (pointer->procedure int
(dynamic-func "wait4" (dynamic-link))
- (int '* int '*))))
+ (list int '* int '*))))
(lambda (pid option)
(let* ((v (make-bytevector 250))
(vp (bytevector->pointer v))
- (w (mkae-bytevector 8))
+ (w (make-bytevector 8))
(wp (bytevector->pointer w)))
(let ((pid2 (rm (f pid wp option vp))))
(list pid
- (bytevector-s32-ref w 0 (native-endianess))
+ (bytevector-s32-ref w 0 (native-endianness))
(ResUsage v)))))))
(define __WCOREFLAG #x80)
(define __W_CONTINUED #xffff)
-(define (__WTERMSIG s)
+
(define (WCOREDUMP status) (> (logand status __WCOREFLAG) 0))
(define (WIFCONTINUED status) (= status __W_CONTINUED))
(define (WIFSTOPPED status) (= (logand status #xff) #x7f))
-(define (WIFSIGNALED status) (> (ash (+ (logand status 0x7f) 1) -1) 0))
+(define (WIFSIGNALED status) (> (ash (+ (logand status #x7f) 1) -1) 0))
(define (WIFEXITED status) (= (WTERMSIG status) 0))
(define (WEXITSTATUS status) (ash (logand status #xff00) 8))
(define (WSTOPSIG status) (WEXITSTATUS status))
(define (WTERMSIG status) (logand status #x7f))
-(define supprts_dir_fs
- (set '()))
-
-(define support_effective_ids
- (set '()))
-
-(define supports_fd
- (set '()))
-
-
-
;; Scheduling
(define SCHED_OTHER 0)
@@ -1773,24 +1852,27 @@
(lambda (self v)
(if (bytevector? v)
(set self 'sched_priority
- (bytevector-s32-ref v 0 (native-endianess)))
+ (bytevector-s32-ref v 0 (native-endianness)))
(set self 'sched_priority v)))))
-(define sched_get_priority_min
+(define sched_get_priority_min #f)
+(defineu sched_get_priority_min
(let ((f (pointer->procedure int
(dynamic-func "sched_get_priority_min"
(dynamic-link))
(list int))))
(lambda (policy) (rm (f policy)))))
-(define sched_get_priority_max
+(define sched_get_priority_max #f)
+(defineu sched_get_priority_max
(let ((f (pointer->procedure int
(dynamic-func "sched_get_priority_max"
(dynamic-link))
(list int))))
(lambda (policy) (rm (f policy)))))
-(define sched_setscheduler
+(define sched_setscheduler #f)
+(defineu sched_setscheduler
(let ((f (pointer->procedure int
(dynamic-func "sched_setscheduler"
(dynamic-link))
@@ -1799,10 +1881,11 @@
(let* ((v (make-bytevector 32))
(vp (bytevector->pointer v)))
(bytevector-s32-set! v 0 (ref param 'sched_priority)
- (native-endianess))
+ (native-endianness))
(rm (f pid policy vp))))))
-(define sched_getscheduler
+(define sched_getscheduler #f)
+(defineu sched_getscheduler
(let ((f (pointer->procedure int
(dynamic-func "sched_getscheduler"
(dynamic-link))
@@ -1810,7 +1893,8 @@
(lambda (pid)
(ca (f pid)))))
-(define sched_setparam
+(define sched_setparam #f)
+(defineu sched_setparam
(let ((f (pointer->procedure int
(dynamic-func "sched_setparam"
(dynamic-link))
@@ -1819,10 +1903,11 @@
(let* ((v (make-bytevector 32))
(vp (bytevector->pointer v)))
(bytevector-s32-set! v 0 (ref param 'sched_priority)
- (native-endianess))
+ (native-endianness))
(rm (f pid vp))))))
-(define sched_getparam
+(define sched_getparam #f)
+(defineu sched_getparam
(let ((f (pointer->procedure int
(dynamic-func "sched_getparam"
(dynamic-link))
@@ -1836,44 +1921,56 @@
(define sched_rr_get_intervall
(lambda x (error "not implemented")))
-(define sched_yield
+(define sched_yield #f)
+(defineu sched_yield
(let ((f (pointer->procedure int
(dynamic-func "sched_yield"
(dynamic-link))
(list))))
(lambda () (rm (f)))))
-(define sched_setaffinity
+(define sched_setaffinity#f)
+(defineu sched_setaffinity
(let ((f (pointer->procedure int
(dynamic-func "sched_setaffinity"
(dynamic-link))
(list int int '*)))
(n (/ 1024 64)))
(lambda (pid mask)
- (let* ((v (make-bytecvector (/ 1024 64)))
+ (let* ((v (make-bytevector (/ 1024 64)))
(vp (bytevector->pointer v)))
- (for ((m : mask)) ()
- (bytevector-u64-set! v i m (native-endianess)))
+ (for ((m : mask)) ((i (range 1000)))
+ (bytevector-u64-set! v i (* m 8) (native-endianness)))
(rm (f pid (/ n 8) vp))))))
-(define sched_getaffinity
+(define sched_getaffinity #f)
+(defineu sched_getaffinity
(let ((f (pointer->procedure int
(dynamic-func "sched_getaffinity"
(dynamic-link))
(list int int '*)))
(n (/ 1024 64)))
(lambda (pid)
- (let* ((v (make-bytecvector (/ 1024 64)))
+ (let* ((v (make-bytevector (/ 1024 64)))
(vp (bytevector->pointer v)))
(rm (f pid (/ n 8) vp))
(let lp ((i 0))
(if (< i n)
- (cons (bytevector-u64-ref v i (native-endianess))
+ (cons (bytevector-u64-ref v (* i 8) (native-endianness))
(lp (+ i 1)))
'()))))))
;; MISC SYSTEM INFORMATION
+
+(define supprts_dir_fs
+ (py-set '()))
+
+(define support_effective_ids
+ (py-set '()))
+
+(define supports_fd
+ (py-set '()))
diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm
index 8264fee..093d03e 100644
--- a/modules/language/python/module/python.scm
+++ b/modules/language/python/module/python.scm
@@ -42,13 +42,18 @@
#:export (print repr complex float int str
set all any bin callable reversed
chr classmethod staticmethod
- divmod enumerate filter
+ divmod enumerate filter open
getattr hasattr hex isinstance issubclass
iter map sum id input oct ord pow super
sorted zip))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+(define (path-it path)
+ (aif it (ref path '__fspath__)
+ (it)
+ path))
+
(define print
(case-lambda
(() ((@ (guile) format) #t "~%"))
@@ -246,6 +251,56 @@
(begin
(yield (reverse r))
(lp))))))))))
-
+
+(define DEFAULT_BUFFER_SIZE 4096)
+(def (open path
+ (= mode "r")
+ (= buffering -1 )
+ (= encoding None)
+ (= errors None)
+ (= newline None)
+ (= closefd #t)
+ (= opener None))
+
+ (define modelist (string->list mode))
+ (define path (path-it path))
+ (define (clean ch l)
+ (filter (lambda (c) (not (eq? ch c))) l))
+ (let ((port (if (number? path)
+ (begin
+ (if (member #\a modelist)
+ (seek path 0 SEEK_END))
+ (if (member #\x modelist)
+ (error "cannot use mode 'x' for fd input"))
+ (cond
+ ((member #\r modelist)
+ (fdes->inport path))
+ ((member #\w modelist)
+ (fdes->outport path))))
+ (begin
+ (if (member #\x modelist)
+ (if (file-exists? path)
+ (raise OSError "mode='x' and file exists")
+ (set mode (list->string
+ (clean #\x modelist)))))
+ ((@ (guile) open-file) (path-it path) mode)))))
+
+ (case buffering
+ ((-1)
+ (setvbuf port 'block DEFAULT_BUFFER_SIZE))
+ ((0)
+ (setvbuf port 'none))
+ ((1)
+ (setvbuf port 'line))
+ (else
+ (setvbuf port 'block buffering)))
+
+ port))
+
+
+
+
+
+
diff --git a/modules/language/python/module/resource.scm b/modules/language/python/module/resource.scm
index 200127e..672c1e9 100644
--- a/modules/language/python/module/resource.scm
+++ b/modules/language/python/module/resource.scm
@@ -1,10 +1,11 @@
(define-module (language python module resource)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
+ #:use-module (oop pf-objects)
#:use-module (language python exceptions)
+ #:use-module (language python list)
#:use-module (language python module errno)
#:use-module (language python try)
- #:use-module (language python list)
#:export (RLIM_INFINITY RLIMIT_CORE RLIMIT_CPU RLIMIT_FSIZE RLIMIT_DATA
RLIMIT_STACK RLIMIT_RSS RLIMIT_NPROC RLIMIT_NOFILE
RLIMIT_MEMLOCK RLIMIT_AS RLIMIT_LOCKS
@@ -34,6 +35,15 @@
(raise OSError (pylist-ref errorcode e) ((@ (guile) strerror) e)))))
(values))))
+(define-syntax-rule (defineu f x)
+ (define f
+ (catch #t
+ (lambda () x)
+ (lambda z
+ (let ((message (format #f "could not define ~a" 'f)))
+ (warn message)
+ (lambda z (error message)))))))
+
(define RLIM_INFINITY #xffffffffffffffff)
(define RLIMIT_CORE 4)
@@ -53,59 +63,64 @@
(define RLIMIT_RTTIME 15)
(define RLIMIT_SIGPENDING 11)
-(define getrlimit
+(define getrlimit #f)
+(defineu getrlimit
(let ((f (pointer->procedure int
(dynamic-func "getrlimit" (dynamic-link))
- (int '*))))
+ (list int '*))))
(lambda (resource)
(let* ((v (make-bytevector 16))
(vp (bytevector->pointer v)))
- (rm (f res vp) (EINVAL (raise ValueError "wrong resource")))
- (list (bytevector-u64-ref v 0 (native-endianess))
- (bytevector-u64-ref v 1 (native-endianess)))))))
+ (rm (f resource vp) (EINVAL (raise ValueError "wrong resource")))
+ (list (bytevector-u64-ref v 0 (native-endianness))
+ (bytevector-u64-ref v 8 (native-endianness)))))))
-(define setrlimit
+
+(define setrlimit #f)
+(defineu setrlimit
(let ((f (pointer->procedure int
(dynamic-func "setrlimit" (dynamic-link))
- (int '*))))
+ (list int '*))))
(lambda (resource limits)
(let* ((v (make-bytevector 16))
(vp (bytevector->pointer v)))
- (bytevector-u64-set! v 0 (pylist-ref limits 0) (native-endianess))
- (bytevector-u64-set! v 1 (pylist-ref limits 1) (native-endianess))
+ (bytevector-u64-set! v 0 (pylist-ref limits 0) (native-endianness))
+ (bytevector-u64-set! v 8 (pylist-ref limits 1) (native-endianness))
+
(rm (f resource vp)
(EINVAL (raise ValueError "wrong resource"))
(EPERM (raise ValueError "wrong permission")))
(values)))))
-(define prlimit
+(define prlimit #f)
+(defineu prlimit
(let ((f (pointer->procedure int
(dynamic-func "prlimit" (dynamic-link))
- (int int '* '*))))
+ (list int int '* '*))))
(lambda* (pid resource #:optional (limits None))
- (let ((vnew (make-bytevector 16))
- (vold (make-bytevector 16))
- (vpnew (bytevector->pointer vnew))
- (vpold (bytevector->pointer vold)))
+ (let* ((vnew (make-bytevector 16))
+ (vold (make-bytevector 16))
+ (vpnew (bytevector->pointer vnew))
+ (vpold (bytevector->pointer vold)))
(if (not (equal? limits None))
(begin
(bytevector-u64-set! vnew 0 (pylist-ref limits 0)
- (native-endianess))
- (bytevector-u64-set! vnew 1 (pylist-ref limits 1)
- (native-endianess))))
+ (native-endianness))
+ (bytevector-u64-set! vnew 8 (pylist-ref limits 1)
+ (native-endianness))))
(rm (f pid resource
(if (eq? limits None)
- (adress-pointer 0)
+ (make-pointer 0)
vpnew)
vpold)
(EINVAL (raise ValueError "wrong resource"))
(ESRCH (raise ProcessLookupError "prlimit"))
(EPERM (raise PermissionError "prlimit")))
- (list (bytevector-u64-ref vold 0 (native-endianess))
- (bytevector-u64-ref vold 1 (native-endianess)))))))
+ (list (bytevector-u64-ref vold 0 (native-endianness))
+ (bytevector-u64-ref vold 8 (native-endianness)))))))
+
-
(define RUSAGE_SELF 0)
(define RUSAGE_CHILDREN -1)
(define RUSAGE_BOTH -2)
@@ -116,14 +131,14 @@
(lambda (self v)
(define i 0)
(define-syntax-rule (gettime k)
- (let ((x1 (bytevector-u64-ref v i (native-endianess)))
- (x2 (bytevector-u64-ref v (+ i 1) (native-endianess))))
- (set! i (+ i 2))
+ (let ((x1 (bytevector-u64-ref v i (native-endianness)))
+ (x2 (bytevector-u64-ref v (+ i 8) (native-endianness))))
+ (set! i (+ i (* 8 2)))
(set self k (+ (* x1 1.0) (/ (* x2 1.0) 1000000)))))
(define-syntax-rule (s k)
(begin
- (set self k (bytevector-u64-ref v i (native-endianess)))
- (set! i (+ i 1))))
+ (set self k (bytevector-u64-ref v i (native-endianness)))
+ (set! i (+ i 8))))
(gettime 'ru_utime)
(gettime 'ru_stime)
(s 'ru_maxrss)
@@ -141,23 +156,26 @@
(s 'ru_nvcsw)
(s 'ru_nivcsw))))
-(define getrusage
+(define getrusage #f)
+(defineu getrusage
(let ((f (pointer->procedure int
(dynamic-func "getrusage" (dynamic-link))
- (int '*))))
+ (list int '*))))
(lambda (who)
(let* ((v (make-bytevector 160))
- (vp (bytevector->pointer)))
+ (vp (bytevector->pointer v)))
(rm (f who vp)
(EINVAL (raise ValueError "wrong who in getrusage")))
(ResUsage v)))))
-(define getpagesize
+(define getpagesize #f)
+(defineu getpagesize
(let ((f (pointer->procedure int
(dynamic-func "getpagesize" (dynamic-link))
- ())))
+ '())))
(lambda ()
(rm (f)))))
+
diff --git a/modules/language/python/module/stat.scm b/modules/language/python/module/stat.scm
index a430562..9723f43 100644
--- a/modules/language/python/module/stat.scm
+++ b/modules/language/python/module/stat.scm
@@ -1,4 +1,7 @@
(define-module (language python module stat)
+ #:use-module (language python list)
+ #:use-module (language python string)
+ #:use-module (language python for)
#:export (ST_MODE ST_INO ST_DEV ST_NLINK ST_UID ST_GID ST_SIZE ST_ATIME
ST_MTIME ST_CTIME S_ISUID S_ISGID S_ENFMT S_ISVTX S_IREAD
S_IWRITE S_IEXEC S_IRWXU S_IRUSR S_IWUSR S_IXUSR S_IRGRP
@@ -96,8 +99,8 @@
(,S_ISGID "S")
(,S_IXGRP "x"))
- ((,S_IROTH "r"),)
- ((,S_IWOTH "w"),)
+ ((,S_IROTH "r"))
+ ((,S_IWOTH "w"))
((,(logior S_IXOTH S_ISVTX) "t")
(,S_ISVTX "T")
(,S_IXOTH "x"))))
@@ -109,9 +112,11 @@
(for ((table : _filemode_table)) ()
(for ((bit char : table)) ()
(if (= (logand mode bit) bit)
- (pylist-append! perm char)
- (break))
+ (begin
+ (pylist-append! perm char)
+ (break)))
#:final
(pylist-append! perm "-")))
+ (pk perm)
+ (py-join "" perm))
- (py-string-join "" perm))
diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm
index 25b02d7..6931956 100644
--- a/modules/language/python/set.scm
+++ b/modules/language/python/set.scm
@@ -38,8 +38,10 @@
((self x)
(let ((d (make-py-hashtable)))
(slot-set! self 'dict d)
- (for ((y : x)) ()
- (pylist-set! d y #t))))))
+ (if (eq? x '())
+ (values)
+ (for ((y : x)) ()
+ (pylist-set! d y #t)))))))
(define pop
(lambda (self)