From 2e6a602fbe7d9861a4db114f144ab48f54e35010 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Tue, 20 Mar 2018 19:16:58 +0100 Subject: autocompilation of python source code modules --- modules/language/python/guilemod.scm | 257 +++++++++++++++++++++++++++++++++++ 1 file changed, 257 insertions(+) create mode 100644 modules/language/python/guilemod.scm (limited to 'modules/language/python/guilemod.scm') 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) -- cgit v1.2.3