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 (p  x) (pretty-print (syntax->datum x)) x)
   7 (define (pf x)
   8   (define port (open-file "compile.log" "a"))
   9   (with-output-to-port port
  10     (lambda () (pretty-print (syntax->datum x)) x))
  11   (close port)
  12   x)
  13
  14 (define (C x) `(@@ (language python compile) ,x))
  15 (define (G x) `(@ (guile) ,x))
  16
  17 (define (union as vs)
  18   (let lp ((as as) (vs vs))
  19     (match as
  20       ((x . as)
  21        (if (member x vs)
  22            (lp as vs)
  23            (lp as (cons x vs))))
  24       (()
  25        vs))))
  26
  27 (define (diff as vs)
  28   (let lp ((as as) (rs '()))
  29     (match as
  30       ((x . as)
  31        (if (member x vs)
  32            (lp as rs)
  33            (lp as (cons x rs))))
  34       (()
  35        rs))))
  36
  37 (define (get-globals code)
  38   (let lp ((vs (glob code '())) (rs (scope code '())))
  39     (match vs
  40       ((x . l)
  41        (if (member x rs)
  42            (lp l rs)
  43            (lp l (cons x rs))))
  44       (()
  45        rs))))
  46
  47 (define (glob x vs)
  48   (match x
  49     ((#:global . l)
  50      (let lp ((l l) (vs vs))
  51        (match l
  52          (((#:identifier v) . l)
  53           (let ((s (string->symbol v)))
  54             (if (member s vs)
  55                 (lp l vs)
  56                 (lp l (cons s vs)))))
  57          (()
  58           vs))))
  59     ((x . y)
  60      (glob y (glob x vs)))
  61     (x vs)))
  62
  63 (define (scope x vs)
  64   (match x
  65     ((#:def  (#:identifier f) . _)
  66      (union (list (string->symbol f)) vs))
  67     ((#:lambdef . _)
  68      vs)
  69     ((#:class . _)
  70      vs)
  71     ((#:global . _)
  72      vs)
  73     ((#:identifier v)
  74      (let ((s (string->symbol v)))
  75        (if (member s vs)
  76            vs
  77            (cons s vs))))
  78     ((x . y)
  79      (scope y (scope x vs)))
  80     (_ vs)))
  81
  82 (define (defs x vs)
  83   (match x
  84     ((#:def  (#:identifier f) . _)
  85      (union (list (string->symbol f)) vs))
  86     ((#:lambdef . _)
  87      vs)
  88     ((#:class . _)
  89      vs)
  90     ((#:global . _)
  91      vs)
  92     ((x . y)
  93      (defs y (defs x vs)))
  94     (_ vs)))
  95
  96 (define (g vs e)
  97   (lambda (x) (e vs x)))
  98
  99 (define return (make-fluid 'error-return))
 100
 101 (define (exp vs x)
 102   (match (p x)
 103     ((#:power (#:identifier x) () . #f)
 104      (string->symbol x))
 105
 106     ((#:power x () . #f)
 107      x)
 108
 109     (((and x (or #:+ #:- #:* #:/)) . l)
 110      (cons (keyword->symbol x) (map (g vs exp) l)))
 111
 112     ((#:u~ x)
 113      (list 'lognot (exp vs x)))
 114
 115     ((#:band . l)
 116      (cons 'logand (map (g vs exp) l)))
 117
 118     ((#:bxor . l)
 119      (cons 'logxor (map (g vs exp) l)))
 120
 121     ((#:bor . l)
 122      (cons 'logior (map (g vs exp) l)))
 123
 124     ((#:not x)
 125      (list 'not (exp vs x)))
 126
 127     ((#:or . x)
 128      (cons 'or (map (g vs exp) x)))
 129
 130     ((#:and . x)
 131      (cons 'and (map (g vs exp) x)))
 132
 133     ((#:test e1 #f)
 134      (exp vs e1))
 135
 136     ((#:test e1 e2 e3)
 137      (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
 138
 139     ((#:suite . l) (cons 'begin (map (g vs exp) l)))
 140
 141     ((#:try x #f #f fin)
 142      `(dynamic-wind
 143         (lambda () #f)
 144         (lambda () ,(exp vs x))
 145         (lambda () ,(exp vs fin))))
 146
 147     ((#:while test code #f)
 148      (let ((lp (gensym "lp")))
 149        `(let ,lp ()
 150           (if test
 151               (begin
 152                 ,(exp vs code)
 153                 (,lp))))))
 154
 155     ((#:for exp in code #f)
 156      (match (cons exp in)
 157        ((((#:power (#:identifier x) #f . #f)) .
 158          ((#:power (#:identifier 'range) ((arg) #f #f) . #f)))
 159         (let ((v   (gensym "v"))
 160               (lp  (gensym "lp")))
 161           `(let ((,v ,(exp arg)))
 162              (let ,lp ((,x 0))
 163                (if (< ,x ,v)
 164                    (begin
 165                      ,(exp vs code)
 166                      (,lp (+ ,x 1))))))))
 167
 168        ((((#:power (#:identifier x) #f . #f)) .
 169          ((#:power (#:identifier 'range) ((arg1 arg2) #f #f) . #f)))
 170         (let ((v1   (gensym "va"))
 171               (v2   (gensym "vb"))
 172               (lp  (gensym "lp")))
 173           `(let ((,v1 ,(exp arg1))
 174                  (,v2 ,(exp arg2)))
 175              (let ,lp ((,x ,v1))
 176                   (if (< ,x ,v2)
 177                       (begin
 178                         ,(exp vs code)
 179                         (,lp (+ ,x 1))))))))
 180
 181        ((((#:power (#:identifier x) #f . #f)) .
 182          ((#:power (#:identifier 'range) ((arg1 arg2 arg3) #f #f) . #f)))
 183         (let ((v1   (gensym "va"))
 184               (v2   (gensym "vb"))
 185               (st   (gensym "vs"))
 186               (lp  (gensym "lp")))
 187           `(let ((,v1 ,(exp arg1))
 188                  (,st ,(exp arg2))
 189                  (,v2 ,(exp arg3)))
 190              (let ,lp ((,x ,v1))
 191                (if (< ,x ,v2)
 192                    (begin
 193                      ,(exp vs code)
 194                      (,lp (+ ,x ,st))))))))))
 195
 196
 197     ((#:while test code else)
 198      (let ((lp (gensym "lp")))
 199        `(let ,lp ()
 200           (if test
 201               (begin
 202                 ,(exp vs code)
 203                 (,lp))
 204               ,(exp else)))))
 205
 206     ((#:try x exc else fin)
 207      (define (f x)
 208        (match else
 209          ((#f x)
 210           `(catch #t
 211              (lambda () ,x)
 212              (lambda ,(gensym "x") ,(exp vs x))))))
 213
 214      `(dynamic-wind
 215         (lambda () #f)
 216         (lambda ()
 217           ,(f
 218             (let lp ((code (exp vs x)) (l (reverse exc)))
 219               (match l
 220                 ((((e) c) . l)
 221                  (lp `(catch ,(exp vs e)
 222                         (lambda () ,code)
 223                         (lambda ,(gensym "x")
 224                           ,(exp c))) l))
 225                 ((((e . as) c) . l)
 226                  (lp `(let ((,as ,(exp vs e)))
 227                         (catch ,as
 228                           (lambda () ,code)
 229                           (lambda ,(gensym "x")
 230                             ,(exp vs c))) l)))
 231                 (()
 232                  code))))
 233           (lambda () ,(exp vs fin)))))
 234
 235     ((#:def (#:identifier f)
 236             (#:types-args-list
 237              args
 238              #f)
 239             #f
 240             code)
 241      (let* ((f  (string->symbol f))
 242             (r  (gensym "return"))
 243             (as (map (lambda (x) (match x
 244                                   ((((#:identifier x) . #f) #f)
 245                                    (string->symbol x))))
 246                      args))
 247             (vs (union as vs))
 248             (ns (scope code vs))
 249             (df (defs code '()))
 250             (ls (diff (diff ns vs) df)))
 251
 252        `(define (,f ,@as) (,(C 'with-return) ,r
 253                             (let ,(map (lambda (x) (list x #f)) ls)
 254                               ,(with-fluids ((return r))
 255                                   (exp ns code)))))))
 256
 257     ((#:global . _)
 258      '(values))
 259
 260     ((#:lambdef v e)
 261      (list `lambda v (exp vs e)))
 262
 263     ((#:stmt l)
 264      (if (> (length l) 1)
 265          (cons 'values (map (g vs exp) l))
 266          (exp vs (car l))))
 267
 268
 269     ((#:expr-stmt (l) (#:assign))
 270      (exp vs l))
 271
 272     ((#:return . x)
 273      `(,(fluid-ref return) ,@(map (g vs exp) x)))
 274
 275     ((#:expr-stmt
 276       ((#:test (#:power (#:identifier v) () . #f) #f))
 277       (#:assign (l)))
 278      (let ((s (string->symbol v)))
 279        `(set! ,s ,(exp vs l))))
 280
 281
 282     ((#:comp . l)
 283      (define (tr op x y)
 284        (match op
 285          ((or "<" ">" "<=" ">=")
 286           (list (string->symbol op) x y))
 287          ("!="    (list 'not (list 'equal? x y)))
 288          ("=="    (list 'equal? x y))
 289          ("is"    (list 'eq? x y))
 290          ("isnot" (list 'not (list 'eq? x y)))
 291          ("in"    (list 'member x y))
 292          ("notin" (list 'not (list 'member x y)))
 293          ("<>"    (list 'not (list 'equal? x y)))))
 294      (let lp ((l l))
 295        (match l
 296          (()
 297           '())
 298          ((x op y)
 299           (tr op (exp vs x) (exp vs y)))
 300          ((x op . l)
 301           (tr op (exp vs x) (lp vs l))))))))
 302
 303 (define (comp x)
 304   (let ((globs (get-globals x)))
 305     `(begin
 306        ,@(map (lambda (s) `(define ,s (values))) globs)
 307        ,@(map (g globs exp) x))))
 308
 309 (define-syntax with-return
 310   (lambda (x)
 311     (define (analyze ret x)
 312       (syntax-case x (begin let if)
 313         ((begin a ... b)
 314          #`(begin a ... #,(analyze ret #'b)))
 315         ((let lp v a ... b)
 316          (symbol? (syntax->datum #'lp))
 317          #`(let lp v a ... #,(analyze ret #'b)))
 318         ((let v a ... b)
 319          #`(let v a ... #,(analyze ret #'b)))
 320         ((if p a b)
 321          #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
 322         ((if p a)
 323          #`(if p #,(analyze ret #'a)))
 324         ((return a b ...)
 325          (equal? (syntax->datum #'return) (syntax->datum ret))
 326          (if (eq? #'(b ...) '())
 327              #'a
 328              #`(values a b ...)))
 329         (x #'x)))
 330
 331     (define (is-ec ret x tail)
 332       (syntax-case x (begin let)
 333         ((begin a ... b)
 334          #t
 335          (or
 336           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 337           (is-ec ret #'b tail)))
 338
 339         ((let lp ((y x) ...) a ... b)
 340          (symbol? (syntax->datum #'lp))
 341          (or
 342           (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
 343           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 344           (is-ec ret #'b tail)))
 345
 346         ((let ((y x) ...) a ... b)
 347          #t
 348          (or
 349           (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
 350           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
 351           (is-ec ret #'b tail)))
 352
 353         ((if p a b)
 354          #t
 355          (or
 356           (is-ec ret #'p #f)
 357           (is-ec ret #'a tail)
 358           (is-ec ret #'b tail)))
 359         ((if p a)
 360          #t
 361          (or
 362           (is-ec ret #'p #f)
 363           (is-ec ret #'a tail)))
 364
 365         ((return a b ...)
 366          (equal? (syntax->datum #'return) (syntax->datum ret))
 367          (not tail))
 368
 369         ((a ...)
 370          #t
 371          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
 372
 373         (x
 374          #t
 375          #f)))
 376
 377     (syntax-case x ()
 378       ((_ ret  l)
 379        (pf (let ((code (analyze #'ret #'l)))
 380             (if (is-ec #'ret #'l #t)
 381                 #`(let/ec ret #,code)
 382                 code)))))))
 383
 384
 385