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