Merge branch 'master' of https://gitlab.com/python-on-guile/python-on-guile

4 files changed, 364 insertions, 78 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 3e7a95a..dad7656 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -46,16 +46,16 @@
   (lambda (x)
     (catch #t
       (lambda ()
-	(set! (@@ (system base message) %dont-warn-list) '()))
+	(fluid-set! (@@ (system base message) %dont-warn-list) '()))
       (lambda x (pre)))
     #f))
 
 (define (dont-warn v)
   (catch #t
     (lambda ()
-      (set! (@@ (system base message) %dont-warn-list)
+      (fluid-set! (@@ (system base message) %dont-warn-list)
 	    (cons v
-		  (@@ (system base message) %dont-warn-list))))
+		  (fluid-ref (@@ (system base message) %dont-warn-list)))))
     (lambda x (values))))
 
 (define *prefixes* (make-fluid '()))
diff --git a/modules/language/python/guilemod.scm b/modules/language/python/guilemod.scm
new file mode 100644
index 0000000..3f7ec7f
--- /dev/null
+++ b/modules/language/python/guilemod.scm
@@ -0,0 +1,257 @@
+(define-module (language python guilemod)
+  #:export ())
+
+(define-syntax-rule (mk-commands path mod-C define-C define-exp-C define-set-C)
+  (begin
+    (define mod-C (resolve-module 'path))
+    (define-syntax-rule (define-C f val)
+      (begin
+        (define f val)
+        (module-define! mod-C 'f f)))
+
+    (define-syntax-rule (define-exp-C f val)
+      (begin
+        (define f val)
+        (module-define! mod-C 'f val)
+        (module-export! mod-C (list 'f))))
+
+    (define-syntax-rule (define-set-C f val)
+      (module-set! mod-C 'f (let ((x val)) x)))))
+
+(mk-commands (system base compile) mod-C define-C define-exp-C define-set-C)
+(mk-commands (system base message) mod-M define-M define-exp-M define-set-M)
+(mk-commands (guile)               mod-G define-G define-exp-G define-set-G)
+(define-syntax-rule (C x) (@@ (system base compile) x))
+(define-syntax-rule (M x) (@@ (system base message) x))
+
+(define-exp-C *do-extension-dispatch* #t)
+(define-exp-C *extension-dispatches*  '((("py" "python") . python)
+                                        (("pl" "prolog") . prolog)))
+
+(define-C default-language
+  (lambda (file)
+    (define default ((C current-language)))
+    (if (C *do-extension-dispatch*)
+        (let ((ext (car (reverse (string-split file #\.)))))
+          (let lp ((l (C *extension-dispatches*)))
+            (if (pair? l)
+                (if (member ext (caar l))
+                    (let ((r (cdar l)))
+                      (if ((C language?) default)
+                          (if (eq? ((C language-name) default) r)
+                              default
+                              r)
+                          r))
+                    (lp (cdr l)))
+                default)))
+        default)))
+
+
+(define-exp-C %in-compile (make-fluid #f))
+
+(define-set-C compile-file
+  (lambda* (file #:key
+                 (output-file      #f)
+                 (from             ((C default-language)   file))
+                 (to               'bytecode)
+                 (env              ((C default-environment) from))
+                 (opts             '())
+                 (canonicalization 'relative))
+    (with-fluids (((C %in-compile                     )   #t               )
+                  ((M %dont-warn-list                 )   '()              )
+                  ((C %file-port-name-canonicalization)   canonicalization))
+      (let* ((comp (or output-file ((C compiled-file-name) file)
+                       (error "failed to create path for auto-compiled file"
+                              file)))
+             (in  ((C open-input-file) file))
+             (enc ((C file-encoding)   in)))
+        ;; Choose the input encoding deterministically.
+        ((C set-port-encoding!) in (or enc "UTF-8"))
+        
+        ((C ensure-directory) ((C dirname) comp))
+        ((C call-with-output-file/atomic) comp
+         (lambda (port)
+           (((C language-printer) ((C ensure-language) to))
+            ((C read-and-compile)
+             in #:env env #:from from #:to to #:opts
+             (cons* #:to-file? #t opts))
+            port))
+         file)
+        comp))))
+
+;; MESSAGE (Mute some variable warnings)
+(define-exp-M %add-to-warn-list
+  (lambda (sym)
+    (fluid-set! (M %dont-warn-list)
+                (cons sym (fluid-ref (M %dont-warn-list))))))
+
+(define-exp-M %dont-warn-list (make-fluid '()))
+(define-set-M %warning-types
+  ;; List of known warning types.
+  (map (lambda (args)
+         (apply (M make-warning-type) args))
+
+       (let-syntax ((emit
+                     (lambda (s)
+                       (syntax-case s ()
+                         ((_ port fmt args ...)
+                          (string? (syntax->datum #'fmt))
+                          (with-syntax ((fmt
+                                         (string-append "~a"
+                                                        (syntax->datum
+                                                         #'fmt))))
+                            #'(format port fmt
+                                      (fluid-ref (M *current-warning-prefix*))
+                                      args ...)))))))
+         `((unsupported-warning ;; a "meta warning"
+            "warn about unknown warning types"
+            ,(lambda (port unused name)
+               (emit port "warning: unknown warning type `~A'~%"
+                name)))
+
+           (unused-variable
+            "report unused variables"
+            ,(lambda (port loc name)
+               (emit port "~A: warning: unused variable `~A'~%"
+                loc name)))
+
+           (unused-toplevel
+            "report unused local top-level variables"
+            ,(lambda (port loc name)
+               (emit port
+                "~A: warning: possibly unused local top-level variable `~A'~%"
+                loc name)))
+
+           (unbound-variable
+            "report possibly unbound variables"
+            ,(lambda (port loc name)
+               (if (not (member name (fluid-ref (M %dont-warn-list))))
+                   (emit port
+                    "~A: warning: possibly unbound variable `~A'~%"
+                    loc name))))
+
+           (macro-use-before-definition
+            "report possibly mis-use of macros before they are defined"
+            ,(lambda (port loc name)
+               (emit port
+                "~A: warning: macro `~A' used before definition~%"
+                loc name)))
+
+           (arity-mismatch
+            "report procedure arity mismatches (wrong number of arguments)"
+            ,(lambda (port loc name certain?)
+               (if certain?
+                   (emit port
+                    "~A: warning: wrong number of arguments to `~A'~%"
+                    loc name)
+                   (emit port
+                    "~A: warning: possibly wrong number of arguments to `~A'~%"
+                    loc name))))
+           
+           (duplicate-case-datum
+            "report a duplicate datum in a case expression"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%"
+                loc datum clause case-expr)))
+
+           (bad-case-datum
+            "report a case datum that cannot be meaningfully compared using `eqv?'"
+            ,(lambda (port loc datum clause case-expr)
+               (emit port
+                "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
+                loc datum clause case-expr)))
+
+           (format
+            "report wrong number of arguments to `format'"
+            ,(lambda (port loc . rest)
+               (define (escape-newlines str)
+                 (list->string
+                  (string-fold-right (lambda (c r)
+                                       (if (eq? c #\newline)
+                                           (append '(#\\ #\n) r)
+                                           (cons c r)))
+                                     '()
+                                     str)))
+
+               (define (range min max)
+                 (cond ((eq? min 'any)
+                        (if (eq? max 'any)
+                            "any number" ;; can't happen
+                            (emit #f "up to ~a" max)))
+                       ((eq? max 'any)
+                        (emit #f "at least ~a" min))
+                       ((= min max) (number->string min))
+                       (else
+                        (emit #f "~a to ~a" min max))))
+
+               ((M match) rest
+                 (('simple-format fmt opt)
+                  (emit port
+                   "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%"
+                   loc (escape-newlines fmt) opt))
+                 (('wrong-format-arg-count fmt min max actual)
+                  (emit port
+                   "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
+                   loc (escape-newlines fmt)
+                   (range min max) actual))
+                 (('syntax-error 'unterminated-iteration fmt)
+                  (emit port "~A: warning: ~S: unterminated iteration~%"
+                   loc (escape-newlines fmt)))
+                 (('syntax-error 'unterminated-conditional fmt)
+                  (emit port "~A: warning: ~S: unterminated conditional~%"
+                   loc (escape-newlines fmt)))
+                 (('syntax-error 'unexpected-semicolon fmt)
+                  (emit port "~A: warning: ~S: unexpected `~~;'~%"
+                   loc (escape-newlines fmt)))
+                 (('syntax-error 'unexpected-conditional-termination fmt)
+                  (emit port "~A: warning: ~S: unexpected `~~]'~%"
+                   loc (escape-newlines fmt)))
+                 (('wrong-port wrong-port)
+                  (emit port
+                   "~A: warning: ~S: wrong port argument~%"
+                   loc wrong-port))
+                 (('wrong-format-string fmt)
+                  (emit port
+                   "~A: warning: ~S: wrong format string~%"
+                        loc fmt))
+                 (('non-literal-format-string)
+                  (emit port
+                   "~A: warning: non-literal format string~%"
+                   loc))
+                 (('wrong-num-args count)
+                  (emit port
+                   "~A: warning: wrong number of arguments to `format'~%"
+                   loc))
+                 (else
+                  (emit port "~A: `format' warning~%" loc)))))))))
+
+
+
+(define pload
+  (let ((guile-load (@ (guile) primitive-load-path)))
+    (lambda (p . q)
+      (let ((tag (make-prompt-tag)))
+        (call-with-prompt
+         tag
+         (lambda ()
+           (guile-load p (lambda () (abort-to-prompt tag))))
+         (lambda (k)
+           (let lp ((l *extension-dispatches*))
+             (if (pair? l)
+                 (let lp2 ((u (caar l)))
+                   (if (pair? u)
+                       (let ((tag (make-prompt-tag)))
+                         (call-with-prompt
+                          tag
+                          (lambda ()
+                            (guile-load (string-append p "." (car u))
+                                        (lambda () (abort-to-prompt tag))))
+                          (lambda (k) (lp2 (cdr u)))))
+                       (lp (cdr l))))))
+           (if (pair? q)
+               ((car q))
+               (error (string-append "no code for path " p)))))))))
+
+
+(define-set-G primitive-load-path pload)
diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm
index 6639b1d..3d8b852 100644
--- a/modules/language/python/module/os.scm
+++ b/modules/language/python/module/os.scm
@@ -82,9 +82,19 @@
                   sched_setscheduler sched_getscheduler sched_setparam
                   sched_getparam sched_rr_get_intervall sched_yield
                   sched_setaffinity sched_getaffinity
-                  
+
+                  supports_dir_fs support_effective_ids supports_fd
                   ))
 
+(define supports_dir_fs
+  (py-set '()))
+
+(define support_effective_ids
+  (py-set '()))
+
+(define supports_fd
+  (py-set '()))
+
 (define error OSError)
 (define errno
   (let ((f (dynamic-pointer "errno" (dynamic-link))))
@@ -102,14 +112,36 @@
         (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 (py-add s x)
+  ((ref s 'add) x))
+
+(define-syntax reg
+  (syntax-rules ()
+    ((_ () f)
+     (values))
+    ((_ (0 . l) f)
+     (begin
+       (py-add supports_dir_fs (symbol->string 'f))
+       (reg l f)))
+    ((_ (1 . l) f)
+     (begin
+       (py-add support_effective_ids (symbol->string 'f))
+       (reg l f)))
+    ((_ (2 . l) f)
+     (begin
+       (py-add supports_fd (symbol->string 'f))
+       (reg l f)))))
+
+(define-syntax-rule (defineu f a x)
+  (begin
+    (define f
+      (catch #t
+        (lambda () x)
+        (lambda z
+          (let ((message (format #f "could not define ~a" 'f)))
+            (warn message)
+            (lambda z (error message))))))
+    (reg a f)))
 
 (define-syntax guile
   (syntax-rules ()
@@ -284,7 +316,7 @@
 (guile getpriority)
 
 (define getresgid #f)
-(defineu getresgid
+(defineu getresgid ()
   (let* ((f  (pointer->procedure
               void
               (dynamic-func "getresgid" (dynamic-link))
@@ -306,7 +338,7 @@
 (guile getuid)
 
 (define initgroups #f)
-(defineu initgroups
+(defineu initgroups ()
   (let ((f (pointer->procedure
             int
             (dynamic-func "initgroups" (dynamic-link))
@@ -324,7 +356,7 @@
 
 (guile setgroups)
 (define setpgrp #f)
-(defineu setpgrp
+(defineu setpgrp ()
   (let ((f (pointer->procedure int
                                (dynamic-func "setpgrp" (dynamic-link))
                                '())))
@@ -351,7 +383,7 @@
       (rm (f a b c)))))
 
 (define setreuid #f)
-(defineu setreuid
+(defineu setreuid ()
   (let ((f (pointer->procedure int
                                (dynamic-func "setreuid" (dynamic-link))
                                (list int int))))
@@ -359,7 +391,7 @@
       (rm (f a b)))))
 
 (define setresuid #f)
-(defineu setresuid
+(defineu setresuid ()
   (let ((f (pointer->procedure int
                                (dynamic-func "setresuid" (dynamic-link))
                                (list int int int))))
@@ -468,7 +500,7 @@
 (define F_TEST  3)
 
 (define lockf #f)
-(defineu lockf
+(defineu lockf (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "lockf" (dynamic-link))
                                (list int int long))))
@@ -484,7 +516,7 @@
 (define SEEK_HOLE #x4)
 
 (define lseek  #f)
-(defineu lseek 
+(defineu lseek (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "lseek" (dynamic-link))
                                (list int long int))))
@@ -541,7 +573,7 @@
     (values (car x) (cdr x))))
 
 (define pipe2 #f)
-(defineu pipe2
+(defineu pipe2 ()
   (let ((f (pointer->procedure int
                                (dynamic-func "pipe2" (dynamic-link))
                                (list int '* int))))
@@ -554,7 +586,7 @@
 
 
 (define posix_fallocate #f)
-(defineu posix_fallocate
+(defineu posix_fallocate (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "posix_fallocate" (dynamic-link))
                                (list int long long))))
@@ -562,7 +594,7 @@
       (rm (f fd off len)))))
 
 (define posix_fadvise #f)
-(defineu posix_fadvise
+(defineu posix_fadvise (2)
    (let ((f (pointer->procedure int
                                (dynamic-func "posix_fadvise" (dynamic-link))
                                (list int long long int))))
@@ -577,7 +609,7 @@
 (define POSIX_FADV_NOREUSE    5)
 
 (define pread #f)
-(defineu pread
+(defineu pread (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "pread" (dynamic-link))
                                (list int '* long long))))
@@ -594,7 +626,7 @@
                 o)))))))
 
 (define pwrite #f)
-(defineu pwrite
+(defineu pwrite (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "pwrite" (dynamic-link))
                                (list int '* long long))))
@@ -604,7 +636,7 @@
         (rm (f fd ap (len a) offset))))))
 
 (define read #f)
-(defineu read
+(defineu read (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "read" (dynamic-link))
                                (list int '* long))))
@@ -631,12 +663,12 @@
 
 (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)))
+(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))))
@@ -655,7 +687,7 @@
 (guile (fd)    ttyname)
 
 (define write #f)
-(defineu write
+(defineu write (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "write" (dynamic-link))
                                (list int '* long))))
@@ -689,7 +721,7 @@
 (define X_OK (@ (guile) X_OK))
 
 (define access #f)
-(defineu access
+(defineu access (0 1)
   (let ((f  (pointer->procedure int
                                (dynamic-func "access" (dynamic-link))
                                (list '* int)))
@@ -709,7 +741,7 @@
 
 
 (define chdir #f)
-(defineu chdir
+(defineu chdir (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "chdir" (dynamic-link))
                                '(*))))
@@ -726,7 +758,7 @@
   (lambda x (error "Not implemented")))
 
 (define chmod (lambda x #f))
-(defineu chmod
+(defineu chmod (0 2)
   (let ((f   (pointer->procedure int
                                  (dynamic-func "chmod" (dynamic-link))
                                  (list '* int)))
@@ -758,7 +790,7 @@
        path))
 
 (define chown (lambda x #f))
-(defineu chown
+(defineu chown (0 2)
   (let ((f   (pointer->procedure int
                                  (dynamic-func "chown" (dynamic-link))
                                  (list '* int int)))
@@ -804,7 +836,7 @@
 (define AT_FDCWD -100)
 
 (define link #f)
-(defineu link
+(defineu link (0)
   (let ((f (pointer->procedure int
                                (dynamic-func "linkat" (dynamic-link))
                                  (list '* '* int int int))))
@@ -843,7 +875,7 @@
           (lambda x (closedir o)))))))
 
 (define stat (lambda x #f))
-(defineu stat
+(defineu stat (0 2)
   (let ((f (pointer->procedure int
                                (dynamic-func "__fxstatat" (dynamic-link))
                                (list int int '* '* int)))
@@ -873,7 +905,7 @@
     (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
 
 (define mkdir #f)
-(defineu mkdir
+(defineu mkdir (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "mkdirat" (dynamic-link))
                                  (list int '* int))))
@@ -906,7 +938,7 @@
          (lp s l))))))
 
 (define mkfifo #f)
-(defineu mkfifo
+(defineu mkfifo (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "mkfifoat" (dynamic-link))
                                  (list int '* int))))
@@ -916,7 +948,7 @@
                mode)))))
 
 (define mknod #f)
-(defineu mknod
+(defineu mknod (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "__xmknodat" (dynamic-link))
                                  (list int int '* int))))
@@ -927,7 +959,7 @@
                device)))))
 
 (define major #f)
-(defineu major
+(defineu major ()
   (let ((f (pointer->procedure int
                                (dynamic-func "gnu_dev_major" (dynamic-link))
                                (list int64))))
@@ -935,7 +967,7 @@
       (ca (f device)))))
 
 (define minor #f)
-(defineu minor
+(defineu minor ()
   (let ((f (pointer->procedure int
                                (dynamic-func "gnu_dev_minor" (dynamic-link))
                                (list int64))))
@@ -943,7 +975,7 @@
       (ca (f device)))))
 
 (define makedev #f)
-(defineu makedev
+(defineu makedev ()
   (let ((f (pointer->procedure int64
                                (dynamic-func "gnu_dev_makedev" (dynamic-link))
                                (list int int))))
@@ -973,7 +1005,7 @@
 
 
 (define pathconf #f)
-(defineu pathconf
+(defineu pathconf (2)
   (let ((f (pointer->procedure long
                                (dynamic-func "pathconf" (dynamic-link))
                                (list '* int)))
@@ -988,7 +1020,7 @@
               (rmp (f (string->pointer path) ni))))))))
 
 (define readlink #f)
-(defineu readlink
+(defineu readlink (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "readlinkat" (dynamic-link))
                                  (list int '* '* long))))
@@ -1004,7 +1036,7 @@
         (pointer->string bvp)))))
 
 (define remove #f)
-(defineu remove
+(defineu remove (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "unlinkat" (dynamic-link))
                                  (list int '* int))))
@@ -1037,7 +1069,7 @@
             (lp (cdr l)))))))
 
 (define rename #f)
-(defineu rename
+(defineu rename (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "renameat" (dynamic-link))
                                  (list int '* int '*))))
@@ -1164,7 +1196,7 @@
        (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)))))
 
 (define statvfs #f)
-(defineu statvfs
+(defineu statvfs (2)
   (let ((f (pointer->procedure int
                                (dynamic-func "statvfs" (dynamic-link))
                                (list '* '*)))
@@ -1191,7 +1223,7 @@
          (bytevector-u64-ref bv (* 10 8) (native-endianness)))))))
 
 (define symlink #f)
-(defineu symlink
+(defineu symlink (0)
   (let ((fat (pointer->procedure int
                                  (dynamic-func "symlinkat" (dynamic-link))
                                  (list '* int '*))))
@@ -1202,7 +1234,7 @@
                 (string->pointer (path-it src))))))))
 
 (define truncate #f)
-(defineu truncate
+(defineu truncate (2)
   (let ((ff (pointer->procedure int
                                 (dynamic-func "ftruncate" (dynamic-link))
                                 (list int long)))
@@ -1219,7 +1251,7 @@
 (define UTIME_NOW (- (ash 1 30) 1))
 
 (define utime #f)
-(defineu utime
+(defineu utime (0 2)
   (let ((ff  (pointer->procedure int
                                  (dynamic-func "futimes" (dynamic-link))
                                  (list int '*)))
@@ -1428,7 +1460,7 @@
 
 ;; Extended attributes
 (define getxattr #f)
-(defineu getxattr
+(defineu getxattr (2)
   (let ((f   (pointer->procedure int
                                 (dynamic-func "getxattr" (dynamic-link))
                                 (list '* '* '* int)))
@@ -1456,7 +1488,7 @@
                    (pointer->string pv)))))))))
 
 (define listxattr #f)
-(defineu listxattr
+(defineu listxattr (2)
   (let ((f  (pointer->procedure int
                                 (dynamic-func "listxattr" (dynamic-link))
                                 (list '* '* int)))
@@ -1507,7 +1539,7 @@
                         (pylist (reverse l))))))))))))
 
 (define removexattr #f)
-(defineu removexattr
+(defineu removexattr (2)
   (let ((f  (pointer->procedure int
                                 (dynamic-func "removexattr" (dynamic-link))
                                 (list '* '*)))
@@ -1529,7 +1561,7 @@
                     (lf path k))))))))
 
 (define setxattr #f)
-(defineu setxattr
+(defineu setxattr (2)
   (let ((f  (pointer->procedure int
                                 (dynamic-func "setxattr" (dynamic-link))
                                 (list '* '* '* int int)))
@@ -1754,7 +1786,7 @@
               (ref self 'si_status)))))
       
 (define waitid #f)
-(defineu waitid
+(defineu waitid ()
   (let ((f (pointer->procedure int
                                 (dynamic-func "waitid" (dynamic-link))
                                 (list int int '* int))))
@@ -1794,7 +1826,7 @@
   (ca ((@ (guile) waitpid) pid options)))
 
 (define wait3 #f)
-(defineu wait3
+(defineu wait3 ()
   (let ((f (pointer->procedure int
                                 (dynamic-func "wait3" (dynamic-link))
                                 (list '* int '*))))
@@ -1810,7 +1842,7 @@
                 (ResUsage v)))))))
 
 (define wait4 #f)
-(defineu wait4
+(defineu wait4 ()
   (let ((f (pointer->procedure int
                                (dynamic-func "wait4" (dynamic-link))
                                (list int '* int '*))))
@@ -1856,7 +1888,7 @@
           (set self 'sched_priority v)))))
 
 (define sched_get_priority_min #f)
-(defineu sched_get_priority_min
+(defineu sched_get_priority_min ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_get_priority_min"
                                              (dynamic-link))
@@ -1864,7 +1896,7 @@
     (lambda (policy) (rm (f policy)))))
 
 (define sched_get_priority_max #f)
-(defineu sched_get_priority_max
+(defineu sched_get_priority_max ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_get_priority_max"
                                              (dynamic-link))
@@ -1872,7 +1904,7 @@
     (lambda (policy) (rm (f policy)))))
 
 (define sched_setscheduler #f)
-(defineu sched_setscheduler
+(defineu sched_setscheduler ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_setscheduler"
                                              (dynamic-link))
@@ -1885,7 +1917,7 @@
         (rm (f pid policy vp))))))
 
 (define sched_getscheduler #f)
-(defineu sched_getscheduler
+(defineu sched_getscheduler ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_getscheduler"
                                              (dynamic-link))
@@ -1894,7 +1926,7 @@
       (ca (f pid)))))
 
 (define sched_setparam #f)
-(defineu sched_setparam
+(defineu sched_setparam ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_setparam"
                                              (dynamic-link))
@@ -1907,7 +1939,7 @@
         (rm (f pid vp))))))
 
 (define sched_getparam #f)
-(defineu sched_getparam
+(defineu sched_getparam ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_getparam"
                                              (dynamic-link))
@@ -1922,7 +1954,7 @@
   (lambda x (error "not implemented")))
 
 (define sched_yield #f)
-(defineu sched_yield
+(defineu sched_yield ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_yield"
                                              (dynamic-link))
@@ -1930,7 +1962,7 @@
     (lambda () (rm (f)))))
 
 (define sched_setaffinity#f)
-(defineu sched_setaffinity
+(defineu sched_setaffinity ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_setaffinity"
                                              (dynamic-link))
@@ -1946,7 +1978,7 @@
         (rm (f pid (/ n 8) vp))))))
 
 (define sched_getaffinity #f)
-(defineu sched_getaffinity
+(defineu sched_getaffinity ()
   (let ((f (pointer->procedure int
                                (dynamic-func "sched_getaffinity"
                                              (dynamic-link))
@@ -1965,12 +1997,3 @@
               
 
 ;; MISC SYSTEM INFORMATION
-
-(define supprts_dir_fs
-  (py-set '()))
-
-(define support_effective_ids
-  (py-set '()))
-
-(define supports_fd
-  (py-set '()))
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 3633865..0418a5f 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -2,6 +2,8 @@
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:use-module (system base message)
+  #:use-module (language python guilemod)
   #:use-module (ice-9 pretty-print)
   #:use-module (logic guile-log persistance)
   #:replace (equal?)  
@@ -752,6 +754,9 @@ explicitly tell it to not update etc.
 			       (symbol->string
 				(syntax->datum #'name))
 			       "-goops-class")))))
+         (%add-to-warn-list (syntax->datum #'nname))
+         (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
+              #'(ddname ...))
 	#'(let ()
 	    (define name 
 	      (letruc ((dname dval) ...)
@@ -769,7 +774,7 @@ explicitly tell it to not update etc.
 
 	    (module-define! (current-module) 'nname (ref name '__goops__))
 	    (name-object nname)
-	    
+	    (name-object name)
 	    name))))))
 
 (define-syntax-rule (def-p-class name . l)
@@ -826,6 +831,7 @@ explicitly tell it to not update etc.
 (define-syntax-rule (define-python-class name (parents ...) code ...)
   (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
 
+
 (define-syntax make-python-class
   (lambda (x)
     (syntax-case x ()