Context Navigation

ihci.scm @ 18

Revision 18, 8.0 kB (checked in by naoya_t, 17 years ago)
initial import (march 01 version)

Line
1	(use srfi-1)
2
3	(define undefined (if #f #f))
4
5	(define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag)))
6	(define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag))))
7	(define (tag t obj) (cons t obj))
8	(define (tag$ t) (lambda (obj) (cons t obj)))
9	(define (untag obj) (cdr obj))
10
11	(use peg)
12
13	(define (nil-if-true l) (if (eq? #t l) '() l))
14	(define ($my-sep-by parse sep . args)
15	($do (them ($sep-by parse sep))
16	($return (nil-if-true them))))
17
18	(define %ws ($many ($one-of #[ \t\r\n])))
19
20	(define %string ; scheme-string で代用
21	(let* ([%dquote ($char #\")]
22	[%unescaped ($none-of #[\"])]
23	[%body-char ($or %unescaped)]
24	[%string-body ($do (chars ($many %body-char))
25	($return (tag :string (list->string chars))))]
26	)
27	($between %dquote %string-body %dquote)))
28
29	(define %ident ;; scheme-symbolで代用
30	(let* ([%ident-head-char ($one-of #[a-z_])]
31	[%ident-rest-char ($one-of #[0-9A-Za-z_'])])
32	($do (head %ident-head-char)
33	(rest ($many %ident-rest-char))
34	($return (string->symbol (list->string (cons head rest)))))))
35
36	(define %digits
37	($do (d ($many digit 1))
38	($return (tag :number (string->number (list->string d))))))
39
40	(define %list
41	(let* ([%begin-list ($seq %ws ($char #\[) %ws)]
42	[%end-list ($seq %ws ($char #\]) %ws)]
43	[%item ($or %digits %string %ident)]
44	[%item-separator ($seq %ws ($char #\,) %ws)]
45	)
46	($do %begin-list
47	(items ($my-sep-by %item %item-separator))
48	%end-list
49	($return (tag :list items)))
50	))
51
52	(define %tuple
53	(let* ([%begin-list ($seq %ws ($char #\() %ws)]
54	[%end-list ($seq %ws ($char #\)) %ws)]
55	[%item ($or %digits %string %ident)]
56	[%item-separator ($seq %ws ($char #\,) %ws)]
57	)
58	($do %begin-list
59	(items ($my-sep-by %item %item-separator))
60	%end-list
61	($return (tag :tuple @items)))
62	))
63
64	(define %expr
65	($or %string %digits %ident %list %tuple))
66
67	(define %application
68	(let1 %an-application
69	($do (fn %ident)
70	%ws
71	(args ($my-sep-by %expr %ws))
72	($return `(:apply ,fn ,@args)))
73	($do (app1 %an-application)
74	(apps ($many ($do %ws
75	(($char #\$))
76	%ws
77	(app %an-application)
78	($return app))))
79	($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps))))))
80
81	(define %haskell
82	(let* ([%unknown ($my-sep-by %expr %ws)]
83
84	[%assignment ($do (id %ident)
85	%ws
86	(($string "<-"))
87	%ws
88	(value %application)
89	($return `(:assign ,id ,value))
90	)]
91	[%do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)]
92	[%do ($do (($string "do"))
93	%ws
94	(exprs ($or ($between ($seq ($char #\{) %ws)
95	($my-sep-by ($or %assignment %application)
96	($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws))
97	($seq %ws ($char #\})))
98	($my-sep-by ($or %assignment %application)
99	($seq newline ($string " ") %ws)) ))
100	($return `(:do ,@exprs)))]
101
102	[%defun ($do (id %ident)
103	%ws
104	(args ($my-sep-by %ident %ws))
105	%ws
106	(($char #\=))
107	%ws
108	(rightside ($or %do %application))
109	($return `(:defun (,id ,@args) ,rightside))
110	)]
111	[%pattern ($do (id %ident)
112	%ws
113	(args ($my-sep-by ($or %ident %digits) %ws))
114	%ws
115	(($char #\=))
116	%ws
117	(rightside ($or %do %application))
118	($return `(:pattern (,id ,@args) ,rightside))
119	)]
120
121	)
122	($or %defun %pattern %assignment %application %expr
123	%unknown)
124	))
125
126	(define (parse-haskell str)
127	(parse-string %haskell str))
128
129	(define putStrLn print)
130
131	(define ident? symbol?)
132	(define ident-body identity)
133	;(define ident? (tagged?$ :ident))
134	;(define ident-body untag)
135
136	(define (indent w lines)
137	(string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line)))
138	lines)
139	"\n"))
140
141	(define namespace (make-hash-table))
142	(define (assign id val)
143	(hash-table-put! namespace id val)
144	id)
145	(define (lookup id)
146	(let1 val (hash-table-get namespace id)
147	;
148	val))
149
150	;;
151	(define (make-procedure params body env)
152	(list :procedure params body env))
153
154	(use util.match)
155	(define (heval-map exps env) (map (cut heval <> env) exps))
156	(define (heval exp env)
157	(if (or (null? exp) (not (pair? exp))) undefined
158	(match exp
159	[(':$ . _)
160	; (delay-it
161	(let loop ([rest (cdr exp)])
162	(if (null? (cdr rest))
163	(heval (car rest) env)
164	(heval (append (car rest) (list (loop (cdr rest)))) env)
165	))
166	; env)
167	]
168	[(':apply f . _)
169	(if (null? (cddr exp))
170	; (delay-it (list (ident-body f)) env)
171	(list (ident-body f))
172	`(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp)))
173	; (delay-it `(,(ident-body f)
174	; ,@(map (cut heval <> env) (cdr exp)))
175	; env)
176	)]
177	[(':assign x y) ; id <- action
178	(assign (ident-body x) (heval y env))]
179	[(':do . _) ; do { ... ; ... ; ... }
180	`(seq ,@(heval-map (cdr exp) env))]
181	[(':defun id definition) ; id x y z = app x $ app y $ app z
182	(let ([ident (car id)]
183	[args (cdr id)])
184	(assign (ident-body ident)
185	(make-procedure (map ident-body args) ;lambda-parameters
186	(if (eq? 'seq (car definition)) ; lambda-body
187	(heval definition env)
188	(list (heval definition env)) )
189	env)))]
190	[(':pattern id definition) ; id x y z = app x $ app y $ app z
191	(let ([ident (car id)]
192	[args (cdr id)])
193	(assign (ident-body ident)
194	(make-procedure (map ident-body args) ;lambda-parameters
195	(if (eq? 'seq (car definition)) ; lambda-body
196	(heval definition env)
197	(list (heval definition env)) )
198	env)))]
199
200	[(':string . str) str]
201	[(':list . l) l]
202	[(':tuple . t) t]
203	[(':ident . id) id]
204
205	[_ (if (pair? exp) (happly (car exp) (cdr exp))
206	(format "unknown: ~a" exp))] )))
207
208	(define (primitive-procedure? proc)
209	(memq proc '(putStr
210	putStrLn
211	lines length print
212	tail)))
213
214	(define (prim-print exp)
215	(define (haskell-description-of-list l)
216	(string-append "[" (string-join (map haskell-description l) ",") "]"))
217
218	(define (haskell-description obj)
219	(cond [(not (pair? obj)) (x->string obj)]
220	[(tagged? :number obj) (number->string (untag obj))]
221	[(tagged? :string obj) (untag obj)]
222	[(tagged? :list obj) ; (untag obj)]
223	(list->haskell-string (untag obj))]
224	[(pair? obj) (haskell-description-of-list obj)]
225	[else (x->string obj)]))
226
227	(print (haskell-description exp)))
228
229	(define (prim-tail exp)
230	(cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))]
231	[(tagged? :list exp) (cddr exp)]
232	[(pair? exp) (cdr exp)]
233	[else undefined]))
234
235	(define (apply-primitive-procedure proc args)
236	(let1 args* (heval-map args '())
237	(case proc
238	((putStr) (display (x->string (car args*))))
239	((putStrLn) (apply prim-print args*))
240	((print) (apply prim-print args*))
241	((lines) (length args*))
242	((length) (if (tagged? :string (car args*))
243	(string-length (car args*))
244	(length (car args*))))
245	((tail) (prim-tail (car args*)))
246	)))
247
248	(define (compound-procedure? proc) (tagged? :procedure proc))
249
250	(define (procedure-parameters proc) (second proc))
251	(define (procedure-body proc) (third proc))
252	(define (procedure-environment proc) (fourth proc))
253
254	(define (make-frame vars vals) (cons vars vals))
255
256	(define (extend-environment vars vals base-env)
257	;; assert-equal (length vars) (length vals)
258	(cons (make-frame vars vals) base-env))
259
260	(define (happly proc args)
261	(cond [(primitive-procedure? proc)
262	(apply-primitive-procedure proc args)]
263	[(compound-procedure? proc)
264	(let1 env (extend-environment (procedure-parameters proc)
265	args
266	(procedure-environment proc))
267	(heval-map (procedure-body proc) env))]
268	[else
269	;
270	]))
271
272	;; REPL
273	(let repl ()
274	(let1 input (read-line)
275	(if (eof-object? input) 'eof
276	(let1 parsed (parse-haskell input); (haskell->scheme input)
277	(let1 evaled (heval parsed '())
278	(print "> " input)
279	(print "=> " parsed)
280	(print "" evaled))
281	(repl)))))
282
283	(define (actual-value exp); env)
284	(force-it (heval exp '())))
285
286	(let1 main (lookup 'main)
287	(print "----")
288	(happly main '())
289	)

Note: See TracBrowser for help on using the browser.

Context Navigation

root/hh2008/naoya_t/trunk/ihci.scm @ 18

Download in other formats: