Changeset 22 for hh2008/naoya_t/trunk

Show
Ignore:
Timestamp:
03/03/08 23:09:07 (17 years ago)
Author:
naoya_t
Message:

2008-03-04 08:09

Location:
hh2008/naoya_t/trunk
Files:
3 modified

Legend:

Unmodified
Added
Removed
  • hh2008/naoya_t/trunk/ihci.scm

    r18 r22  
     1;; 
     2;; IHC - Ikoma Haskell Compiler 
     3;; 
    14(use srfi-1) 
    25 
     
    2326         [%body-char ($or %unescaped)] 
    2427         [%string-body ($do (chars ($many %body-char)) 
    25                                                         ($return (tag :string (list->string chars))))] 
     28;                                                       ($return (tag :string (list->string chars))))] 
     29                                                        ($return (list->string chars)))] 
    2630                 ) 
    2731        ($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           )) 
    2841 
    2942(define %ident ;; scheme-symbolで代用 
     
    3245        ($do (head %ident-head-char) 
    3346                 (rest ($many %ident-rest-char)) 
     47;                ($return (tag :ident (string->symbol (list->string (cons head rest)))))))) 
    3448                 ($return (string->symbol (list->string (cons head rest))))))) 
    3549 
    3650(define %digits 
    3751  ($do (d ($many digit 1)) 
    38            ($return (tag :number (string->number (list->string d)))))) 
     52;          ($return (tag :number (string->number (list->string d)))))) 
     53           ($return (string->number (list->string d))))) 
    3954 
    4055(define %list 
    41   (let* ([%begin-list ($seq %ws ($char #\[) %ws)] 
    42                  [%end-list ($seq %ws ($char #\]) %ws)] 
     56  (let* ([%begin-list ($char #\[)] 
     57                 [%end-list ($char #\])] 
    4358                 [%item ($or %digits %string %ident)] 
    4459                 [%item-separator ($seq %ws ($char #\,) %ws)] 
     
    5166 
    5267(define %tuple 
    53   (let* ([%begin-list ($seq %ws ($char #\() %ws)] 
    54                  [%end-list ($seq %ws ($char #\)) %ws)] 
     68  (let* ([%begin-list ($char #\()] 
     69                 [%end-list ($char #\))] 
    5570                 [%item ($or %digits %string %ident)] 
    5671                 [%item-separator ($seq %ws ($char #\,) %ws)] 
     
    6277        )) 
    6378 
     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 
    64128(define %expr 
    65   ($or %string %digits %ident %list %tuple)) 
     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))))) 
    66151 
    67152(define %application 
     
    69154          ($do (fn %ident) 
    70155                   %ws 
     156                   (arg1 ($or %expr 
     157                                          ($between ($char #\() %expr ($char #\))))) 
     158                   %ws 
    71159                   (args ($my-sep-by %expr %ws)) 
    72                    ($return `(:apply ,fn ,@args))) 
    73         ($do (app1 %an-application) 
     160                   ($return `(:apply ,fn ,arg1 ,@args))) 
     161        ($do (app1 ($or %infixed %an-application %lambda %ident)) 
    74162                 (apps ($many ($do %ws 
    75                                                    (($char #\$)) 
     163                                                   (($char #\$)) ; " $ " 
    76164                                                   %ws 
    77                                                    (app %an-application) 
     165                                                   (app ($or %infixed %an-application %lambda %ident)) 
    78166                                                   ($return app)))) 
    79167                 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) 
    80168 
     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 
    81221(define %haskell 
    82222  (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  
    121223                 ) 
    122         ($or %defun %pattern %assignment %application %expr 
    123                  %unknown) 
     224        ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr 
     225                 %unknown 
     226                 newline) 
    124227        )) 
    125228 
     
    134237;(define ident-body untag) 
    135238 
     239(define lambda? (tagged?$ :lambda)) 
     240 
    136241(define (indent w lines) 
    137242  (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) 
     
    143248  (hash-table-put! *namespace* id val) 
    144249  id) 
    145 (define (lookup id) 
    146   (let1 val (hash-table-get *namespace* id) 
    147         ; 
    148         val)) 
     250 
     251(define (lookup id env) 
     252  (let1 val (lookup-variable-value id env) 
     253        (if val val (hash-table-get *namespace* id)))) 
    149254 
    150255;; 
     
    155260(define (heval-map exps env) (map (cut heval <> env) exps)) 
    156261(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))] ))) 
     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                                )])) 
    207332 
    208333(define (primitive-procedure? proc) 
     
    210335                           putStrLn 
    211336                           lines length print 
    212                            tail))) 
     337                           tail 
     338                           * + - /))) 
    213339 
    214340(define (prim-print exp) 
     
    223349                   (list->haskell-string (untag obj))] 
    224350                  [(pair? obj) (haskell-description-of-list obj)] 
     351                  [(number? obj) (number->string obj)] 
     352                  [(string? obj) obj] 
    225353                  [else (x->string obj)])) 
    226  
    227354  (print (haskell-description exp))) 
    228355 
     
    236363  (let1 args* (heval-map args '()) 
    237364        (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*)) 
     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*)) 
    243370                                        (string-length (car args*)) 
    244                                         (length (car args*)))) 
    245           ((tail) (prim-tail (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)] 
    246379          ))) 
    247380 
     
    252385(define (procedure-environment proc) (fourth proc)) 
    253386 
     387; SICP pp225-226 
     388(define (enclosing-environment env) (cdr env)) 
     389(define (first-frame env) (car env)) 
     390(define the-empty-environment '()) 
     391 
    254392(define (make-frame vars vals) (cons vars vals)) 
     393(define (frame-variables frame) (car frame)) 
     394(define (frame-values frame) (cdr frame)) 
    255395 
    256396(define (extend-environment vars vals base-env) 
    257397  ;; assert-equal (length vars) (length vals) 
    258398  (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)])) 
    259420 
    260421(define (happly proc args) 
     
    265426                                                                           args 
    266427                                                                           (procedure-environment proc)) 
    267                    (heval-map (procedure-body proc) env))] 
     428                   (heval-sequence (procedure-body proc) env))] 
    268429                [else 
    269430                 ; 
     
    274435  (let1 input (read-line) 
    275436        (if (eof-object? input) 'eof 
    276                 (let1 parsed (parse-haskell input); (haskell->scheme input) 
    277                   (let1 evaled (heval parsed '()) 
     437                (begin 
     438                  (when (and (string? input) (< 0 (string-length input))) 
    278439                        (print "> " input) 
    279                         (print "=> " parsed) 
    280                         (print "" evaled)) 
     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 "")) 
    281447                  (repl))))) 
    282448 
    283 (define (actual-value exp); env) 
    284   (force-it (heval exp '()))) 
    285  
    286 (let1 main (lookup 'main) 
    287   (print "----") 
    288    (happly main '()) 
    289    ) 
     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  ) 
  • hh2008/naoya_t/trunk/test.hs

    r18 r22  
    1 main = putStrLn "Hello, World!" 
     1"Hello, World!" 
     2putStrLn "Hello, World!" 
     35 * 6 - 7 
     4print $ 5 * 6 - 7 
     5\x -> x * x $ 5 * 6 - 7 
     6print $ \x -> x * x $ 5 * 6 - 7 
     7[1,2,3,4] 
     8print [1,2,3,4] 
     9tail [1,2,3] 
     10print $ tail [1,2,3] 
    211 
    3 -- main = do { cs <- getContents ; print $ length $ lines cs } 
     12print if 1 then '@' else '*' 
     13-- if c == '\t' then '@' else c 
     14\num -> num * num 
     15\x -> x 
     163 + 4 
     174 * 5 - 1 
    418 
    519firstNLines n cs = unlines $ take n $ lines cs 
    620 
    7 -- main = print $ 5 + 2 * 5 
    8 rmain = print $ tail [1,2,3] 
    9 -- main = tail [1,2,3] 
    10  
    11 tail [1,2,3] 
    12 print [1,2,3,4] 
     21f1 = do { cs <- getContents ; print $ length $ lines cs } 
     22f2 = print $ 5 + 2 * 5 
     23f3 = print $ tail [1,2,3] 
     24f4 = tail [1,2,3] 
    1325 
    1426fib 0 = 0 
     
    1628fib n = fib (n-1) + fib (n-2) 
    1729 
     30square n = n * n 
     31triple a = a + a + a 
     32 
     33main = putStrLn "Hello, World!" 
     34 
     35main = print $ 5 * 6 - 7 
     36-- main = print $ \x -> x * x $ 5 * 6 - 7 
  • hh2008/naoya_t/trunk/test.sh

    r18 r22  
    11#!/bin/sh 
    2 sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm 
    3  
     2# sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm 
     3gosh -I. ihci.scm < test.hs