diff options
-rw-r--r-- | modules/language/python/compile.scm | 6 | ||||
-rw-r--r-- | modules/language/python/guilemod.scm | 257 | ||||
-rw-r--r-- | modules/language/python/module/os.scm | 171 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 8 |
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 () |