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