Changes in hh2008/naoya_t/trunk/ihci.scm [18:22]

Files:

• hh2008/naoya_t/trunk/ihci.scm (modified) (15 diffs)

hh2008/naoya_t/trunk/ihci.scm

@@ +1 @@
+;;
+;; IHC - Ikoma Haskell Compiler
+;;
 (use srfi-1)
 
@@ -23 +26 @@
          [%body-char ($or %unescaped)]
          [%string-body ($do (chars ($many %body-char))
-                                                        ($return (tag :string (list->string chars))))]
+;                                                       ($return (tag :string (list->string chars))))]
+                                                        ($return (list->string chars)))]
                  )
         ($between %dquote %string-body %dquote)))
+
+(define %char
+  ($do (($char #\'))
+           (($optional ($char #\\)))
+           (ch anychar)
+           (($char #\'))
+;          ($return (tag :char ch))
+           ($return ch)
+           ))
 
 (define %ident ;; scheme-symbolで代用
@@ -32 +45 @@
         ($do (head %ident-head-char)
                  (rest ($many %ident-rest-char))
+;                ($return (tag :ident (string->symbol (list->string (cons head rest))))))))
                  ($return (string->symbol (list->string (cons head rest)))))))
 
 (define %digits
   ($do (d ($many digit 1))
-           ($return (tag :number (string->number (list->string d))))))
+;          ($return (tag :number (string->number (list->string d))))))
+           ($return (string->number (list->string d)))))
 
 (define %list
-  (let* ([%begin-list ($seq %ws ($char #\[) %ws)]
-                 [%end-list ($seq %ws ($char #\]) %ws)]
+  (let* ([%begin-list ($char #\[)]
+                 [%end-list ($char #\])]
                  [%item ($or %digits %string %ident)]
                  [%item-separator ($seq %ws ($char #\,) %ws)]
@@ -51 +66 @@
 
 (define %tuple
-  (let* ([%begin-list ($seq %ws ($char #\() %ws)]
-                 [%end-list ($seq %ws ($char #\)) %ws)]
+  (let* ([%begin-list ($char #\()]
+                 [%end-list ($char #\))]
                  [%item ($or %digits %string %ident)]
                  [%item-separator ($seq %ws ($char #\,) %ws)]
@@ -62 +77 @@
         ))
 
+(define %atomic
+  ($or %string %char %digits %ident %list %tuple))
+
+(define (char->symbol ch)
+  (string->symbol (x->string ch)))
+
+(define %infixed
+  (let1 %infix ($or ($one-of #[-+*/<>])
+                                        ($string "==") ($string "<=") ($string ">="))
+        ($do (item1 %atomic);($or %application %atomic)) ;%atomic)
+;                (seq ($do %ws
+;                                  (infix %infix)
+                                                                                ;                                  %ws
+;                                  (rest ($or %infixed %atomic))
+;                                  ($return (cons infix rest))))
+                 %ws
+                 (infix %infix)
+                 %ws
+                 (item2 %atomic);($or %application %atomic)) ;%atomic)
+                 (rest ($many ($do %ws
+                                                   (infix %infix)
+                                                   %ws
+                                                   (item %atomic);($or %application %atomic)) ;%atomic)
+                                                   ($return (list (char->symbol infix) item)))))
+                 ($return (let1 expr (append (list item1 (char->symbol infix) item2)
+                                                                         (apply append rest))
+                                        (case (length expr)
+                                          ((3)
+                                           (list ':apply (second expr) (first expr) (third expr)))
+                                          ((5) ; 優先度まだ
+                                           (list ':apply (fourth expr)
+                                                         (list ':apply (second expr) (first expr) (third expr))
+                                                         (fifth expr)))
+                                          )))
+                                        ;(tag :infixed (append (list item1 (char->symbol infix) item2)
+                                        ;(apply append rest))))
+                 )))
+;                (seq ($or ($do %ws
+;                                               (infix %infix)
+;                                               %ws
+;                                               (rest %infixed)
+;                                               ($return (cons infix rest)))
+;                                  ($do %ws
+;                                               (infix %infix)
+;                                               %ws
+;                                               (rest %atomic)
+;                                               ($return (list infix rest))) ))
+;                ($return (tag :infixed (cons elem1 seq))))))
+
 (define %expr
-  ($or %string %digits %ident %list %tuple))
+  ($or %infixed 
+;          ($between ($char #\() %expr ($char #\)))
+           %if %atomic))
+
+(define %comment
+  ($or
+   ($seq ($string "-- ") ($none-of #[\n]) ($char #\n))
+   ($seq ($string "{-") ($many anychar) ($string "-}"))
+   ))
+
+(define %if
+  ($do (($string "if"))
+           %ws
+           (cond %expr)
+           %ws
+           (($string "then"))
+           %ws
+           (conseq %expr)
+           (alt ($optional ($do %ws (($string "else")) %ws 
+                                                        (alt %expr)
+                                                        ($return alt))))
+           ($return (tag :if (list cond conseq alt)))))
 
 (define %application
@@ -69 +154 @@
           ($do (fn %ident)
                    %ws
+                   (arg1 ($or %expr
+                                          ($between ($char #\() %expr ($char #\)))))
+                   %ws
                    (args ($my-sep-by %expr %ws))
-                   ($return `(:apply ,fn ,@args)))
-        ($do (app1 %an-application)
+                   ($return `(:apply ,fn ,arg1 ,@args)))
+        ($do (app1 ($or %infixed %an-application %lambda %ident))
                  (apps ($many ($do %ws
-                                                   (($char #\$))
+                                                   (($char #\$)) ; " $ "
                                                    %ws
-                                                   (app %an-application)
+                                                   (app ($or %infixed %an-application %lambda %ident))
                                                    ($return app))))
                  ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps))))))
 
+(define %lambda
+  ($do (($char #\\))
+           (vars ($my-sep-by %ident %ws))
+           %ws
+           (($string "->"))
+           %ws
+           (body ($or %do %infixed %application %expr))
+           ($return (tag ':lambda (list vars body)))))
+
+(define %assignment
+  ($do (id %ident)
+           %ws
+           (($string "<-"))
+           %ws
+           (value ($or %infixed %application %expr))
+           ($return `(:assign ,id ,value))
+           ))
+
+(define %do
+  (let1 %do-line-separator ($seq %ws ($or ($seq newline ($string "  ")) ($char #\;)) %ws)
+        ($do (($string "do"))
+                 %ws
+                 (exprs ($or ($between ($seq ($char #\{) %ws)
+                                                           ($my-sep-by ($or %assignment %infixed %application %expr)
+                                                                                   ($seq %ws ($char #\;) ($optional ($seq newline ($string "  "))) %ws))
+                                                           ($seq %ws ($char #\})))
+                                         ($my-sep-by ($or %assignment %infixed %application %expr)
+                                                                 ($seq newline ($string "  ") %ws)) ))
+                 ($return `(:do ,@exprs)))))
+
+(define %defun
+  ($do (id %ident)
+           %ws
+           (args ($my-sep-by %ident %ws))
+           %ws
+           (($char #\=))
+           %ws
+           (rightside ($or %do %infixed %application %expr))
+           ($return `(:defun (,id ,@args) ,rightside))
+           ))
+
+(define %pattern
+  ($do (id %ident)
+           %ws
+           (args ($my-sep-by ($or %ident %digits) %ws))
+           %ws
+           (($char #\=))
+           %ws
+           (rightside ($or %do %infixed %application %expr))
+           ($return `(:pattern (,id ,@args) ,rightside))
+           ))
+
 (define %haskell
   (let* ([%unknown ($my-sep-by %expr %ws)]
-                 
-                 [%assignment ($do (id %ident)
-                                                   %ws
-                                                   (($string "<-"))
-                                                   %ws
-                                                   (value %application)
-                                                   ($return `(:assign ,id ,value))
-                                                   )]
-                 [%do-line-separator ($seq %ws ($or ($seq newline ($string "  ")) ($char #\;)) %ws)]
-                 [%do ($do (($string "do"))
-                                   %ws
-                                   (exprs ($or ($between ($seq ($char #\{) %ws)
-                                                                                 ($my-sep-by ($or %assignment %application)
-                                                                                                         ($seq %ws ($char #\;) ($optional ($seq newline ($string "  "))) %ws))
-                                                                                 ($seq %ws ($char #\})))
-                                                           ($my-sep-by ($or %assignment %application)
-                                                                                   ($seq newline ($string "  ") %ws)) ))
-                                   ($return `(:do ,@exprs)))]
-
-                 [%defun ($do (id %ident)
-                                          %ws
-                                          (args ($my-sep-by %ident %ws))
-                                          %ws
-                                          (($char #\=))
-                                          %ws
-                                          (rightside ($or %do %application))
-                                          ($return `(:defun (,id ,@args) ,rightside))
-                                          )]
-                 [%pattern ($do (id %ident)
-                                                %ws
-                                                (args ($my-sep-by ($or %ident %digits) %ws))
-                                                %ws
-                                                (($char #\=))
-                                                %ws
-                                                (rightside ($or %do %application))
-                                                ($return `(:pattern (,id ,@args) ,rightside))
-                                                )]
-
                  )
-        ($or %defun %pattern %assignment %application %expr
-                 %unknown)
+        ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr
+                 %unknown
+                 newline)
         ))
 
@@ -134 +237 @@
 ;(define ident-body untag)
 
+(define lambda? (tagged?$ :lambda))
+
 (define (indent w lines)
   (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line)))
@@ -143 +248 @@
   (hash-table-put! *namespace* id val)
   id)
-(define (lookup id)
-  (let1 val (hash-table-get *namespace* id)
-        ;
-        val))
+
+(define (lookup id env)
+  (let1 val (lookup-variable-value id env)
+        (if val val (hash-table-get *namespace* id))))
 
 ;;
@@ -155 +260 @@
 (define (heval-map exps env) (map (cut heval <> env) exps))
 (define (heval exp env)
-  (if (or (null? exp) (not (pair? exp))) *undefined*
-          (match exp
-                [(':$ . _)
-;                (delay-it
-                  (let loop ([rest (cdr exp)])
-                        (if (null? (cdr rest))
-                                (heval (car rest) env)
-                                (heval (append (car rest) (list (loop (cdr rest)))) env)
-                                ))
-;                 env)
-                  ]
-                [(':apply f . _)
-                 (if (null? (cddr exp))
-;                        (delay-it (list (ident-body f)) env)
-                         (list (ident-body f))
-                         `(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp)))
-;                        (delay-it `(,(ident-body f)
-;                                                ,@(map (cut heval <> env) (cdr exp)))
-;                                          env)
-                         )]
-                [(':assign x y) ; id <- action
-                 (assign (ident-body x) (heval y env))]
-                [(':do . _) ; do { ... ; ... ; ... }
-                 `(seq ,@(heval-map (cdr exp) env))]
-                [(':defun id definition) ; id x y z = app x $ app y $ app z
-                 (let ([ident (car id)]
-                           [args (cdr id)])
-                   (assign (ident-body ident)
-                                   (make-procedure (map ident-body args) ;lambda-parameters
-                                                                   (if (eq? 'seq (car definition)) ; lambda-body
-                                                                           (heval definition env)
-                                                                           (list (heval definition env)) )
-                                                                   env)))]
-                [(':pattern id definition) ; id x y z = app x $ app y $ app z
-                 (let ([ident (car id)]
-                           [args (cdr id)])
-                   (assign (ident-body ident)
-                                   (make-procedure (map ident-body args) ;lambda-parameters
-                                                                   (if (eq? 'seq (car definition)) ; lambda-body
-                                                                           (heval definition env)
-                                                                           (list (heval definition env)) )
-                                                                   env)))]
-                
-                [(':string . str) str]
-                [(':list . l) l]
-                [(':tuple . t) t]
-                [(':ident . id) id]
-
-                [_ (if (pair? exp) (happly (car exp) (cdr exp))
-                           (format "unknown: ~a" exp))] )))
+;  (print "HEVAL " exp)
+  (cond [(null? exp) *undefined*]
+                [(number? exp) exp]
+                [(string? exp) exp]
+                [(char? exp) exp]
+                [(symbol? exp) (let1 val (lookup exp env)
+                                                 (if val (heval val env) *undefined*))]
+                [else (match exp
+                                [(':$ . _)
+                                 (let loop ([apps (map (lambda (e) (if (or (ident? e) (lambda? e))
+                                                                                                           (list ':apply e) e))
+                                                                           (cdr exp))])
+                                   (if (null? (cdr apps))
+                                           (heval (car apps) env)
+                                           (heval (append (car apps)
+                                                                          (list (loop (cdr apps))))
+                                                          env)
+                                           ))
+                                 ]
+
+                                [(':apply f . _)
+                                 (let ([f (cadr exp)]
+                                           [args (cddr exp)])
+                                   (happly
+                                        (if (symbol? f) f (heval (second exp) env))
+                                        (heval-map args env))
+                                   )]
+
+                                [(':assign x y) ; id <- action
+                                 (assign (ident-body x) (heval y env))]
+
+                                [(':if cond then)
+                                 (if cond then *undefined*)]
+                                [(':if cond then else)
+                                 (if cond then else)]
+
+                                [(':do . _) ; do { ... ; ... ; ... }
+                                 `(seq ,@(heval-map (cdr exp) env))]
+
+                                [(':lambda args . lambda-body)
+                                 (make-procedure (map ident-body args) ;lambda-parameters
+                                                                 lambda-body
+                                                                 env)]
+
+                                [(':defun id definition) ; id x y z = app x $ app y $ app z
+                                 (let ([ident (car id)]
+                                           [args (cdr id)])
+                                   (assign (ident-body ident)
+                                                   (make-procedure (map ident-body args) ;lambda-parameters
+                                                                                   (if (eq? 'seq (car definition)) ; lambda-body
+                                                                                ;(heval definition env)
+                                                                                ;(list (heval definition env)) )
+                                                                                           definition
+                                                                                           (list definition))
+                                                                                   env)))]
+
+                                [(':pattern id definition) ; id x y z = app x $ app y $ app z
+                                 (let ([ident (car id)]
+                                           [args (cdr id)])
+                                   )]
+                                
+                                [(':string . str) str]
+                                [(':list . l) l];(heval-map l env)]
+                                [(':tuple . t) t]
+                                [(':ident . id) id]
+
+                                [_ (if (pair? exp) exp ;(happly (car exp) (cdr exp))
+                                           (format "unknown: ~a" exp))]
+
+                                )]))
 
 (define (primitive-procedure? proc)
@@ -210 +335 @@
                            putStrLn
                            lines length print
-                           tail)))
+                           tail
+                           * + - /)))
 
 (define (prim-print exp)
@@ -223 +349 @@
                    (list->haskell-string (untag obj))]
                   [(pair? obj) (haskell-description-of-list obj)]
+                  [(number? obj) (number->string obj)]
+                  [(string? obj) obj]
                   [else (x->string obj)]))
-
   (print (haskell-description exp)))
 
@@ -236 +363 @@
   (let1 args* (heval-map args '())
         (case proc
-          ((putStr) (display (x->string (car args*))))
-          ((putStrLn) (apply prim-print args*))
-          ((print) (apply prim-print args*))
-          ((lines) (length args*))
-          ((length) (if (tagged? :string (car args*))
+          [(putStr) (display (x->string (car args*)))]
+          [(putStrLn) (apply prim-print args*)]
+          [(print) (apply prim-print args*)]
+          [(lines) (length args*)]
+          [(length) (if (tagged? :string (car args*))
                                         (string-length (car args*))
-                                        (length (car args*))))
-          ((tail) (prim-tail (car args*)))
+                                        (length (car args*)))]
+          [(tail) (prim-tail (car args*))]
+
+          [(*) (apply * args*)]
+          [(+) (apply + args*)]
+          [(/) (apply / args*)]
+          [(-) (apply - args*)]
+;         [else (error "unknown primitive: " proc)]
           )))
 
@@ -252 +385 @@
 (define (procedure-environment proc) (fourth proc))
 
+; SICP pp225-226
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
 (define (make-frame vars vals) (cons vars vals))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
 
 (define (extend-environment vars vals base-env)
   ;; assert-equal (length vars) (length vals)
   (cons (make-frame vars vals) base-env))
+
+(define (lookup-variable-value var env)
+  (define (env-loop env)
+        (define (scan vars vals)
+          (cond [(null? vars)
+                         (env-loop (enclosing-environment env))]
+                        [(eq? var (car vars))
+                         (car vals)]
+                        [else (scan (cdr vars) (cdr vals))]))
+        (if (eq? env the-empty-environment)
+                #f ; (error "unbound variable" var)
+                (let1 frame (first-frame env)
+                  (scan (frame-variables frame)
+                                (frame-values frame)))))
+  (env-loop env))
+
+(define (last-exp? seq) (null? (cdr seq)))
+(define (heval-sequence exps env)
+  (cond [(last-exp? exps) (heval (car exps) env)]
+                [else (heval (car exps) env)
+                          (heval-sequence (cdr exps) env)]))
 
 (define (happly proc args)
@@ -265 +426 @@
                                                                            args
                                                                            (procedure-environment proc))
-                   (heval-map (procedure-body proc) env))]
+                   (heval-sequence (procedure-body proc) env))]
                 [else
                  ;
@@ -274 +435 @@
   (let1 input (read-line)
         (if (eof-object? input) 'eof
-                (let1 parsed (parse-haskell input); (haskell->scheme input)
-                  (let1 evaled (heval parsed '())
+                (begin
+                  (when (and (string? input) (< 0 (string-length input)))
                         (print "> " input)
-                        (print "=> " parsed)
-                        (print "" evaled))
+                        (let1 parsed (parse-haskell input); (haskell->scheme input)
+                          (print "=> " parsed)
+                          (let1 evaled (heval parsed '())
+                                (print "=> " evaled)
+                                                                                ;                         (if evaled (print ": " (heval evaled '())))
+                                ))
+                        (print ""))
                   (repl)))))
 
-(define (actual-value exp); env)
-  (force-it (heval exp '())))
-
-(let1 main (lookup 'main)
-  (print "----")
-   (happly main '())
-   )
+;(define (actual-value exp); env)
+;  (if (and (pair? exp) (tagged? ':apply exp))
+;         (
+;  (force-it (heval exp '())))
+
+(let1 main (lookup 'main '())
+  (print "====")
+  (happly main '())
+  )