[22] | 1 | ;; |
---|
| 2 | ;; IHC - Ikoma Haskell Compiler |
---|
| 3 | ;; |
---|
[18] | 4 | (use srfi-1) |
---|
| 5 | |
---|
| 6 | (define *undefined* (if #f #f)) |
---|
| 7 | |
---|
| 8 | (define (tagged? tag obj) (and (pair? obj) (eq? (car obj) tag))) |
---|
| 9 | (define (tagged?$ tag) (lambda (obj) (and (pair? obj) (eq? (car obj) tag)))) |
---|
| 10 | (define (tag t obj) (cons t obj)) |
---|
| 11 | (define (tag$ t) (lambda (obj) (cons t obj))) |
---|
| 12 | (define (untag obj) (cdr obj)) |
---|
| 13 | |
---|
| 14 | (use peg) |
---|
| 15 | |
---|
| 16 | (define (nil-if-true l) (if (eq? #t l) '() l)) |
---|
| 17 | (define ($my-sep-by parse sep . args) |
---|
| 18 | ($do (them ($sep-by parse sep)) |
---|
| 19 | ($return (nil-if-true them)))) |
---|
| 20 | |
---|
| 21 | (define %ws ($many ($one-of #[ \t\r\n]))) |
---|
| 22 | |
---|
| 23 | (define %string ; scheme-string で代用 |
---|
| 24 | (let* ([%dquote ($char #\")] |
---|
| 25 | [%unescaped ($none-of #[\"])] |
---|
| 26 | [%body-char ($or %unescaped)] |
---|
| 27 | [%string-body ($do (chars ($many %body-char)) |
---|
[22] | 28 | ; ($return (tag :string (list->string chars))))] |
---|
| 29 | ($return (list->string chars)))] |
---|
[18] | 30 | ) |
---|
| 31 | ($between %dquote %string-body %dquote))) |
---|
| 32 | |
---|
[22] | 33 | (define %char |
---|
| 34 | ($do (($char #\')) |
---|
| 35 | (($optional ($char #\\))) |
---|
| 36 | (ch anychar) |
---|
| 37 | (($char #\')) |
---|
| 38 | ; ($return (tag :char ch)) |
---|
| 39 | ($return ch) |
---|
| 40 | )) |
---|
| 41 | |
---|
[18] | 42 | (define %ident ;; scheme-symbolで代用 |
---|
| 43 | (let* ([%ident-head-char ($one-of #[a-z_])] |
---|
| 44 | [%ident-rest-char ($one-of #[0-9A-Za-z_'])]) |
---|
| 45 | ($do (head %ident-head-char) |
---|
| 46 | (rest ($many %ident-rest-char)) |
---|
[22] | 47 | ; ($return (tag :ident (string->symbol (list->string (cons head rest)))))))) |
---|
[18] | 48 | ($return (string->symbol (list->string (cons head rest))))))) |
---|
| 49 | |
---|
| 50 | (define %digits |
---|
| 51 | ($do (d ($many digit 1)) |
---|
[22] | 52 | ; ($return (tag :number (string->number (list->string d)))))) |
---|
| 53 | ($return (string->number (list->string d))))) |
---|
[18] | 54 | |
---|
| 55 | (define %list |
---|
[22] | 56 | (let* ([%begin-list ($char #\[)] |
---|
| 57 | [%end-list ($char #\])] |
---|
[18] | 58 | [%item ($or %digits %string %ident)] |
---|
| 59 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
| 60 | ) |
---|
| 61 | ($do %begin-list |
---|
| 62 | (items ($my-sep-by %item %item-separator)) |
---|
| 63 | %end-list |
---|
| 64 | ($return (tag :list items))) |
---|
| 65 | )) |
---|
| 66 | |
---|
| 67 | (define %tuple |
---|
[22] | 68 | (let* ([%begin-list ($char #\()] |
---|
| 69 | [%end-list ($char #\))] |
---|
[18] | 70 | [%item ($or %digits %string %ident)] |
---|
| 71 | [%item-separator ($seq %ws ($char #\,) %ws)] |
---|
| 72 | ) |
---|
| 73 | ($do %begin-list |
---|
| 74 | (items ($my-sep-by %item %item-separator)) |
---|
| 75 | %end-list |
---|
| 76 | ($return (tag :tuple @items))) |
---|
| 77 | )) |
---|
| 78 | |
---|
[22] | 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 | |
---|
[18] | 128 | (define %expr |
---|
[22] | 129 | ($or %infixed |
---|
| 130 | ; ($between ($char #\() %expr ($char #\))) |
---|
| 131 | %if %atomic)) |
---|
[18] | 132 | |
---|
[22] | 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))))) |
---|
| 151 | |
---|
[18] | 152 | (define %application |
---|
| 153 | (let1 %an-application |
---|
| 154 | ($do (fn %ident) |
---|
| 155 | %ws |
---|
[22] | 156 | (arg1 ($or %expr |
---|
| 157 | ($between ($char #\() %expr ($char #\))))) |
---|
| 158 | %ws |
---|
[18] | 159 | (args ($my-sep-by %expr %ws)) |
---|
[22] | 160 | ($return `(:apply ,fn ,arg1 ,@args))) |
---|
| 161 | ($do (app1 ($or %infixed %an-application %lambda %ident)) |
---|
[18] | 162 | (apps ($many ($do %ws |
---|
[22] | 163 | (($char #\$)) ; " $ " |
---|
[18] | 164 | %ws |
---|
[22] | 165 | (app ($or %infixed %an-application %lambda %ident)) |
---|
[18] | 166 | ($return app)))) |
---|
| 167 | ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) |
---|
| 168 | |
---|
[22] | 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 | |
---|
[18] | 221 | (define %haskell |
---|
| 222 | (let* ([%unknown ($my-sep-by %expr %ws)] |
---|
| 223 | ) |
---|
[22] | 224 | ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr |
---|
| 225 | %unknown |
---|
| 226 | newline) |
---|
[18] | 227 | )) |
---|
| 228 | |
---|
| 229 | (define (parse-haskell str) |
---|
| 230 | (parse-string %haskell str)) |
---|
| 231 | |
---|
| 232 | (define putStrLn print) |
---|
| 233 | |
---|
| 234 | (define ident? symbol?) |
---|
| 235 | (define ident-body identity) |
---|
| 236 | ;(define ident? (tagged?$ :ident)) |
---|
| 237 | ;(define ident-body untag) |
---|
| 238 | |
---|
[22] | 239 | (define lambda? (tagged?$ :lambda)) |
---|
| 240 | |
---|
[18] | 241 | (define (indent w lines) |
---|
| 242 | (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) |
---|
| 243 | lines) |
---|
| 244 | "\n")) |
---|
| 245 | |
---|
| 246 | (define *namespace* (make-hash-table)) |
---|
| 247 | (define (assign id val) |
---|
| 248 | (hash-table-put! *namespace* id val) |
---|
| 249 | id) |
---|
| 250 | |
---|
[22] | 251 | (define (lookup id env) |
---|
| 252 | (let1 val (lookup-variable-value id env) |
---|
| 253 | (if val val (hash-table-get *namespace* id)))) |
---|
| 254 | |
---|
[18] | 255 | ;; |
---|
| 256 | (define (make-procedure params body env) |
---|
| 257 | (list :procedure params body env)) |
---|
| 258 | |
---|
| 259 | (use util.match) |
---|
| 260 | (define (heval-map exps env) (map (cut heval <> env) exps)) |
---|
| 261 | (define (heval exp env) |
---|
[22] | 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 | ] |
---|
[18] | 281 | |
---|
[22] | 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 | )] |
---|
[18] | 289 | |
---|
[22] | 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 | )])) |
---|
| 332 | |
---|
[18] | 333 | (define (primitive-procedure? proc) |
---|
| 334 | (memq proc '(putStr |
---|
| 335 | putStrLn |
---|
| 336 | lines length print |
---|
[22] | 337 | tail |
---|
| 338 | * + - /))) |
---|
[18] | 339 | |
---|
| 340 | (define (prim-print exp) |
---|
| 341 | (define (haskell-description-of-list l) |
---|
| 342 | (string-append "[" (string-join (map haskell-description l) ",") "]")) |
---|
| 343 | |
---|
| 344 | (define (haskell-description obj) |
---|
| 345 | (cond [(not (pair? obj)) (x->string obj)] |
---|
| 346 | [(tagged? :number obj) (number->string (untag obj))] |
---|
| 347 | [(tagged? :string obj) (untag obj)] |
---|
| 348 | [(tagged? :list obj) ; (untag obj)] |
---|
| 349 | (list->haskell-string (untag obj))] |
---|
| 350 | [(pair? obj) (haskell-description-of-list obj)] |
---|
[22] | 351 | [(number? obj) (number->string obj)] |
---|
| 352 | [(string? obj) obj] |
---|
[18] | 353 | [else (x->string obj)])) |
---|
| 354 | (print (haskell-description exp))) |
---|
| 355 | |
---|
| 356 | (define (prim-tail exp) |
---|
| 357 | (cond [(tagged? :string exp) (substring (cdr exp) 1 (string-length (cdr exp)))] |
---|
| 358 | [(tagged? :list exp) (cddr exp)] |
---|
| 359 | [(pair? exp) (cdr exp)] |
---|
| 360 | [else *undefined*])) |
---|
| 361 | |
---|
| 362 | (define (apply-primitive-procedure proc args) |
---|
| 363 | (let1 args* (heval-map args '()) |
---|
| 364 | (case proc |
---|
[22] | 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*)) |
---|
[18] | 370 | (string-length (car args*)) |
---|
[22] | 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)] |
---|
[18] | 379 | ))) |
---|
| 380 | |
---|
| 381 | (define (compound-procedure? proc) (tagged? :procedure proc)) |
---|
| 382 | |
---|
| 383 | (define (procedure-parameters proc) (second proc)) |
---|
| 384 | (define (procedure-body proc) (third proc)) |
---|
| 385 | (define (procedure-environment proc) (fourth proc)) |
---|
| 386 | |
---|
[22] | 387 | ; SICP pp225-226 |
---|
| 388 | (define (enclosing-environment env) (cdr env)) |
---|
| 389 | (define (first-frame env) (car env)) |
---|
| 390 | (define the-empty-environment '()) |
---|
| 391 | |
---|
[18] | 392 | (define (make-frame vars vals) (cons vars vals)) |
---|
[22] | 393 | (define (frame-variables frame) (car frame)) |
---|
| 394 | (define (frame-values frame) (cdr frame)) |
---|
[18] | 395 | |
---|
| 396 | (define (extend-environment vars vals base-env) |
---|
| 397 | ;; assert-equal (length vars) (length vals) |
---|
| 398 | (cons (make-frame vars vals) base-env)) |
---|
| 399 | |
---|
[22] | 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)])) |
---|
| 420 | |
---|
[18] | 421 | (define (happly proc args) |
---|
| 422 | (cond [(primitive-procedure? proc) |
---|
| 423 | (apply-primitive-procedure proc args)] |
---|
| 424 | [(compound-procedure? proc) |
---|
| 425 | (let1 env (extend-environment (procedure-parameters proc) |
---|
| 426 | args |
---|
| 427 | (procedure-environment proc)) |
---|
[22] | 428 | (heval-sequence (procedure-body proc) env))] |
---|
[18] | 429 | [else |
---|
| 430 | ; |
---|
| 431 | ])) |
---|
| 432 | |
---|
| 433 | ;; REPL |
---|
| 434 | (let repl () |
---|
| 435 | (let1 input (read-line) |
---|
| 436 | (if (eof-object? input) 'eof |
---|
[22] | 437 | (begin |
---|
| 438 | (when (and (string? input) (< 0 (string-length input))) |
---|
[18] | 439 | (print "> " input) |
---|
[22] | 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 "")) |
---|
[18] | 447 | (repl))))) |
---|
| 448 | |
---|
[22] | 449 | ;(define (actual-value exp); env) |
---|
| 450 | ; (if (and (pair? exp) (tagged? ':apply exp)) |
---|
| 451 | ; ( |
---|
| 452 | ; (force-it (heval exp '()))) |
---|
[18] | 453 | |
---|
[22] | 454 | (let1 main (lookup 'main '()) |
---|
| 455 | (print "====") |
---|
| 456 | (happly main '()) |
---|
| 457 | ) |
---|