Index: hh2008/naoya_t/trunk/test.hs
===================================================================
--- hh2008/naoya_t/trunk/test.hs (revision 18)
+++ hh2008/naoya_t/trunk/test.hs (revision 22)
@@ -1,14 +1,26 @@
-main = putStrLn "Hello, World!"
+"Hello, World!"
+putStrLn "Hello, World!"
+5 * 6 - 7
+print $ 5 * 6 - 7
+\x -> x * x $ 5 * 6 - 7
+print $ \x -> x * x $ 5 * 6 - 7
+[1,2,3,4]
+print [1,2,3,4]
+tail [1,2,3]
+print $ tail [1,2,3]
 
--- main = do { cs <- getContents ; print $ length $ lines cs }
+print if 1 then '@' else '*'
+-- if c == '\t' then '@' else c
+\num -> num * num
+\x -> x
+3 + 4
+4 * 5 - 1
 
 firstNLines n cs = unlines $ take n $ lines cs
 
--- main = print $ 5 + 2 * 5
-rmain = print $ tail [1,2,3]
--- main = tail [1,2,3]
-
-tail [1,2,3]
-print [1,2,3,4]
+f1 = do { cs <- getContents ; print $ length $ lines cs }
+f2 = print $ 5 + 2 * 5
+f3 = print $ tail [1,2,3]
+f4 = tail [1,2,3]
 
 fib 0 = 0
@@ -16,2 +28,9 @@
 fib n = fib (n-1) + fib (n-2)
 
+square n = n * n
+triple a = a + a + a
+
+main = putStrLn "Hello, World!"
+
+main = print $ 5 * 6 - 7
+-- main = print $ \x -> x * x $ 5 * 6 - 7
Index: hh2008/naoya_t/trunk/test.sh
===================================================================
--- hh2008/naoya_t/trunk/test.sh (revision 18)
+++ hh2008/naoya_t/trunk/test.sh (revision 22)
@@ -1,3 +1,3 @@
 #!/bin/sh
-sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm
-
+# sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm
+gosh -I. ihci.scm < test.hs
Index: hh2008/naoya_t/trunk/ihci.scm
===================================================================
--- hh2008/naoya_t/trunk/ihci.scm (revision 18)
+++ hh2008/naoya_t/trunk/ihci.scm (revision 22)
@@ -1,2 +1,5 @@
+;;
+;; IHC - Ikoma Haskell Compiler
+;;
 (use srfi-1)
 
@@ -23,7 +26,17 @@
          [%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,13 +45,15 @@
 	($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,6 +66,6 @@
 
 (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,6 +77,76 @@
 	))
 
+(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,57 +154,75 @@
 	  ($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,4 +237,6 @@
 ;(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,8 +248,8 @@
   (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,54 +260,74 @@
 (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,5 +335,6 @@
 			   putStrLn
 			   lines length print
-			   tail)))
+			   tail
+			   * + - /)))
 
 (define (prim-print exp)
@@ -223,6 +349,7 @@
 		   (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,12 +363,18 @@
   (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,9 +385,37 @@
 (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,5 +426,5 @@
 									   args
 									   (procedure-environment proc))
-		   (heval-map (procedure-body proc) env))]
+		   (heval-sequence (procedure-body proc) env))]
 		[else
 		 ;
@@ -274,16 +435,23 @@
   (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 '())
+  )