fix bug in guile-mod
[software/python-on-guile.git] / modules / language / python / guilemod.scm
1 (define-module (language python guilemod)
2 #:export ())
3
4 (define-syntax-rule (aif it p . l) (let ((it p)) (if it . l)))
5
6 (define-syntax-rule (mk-commands path mod-C define-C define-exp-C define-set-C)
7 (begin
8 (define mod-C (resolve-module 'path))
9 (define-syntax-rule (define-C f val)
10 (begin
11 (define f val)
12 (module-define! mod-C 'f f)))
13
14 (define-syntax-rule (define-exp-C f val)
15 (begin
16 (define f val)
17 (module-define! mod-C 'f val)
18 (module-export! mod-C (list 'f))))
19
20 (define-syntax-rule (define-set-C f val)
21 (module-set! mod-C 'f (let ((x val)) x)))))
22
23 (mk-commands (system base compile) mod-C define-C define-exp-C define-set-C)
24 (mk-commands (system base message) mod-M define-M define-exp-M define-set-M)
25 (mk-commands (guile) mod-G define-G define-exp-G define-set-G)
26 (define-syntax-rule (C x) (@@ (system base compile) x))
27 (define-syntax-rule (M x) (@@ (system base message) x))
28
29 (define-exp-C *do-extension-dispatch* #t)
30 (define-exp-C *extension-dispatches* '((("py" "python") . python)
31 (("pl" "prolog") . prolog)
32 (("plb" "prolog-boot") . prolog-boot)))
33
34 (define-exp-C %current-file% (make-fluid '(guile)))
35
36 (define-C default-language
37 (lambda (file)
38 (define default ((C current-language)))
39 (pk file)
40 (pk
41 (if (C *do-extension-dispatch*)
42 (let ((ext (car (reverse (string-split file #\.)))))
43 (let lp ((l (C *extension-dispatches*)))
44 (if (pair? l)
45 (if (member ext (caar l))
46 (let ((r (cdar l)))
47 (if ((C language?) default)
48 (if (eq? ((C language-name) default) r)
49 default
50 r)
51 r))
52 (lp (cdr l)))
53 default)))
54 default))))
55
56
57 (define-exp-C %in-compile (make-fluid #f))
58
59 (define-set-C compile-file
60 (lambda* (file #:key
61 (output-file #f)
62 (from ((C default-language) file))
63 (to 'bytecode)
64 (env ((C default-environment) from))
65 (opts '())
66 (canonicalization 'relative))
67
68 (with-fluids (((C %in-compile ) #t )
69 ((M %dont-warn-list ) '() )
70 ((C %file-port-name-canonicalization) canonicalization )
71 ((C %current-file% ) file))
72
73 (let* ((comp (or output-file ((C compiled-file-name) file)
74 (error "failed to create path for auto-compiled file"
75 file)))
76 (in ((C open-input-file) file))
77 (enc ((C file-encoding) in)))
78 ;; Choose the input encoding deterministically.
79 ((C set-port-encoding!) in (or enc "UTF-8"))
80
81 ((C ensure-directory) ((C dirname) comp))
82 ((C call-with-output-file/atomic) comp
83 (lambda (port)
84 (((C language-printer) ((C ensure-language) to))
85 ((C read-and-compile)
86 in #:env env #:from from #:to to #:opts
87 (cons* #:to-file? #t opts))
88 port))
89 file)
90 comp))))
91
92 ;; MESSAGE (Mute some variable warnings)
93 (define-exp-M %add-to-warn-list
94 (lambda (sym)
95 (fluid-set! (M %dont-warn-list)
96 (cons sym (fluid-ref (M %dont-warn-list))))))
97
98 (define-exp-M %dont-warn-list (make-fluid '()))
99 (define-set-M %warning-types
100 ;; List of known warning types.
101 (map (lambda (args)
102 (apply (M make-warning-type) args))
103
104 (let-syntax ((emit
105 (lambda (s)
106 (syntax-case s ()
107 ((_ port fmt args ...)
108 (string? (syntax->datum #'fmt))
109 (with-syntax ((fmt
110 (string-append "~a"
111 (syntax->datum
112 #'fmt))))
113 #'(format port fmt
114 (fluid-ref (M *current-warning-prefix*))
115 args ...)))))))
116 `((unsupported-warning ;; a "meta warning"
117 "warn about unknown warning types"
118 ,(lambda (port unused name)
119 (emit port "warning: unknown warning type `~A'~%"
120 name)))
121
122 (unused-variable
123 "report unused variables"
124 ,(lambda (port loc name)
125 (emit port "~A: warning: unused variable `~A'~%"
126 loc name)))
127
128 (unused-toplevel
129 "report unused local top-level variables"
130 ,(lambda (port loc name)
131 (emit port
132 "~A: warning: possibly unused local top-level variable `~A'~%"
133 loc name)))
134
135 (unbound-variable
136 "report possibly unbound variables"
137 ,(lambda (port loc name)
138 (if (not (member name (fluid-ref (M %dont-warn-list))))
139 (emit port
140 "~A: warning: possibly unbound variable `~A'~%"
141 loc name))))
142
143 (macro-use-before-definition
144 "report possibly mis-use of macros before they are defined"
145 ,(lambda (port loc name)
146 (emit port
147 "~A: warning: macro `~A' used before definition~%"
148 loc name)))
149
150 (arity-mismatch
151 "report procedure arity mismatches (wrong number of arguments)"
152 ,(lambda (port loc name certain?)
153 (if certain?
154 (emit port
155 "~A: warning: wrong number of arguments to `~A'~%"
156 loc name)
157 (emit port
158 "~A: warning: possibly wrong number of arguments to `~A'~%"
159 loc name))))
160
161 (shadowed-toplevel
162 ""
163 ,(lambda x x))
164
165 (duplicate-case-datum
166 "report a duplicate datum in a case expression"
167 ,(lambda (port loc datum clause case-expr)
168 (emit port
169 "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%"
170 loc datum clause case-expr)))
171
172 (bad-case-datum
173 "report a case datum that cannot be meaningfully compared using `eqv?'"
174 ,(lambda (port loc datum clause case-expr)
175 (emit port
176 "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
177 loc datum clause case-expr)))
178
179 (format
180 "report wrong number of arguments to `format'"
181 ,(lambda (port loc . rest)
182 (define (escape-newlines str)
183 (list->string
184 (string-fold-right (lambda (c r)
185 (if (eq? c #\newline)
186 (append '(#\\ #\n) r)
187 (cons c r)))
188 '()
189 str)))
190
191 (define (range min max)
192 (cond ((eq? min 'any)
193 (if (eq? max 'any)
194 "any number" ;; can't happen
195 (emit #f "up to ~a" max)))
196 ((eq? max 'any)
197 (emit #f "at least ~a" min))
198 ((= min max) (number->string min))
199 (else
200 (emit #f "~a to ~a" min max))))
201
202 ((M match) rest
203 (('simple-format fmt opt)
204 (emit port
205 "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%"
206 loc (escape-newlines fmt) opt))
207 (('wrong-format-arg-count fmt min max actual)
208 (emit port
209 "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
210 loc (escape-newlines fmt)
211 (range min max) actual))
212 (('syntax-error 'unterminated-iteration fmt)
213 (emit port "~A: warning: ~S: unterminated iteration~%"
214 loc (escape-newlines fmt)))
215 (('syntax-error 'unterminated-conditional fmt)
216 (emit port "~A: warning: ~S: unterminated conditional~%"
217 loc (escape-newlines fmt)))
218 (('syntax-error 'unexpected-semicolon fmt)
219 (emit port "~A: warning: ~S: unexpected `~~;'~%"
220 loc (escape-newlines fmt)))
221 (('syntax-error 'unexpected-conditional-termination fmt)
222 (emit port "~A: warning: ~S: unexpected `~~]'~%"
223 loc (escape-newlines fmt)))
224 (('wrong-port wrong-port)
225 (emit port
226 "~A: warning: ~S: wrong port argument~%"
227 loc wrong-port))
228 (('wrong-format-string fmt)
229 (emit port
230 "~A: warning: ~S: wrong format string~%"
231 loc fmt))
232 (('non-literal-format-string)
233 (emit port
234 "~A: warning: non-literal format string~%"
235 loc))
236 (('wrong-num-args count)
237 (emit port
238 "~A: warning: wrong number of arguments to `format'~%"
239 loc))
240 (else
241 (emit port "~A: `format' warning~%" loc)))))))))