autocompilation of python source code modules

1 files changed, 257 insertions, 0 deletions

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)