- Timestamp:
- 03/03/08 23:09:07 (17 years ago)
- 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 ;; 1 4 (use srfi-1) 2 5 … … 23 26 [%body-char ($or %unescaped)] 24 27 [%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)))] 26 30 ) 27 31 ($between %dquote %string-body %dquote))) 32 33 (define %char 34 ($do (($char #\')) 35 (($optional ($char #\\))) 36 (ch anychar) 37 (($char #\')) 38 ; ($return (tag :char ch)) 39 ($return ch) 40 )) 28 41 29 42 (define %ident ;; scheme-symbolで代用 … … 32 45 ($do (head %ident-head-char) 33 46 (rest ($many %ident-rest-char)) 47 ; ($return (tag :ident (string->symbol (list->string (cons head rest)))))))) 34 48 ($return (string->symbol (list->string (cons head rest))))))) 35 49 36 50 (define %digits 37 51 ($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))))) 39 54 40 55 (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 #\])] 43 58 [%item ($or %digits %string %ident)] 44 59 [%item-separator ($seq %ws ($char #\,) %ws)] … … 51 66 52 67 (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 #\))] 55 70 [%item ($or %digits %string %ident)] 56 71 [%item-separator ($seq %ws ($char #\,) %ws)] … … 62 77 )) 63 78 79 (define %atomic 80 ($or %string %char %digits %ident %list %tuple)) 81 82 (define (char->symbol ch) 83 (string->symbol (x->string ch))) 84 85 (define %infixed 86 (let1 %infix ($or ($one-of #[-+*/<>]) 87 ($string "==") ($string "<=") ($string ">=")) 88 ($do (item1 %atomic);($or %application %atomic)) ;%atomic) 89 ; (seq ($do %ws 90 ; (infix %infix) 91 ; %ws 92 ; (rest ($or %infixed %atomic)) 93 ; ($return (cons infix rest)))) 94 %ws 95 (infix %infix) 96 %ws 97 (item2 %atomic);($or %application %atomic)) ;%atomic) 98 (rest ($many ($do %ws 99 (infix %infix) 100 %ws 101 (item %atomic);($or %application %atomic)) ;%atomic) 102 ($return (list (char->symbol infix) item))))) 103 ($return (let1 expr (append (list item1 (char->symbol infix) item2) 104 (apply append rest)) 105 (case (length expr) 106 ((3) 107 (list ':apply (second expr) (first expr) (third expr))) 108 ((5) ; 優先度まだ 109 (list ':apply (fourth expr) 110 (list ':apply (second expr) (first expr) (third expr)) 111 (fifth expr))) 112 ))) 113 ;(tag :infixed (append (list item1 (char->symbol infix) item2) 114 ;(apply append rest)))) 115 ))) 116 ; (seq ($or ($do %ws 117 ; (infix %infix) 118 ; %ws 119 ; (rest %infixed) 120 ; ($return (cons infix rest))) 121 ; ($do %ws 122 ; (infix %infix) 123 ; %ws 124 ; (rest %atomic) 125 ; ($return (list infix rest))) )) 126 ; ($return (tag :infixed (cons elem1 seq)))))) 127 64 128 (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))))) 66 151 67 152 (define %application … … 69 154 ($do (fn %ident) 70 155 %ws 156 (arg1 ($or %expr 157 ($between ($char #\() %expr ($char #\))))) 158 %ws 71 159 (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)) 74 162 (apps ($many ($do %ws 75 (($char #\$)) 163 (($char #\$)) ; " $ " 76 164 %ws 77 (app %an-application)165 (app ($or %infixed %an-application %lambda %ident)) 78 166 ($return app)))) 79 167 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) 80 168 169 (define %lambda 170 ($do (($char #\\)) 171 (vars ($my-sep-by %ident %ws)) 172 %ws 173 (($string "->")) 174 %ws 175 (body ($or %do %infixed %application %expr)) 176 ($return (tag ':lambda (list vars body))))) 177 178 (define %assignment 179 ($do (id %ident) 180 %ws 181 (($string "<-")) 182 %ws 183 (value ($or %infixed %application %expr)) 184 ($return `(:assign ,id ,value)) 185 )) 186 187 (define %do 188 (let1 %do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws) 189 ($do (($string "do")) 190 %ws 191 (exprs ($or ($between ($seq ($char #\{) %ws) 192 ($my-sep-by ($or %assignment %infixed %application %expr) 193 ($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws)) 194 ($seq %ws ($char #\}))) 195 ($my-sep-by ($or %assignment %infixed %application %expr) 196 ($seq newline ($string " ") %ws)) )) 197 ($return `(:do ,@exprs))))) 198 199 (define %defun 200 ($do (id %ident) 201 %ws 202 (args ($my-sep-by %ident %ws)) 203 %ws 204 (($char #\=)) 205 %ws 206 (rightside ($or %do %infixed %application %expr)) 207 ($return `(:defun (,id ,@args) ,rightside)) 208 )) 209 210 (define %pattern 211 ($do (id %ident) 212 %ws 213 (args ($my-sep-by ($or %ident %digits) %ws)) 214 %ws 215 (($char #\=)) 216 %ws 217 (rightside ($or %do %infixed %application %expr)) 218 ($return `(:pattern (,id ,@args) ,rightside)) 219 )) 220 81 221 (define %haskell 82 222 (let* ([%unknown ($my-sep-by %expr %ws)] 83 84 [%assignment ($do (id %ident)85 %ws86 (($string "<-"))87 %ws88 (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 %ws94 (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 %ws104 (args ($my-sep-by %ident %ws))105 %ws106 (($char #\=))107 %ws108 (rightside ($or %do %application))109 ($return `(:defun (,id ,@args) ,rightside))110 )]111 [%pattern ($do (id %ident)112 %ws113 (args ($my-sep-by ($or %ident %digits) %ws))114 %ws115 (($char #\=))116 %ws117 (rightside ($or %do %application))118 ($return `(:pattern (,id ,@args) ,rightside))119 )]120 121 223 ) 122 ($or %defun %pattern %assignment %application %expr 123 %unknown) 224 ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr 225 %unknown 226 newline) 124 227 )) 125 228 … … 134 237 ;(define ident-body untag) 135 238 239 (define lambda? (tagged?$ :lambda)) 240 136 241 (define (indent w lines) 137 242 (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) … … 143 248 (hash-table-put! *namespace* id val) 144 249 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)))) 149 254 150 255 ;; … … 155 260 (define (heval-map exps env) (map (cut heval <> env) exps)) 156 261 (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 )])) 207 332 208 333 (define (primitive-procedure? proc) … … 210 335 putStrLn 211 336 lines length print 212 tail))) 337 tail 338 * + - /))) 213 339 214 340 (define (prim-print exp) … … 223 349 (list->haskell-string (untag obj))] 224 350 [(pair? obj) (haskell-description-of-list obj)] 351 [(number? obj) (number->string obj)] 352 [(string? obj) obj] 225 353 [else (x->string obj)])) 226 227 354 (print (haskell-description exp))) 228 355 … … 236 363 (let1 args* (heval-map args '()) 237 364 (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*)) 243 370 (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)] 246 379 ))) 247 380 … … 252 385 (define (procedure-environment proc) (fourth proc)) 253 386 387 ; SICP pp225-226 388 (define (enclosing-environment env) (cdr env)) 389 (define (first-frame env) (car env)) 390 (define the-empty-environment '()) 391 254 392 (define (make-frame vars vals) (cons vars vals)) 393 (define (frame-variables frame) (car frame)) 394 (define (frame-values frame) (cdr frame)) 255 395 256 396 (define (extend-environment vars vals base-env) 257 397 ;; assert-equal (length vars) (length vals) 258 398 (cons (make-frame vars vals) base-env)) 399 400 (define (lookup-variable-value var env) 401 (define (env-loop env) 402 (define (scan vars vals) 403 (cond [(null? vars) 404 (env-loop (enclosing-environment env))] 405 [(eq? var (car vars)) 406 (car vals)] 407 [else (scan (cdr vars) (cdr vals))])) 408 (if (eq? env the-empty-environment) 409 #f ; (error "unbound variable" var) 410 (let1 frame (first-frame env) 411 (scan (frame-variables frame) 412 (frame-values frame))))) 413 (env-loop env)) 414 415 (define (last-exp? seq) (null? (cdr seq))) 416 (define (heval-sequence exps env) 417 (cond [(last-exp? exps) (heval (car exps) env)] 418 [else (heval (car exps) env) 419 (heval-sequence (cdr exps) env)])) 259 420 260 421 (define (happly proc args) … … 265 426 args 266 427 (procedure-environment proc)) 267 (heval- map(procedure-body proc) env))]428 (heval-sequence (procedure-body proc) env))] 268 429 [else 269 430 ; … … 274 435 (let1 input (read-line) 275 436 (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))) 278 439 (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 "")) 281 447 (repl))))) 282 448 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!" 2 putStrLn "Hello, World!" 3 5 * 6 - 7 4 print $ 5 * 6 - 7 5 \x -> x * x $ 5 * 6 - 7 6 print $ \x -> x * x $ 5 * 6 - 7 7 [1,2,3,4] 8 print [1,2,3,4] 9 tail [1,2,3] 10 print $ tail [1,2,3] 2 11 3 -- main = do { cs <- getContents ; print $ length $ lines cs } 12 print if 1 then '@' else '*' 13 -- if c == '\t' then '@' else c 14 \num -> num * num 15 \x -> x 16 3 + 4 17 4 * 5 - 1 4 18 5 19 firstNLines n cs = unlines $ take n $ lines cs 6 20 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] 21 f1 = do { cs <- getContents ; print $ length $ lines cs } 22 f2 = print $ 5 + 2 * 5 23 f3 = print $ tail [1,2,3] 24 f4 = tail [1,2,3] 13 25 14 26 fib 0 = 0 … … 16 28 fib n = fib (n-1) + fib (n-2) 17 29 30 square n = n * n 31 triple a = a + a + a 32 33 main = putStrLn "Hello, World!" 34 35 main = print $ 5 * 6 - 7 36 -- main = print $ \x -> x * x $ 5 * 6 - 7 -
hh2008/naoya_t/trunk/test.sh
r18 r22 1 1 #!/bin/sh 2 sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm3 2 # sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm 3 gosh -I. ihci.scm < test.hs
