modules/language/python/compile.scm

   1 (define-module (language python compile)
   2   #:use-module (ice-9 match)
   3   #:use-module (ice-9 pretty-print)
   4   #:export (comp))
   5
   6 (define (fold f init l)
   7   (if (pair? l)
   8       (fold f (f (car l) init) (cdr l))
   9       init))
  10
  11 (define (pr . x)
  12   (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
  13   (with-output-to-port port
  14     (lambda ()
  15       (pretty-print x)))
  16   (close port)
  17   (car (reverse x)))
  18
  19 (define (pf x)
  20   (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
  21   (with-output-to-port port
  22     (lambda () (pretty-print (syntax->datum x)) x))
  23   (close port)
  24   x)
  25
  26 (define (C x) `(@@ (language python compile) ,x))
  27 (define (O x) `(@@ (oop pf-objects) ,x))
  28 (define (G x) `(@ (guile) ,x))
  29
  30 (define (union as vs)
  31   (let lp ((as as) (vs vs))
  32     (match as
  33       ((x . as)
  34        (if (member x vs)
  35            (lp as vs)
  36            (lp as (cons x vs))))
  37       (()
  38        vs))))
  39
  40 (define (diff as vs)
  41   (let lp ((as as) (rs '()))
  42     (match as
  43       ((x . as)
  44        (if (member x vs)
  45            (lp as rs)
  46            (lp as (cons x rs))))
  47       (()
  48        rs))))
  49
  50 (define (get-globals code)
  51   (let lp ((vs (glob code '())) (rs (scope code '())))
  52     (match vs
  53       ((x . l)
  54        (if (member x rs)
  55            (lp l rs)
  56            (lp l (cons x rs))))
  57       (()
  58        rs))))
  59
  60 (define (glob x vs)
  61   (match x
  62     ((#:global . l)
  63      (let lp ((l l) (vs vs))
  64        (match l
  65          (((#:identifier v . _) . l)
  66           (let ((s (string->symbol v)))
  67             (if (member s vs)
  68                 (lp l vs)
  69                 (lp l (cons s vs)))))
  70          (()
  71           vs))))
  72     ((x . y)
  73      (glob y (glob x vs)))
  74     (x vs)))
  75
  76 (define (scope x vs)
  77   (match x
  78     ((#:def  (#:identifier f . _) . _)
  79      (union (list (string->symbol f)) vs))
  80     ((#:lambdef . _)
  81      vs)
  82     ((#:classdef . _)
  83      vs)
  84     ((#:global . _)
  85      vs)
  86     ((#:identifier v . _)
  87      (let ((s (string->symbol v)))
  88        (if (member s vs)
  89            vs
  90            (cons s vs))))
  91     ((x . y)
  92      (scope y (scope x vs)))
  93     (_ vs)))
  94
  95 (define (defs x vs)
  96   (match x
  97     ((#:def  (#:identifier f . _) . _)
  98      (union (list (string->symbol f)) vs))
  99     ((#:lambdef . _)
 100      vs)
 101     ((#:class . _)
 102      vs)
 103     ((#:global . _)
 104      vs)
 105     ((x . y)
 106      (defs y (defs x vs)))
 107     (_ vs)))
 108
 109 (define (g vs e)
 110   (lambda (x) (e vs x)))
 111
 112 (define return (make-fluid 'error-return))
 113
 114 (define (make-set vs x u)
 115   (match x
 116     ((#:test (#:power (#:identifier v . _) addings . _) . _)
 117      (let ((v (string->symbol v)))
 118        (if (null? addings)
 119            `(set! ,v ,u)
 120            (let* ((rev (reverse addings))
 121                   (las (car rev))
 122                   (new (reverse (cdr rev))))
 123              `(,(O 'set) ,(let lp ((v v) (new new))
 124                              (match new
 125                                ((x . new)
 126                                 (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
 127                                (() v)))
 128                ',(exp vs las) ,u)))))))
 129
 130
 131
 132 (define (exp vs x)
 133   (match (pr x)
 134     ((#:power x () . #f)
 135      (exp vs x))
 136
 137     ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
 138     ((#:power vf ((and trailer (#:identifier _ . _)) ...
 139                   (#:arglist (args ...) #f #f)) . #f)
 140      (let ((args (map (g vs exp) args)))
 141        (match vf
 142          ((#:f (#:identifier f . _) e)
 143           (let ((obj  (gensym "obj"))
 144                 (l    (gensym "l")))
 145             '(call-with-values (lambda () (fcall (,(exp vs e)
 146                                                   ,@(map (g vd exp) trailer))
 147                                                  ,@args))
 148                (lambda (,obj . ,l)
 149                  `(set! ,(string->symbol f) ,obj)
 150                  (apply 'values ,l)))))
 151          (x
 152           `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
 153
 154     ((#:identifier x . _)
 155      (string->symbol x))
 156
 157     ((#:string x)
 158      x)
 159
 160     (((and x (or #:+ #:- #:* #:/)) . l)
 161      (cons (keyword->symbol x) (map (g vs exp) l)))
 162
 163     ((#:u~ x)
 164      (list 'lognot (exp vs x)))
 165
 166     ((#:band . l)
 167      (cons 'logand (map (g vs exp) l)))
 168
 169     ((#:bxor . l)
 170      (cons 'logxor (map (g vs exp) l)))
 171
 172     ((#:bor . l)
 173      (cons 'logior (map (g vs exp) l)))
 174
 175     ((#:not x)
 176      (list 'not (exp vs x)))
 177
 178     ((#:or . x)
 179      (cons 'or (map (g vs exp) x)))
 180
 181     ((#:and . x)
 182      (cons 'and (map (g vs exp) x)))
 183
 184     ((#:test e1 #f)
 185      (exp vs e1))
 186
 187     ((#:test e1 e2 e3)
 188      (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
 189
 190     ((#:if test a ((tests . as) ...) . else)
 191      `(,(G 'cond)
 192        (,(exp vs test) ,(exp vs a))
 193        ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
 194        ,@(if else `((else ,(exp vs else))) '())))
 195
 196     ((#:suite . l) (cons 'begin (map (g vs exp) l)))
 197
 198     ((#:try x #f #f fin)
 199      `(dynamic-wind
 200         (lambda () #f)
 201         (lambda () ,(exp vs x))
 202         (lambda () ,(exp vs fin))))
 203
 204     ((#:while test code #f)
 205      (let ((lp (gensym "lp")))
 206        `(let ,lp ()
 207           (if test
 208               (begin
 209                 ,(exp vs code)
 210                 (,lp))))))
 211
 212     ((#:classdef (#:identifier class . _) parents defs)
 213      (let ()
 214        (define (filt l)
 215          (reverse
 216           (fold (lambda (x s)
 217                   (match x
 218                     (((or 'fast 'functional)) s)
 219                     (x (cons x s))))
 220                 '() l)))
 221        (define (is-functional l)
 222          (fold (lambda (x pred)
 223                  (if pred
 224                      pred
 225                      (match x
 226                        (('functional) #t)
 227                        (_ #f)))) #f l))
 228        (define (is-fast l)
 229          (fold (lambda (x pred)
 230                  (if pred
 231                      pred
 232                      (match x
 233                        (('fast) #t)
 234                        (_ #f)))) #f l))
 235
 236
 237        (let* ((class   (string->symbol class))
 238               (parents (match parents
 239                          (#f
 240                           '())
 241                          ((#:arglist args . _)
 242                           (map (g vs exp) args))))
 243               (is-func (is-functional parents))
 244               (is-fast (is-fast       parents))
 245               (kind    (if is-func
 246                            (if is-fast
 247                                'mk-pf-class
 248                                'mk-pyf-class)
 249                            (if is-fast
 250                                'mk-p-class
 251                                'mk-py-class)))
 252               (parents (filt parents)))
 253          `(define ,class (,(O 'wrap)
 254                           (,(O kind)
 255                            ,class
 256                            ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
 257                           #:const
 258                           ,(match (exp vs defs)
 259                              ((begin . l)
 260                               l)
 261                              (l l))
 262                           #:dynamic
 263                           ()))))))
 264
 265
 266
 267     ((#:for e in code . #f)
 268      (=> next)
 269      (match e
 270        (((#:power (#:identifier x . _) () . #f))
 271         (match in
 272           (((#:test power . _))
 273            (match power
 274              ((#:power
 275                (#:identifier "range" . _)
 276                ((#:arglist arglist . _))
 277                . _)
 278               (match arglist
 279                 ((arg)
 280                  (let ((v   (gensym "v"))
 281                        (x   (string->symbol x))
 282                        (lp  (gensym "lp")))
 283                    `(let ((,v ,(exp vs arg)))
 284                       (let ,lp ((,x 0))
 285                            (if (< ,x ,v)
 286                                (begin
 287                                  ,(exp vs code)
 288                                  (,lp (+ ,x 1))))))))
 289                 ((arg1 arg2)
 290                  (let ((v1   (gensym "va"))
 291                        (v2   (gensym "vb"))
 292                        (lp  (gensym "lp")))
 293                    `(let ((,v1 ,(exp vs arg1))
 294                           (,v2 ,(exp vs arg2)))
 295                       (let ,lp ((,x ,v1))
 296                            (if (< ,x ,v2)
 297                                (begin
 298                                  ,(exp vs code)
 299                                  (,lp (+ ,x 1))))))))
 300                 ((arg1 arg2 arg3)
 301                  (let ((v1   (gensym "va"))
 302                        (v2   (gensym "vb"))
 303                        (st   (gensym "vs"))
 304                        (lp  (gensym "lp")))
 305                    `(let ((,v1 ,(exp vs arg1))
 306                           (,st ,(exp vs arg2))
 307                           (,v2 ,(exp vs arg3)))
 308                       (if (> st 0)
 309                           (let ,lp ((,x ,v1))
 310                                (if (< ,x ,v2)
 311                                    (begin
 312                                      ,(exp vs code)
 313                                      (,lp (+ ,x ,st)))))
 314                           (if (< st 0)
 315                               (let ,lp ((,x ,v1))
 316                                    (if (> ,x ,v2)
 317                                        (begin
 318                                          ,(exp vs code)
 319                                          (,lp (+ ,x ,st)))))
 320                               (error "range with step 0 not allowed"))))))
 321                 (_ (next))))
 322              (_ (next))))
 323           (_ (next))))
 324        (_ (next))))
 325
 326     ((#:while test code else)
 327      (let ((lp (gensym "lp")))
 328        `(let ,lp ()
 329           (if test
 330               (begin
 331                 ,(exp vs code)
 332                 (,lp))
 333               ,(exp vs else)))))
 334
 335     ((#:try x exc else fin)
 336      (define (f x)
 337        (match else
 338          ((#f x)
 339           `(catch #t
 340              (lambda () ,x)
 341              (lambda ,(gensym "x") ,(exp vs x))))))
 342
 343      `(dynamic-wind
 344         (lambda () #f)
 345         (lambda ()
 346           ,(f
 347             (let lp ((code (exp vs x)) (l (reverse exc)))
 348               (match l
 349                 ((((e) c) . l)
 350                  (lp `(catch ,(exp vs e)
 351                         (lambda () ,code)
 352                         (lambda ,(gensym "x")
 353                           ,(exp vs c))) l))
 354                 ((((e . as) c) . l)
 355                  (lp `(let ((,as ,(exp vs e)))
 356                         (catch ,as
 357                           (lambda () ,code)
 358                           (lambda ,(gensym "x")
 359                             ,(exp vs c)))) l))
 360                 (()
 361                  code))))
 362           (lambda () ,(exp vs fin)))))
 363
 364     ((#:def (#:identifier f . _)
 365             (#:types-args-list
 366              args
 367              #f #f)
 368             #f
 369             code)
 370      (let* ((f  (string->symbol f))
 371             (r  (gensym "return"))
 372             (as (map (lambda (x) (match x
 373                                   ((((#:identifier x . _) . #f) #f)
 374                                    (string->symbol x))))
 375                      args))
 376             (vs (union as vs))
 377             (ns (scope code vs))
 378             (df (defs code '()))
 379             (ls (diff (diff ns vs) df)))
 380
 381        `(define ,f (lambda (,@as)
 382                      (,(C 'with-return) ,r
 383                       (let ,(map (lambda (x) (list x #f)) ls)
 384                         ,(with-fluids ((return r))
 385                            (exp ns code))))))))
 386
 387     ((#:global . _)
 388      '(values))
 389
 390     ((#:lambdef v e)
 391      (list `lambda v (exp vs e)))
 392
 393     ((#:stmt l)
 394      (if (> (length l) 1)
 395          (cons 'values (map (g vs exp) l))
 396          (exp vs (car l))))
 397
 398
 399     ((#:expr-stmt (l) (#:assign))
 400      (exp vs l))
 401
 402     ((#:expr-stmt l (#:assign u))
 403      (cond
 404       ((= (length l) (length u))
 405        (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
 406       ((= (length u) 1)
 407        (let ((vars (map (lambda (x) (gensym "v")) l)))
 408          `(call-with-values (lambda () (exp vs (car u)))
 409             (lambda vars
 410               ,@(map make-set l vars)))))))
 411
 412
 413
 414     ((#:return . x)
 415      `(,(fluid-ref return) ,@(map (g vs exp) x)))
 416
 417     ((#:expr-stmt
 418       ((#:test (#:power (#:identifier v . _) () . #f) #f))
 419       (#:assign (l)))
 420      (let ((s (string->symbol v)))
 421        `(set! ,s ,(exp vs l))))
 422
 423     ((#:comp x #f)
 424      (exp vs x))
 425
 426     ((#:comp x (op . y))
 427      (define (tr op x y)
 428        (match op
 429          ((or "<" ">" "<=" ">=")
 430           (list (G (string->symbol op)) x y))
 431          ("!="    (list 'not (list 'equal? x y)))
 432          ("=="    (list 'equal? x y))
 433          ("is"    (list 'eq? x y))
 434          ("isnot" (list 'not (list 'eq? x y)))
 435          ("in"    (list 'member x y))
 436          ("notin" (list 'not (list 'member x y)))
 437          ("<>"    (list 'not (list 'equal? x y)))))
 438      (tr op (exp vs x) (exp vs y)))
 439
 440     (x x)))
 441
 442 (define (comp x)
 443   (define start
 444     (match (pr 'start x)
 445       (((#:stmt
 446          ((#:expr-stmt
 447            ((#:test
 448              (#:power
 449               (#:identifier "module" . _)
 450               ((#:arglist arglist #f #f))
 451               . #f) #f))
 452            (#:assign)))) . _)
 453        (let ()
 454          (define args
 455            (map (lambda (x)
 456                   (exp '() x))
 457                 arglist))
 458
 459          `((,(G 'define-module) (language python module ,@args)))))
 460       (x '())))
 461
 462   (if (pair? start)
 463       (set! x (cdr x)))
 464
 465   (let ((globs (get-globals x)))
 466     `(begin
 467        ,@start
 468        ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
 469        ,@(map (g globs exp) x))))
 470
 471 (define-syntax with-return
 472   (lambda (x)
 473     (define (analyze ret x)
 474       (syntax-case x (begin let if)
 475         ((begin a ... b)
 476          #`(begin a ... #,(analyze ret #'b)))
 477         ((let lp v a ... b)
 478          (symbol? (syntax->datum #'lp))
 479          #`(let lp v a ... #,(analyze ret #'b)))
 480         ((let v a ... b)
 481          #`(let v a ... #,(analyze ret #'b)))
 482         ((if p a b)
 483          #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
 484         ((if p a)
 485          #`(if p #,(analyze ret #'a)))
 486         ((return a b ...)
 487          (equal? (syntax->datum #'return) (syntax->datum ret))
 488          (if (eq? #'(b ...) '())
 489              #'a
 490              #`(values a b ...)))
 491         (x #'x)))
 492
 493     (define (is-ec ret x tail)
 494       (syntax-case x (begin let)
 495         ((begin a ... b)
 496          #t
 497          (or
 498           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 499           (is-ec ret #'b tail)))
 500
 501         ((let lp ((y x) ...) a ... b)
 502          (symbol? (syntax->datum #'lp))
 503          (or
 504           (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
 505           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 506           (is-ec ret #'b tail)))
 507
 508         ((let ((y x) ...) a ... b)
 509          #t
 510          (or
 511           (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
 512           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 513           (is-ec ret #'b tail)))
 514
 515         ((if p a b)
 516          #t
 517          (or
 518           (is-ec ret #'p #f)
 519           (is-ec ret #'a tail)
 520           (is-ec ret #'b tail)))
 521         ((if p a)
 522          #t
 523          (or
 524           (is-ec ret #'p #f)
 525           (is-ec ret #'a tail)))
 526
 527         ((return a b ...)
 528          (equal? (syntax->datum #'return) (syntax->datum ret))
 529          (not tail))
 530
 531         ((a ...)
 532          #t
 533          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
 534
 535         (x
 536          #t
 537          #f)))
 538
 539     (syntax-case x ()
 540       ((_ ret  l)
 541        (let ((code (analyze #'ret #'l)))
 542          (if (is-ec #'ret #'l #t)
 543              #`(let/ec ret #,code)
 544              code))))))
 545
 546 (define-syntax call
 547   (syntax-rules ()
 548     ((_ (f) . l) (f . l))))
 549
 550 (define-syntax-rule (var v)
 551   (if (defined? 'v)
 552       (values)
 553       (define! 'v #f)))
 554