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