(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-exp-C %current-file% (make-fluid '(guile))) (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 ) ((C %current-file% ) file)) (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)