diff options
Diffstat (limited to 'modules/language')
-rw-r--r-- | modules/language/python/for.scm | 39 | ||||
-rw-r--r-- | modules/language/python/module/errno.scm | 11 | ||||
-rw-r--r-- | modules/language/python/module/os.scm | 671 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 59 | ||||
-rw-r--r-- | modules/language/python/module/resource.scm | 84 | ||||
-rw-r--r-- | modules/language/python/module/stat.scm | 15 | ||||
-rw-r--r-- | modules/language/python/set.scm | 6 |
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) |