I'm working on a python implementation in guile and stumble on two issues.
2) I need to silence wanrings of undefined vatiables.
you find the code that is copied to the end of this email.
which is a list of pair where each pairs car is a list of extensions for a land and the cdr is
the name of the language.
guile will understand this information and comile from the correct language. so id we have a faile
Guile will compile from python to bytecode and load it in.
When it comes to sielencing the warnings, maintain the warning list as a fluid of a list by using
Typically in a compile pass one clear the fluid to a null list and for each encounter of a variable the will be falsely warned can be added to this datastructure and we would not see any wanrings. Works for me and is a godsend because else very useful warnings would be drowned in a mass of errornous information.
If you like these features vote it up for inclusion. It would be nice with a well engineered solution in the end, but this hack works pretty well for me.
(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)