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

Files:

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

hh2008/naoya_t/trunk/ihci.scm

@@ -1 @@
-;;
-;; IHC - Ikoma Haskell Compiler
-;;
 (use srfi-1)
 
@@ -26 +23 @@
          [%body-char ($or %unescaped)]
          [%string-body ($do (chars ($many %body-char))
-;                                                       ($return (tag :string (list->string chars))))]
-                                                        ($return (list->string chars)))]
+                                                        ($return (tag :string (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で代用
@@ -45 +32 @@
         ($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 (string->number (list->string d)))))
+           ($return (tag :number (string->number (list->string d))))))
 
 (define %list
-  (let* ([%begin-list ($char #\[)]
-                 [%end-list ($char #\])]
+  (let* ([%begin-list ($seq %ws ($char #\[) %ws)]
+                 [%end-list ($seq %ws ($char #\]) %ws)]
                  [%item ($or %digits %string %ident)]
                  [%item-separator ($seq %ws ($char #\,) %ws)]
@@ -66 +51 @@
 
 (define %tuple
-  (let* ([%begin-list ($char #\()]
-                 [%end-list ($char #\))]
+  (let* ([%begin-list ($seq %ws ($char #\() %ws)]
+                 [%end-list ($seq %ws ($char #\)) %ws)]
                  [%item ($or %digits %string %ident)]
                  [%item-separator ($seq %ws ($char #\,) %ws)]
@@ -77 +62 @@
         ))
 
-(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 %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)))))
+  ($or %string %digits %ident %list %tuple))
 
 (define %application
@@ -154 +69 @@
           ($do (fn %ident)
                    %ws
-                   (arg1 ($or %expr
-                                          ($between ($char #\() %expr ($char #\)))))
-                   %ws
                    (args ($my-sep-by %expr %ws))
-                   ($return `(:apply ,fn ,arg1 ,@args)))
-        ($do (app1 ($or %infixed %an-application %lambda %ident))
+                   ($return `(:apply ,fn ,@args)))
+        ($do (app1 %an-application)
                  (apps ($many ($do %ws
-                                                   (($char #\$)) ; " $ "
+                                                   (($char #\$))
                                                    %ws
-                                                   (app ($or %infixed %an-application %lambda %ident))
+                                                   (app %an-application)
                                                    ($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)]
-                 )
-        ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr
-                 %unknown
-                 newline)
+                 
+                 [%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)
         ))
 
@@ -237 +134 @@
 ;(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)))
@@ -248 +143 @@
   (hash-table-put! *namespace* id val)
   id)
-
-(define (lookup id env)
-  (let1 val (lookup-variable-value id env)
-        (if val val (hash-table-get *namespace* id))))
+(define (lookup id)
+  (let1 val (hash-table-get *namespace* id)
+        ;
+        val))
 
 ;;
@@ -260 +155 @@
 (define (heval-map exps env) (map (cut heval <> env) exps))
 (define (heval exp env)
-;  (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))]
-
-                                )]))
+  (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))] )))
 
 (define (primitive-procedure? proc)
@@ -335 +210 @@
                            putStrLn
                            lines length print
-                           tail
-                           * + - /)))
+                           tail)))
 
 (define (prim-print exp)
@@ -349 +223 @@
                    (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)))
 
@@ -363 +236 @@
   (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*))]
-
-          [(*) (apply * args*)]
-          [(+) (apply + args*)]
-          [(/) (apply / args*)]
-          [(-) (apply - args*)]
-;         [else (error "unknown primitive: " proc)]
+                                        (length (car args*))))
+          ((tail) (prim-tail (car args*)))
           )))
 
@@ -385 +252 @@
 (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)
@@ -426 +265 @@
                                                                            args
                                                                            (procedure-environment proc))
-                   (heval-sequence (procedure-body proc) env))]
+                   (heval-map (procedure-body proc) env))]
                 [else
                  ;
@@ -435 +274 @@
   (let1 input (read-line)
         (if (eof-object? input) 'eof
-                (begin
-                  (when (and (string? input) (< 0 (string-length input)))
+                (let1 parsed (parse-haskell input); (haskell->scheme input)
+                  (let1 evaled (heval parsed '())
                         (print "> " input)
-                        (let1 parsed (parse-haskell input); (haskell->scheme input)
-                          (print "=> " parsed)
-                          (let1 evaled (heval parsed '())
-                                (print "=> " evaled)
-                                                                                ;                         (if evaled (print ": " (heval evaled '())))
-                                ))
-                        (print ""))
+                        (print "=> " parsed)
+                        (print "" evaled))
                   (repl)))))
 
-;(define (actual-value exp); env)
-;  (if (and (pair? exp) (tagged? ':apply exp))
-;         (
-;  (force-it (heval exp '())))
-
-(let1 main (lookup 'main '())
-  (print "====")
-  (happly main '())
-  )
+(define (actual-value exp); env)
+  (force-it (heval exp '())))
+
+(let1 main (lookup 'main)
+  (print "----")
+   (happly main '())
+   )