Context Navigation

ihci.scm

Revision 22, 12.2 kB (checked in by naoya_t, 17 years ago)
2008-03-04 08:09

Line
1	;;
2	;; IHC - Ikoma Haskell Compiler
3	;;
4	(use srfi-1)
5
6	(define undefined (if #f #f))
7
8	(define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag)))
9	(define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag))))
10	(define (tag t obj) (cons t obj))
11	(define (tag$ t) (lambda (obj) (cons t obj)))
12	(define (untag obj) (cdr obj))
13
14	(use peg)
15
16	(define (nil-if-true l) (if (eq? #t l) '() l))
17	(define ($my-sep-by parse sep . args)
18	($do (them ($sep-by parse sep))
19	($return (nil-if-true them))))
20
21	(define %ws ($many ($one-of #[ \t\r\n])))
22
23	(define %string ; scheme-string で代用
24	(let* ([%dquote ($char #\")]
25	[%unescaped ($none-of #[\"])]
26	[%body-char ($or %unescaped)]
27	[%string-body ($do (chars ($many %body-char))
28	; ($return (tag :string (list->string chars))))]
29	($return (list->string chars)))]
30	)
31	($between %dquote %string-body %dquote)))
32
33	(define %char
34	($do (($char #\'))
35	(($optional ($char #\\)))
36	(ch anychar)
37	(($char #\'))
38	; ($return (tag :char ch))
39	($return ch)
40	))
41
42	(define %ident ;; scheme-symbolで代用
43	(let* ([%ident-head-char ($one-of #[a-z_])]
44	[%ident-rest-char ($one-of #[0-9A-Za-z_'])])
45	($do (head %ident-head-char)
46	(rest ($many %ident-rest-char))
47	; ($return (tag :ident (string->symbol (list->string (cons head rest))))))))
48	($return (string->symbol (list->string (cons head rest)))))))
49
50	(define %digits
51	($do (d ($many digit 1))
52	; ($return (tag :number (string->number (list->string d))))))
53	($return (string->number (list->string d)))))
54
55	(define %list
56	(let* ([%begin-list ($char #\[)]
57	[%end-list ($char #\])]
58	[%item ($or %digits %string %ident)]
59	[%item-separator ($seq %ws ($char #\,) %ws)]
60	)
61	($do %begin-list
62	(items ($my-sep-by %item %item-separator))
63	%end-list
64	($return (tag :list items)))
65	))
66
67	(define %tuple
68	(let* ([%begin-list ($char #\()]
69	[%end-list ($char #\))]
70	[%item ($or %digits %string %ident)]
71	[%item-separator ($seq %ws ($char #\,) %ws)]
72	)
73	($do %begin-list
74	(items ($my-sep-by %item %item-separator))
75	%end-list
76	($return (tag :tuple @items)))
77	))
78
79	(define %atomic
80	($or %string %char %digits %ident %list %tuple))
81
82	(define (char->symbol ch)
83	(string->symbol (x->string ch)))
84
85	(define %infixed
86	(let1 %infix ($or ($one-of #[-+*/<>])
87	($string "==") ($string "<=") ($string ">="))
88	($do (item1 %atomic);($or %application %atomic)) ;%atomic)
89	; (seq ($do %ws
90	; (infix %infix)
91	; %ws
92	; (rest ($or %infixed %atomic))
93	; ($return (cons infix rest))))
94	%ws
95	(infix %infix)
96	%ws
97	(item2 %atomic);($or %application %atomic)) ;%atomic)
98	(rest ($many ($do %ws
99	(infix %infix)
100	%ws
101	(item %atomic);($or %application %atomic)) ;%atomic)
102	($return (list (char->symbol infix) item)))))
103	($return (let1 expr (append (list item1 (char->symbol infix) item2)
104	(apply append rest))
105	(case (length expr)
106	((3)
107	(list ':apply (second expr) (first expr) (third expr)))
108	((5) ; 優先度まだ
109	(list ':apply (fourth expr)
110	(list ':apply (second expr) (first expr) (third expr))
111	(fifth expr)))
112	)))
113	;(tag :infixed (append (list item1 (char->symbol infix) item2)
114	;(apply append rest))))
115	)))
116	; (seq ($or ($do %ws
117	; (infix %infix)
118	; %ws
119	; (rest %infixed)
120	; ($return (cons infix rest)))
121	; ($do %ws
122	; (infix %infix)
123	; %ws
124	; (rest %atomic)
125	; ($return (list infix rest))) ))
126	; ($return (tag :infixed (cons elem1 seq))))))
127
128	(define %expr
129	($or %infixed
130	; ($between ($char #$) %expr ($char #$))
131	%if %atomic))
132
133	(define %comment
134	($or
135	($seq ($string "-- ") ($none-of #[\n]) ($char #\n))
136	($seq ($string "{-") ($many anychar) ($string "-}"))
137	))
138
139	(define %if
140	($do (($string "if"))
141	%ws
142	(cond %expr)
143	%ws
144	(($string "then"))
145	%ws
146	(conseq %expr)
147	(alt ($optional ($do %ws (($string "else")) %ws
148	(alt %expr)
149	($return alt))))
150	($return (tag :if (list cond conseq alt)))))
151
152	(define %application
153	(let1 %an-application
154	($do (fn %ident)
155	%ws
156	(arg1 ($or %expr
157	($between ($char #$) %expr ($char #$))))
158	%ws
159	(args ($my-sep-by %expr %ws))
160	($return `(:apply ,fn ,arg1 ,@args)))
161	($do (app1 ($or %infixed %an-application %lambda %ident))
162	(apps ($many ($do %ws
163	(($char #\$)) ; " $ "
164	%ws
165	(app ($or %infixed %an-application %lambda %ident))
166	($return app))))
167	($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps))))))
168
169	(define %lambda
170	($do (($char #\\))
171	(vars ($my-sep-by %ident %ws))
172	%ws
173	(($string "->"))
174	%ws
175	(body ($or %do %infixed %application %expr))
176	($return (tag ':lambda (list vars body)))))
177
178	(define %assignment
179	($do (id %ident)
180	%ws
181	(($string "<-"))
182	%ws
183	(value ($or %infixed %application %expr))
184	($return `(:assign ,id ,value))
185	))
186
187	(define %do
188	(let1 %do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)
189	($do (($string "do"))
190	%ws
191	(exprs ($or ($between ($seq ($char #\{) %ws)
192	($my-sep-by ($or %assignment %infixed %application %expr)
193	($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws))
194	($seq %ws ($char #\})))
195	($my-sep-by ($or %assignment %infixed %application %expr)
196	($seq newline ($string " ") %ws)) ))
197	($return `(:do ,@exprs)))))
198
199	(define %defun
200	($do (id %ident)
201	%ws
202	(args ($my-sep-by %ident %ws))
203	%ws
204	(($char #\=))
205	%ws
206	(rightside ($or %do %infixed %application %expr))
207	($return `(:defun (,id ,@args) ,rightside))
208	))
209
210	(define %pattern
211	($do (id %ident)
212	%ws
213	(args ($my-sep-by ($or %ident %digits) %ws))
214	%ws
215	(($char #\=))
216	%ws
217	(rightside ($or %do %infixed %application %expr))
218	($return `(:pattern (,id ,@args) ,rightside))
219	))
220
221	(define %haskell
222	(let* ([%unknown ($my-sep-by %expr %ws)]
223	)
224	($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr
225	%unknown
226	newline)
227	))
228
229	(define (parse-haskell str)
230	(parse-string %haskell str))
231
232	(define putStrLn print)
233
234	(define ident? symbol?)
235	(define ident-body identity)
236	;(define ident? (tagged?$ :ident))
237	;(define ident-body untag)
238
239	(define lambda? (tagged?$ :lambda))
240
241	(define (indent w lines)
242	(string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line)))
243	lines)
244	"\n"))
245
246	(define namespace (make-hash-table))
247	(define (assign id val)
248	(hash-table-put! namespace id val)
249	id)
250
251	(define (lookup id env)
252	(let1 val (lookup-variable-value id env)
253	(if val val (hash-table-get namespace id))))
254
255	;;
256	(define (make-procedure params body env)
257	(list :procedure params body env))
258
259	(use util.match)
260	(define (heval-map exps env) (map (cut heval <> env) exps))
261	(define (heval exp env)
262	; (print "HEVAL " exp)
263	(cond [(null? exp) undefined]
264	[(number? exp) exp]
265	[(string? exp) exp]
266	[(char? exp) exp]
267	[(symbol? exp) (let1 val (lookup exp env)
268	(if val (heval val env) undefined))]
269	[else (match exp
270	[(':$ . _)
271	(let loop ([apps (map (lambda (e) (if (or (ident? e) (lambda? e))
272	(list ':apply e) e))
273	(cdr exp))])
274	(if (null? (cdr apps))
275	(heval (car apps) env)
276	(heval (append (car apps)
277	(list (loop (cdr apps))))
278	env)
279	))
280	]
281
282	[(':apply f . _)
283	(let ([f (cadr exp)]
284	[args (cddr exp)])
285	(happly
286	(if (symbol? f) f (heval (second exp) env))
287	(heval-map args env))
288	)]
289
290	[(':assign x y) ; id <- action
291	(assign (ident-body x) (heval y env))]
292
293	[(':if cond then)
294	(if cond then undefined)]
295	[(':if cond then else)
296	(if cond then else)]
297
298	[(':do . _) ; do { ... ; ... ; ... }
299	`(seq ,@(heval-map (cdr exp) env))]
300
301	[(':lambda args . lambda-body)
302	(make-procedure (map ident-body args) ;lambda-parameters
303	lambda-body
304	env)]
305
306	[(':defun id definition) ; id x y z = app x $ app y $ app z
307	(let ([ident (car id)]
308	[args (cdr id)])
309	(assign (ident-body ident)
310	(make-procedure (map ident-body args) ;lambda-parameters
311	(if (eq? 'seq (car definition)) ; lambda-body
312	;(heval definition env)
313	;(list (heval definition env)) )
314	definition
315	(list definition))
316	env)))]
317
318	[(':pattern id definition) ; id x y z = app x $ app y $ app z
319	(let ([ident (car id)]
320	[args (cdr id)])
321	)]
322
323	[(':string . str) str]
324	[(':list . l) l];(heval-map l env)]
325	[(':tuple . t) t]
326	[(':ident . id) id]
327
328	[_ (if (pair? exp) exp ;(happly (car exp) (cdr exp))
329	(format "unknown: ~a" exp))]
330
331	)]))
332
333	(define (primitive-procedure? proc)
334	(memq proc '(putStr
335	putStrLn
336	lines length print
337	tail
338	* + - /)))
339
340	(define (prim-print exp)
341	(define (haskell-description-of-list l)
342	(string-append "[" (string-join (map haskell-description l) ",") "]"))
343
344	(define (haskell-description obj)
345	(cond [(not (pair? obj)) (x->string obj)]
346	[(tagged? :number obj) (number->string (untag obj))]
347	[(tagged? :string obj) (untag obj)]
348	[(tagged? :list obj) ; (untag obj)]
349	(list->haskell-string (untag obj))]
350	[(pair? obj) (haskell-description-of-list obj)]
351	[(number? obj) (number->string obj)]
352	[(string? obj) obj]
353	[else (x->string obj)]))
354	(print (haskell-description exp)))
355
356	(define (prim-tail exp)
357	(cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))]
358	[(tagged? :list exp) (cddr exp)]
359	[(pair? exp) (cdr exp)]
360	[else undefined]))
361
362	(define (apply-primitive-procedure proc args)
363	(let1 args* (heval-map args '())
364	(case proc
365	[(putStr) (display (x->string (car args*)))]
366	[(putStrLn) (apply prim-print args*)]
367	[(print) (apply prim-print args*)]
368	[(lines) (length args*)]
369	[(length) (if (tagged? :string (car args*))
370	(string-length (car args*))
371	(length (car args*)))]
372	[(tail) (prim-tail (car args*))]
373
374	[() (apply args*)]
375	[(+) (apply + args*)]
376	[(/) (apply / args*)]
377	[(-) (apply - args*)]
378	; [else (error "unknown primitive: " proc)]
379	)))
380
381	(define (compound-procedure? proc) (tagged? :procedure proc))
382
383	(define (procedure-parameters proc) (second proc))
384	(define (procedure-body proc) (third proc))
385	(define (procedure-environment proc) (fourth proc))
386
387	; SICP pp225-226
388	(define (enclosing-environment env) (cdr env))
389	(define (first-frame env) (car env))
390	(define the-empty-environment '())
391
392	(define (make-frame vars vals) (cons vars vals))
393	(define (frame-variables frame) (car frame))
394	(define (frame-values frame) (cdr frame))
395
396	(define (extend-environment vars vals base-env)
397	;; assert-equal (length vars) (length vals)
398	(cons (make-frame vars vals) base-env))
399
400	(define (lookup-variable-value var env)
401	(define (env-loop env)
402	(define (scan vars vals)
403	(cond [(null? vars)
404	(env-loop (enclosing-environment env))]
405	[(eq? var (car vars))
406	(car vals)]
407	[else (scan (cdr vars) (cdr vals))]))
408	(if (eq? env the-empty-environment)
409	#f ; (error "unbound variable" var)
410	(let1 frame (first-frame env)
411	(scan (frame-variables frame)
412	(frame-values frame)))))
413	(env-loop env))
414
415	(define (last-exp? seq) (null? (cdr seq)))
416	(define (heval-sequence exps env)
417	(cond [(last-exp? exps) (heval (car exps) env)]
418	[else (heval (car exps) env)
419	(heval-sequence (cdr exps) env)]))
420
421	(define (happly proc args)
422	(cond [(primitive-procedure? proc)
423	(apply-primitive-procedure proc args)]
424	[(compound-procedure? proc)
425	(let1 env (extend-environment (procedure-parameters proc)
426	args
427	(procedure-environment proc))
428	(heval-sequence (procedure-body proc) env))]
429	[else
430	;
431	]))
432
433	;; REPL
434	(let repl ()
435	(let1 input (read-line)
436	(if (eof-object? input) 'eof
437	(begin
438	(when (and (string? input) (< 0 (string-length input)))
439	(print "> " input)
440	(let1 parsed (parse-haskell input); (haskell->scheme input)
441	(print "=> " parsed)
442	(let1 evaled (heval parsed '())
443	(print "=> " evaled)
444	; (if evaled (print ": " (heval evaled '())))
445	))
446	(print ""))
447	(repl)))))
448
449	;(define (actual-value exp); env)
450	; (if (and (pair? exp) (tagged? ':apply exp))
451	; (
452	; (force-it (heval exp '())))
453
454	(let1 main (lookup 'main '())
455	(print "====")
456	(happly main '())
457	)

Note: See TracBrowser for help on using the browser.

Context Navigation

root/hh2008/naoya_t/trunk/ihci.scm

Download in other formats: