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

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.